SUBROUTINE HARMEA(X,N,IWRITE,XHARM,IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C SAMPLE HARMONIC MEAN, XHARM, C OF THE DATA IN THE INPUT VECTOR X. C THE SAMPLE XHARM = SUM(N/(1/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--XHARM = THE SINGLE PRECISION VALUE OF THE C COMPUTED SAMPLE HARMONIC MEAN. C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE C SAMPLE HARMONIC 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 WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--99.3 C ORIGINAL VERSION--MARCH 1999. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DOUBLE PRECISION DN DOUBLE PRECISION DX DOUBLE PRECISION DSUM C DIMENSION X(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='GEOM' ISUBN2='EA ' C IERROR='NO' C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF HARMEA--') 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 HARMONIC 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 HARMEA--') 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 HARMEA 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 XHARM=X(1) GOTO9000 129 CONTINUE C 190 CONTINUE C C *********************************** C ** STEP 2-- ** C ** COMPUTE THE HARMONIC MEAN. ** C *********************************** C DN=N DSUM=0.0D0 DO200I=1,N DX=DBLE(X(I)) IF(DX.NE.0.0D0)DSUM=DSUM+1.0D0/DX 200 CONTINUE DSUM=DN/DSUM XHARM=REAL(DSUM) C C ******************************* C ** STEP 3-- ** C ** WRITE OUT A LINE ** C ** OF SUMMARY INFORMATION. ** C ******************************* C IF(IFEEDB.EQ.'OFF')GOTO890 IF(IWRITE.EQ.'OFF')GOTO890 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,811)N,XHARM 811 FORMAT('THE HARMONIC 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 HARMEA--') 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)XHARM 9015 FORMAT('XHARM = ',E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE HAZARD(X,TAG,NX,IWRITE,Y,IBUGA3,IERROR) C C PURPOSE--COMPUTE HAZARD OF AN ARRAY C THE TAG VARIABLE IDENTIFIES CENSORED DATA C (1 = FAILURE TIME, 0 = CENSORED) C NOTE--IT IS PERMISSIBLE TO HAVE THE OUTPUT VECTOR Y(.) C BEING IDENTICAL TO THE INPUT VECTOR X(.). 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--98/5 C ORIGINAL VERSION--MAY 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 DIMENSION X(*) DIMENSION Y(*) DIMENSION TAG(*) 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='HAZA' ISUBN2='RD ' 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 HAZARD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)NX 53 FORMAT('NX = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,NX WRITE(ICOUT,56)I,X(I),TAG(I) 56 FORMAT('I,X(I), TAG(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ************************************** C ** COMPUTE CUMULATIVE HAZARD ** C ************************************** C CALL SORTC(X,TAG,NX,Y,TAG) CALL RANK(Y,NX,IWRITE,Y,IBUGA3,IERROR) IF(IERROR.EQ.'YES')GOTO9000 AFACT=REAL(NX+1) DO100I=1,NX IF(ABS(TAG(I)).GE.0.5)THEN Y(I)=100.0/(AFACT - Y(I)) ELSE Y(I)=0.0 ENDIF 100 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE C IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF HAZARD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)NX 9013 FORMAT('NX = ',I8) CALL DPWRST('XXX','BUG ') DO9015I=1,NX WRITE(ICOUT,9016)I,X(I),Y(I) 9016 FORMAT('I,X(I),Y(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE HBOCDF(X,ALPHA,XI,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE HYPERBOLIC C DISTRIBUTION WITH SHAPE PARAMETERS ALPHA AND XI. 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 --XI = THE SECOND SHAPE PARAMETER C OUTPUT ARGUMENTS--CDF = THE DOUBLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE HYPERBOLIC C DISTRIBUTION WITH SHAPE PARAMETERS ALPHA AND XI. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--DQAGI. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND BALAKRISNAN, "CONTINUOUS C UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION, C WILEY, 1994, PP. 60. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.9 C ORIGINAL VERSION--SEPTEMBER 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C INTEGER LIMIT INTEGER LENW PARAMETER(LIMIT=100) PARAMETER(LENW=4*LIMIT) INTEGER INF INTEGER NEVAL INTEGER IER INTEGER LAST INTEGER IWORK(LIMIT) DOUBLE PRECISION ALPHA DOUBLE PRECISION XI DOUBLE PRECISION EPSABS DOUBLE PRECISION EPSREL DOUBLE PRECISION RESULT DOUBLE PRECISION DCDF DOUBLE PRECISION CDF DOUBLE PRECISION X DOUBLE PRECISION DX DOUBLE PRECISION DB DOUBLE PRECISION DC DOUBLE PRECISION DM DOUBLE PRECISION ABSERR DOUBLE PRECISION WORK(LENW) C DOUBLE PRECISION HBOFUN EXTERNAL HBOFUN C DOUBLE PRECISION DALPHA DOUBLE PRECISION DXI COMMON/HBOCOM/DALPHA,DXI 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 FIRST SHAPE PARAMETER (ALPHA)', 1 ' IN HBOCDF ROUTINE IS NON-POSITIVE.') IF(XI.LE.0.0D0)THEN WRITE(ICOUT,8) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)XI CALL DPWRST('XXX','WRIT') CDF=0.0D0 GOTO9000 ENDIF 8 FORMAT('***** ERROR: VALUE OF SECOND SHAPE PARAMETER (XI)', 1 ' IN HBOCDF ROUTINE IS NON-POSITIVE.') 48 FORMAT(' VALUE OF ARGUMENT IS: ',G15.7) C C ************************************ C ** STEP 1-- ** C ** COMPUTE THE DENSITY FUNCTION ** C ************************************ C INF=-1 EPSABS=0.0D0 EPSREL=1.0D-7 IER=0 DCDF=0.0D0 IFLAG=0 IF(DX.LT.0.0D0)THEN IFLAG=1 INF=1 ENDIF C DATEMP=0.0D0 DXI=XI C CALL DQAGI(HBOFUN,DX,INF,EPSABS,EPSREL,DCDF,ABSERR,NEVAL, 1 IER,LIMIT,LENW,LAST,IWORK,WORK) C IF(IFLAG.EQ.1)THEN CDF=1.0D0 - DCDF ELSE CDF=DCDF ENDIF C IF(IER.EQ.1)THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR FROM HBOCDF--') 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 HBOCDF--') 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 HBOCDF--') 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 HBOCDF--') 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 HBOCDF--') 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 HBOCDF--') 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 HBOFUN(DX) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE HYPERBOLIC C DISTRIBUTION WITH SHAPE PARAMETERS ALPHA AND XI. C THIS DISTRIBUTION IS DEFINED FOR ALL REAL X C AND HAS THE PROBABILITY DENSITY FUNCTION C C f(X;ALPHA,XI) = (1/{2*SQRT(1+ALPHA**2)*K(1)(XI)})* C EXP{-XI*[SQRT(1+ALPHA**2)*SQRT(1+X**2)-ALPHA*X]} C XI > 0 C WHERE C K(N,X) IS THE MODIFIED BESSEL FUNCTION OF THE C SECOND KIND AND ORDER N. C C THE HBOPDF ROUTINE IS CALLED TO COMPUTE THE C PROBABILITY DENSITY. DEFINE AS FUNCTION TO BE USED FOR C INTEGRATION CODE CALLED BY HBOCDF. 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--HBOFUN = THE DOUBLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY C FUNCTION VALUE PDF FOR THE HYPERBOLIC C DISTRIBUTION WITH SHAPE PARAMETERS ALPHA AND XI. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--HBOPDF. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. 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. 60. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.9 C ORIGINAL VERSION--SEPTEMBER 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DTERM C DOUBLE PRECISION DX DOUBLE PRECISION DALPHA DOUBLE PRECISION DXI COMMON/HBOCOM/DALPHA,DXI 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 HBOPDF(DX,DALPHA,DXI,DTERM) HBOFUN=DTERM C 9000 CONTINUE RETURN END SUBROUTINE HBOPDF(X,ALPHA,XI,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE HYPERBOLIC DISTRIBUTION WITH C SHAPE PARAMETERS ALPHA AND XI. THIS DISTRIBUTION IS C DEFINED FOR ALL REAL X AND HAS THE PROBABILITY DENSITY C FUNCTION C C f(X;ALPHA,XI) = (1/{2*SQRT(1+ALPHA**2)*K(1)(XI)})* C EXP{-XI*[SQRT(1+ALPHA**2)*SQRT(1+X**2)-ALPHA*X]} C XI > 0 C WHERE C K(N,X) IS THE MODIFIED BESSEL FUNCTION OF THE C SECOND KIND AND ORDER N. 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 --ALPHA = THE FIRST SHAPE PARAMETER C --XI = THE SECOND SHAPE PARAMETER, C XI SHOULD BE POSITIVE. 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 HYPERBOLIC DISTRIBUTION C WITH SHAPE PARAMETERS ALPHA AND XI. 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. 60. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.9 C ORIGINAL VERSION--SEPTEMBER 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION X DOUBLE PRECISION ALPHA DOUBLE PRECISION XI DOUBLE PRECISION PDF DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DBESK1 EXTERNAL DBESK1 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 THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C IF(ALPHA.LE.0.0D0)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)ALPHA CALL DPWRST('XXX','WRIT') PDF=0.0D0 GOTO9000 ENDIF 5 FORMAT('***** ERROR: VALUE OF FIRST SHAPE PARAMETER (ALPHA)', 1 ' IN HBOPDF ROUTINE IS NON-POSITIVE.') IF(XI.LE.0.0D0)THEN WRITE(ICOUT,8) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)XI CALL DPWRST('XXX','WRIT') PDF=0.0D0 GOTO9000 ENDIF 8 FORMAT('***** ERROR: VALUE OF SECOND SHAPE PARAMETER (XI)', 1 ' IN HBOPDF 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 DTERM1=DLOG(2.0D0) + 0.5D0*DLOG(1.0D0+ALPHA**2) + 1 DLOG(DBESK1(XI)) DTERM2=-XI*(DSQRT((1.0D0+ALPHA**2)*(1.0D0+X**2)) - ALPHA*X) DTERM3=-DTERM1 + DTERM2 PDF=DEXP(DTERM3) C 9000 CONTINUE RETURN END SUBROUTINE HCONS(Y,X,XIDTEM,TEMP,TEMP2,N,IWRITE,YOUT,NUMSET, 1ISUBRO,IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE H CONSISTENCY STATISTIC C OF THE DATA IN THE INPUT VECTOR Y WITH LAB ID C VECTOR X. THE H CONSISTENCY STATISTIC IS DEFINED AS: C C H(i) = D(i)/s(xbar(i)) C C WITH C C xbar(i) = MEAN OF GROUP I C s(xbar(i)) = STANDARD DEVIATION OF THE GROUP C MEANS C D(i) = xbar(i) - xbar C xbar = OVERALL MEAN C C INPUT ARGUMENTS--Y = THE SINGLE PRECISION VECTOR OF C (UNSORTED OR SORTED) OBSERVATIONS. C --X = THE SINGLE PRECISION VECTOR OF C GROUP ID's. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR Y. C OUTPUT ARGUMENTS--YOUT = THE SINGLE PRECISION VECTOR OF THE C COMPUTED SAMPLE H CONSISTENCY C STATISTIC. C --NUMSET = THE INTEGER VALUE CONTAINING THE C NUMBER OF GROUPS. C OUTPUT--THE COMPUTED SINGLE PRECISION VECTOR OF THE C SAMPLE H CONSISTENCY STATISTIC. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--SORT, DISTIN, SD. C FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--"Standard Practice for Conducting an C Interlaboratory Study to Determine the Precision C of a Test Method", ASTM International, C 100 Barr Harbor Drive, PO BOX C700, C West Conshohoceken, PA 19428-2959, USA. C This document is in support of C ASTM Standard E 691 - 99. 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 LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2005.2 C ORIGINAL VERSION--FEBRUARY 2005. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DIMENSION Y(*) DIMENSION X(*) DIMENSION YOUT(*) DIMENSION XIDTEM(*) DIMENSION TEMP(*) DIMENSION TEMP2(*) 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='HCON' ISUBN2='S ' C IERROR='NO' C IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CONS')THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF HCONS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3,ISUBRO,N 52 FORMAT('IBUGA3,ISUBRO,N = ',A4,1X,A4,1X,I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,Y(I),X(I) 56 FORMAT('I,Y(I),X(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE ENDIF C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C AN=N C IF(N.LE.1)THEN IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN COMPUTING H CONSISTENCY STATISTIC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,112) 112 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS IN THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,114) 114 FORMAT(' VARIABLES FOR WHICH THE H CONSISTENCY ', 1 'STATISTIC') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,115) 115 FORMAT(' IS TO BE COMPUTED MUST BE 2 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 = ',I8,'.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF C C **************************************************** C ** STEP 2-- ** C ** COMPUTE THE H CONSISTENCY STATISTIC ** C **************************************************** C IWRITE='OFF' CALL DISTIN(X,N,IWRITE,XIDTEM,NUMSET,IBUGA3,IERROR) CALL SORT(XIDTEM,NUMSET,XIDTEM) CALL MEAN(Y,N,IWRITE,XBAR,IBUGA3,IERROR) C IF(NUMSET.LT.1)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,192) 192 FORMAT(' NUMBER OF LABS NUMSET < 1') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF C AN=N ANUMSE=NUMSET C J=0 DO1110ISET1=1,NUMSET K=0 DO1130I=1,N IF(XIDTEM(ISET1).EQ.X(I))THEN K=K+1 TEMP(K)=Y(I) ENDIF 1130 CONTINUE NTEMP=K CALL MEAN(TEMP,NTEMP,IWRITE,XBARI,IBUGA3,IERROR) TEMP2(ISET1)=XBARI YOUT(ISET1)=XBARI - XBAR IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CONS')THEN WRITE(ICOUT,1131)ISET1,XBARI 1131 FORMAT('ISET1,XBARI = ',I8,G15.7) CALL DPWRST('XXX','BUG ') ENDIF 1110 CONTINUE C CALL SD(TEMP2,NUMSET,IWRITE,SDBARI,IBUGA3,IERROR) DO1150I=1,NUMSET YOUT(I)=YOUT(I)/SDBARI 1150 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CONS')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF HCONS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,ISUBRO,IERROR 9012 FORMAT('IBUGA3,ISUBRO,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N,NUMSET,XBAR 9013 FORMAT('N,NUMSET,XBAR = ',I8,1X,I8,1X,G15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)SDBARI 9015 FORMAT('SDBARI = ',E15.7) CALL DPWRST('XXX','BUG ') DO9018I=1,NUMSET WRITE(ICOUT,9019)I,TEMP2(I),YOUT(I) 9019 FORMAT('I,TEMP2(I),YOUT(I) = ',I8,2G15.7) CALL DPWRST('XXX','BUG ') 9018 CONTINUE ENDIF C RETURN END SUBROUTINE HCONS2(Y,X1,X2,XIDTEM,XIDTE2,TEMP,TEMP2,N,IWRITE, 1YOUT,TAG,NOUT, 1ISUBRO,IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE H CONSISTENCY STATISTIC C OF THE DATA IN THE INPUT VECTOR Y WITH LAB ID C VECTOR X. THE H CONSISTENCY STATISTIC IS DEFINED AS: C C H(i) = D(i)/s(xbar(i)) C C WITH C C xbar(i) = MEAN OF GROUP I C s(xbar(i)) = STANDARD DEVIATION OF THE GROUP C MEANS C D(i) = xbar(i) - xbar C xbar = OVERALL MEAN C C THE DISTINCTION BETWEEN HCONS AND HCONS2 IS THAT C HCONS IS USED TO COMPUTE THE H CONSISTENCY STATISTIC C FOR A SINGLE MATERIAL WHILE HCONS2 COMPUTES THE C H CONSISTENCY STATISTIC FOR MULTIPLE MATERIALS. C C INPUT ARGUMENTS--Y = THE SINGLE PRECISION VECTOR OF C (UNSORTED OR SORTED) OBSERVATIONS. C --X1 = THE SINGLE PRECISION VECTOR OF C GROUP ID's. C --X2 = THE SINGLE PRECISION VECTOR OF C MATERIAL ID's. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR Y. C OUTPUT ARGUMENTS--YOUT = THE SINGLE PRECISION VECTOR OF THE C COMPUTED SAMPLE H CONSISTENCY C STATISTIC. C --TAG = THE SINGLE PRECISION VECTOR OF THE C MATERIAL ID's. C --NOUT = THE INTEGER VALUE CONTAINING THE C NUMBER OF VALUES IN YOUT C OUTPUT--THE COMPUTED SINGLE PRECISION VECTOR OF THE C SAMPLE H CONSISTENCY STATISTIC WITH THE CORRESPONDING C MATERIAL ID. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--SORT, DISTIN, SD. C FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--"Standard Practice for Conducting an C Interlaboratory Study to Determine the Precision C of a Test Method", ASTM International, C 100 Barr Harbor Drive, PO BOX C700, C West Conshohoceken, PA 19428-2959, USA. C This document is in support of C ASTM Standard E 691 - 99. 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 LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2005.2 C ORIGINAL VERSION--FEBRUARY 2005. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DIMENSION Y(*) DIMENSION X1(*) DIMENSION X2(*) DIMENSION YOUT(*) DIMENSION TAG(*) DIMENSION XIDTEM(*) DIMENSION XIDTE2(*) DIMENSION TEMP(*) DIMENSION TEMP2(*) 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='HCON' ISUBN2='S2 ' C IERROR='NO' C IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ONS2')THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF HCONS2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3,ISUBRO,N 52 FORMAT('IBUGA3,ISUBRO,N = ',A4,1X,A4,1X,I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,Y(I),X1(I),X2(I) 56 FORMAT('I,Y(I),X1(I),X2(I) = ',I8,3G15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE ENDIF C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C AN=N C IF(N.LE.1)THEN IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN COMPUTING H CONSISTENCY STATISTIC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,112) 112 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS IN THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,114) 114 FORMAT(' VARIABLES FOR WHICH THE H CONSISTENCY ', 1 'STATISTIC') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,115) 115 FORMAT(' IS TO BE COMPUTED MUST BE 2 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 = ',I8,'.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF C C **************************************************** C ** STEP 2-- ** C ** COMPUTE THE H CONSISTENCY STATISTIC ** C **************************************************** C IWRITE='OFF' CALL DISTIN(X1,N,IWRITE,XIDTEM,NUMSE1,IBUGA3,IERROR) CALL SORT(XIDTEM,NUMSE1,XIDTEM) CALL DISTIN(X2,N,IWRITE,XIDTE2,NUMSE2,IBUGA3,IERROR) CALL SORT(XIDTE2,NUMSE2,XIDTEM) C IF(NUMSE1.LT.1)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,192) 192 FORMAT(' NUMBER OF LABS NUMSE1 < 1') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF C IF(NUMSE2.LT.1)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,194) 194 FORMAT(' NUMBER OF MATERIALS NUMSE2 < 1') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF C J=0 NOUT=0 DO1110ISET2=1,NUMSE2 C C STEP 1: COMPUTE OVERALL MEAN FOR CURRENT MATERIAL C K=0 DO1120I=1,N IF(XIDTE2(ISET2).EQ.X2(I))THEN K=K+1 TEMP(K)=Y(I) ENDIF 1120 CONTINUE NTEMP=K CALL MEAN(TEMP,NTEMP,IWRITE,XBAR,IBUGA3,IERROR) C DO1130ISET1=1,NUMSE1 C K=0 DO1140I=1,N IF(XIDTEM(ISET1).EQ.X1(I).AND.XIDTE2(ISET2).EQ.X2(I))THEN K=K+1 TEMP(K)=Y(I) ENDIF 1140 CONTINUE NTEMP=K C CALL MEAN(TEMP,NTEMP,IWRITE,XBARI,IBUGA3,IERROR) TEMP2(ISET1)=XBARI NOUT=(ISET2-1)*NUMSE1 + ISET1 YOUT(NOUT)=XBARI - XBAR TAG(NOUT)=REAL(ISET2) IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ONS2')THEN WRITE(ICOUT,1141)ISET1,ISET2,XBAR,XBARI 1141 FORMAT('ISET1,ISET2,XBAR,XBARI = ',2I8,2G15.7) CALL DPWRST('XXX','BUG ') ENDIF 1130 CONTINUE C CALL SD(TEMP2,NUMSE1,IWRITE,SDBARI,IBUGA3,IERROR) DO1150I=(ISET2-1)*NUMSE1+1,ISET2*NUMSE1 YOUT(I)=YOUT(I)/SDBARI 1150 CONTINUE C 1110 CONTINUE NOUT=NUMSE1*NUMSE2 C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ONS2')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF HCONS2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,ISUBRO,IERROR 9012 FORMAT('IBUGA3,ISUBRO,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N,NUMSE1,NUMSE2,XBAR 9013 FORMAT('N,NUMSE1,NUMSE2,XBAR = ',I8,1X,I8,1X,I8,1X,G15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)SDBARI 9015 FORMAT('SDBARI = ',G15.7) CALL DPWRST('XXX','BUG ') DO9018I=1,NOUT WRITE(ICOUT,9019)I,TAG(I),YOUT(I) 9019 FORMAT('I,TAG(I),YOUT(I) = ',I8,2G15.7) CALL DPWRST('XXX','BUG ') 9018 CONTINUE ENDIF C RETURN END SUBROUTINE HEADS(Y,X,TAG,N, 1DIST,DTAG, 1HEADS2,NTRIAL,AVEDEL,SDAVED,IBUGG3,ISUBRO,IERROR) C C PURPOSE--DETERMINE NUMBER OF "HEADS" IN BLOCK PLOT C WRITTEN BY--JAMES J. FILLIBEN C NATIONAL INSTITUTE OF STANDARDS & TECHNOLOGY C GAITHERSBURG, MARYLAND 20899 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 ORIGINAL VERSION--MAY 1992. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IBUGG3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C CHARACTER*4 IWRITE C C--------------------------------------------------------------------- C DIMENSION Y(*) DIMENSION X(*) DIMENSION TAG(*) DIMENSION DIST(*) DIMENSION DTAG(*) C DIMENSION TAGMAX(1000) DIMENSION TAGMIN(1000) DIMENSION DEL(1000) C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCOZZ.INC' EQUIVALENCE (GARBAG(IGARB7),TAGMAX(1)) EQUIVALENCE (GARBAG(IGARB8),TAGMIN(1)) EQUIVALENCE (GARBAG(IGARB9),DEL(1)) 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 IERROR='NO' C IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'EADS')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,70) 70 FORMAT('AT THE BEGINNING OF HEADS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,71)N 71 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') DO75I=1,N WRITE(ICOUT,76)I,Y(I),X(I),TAG(I) 76 FORMAT('I,Y(I),X(I),TAG(I) = ',I8,3F15.7) CALL DPWRST('XXX','BUG ') 75 CONTINUE 90 CONTINUE C C ************************************************** C ** STEP 1-- ** C ** FORM A VECTOR (TAXMAX(.)) ** C ** WHICH WILL CONTAIN THE TAGS ** C ** OF THE LARGEST ITEM IN EACH BLOCK. ** C ** THE NUMBER OF ITEMS IN TAGMAX(.) ** C ** WILL EQUAL THE NUMBER OF DISTINCT X VALUES. ** C ************************************************** C CALL DISTIN(X,N,'OFF ',DIST,NTRIAL,IBUGG3,IERROR) C DO1100ID=1,NTRIAL C YIMAX=CPUMIN DO1200I=1,N IF(X(I).EQ.DIST(ID))THEN IF(Y(I).GT.YIMAX)THEN YIMAX=Y(I) TAGMAX(ID)=TAG(I) ENDIF ENDIF 1200 CONTINUE C YIMIN=CPUMAX DO1300I=1,N IF(X(I).EQ.DIST(ID))THEN IF(Y(I).LT.YIMIN)THEN YIMIN=Y(I) TAGMIN(ID)=TAG(I) ENDIF ENDIF 1300 CONTINUE C IF(TAGMAX(ID).EQ.TAGMAX(1))DEL(ID)=YIMAX-YIMIN IF(TAGMAX(ID).NE.TAGMAX(1))DEL(ID)=(-(YIMAX-YIMIN)) C 1100 CONTINUE C C ************************************************** C ** STEP 2-- ** C ** SCAN THE TAGMAX(.) VECTOR. ** C ** DETERMINE THE MOST FREQUENT TAG IN TAXMAX(.). ** C ** OUTPUT THAT MAX FREQUENCY (IN HEADS2). ** C ************************************************** C CALL DISTIN(TAGMAX,NTRIAL,'OFF ',DTAG,NDTAG,IBUGG3,IERROR) C JMAX=(-999) DO2100IDTAG=1,NDTAG J=0 DO2200I=1,NTRIAL IF(TAGMAX(I).EQ.DTAG(IDTAG))J=J+1 2200 CONTINUE IF(J.GT.JMAX)JMAX=J 2100 CONTINUE HEADS2=JMAX C C ***************************************************** C ** STEP 3-- ** C ** COMPUTE THE AVERAGE DIFFERENCE (= EST. EFFECT) ** C ** IN THE RESPONSE ** C ** BETWEEN THE MAX AND THE MIN ** C ***************************************************** C IWRITE='OFF' CALL MEAN(DEL,NTRIAL,IWRITE,AVEDEL,IBUGG3,IERROR) CALL SDMEAN(DEL,NTRIAL,IWRITE,SDAVED,IBUGG3,IERROR) C C ****************** C ** STEP 90-- ** C ** EXIT ** C ****************** C 9000 CONTINUE IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'EADS')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('AT THE END OF HEADS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9021)N 9021 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') DO9022I=1,N WRITE(ICOUT,9023)I,Y(I),X(I),TAG(I) 9023 FORMAT('I,Y(I),X(I),TAG(I) = ',I8,3F15.7) CALL DPWRST('XXX','BUG ') 9022 CONTINUE WRITE(ICOUT,9031)HEADS2,NTRIAL 9031 FORMAT('HEADS2,NTRIAL= ',F15.5,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9032)AVEDEL,SDAVED 9032 FORMAT('AVEDEL,SDAVED = ',2F15.5) CALL DPWRST('XXX','BUG ') DO9033I=1,NTRIAL WRITE(ICOUT,9034)I,DIST(I),TAGMAX(I) 9034 FORMAT('I,DIST(I),TAGMAX(I) = ',I8,2F15.7) CALL DPWRST('XXX','BUG ') 9033 CONTINUE WRITE(ICOUT,9041)NDTAG 9041 FORMAT('NDTAG = ',I8) CALL DPWRST('XXX','BUG ') DO9042I=1,NDTAG WRITE(ICOUT,9043)I,DTAG(I) 9043 FORMAT('I,DTAG(I) = ',I8,F15.7) CALL DPWRST('XXX','BUG ') 9042 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE HERMIT(X,AN,HN) C C PURPOSE--THIS SUBROUTINE COMPUTES THE HERMITE POLYNOMIAL OF C 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--HN = THE SINGLE PRECISION VALUE OF THE C HERMITE 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 H(N+1) = 2.0*X*H(N)-2.0*N*H(N-1) C FIRST FEW TERMS ARE FROM TABLE 22.12 OF ABRAMOWITZ C AND STEGUM. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-975-2855 C ORIGINAL VERSION--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 DHN, DHN1, DHN2 C C-----START POINT----------------------------------------------------- C 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 HERMIT 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 HN=1.0 ELSEIF(N.EQ.1)THEN HN=2.0*X ELSEIF(N.EQ.2)THEN HN=4.0*X**2 - 2.0 ELSEIF(N.EQ.3)THEN DHN=8.0D0*DX**3 - 12.0D0*DX HN=REAL(DHN) ELSEIF(N.EQ.4)THEN DHN=16.0D0*DX**4 - 48.0D0*X**2 + 12.0D0 HN=REAL(DHN) ELSEIF(N.EQ.5)THEN DHN=32.0D0*DX**5 - 160.0D0*DX**3 + 120.0D0*DX HN=REAL(DHN) ELSE DHN1=32.0D0*DX**5 - 160.0D0*DX**3 + 120.0D0*DX DHN2=16.0D0*DX**4 - 48.0D0*X**2 + 12.0D0 DO1000I=6,N DN2=DBLE(I)-1.0D0 DHN=2.0D0*DX*DHN1 - 2.0D0*DN2*DHN2 DHN2=DHN1 DHN1=DHN 1000 CONTINUE HN=REAL(DHN) ENDIF C 9999 CONTINUE RETURN END SUBROUTINE HERCDF(X,ALPHA,BETA,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE AT THE SINGLE PRECISION VALUE X C FOR THE HERMITE DISTRIBUTION C WITH SINGLE PRECISION PARAMETERS ALPHA AND BETA. C THIS DISTRIBUTION IS DEFINED FOR ALL C NON-NEGATIVE INTEGERS. C THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION C F(X) = (ALPHA**X*H(BETA)/X!)*PR(X=0) C WITH H(X) DENOTING THE MODIFIED HERMITE POLYNOMIAL: C H(BETA) = SUM[j=0 to INT(N/2)] C [N!*X**(N-2*j)/((N-2(j)!j!2**j)] C THE FIRST FEW TERMS ARE: C PR(X=0) = EXP[-ALPHA*BETA - ALPHA**2/2] C PR(X=1) = ALPHA*BETA*PR(X=0) C PR(X=2) = (ALPHA**2*(BETA**2+1)/2!)*PR(X=0) C PR(X=3) = (ALPHA**3*(BETA**3+3*BETA)/3!)*PR(X=0) C PR(X=4) = (ALPHA**4*(BETA**4+6*BETA**2+3)/4!)*PR(X=0) C PR(X=5) = (ALPHA**5*(BETA**5+10*BETA**3+15*BETA)/5!) C *PR(X=0) C C PR(X=X+1) = (1/(X+1))*ALPHA*BETA*PR(X=x) + C ALPHA**2*PR(X=x-1) C C FOR X <= 20, THE ABOVE RECURRENCE RELATION WILL C BE USED. FOR X > 20, AN AYMPTOTIC FORMULA DUE C TO Y. C. PATEL WILL BE USED. NOTE THAT THE C PATEL ARTICLE USES: C C A = ALPHA*BETA C B = ALPHA**2/2 C C IF YOU WANT TO OBTAIN APPROPRIATE VALUES OF C ALPHA AND BETA GIVEN A AND B, THEN C C ALPHA = SQRT(2*B) C BETA = A/SQRT(2*B) 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 INTEGRAL-VALUED, C AND BETWEEN 0.0 (INCLUSIVELY) C AND N (INCLUSIVELY). C --ALPHA = THE SINGLE PRECISION VALUE C OF THE FIRST SHAPE PARAMETER. C --BETA = THE SINGLE PRECISION VALUE C OF THE SECOND SHAPE PARAMETER. C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION C FUNCTION VALUE CDF FOR THE HERMITE DISTRIBUTION C WITH SHAPE PARAMETERS ALPHA AND BETA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE INTEGRAL-VALUED AND NON-NEGATIVE C --ALPHA AND BETA SHOULD BE POSITIVE. C OTHER DATAPAC SUBROUTINES NEEDED--DLNGAM, DGAMMA. C FORTRAN LIBRARY SUBROUTINES NEEDED--DLOG, DEXP, DSQRT, DCOSH, C DSINH, DLOG10. 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. 357-364. C --Y. C. PATEL, "AN ASYMPTOTIC EXPRESSION FOR C CUMULATIVE SUM OF PROBABILITIES OF THE HERMITE C DISTRIBUTION", COMMUNICATIOS IN STATISTICS- C THEORY AND METHODS, 14, PP. 2233-2241. C --KEMP AND KEMP, "SOME PROPERTIES OF THE HERMITE C DISTRIBUTION", BIOMETRIKA, 1965, 52, 3 AND 4, C P. 381 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 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 DOUBLE PRECISION DX DOUBLE PRECISION DALPHA DOUBLE PRECISION DBETA DOUBLE PRECISION DA DOUBLE PRECISION DB DOUBLE PRECISION DTERM1, DTERM2, DTERM3, DTERM4, DTERM5 DOUBLE PRECISION DCDF DOUBLE PRECISION DPDF DOUBLE PRECISION DCDF0 DOUBLE PRECISION DS DOUBLE PRECISION DMU DOUBLE PRECISION DMUS DOUBLE PRECISION S0 DOUBLE PRECISION K DOUBLE PRECISION ZS DOUBLE PRECISION DNUM DOUBLE PRECISION DDENOM 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 IF(ALPHA.LE.0.0)THEN WRITE(ICOUT,11) 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,12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)BETA 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)THEN WRITE(ICOUT,4) 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 HERCDF SUBROUTINE IS NEGATIVE.') 5 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ', 1'ARGUMENT TO THE HERCDF SUBROUTINE IS NON-INTEGRAL *****') 6 FORMAT(' IT HAS BEEN SET TO ',I8) 11 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1' HERCDF SUBROUTINE IS NON-POSITIVE') 12 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ', 1' HERCDF SUBROUTINE IS NON-POSITIVE') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') C DALPHA=DBLE(ALPHA) DBETA=DBLE(BETA) DB=DALPHA**2/2.0D0 DA=DALPHA*DBETA C C USE EXACT FORMULAS C IF(INTX.LE.25)THEN DCDF0=DEXP(-DALPHA*DBETA - DALPHA**2/2.0D0) DCDF=DCDF0 IF(INTX.EQ.0)GOTO9010 C DCDF=DCDF + DALPHA*DBETA*DCDF0 IF(INTX.EQ.1)GOTO9010 C DTERM1=DALPHA**2*(DBETA*DBETA + 1.0D0) DCDF=DCDF + (DTERM1/2.0D0)*DCDF0 IF(INTX.EQ.2)GOTO9010 C DTERM1=DALPHA**3*(DBETA**3 + 3.0D0*DBETA) DCDF=DCDF + (DTERM1/6.0D0)*DCDF0 IF(INTX.EQ.3)GOTO9010 C DTERM1=DALPHA**4*(DBETA**4 + 6.0D0*DBETA**2 + 3.0D0) DCDF=DCDF + (DTERM1/24.0D0)*DCDF0 IF(INTX.EQ.4)GOTO9010 C DTERM1=DALPHA**5*(DBETA**5 + 10.0D0*DBETA**3 + 15.0D0*DBETA) DCDF=DCDF + (DTERM1/120.0D0)*DCDF0 IF(INTX.EQ.5)GOTO9010 C DTERM1=DALPHA**4*(DBETA**4 + 6.0D0*DBETA**2 + 3.0D0) DTERM1=(DTERM1/24.0D0)*DCDF0 DTERM2=DALPHA**5*(DBETA**5 + 10.0D0*DBETA**3 + 15.0D0*DBETA) DTERM2=(DTERM2/120.0D0)*DCDF0 C DO110I=6,INTX DPDF=(DALPHA*DBETA*DTERM2 + DALPHA*DALPHA*DTERM1)/DBLE(I) DCDF=DCDF + DPDF DTERM1=DTERM2 DTERM2=DPDF 110 CONTINUE GOTO9010 ELSE C C USE ASYMPTOTIC APPROXIMATION C DS=DBLE(INTX) DMU=DA + 2.0D0*DB CALL HERPDF(0.0,ALPHA,BETA,PDF) S0=1.0D0 + 1.0D0/(12.0D0*DS) + 1.0D0/(288.0D0*DS*DS) DMUS=(DMU-DS)/DSQRT(DS+2.0D0*DB) C=DSQRT(2.0D0*DB/DS) K=DSQRT(1.0D0 + 2.0D0*DB/DS) CALL NODPDF(DMUS,ZS) CALL NODCDF(DMUS,DTERM1) C DTERM1=1.0D0-DTERM1 DTERM1=DTERM1*(1.0D0 + 1.0D0/(12.0D0*DS)) C DNUM=(DMUS**2 + (6.0D0*DB/DS) + 2.0D0)*DS DDENOM=3.0D0*(DS+2.0D0*DB)**(3.0D0/2.0D0) DTERM2=(DNUM/DDENOM)*ZS C DNUM=DMUS*(DS**2 + 6.0D0*DB*DS + 48.0D0*DB*DB) DDENOM=12.0D0*(DS+2.0D0*DB)**3 DTERM3=(DNUM/DDENOM)*ZS C DNUM=DMUS**3*(DS + 42.0D0*DB)*DS DDENOM=36.0D0*(DS+2.0D0*DB)**3 DTERM4=(DNUM/DDENOM)*ZS C DNUM=DMUS**5*DS*DS DDENOM=18.0D0*(DS+2.0D0*DB)**3 DTERM5=(DNUM/DDENOM)*ZS C DCDF=DTERM5 + DTERM4 + DTERM3 + DTERM2 + DTERM1 DCDF=(1.0D0/S0)*DCDF GOTO9010 ENDIF C 9010 CONTINUE CDF=REAL(DCDF) C 9999 CONTINUE RETURN END SUBROUTINE HERPDF(X,ALPHA,BETA,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE AT THE SINGLE PRECISION VALUE X C FOR THE HERMITE DISTRIBUTION C WITH SINGLE PRECISION PARAMETERS ALPHA AND BETA. C THIS DISTRIBUTION IS DEFINED FOR ALL C NON-NEGATIVE INTEGERS. C THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION C F(X) = (ALPHA**X*H(BETA)/X!)*PR(X=0) C WITH H(X) DENOTING THE MODIFIED HERMITE POLYNOMIAL: C H(BETA) = SUM[j=0 to INT(N/2)] C [N!*X**(N-2*j)/((N-2(j)!j!2**j)] C THE FIRST FEW TERMS ARE: C PR(X=0) = EXP[-ALPHA*BETA - ALPHA**2/2] C PR(X=1) = ALPHA*BETA*PR(X=0) C PR(X=2) = (ALPHA**2*(BETA**2+1)/2!)*PR(X=0) C PR(X=3) = (ALPHA**3*(BETA**3+3*BETA)/3!)*PR(X=0) C PR(X=4) = (ALPHA**4*(BETA**4+6*BETA**2+3)/4!)*PR(X=0) C PR(X=5) = (ALPHA**5*(BETA**5+10*BETA**3+15*BETA)/5!) C *PR(X=0) C C PR(X=X+1) = (1/(X+1))*ALPHA*BETA*PR(X=x) + C ALPHA**2*PR(X=x-1) C C FOR X <= 10, THE ABOVE RECURRENCE RELATION WILL C BE USED. FOR X > 10, AN AYMPTOTIC FORMULA DUE C TO Y. C. PATEL WILL BE USED. NOTE THAT THE C PATEL ARTICLE USES: C C A = ALPHA*BETA C B = ALPHA**2/2 C C IF YOU WANT TO OBTAIN APPROPRIATE VALUES OF C ALPHA AND BETA GIVEN A AND B, THEN C C ALPHA = SQRT(2*B) C BETA = A/SQRT(2*B) 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 INTEGRAL-VALUED, C AND BETWEEN 0.0 (INCLUSIVELY) C AND N (INCLUSIVELY). C --ALPHA = THE SINGLE PRECISION VALUE C OF THE FIRST SHAPE PARAMETER. C --BETA = THE SINGLE PRECISION VALUE C OF THE SECOND SHAPE PARAMETER. C OUTPUT ARGUMENTS--PDF = THE SINGLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY C FUNCTION VALUE PDF FOR THE HERMITE DISTRIBUTION C WITH SHAPE PARAMETERS ALPHA AND BETA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE INTEGRAL-VALUED AND NON-NEGATIVE C --ALPHA AND BETA SHOULD BE POSITIVE. C OTHER DATAPAC SUBROUTINES NEEDED--DLNGAM, DGAMMA. C FORTRAN LIBRARY SUBROUTINES NEEDED--DLOG, DEXP, DSQRT, DCOSH, C DSINH, DLOG10. 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. 357-364. C --Y. C. PATEL, "AN ASYMPTOTIC EXPRESSION FOR C CUMULATIVE SUM OF PROBABILITIES OF THE HERMITE C DISTRIBUTION", COMMUNICATIOS IN STATISTICS- C THEORY AND METHODS, 14, PP. 2233-2241. C --KEMP AND KEMP, "SOME PROPERTIES OF THE HERMITE C DISTRIBUTION", BIOMETRIKA, 1965, 52, 3 AND 4, C P. 381 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 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 DOUBLE PRECISION DX DOUBLE PRECISION DALPHA DOUBLE PRECISION DBETA DOUBLE PRECISION DA DOUBLE PRECISION DB DOUBLE PRECISION DTERM1, DTERM2, DTERM3, DTERM4 DOUBLE PRECISION DSUM DOUBLE PRECISION DPDF DOUBLE PRECISION DPDF0 DOUBLE PRECISION DTHETA DOUBLE PRECISION DLNGAM DOUBLE PRECISION DGAMMA DOUBLE PRECISION DIS DOUBLE PRECISION DAA DOUBLE PRECISION BS DOUBLE PRECISION CS 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 IF(ALPHA.LE.0.0)THEN WRITE(ICOUT,11) 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,12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)BETA 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)THEN WRITE(ICOUT,4) 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 HERPDF SUBROUTINE IS NEGATIVE.') 5 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ', 1'ARGUMENT TO THE HERPDF SUBROUTINE IS NON-INTEGRAL *****') 6 FORMAT(' IT HAS BEEN SET TO ',I8) 11 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1' HERPDF SUBROUTINE IS NON-POSITIVE') 12 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ', 1' HERPDF SUBROUTINE IS NON-POSITIVE') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') C DALPHA=DBLE(ALPHA) DBETA=DBLE(BETA) DB=DALPHA**2/2.0D0 DA=DALPHA*DBETA C C USE EXACT FORMULAS C CCCCC IF(INTX.LE.20)THEN IF(INTX.LE.10)THEN DPDF0=DEXP(-DALPHA*DBETA - DALPHA**2/2.0D0) IF(INTX.EQ.0)THEN DPDF=DPDF0 ELSEIF(INTX.EQ.1)THEN DPDF=DALPHA*DBETA*DPDF0 ELSEIF(INTX.EQ.2)THEN DTERM1=DALPHA**2*(DBETA*DBETA + 1.0D0) DPDF=(DTERM1/2.0D0)*DPDF0 ELSEIF(INTX.EQ.3)THEN DTERM1=DALPHA**3*(DBETA**3 + 3.0D0*DBETA) DPDF=(DTERM1/6.0D0)*DPDF0 ELSEIF(INTX.EQ.4)THEN DTERM1=DALPHA**4*(DBETA**4 + 6.0D0*DBETA**2 + 3.0D0) DPDF=(DTERM1/24.0D0)*DPDF0 ELSEIF(INTX.EQ.5)THEN DTERM1=DALPHA**5*(DBETA**5 + 10.0D0*DBETA**3 + 15.0D0*DBETA) DPDF=(DTERM1/120.0D0)*DPDF0 ELSEIF(INTX.GE.6)THEN DTERM1=DALPHA**4*(DBETA**4 + 6.0D0*DBETA**2 + 3.0D0) DTERM1=(DTERM1/24.0D0)*DPDF0 DTERM2=DALPHA**5*(DBETA**5 + 10.0D0*DBETA**3 + 15.0D0*DBETA) DTERM2=(DTERM2/120.0D0)*DPDF0 DO110I=6,INTX DPDF=(DALPHA*DBETA*DTERM2 + DALPHA*DALPHA*DTERM1)/DBLE(I) DTERM1=DTERM2 DTERM2=DPDF 110 CONTINUE ENDIF PDF=REAL(DPDF) ELSE IF(MOD(INTX,2).EQ.0)THEN IS=INTX/2 DIS=DBLE(IS) DAA=DA*DA/(8.0D0*DB) BS=(4.0D0*DIS+1.0D0) DTERM1=DSQRT(DAA)*DSQRT(DAA+BS) DTERM2=BS*DLOG10(DSQRT(1.0D0+DAA/BS)+DSQRT(DAA/BS)) DTHETA=DCOSH(DTERM1 + DTERM2) DTERM1=-(DA+DB+DAA) DTERM2=DIS*DLOG(DB) - DLNGAM(DBLE(IS+1)) DTERM3=-0.25D0*DLOG(1.0D0 + DAA/BS) DTERM4=DLOG(DTHETA) DPDF=DTERM1 + DTERM2 + DTERM3 + DTERM4 DPDF=DEXP(DPDF) PDF=REAL(DPDF) ELSE IS=(INTX-1)/2 DIS=DBLE(IS) DAA=DA*DA/(8.0D0*DB) CS=(4.0D0*DIS+3.0D0)/2.0D0 DTERM1=DSQRT(DAA)*DSQRT(DAA+CS) DTERM2=CS*DLOG(DSQRT(1.0D0+DAA/CS)+DSQRT(DAA/CS)) DTHETA=DSINH(DTERM1 + DTERM2) DTERM1=-(DA+DB+DAA) DTERM2=DIS*DLOG(DB) + 0.5D0*DLOG(2.0D0*DB) - 1 0.5D0*DLOG(CS) - DLNGAM(DBLE(IS+1)) DTERM3=0.25D0*DLOG(1.0D0 + DAA/CS) DTERM4=DLOG(DTHETA) DPDF=DTERM1 + DTERM2 + DTERM3 + DTERM4 DPDF=DEXP(DPDF) PDF=REAL(DPDF) ENDIF C C USE ASYMPTOTIC APPROXIMATION C ENDIF C 9999 CONTINUE RETURN END SUBROUTINE HERPPF(P,ALPHA,BETA,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE AT THE SINGLE PRECISION VALUE P C FOR THE HERMITE DISTRIBUTION C WITH SINGLE PRECISION PARAMETERS ALPHA AND BETA. C THE FIRST 25 TERMS OF THE HERMITE CUMULATIVE C DISTRIBUTION WILL BE COMPUTED. IF THE PERCENT C POINT IS NOT FOUND WITHIN THESE FIRST 25 TERMS, C A BISECTION METHOD WILL BE ATTEMPTED. 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 --ALPHA = THE SINGLE PRECISION VALUE C OF THE FIRST SHAPE PARAMETER. C --BETA = THE SINGLE PRECISION VALUE C OF THE SECOND SHAPE 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 HERMITE DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--ALPHA AND BETA SHOULD BE POSITIVE. C --P SHOULD BE BETWEEN 0.0 (INCLUSIVELY) C AND 1.0 (INCLUSIVELY). C OTHER DATAPAC SUBROUTINES NEEDED--HERCDF C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION AND DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND KEMP, "UNIVARIATE DISCRETE C DISTRIBUTIONS", SECOND EDITION, WILEY, 1992, C PP. 357-364. C --Y. C. PATEL, "AN ASYMPTOTIC EXPRESSION FOR C CUMULATIVE SUM OF PROBABILITIES OF THE HERMITE C DISTRIBUTION", COMMUNICATIOS IN STATISTICS- C THEORY AND METHODS, 14, PP. 2233-2241. C --KEMP AND KEMP, "SOME PROPERTIES OF THE HERMITE C DISTRIBUTION", BIOMETRIKA, 1965, 52, 3 AND 4, C P. 381 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 (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 C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DALPHA DOUBLE PRECISION DBETA DOUBLE PRECISION DTERM1, DTERM2, DTERM3, DTERM4, DTERM5 DOUBLE PRECISION DCDF DOUBLE PRECISION DPDF DOUBLE PRECISION DCDF0 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.GE.1.0)THEN WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF IF(ALPHA.LE.0.0)THEN WRITE(ICOUT,11) 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,12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)BETA CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ENDIF 1 FORMAT('***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO THE ', 1' HERPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1] INTERVAL') 11 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1' HERPPF SUBROUTINE IS NON-POSITIVE') 12 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ', 1' HERPPF SUBROUTINE IS NON-POSITIVE') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') C PPF=0.0 C C TREAT CERTAIN SPECIAL CASES IMMEDIATELY-- C 1) P = 0.0 C IF(P.EQ.0.0)THEN PPF=0.0 GOTO9999 ENDIF C C COMPUTE THE HERCDF, TERMINATE WHEN CDF IS GREATER THAN OR C EQUAL TO P. C DP=DBLE(P) DALPHA=DBLE(ALPHA) DBETA=DBLE(BETA) C DCDF0=DEXP(-DALPHA*DBETA - DALPHA**2/2.0D0) DCDF=DCDF0 IF(DCDF.GE.DP)THEN PPF=0.0 GOTO9999 ENDIF C DCDF=DCDF + DALPHA*DBETA*DCDF0 IF(DCDF.GE.DP)THEN PPF=1.0 GOTO9999 ENDIF C DTERM1=DALPHA**2*(DBETA*DBETA + 1.0D0) DCDF=DCDF + (DTERM1/2.0D0)*DCDF0 IF(DCDF.GE.DP)THEN PPF=2.0 GOTO9999 ENDIF C DTERM1=DALPHA**3*(DBETA**3 + 3.0D0*DBETA) DCDF=DCDF + (DTERM1/6.0D0)*DCDF0 IF(DCDF.GE.DP)THEN PPF=3.0 GOTO9999 ENDIF C DTERM1=DALPHA**4*(DBETA**4 + 6.0D0*DBETA**2 + 3.0D0) DCDF=DCDF + (DTERM1/24.0D0)*DCDF0 IF(DCDF.GE.DP)THEN PPF=4.0 GOTO9999 ENDIF C DTERM1=DALPHA**5*(DBETA**5 + 10.0D0*DBETA**3 + 15.0D0*DBETA) DCDF=DCDF + (DTERM1/120.0D0)*DCDF0 IF(DCDF.GE.DP)THEN PPF=5.0 GOTO9999 ENDIF C DTERM1=DALPHA**4*(DBETA**4 + 6.0D0*DBETA**2 + 3.0D0) DTERM1=(DTERM1/24.0D0)*DCDF0 DTERM2=DALPHA**5*(DBETA**5 + 10.0D0*DBETA**3 + 15.0D0*DBETA) DTERM2=(DTERM2/120.0D0)*DCDF0 C DO110I=6,25 DPDF=(DALPHA*DBETA*DTERM2 + DALPHA*DALPHA*DTERM1)/DBLE(I) DCDF=DCDF + DPDF IF(DCDF.GE.DP)THEN PPF=REAL(I) GOTO9999 ENDIF DTERM1=DTERM2 DTERM2=DPDF 110 CONTINUE P0=REAL(DCDF) C C IF PPF NOT FOUND IN FIRST 25 TERMS, SWITCH TO BISECTION METHOD. C X0=25.0 AMEAN=ALPHA*(ALPHA+BETA) ASD=SQRT(ALPHA*(2*ALPHA+BETA)) ISD=INT(ASD)+1 C C DETERMINE AN UPPER BOUND BY ITERATING IN STEPS OF ONE SD. C MAXIT=1000 ICOUNT=0 200 CONTINUE ICOUNT=ICOUNT+1 IF(ICOUNT.GT.MAXIT)THEN WRITE(ICOUT,210) 210 FORMAT('***** ERROR: UNABLE TO FIND UPPER BOUND IN ', 1 'HERPPF.') CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF X1=X0 + REAL(ISD) CALL HERCDF(X1,ALPHA,BETA,P1) IF(P1.LT.P)THEN X0=X1 GOTO200 ENDIF 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. IX0=INT(X0+ 0.01) IX1=INT(X1+ 0.01) C 300 CONTINUE IXOP1=IX0+1 IF(IX1.EQ.IXOP1)THEN PPF=REAL(IX1) IF(P0.EQ.P)PPF=REAL(IX0) GOTO9999 ENDIF IX2=(IX0+IX1)/2 IF(IX2.EQ.IX0 .OR. IX2.EQ.IX0)THEN WRITE(ICOUT,311) 311 FORMAT('***** INTERNAL ERROR IN HERPPF SUBROUTINE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,313) 313 FORMAT(' BISECTION VALUE (X2) = LOWER BOUND (X0) OR ', 1 'UPPER BOUND (X1)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,315)X0,P0 315 FORMAT(' X0 = ',F14.7,10X,'P0 = ',F14.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,317)X1,P1 317 FORMAT(' X1 = ',F14.7,10X,'P1 = ',F14.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,319)X2,P2 319 FORMAT(' X2 = ',F14.7,10X,'P2 = ',F14.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,321)P 321 FORMAT(' P = ',F14.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,323)ALPHA,BETA 323 FORMAT(' ALPHA, BETA = ',F14.7,F14.7) CALL DPWRST('XXX','BUG ') ELSE X2=REAL(IX2) CALL HERCDF(X2,ALPHA,BETA,P2) IF(P0.LT.P2 .AND. P2.LT.P1)THEN IF(P2.LE.P)THEN IX0=IX2 X0=REAL(IX0) P0=P2 ELSE IX1=IX2 X1=REAL(IX1) P1=P2 ENDIF GOTO300 ELSEIF(P2.LE.P0 .OR. P2.GE.P1)THEN WRITE(ICOUT,311) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,313) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,315)X0,P0 CALL DPWRST('XXX','BUG ') WRITE(ICOUT,317)X1,P1 CALL DPWRST('XXX','BUG ') WRITE(ICOUT,319)X2,P2 CALL DPWRST('XXX','BUG ') WRITE(ICOUT,321)P CALL DPWRST('XXX','BUG ') WRITE(ICOUT,323)ALPHA,BETA CALL DPWRST('XXX','BUG ') ELSE WRITE(ICOUT,311) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,313) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,315)X0,P0 CALL DPWRST('XXX','BUG ') WRITE(ICOUT,317)X1,P1 CALL DPWRST('XXX','BUG ') WRITE(ICOUT,319)X2,P2 CALL DPWRST('XXX','BUG ') WRITE(ICOUT,321)P CALL DPWRST('XXX','BUG ') WRITE(ICOUT,323)ALPHA,BETA CALL DPWRST('XXX','BUG ') ENDIF ENDIF C 9999 CONTINUE RETURN END SUBROUTINE HERRAN(ALPHA,BETA,N,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE HERMITE DISTRIBUTION C WITH SHAPE PARAMETERS ALPHA AND BETA. C THIS DISTRIBUTION IS DEFINED FOR ALL C NON-NEGATIVE X. C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --ALPHA = THE SINGLE PRECISION VALUE C OF THE FIRST SHAPE PARAMETER OF THE C HERMITE DISTRIBUTION. C ALPHA > 0. C --BETA = THE SINGLE PRECISION VALUE C OF THE SECOND SHAPE PARAMETER OF THE C HERMITE DISTRIBUTION. C BETA > 0. 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 HERMITE 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 --ALPHA, BETA > 0 C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN, GEORAN. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND KEMP, "UNIVARIATE DISCRETE C DISTRIBUTIONS", SECOND EDITION, WILEY, 1992, C PP. 357-364. C --Y. C. PATEL, "AN ASYMPTOTIC EXPRESSION FOR C CUMULATIVE SUM OF PROBABILITIES OF THE HERMITE C DISTRIBUTION", COMMUNICATIOS IN STATISTICS- C THEORY AND METHODS, 14, PP. 2233-2241. C --KEMP AND KEMP, "SOME PROPERTIES OF THE HERMITE C DISTRIBUTION", BIOMETRIKA, 1965, 52, 3 AND 4, C P. 381 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 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/4 C ORIGINAL VERSION--APRIL 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION G(2) 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(ALPHA.LE.0.0)THEN WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALPHA CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF IF(BETA.LE.0.0)THEN WRITE(ICOUT,12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)BETA CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 5 FORMAT('***** FATAL ERROR--NUMBER OF HERMITE RANDOM ', 1'NUMBERS REQUESTED < 1') 11 FORMAT('***** FATAL ERROR--THE ALPHA SHAPE PARAMETER ARGUMENT', 1' TO THE HERRAN SUBROUTINE IS <= 0') 12 FORMAT('***** FATAL ERROR--THE BETA SHAPE PARAMETER ARGUMENT', 1' TO THE HERRAN SUBROUTINE IS <= 0') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') C C ALGORITHM BASED ON FACT THAT HERMITE DISTRIBUTION IS C C X1 + 2*X2 C C WHERE X1 AND X2 ARE INDPENDENT POISSON RANDOM VARIABLES C WITH SHAPE PARAMETERS ALPHA*BETA AND ALPHA**2/2, RESPECTIVELY. C A1=ALPHA*BETA A2=ALPHA*ALPHA/2.0 NTEMP=1 C DO100I=1,N CALL POIRAN(NTEMP,A1,ISEED,G(1)) CALL POIRAN(NTEMP,A2,ISEED,G(2)) X(I)=G(1) + 2.0*G(2) 100 CONTINUE C 9000 CONTINUE RETURN C END SUBROUTINE HESS(PNRFUN,X,N,SCL,STPSZ,FNBR,H) 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 Declarations C IMPLICIT DOUBLE PRECISION (a-h,o-z) C DOUBLE PRECISION X(N),SCL(N),STPSZ(N),FNBR(N),H(N,N) DOUBLE PRECISION MACHEP DOUBLE PRECISION FNVAL C REAL R1MACH INCLUDE 'DPCOMC.INC' C EXTERNAL PNRFUN C C End declarations C MACHEP = D1MACH(4) FC = PNRFUN(X,N) C = MACHEP**(1.0D0/3.0D0) C C Calculate stepsize and updated function value C DO 10 i = 1,n stpsz(i) = dmax1(dabs(x(i)),1.0d0/scl(i)) stpsz(i) = stpsz(i)*c*dsign(1.0d0,x(i)) tempi = x(i) x(i) = x(i) + stpsz(i) stpsz(i) = x(i) - tempi FNBR(I) = PNRFUN(X,N) x(i) = tempi 10 CONTINUE DO 30 i = 1,n C C Calculate Hessian C C C Calculate Diagonal Elements C tempi = x(i) x(i) = x(i) + 2.0d0*stpsz(i) fii=pnrfun(x,n) h(i,i) = ((fc-fnbr(i))+ (fii-fnbr(i)))/ (stpsz(i)*stpsz(i)) x(i) = tempi + stpsz(i) DO 20 j = i + 1,n C C Calculate Off-Diagonal Elements C tempj = x(j) x(j) = x(j) + stpsz(j) fij=pnrfun(x,n) h(i,j) = ((fc-fnbr(i))+ (fij-fnbr(j)))/ + (stpsz(i)*stpsz(j)) h(j,i) = h(i,j) x(j) = tempj 20 CONTINUE x(i) = tempi 30 CONTINUE C RETURN END SUBROUTINE HFCCDF(X,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE HALF-CAUCHY DISTRIBUTION C THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X C AND HAS THE PROBABILITY DENSITY FUNCTION C F(X) = (2/PI)/(1+x**2) C THE HALF-CAUCHY DISTRIBUTION USED HEREIN C IS THE DISTRIBUTION OF THE VARIATE X = ABS(Z) WHERE C THE VARIATE Z IS CAUCHY DISTRIBUTED 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. 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 HALF-CAUCHY DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE NON-NEGATIVE. C OTHER DATAPAC SUBROUTINES NEEDED--CAUCDF. 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, 1994, PAGE 328 C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-975-2855 C ORIGINAL VERSION--OCTOBER 1995. C 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.0.0)GOTO50 GOTO90 50 CONTINUE WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') CDF=0.0 RETURN 90 CONTINUE 4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT') 5 FORMAT(' TO THE HFCCDF SUBROUTINE IS NEGATIVE *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C C-----START POINT----------------------------------------------------- C CALL CAUCDF(X,CDF) CDF=2.0*CDF-1.0 C RETURN END SUBROUTINE HFCPDF(X,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE HALF-CAUCHY DISTRIBUTION. C THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X C AND HAS THE PROBABILITY DENSITY FUNCTION C F(X) = (2/PI)/(1+x**2) C THE HALF-CAUCHY DISTRIBUTION USED HEREIN C IS THE DISTRIBUTION OF THE VARIATE X = ABS(Z) WHERE C THE VARIATE Z IS CAUCHY DISTRIBUTED C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE C AT WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C X SHOULD BE NON-NEGATIVE. 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 HALF-CAUCHY C DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE NON-NEGATIVE. C OTHER DATAPAC SUBROUTINES NEEDED--CAUPDF. 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, 1994, PAGE 328 C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-975-2855 C ORIGINAL VERSION--OCTOBER 1995. C 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.0.0)GOTO50 GOTO90 50 CONTINUE WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') PDF=0.0 RETURN 90 CONTINUE 4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT') 5 FORMAT(' TO THE HFCPDF SUBROUTINE IS NEGATIVE *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C C-----START POINT----------------------------------------------------- C CALL CAUPDF(X,PDF) PDF=2.0*PDF C RETURN END SUBROUTINE HFCPPF(P,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE HALF-CAUCHY DISTRIBUTION C THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X C AND HAS THE PROBABILITY DENSITY FUNCTION C F(X) = (2/PI)/(1+X**2) C THE HALF-CAUCHY DISTRIBUTION USED HEREIN C IS THE DISTRIBUTION OF THE VARIATE X = ABS(Z) WHERE C THE VARIATE Z IS CAUCHY DISTRIBUTED 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 OUTPUT ARGUMENTS--PPF = THE SINGLE PRECISION PERCENT C POINT FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION . C VALUE PPF FOR THE HALF-CAUCHY DISTRIBUTION 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--CAUPPF. 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, 1994, PAGE 328 C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--95/10 C ORIGINAL VERSION--OCTOBER 1995. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(P.LT.0.0.OR.P.GE.1.0)GOTO50 GOTO90 50 WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PPF=0.0 RETURN 90 CONTINUE 1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ', 1'HFCPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C ARG=(1.0+P)/2.0 CALL CAUPPF(ARG,PPF) IF(PPF.LE.0.0)PPF=0.0 C RETURN END SUBROUTINE HFCRAN(N,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE HALF-CAUCHY DISTRIBUTION C WITH MEDIAN = 0 AND 75% POINT = 1. C THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS C THE PROBABILITY DENSITY FUNCTION C F(X) = (2/PI)*(1/(1+X*X)). 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 FUNCTION VALUE FOR THE HALF-CAUCHY DISTRIBUTION C WITH MEDIAN = 0 AND 75% POINT = 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--SIN, COS. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--TOCHER, THE ART OF SIMULATION, C 1963, PAGE 15. C --HAMMERSLEY AND HANDSCOMB, MONTE CARLO METHODS, C 1964, PAGE 36. C --FILLIBEN, SIMPLE AND ROBUST LINEAR ESTIMATION C OF THE LOCATION PARAMETER OF A SYMMETRIC C DISTRIBUTION (UNPUBLISHED PH.D. DISSERTATION, C PRINCETON UNIVERSITY), 1969, PAGE 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 154-165. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--95/10 C ORIGINAL VERSION--OCTOBER 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-----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'HFCRAN 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 CAUCHY RANDOM NUMBERS C USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD. C DO100I=1,N ARG=PI*X(I) X(I)=-COS(ARG)/SIN(ARG) 100 CONTINUE C C C GENERATE N HALF-CAUCHY RANDOM NUMBERS C USING THE DEFINITION THAT C A HALF-CAUCHY VARIATE C EQUALS THE ABSOLUTE VALUE OF A CAUCHY VARIATE. C DO400I=1,N IF(X(I).LT.0.0)X(I)=-X(I) 400 CONTINUE C RETURN END SUBROUTINE HFLCDF(X,GAMMA,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE HALF-LOGISTIC DISTRIBUTION. C THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X C AND HAS THE PROBABILITY DENSITY FUNCTION C F(X) = 2*EXP(-X)/(1+EXP(-X))**2 X>=0 C THE HALF-LOGISTIC DISTRIBUTION USED HEREIN C IS THE DISTRIBUTION OF THE VARIATE X = ABS(Z) WHERE C THE VARIATE Z IS LOGISTICALLY DISTRIBUTED C IF GAMMA IS POSITIVE, THE GENERALIZED HALF-LOGISTIC C DISTRIBUTION IS COMPUTED. THIS HAS THE PDF: C F(X) = 2*(1-K*X)**((1/K)-1)/(1+(1-K*X)**(1/K))**2 C 0<=X<=1/K C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE C AT WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C X SHOULD BE NON-NEGATIVE. C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY C FUNCTION VALUE CDF FOR THE HALF-LOGISTIC C DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE NON-NEGATIVE. C OTHER DATAPAC SUBROUTINES NEEDED--CAUCDF. 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, PAGES 150-151 C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-975-2855 C ORIGINAL VERSION--OCTOBER 1995. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX, DG, 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(GAMMA.GT.10.0)THEN WRITE(ICOUT,24) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,25) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)GAMMA CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ENDIF IF(GAMMA.LE.0.0)THEN 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 ELSE ARG1=1./GAMMA IF(X.LT.0.0.OR.X.GT.ARG1)THEN WRITE(ICOUT,14) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ENDIF ENDIF 90 CONTINUE 4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT ', * 'TO THE HFLCDF SUBROUTINE') 5 FORMAT(' IS NEGATIVE. *****') 14 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT ', * 'TO THE HFLCDF SUBROUTINE') 15 FORMAT(' IS OUTSIDE THE (0,1/GAMMA) INTERVAL. *****') 24 FORMAT('***** FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT ', * 'TO THE HFLCDF SUBROUTINE') 25 FORMAT(' IS GREATER THAN 10. *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C C-----START POINT----------------------------------------------------- C IF(X.EQ.0.)THEN CDF=0.0 GOTO9999 ELSEIF(GAMMA.GT.0.0.AND.X.GE.1.0/GAMMA)THEN CDF=1.0 GOTO9999 ENDIF C DX=DBLE(X) DG=DBLE(GAMMA) IF(GAMMA.LE.0.0)THEN DTERM1=DLOG(1.D0-DEXP(-DX)) DTERM2=DLOG(1.D0+DEXP(-DX)) DTERM3=DTERM1-DTERM2 IF(DTERM3.LE.-500.D0)THEN CDF=0.0 ELSEIF(DTERM3.GE.500.D0)THEN CDF=1.0 ELSE DCDF=DEXP(DTERM3) CDF=SNGL(DCDF) ENDIF ELSE DTERM1=DLOG(1.D0-(1.D0-DG*DX)**(1.D0/DG)) DTERM2=DLOG(1.D0+(1.D0-DG*DX)**(1.D0/DG)) DTERM3=DTERM1-DTERM2 IF(DTERM3.LE.-500.D0)THEN CDF=0.0 ELSEIF(DTERM3.GE.500.D0)THEN CDF=1.0 ELSE DCDF=DEXP(DTERM3) CDF=SNGL(DCDF) ENDIF ENDIF C 9999 CONTINUE RETURN END SUBROUTINE HFLPDF(X,GAMMA,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE HALF-LOGISTIC DISTRIBUTION. C THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X C AND HAS THE PROBABILITY DENSITY FUNCTION C F(X) = 2*EXP(-X)/(1+EXP(-X))**2 X>=0 C THE HALF-LOGISTIC DISTRIBUTION USED HEREIN C IS THE DISTRIBUTION OF THE VARIATE X = ABS(Z) WHERE C THE VARIATE Z IS LOGISTIC DISTRIBUTED C IF GAMMA IS POSITIVE, THE GENERALIZED HALF-LOGISTIC C DISTRIBUTION IS COMPUTED. THIS HAS THE PDF: C F(X) = 2*(1-K*X)**((1/K)-1)/(1+(1-K*X)**(1/K))**2 C 0<=X<=1/K C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE C AT WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C X SHOULD BE NON-NEGATIVE. 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 HALF-LOGISTIC C DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE NON-NEGATIVE. C OTHER DATAPAC SUBROUTINES NEEDED--CAUPDF. 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, PAGES 150-151 C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-975-2855 C ORIGINAL VERSION--OCTOBER 1995. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX, DG, DPDF DOUBLE PRECISION DTERM1, DTERM2, DTERM3, DTERM4 C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT 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(GAMMA.GT.10.0)THEN WRITE(ICOUT,24) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,25) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)GAMMA CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ENDIF IF(GAMMA.LE.0.0)THEN 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 ELSE ARG1=1./GAMMA IF(X.LT.0.0.OR.X.GT.ARG1)THEN WRITE(ICOUT,14) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF ENDIF 90 CONTINUE 4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT ', * 'TO THE HFLPDF SUBROUTINE') 5 FORMAT(' IS NEGATIVE. *****') 14 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT ', * 'TO THE HFLPDF SUBROUTINE') 15 FORMAT(' IS OUTSIDE THE (0,1/GAMMA) INTERVAL. *****') 24 FORMAT('***** FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT ', * 'TO THE HFLCDF SUBROUTINE') 25 FORMAT(' IS GREATER THAN 10. *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C C-----START POINT----------------------------------------------------- C IF(GAMMA.LE.0.0)THEN CALL LOGPDF(X,PDF) PDF=2.0*PDF ELSE DX=DBLE(X) IF(X.GE.1.0/GAMMA)THEN IF(GAMMA.LT.1.0)THEN PDF=0.0 GOTO9999 ELSEIF(GAMMA.EQ.1.0)THEN PDF=2.0 GOTO9999 ELSE DX=DX-0.000000001D0 ENDIF ENDIF DG=DBLE(GAMMA) DTERM1=DLOG(2.0D0) DTERM2=((1.D0/DG)-1.D0)*DLOG(1.D0-DG*DX) DTERM3=2.D0*DLOG(1.D0+(1.D0-DG*DX)**(1.D0/DG)) DTERM4=DTERM1+DTERM2-DTERM3 IF(DABS(DTERM4).GE.40.D0)THEN PDF=0.0 ELSE DPDF=DEXP(DTERM4) PDF=SNGL(DPDF) ENDIF ENDIF C 9999 CONTINUE RETURN END SUBROUTINE HFLPPF(P,GAMMA,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE HALF-LOGISTIC DISTRIBUTION. C THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X C AND HAS THE PROBABILITY DENSITY FUNCTION C F(X) = 2*EXP(-X)/(1+EXP(-X))**2 X>=0 C THE HALF-LOGISTIC DISTRIBUTION USED HEREIN C IS THE DISTRIBUTION OF THE VARIATE X = ABS(Z) WHERE C THE VARIATE Z IS LOGISTIC DISTRIBUTED C IF GAMMA IS POSITIVE, THE GENERALIZED HALF-LOGISTIC C DISTRIBUTION IS COMPUTED. THIS HAS THE PDF: C F(X) = 2*(1-K*X)**((1/K)-1)/(1+(1-K*X)**(1/K))**2 C 0<=X<=1/K C C FOR THE HALF-LOGISTIC, THE PPF FUNCTION IS: C C G(P) = -LOG((P-1)/(P+1)) C C FOR THE GENERALIZED HALF-LOGISTIC, THE PPF C FUNCTION IS: C C G(P,GAMMA) = (1 - ((1-P)/(1+P))**GAMMA)/GAMMA C 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 OUTPUT ARGUMENTS--PPF = THE SINGLE PRECISION PERCENT C POINT FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION . C VALUE PPF FOR THE HALF-LOGISTIC DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--P SHOULD BE BETWEEN 0.0 (INCLUSIVELY) C AND 1.0 (EXCLUSIVELY). C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--2, 1994, PAGES 150-151 C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--95/10 C ORIGINAL VERSION--OCTOBER 1995. C UPDATED --JANUARY 2005. REPLACE NUMERICAL INVERSION C WITH EXPLICIT FORMULAS C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DP DOUBLE PRECISION DPPF DOUBLE PRECISION DG C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(GAMMA.GT.10.0)THEN WRITE(ICOUT,24) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,25) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)GAMMA CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ENDIF IF(GAMMA.LE.0.0)THEN IF(P.LT.0.0.OR.P.GE.1.0)THEN WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF ELSE IF(P.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 ENDIF 1 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE ', 1'HFLPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') 24 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT ', * 'TO THE HFLCDF SUBROUTINE') 25 FORMAT(' IS GREATER THAN 10. *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C C STANDARD HALF-LOGISTIC CASE. HAVE TO BOUND TO THE RIGHT. C IF(P.EQ.0.0)THEN PPF=0. GOTO9999 ENDIF C DP=DBLE(P) DG=DBLE(GAMMA) C IF(GAMMA.LE.0.0)THEN DPPF=-DLOG((1.0D0-DP)/(1.0D0+DP)) ELSE IF(P.EQ.1.0)THEN DPPF=1.0D0/DG ELSE DPPF=(1.0D0 - ((1.0D0-DP)/(1.0D0+DP))**DG)/DG ENDIF ENDIF PPF=REAL(DPPF) C 9999 CONTINUE RETURN END SUBROUTINE HFLRAN(N,GAMMA,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE HALF-LOGISTIC DISTRIBUTION C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR C (OF DIMENSION AT LEAST N) C INTO WHICH THE GENERATED C RANDOM SAMPLE WILL BE PLACED. C OUTPUT--A RANDOM SAMPLE OF SIZE N C FROM THE HALF-LOGISTIC DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. 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)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'HFLRAN 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 HALF-LOGISTIC RANDOM NUMBERS C USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD C AND THE FACT THAT THE HALF-LOGISTIC RANDOM NUMBER IS DEFINED C TO BE THE ABSOLUTE VALUE OF LOGISTIC RANDOM NUMBER. C DO100I=1,N CALL HFLPPF(X(I),GAMMA,XTEMP) X(I)=XTEMP 100 CONTINUE C RETURN END SUBROUTINE HFNCDF(X,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE HALFNORMAL C DISTRIBUTION. C THE HALFNORMAL DISTRIBUTION USED C HEREIN HAS MEAN = SQRT(2/PI) = 0.79788456 C AND STANDARD DEVIATION = 1. C THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X C AND HAS THE PROBABILITY DENSITY FUNCTION C F(X) = (2/SQRT(2*PI)) * EXP(-X*X/2). C THE HALFNORMAL DISTRIBUTION USED HEREIN C IS THE DISTRIBUTION OF THE VARIATE X = ABS(Z) WHERE C THE VARIATE Z IS NORMALLY DISTRIBUTED C WITH MEAN = 0 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. 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 HALFNORMAL C DISTRIBUTION WITH MEAN = SQRT(2/PI) = 0.79788456 C AND STANDARD DEVIATION = 1. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE NON-NEGATIVE. C OTHER DATAPAC SUBROUTINES NEEDED--NORCDF. 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 53, 59, 81, 83. C --DANIEL, 'USE OF HALF-NORMAL PLOTS IN C INTERPRETING FACTORIAL TWO-LEVEL EXPERIMENTS', C TECHNOMETRICS, 1959, PAGES 311-341. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-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 C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(X.LT.0.0)GOTO50 GOTO90 50 CONTINUE WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') CDF=0.0 RETURN 90 CONTINUE 4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT') 5 FORMAT(' TO THE HFNCDF SUBROUTINE IS NEGATIVE *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C C-----START POINT----------------------------------------------------- C CALL NORCDF(X,CDF) CDF=2.0*CDF-1.0 C RETURN END SUBROUTINE HFNPDF(X,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE HALFNORMAL DISTRIBUTION. C THE HALFNORMAL DISTRIBUTION USED C HEREIN HAS MEAN = SQRT(2/PI) = 0.79788456 C AND STANDARD DEVIATION = 1. C THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X C AND HAS THE PROBABILITY DENSITY FUNCTION C F(X) = (2/SQRT(2*PI)) * EXP(-X*X/2). C THE HALFNORMAL DISTRIBUTION USED HEREIN C IS THE DISTRIBUTION OF THE VARIATE X = ABS(Z) WHERE C THE VARIATE Z IS NORMALLY DISTRIBUTED C WITH MEAN = 0 AND STANDARD DEVIATION = 1. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE C AT WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C X SHOULD BE NON-NEGATIVE. 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 HALFNORMAL C DISTRIBUTION WITH MEAN = SQRT(2/PI) = 0.79788456 C AND STANDARD DEVIATION = 1. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE NON-NEGATIVE. C OTHER DATAPAC SUBROUTINES NEEDED--NORPDF. 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 53, 59, 81, 83. C --DANIEL, 'USE OF HALF-NORMAL PLOTS IN C INTERPRETING FACTORIAL TWO-LEVEL EXPERIMENTS', C TECHNOMETRICS, 1959, PAGES 311-341. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-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 C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(X.LT.0.0)GOTO50 GOTO90 50 CONTINUE WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') PDF=0.0 RETURN 90 CONTINUE 4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT') 5 FORMAT(' TO THE HFNPDF SUBROUTINE IS NEGATIVE *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C C-----START POINT----------------------------------------------------- C CALL NORPDF(X,PDF) PDF=2.0*PDF C RETURN END SUBROUTINE HFNPPF(P,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE HALFNORMAL C DISTRIBUTION. C THE HALFNORMAL DISTRIBUTION USED C HEREIN HAS MEAN = SQRT(2/PI) = 0.79788456 C AND STANDARD DEVIATION = 1. C THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X C AND HAS THE PROBABILITY DENSITY FUNCTION C F(X) = (2/SQRT(2*PI)) * EXP(-X*X/2). C THE HALFNORMAL DISTRIBUTION USED HEREIN C IS THE DISTRIBUTION OF THE VARIATE X = ABS(Z) WHERE C THE VARIATE Z IS NORMALLY DISTRIBUTED C WITH MEAN = 0 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 OUTPUT ARGUMENTS--PPF = THE SINGLE PRECISION PERCENT C POINT FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION . C VALUE PPF FOR THE HALFNORMAL DISTRIBUTION C WITH MEAN = SQRT(2/PI) = 0.79788456 C AND STANDARD DEVIATION = 1. 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--NORPPF. 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 53, 59, 81, 83. C --DANIEL, 'USE OF HALF-NORMAL PLOTS IN C INTERPRETING FACTORIAL TWO-LEVEL EXPERIMENTS', C TECHNOMETRICS, 1959, PAGES 311-341. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--82/7 C ORIGINAL VERSION--NOVEMBER 1975. C UPDATED --OCTOBER 1976. C UPDATED --DECEMBER 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(P.LT.0.0.OR.P.GE.1.0)GOTO50 GOTO90 50 WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PPF=0.0 RETURN 90 CONTINUE 1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ', 1'HFNPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C ARG=(1.0+P)/2.0 CALL NORPPF(ARG,PPF) IF(PPF.LE.0.0)PPF=0.0 C RETURN END SUBROUTINE HFNRAN(N,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE HALFNORMAL DISTRIBUTION. C THE PROTOTYPE HALFNORMAL DISTRIBUTION USED C HEREIN HAS MEAN = SQRT(2/PI) = 0.79788456 C AND STANDARD DEVIATION = 1. C THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE X C AND HAS THE PROBABILITY DENSITY FUNCTION C F(X) = (2/SQRT(2*PI)) * EXP(-X*X/2). C THE PROTOTYPE HALFNORMAL DISTRIBUTION USED HEREIN C IS THE DISTRIBUTION OF THE VARIATE X = ABS(Z) WHERE C THE VARIATE Z IS NORMALLY DISTRIBUTED C WITH MEAN = 0 AND STANDARD DEVIATION = 1. 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 HALFNORMAL DISTRIBUTION C WITH MEAN = SQRT(2/PI) = 0.79788456 C 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 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 53, 59, 81, 83. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--82/7 C ORIGINAL VERSION--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'HFNRAN 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 C GENERATE N HALFNORMAL RANDOM NUMBERS C USING THE DEFINITION THAT C A HALFNORMAL VARIATE C EQUALS THE ABSOLUTE VALUE OF A NORMAL VARIATE. C DO400I=1,N IF(X(I).LT.0.0)X(I)=-X(I) 400 CONTINUE C RETURN END SUBROUTINE HLQEST(X, N, XTEMP, LB, RB, Q, ISEED, RESULT) C C SUBROUTINE HLQEST C C PURPOSE COMPUTES THE HODGES-LEHMANN LOCATION ESTIMATOR: C MEDIAN OF ( X(I) + X(J) ) / 2 FOR 1 LE I LE J LE N C C USAGE CALL HLQEST(X,N,LB,RB,Q,RESULT) C C ARGUMENTS X REAL ARRAY OF OBSERVATIONS (INPUT) C * VALUES OF X MUST BE IN NONDECREASING ORDER * C C N INTEGER NUMBER OF OBSERVATIONS (INPUT) C * N MUST NOT BE LESS THAN 1 * C C LB INTEGER ARRAY OF LENGTH N FOR WORKSPACE C C RB INTEGER ARRAY OF LENGTH N FOR WORKSPACE C C Q INTEGER ARRAY OF LENGTH N FOR WORKSPACE C C ISEED SEED FOR UNIFORM RANDOM NUMBER GENERATOR C C NOTE --- ONLY LB,RB, AND Q ARE CHANGED IN COMPUTATION C C EXTERNAL ROUTINE C RAN FUNCTION PROVIDING UNIFORM RANDOM VARIABLES C IN THE INTERVAL (0,1) C RAN REQUIRES A DUMMY INTEGER ARGUMENT C C NOTES HLQEST HAS AN EXPECTED TIME COMPLEXITY ON C THE ORDER OF N * LG( N ) C C C FOR N <= 25, COMPUTE DIRECTLY C C J F MONAHAN, APRIL 1982, DEPT OF STAT, N C S U, RALEIGH, N C 27650 C FINAL VERSION JUNE 1983 C REAL X(*), AMN, AMX, XRAN(1) REAL XTEMP(*) INTEGER LB(*), RB(*), Q(*), SM, SQ, I, J, K, K1, K2, L, N, NN, * MDLL, MDLU, LBI, RBI, MDLROW, IQ C C TAKE CARE OF SPECIAL CASES: N=1 AND N=2 C IF (N.LE.0) THEN RESULT=0.0 RETURN ENDIF C CALL SORT(X,N,X) IF (N.EQ.1) THEN RESULT = X(1) RETURN ELSEIF (N.EQ.2) THEN RESULT = (X(1)+X(2))/2. RETURN ELSEIF (N.LE.25) THEN NN = 0 DO 1 I=1,N DO 2 J = I,N NN = NN + 1 XTEMP(NN) = X(I) + X(J) 2 CONTINUE 1 CONTINUE CALL SORT(XTEMP,NN,XTEMP) K=(NN+1)/2 IF(2*K.EQ.NN) XTEMP(K) = (XTEMP(K) + XTEMP(K+1))/2. RESULT=XTEMP(K)/2. RETURN ENDIF C C FIND THE TOTAL NUMBER OF PAIRS (NN) AND THE MEDIAN(S) (K1,K2) NEEDED C 10 CONTINUE NN = (N*(N+1))/2 K1 = (NN+1)/2 K2 = (NN+2)/2 C C INITIALIZE LEFT AND RIGHT BOUNDS C DO 20 I=1,N LB(I) = I RB(I) = N 20 CONTINUE C SM = NUMBER IN SET S AT STEP M SM = NN C L = NUMBER OF PAIRS LESS THAN THOSE IN SET S AT STEP M L = 0 C C C USE THE MEDIAN OF X(I)'S TO PARTITION ON THE FIRST STEP C MDLL = (N+1)/2 MDLU = (N+2)/2 AM = X(MDLL) + X(MDLU) GO TO 80 C C USE THE MIDRANGE OF SET S AS PARTITION ELEMENT WHEN TIES ARE LIKELY C -- OR GET THE AVERAGE OF THE LAST 2 ELEMENTS C 30 AMX = X(1) + X(1) AMN = X(N) + X(N) DO 40 I=1,N C SKIP THIS ROW IF NO ELEMENT IN IT IS IN SET S ON THIS STEP IF (LB(I).GT.RB(I)) GO TO 40 LBI = LB(I) C GET THE SMALLEST IN THIS ROW AMN = AMIN1(AMN,X(LBI)+X(I)) RBI = RB(I) C GET THE LARGEST IN THIS ROW AMX = AMAX1(AMX,X(RBI)+X(I)) 40 CONTINUE AM = (AMX+AMN)/2. C BE CAREFUL TO CUT OFF SOMETHING -- ROUNDOFF CAN DO WIERD THINGS IF (AM.LE.AMN .OR. AM.GT.AMX) AM = AMX C UNLESS FINISHED, JUMP TO PARTITION STEP IF (AMN.NE.AMX .AND. SM.NE.2) GO TO 80 C ALL DONE IF ALL OF S IS THE SAME -OR- IF ONLY 2 ELEMENTS ARE LEFT RESULT = AM/2. RETURN C C ***** RESTART HERE UNLESS WORRIED ABOUT TIES ***** C 50 CONTINUE C USE RANDOM ROW MEDIAN AS PARTITION ELEMENT CCCCC FOR DATAPLOT: CALL UNIRAN CCCCC K = IFIX(FLOAT(SM)*RAN(SM)) NTEMP=1 CALL UNIRAN(NTEMP, ISEED, XRAN) K = IFIX(FLOAT(SM)*XRAN(1)) C K IS A RANDOM INTEGER FROM O TO SM-1 DO 60 I=1,N J = I IF (K.LE.RB(I)-LB(I)) GO TO 70 K = K - RB(I) + LB(I) - 1 60 CONTINUE C J IS A RANDOM ROW --- NOW GET ITS MEDIAN 70 MDLROW = (LB(J)+RB(J))/2 AM = X(J) + X(MDLROW) C C ***** PARTITION STEP ***** C C USE AM TO PARTITION S0 INTO 2 GROUPS: THOSE .LT. AM, THOSE .GE. AM C Q(I)= HOW MANY PAIRS (X(I)+X(J)) IN ROW I LESS THAN AM 80 CONTINUE J = N C START IN UPPER RIGHT CORNER SQ = 0 C I COUNTS ROWS DO 110 I=1,N Q(I) = 0 C HAVE WE HIT THE DIAGONAL ? 90 IF (J.LT.I) GO TO 110 C SHALL WE MOVE LEFT ? IF (X(I)+X(J).LT.AM) GO TO 100 J = J - 1 GO TO 90 C WE'RE DONE IN THIS ROW 100 Q(I) = J - I + 1 C SQ = TOTAL NUMBER OF PAIRS LESS THAN AM SQ = SQ + Q(I) 110 CONTINUE C C *** FINISHED PARTITION --- START BRANCHING *** C C IF CONSECUTIVE PARTITIONS ARE THE SAME WE PROBABLY HAVE TIES IF (SQ.EQ.L) GO TO 30 C C ARE WE NEARLY DONE, WITH THE VALUES WE WANT ON THE BORDER? C IF(WE NEED MAX OF THOSE .LT. AM -OR- MIN OF THOSE .GE. AM) GO TO 90 C IF (SQ.EQ.K2-1) GO TO 180 C C THE SET S IS SPLIT, WHICH PIECE DO WE KEEP? C 70 = CUT OFF BOTTOM, 90 = NEARLY DONE, 60 = CUT OFF TOP C IF (SQ-K1) 140, 180, 120 C C NEW S = (OLD S) .INTERSECT. (THOSE .LT. AM) 120 CONTINUE DO 130 I=1,N C RESET RIGHT BOUNDS FOR EACH ROW RB(I) = I + Q(I) - 1 130 CONTINUE GO TO 160 C NEW S = (OLD S) .INTERSECT. (THOSE .GE. AM) 140 CONTINUE DO 150 I=1,N C RESET LEFT BOUNDS FOR EACH ROW LB(I) = I + Q(I) 150 CONTINUE C C COUNT SM = NUMBER OF PAIRS STILL IN NEW SET S C L = NUMBER OF PAIRS LESS THAN THOSE IN NEW SET S 160 L = 0 SM = 0 DO 170 I=1,N L = L + LB(I) - I SM = SM + RB(I) - LB(I) + 1 170 CONTINUE C C ***** NORMAL RESTART JUMP ***** C IF (SM.GT.2) GO TO 50 C CAN ONLY GET TO 2 LEFT IF K1.NE.K2 -- GO GET THEIR AVERAGE GO TO 30 C C FIND: MAX OF THOSE .LT. AM C MIN OF THOSE .GE. AM 180 CONTINUE AMN = X(N) + X(N) AMX = X(1) + X(1) DO 190 I=1,N IQ = Q(I) IPIQ = I + IQ IF (IQ.GT.0) AMX = AMAX1(AMX,X(I)+X(IPIQ-1)) IPIQ = I + IQ IF (IQ.LT.N-I+1) AMN = AMIN1(AMN,X(I)+X(IPIQ)) 190 CONTINUE RESULT = (AMN+AMX)/4. C WE ARE DONE, BUT WHICH SITUATION ARE WE IN? IF (K1.LT.K2) RETURN IF (SQ.EQ.K1) RESULT = AMX/2. IF (SQ.EQ.K1-1) RESULT = AMN/2. RETURN END SUBROUTINE HN(NX,DHN) C C PURPOSE--THIS SUBROUTINE COMPUTES THE HARMONIC NUMBER C FUNCTION FOR REAL ARGUMENTS GREATER THAN 1. C C THE HARMONIC NUMBER IS: C C H(N)=SUM[K=1 to N][1/K] C C THE HARMONIC NUMBER CAN BE COMPUTED IN EITHER C OF THE FOLLOWING TWO WAYS: C C 1) H(N) = PSI(N+1) + gamma C WHERE gamma IS EULER'S CONSTANT C C 2) H(N) = gamma + LOG(N) + (1/2)*N**(-2) + C (1/120)*N**(-4) + O(n**(-6)) C C IN THIS SUBROUTINE, WE WILL USE DIRECT SUMMATION C FOR N <= 30. FOR N > 30, WE WILL USE THE PSI C FUNCTION. C C INPUT ARGUMENTS--NX = THE INTEGR VALUE OF THE ORDER OF C THE HARMONIC NUMBER C OUTPUT ARGUMENTS--DHN = THE DOUBLE PRECISION HARMONIC C NUMBER C OUTPUT--THE DOUBLE PRECISION HARMONIC NUMBER DHN. C PRINTING--NONE. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--DPSI. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--XX C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBRUG, 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 LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006.9 C ORIGINAL VERSION--MAY 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES----------------- C C------------------------------------------------------------------- C IMPLICIT DOUBLE PRECISION (A-H, O-Z) REAL CPUMAX, CPUMIN EXTERNAL DPSI DOUBLE PRECISION DPSI C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT 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 DEPS/1.0D-20/ C C-----START POINT--------------------------------------------------- C IF(NX.LT.1)THEN WRITE(ICOUT,51) 51 FORMAT('***** ERROR FROM HARMNUMB FUNCTION--') CALL DPWRST('XXX','BUG') WRITE(ICOUT,53) 53 FORMAT(' THE FIRST ARGUMENT (N) MUST BE A POSITIVE ', 1 'INTEGER') CALL DPWRST('XXX','BUG') WRITE(ICOUT,55)NX 55 FORMAT(' VALUE OF THE ARGUMENT IS ',I8) CALL DPWRST('XXX','BUG') DHN=0.0D0 GOTO9000 ENDIF C C FOR N <= 30, JUST DO A DIRECT SUM. C IF(NX.LE.30)THEN DSUM=0.0D0 DO100I=NX,1,-1 DSUM=DSUM + 1.0D0/DBLE(I) 100 CONTINUE DHN=DSUM C C OTHERWISE, USE DPSI FUNCTION C ELSE DHN=DPSI(DBLE(NX+1)) + 0.5772156649 ENDIF C 9000 CONTINUE RETURN END SUBROUTINE HNM(NX,DM,DHNM) C C PURPOSE--THIS SUBROUTINE COMPUTES THE GENERALIZED HARMONIC C NUMBER FUNCTION FOR REAL ARGUMENTS GREATER THAN 1. C C THE GENERALIZED HARMONIC NUMBER IS: C C H(N,M)=SUM[K=1 to N][1/K**M] C C THIS IS RELATED TO THE RIEMAN-ZETA SUM: C C ZETA(M)=SUM[K=1 to INFINITY][1/K**M] C C THAT IS, THE ZETA SUM IS THE LIMIT OF THE C GENERALIZED HARMONIC NUMBER AS N GOES TO INFINITY. C C WE ADAPT THE CODE FOR COMPUTING THE RIEMAN-ZETA SUM. C THIS CODE IS BASED ON EULER-MACMACLAURIN SUMMATION. C C FOR BETTER COMPUTATIONAL ACCURACY, ACTUALLY C COMPUTE ZETA(X) - 1. C INPUT ARGUMENTS--DNX = THE DOUBLE PRECISION VALUE OF C THE N ARGUMENT C --DM = THE DOUBLE PRECISION VALUE OF C THE M ARGUMENT C OUTPUT ARGUMENTS--DHNM = THE DOUBLE PRECISION GENERALIZED C HARMONIC NUMBER C OUTPUT--THE DOUBLE PRECISION GENERALIZED HARMONIC NUMBER DHNM. C PRINTING--NONE. C RESTRICTIONS--NONE. 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--NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS C SERIES 55, 1964. C --THOMPSON, "ATLAS FOR COMPUTING MATHEMATICAL C FUNCTIONS", WILEY, 1997. THIS ROUTINE IS A C FORTRAN TRANSLATION OF THE C FUNCTION ON PAGE 146 C OF THIS BOOK. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBRUG, 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 LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006.9 C ORIGINAL VERSION--MAY 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES----------------- C C------------------------------------------------------------------- C IMPLICIT DOUBLE PRECISION (A-H, O-Z) REAL CPUMAX, CPUMIN C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT 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 DEPS/1.0D-30/ C C-----START POINT--------------------------------------------------- C IF(NX.LT.1)THEN WRITE(ICOUT,51) 51 FORMAT('***** ERROR FROM GENEHARM FUNCTION--') CALL DPWRST('XXX','BUG') WRITE(ICOUT,53) 53 FORMAT(' THE FIRST ARGUMENT (N) MUST BE A POSITIVE ', 1 'INTEGER') CALL DPWRST('XXX','BUG') WRITE(ICOUT,55)NX 55 FORMAT(' VALUE OF THE ARGUMENT IS ',I8) CALL DPWRST('XXX','BUG') DHNM=0.0D0 GOTO9000 ELSEIF(DM.LE.1.0D0)THEN WRITE(ICOUT,51) CALL DPWRST('XXX','BUG') WRITE(ICOUT,63) 63 FORMAT(' THE SECOND ARGUMENT (M) MUST BE > 1') CALL DPWRST('XXX','BUG') WRITE(ICOUT,65)DM 65 FORMAT(' VALUE OF THE ARGUMENT IS ',G15.7) CALL DPWRST('XXX','BUG') DHNM=0.0D0 GOTO9000 ENDIF C CCCCC DX=DM C CCCCC DSTERM=DX*(DX+1.0D0)*(DX+2.0D0)* CCCCC1 (DX+3.0D0)*(DX+4.0D0)/30240.0D0 CCCCC DTERM1=DSTERM*(2.0D0**DX)/DEPS CCCCC DTERM2=DTERM1**(1.0D0/(DX+5.0D0)) CCCCC IF(DTERM2.LE.10.01)THEN CCCCC N=10 CCCCC ELSE CCCCC N=INT(DTERM2) CCCCC ENDIF C CCCCC DSUM2=0.0D0 CCCCC DO190I=1,MIN(N,NX) CCCCC DSUM2=DSUM2 + 1.0D0/DBLE(I)**DX CC190 CONTINUE CCCCC print *,'nx,n,dsum2=',nx,n,dsum2 C C FOR NOW, JUST COMPUTE BY DIRECT SUMMATION. NEED TO C FIND A BETTER ALGORITHM FOR THIS FUNCTION. C DX=DM N=NX CCCCC IF(N.LE.30)THEN DSUM=0.0D0 DO200I=N,1,-1 DSUM=DSUM + 1.0D0/DBLE(I)**DX 200 CONTINUE DHNM=DSUM C C OTHERWISE, USE ZETA APPROXIMATION WHERE N MAY BE C TRUNCATED SOONER THAN FOR ZETA. C CCCCC ELSE CCCCC FN=DBLE(N) CCCCC DNEGX=-DX CCCCC DSUM=0.0D0 CCCCC DO100K=2,N-1 CCCCC DSUM=DSUM + DBLE(K)**DNEGX C100 CONTINUE C CCCCC DSUM = DSUM + CCCCC1 (FN**DNEGX)*(0.5D0 + FN/(DX-1.0D0) CCCCC1 + DX*(1.0D0 - CCCCC1 (DX+1.0D0)*(DX+2.0D0)/(60.0D0*FN*FN))/(12.0D0*FN)) CCCCC1 + DSTERM/(FN**(DX+0.5D0)) C CCCCC DHNM=DSUM + 1.0D0 CCCCC ENDIF C 9000 CONTINUE RETURN END SUBROUTINE HOOKDR(NR,N,X,F,G,A,UDIAG,P,XPLS,FPLS, + SX,STEPMX, CDPLT+ OPTFCN,SX,STEPMX, + STEPTL,DLT,IRETCD,MXTAKE,AMU,DLTP,PHI,PHIP0, + SC,XPLSP,WRK0,EPSM,ITNCNT,IPR) IMPLICIT DOUBLE PRECISION (A-H,O-Z) C C PURPOSE C ------- C FIND A NEXT NEWTON ITERATE (XPLS) BY THE MORE-HEBDON METHOD C C PARAMETERS C ---------- C NR --> ROW DIMENSION OF MATRIX C N --> DIMENSION OF PROBLEM C X(N) --> OLD ITERATE X[K-1] C F --> FUNCTION VALUE AT OLD ITERATE, F(X) C G(N) --> GRADIENT AT OLD ITERATE, G(X), OR APPROXIMATE C A(N,N) --> CHOLESKY DECOMPOSITION OF HESSIAN IN LOWER C TRIANGULAR PART AND DIAGONAL. C HESSIAN IN UPPER TRIANGULAR PART AND UDIAG. C UDIAG(N) --> DIAGONAL OF HESSIAN IN A(.,.) C P(N) --> NEWTON STEP C XPLS(N) <-- NEW ITERATE X[K] C FPLS <-- FUNCTION VALUE AT NEW ITERATE, F(XPLS) C OPTFCN --> NAME OF SUBROUTINE TO EVALUATE FUNCTION C SX(N) --> DIAGONAL SCALING MATRIX FOR X C STEPMX --> MAXIMUM ALLOWABLE STEP SIZE C STEPTL --> RELATIVE STEP SIZE AT WHICH SUCCESSIVE ITERATES C CONSIDERED CLOSE ENOUGH TO TERMINATE ALGORITHM C DLT <--> TRUST REGION RADIUS C IRETCD <-- RETURN CODE C =0 SATISFACTORY XPLS FOUND C =1 FAILED TO FIND SATISFACTORY XPLS SUFFICIENTLY C DISTINCT FROM X C MXTAKE <-- BOOLEAN FLAG INDICATING STEP OF MAXIMUM LENGTH USED C AMU <--> [RETAIN VALUE BETWEEN SUCCESSIVE CALLS] C DLTP <--> [RETAIN VALUE BETWEEN SUCCESSIVE CALLS] C PHI <--> [RETAIN VALUE BETWEEN SUCCESSIVE CALLS] C PHIP0 <--> [RETAIN VALUE BETWEEN SUCCESSIVE CALLS] C SC(N) --> WORKSPACE C XPLSP(N) --> WORKSPACE C WRK0(N) --> WORKSPACE C EPSM --> MACHINE EPSILON C ITNCNT --> ITERATION COUNT C IPR --> DEVICE TO WHICH TO SEND OUTPUT C DIMENSION X(N),G(N),P(N),XPLS(N),SX(N) DIMENSION A(NR,1),UDIAG(N) DIMENSION SC(N),XPLSP(N),WRK0(N) LOGICAL MXTAKE,NWTAKE LOGICAL FSTIME CDPLT EXTERNAL OPTFCN C IRETCD=4 FSTIME=.TRUE. TMP=0. DO 5 I=1,N TMP=TMP+SX(I)*SX(I)*P(I)*P(I) 5 CONTINUE RNWTLN=SQRT(TMP) C$ WRITE(IPR,954) RNWTLN C IF(ITNCNT.GT.1) GO TO 100 C IF(ITNCNT.EQ.1) C THEN AMU=0. C C IF FIRST ITERATION AND TRUST REGION NOT PROVIDED BY USER, C COMPUTE INITIAL TRUST REGION. C IF(DLT.NE. (-1.)) GO TO 100 C IF(DLT.EQ. (-1.)) C THEN ALPHA=0. DO 10 I=1,N ALPHA=ALPHA+(G(I)*G(I))/(SX(I)*SX(I)) 10 CONTINUE BETA=0.0 DO 30 I=1,N TMP=0. DO 20 J=I,N TMP=TMP + (A(J,I)*G(J))/(SX(J)*SX(J)) 20 CONTINUE BETA=BETA+TMP*TMP 30 CONTINUE DLT=ALPHA*SQRT(ALPHA)/BETA DLT = MIN(DLT, STEPMX) C$ WRITE(IPR,950) C$ WRITE(IPR,951) ALPHA,BETA,DLT C ENDIF C ENDIF C 100 CONTINUE C C FIND NEW STEP BY MORE-HEBDON ALGORITHM CALL HOOKST(NR,N,G,A,UDIAG,P,SX,RNWTLN,DLT,AMU, + DLTP,PHI,PHIP0,FSTIME,SC,NWTAKE,WRK0,EPSM,IPR) DLTP=DLT C C CHECK NEW POINT AND UPDATE TRUST REGION CDPLT CALL TREGUP(NR,N,X,F,G,A,OPTFCN,SC,SX,NWTAKE,STEPMX,STEPTL, CALL TREGUP(NR,N,X,F,G,A,SC,SX,NWTAKE,STEPMX,STEPTL, + DLT,IRETCD,XPLSP,FPLSP,XPLS,FPLS,MXTAKE,IPR,3,UDIAG) IF(IRETCD.LE.1) RETURN GO TO 100 C CC950 FORMAT(43H HOOKDR INITIAL TRUST REGION NOT GIVEN. , CC + 21H COMPUTE CAUCHY STEP.) CC951 FORMAT(18H HOOKDR ALPHA =,E20.13/ CC + 18H HOOKDR BETA =,E20.13/ CC + 18H HOOKDR DLT =,E20.13) CC952 FORMAT(28H HOOKDR CURRENT STEP (SC)) CC954 FORMAT(18H0HOOKDR RNWTLN=,E20.13) CC955 FORMAT(14H HOOKDR ,5(E20.13,3X)) END SUBROUTINE HOOKST(NR,N,G,A,UDIAG,P,SX,RNWTLN,DLT,AMU, + DLTP,PHI,PHIP0,FSTIME,SC,NWTAKE,WRK0,EPSM,IPR) IMPLICIT DOUBLE PRECISION (A-H,O-Z) C C PURPOSE C ------- C FIND NEW STEP BY MORE-HEBDON ALGORITHM C C PARAMETERS C ---------- C NR --> ROW DIMENSION OF MATRIX C N --> DIMENSION OF PROBLEM C G(N) --> GRADIENT AT CURRENT ITERATE, G(X) C A(N,N) --> CHOLESKY DECOMPOSITION OF HESSIAN IN C LOWER TRIANGULAR PART AND DIAGONAL. C HESSIAN OR APPROX IN UPPER TRIANGULAR PART C UDIAG(N) --> DIAGONAL OF HESSIAN IN A(.,.) C P(N) --> NEWTON STEP C SX(N) --> DIAGONAL SCALING MATRIX FOR N C RNWTLN --> NEWTON STEP LENGTH C DLT <--> TRUST REGION RADIUS C AMU <--> [RETAIN VALUE BETWEEN SUCCESSIVE CALLS] C DLTP --> TRUST REGION RADIUS AT LAST EXIT FROM THIS ROUTINE C PHI <--> [RETAIN VALUE BETWEEN SUCCESSIVE CALLS] C PHIP0 <--> [RETAIN VALUE BETWEEN SUCCESSIVE CALLS] C FSTIME <--> BOOLEAN. =.TRUE. IF FIRST ENTRY TO THIS ROUTINE C DURING K-TH ITERATION C SC(N) <-- CURRENT STEP C NWTAKE <-- BOOLEAN, =.TRUE. IF NEWTON STEP TAKEN C WRK0 --> WORKSPACE C EPSM --> MACHINE EPSILON C IPR --> DEVICE TO WHICH TO SEND OUTPUT C DIMENSION G(N),P(N),SX(N),SC(N),WRK0(N) DIMENSION A(NR,1),UDIAG(N) LOGICAL NWTAKE,DONE LOGICAL FSTIME C C HI AND ALO ARE CONSTANTS USED IN THIS ROUTINE. C CHANGE HERE IF OTHER VALUES ARE TO BE SUBSTITUTED. IPR=IPR HI=1.5 ALO=.75 C ----- IF(RNWTLN.GT.HI*DLT) GO TO 15 C IF(RNWTLN.LE.HI*DLT) C THEN C C TAKE NEWTON STEP C NWTAKE=.TRUE. DO 10 I=1,N SC(I)=P(I) 10 CONTINUE DLT=MIN(DLT,RNWTLN) AMU=0. C$ WRITE(IPR,951) RETURN C ELSE C C NEWTON STEP NOT TAKEN C 15 CONTINUE C$ WRITE(IPR,952) NWTAKE=.FALSE. IF(AMU.LE.0.) GO TO 20 C IF(AMU.GT.0.) C THEN AMU=AMU- (PHI+DLTP) *((DLTP-DLT)+PHI)/(DLT*PHIP) C$ WRITE(IPR,956) AMU C ENDIF 20 CONTINUE PHI=RNWTLN-DLT IF(.NOT.FSTIME) GO TO 28 C IF(FSTIME) C THEN DO 25 I=1,N WRK0(I)=SX(I)*SX(I)*P(I) 25 CONTINUE C C SOLVE L*Y = (SX**2)*P C CALL FORSLV(NR,N,A,WRK0,WRK0) PHIP0=-DNRM2(N,WRK0,1)**2/RNWTLN FSTIME=.FALSE. C ENDIF 28 PHIP=PHIP0 AMULO=-PHI/PHIP AMUUP=0.0 DO 30 I=1,N AMUUP=AMUUP+(G(I)*G(I))/(SX(I)*SX(I)) 30 CONTINUE AMUUP=SQRT(AMUUP)/DLT DONE=.FALSE. C$ WRITE(IPR,956) AMU C$ WRITE(IPR,959) PHI C$ WRITE(IPR,960) PHIP C$ WRITE(IPR,957) AMULO C$ WRITE(IPR,958) AMUUP C C TEST VALUE OF AMU; GENERATE NEXT AMU IF NECESSARY C 100 CONTINUE IF(DONE) RETURN C$ WRITE(IPR,962) IF(AMU.GE.AMULO .AND. AMU.LE.AMUUP) GO TO 110 C IF(AMU.LT.AMULO .OR. AMU.GT.AMUUP) C THEN AMU=MAX(SQRT(AMULO*AMUUP),AMUUP*1.0E-3) C$ WRITE(IPR,956) AMU C ENDIF 110 CONTINUE C C COPY (H,UDIAG) TO L C WHERE H <-- H+AMU*(SX**2) [DO NOT ACTUALLY CHANGE (H,UDIAG)] DO 130 J=1,N A(J,J)=UDIAG(J) + AMU*SX(J)*SX(J) IF(J.EQ.N) GO TO 130 JP1=J+1 DO 120 I=JP1,N A(I,J)=A(J,I) 120 CONTINUE 130 CONTINUE C C FACTOR H=L(L+) C CALL CHOLDC(NR,N,A,0.0D0,SQRT(EPSM),ADDMAX) C C SOLVE H*P = L(L+)*SC = -G C DO 140 I=1,N WRK0(I)=-G(I) 140 CONTINUE CALL LLTSLV(NR,N,A,SC,WRK0) C$ WRITE(IPR,955) C$ WRITE(IPR,963) (SC(I),I=1,N) C C RESET H. NOTE SINCE UDIAG HAS NOT BEEN DESTROYED WE NEED DO C NOTHING HERE. H IS IN THE UPPER PART AND IN UDIAG, STILL INTACT C STEPLN=0. DO 150 I=1,N STEPLN=STEPLN + SX(I)*SX(I)*SC(I)*SC(I) 150 CONTINUE STEPLN=SQRT(STEPLN) PHI=STEPLN-DLT DO 160 I=1,N WRK0(I)=SX(I)*SX(I)*SC(I) 160 CONTINUE CALL FORSLV(NR,N,A,WRK0,WRK0) PHIP=-DNRM2(N,WRK0,1)**2/STEPLN C$ WRITE(IPR,961) DLT,STEPLN C$ WRITE(IPR,959) PHI C$ WRITE(IPR,960) PHIP IF((ALO*DLT.GT.STEPLN .OR. STEPLN.GT.HI*DLT) .AND. + (AMUUP-AMULO.GT.0.)) GO TO 170 C IF((ALO*DLT.LE.STEPLN .AND. STEPLN.LE.HI*DLT) .OR. C (AMUUP-AMULO.LE.0.)) C THEN C C SC IS ACCEPTABLE HOOKSTEP C C$ WRITE(IPR,954) DONE=.TRUE. GO TO 100 C ELSE C C SC NOT ACCEPTABLE HOOKSTEP. SELECT NEW AMU C 170 CONTINUE C$ WRITE(IPR,953) AMULO=MAX(AMULO,AMU-(PHI/PHIP)) IF(PHI.LT.0.) AMUUP=MIN(AMUUP,AMU) AMU=AMU-(STEPLN*PHI)/(DLT*PHIP) C$ WRITE(IPR,956) AMU C$ WRITE(IPR,957) AMULO C$ WRITE(IPR,958) AMUUP GO TO 100 C ENDIF C ENDIF C 951 FORMAT(27H0HOOKST TAKE NEWTON STEP) 952 FORMAT(32H0HOOKST NEWTON STEP NOT TAKEN) 953 FORMAT(31H HOOKST SC IS NOT ACCEPTABLE) 954 FORMAT(27H HOOKST SC IS ACCEPTABLE) 955 FORMAT(28H HOOKST CURRENT STEP (SC)) 956 FORMAT(18H HOOKST AMU =,E20.13) 957 FORMAT(18H HOOKST AMULO =,E20.13) 958 FORMAT(18H HOOKST AMUUP =,E20.13) 959 FORMAT(18H HOOKST PHI =,E20.13) 960 FORMAT(18H HOOKST PHIP =,E20.13) 961 FORMAT(18H HOOKST DLT =,E20.13/ + 18H HOOKST STEPLN=,E20.13) 962 FORMAT(23H0HOOKST FIND NEW AMU) 963 FORMAT(14H HOOKST ,5(E20.13,3X)) END SUBROUTINE HORIND(X,XMIN,XMAX,I1,I2,I,IBUGU2,ISUBRO,IERROR) C C PURPOSE--TRANSLATE A FLOATING POINT NUMBER C BETWEEN XMIN AND XMAX C INTO AN INTEGER INDEX BETWEEN I1 AND I2. C THIS IS USED IN REFERENCING ELEMENTS C IN HTE HORIZON TABLES USED IN C 3-D HIDDEN LINE REMOVAL. C C--------------------------------------------------------------------- C CHARACTER*4 IBUGU2 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C ************************************************** C ** STEP 11-- ** C ** COMPUTE THE INTEGER INDEX. ** C ************************************************** C P=(X-XMIN)/(XMAX-XMIN) AI1=I1 AI2=I2 AI=AI1+P*(AI2-AI1) I=AI+0.5 C C ************************************************** C ** STEP 90-- ** C ** EXIT. ** C ************************************************** C IF(IBUGU2.EQ.'ON'.OR.ISUBRO.EQ.'NDEX')GOTO9010 GOTO9090 9010 CONTINUE CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,9011) C9011 FORMAT('AT THE END OF HORIND--') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,9012)X,XMIN,XMAX C9012 FORMAT('X,XMIN,XMAX = ',3E15.7) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,9013)I1,I2,I C9013 FORMAT('I1,I2,I = ',3I8) CCCCC CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)X,XMIN,XMAX,I1,I2,I 9014 FORMAT('FROM HORIND--X,XMIN,XMAX,I1,I2,I = ',3E15.7,3I8) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE HPBRES(IXSTRT,IYSTRT,IXSTOP,IYSTOP, * ICOLOR,IWIDTH) C C THIS SUBROUTINE IMPLEMENTS THE BRESENHAM ALGORITHM FOR C GENERATING A VECTOR LINE ON AN HP-LASER JET PRINTER. C C IXSTRT - X COORDINATE OF START POINT OF THE LINE C IYSTRT - Y COORDINATE OF START POINT OF THE LINE C IXSTOP - X COORDINATE OF END POINT OF THE LINE C IYSTOP - Y COORDINATE OF END POINT OF THE LINE C ICOLOR - COLOR THE POINT SHOULD BE PLOTTED AS C (NULL FOR NOW SINCE ALL CURRENT LASER JET PRINTERS ARE C BLACK AND WHITE) C IWIDTH - WIDTH OF LINE IN PIXELS (SHOULD BE ODD INTEGER) C C NOTE: THIS ROUTINE GENERATES INDIVIDUAL VECTORS, WHICH CAN GENERATE C AN EXTREMELY LARGE NUMBER OF POINTS FOR COMPLEX PLOTS. AN C ALTERNATIVE IS TO A STORE THE VECTORIZED POINTS IN AN ARRAY C AND USE THE PCL RASTER GRAPHICS COMMANDS TO PRINT AN ENTIRE C PAGE AT ONE TIME. C C THE METHOD TO DRAW A LINE IS TO MOVE TO A POINT AND THEN DRAW A C RECTANGLE OF GIVEN HEIGHT AND WIDTH. THE HEIGHT WILL BE 1 AND THE C WIDTH IS THE DETERMINED BY THE DESIRED WIDTH OF THE LINE (3 PIXELS C BY DEFAULT). C C THE RECTANGLE GRAPHICS COMMANDS ARE: C C *pX - MOVE TO X COORDINATE (IN DOTS) C *pY - MOVE TO Y COORDINATE (IN DOTS) C *cA - HORIZONTAL SIZE OF RECTANGLE (IN DOTS) C *cB - VERTICAL SIZE OF RECTANGLE (IN DOTS) C *c0P - DRAW THE SOLID FILLED RECTANGLE C C THE RASTER GRAPHICS COMMANDS ARE: C C *t#R - RESOLUTION (#=75,100,150 OR 300) C *r#A - SET LEFT MARGIN (#=0 FOR 0, #=1 FOR CURRENT C X POSITION) C *rB - END RASTER GRAPHICS C *b#W[DATA] - SEND BYTES OF RASTER DATA, EACH BYTE SETS C 8 DOTS (1=ON, 0=OFF), #=NUMBER OF BYTES C CCCCC INTEGER IXCOOR,IYCOOR CHARACTER*(*) ICOLOR CHARACTER*4 ISUBN0 CHARACTER*130 ICSTR C INCLUDE 'DPCONP.INC' C C BRESENHAM PARAMETER INITIALIZATION C ISUBN0='BRES' IERROR=0 IDELX=IXSTOP-IXSTRT IDELY=IYSTOP-IYSTRT INCX=SIGN(1,IDELX) INCY=SIGN(1,IDELY) IADELX=ABS(IDELX) IADELY=ABS(IDELY) IXNEW=IXSTRT IYNEW=IYSTRT ICSTR=' ' C C TEST FOR VERTICAL LINE C IF(IXSTRT.EQ.IXSTOP) THEN ICSTR(1:1)=IESCC ICSTR(2:3)='*p' IXTEMP=IXSTRT-IWIDTH/2 NCSTR=3 NCHTOT=4 CALL GRTRIN(IXTEMP,NCHTOT,ICSTR,NCSTR) ICSTR(8:8)='x' NCSTR=8 CALL GRTRIN(IYSTRT,NCHTOT,ICSTR,NCSTR) ICSTR(13:13)='Y' ICSTR(14:14)=IESCC ICSTR(15:16)='*c' NCHTOT=2 NCSTR=16 CALL GRTRIN(IWIDTH,NCHTOT,ICSTR,NCSTR) ICSTR(19:19)='a' NCHTOT=4 NCSTR=19 IYTEMP=ABS(IYSTOP-IYSTRT)+1 CALL GRTRIN(IYTEMP,NCHTOT,ICSTR,NCSTR) ICSTR(24:24)='b' ICSTR(25:26)='0P' NCSTR=26 CALL GRWRST(ICSTR,NCSTR,ISUBN0) GOTO999 END IF C C TEST FOR HORIZONTAL LINE C IF(IYSTRT.EQ.IYSTOP) THEN ICSTR(1:1)=IESCC ICSTR(2:3)='*p' IYTEMP=IYSTRT-IWIDTH/2 NCSTR=3 NCHTOT=4 CALL GRTRIN(IXSTRT,NCHTOT,ICSTR,NCSTR) ICSTR(8:8)='x' NCSTR=8 CALL GRTRIN(IYTEMP,NCHTOT,ICSTR,NCSTR) ICSTR(13:13)='Y' ICSTR(14:14)=IESCC ICSTR(15:16)='*c' NCHTOT=2 NCSTR=16 CALL GRTRIN(IWIDTH,NCHTOT,ICSTR,NCSTR) ICSTR(19:19)='b' NCHTOT=4 NCSTR=19 IYTEMP=ABS(IYSTOP-IYSTRT)+1 CALL GRTRIN(IYTEMP,NCHTOT,ICSTR,NCSTR) ICSTR(24:24)='a' ICSTR(25:26)='0P' NCSTR=26 CALL GRWRST(ICSTR,NCSTR,ISUBN0) GOTO999 END IF C C BRESENHAM ALGORITHM. TWO CASES: WHERE X INCRESES FASTER THAN C Y AND WHERE Y INCREASES FASTER THAN X. C C CASE 1: X INCRESES FASTER THAN Y C IF(IADELX.GE.IADELY) THEN IHALF=IADELX/2 ICSTR(1:1)=IESCC ICSTR(2:13)='*p x Y' ICSTR(14:14)=IESCC ICSTR(15:19)='*c b' ICSTR(20:21)='1a' ICSTR(22:23)='0P' ICSTR(24:46)=ICSTR(1:23) ICSTR(47:69)=ICSTR(1:23) ICSTR(70:92)=ICSTR(1:23) ICSTR(93:115)=ICSTR(1:23) NGEN=IADELX+1 DO 100 I=1,NGEN C NFACT=(MOD(I,5)-1)*23 IYTEMP=IYNEW-IWIDTH/2 NCSTR=NFACT+3 NCHTOT=4 CALL GRTRIN(IXNEW,NCHTOT,ICSTR,NCSTR) NCSTR=NFACT+8 CALL GRTRIN(IYTEMP,NCHTOT,ICSTR,NCSTR) NCHTOT=2 NCSTR=NFACT+16 CALL GRTRIN(IWIDTH,NCHTOT,ICSTR,NCSTR) NCSTR=(NFACT+1)*23 IF(NCSTR.GE.115)CALL GRWRST(ICSTR,NCSTR,ISUBN0) C IXNEW=IXNEW+INCX IERROR=IERROR+IADELY IF(IERROR.GT.IHALF) THEN IERROR=IERROR-IADELX IYNEW=IYNEW+INCY END IF 100 CONTINUE IF(NCSTR.LT.115)CALL GRWRST(ICSTR,NCSTR,ISUBN0) ELSE C C CASE 2: Y INCRESES FASTER THAN X C IHALF=IADELY/2 ICSTR(1:1)=IESCC ICSTR(2:13)='*p x Y' ICSTR(14:14)=IESCC ICSTR(15:19)='*c a' ICSTR(20:21)='1b' ICSTR(22:23)='0P' ICSTR(24:46)=ICSTR(1:23) ICSTR(47:69)=ICSTR(1:23) ICSTR(70:92)=ICSTR(1:23) ICSTR(93:115)=ICSTR(1:23) NGEN=IADELY+1 DO 200 I=1,NGEN C NFACT=(MOD(I,5)-1)*23 IXTEMP=IXNEW-IWIDTH/2 NCSTR=NFACT+3 NCHTOT=4 CALL GRTRIN(IXTEMP,NCHTOT,ICSTR,NCSTR) NCSTR=NFACT+8 CALL GRTRIN(IYNEW,NCHTOT,ICSTR,NCSTR) NCHTOT=2 NCSTR=NFACT+16 CALL GRTRIN(IWIDTH,NCHTOT,ICSTR,NCSTR) NCSTR=(NFACT+1)*23 IF(NCSTR.GE.115)CALL GRWRST(ICSTR,NCSTR,ISUBN0) C IYNEW=IYNEW+INCY IERROR=IERROR+IADELX IF(IERROR.GT.IHALF) THEN IERROR=IERROR-IADELY IXNEW=IXNEW+INCX END IF 200 CONTINUE IF(NCSTR.LT.115)CALL GRWRST(ICSTR,NCSTR,ISUBN0) END IF C C END C 999 CONTINUE RETURN END SUBROUTINE HPSORT (HX, N, STRBEG, STREND, IPERM, KFLAG, WORK, IER) C***BEGIN PROLOGUE HPSORT C***PURPOSE Return the permutation vector generated by sorting a C substring within a character array and, optionally, C rearrange the elements of the array. The array may be C sorted in forward or reverse lexicographical order. A C slightly modified quicksort algorithm is used. C***LIBRARY SLATEC C***CATEGORY N6A1C, N6A2C C***TYPE CHARACTER (SPSORT-S, DPSORT-D, IPSORT-I, HPSORT-H) C***KEYWORDS PASSIVE SORTING, SINGLETON QUICKSORT, SORT, STRING SORTING C***AUTHOR Jones, R. E., (SNLA) C Rhoads, G. S., (NBS) C Sullivan, F. E., (NBS) C Wisniewski, J. A., (SNLA) C***DESCRIPTION C C HPSORT returns the permutation vector IPERM generated by sorting C the substrings beginning with the character STRBEG and ending with C the character STREND within the strings in array HX and, optionally, C rearranges the strings in HX. HX may be sorted in increasing or C decreasing lexicographical order. A slightly modified quicksort C algorithm is used. C C IPERM is such that HX(IPERM(I)) is the Ith value in the C rearrangement of HX. IPERM may be applied to another array by C calling IPPERM, SPPERM, DPPERM or HPPERM. C C An active sort of numerical data is expected to execute somewhat C more quickly than a passive sort because there is no need to use C indirect references. But for the character data in HPSORT, integers C in the IPERM vector are manipulated rather than the strings in HX. C Moving integers may be enough faster than moving character strings C to more than offset the penalty of indirect referencing. C C Description of Parameters C HX - input/output -- array of type character to be sorted. C For example, to sort a 80 element array of names, C each of length 6, declare HX as character HX(100)*6. C If ABS(KFLAG) = 2, then the values in HX will be C rearranged on output; otherwise, they are unchanged. C N - input -- number of values in array HX to be sorted. C STRBEG - input -- the index of the initial character in C the string HX that is to be sorted. C STREND - input -- the index of the final character in C the string HX that is to be sorted. C IPERM - output -- permutation array such that IPERM(I) is the C index of the string in the original order of the C HX array that is in the Ith location in the sorted C order. C KFLAG - input -- control parameter: C = 2 means return the permutation vector resulting from C sorting HX in lexicographical order and sort HX also. C = 1 means return the permutation vector resulting from C sorting HX in lexicographical order and do not sort C HX. C = -1 means return the permutation vector resulting from C sorting HX in reverse lexicographical order and do C not sort HX. C = -2 means return the permutation vector resulting from C sorting HX in reverse lexicographical order and sort C HX also. C WORK - character variable which must have a length specification C at least as great as that of HX. C IER - output -- error indicator: C = 0 if no error, C = 1 if N is zero or negative, C = 2 if KFLAG is not 2, 1, -1, or -2, C = 3 if work array is not long enough, C = 4 if string beginning is beyond its end, C = 5 if string beginning is out-of-range, C = 6 if string end is out-of-range. C C E X A M P L E O F U S E C C CHARACTER*2 HX, W C INTEGER STRBEG, STREND C DIMENSION HX(10), IPERM(10) C DATA (HX(I),I=1,10)/ '05','I ',' I',' ','Rs','9R','R9','89', C 1 ',*','N"'/ C DATA STRBEG, STREND / 1, 2 / C CALL HPSORT (HX,10,STRBEG,STREND,IPERM,1,W) C PRINT 100, (HX(IPERM(I)),I=1,10) C 100 FORMAT (2X, A2) C STOP C END C C***REFERENCES R. C. Singleton, Algorithm 347, An efficient algorithm C for sorting with minimal storage, Communications of C the ACM, 12, 3 (1969), pp. 185-187. C***ROUTINES CALLED XERMSG C***REVISION HISTORY (YYMMDD) C 761101 DATE WRITTEN C 761118 Modified by John A. Wisniewski to use the Singleton C quicksort algorithm. C 811001 Modified by Francis Sullivan for string data. C 850326 Documentation slightly modified by D. Kahaner. C 870423 Modified by Gregory S. Rhoads for passive sorting with the C option for the rearrangement of the original data. C 890620 Algorithm for rearranging the data vector corrected by R. C Boisvert. C 890622 Prologue upgraded to Version 4.0 style by D. Lozier. C 920507 Modified by M. McClain to revise prologue text. C 920818 Declarations section rebuilt and code restructured to use C IF-THEN-ELSE-ENDIF. (SMR, WRB) C***END PROLOGUE HPSORT C .. Scalar Arguments .. INTEGER IER, KFLAG, N, STRBEG, STREND CHARACTER * (*) WORK C .. Array Arguments .. INTEGER IPERM(*) CHARACTER * (*) HX(*) C .. Local Scalars .. REAL R INTEGER I, IJ, INDX, INDX0, IR, ISTRT, J, K, KK, L, LM, LMT, M, + NN, NN2 C .. Local Arrays .. INTEGER IL(21), IU(21) C .. External Subroutines .. CCCCC EXTERNAL XERMSG C .. Intrinsic Functions .. INTRINSIC ABS, INT, LEN C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C***FIRST EXECUTABLE STATEMENT HPSORT IER = 0 NN = N IF (NN .LT. 1) THEN IER = 1 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,901) 901 FORMAT('***** ERROR IN HPSORT (SORTING CHARACTER DATA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,903) 903 FORMAT(' THE NUMBER OF VALUES TO BE SORTED IS ', 1 'NON-POSITIVE') CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF KK = ABS(KFLAG) IF (KK.NE.1 .AND. KK.NE.2) THEN IER = 2 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,901) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,921) 921 FORMAT(' THE SORT CONTROL PARAMETER HAS AN INVALID ', 1 'VALUE.') CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF C IF(LEN(WORK) .LT. LEN(HX(1))) THEN IER = 3 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,901) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,931) 931 FORMAT(' THE LENGTH OF THE WORK VARIABLE IS TOO SHORT.') CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF IF (STRBEG .GT. STREND) THEN IER = 4 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,901) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,941)STRBEG,STREND 941 FORMAT(' THE STRING BEGINNING, ',I8,' IS BEYOND ITS ', 1 'END, ',I8,' .') CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF IF (STRBEG .LT. 1 .OR. STRBEG .GT. LEN(HX(1))) THEN IER = 5 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,901) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,951)STRBEG 951 FORMAT(' THE STRING BEGINNING, ',I8,' IS OUT-OF-RANGE.') CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF IF (STREND .LT. 1 .OR. STREND .GT. LEN(HX(1))) THEN IER = 6 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,901) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,961)STREND 961 FORMAT(' THE STRING END, ',I8,' IS OUT-OF-RANGE.') CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF C C Initialize permutation vector C DO 10 I=1,NN IPERM(I) = I 10 CONTINUE C C Return if only one value is to be sorted C IF (NN .EQ. 1) RETURN C C Sort HX only C M = 1 I = 1 J = NN R = .375E0 C 20 IF (I .EQ. J) GO TO 70 IF (R .LE. 0.5898437E0) THEN R = R+3.90625E-2 ELSE R = R-0.21875E0 ENDIF C 30 K = I C C Select a central element of the array and save it in location L C IJ = I + INT((J-I)*R) LM = IPERM(IJ) C C If first element of array is greater than LM, interchange with LM C IF (HX(IPERM(I))(STRBEG:STREND) .GT. HX(LM)(STRBEG:STREND)) THEN IPERM(IJ) = IPERM(I) IPERM(I) = LM LM = IPERM(IJ) ENDIF L = J C C If last element of array is less than LM, interchange with LM C IF (HX(IPERM(J))(STRBEG:STREND) .LT. HX(LM)(STRBEG:STREND)) THEN IPERM(IJ) = IPERM(J) IPERM(J) = LM LM = IPERM(IJ) C C If first element of array is greater than LM, interchange C with LM C IF (HX(IPERM(I))(STRBEG:STREND) .GT. HX(LM)(STRBEG:STREND)) + THEN IPERM(IJ) = IPERM(I) IPERM(I) = LM LM = IPERM(IJ) ENDIF ENDIF GO TO 50 40 LMT = IPERM(L) IPERM(L) = IPERM(K) IPERM(K) = LMT C C Find an element in the second half of the array which is smaller C than LM C 50 L = L-1 IF (HX(IPERM(L))(STRBEG:STREND) .GT. HX(LM)(STRBEG:STREND)) + GO TO 50 C C Find an element in the first half of the array which is greater C than LM C 60 K = K+1 IF (HX(IPERM(K))(STRBEG:STREND) .LT. HX(LM)(STRBEG:STREND)) + GO TO 60 C C Interchange these elements C IF (K .LE. L) GO TO 40 C C Save upper and lower subscripts of the array yet to be sorted C IF (L-I .GT. J-K) THEN IL(M) = I IU(M) = L I = K M = M+1 ELSE IL(M) = K IU(M) = J J = L M = M+1 ENDIF GO TO 80 C C Begin again on another portion of the unsorted array C 70 M = M-1 IF (M .EQ. 0) GO TO 110 I = IL(M) J = IU(M) C 80 IF (J-I .GE. 1) GO TO 30 IF (I .EQ. 1) GO TO 20 I = I-1 C 90 I = I+1 IF (I .EQ. J) GO TO 70 LM = IPERM(I+1) IF (HX(IPERM(I))(STRBEG:STREND) .LE. HX(LM)(STRBEG:STREND)) + GO TO 90 K = I C 100 IPERM(K+1) = IPERM(K) K = K-1 C IF (HX(LM)(STRBEG:STREND) .LT. HX(IPERM(K))(STRBEG:STREND)) + GO TO 100 IPERM(K+1) = LM GO TO 90 C C Clean up C 110 IF (KFLAG .LE. -1) THEN C C Alter array to get reverse order, if necessary C NN2 = NN/2 DO 120 I=1,NN2 IR = NN-I+1 LM = IPERM(I) IPERM(I) = IPERM(IR) IPERM(IR) = LM 120 CONTINUE ENDIF C C Rearrange the values of HX if desired C IF (KK .EQ. 2) THEN C C Use the IPERM vector as a flag. C If IPERM(I) < 0, then the I-th value is in correct location C DO 140 ISTRT=1,NN IF (IPERM(ISTRT) .GE. 0) THEN INDX = ISTRT INDX0 = INDX WORK = HX(ISTRT) 130 IF (IPERM(INDX) .GT. 0) THEN HX(INDX) = HX(IPERM(INDX)) INDX0 = INDX IPERM(INDX) = -IPERM(INDX) INDX = ABS(IPERM(INDX)) GO TO 130 ENDIF HX(INDX0) = WORK ENDIF 140 CONTINUE C C Revert the signs of the IPERM values C DO 150 I=1,NN IPERM(I) = -IPERM(I) 150 CONTINUE C ENDIF C 9999 CONTINUE RETURN END SUBROUTINE HPTRPT(IXC,IYC,ICSTR,NCSTR,ISUBN0) C C PURPOSE--TRANSLATE AN INTEGER PAIR OF COORDINATES C (HP MBP = MULTIPLE BYTE PAIR OF NUMBERS) C INTO A 5-BYTE PACKED CHARACTER REPRESENTATION C THAT WILL BE UNDERSTOOD BY A HEWLETT-PACKARD C GRAPHICS DEVICE. C NOTE--THE RESULTING PACKED WORDS C WILL BE PLACED IN SPECIFIC ELEMENTS C OF THE CHARACTER*130 VARIABLE ICSTR(.:.). C THE VALUE OF THE VARIABLE NCSTR C REPRESENTS THE NUMBER OF ELEMENTS IN ICSTR(.:.) C THAT HAVE ALREADY BEEN FILLED. C THE RESULTING PACKED WORDS WILL GO INTO C THE NEXT AVAILABLE ELEMENTS OF ICSTR(.:.) C AND THE VALUE OF NCSTR WILL BE C UPDATED ACCORDINGLY. C NOTE--MORE COMPACT (1 TO 4-BYTE REPRESENTATIONS) C ARE POSSIBLE FOR HP DEVICES FOR SMALLER C RANGES (0 TO 3, 0 TO 31, 0 TO 255, AND C 0 TO 2047, RESPECTIVELY) OF THE INPUT X AND Y C COORDINATES. C THIS SUBROUTINE IS GENERAL AND TREATS ALL C X AND Y VALUES FROM 0 TO 2**14-1 (= 16383). C THE OUTPUT WILL THUS ALWAYS BE A 5-BYTE C REPRESENTATION. C DANGER--NCSTR IS BOTH AN INPUT ARGUMENT C AND AN OUTPUT ARGUMENT OF THIS SUBROUTINE. C NOTE--ISUBN0 = NAME OF SUBROUTINE WHICH CALLED HPTRPT C (AND THEREBY HAVE WALKBACK INFORMATION). C REFERENCE--HP 7221 C AND HP 7221T GRAPHICS PLOTTER C OPERATING AND PROGRAMMING MANUAL, C PAGES 71-72 AND 319. C C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-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--83.6 C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH 1984. C C-----NON-COMMON VARIABLES (GRAPHICS)------------------------------------------- C CHARACTER*4 ISUBN0 C CHARACTER*130 ICSTR C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOGR.INC' INCLUDE 'DPCOBE.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS----------------------------------------------- C DATA K2/4/ DATA K4/16/ DATA K6/64/ DATA K10/1024/ DATA K12/4096/ C C-----START POINT----------------------------------------------------- C IERRG4='NO' C IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'TRPT')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF HPTRPT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ISUBN0 52 FORMAT('ISUBN0 (NAME OF THE CALLING SUBROUTINE) = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IXC,IYC 53 FORMAT('IXC,IYC = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)K2,K4,K6,K10,K12 55 FORMAT('K2,K4,K6,K10,K12 = ',5I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,56)IGUNIT 56 FORMAT('IGUNIT = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,63)NCSTR 63 FORMAT('NCSTR = ',I8) CALL DPWRST('XXX','BUG ') IF(NCSTR.LE.0)GOTO67 DO65I=1,NCSTR CCCCC IASCNE=ICHAR(ICSTR(I:I)) CALL DPCOAN(ICSTR(I:I),IASCNE) WRITE(ICOUT,66)I,ICSTR(I:I),IASCNE 66 FORMAT('I,ICSTR(I:I),IASCNE = ',I8,2X,A1,I8) CALL DPWRST('XXX','BUG ') 65 CONTINUE 67 CONTINUE WRITE(ICOUT,69)IBUGG4,ISUBG4,IERRG4 69 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C IVX=IXC IVY=IYC IF(IVX.LT.0)IVX=0 IF(IVY.LT.0)IVY=0 C C ****************************************************** C ** STEP 1-- ** C ** FORM THE HIGH-X 7-BIT BYTE-- ** C ** THE LEFT 3 BITS ARE 1 1 0; ** C ** THE RIGHT 4 BITS = BITS 13 TO 10 OF X. ** C ** SHIFT THE X VALUE TO THE RIGHT 10 PLACES; ** C ** THEN KEEP ONLY THE RIGHT 4 PLACES; ** C ** THEN PLACE A 1 1 0 IN BITS 6, 5, AND 4 ** C ** (WHERE BIT 6 = LEFT-MOST BIT IN A 7-BIT BYTE). ** C ****************************************************** C NCSTR=NCSTR+1 IBYTE1=MOD(IVX/K10,K4)+96 CCCCC ICSTR(NCSTR:NCSTR)=CHAR(IBYTE1) CALL DPCONA(IBYTE1,ICSTR(NCSTR:NCSTR)) C C *************************************************************** C ** STEP 2-- ** C ** FORM THE MIDDLE-X 7-BIT BYTE-- ** C ** THE LEFT BIT IS THE COMPLEMENT OF THE NEXT-TO-LEFT BIT; ** C ** THE RIGHT 6 BITS = BITS 9 TO 4 OF X. ** C ** SHIFT THE X VALUE TO THE RIGHT 4 PLACES; ** C ** THEN KEEP ONLY THE RIGHT 6 PLACES; ** C ** THEN IF NEW BIT 5 = 0, PLACE A 1 IN NEW BIT 6, ** C ** OR IF NEW BIT 5 = 1, PLACE A 0 IN NEW BIT 6. ** C *************************************************************** C NCSTR=NCSTR+1 IBYTE2=MOD(IVX/K4,K6) IF(IBYTE2.LE.31)IBYTE2=IBYTE2+64 CCCCC ICSTR(NCSTR:NCSTR)=CHAR(IBYTE2) CALL DPCONA(IBYTE2,ICSTR(NCSTR:NCSTR)) C C *************************************************************** C ** STEP 3-- ** C ** FORM THE SHARED (LOW-X, HIGH Y) 7-BIT BYTE-- ** C ** THE LEFT BIT IS THE COMPLEMENT OF THE NEXT-TO-LEFT BIT; ** C ** THE NEXT 4 BITS = BITS 3 TO 0 OF X; ** C ** THE RIGHT 2 BITS = BITS 13 AND 12 OF Y. ** C ** KEEP ONLY THE RIGHT 4 BITS OF X; ** C ** SHIFT THESE 4 BITS TO THE LEFT 2 PLACES; ** C ** SHIFT THE Y VALUE TO THE RIGHT 12 PLACES; ** C ** THEN KEEP ONLY THE RIGHT 2 BITS; ** C ** THEN MERGE THE 4 X BITS AND THE 2 Y BITS; ** C ** FINALLY, IF NEW BIT 5 = 0, PLACE A 1 IN NEW BIT 6, ** C ** OR IF NEW BIT 5 = 1, PLACE A 0 IN NEW BIT 6. ** C *************************************************************** C NCSTR=NCSTR+1 IBYTE3=MOD(IVX,K4)*K2+MOD(IVY/K12,K2) IF(IBYTE3.LE.31)IBYTE3=IBYTE3+64 CCCCC ICSTR(NCSTR:NCSTR)=CHAR(IBYTE3) CALL DPCONA(IBYTE3,ICSTR(NCSTR:NCSTR)) C C *************************************************************** C ** STEP 4-- ** C ** FORM THE MIDDLE-Y 7-BIT BYTE-- ** C ** THE LEFT BIT IS THE COMPLEMENT OF THE NEXT-TO-LEFT BIT; ** C ** THE RIGHT 6 BITS = BITS 11 TO 6 OF Y. ** C ** SHIFT THE Y VALUE 6 PLACES TO THE RIGHT; ** C ** THEN KEEP ONLY THE RIGHT 6 PLACES; ** C ** THEN IF NEW BIT 5 = 0, PLACE A 1 IN NEW BIT 6, ** C ** OR IF NEW BIT 5 = 1, PLACE A 0 IN NEW BIT 6. ** C *************************************************************** C NCSTR=NCSTR+1 IBYTE4=MOD(IVY/K6,K6) IF(IBYTE4.LE.31)IBYTE4=IBYTE4+64 CCCCC ICSTR(NCSTR:NCSTR)=CHAR(IBYTE4) CALL DPCONA(IBYTE4,ICSTR(NCSTR:NCSTR)) C C *************************************************************** C ** STEP 5-- ** C ** FORM THE LOW-Y 7-BIT BYTE-- ** C ** THE LEFT BIT IS THE COMPLEMENT OF THE NEXT-TO-LEFT BIT; ** C ** THE RIGHT 6 BITS = BITS 5 TO 0 OF Y. ** C ** KEEP ONLY THE RIGHT 6 BITS OF Y; ** C ** THEN IF NEW BIT 5 = 0, PLACE A 1 IN NEW BIT 6, ** C ** OR IF NEW BIT 5 = 1, PLACE A 0 IN NEW BIT 6. ** C *************************************************************** C NCSTR=NCSTR+1 IBYTE5=MOD(IVY,K6) IF(IBYTE5.LE.31)IBYTE5=IBYTE5+64 CCCCC ICSTR(NCSTR:NCSTR)=CHAR(IBYTE5) CALL DPCONA(IBYTE5,ICSTR(NCSTR:NCSTR)) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'TRPT')GOTO9090 9011 FORMAT('***** AT THE END OF TKTRPT--') WRITE(ICOUT,9012)IXC,IYC 9012 FORMAT('IXC,IYC = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IVX,IVY 9013 FORMAT('IVX,IVY = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)K2,K4,K6,K10,K12 9015 FORMAT('K2,K4,K6,K10,K12 = ',5I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)IGUNIT 9016 FORMAT('IGUNIT = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9017)IBYTE1,IBYTE2,IBYTE3,IBYTE4,IBYTE5 9017 FORMAT('IBYTE1,IBYTE2,IBYTE3,IBYTE4,IBYTE5 = ',5I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9023)NCSTR 9023 FORMAT('NCSTR = ',I8) CALL DPWRST('XXX','BUG ') IF(NCSTR.LE.0)GOTO9027 DO9025I=1,NCSTR CCCCC IASCNE=ICHAR(ICSTR(I:I)) CALL DPCOAN(ICSTR(I:I),IASCNE) WRITE(ICOUT,9026)I,ICSTR(I:I),IASCNE 9026 FORMAT('I,ICSTR(I:I),IASCNE = ',I8,2X,A1,I8) CALL DPWRST('XXX','BUG ') 9025 CONTINUE 9027 CONTINUE WRITE(ICOUT,9029)IBUGG4,ISUBG4,IERRG4 9029 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE HQR(NM,N,LOW,IGH,H,WR,WI,IERR) C***BEGIN PROLOGUE HQR C***DATE WRITTEN 760101 (YYMMDD) C***REVISION DATE 830518 (YYMMDD) C***CATEGORY NO. D4C2B C***KEYWORDS EIGENVALUES,EIGENVECTORS,EISPACK C***AUTHOR SMITH, B. T., ET AL. C***PURPOSE Computes eigenvalues of a real upper Hessenberg matrix C using the QR method. C***DESCRIPTION C C This subroutine is a translation of the ALGOL procedure HQR, C NUM. MATH. 14, 219-231(1970) by Martin, Peters, and Wilkinson. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 359-371(1971). C C This subroutine finds the eigenvalues of a REAL C UPPER Hessenberg matrix by the QR method. 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 H contains the upper Hessenberg matrix. Information about C the transformations used in the reduction to Hessenberg C form by ELMHES or ORTHES, if performed, is stored C in the remaining triangle under the Hessenberg matrix. C C On OUTPUT C C H has been destroyed. Therefore, it must be saved C before calling HQR if subsequent calculation and C back transformation of eigenvectors is to be performed. C C WR and WI contain the real and imaginary parts, C respectively, of the eigenvalues. The eigenvalues C are unordered except that complex conjugate pairs C of values appear consecutively with the eigenvalue C having the positive imaginary part first. If an C error exit is made, the eigenvalues should be correct C for indices IERR+1,...,N. C C IERR is set to C Zero for normal return, C J if the J-th eigenvalue has not been C determined after a total of 30*N iterations. 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 HQR C INTEGER I,J,K,L,M,N,EN,LL,MM,NA,NM,IGH,ITN,ITS,LOW,MP2,ENM2,IERR REAL H(NM,N),WR(N),WI(N) REAL P,Q,R,S,T,W,X,Y,ZZ,NORM,S1,S2 LOGICAL NOTLAS C C***FIRST EXECUTABLE STATEMENT HQR IERR = 0 NORM = 0.0E0 K = 1 C .......... STORE ROOTS ISOLATED BY BALANC C AND COMPUTE MATRIX NORM .......... DO 50 I = 1, N C DO 40 J = K, N 40 NORM = NORM + ABS(H(I,J)) C K = I IF (I .GE. LOW .AND. I .LE. IGH) GO TO 50 WR(I) = H(I,I) WI(I) = 0.0E0 50 CONTINUE C EN = IGH T = 0.0E0 ITN = 30*N C .......... SEARCH FOR NEXT EIGENVALUES .......... 60 IF (EN .LT. LOW) GO TO 1001 ITS = 0 NA = EN - 1 ENM2 = NA - 1 C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT C FOR L=EN STEP -1 UNTIL LOW DO -- .......... 70 DO 80 LL = LOW, EN L = EN + LOW - LL IF (L .EQ. LOW) GO TO 100 S = ABS(H(L-1,L-1)) + ABS(H(L,L)) IF (S .EQ. 0.0E0) S = NORM S2 = S + ABS(H(L,L-1)) IF (S2 .EQ. S) GO TO 100 80 CONTINUE C .......... FORM SHIFT .......... 100 X = H(EN,EN) IF (L .EQ. EN) GO TO 270 Y = H(NA,NA) W = H(EN,NA) * H(NA,EN) IF (L .EQ. NA) GO TO 280 IF (ITN .EQ. 0) GO TO 1000 IF (ITS .NE. 10 .AND. ITS .NE. 20) GO TO 130 C .......... FORM EXCEPTIONAL SHIFT .......... T = T + X C DO 120 I = LOW, EN 120 H(I,I) = H(I,I) - X C S = ABS(H(EN,NA)) + ABS(H(NA,ENM2)) X = 0.75E0 * S Y = X W = -0.4375E0 * S * S 130 ITS = ITS + 1 ITN = ITN - 1 C .......... LOOK FOR TWO CONSECUTIVE SMALL C SUB-DIAGONAL ELEMENTS. C FOR M=EN-2 STEP -1 UNTIL L DO -- .......... DO 140 MM = L, ENM2 M = ENM2 + L - MM ZZ = H(M,M) R = X - ZZ S = Y - ZZ P = (R * S - W) / H(M+1,M) + H(M,M+1) Q = H(M+1,M+1) - ZZ - R - S R = H(M+2,M+1) S = ABS(P) + ABS(Q) + ABS(R) P = P / S Q = Q / S R = R / S IF (M .EQ. L) GO TO 150 S1 = ABS(P) * (ABS(H(M-1,M-1)) + ABS(ZZ) + ABS(H(M+1,M+1))) S2 = S1 + ABS(H(M,M-1)) * (ABS(Q) + ABS(R)) IF (S2 .EQ. S1) GO TO 150 140 CONTINUE C 150 MP2 = M + 2 C DO 160 I = MP2, EN H(I,I-2) = 0.0E0 IF (I .EQ. MP2) GO TO 160 H(I,I-3) = 0.0E0 160 CONTINUE C .......... DOUBLE QR STEP INVOLVING ROWS L TO EN AND C COLUMNS M TO EN .......... DO 260 K = M, NA NOTLAS = K .NE. NA IF (K .EQ. M) GO TO 170 P = H(K,K-1) Q = H(K+1,K-1) R = 0.0E0 IF (NOTLAS) R = H(K+2,K-1) X = ABS(P) + ABS(Q) + ABS(R) IF (X .EQ. 0.0E0) GO TO 260 P = P / X Q = Q / X R = R / X 170 S = SIGN(SQRT(P*P+Q*Q+R*R),P) IF (K .EQ. M) GO TO 180 H(K,K-1) = -S * X GO TO 190 180 IF (L .NE. M) H(K,K-1) = -H(K,K-1) 190 P = P + S X = P / S Y = Q / S ZZ = R / S Q = Q / P R = R / P C .......... ROW MODIFICATION .......... DO 210 J = K, EN P = H(K,J) + Q * H(K+1,J) IF (.NOT. NOTLAS) GO TO 200 P = P + R * H(K+2,J) H(K+2,J) = H(K+2,J) - P * ZZ 200 H(K+1,J) = H(K+1,J) - P * Y H(K,J) = H(K,J) - P * X 210 CONTINUE C J = MIN0(EN,K+3) C .......... COLUMN MODIFICATION .......... DO 230 I = L, J P = X * H(I,K) + Y * H(I,K+1) IF (.NOT. NOTLAS) GO TO 220 P = P + ZZ * H(I,K+2) H(I,K+2) = H(I,K+2) - P * R 220 H(I,K+1) = H(I,K+1) - P * Q H(I,K) = H(I,K) - P 230 CONTINUE C 260 CONTINUE C GO TO 70 C .......... ONE ROOT FOUND .......... 270 WR(EN) = X + T WI(EN) = 0.0E0 EN = NA GO TO 60 C .......... TWO ROOTS FOUND .......... 280 P = (Y - X) / 2.0E0 Q = P * P + W ZZ = SQRT(ABS(Q)) X = X + T IF (Q .LT. 0.0E0) GO TO 320 C .......... REAL PAIR .......... ZZ = P + SIGN(ZZ,P) WR(NA) = X + ZZ WR(EN) = WR(NA) IF (ZZ .NE. 0.0E0) WR(EN) = X - W / ZZ WI(NA) = 0.0E0 WI(EN) = 0.0E0 GO TO 330 C .......... COMPLEX PAIR .......... 320 WR(NA) = X + P WR(EN) = X + P WI(NA) = ZZ WI(EN) = -ZZ 330 EN = ENM2 GO TO 60 C .......... SET ERROR -- NO CONVERGENCE TO AN C EIGENVALUE AFTER 30*N ITERATIONS .......... 1000 IERR = EN 1001 RETURN END SUBROUTINE HQR2(NM,N,LOW,IGH,H,WR,WI,Z,IERR) C***BEGIN PROLOGUE HQR2 C***DATE WRITTEN 760101 (YYMMDD) C***REVISION DATE 830518 (YYMMDD) C***CATEGORY NO. D4C2B C***KEYWORDS EIGENVALUES,EIGENVECTORS,EISPACK C***AUTHOR SMITH, B. T., ET AL. C***PURPOSE Computes eigenvalues and eigenvectors of real upper C Hessenberg matrix using QR method. C***DESCRIPTION C C This subroutine is a translation of the ALGOL procedure HQR2, 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 finds the eigenvalues and eigenvectors C of a REAL UPPER Hessenberg matrix by the QR method. The C eigenvectors of a REAL GENERAL matrix can also be found C if ELMHES and ELTRAN or ORTHES and ORTRAN have C been used to reduce this general matrix to Hessenberg form C and to accumulate the 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 H contains the upper Hessenberg matrix. C C Z contains the transformation matrix produced by ELTRAN C after the reduction by ELMHES, or by ORTRAN after the C reduction by ORTHES, if performed. If the eigenvectors C of the Hessenberg matrix are desired, Z must contain the C identity matrix. C C On OUTPUT C C H has been destroyed. C C WR and WI contain the real and imaginary parts, C respectively, of the eigenvalues. The eigenvalues C are unordered except that complex conjugate pairs C of values appear consecutively with the eigenvalue C having the positive imaginary part first. If an C error exit is made, the eigenvalues should be correct C for indices IERR+1,...,N. C C Z contains the real and imaginary parts of the eigenvectors. C If the I-th eigenvalue is real, the I-th column of Z C contains its eigenvector. If the I-th eigenvalue is complex C with positive imaginary part, the I-th and (I+1)-th C columns of Z contain the real and imaginary parts of its C eigenvector. The eigenvectors are unnormalized. If an C error exit is made, none of the eigenvectors has been found. C C IERR is set to C Zero for normal return, C J if the J-th eigenvalue has not been C determined after a total of 30*N iterations. C C Calls CDIV for complex division. 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 CDIV C***END PROLOGUE HQR2 C INTEGER I,J,K,L,M,N,EN,II,JJ,LL,MM,NA,NM,NN INTEGER IGH,ITN,ITS,LOW,MP2,ENM2,IERR REAL H(NM,N),WR(N),WI(N),Z(NM,N) REAL P,Q,R,S,T,W,X,Y,RA,SA,VI,VR,ZZ,NORM,S1 LOGICAL NOTLAS C C***FIRST EXECUTABLE STATEMENT HQR2 IERR = 0 NORM = 0.0E0 K = 1 C .......... STORE ROOTS ISOLATED BY BALANC C AND COMPUTE MATRIX NORM .......... DO 50 I = 1, N C DO 40 J = K, N 40 NORM = NORM + ABS(H(I,J)) C K = I IF (I .GE. LOW .AND. I .LE. IGH) GO TO 50 WR(I) = H(I,I) WI(I) = 0.0E0 50 CONTINUE C EN = IGH T = 0.0E0 ITN = 30*N C .......... SEARCH FOR NEXT EIGENVALUES .......... 60 IF (EN .LT. LOW) GO TO 340 ITS = 0 NA = EN - 1 ENM2 = NA - 1 C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT C FOR L=EN STEP -1 UNTIL LOW DO -- .......... 70 DO 80 LL = LOW, EN L = EN + LOW - LL IF (L .EQ. LOW) GO TO 100 S = ABS(H(L-1,L-1)) + ABS(H(L,L)) IF (S .EQ. 0.0E0) S = NORM S2 = S + ABS(H(L,L-1)) IF (S2 .EQ. S) GO TO 100 80 CONTINUE C .......... FORM SHIFT .......... 100 X = H(EN,EN) IF (L .EQ. EN) GO TO 270 Y = H(NA,NA) W = H(EN,NA) * H(NA,EN) IF (L .EQ. NA) GO TO 280 IF (ITN .EQ. 0) GO TO 1000 IF (ITS .NE. 10 .AND. ITS .NE. 20) GO TO 130 C .......... FORM EXCEPTIONAL SHIFT .......... T = T + X C DO 120 I = LOW, EN 120 H(I,I) = H(I,I) - X C S = ABS(H(EN,NA)) + ABS(H(NA,ENM2)) X = 0.75E0 * S Y = X W = -0.4375E0 * S * S 130 ITS = ITS + 1 ITN = ITN - 1 C .......... LOOK FOR TWO CONSECUTIVE SMALL C SUB-DIAGONAL ELEMENTS. C FOR M=EN-2 STEP -1 UNTIL L DO -- .......... DO 140 MM = L, ENM2 M = ENM2 + L - MM ZZ = H(M,M) R = X - ZZ S = Y - ZZ P = (R * S - W) / H(M+1,M) + H(M,M+1) Q = H(M+1,M+1) - ZZ - R - S R = H(M+2,M+1) S = ABS(P) + ABS(Q) + ABS(R) P = P / S Q = Q / S R = R / S IF (M .EQ. L) GO TO 150 S1 = ABS(P) * (ABS(H(M-1,M-1)) + ABS(ZZ) + ABS(H(M+1,M+1))) S2 = S1 + ABS(H(M,M-1)) * (ABS(Q) + ABS(R)) IF (S2 .EQ. S1) GO TO 150 140 CONTINUE C 150 MP2 = M + 2 C DO 160 I = MP2, EN H(I,I-2) = 0.0E0 IF (I .EQ. MP2) GO TO 160 H(I,I-3) = 0.0E0 160 CONTINUE C .......... DOUBLE QR STEP INVOLVING ROWS L TO EN AND C COLUMNS M TO EN .......... DO 260 K = M, NA NOTLAS = K .NE. NA IF (K .EQ. M) GO TO 170 P = H(K,K-1) Q = H(K+1,K-1) R = 0.0E0 IF (NOTLAS) R = H(K+2,K-1) X = ABS(P) + ABS(Q) + ABS(R) IF (X .EQ. 0.0E0) GO TO 260 P = P / X Q = Q / X R = R / X 170 S = SIGN(SQRT(P*P+Q*Q+R*R),P) IF (K .EQ. M) GO TO 180 H(K,K-1) = -S * X GO TO 190 180 IF (L .NE. M) H(K,K-1) = -H(K,K-1) 190 P = P + S X = P / S Y = Q / S ZZ = R / S Q = Q / P R = R / P C .......... ROW MODIFICATION .......... DO 210 J = K, N P = H(K,J) + Q * H(K+1,J) IF (.NOT. NOTLAS) GO TO 200 P = P + R * H(K+2,J) H(K+2,J) = H(K+2,J) - P * ZZ 200 H(K+1,J) = H(K+1,J) - P * Y H(K,J) = H(K,J) - P * X 210 CONTINUE C J = MIN0(EN,K+3) C .......... COLUMN MODIFICATION .......... DO 230 I = 1, J P = X * H(I,K) + Y * H(I,K+1) IF (.NOT. NOTLAS) GO TO 220 P = P + ZZ * H(I,K+2) H(I,K+2) = H(I,K+2) - P * R 220 H(I,K+1) = H(I,K+1) - P * Q H(I,K) = H(I,K) - P 230 CONTINUE C .......... ACCUMULATE TRANSFORMATIONS .......... DO 250 I = LOW, IGH P = X * Z(I,K) + Y * Z(I,K+1) IF (.NOT. NOTLAS) GO TO 240 P = P + ZZ * Z(I,K+2) Z(I,K+2) = Z(I,K+2) - P * R 240 Z(I,K+1) = Z(I,K+1) - P * Q Z(I,K) = Z(I,K) - P 250 CONTINUE C 260 CONTINUE C GO TO 70 C .......... ONE ROOT FOUND .......... 270 H(EN,EN) = X + T WR(EN) = H(EN,EN) WI(EN) = 0.0E0 EN = NA GO TO 60 C .......... TWO ROOTS FOUND .......... 280 P = (Y - X) / 2.0E0 Q = P * P + W ZZ = SQRT(ABS(Q)) H(EN,EN) = X + T X = H(EN,EN) H(NA,NA) = Y + T IF (Q .LT. 0.0E0) GO TO 320 C .......... REAL PAIR .......... ZZ = P + SIGN(ZZ,P) WR(NA) = X + ZZ WR(EN) = WR(NA) IF (ZZ .NE. 0.0E0) WR(EN) = X - W / ZZ WI(NA) = 0.0E0 WI(EN) = 0.0E0 X = H(EN,NA) S = ABS(X) + ABS(ZZ) P = X / S Q = ZZ / S R = SQRT(P*P+Q*Q) P = P / R Q = Q / R C .......... ROW MODIFICATION .......... DO 290 J = NA, N ZZ = H(NA,J) H(NA,J) = Q * ZZ + P * H(EN,J) H(EN,J) = Q * H(EN,J) - P * ZZ 290 CONTINUE C .......... COLUMN MODIFICATION .......... DO 300 I = 1, EN ZZ = H(I,NA) H(I,NA) = Q * ZZ + P * H(I,EN) H(I,EN) = Q * H(I,EN) - P * ZZ 300 CONTINUE C .......... ACCUMULATE TRANSFORMATIONS .......... DO 310 I = LOW, IGH ZZ = Z(I,NA) Z(I,NA) = Q * ZZ + P * Z(I,EN) Z(I,EN) = Q * Z(I,EN) - P * ZZ 310 CONTINUE C GO TO 330 C .......... COMPLEX PAIR .......... 320 WR(NA) = X + P WR(EN) = X + P WI(NA) = ZZ WI(EN) = -ZZ 330 EN = ENM2 GO TO 60 C .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND C VECTORS OF UPPER TRIANGULAR FORM .......... 340 IF (NORM .EQ. 0.0E0) GO TO 1001 C .......... FOR EN=N STEP -1 UNTIL 1 DO -- .......... DO 800 NN = 1, N EN = N + 1 - NN P = WR(EN) Q = WI(EN) NA = EN - 1 IF (Q) 710, 600, 800 C .......... REAL VECTOR .......... 600 M = EN H(EN,EN) = 1.0E0 IF (NA .EQ. 0) GO TO 800 C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- .......... DO 700 II = 1, NA I = EN - II W = H(I,I) - P R = H(I,EN) IF (M .GT. NA) GO TO 620 C DO 610 J = M, NA 610 R = R + H(I,J) * H(J,EN) C 620 IF (WI(I) .GE. 0.0E0) GO TO 630 ZZ = W S = R GO TO 700 630 M = I IF (WI(I) .NE. 0.0E0) GO TO 640 T = W IF (T .NE. 0.0E0) GO TO 635 T = NORM 632 T = 0.5E0*T IF (NORM + T .GT. NORM) GO TO 632 T = 2.0E0*T 635 H(I,EN) = -R / T GO TO 700 C .......... SOLVE REAL EQUATIONS .......... 640 X = H(I,I+1) Y = H(I+1,I) Q = (WR(I) - P) * (WR(I) - P) + WI(I) * WI(I) T = (X * S - ZZ * R) / Q H(I,EN) = T IF (ABS(X) .LE. ABS(ZZ)) GO TO 650 H(I+1,EN) = (-R - W * T) / X GO TO 700 650 H(I+1,EN) = (-S - Y * T) / ZZ 700 CONTINUE C .......... END REAL VECTOR .......... GO TO 800 C .......... COMPLEX VECTOR .......... 710 M = NA C .......... LAST VECTOR COMPONENT CHOSEN IMAGINARY SO THAT C EIGENVECTOR MATRIX IS TRIANGULAR .......... IF (ABS(H(EN,NA)) .LE. ABS(H(NA,EN))) GO TO 720 H(NA,NA) = Q / H(EN,NA) H(NA,EN) = -(H(EN,EN) - P) / H(EN,NA) GO TO 730 720 CALL CDIV(0.0E0,-H(NA,EN),H(NA,NA)-P,Q,H(NA,NA),H(NA,EN)) 730 H(EN,NA) = 0.0E0 H(EN,EN) = 1.0E0 ENM2 = NA - 1 IF (ENM2 .EQ. 0) GO TO 800 C .......... FOR I=EN-2 STEP -1 UNTIL 1 DO -- .......... DO 790 II = 1, ENM2 I = NA - II W = H(I,I) - P RA = 0.0E0 SA = H(I,EN) C DO 760 J = M, NA RA = RA + H(I,J) * H(J,NA) SA = SA + H(I,J) * H(J,EN) 760 CONTINUE C IF (WI(I) .GE. 0.0E0) GO TO 770 ZZ = W R = RA S = SA GO TO 790 770 M = I IF (WI(I) .NE. 0.0E0) GO TO 780 CALL CDIV(-RA,-SA,W,Q,H(I,NA),H(I,EN)) GO TO 790 C .......... SOLVE COMPLEX EQUATIONS .......... 780 X = H(I,I+1) Y = H(I+1,I) VR = (WR(I) - P) * (WR(I) - P) + WI(I) * WI(I) - Q * Q VI = (WR(I) - P) * 2.0E0 * Q IF (VR .NE. 0.0E0 .OR. VI .NE. 0.0E0) GO TO 783 S1 = NORM * (ABS(W)+ABS(Q)+ABS(X)+ABS(Y)+ABS(ZZ)) VR = S1 782 VR = 0.5E0*VR IF (S1 + VR .GT. S1) GO TO 782 VR = 2.0E0*VR 783 CALL CDIV(X*R-ZZ*RA+Q*SA,X*S-ZZ*SA-Q*RA,VR,VI, 1 H(I,NA),H(I,EN)) IF (ABS(X) .LE. ABS(ZZ) + ABS(Q)) GO TO 785 H(I+1,NA) = (-RA - W * H(I,NA) + Q * H(I,EN)) / X H(I+1,EN) = (-SA - W * H(I,EN) - Q * H(I,NA)) / X GO TO 790 785 CALL CDIV(-R-Y*H(I,NA),-S-Y*H(I,EN),ZZ,Q, 1 H(I+1,NA),H(I+1,EN)) 790 CONTINUE C .......... END COMPLEX VECTOR .......... 800 CONTINUE C .......... END BACK SUBSTITUTION. C VECTORS OF ISOLATED ROOTS .......... DO 840 I = 1, N IF (I .GE. LOW .AND. I .LE. IGH) GO TO 840 C DO 820 J = I, N 820 Z(I,J) = H(I,J) C 840 CONTINUE C .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE C VECTORS OF ORIGINAL FULL MATRIX. C FOR J=N STEP -1 UNTIL LOW DO -- .......... DO 880 JJ = LOW, N J = N + LOW - JJ M = MIN0(J,IGH) C DO 880 I = LOW, IGH ZZ = 0.0E0 C DO 860 K = LOW, M 860 ZZ = ZZ + Z(I,K) * H(K,J) C Z(I,J) = ZZ 880 CONTINUE C GO TO 1001 C .......... SET ERROR -- NO CONVERGENCE TO AN C EIGENVALUE AFTER 30*N ITERATIONS .......... 1000 IERR = EN 1001 RETURN END SUBROUTINE HSECDF(X,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE HYPERBOLIC SECANT DISTRIBUTION C WITH MEAN = 0 AND STANDARD DEVIATION = PI/SQRT(3). C THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS C THE PROBABILITY DENSITY FUNCTION C F(X) = EXP(X)/(1+EXP(X)). 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. C REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--2, 1994, PAGE 147 C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-975-2855 C ORIGINAL VERSION--OCTOBER 1995. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DATA PI / 3.1415926535/ C C--------------------------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS. C NO INPUT ARGUMENT ERRORS POSSIBLE C FOR THIS DISTRIBUTION. C C-----START POINT----------------------------------------------------- C IF(X.GT.80.0)THEN CDF=1.0 GOTO9999 ELSEIF(X.LT.-80.0)THEN CDF=0.0 GOTO9999 ELSE ARG=X/2.0 TERM1=(EXP(ARG)-EXP(-ARG))/(EXP(ARG)+EXP(-ARG)) CDF=0.5 + (2.0/PI)*ATAN(TERM1) ENDIF C 9999 CONTINUE RETURN END SUBROUTINE HSEPDF(X,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE HYPERBOLIC SECANT DISTRIBUTION C THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS C THE PROBABILITY DENSITY FUNCTION C F(X) = SECH(X)/PI C = (1/PI)*(2/(EXP(X) + EXP(-X)) 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. C REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--2, 1994, PAGE 147 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-2899 C ORIGINAL VERSION--OCTOBER 1995. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX, DPDF, DPI C CHARACTER*4 IFEEDB CHARACTER*4 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--------------------------------------------------------------------- C DX=DBLE(X) IF(DABS(DX).GT.500.0D0)THEN PDF=0.0 ELSE DPDF=2.0D0/(DEXP(DX) + DEXP(-DX)) PDF=SNGL(DPDF/DPI) ENDIF C RETURN END SUBROUTINE HSEPPF(P,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE HYPERBOLIC SECANT DISTRIBUTION C THE PROBABILITY DENSITY FUNCTION IS C F(X) = SECH(X)/PI C = (1/PI)*(2/(EXP(X) + EXP(-X)) 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--EXP. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--2, 1994, PAGE 147 C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--95.10 C ORIGINAL VERSION--OCTOBER 1995. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DARG DOUBLE PRECISION DPI DOUBLE PRECISION DTERM1 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 DATA DPI / 3.1415926535 8979323846 2643383279 503 D0 / C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(P.LE.0.0.OR.P.GE.1.0)GOTO50 GOTO90 50 WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') RETURN 90 CONTINUE 1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ', 1'HSEPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C DARG=DPI*(DBLE(P)-0.5D0)/2.0D0 DTERM1=DTAN(DARG) DPPF=DLOG((1.0+DTERM1)/(1.0D0-DTERM1)) PPF=SNGL(DPPF) C RETURN END SUBROUTINE HSERAN(N,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE HYPERBOLIC SECANT 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 HYPERBOLIC SECANT DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. 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)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'HSERAN 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 HYPERBOLIC SECANT RANDOM NUMBERS C USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD. C DO100I=1,N CALL HSEPPF(X(I),XTEMP) X(I)=XTEMP 100 CONTINUE C RETURN END SUBROUTINE HSNINT(NR,N,A,SX,METHOD) IMPLICIT DOUBLE PRECISION (A-H,O-Z) C C PURPOSE C ------- C PROVIDE INITIAL HESSIAN WHEN USING SECANT UPDATES C C PARAMETERS C ---------- C NR --> ROW DIMENSION OF MATRIX C N --> DIMENSION OF PROBLEM C A(N,N) <-- INITIAL HESSIAN (LOWER TRIANGULAR MATRIX) C SX(N) --> DIAGONAL SCALING MATRIX FOR X C METHOD --> ALGORITHM TO USE TO SOLVE MINIMIZATION PROBLEM C =1,2 FACTORED SECANT METHOD USED C =3 UNFACTORED SECANT METHOD USED C DIMENSION A(NR,1),SX(N) C DO 100 J=1,N IF(METHOD.EQ.3) A(J,J)=SX(J)*SX(J) IF(METHOD.NE.3) A(J,J)=SX(J) IF(J.EQ.N) GO TO 100 JP1=J+1 DO 90 I=JP1,N A(I,J)=0. 90 CONTINUE 100 CONTINUE RETURN END SUBROUTINE HTTSQ1(AMAT1,AMAT2,MAXROM,MAXCOM,NR1,NC1, 1TSTAT,ASIG90,ASIG95,ASIG99,ASG995, 1DMEAN,Y1,Y2,Y3,INDEX, 1IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C 1-SAMPLE HOTELLING T-SQUARE STATISTIC. C HO: U = U0 C T2=N*(XBAR-U0)'*SINV*(XBAR-U0) C INPUT ARGUMENTS--AMAT1 = THE ORIGINAL SINGLE PRECISION MATRIX C --MAXROM = THE INTEGER ROW DIMENSION OF AMAT1 C --MAXCOM = THE INTEGER COUMN DIMENSION OF AMAT1 C --NR1 = THE INTEGER NUMBER OF ROWS OF AMAT1 C --NC1 = THE INTEGER NUMBER OF COLUMNS OF AMAT1 C --Y1 = VECTOR CONTAINING HYPOTHESIZED MEANS C --Y2 = DUMMY VECTOR CONTAINING SAMPLE MEANS C OUTPUT ARGUMENTS--AMAT2 = THE SINGLE PRECISION VALUE OF THE C COMPUTED INVERTED VARIANCE-COVARIANCE C MATRIX C --TSTAT = VALUE OF HOTELLING T-SQUARE C --ASIG90 = CRITICAL VALUE FOR ALPHA = .90 C --ASIG95 = CRITICAL VALUE FOR ALPHA = .95 C --ASIG99 = CRITICAL VALUE FOR ALPHA = .99 C --ASG995= CRITICAL VALUE FOR ALPHA = .995 C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE C HOTELLING T-SQUARE VALUE C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C LANGUAGE--ANSI FORTRAN (1977) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--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 C DIMENSION AMAT1(MAXROM,MAXCOM) DIMENSION AMAT2(MAXROM,MAXCOM) DIMENSION Y1(*) DIMENSION Y2(*) DIMENSION Y3(*) DIMENSION INDEX(*) DOUBLE PRECISION DMEAN(*) 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='HOTT' ISUBN2='SQ ' C IWRITE='OFF' 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 HTTSQ1--') 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,NC1 WRITE(ICOUT,56)I,Y1(I) 56 FORMAT('I,Y(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ********************************** C ** COMPUTE HOTELLING T-SQUARE ** C ********************************** C ICASE='COLU' CALL VARCOV(AMAT1,AMAT2,MAXROM,MAXCOM,NR1,NC1,DMEAN, 1 ICASE,IBUGA3,IERROR) CALL SGECO(AMAT2,MAXROM,NC1,INDEX,RCOND,Y2) C IF(1.0+RCOND.EQ.1.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5171) CALL DPWRST('XXX','ERRO ') WRITE(ICOUT,5172) CALL DPWRST('XXX','ERRO ') WRITE(ICOUT,5173) CALL DPWRST('XXX','ERRO ') IERROR='YES' GOTO9000 ENDIF 5171 FORMAT('*** ERROR FROM HTTSQ1: UNABLE TO COMPUTE THE INVERSE OF ', 1 'THE COVARIANCE MATRIX.') 5172 FORMAT(' PROBLEM: SOME COLUMNS ARE LINEARLY DEPDENDENT ON ', 1 ' OTHER COLUMNS.') 5173 FORMAT(' SUGGESTED SOLUTION: WORK WITH A SUBSET OF THE ', 1 'ORIGINAL COLUMNS.') C IJOB=1 CALL SGEDI(AMAT2,MAXROM,NC1,INDEX,Y2,Y3,IJOB) C DO6000I=1,NC1 DO6110J=1,NR1 Y2(J)=AMAT1(J,I) 6110 CONTINUE CALL MEAN(Y2,NR1,IWRITE,XMEAN,IBUGA3,IERROR) Y3(I)=XMEAN-Y1(I) 6000 CONTINUE CALL QUAFRM(AMAT2,MAXROM,MAXCOM,NC1,NC1,Y3,IWRITE, 1 XQUAD,IBUGA3,IERROR) TSTAT=REAL(NR1)*XQUAD C AFACT=REAL(NC1*(NR1-1)/(NR1-NC1)) CALL FPPF(0.90,NC1,NR1-NC1,ATEMP1) ASIG90=AFACT*ATEMP1 CALL FPPF(0.95,NC1,NR1-NC1,ATEMP1) ASIG95=AFACT*ATEMP1 CALL FPPF(0.99,NC1,NR1-NC1,ATEMP1) ASIG99=AFACT*ATEMP1 CALL FPPF(0.995,NC1,NR1-NC1,ATEMP1) ASG995=AFACT*ATEMP1 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 HTTSQ1--') 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 HTTSQ2(AMAT1,AMAT2,AMAT3,MAXROM,MAXCOM,NR1,NR2,NC1, 1TSTAT,ASIG90,ASIG95,ASIG99,ASG995, 1DMEAN,Y1,Y2,Y3,INDEX, 1IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C 2-SAMPLE HOTELLING T-SQUARE STATISTIC. C HO: U1 = U2 C T2=N1*N2*(XBAR1-XBAR2)'*SINV*(XBAR1-XBAR2)/(N1+N2) C WHERE SINV IS THE INVERSE OF THE POOLED COVARIANCE C MATRIX. C INPUT ARGUMENTS--AMAT1 = THE SAMPLE 1 SINGLE PRECISION MATRIX C --AMAT2 = THE SAMPLE 2 SINGLE PRECISION MATRIX C --MAXROM = THE INTEGER ROW DIMENSION OF AMAT1 C --MAXCOM = THE INTEGER COUMN DIMENSION OF AMAT1 C --NR1 = THE INTEGER NUMBER OF ROWS OF AMAT1 C --NR2 = THE INTEGER NUMBER OF ROWS OF AMAT2 C --NC1 = THE INTEGER NUMBER OF COLUMNS OF AMAT1 C --Y1 = DUMMY VECTOR CONTAINING SAMPLE 1 MEANS C --Y2 = DUMMY VECTOR CONTAINING SAMPLE 2 MEANS C OUTPUT ARGUMENTS--AMAT3 = THE SINGLE PRECISION VALUE OF THE C COMPUTED INVERTED VARIANCE-COVARIANCE C MATRIX C --TSTAT = VALUE OF HOTELLING T-SQUARE C --ASIG90 = CRITICAL VALUE FOR ALPHA = .90 C --ASIG95 = CRITICAL VALUE FOR ALPHA = .95 C --ASIG99 = CRITICAL VALUE FOR ALPHA = .99 C --ASG995= CRITICAL VALUE FOR ALPHA = .995 C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE C HOTELLING T-SQUARE VALUE C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C LANGUAGE--ANSI FORTRAN (1977) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--98.7 C ORIGINAL VERSION--JULY 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 C DIMENSION AMAT1(MAXROM,MAXCOM) DIMENSION AMAT2(MAXROM,MAXCOM) DIMENSION AMAT3(MAXROM,MAXCOM) DIMENSION Y1(*) DIMENSION Y2(*) DIMENSION Y3(*) DIMENSION INDEX(*) DOUBLE PRECISION DMEAN(*) 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='HTTS' ISUBN2='Q2 ' C IWRITE='OFF' 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 HTTSQ2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)NR1,NR2,NC1 53 FORMAT('NR1, NR2, NC1 = ',3I8) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ********************************** C ** COMPUTE HOTELLING T-SQUARE ** C ********************************** C CALL VARPOO(AMAT1,AMAT2,AMAT3,MAXROM,MAXCOM,NR1,NC1,NR2, 1 DMEAN,IBUGA3,IERROR) CALL SGECO(AMAT3,MAXROM,NC1,INDEX,RCOND,Y1) C IF(1.0+RCOND.EQ.1.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5171) CALL DPWRST('XXX','ERRO ') WRITE(ICOUT,5172) CALL DPWRST('XXX','ERRO ') WRITE(ICOUT,5173) CALL DPWRST('XXX','ERRO ') IERROR='YES' GOTO9000 ENDIF 5171 FORMAT('*** ERROR FROM HTTSQ2: UNABLE TO COMPUTE THE INVERSE OF ', 1 'THE POOLED COVARIANCE MATRIX.') 5172 FORMAT(' PROBLEM: SOME COLUMNS ARE LINEARLY DEPDENDENT ON ', 1 ' OTHER COLUMNS.') 5173 FORMAT(' SUGGESTED SOLUTION: WORK WITH A SUBSET OF THE ', 1 'ORIGINAL COLUMNS.') C IJOB=1 CALL SGEDI(AMAT3,MAXROM,NC1,INDEX,Y1,Y2,IJOB) C DO6000I=1,NC1 DO6110J=1,NR1 Y1(J)=AMAT1(J,I) 6110 CONTINUE DO6120J=1,NR2 Y2(J)=AMAT2(J,I) 6120 CONTINUE CALL MEAN(Y1,NR1,IWRITE,XMEAN1,IBUGA3,IERROR) CALL MEAN(Y2,NR2,IWRITE,XMEAN2,IBUGA3,IERROR) Y3(I)=XMEAN1-XMEAN2 6000 CONTINUE CALL QUAFRM(AMAT3,MAXROM,MAXCOM,NC1,NC1,Y3,IWRITE, 1 XQUAD,IBUGA3,IERROR) TSTAT=REAL(NR1*NR2)*XQUAD/REAL(NR1+NR2) C AFACT=REAL((Nr1+NR2-NC1-1)/((NR1+NR2-2)*NC1)) CALL FPPF(0.90,NC1,NR1+NR2-NC1-1,ATEMP1) ASIG90=AFACT*ATEMP1 CALL FPPF(0.95,NC1,NR1+NR2-NC1-1,ATEMP1) ASIG95=AFACT*ATEMP1 CALL FPPF(0.99,NC1,NR1+NR2-NC1-1,ATEMP1) ASIG99=AFACT*ATEMP1 CALL FPPF(0.995,NC1,NR1+NR2-NC1-1,ATEMP1) ASG995=AFACT*ATEMP1 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 HTTSQ2--') 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 HYGFX(A,B,C,X,HF,IERROR) C C ==================================================== C Purpose: Compute hypergeometric function F(a,b,c,x) C Input : a --- Parameter C b --- Parameter C c --- Parameter, c <> 0,-1,-2,... C x --- Argument ( x < 1 ) C Output: HF --- F(a,b,c,x) C IERROR--ERROR FLAG C Routines called: C (1) GAMMA for computing gamma function C (2) PSI for computing psi function C ==================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) LOGICAL L0,L1,L2,L3,L4,L5 PI=3.141592653589793D0 EL=.5772156649015329D0 L0=C.EQ.INT(C).AND.C.LT.0.0 L1=1.0D0-X.LT.1.0D-15.AND.C-A-B.LE.0.0 L2=A.EQ.INT(A).AND.A.LT.0.0 L3=B.EQ.INT(B).AND.B.LT.0.0 L4=C-A.EQ.INT(C-A).AND.C-A.LE.0.0 L5=C-B.EQ.INT(C-B).AND.C-B.LE.0.0 IF (L0) THEN IERROR=1 CCCCC WRITE(*,*)'The hypergeometric series is divergent' RETURN ENDIF IF (L1) THEN IERROR=2 CCCCC WRITE(*,*)'The hypergeometric series is divergent' RETURN ENDIF EPS=1.0D-15 IF (X.GT.0.95) EPS=1.0D-8 IF (X.EQ.0.0.OR.A.EQ.0.0.OR.B.EQ.0.0) THEN HF=1.0D0 RETURN ELSE IF (1.0D0-X.EQ.EPS.AND.C-A-B.GT.0.0) THEN CCCCC USE CMLIB DGAMMA ROUTINE CCCCC CALL GAMMA(C,GC) CCCCC CALL GAMMA(C-A-B,GCAB) CCCCC CALL GAMMA(C-A,GCA) CCCCC CALL GAMMA(C-B,GCB) GC=DGAMMA(C) GCAB=DGAMMA(C-A-B) GCA=DGAMMA(C-A) GCB=DGAMMA(C-B) HF=GC*GCAB/(GCA*GCB) RETURN ELSE IF (1.0D0+X.LE.EPS.AND.DABS(C-A+B-1.0).LE.EPS) THEN G0=DSQRT(PI)*2.0D0**(-A) CCCCC USE CMLIB DGAMMA ROUTINE CCCCC CALL GAMMA(C,G1) CCCCC CALL GAMMA(1.0D0+A/2.0-B,G2) CCCCC CALL GAMMA(0.5D0+0.5*A,G3) G1=DGAMMA(C) G2=DGAMMA(1.0D0+A/2.0-B) G3=DGAMMA(0.5D0+0.5*A) HF=G0*G1/(G2*G3) RETURN ELSE IF (L2.OR.L3) THEN IF (L2) NM=INT(ABS(A)) IF (L3) NM=INT(ABS(B)) HF=1.0D0 R=1.0D0 DO 10 K=1,NM R=R*(A+K-1.0D0)*(B+K-1.0D0)/(K*(C+K-1.0D0))*X 10 HF=HF+R RETURN ELSE IF (L4.OR.L5) THEN IF (L4) NM=INT(ABS(C-A)) IF (L5) NM=INT(ABS(C-B)) HF=1.0D0 R=1.0D0 DO 15 K=1,NM R=R*(C-A+K-1.0D0)*(C-B+K-1.0D0)/(K*(C+K-1.0D0))*X 15 HF=HF+R HF=(1.0D0-X)**(C-A-B)*HF RETURN ENDIF AA=A BB=B X1=X IF (X.LT.0.0D0) THEN X=X/(X-1.0D0) IF (C.GT.A.AND.B.LT.A.AND.B.GT.0.0) THEN A=BB B=AA ENDIF B=C-B ENDIF IF (X.GE.0.75D0) THEN GM=0.0D0 IF (DABS(C-A-B-INT(C-A-B)).LT.1.0D-15) THEN M=INT(C-A-B) CCCCC USE CMLIB DGAMMA ROUTINE CCCCC CALL GAMMA(A,GA) CCCCC CALL GAMMA(B,GB) CCCCC CALL GAMMA(C,GC) CCCCC CALL GAMMA(A+M,GAM) CCCCC CALL GAMMA(B+M,GBM) GA=DGAMMA(A) GB=DGAMMA(B) GC=DGAMMA(C) GAM=DGAMMA(A+M) GBM=DGAMMA(B+M) CCCCC USE CMLIB DPSI ROUTINE CCCCC CALL PSI(A,PA) CCCCC CALL PSI(B,PB) PA=DPSI(A) PB=DPSI(B) IF (M.NE.0) GM=1.0D0 DO 30 J=1,ABS(M)-1 30 GM=GM*J RM=1.0D0 DO 35 J=1,ABS(M) 35 RM=RM*J F0=1.0D0 R0=1.0D0 R1=1.0D0 SP0=0.D0 SP=0.0D0 IF (M.GE.0) THEN C0=GM*GC/(GAM*GBM) C1=-GC*(X-1.0D0)**M/(GA*GB*RM) DO 40 K=1,M-1 R0=R0*(A+K-1.0D0)*(B+K-1.0)/(K*(K-M))*(1.0-X) 40 F0=F0+R0 DO 45 K=1,M 45 SP0=SP0+1.0D0/(A+K-1.0)+1.0/(B+K-1.0)-1.0/K F1=PA+PB+SP0+2.0D0*EL+DLOG(1.0D0-X) DO 55 K=1,250 SP=SP+(1.0D0-A)/(K*(A+K-1.0))+(1.0-B)/(K*(B+K-1.0)) SM=0.0D0 DO 50 J=1,M 50 SM=SM+(1.0D0-A)/((J+K)*(A+J+K-1.0))+1.0/ & (B+J+K-1.0) RP=PA+PB+2.0D0*EL+SP+SM+DLOG(1.0D0-X) R1=R1*(A+M+K-1.0D0)*(B+M+K-1.0)/(K*(M+K))*(1.0-X) F1=F1+R1*RP IF (DABS(F1-HW).LT.DABS(F1)*EPS) GO TO 60 55 HW=F1 60 HF=F0*C0+F1*C1 ELSE IF (M.LT.0) THEN M=-M C0=GM*GC/(GA*GB*(1.0D0-X)**M) C1=-(-1)**M*GC/(GAM*GBM*RM) DO 65 K=1,M-1 R0=R0*(A-M+K-1.0D0)*(B-M+K-1.0)/(K*(K-M))*(1.0-X) 65 F0=F0+R0 DO 70 K=1,M 70 SP0=SP0+1.0D0/K F1=PA+PB-SP0+2.0D0*EL+DLOG(1.0D0-X) DO 80 K=1,250 SP=SP+(1.0D0-A)/(K*(A+K-1.0))+(1.0-B)/(K*(B+K-1.0)) SM=0.0D0 DO 75 J=1,M 75 SM=SM+1.0D0/(J+K) RP=PA+PB+2.0D0*EL+SP-SM+DLOG(1.0D0-X) R1=R1*(A+K-1.0D0)*(B+K-1.0)/(K*(M+K))*(1.0-X) F1=F1+R1*RP IF (DABS(F1-HW).LT.DABS(F1)*EPS) GO TO 85 80 HW=F1 85 HF=F0*C0+F1*C1 ENDIF ELSE CCCCC USE CMLIB DGAMMA ROUTINE CCCCC CALL GAMMA(A,GA) CCCCC CALL GAMMA(B,GB) CCCCC CALL GAMMA(C,GC) CCCCC CALL GAMMA(C-A,GCA) CCCCC CALL GAMMA(C-B,GCB) CCCCC CALL GAMMA(C-A-B,GCAB) CCCCC CALL GAMMA(A+B-C,GABC) GA=DGAMMA(A) GB=DGAMMA(B) GC=DGAMMA(C) GCA=DGAMMA(C-A) GCB=DGAMMA(C-B) GCAB=DGAMMA(C-A-B) GABC=DGAMMA(A+B-C) C0=GC*GCAB/(GCA*GCB) C1=GC*GABC/(GA*GB)*(1.0D0-X)**(C-A-B) HF=0.0D0 R0=C0 R1=C1 DO 90 K=1,250 R0=R0*(A+K-1.0D0)*(B+K-1.0)/(K*(A+B-C+K))*(1.0-X) R1=R1*(C-A+K-1.0D0)*(C-B+K-1.0)/(K*(C-A-B+K)) & *(1.0-X) HF=HF+R0+R1 IF (DABS(HF-HW).LT.DABS(HF)*EPS) GO TO 95 90 HW=HF 95 HF=HF+C0+C1 ENDIF ELSE A0=1.0D0 IF (C.GT.A.AND.C.LT.2.0D0*A.AND. & C.GT.B.AND.C.LT.2.0D0*B) THEN A0=(1.0D0-X)**(C-A-B) A=C-A B=C-B ENDIF HF=1.0D0 R=1.0D0 DO 100 K=1,250 R=R*(A+K-1.0D0)*(B+K-1.0D0)/(K*(C+K-1.0D0))*X HF=HF+R IF (DABS(HF-HW).LE.DABS(HF)*EPS) GO TO 105 100 HW=HF 105 HF=A0*HF ENDIF IF (X1.LT.0.0D0) THEN X=X1 C0=1.0D0/(1.0D0-X)**AA HF=C0*HF ENDIF A=AA B=BB IF (K.GT.120) THEN CCCCC WRITE(*,115) C115 FORMAT(1X,'Warning! You should check the accuracy') IERROR=3 ENDIF RETURN END SUBROUTINE HYPCDF(LL,KK,NN,MM,POINT,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE AT THE INTEGER VALUE LL C FOR THE HYPERGEOMETRIC DISTRIBUTION. C THE HYPERGEOMETRIC DISTRIBUTION IS THE PROBABILITY OF C SELECTING LL MARKED ITEMS WHEN A RANDOM SAMPLE OF SIZE C KK IS TAKEN WITHOUT REPLACEMENT FROM A POPULATION OF C MM ITEMS, NN OF WHICH ARE MARKED. IT HAS CDF OF: C CDF = P(X<= LL | KK, NN, MM) C INPUT ARGUMENTS--LL = THE INTEGER VALUE C AT WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C IT SHOULD BE INTEGRAL-VALUED, C AND BETWEEN 0.0 (INCLUSIVELY) C AND MM (INCLUSIVELY). C --KK = THE INTEGER VALUE INDICATING THE C SAMPLE SIZE. C --NN = THE NUMBER OF MARKED ITEMS IN THE C POPULATION. C --MM = THE POPULATION SIZE. C --POINT = LOGICAL VARIABLE THAT SPECIFIES C WHETHER THE CDF OR PDF SHOULD BE C COMPUTED. C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--LL SHOULD BE INTEGRAL-VALUED, C AND BETWEEN 0 AND MM (INCLUSIVELY) C --KK SHOULD BE A POSITIVE INTEGER BETWEEN 1 AND MM. C --NN SHOULD BE A POSITIVE INTEGER BETWEEN 1 AND MM. C OTHER SUBROUTINES NEEDED--NORCDF, DLNGAM C LANGUAGE--ANSI FORTRAN (1977) C COMMENT--THIS ROUTINE USES ALGORITHM AS R77 FROM THE C APPLIED STATISTICS JOURNAL. CODE RETRIEVED FROM STATLIB. C C ALGORITHM AS R77 APPL. STATIST. (1989), VOL.38, NO.1 C Replaces AS 59 and AS 152 C Incorporates AS R86 from vol.40(2) C C Auxiliary routines required: ALNFAC (AS 245), ALNORM (AS 66) C C REFERENCES--HASTINGS AND PEACOCK, STATISTICAL C DISTRIBUTIONS--A HANDBOOK FOR C STUDENTS AND PRACTITIONERS, 1975, C --JOHNSON AND KOTZ, DISCRETE C DISTRIBUTIONS, 1969. C --REMARK AS R77, AS152, AND AS59 FROM THE APPLIED C STATISTICS JOURNAL. C --"THE ACCURACY OF PIEZER APPROXIMATIONS TO THE C HYPERGEOMETRIC DISTRIBUTION, WITH COMPARISONS TO C SOME OTHER APPROXIMATIONS", LING AND PRATT, JASA, C MARCH, 1984. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--94/9 C ORIGINAL VERSION--SEPTEMBER 1994. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C INTEGER KK, LL, MM, NN, K, L, M, N, I, J, NL, KL, * MNKL, MVBIG, MBIG CCCCC DOUBLE PRECISION ZERO, ONE, P, PT, HALF, DLNGAM, ELIMIT, MEAN, CCCCC* SIG, SXTEEN, SCALE, ROOTPI, ARG, HUNDRD, DCDF, DOUBLE PRECISION ZERO, ONE, P, PT, HALF, DLNGAM, ELIMIT, * SXTEEN, SCALE, ROOTPI, HUNDRD, DCDF, * XMAX,XMAXT,DTERM1, * DTERM2,DTERM3,DTERM4,DTERM5,DTERM6,DTERM7,DTERM8 DOUBLE PRECISION P1, P2, A, B, C, D LOGICAL POINT, DIR PARAMETER (ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, MVBIG = 1000, * MBIG = 600, SXTEEN = 16.0D0, * ROOTPI = 2.50662 82746 31001D0, * HUNDRD = 100.0D0) C C--------------------------------------------------------------------- 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-----DATA STATEMENTS------------------------------------------------- C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(NN.LE.0.OR.NN.GT.MM)THEN WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)NN CALL DPWRST('XXX','BUG ') CDF=0.0 RETURN ENDIF 11 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ', 1' HYPCDF SUBROUTINE (THE NUMBER OF MARKED ITEMS) ') 12 FORMAT(' IS LESS THAN ZERO OR GREATER THAN THE POULATION ', 1'SIZE.') IF(KK.LE.0.OR.KK.GT.MM)THEN WRITE(ICOUT,21) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,22) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)KK CALL DPWRST('XXX','BUG ') CDF=0.0 RETURN ENDIF 21 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ', 1' HYPCDF SUBROUTINE (THE SAMPLE SIZE) ') 22 FORMAT(' IS LESS THAN ZERO OR GREATER THAN THE POULATION ', 1'SIZE.') IF(LL.LT.0.OR.KK-LL.GT.MM-NN)THEN WRITE(ICOUT,31)MM-NN CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)LL CALL DPWRST('XXX','BUG ') CDF=0.0 RETURN ENDIF 31 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 1ST INPUT ARGUMENT TO ', 1'THE HYPCDF SUBROUTINE IS OUTSIDE THE (0,',I8,') INTERVAL.') IF(LL.GT.NN.OR.LL.GT.KK)THEN WRITE(ICOUT,41) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,42) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)LL CALL DPWRST('XXX','BUG ') CDF=0.0 IF(.NOT.POINT)CDF=1.0 RETURN ENDIF 41 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 1ST INPUT ARGUMENT TO ', 1'THE HYPCDF SUBROUTINE IS GREATER THAN THE SAMPLE SIZE ') 42 FORMAT(' OR GREATER THAN THE NUMBER OF MARKED ITEMS.') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') C 90 CONTINUE C C CALCULATE EXPONENTIAL LIMIT FOR UNDERFLOW C XMAXT = -DLOG(D1MACH(1)) XMAX = XMAXT - 0.5D0*XMAXT*DLOG(XMAXT)/(XMAXT+0.5D0) - 0.01D0 ELIMIT=-XMAX SCALE = D1MACH(1) + 1000.D0*D1MACH(3) C C TREAT IMMEDIATELY THE SPECIAL CASES WHICH RETURN A VALUE OF C 0 OR 1. C K = KK + 1 L = LL + 1 M = MM + 1 N = NN + 1 DIR = .TRUE. DCDF = ONE IF (K .EQ. 1 .OR. K .EQ. M .OR. N .EQ. 1 .OR. N .EQ. M) GOTO9999 IF (.NOT. POINT .AND. LL .EQ. MIN(KK, NN)) GOTO9999 C P = DBLE(NN) / DBLE(MM - NN) C C Use a normal approximation for sufficently large arguments C C THE NORMAL APPROXIMATION HERE DOES NOT SEEM TO PRODUCE C PARTICULARLY ACCURATE RESULTS. USE A BINOMIAL APPROXIMATION C INSTEAD (TAKEN FROM LING AND PRATT ARTICLE IN REFERENCE). CCCCC IF (DBLE(MIN(KK, MM-KK)) .GT. SXTEEN * MAX(P, ONE/P) .AND. CCCCC* MM .GT. MVBIG .AND. ELIMIT .GT. -HUNDRD) THEN IF (DBLE(MIN(KK, MM-KK)) .GT. SXTEEN * MAX(P, ONE/P) .AND. * MM .GT. MVBIG ) THEN K=KK M=MM N=NN L=LL IF (MIN(K-1, M-K) .GT. MIN(N-1, M-N)) THEN I = K K = N N = I END IF IF (M-K .LT. K-1) THEN DIR = .NOT. DIR L = N - L + 1 K = M - K + 1 END IF CCCCC MEAN = DBLE(K) * DBLE(N) / DBLE(M) CCCCC SIG = DSQRT(MEAN*(DBLE(M-N)/DBLE(M))*(DBLE(M-K)/(DBLE(M-1)))) CCCCC IF (POINT) THEN CCCCC ARG = -HALF * (((DBLE(L) - MEAN) / SIG)**2) CCCCC DCDF = ZERO CCCCC IF (ARG .GE. ELIMIT) DCDF = DEXP(ARG)/(SIG*ROOTPI) CCCCC ELSE CCCCC DTERM1=(DBLE(L)+HALF-MEAN)/SIG CCCCC CALL NORCDF(SNGL(DTERM1),CDF) CCCCC DCDF = DBLE(CDF) CCCCC IF(.NOT.DIR)DCDF=1.0D0 - DCDF CCCCC END IF C C BINOMIAL APPROXIMATION. C A=DBLE(L) B=DBLE(K-L) C=DBLE(N-L) D=DBLE(M+L-N-K) P1=DBLE(2*N-L)/DBLE(2*M-K+1) DTERM1=DBLE(K+1)*(A*P1-(B-1.0D0)*(1.0D0-P1)) DTERM2=-A*(A+2.0D0)/P1 + (B**2-1.0D0)/(1.0D0-P1) DTERM3=6.0D0*(2.0D0*DBLE(M)-DBLE(K)+1.0D0)**2 P2=P1+(DTERM1+DTERM2)/DTERM3 AP1=SNGL(P1) AP2=SNGL(P2) AX=REAL(L) IF (POINT) THEN CALL BINCDF(AX,AP2,K,CDF) IF(AX.LE.0.1)THEN DCDF=DBLE(CDF) ELSE AX=AX-1.0 CALL BINCDF(AX,AP2,K,CDF2) DCDF=DBLE(CDF-CDF2) ENDIF ELSE CALL BINCDF(AX,AP2,K,CDF) DCDF=DBLE(CDF) IF(.NOT.DIR) DCDF=1.0D0-DCDF ENDIF C C Calculate exact hypergeometric probabilities. C Interchange K and N if this saves calculations. C ELSE IF (MIN(K-1, M-K) .GT. MIN(N-1, M-N)) THEN I = K K = N N = I END IF IF (M-K .LT. K-1) THEN DIR = .NOT. DIR L = N - L + 1 K = M - K + 1 END IF IF (MM .GT. MBIG) THEN C C Take logarithms of factorials. C Use fact that GAMMA(N)=(N-1)!. USE DLNGAM function. C CCCCC P = ALNFAC(NN) - ALNFAC(MM) + ALNFAC(MM-KK) + ALNFAC(KK) + CCCCC* ALNFAC(MM-NN)-ALNFAC(LL)-ALNFAC(NN-LL)-ALNFAC(KK-LL) CCCCC* - ALNFAC(MM-NN-KK+LL) CCCCC P = DLNGAM(DBLE(NN-1)) - DLNGAM(DBLE(MM-1)) + CCCCC* DLNGAM(DBLE(MM-KK-1)) + DLNGAM(DBLE(KK-1)) + CCCCC* DLNGAM(DBLE(MM-NN-1)) - DLNGAM(DBLE(LL-1)) - CCCCC* DLNGAM(DBLE(NN-LL-1)) - DLNGAM((KK-LL-1)) - CCCCC* DLNGAM(DBLE(MM-NN-KK+LL-1)) DTERM1=DLNGAM(DBLE(NN+1)) DTERM2=DLNGAM(DBLE(MM+1)) DTERM3=DLNGAM(DBLE(MM-KK+1)) DTERM4=DLNGAM(DBLE(KK+1)) DTERM5=DLNGAM(DBLE(MM-NN+1)) DTERM6=DLNGAM(DBLE(LL+1)) DTERM7=DLNGAM(DBLE(NN-LL+1)) DTERM8=DLNGAM(DBLE(KK-LL+1)) DTERM9=DLNGAM(DBLE(MM-NN-KK+LL+1)) P=DTERM1-DTERM2+DTERM3+DTERM4+DTERM5- * DTERM6-DTERM7-DTERM8-DTERM9 DCDF = ZERO IF (P .GE. ELIMIT) DCDF = DEXP(P) C C Use Freeman/Lund algorithm C ELSE DO 3 I = 1, L-1 DCDF= DCDF*DBLE(K-I)*DBLE(N-I)/(DBLE(L-I)*DBLE(M-I)) 3 CONTINUE IF (L .NE. K) THEN J = M - N + L DO 5 I = L, K-1 DCDF = DCDF * DBLE(J-I) / DBLE(M-I) 5 CONTINUE END IF C END IF C IF (POINT) GOTO9999 C C We must recompute the point probability since it has underflowed. C IF (DCDF .EQ. ZERO) THEN IF (MM.LE.MBIG) * P = DLNGAM(DBLE(NN+1)) - DLNGAM(DBLE(MM+1)) + * DLNGAM(DBLE(KK+1)) + DLNGAM(DBLE(MM-NN+1)) - * DLNGAM(DBLE(LL+1)) - DLNGAM(DBLE(NN-LL+1)) - * DLNGAM(DBLE(KK-LL+1)) - DLNGAM(DBLE(MM-NN-KK+LL+1)) + * DLNGAM(DBLE(MM-KK+1)) P = P + DLOG(SCALE) IF (P .LT. ELIMIT) THEN WRITE(ICOUT,51) CALL DPWRST('XXX','BUG ') IF (LL .GT. DBLE(NN*KK + NN + KK +1)/(MM +2)) DCDF = ONE GOTO9999 ELSE P = DEXP(P) END IF 51 FORMAT('***** NON-FATAL DIAGNOSTIC--UNDERFLOW DETECTED. RESULT', 1' MAY BE IN ERROR.') ELSE C C Scale up at this point. C P = DCDF * SCALE END IF C PT = ZERO NL = N - L KL = K - L MNKL = M - N - KL + 1 IF (L .LE. KL) THEN DO 7 I = 1, L-1 P = P * DBLE(L-I) * DBLE(MNKL-I) /(DBLE(NL+I) * DBLE(KL+I)) PT = PT + P 7 CONTINUE IF (P .EQ. ZERO) THEN WRITE(ICOUT,51) CALL DPWRST('XXX','BUG ') ENDIF ELSE DIR = .NOT. DIR DO 9 J = 0, KL-1 P=P*DBLE(NL-J)*DBLE(KL-J)/(DBLE(L+J)*DBLE(MNKL+J)) PT = PT + P 9 CONTINUE IF (P .EQ. ZERO) THEN WRITE(ICOUT,51) CALL DPWRST('XXX','BUG ') ENDIF END IF C IF (DIR) THEN DCDF = DCDF + (PT / SCALE) ELSE DCDF = ONE - (PT / SCALE) END IF C END IF C 9999 CONTINUE CDF=SNGL(DCDF) RETURN END SUBROUTINE HYPPPF(P,K,N,M,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE AT THE SINGLE PRECISION VALUE P C FOR THE HYPERGEOMETRIC DISTRIBUTION C THE HYPERGEOMETRIC DISTRIBUTION IS THE PROBABILITY OF C SELECTING LL MARKED ITEMS WHEN A RANDOM SAMPLE OF SIZE C KK IS TAKEN WITHOUT REPLACEMENT FROM A POPULATION OF C MM ITEMS, NN OF WHICH ARE MARKED. IT HAS CDF OF: C CDF = P(X<= LL | KK, NN, MM) C INPUT ARGUMENTS--P = THE SINGLE PRECISION VALUE C AT WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. C IT SHOULD BE IN THE INTERVAL (0,1). C --KK = THE INTEGER VALUE INDICATING THE C SAMPLE SIZE. C --NN = THE NUMBER OF MARKED ITEMS IN THE C POPULATION. C --MM = THE POPULATION SIZE. C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--P SHOULD BE BETWEEN 0 and 1 (INCLUSIVELY). C --KK SHOULD BE A POSITIVE INTEGER BETWEEN 1 AND MM. C --NN SHOULD BE A POSITIVE INTEGER BETWEEN 1 AND MM. 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 HYPERGEOMETRIC DISTRIBUTION 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 (INCLUSIVELY). C OTHER DATAPAC SUBROUTINES NEEDED--NORPPF, HYPCDF. C MODE OF INTERNAL OPERATIONS--SINGLE 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. C --HASTINGS AND PEACOCK, STATISTICAL C DISTRIBUTIONS--A HANDBOOK FOR C STUDENTS AND PRACTITIONERS, 1975, C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--94/9 C ORIGINAL VERSION--SEPTEMBER 1994. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C LOGICAL POINT 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.GT.1.0)THEN WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PPF=0.0 ENDIF 1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ', 1' HYPPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') IF(N.LE.0.OR.N.GT.M)THEN WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)N CALL DPWRST('XXX','BUG ') PPF=0.0 RETURN ENDIF 11 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ', 1' HYPPPF SUBROUTINE (THE NUMBER OF MARKED ITEMS) ') 12 FORMAT(' IS LESS THAN ZERO OR GREATER THAN THE POULATION ', 1'SIZE.') IF(K.LE.0.OR.K.GT.M)THEN WRITE(ICOUT,21) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,22) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)K CALL DPWRST('XXX','BUG ') PPF=0.0 RETURN ENDIF 21 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ', 1' HYPPPF SUBROUTINE (THE SAMPLE SIZE) ') 22 FORMAT(' IS LESS THAN ZERO OR GREATER THAN THE POULATION ', 1'SIZE.') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') C 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 OR 1.0 C IF(P.EQ.0.0)GOTO110 IF(P.EQ.1.0)GOTO120 GOTO190 110 PPF=0.0 RETURN 120 PPF=REAL(MIN(N,K)) RETURN 190 CONTINUE C C DETERMINE AN INITIAL APPROXIMATION TO THE HYPERGEOMETRIC C PERCENT POINT BY USE OF THE BINOMIAL APPROXIMATION C TO THE HYPERGEOMETRIC. C PPAR=REAL(N)/REAL(M) IF(PPAR.LT.0.0.OR.PPAR.GT.1.0)PPAR=0.5 CALL BINPPF(P,PPAR,K,ZPPF) IX2=ZPPF C C CHECK AND MODIFY (IF NECESSARY) THIS INITIAL C ESTIMATE OF THE PERCENT POINT C TO ASSURE THAT IT BE IN THE CLOSED INTERVAL 0 TO MIN(N,K). C ITERM=MIN(N,K) IF(IX2.LT.0)IX2=0 IF(IX2.GT.ITERM)IX2=ITERM 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=N SD=(REAL(M-K)/REAL(M-1))*REAL(K)*(REAL(N)/REAL(M))* 1(1.0-REAL(N)/REAL(M)) ISD=SD+1.0 POINT=.FALSE. CALL HYPCDF(IX2,K,N,M,POINT,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 CALL HYPCDF(IX2,K,N,M,POINT,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 CALL HYPCDF(IX2,K,N,M,POINT,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 HYPERGEOMETRIC PROBABILITIES FOR THE C DERIVED LOWER AND UPPER BOUNDS. C CALL HYPCDF(IX0,K,N,M,POINT,P0) CALL HYPCDF(IX1,K,N,M,POINT,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 CALL HYPCDF(IX2,K,N,M,POINT,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 ') C 222 FORMAT(43HNO UPPER BOUND FOUND AFTER 10**7 ITERATIONS) 240 FORMAT(7HIX0 = ,I8,10X,5HP0 = ,F14.7) 241 FORMAT(7HIX1 = ,I8,10X,5HP1 = ,F14.7) 242 FORMAT(7HIX2 = ,I8,10X,5HP2 = ,F14.7) 244 FORMAT(7HP = ,F14.7) 249 FORMAT('***** INTERNAL ERROR IN HYPPPF 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 RETURN END SUBROUTINE HYPRAN(KK,NN1,NN2,ISEED,JX) CCCCC SUBROUTINE H2PEC(KK,NN1,NN2,ISEED,JX) C C ALGORITHM 668, COLLECTED ALGORITHMS FROM ACM. C THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE, C VOL. 14, NO. 4, PP. 397-398. C C C HYPERGEOMETRIC RANDOM VARIATE GENERATOR C C METHOD C IF (MODE - MAX(0,KK-NN2) .LT. 10), USE THE INVERSE CDF. C OTHERWISE, USE ALGORITHM H2PE: ACCEPTANCE-REJECTION VIA C THREE REGION COMPOSITION. THE THREE REGIONS ARE A C RECTANGLE, AND EXPONENTIAL LEFT AND RIGHT TAILS. C H2PE REFERS TO HYPERGEOMETRIC-2 POINTS-EXPONENTIAL TAILS. C H2PEC REFERS TO H2PE AND "COMBINED." THUS H2PE IS THE C RESEARCH RESULT AND H2PEC IS THE IMPLEMENTATION OF A C COMPLETE USABLE ALGORITHM. C C REFERENCE C VORATAS KACHITVICHYANUKUL AND BRUCE SCHMEISER, C C "COMPUTER GENERATION OF HYPERGEOMETRIC RANDOM VARIATES," C JOURNAL OF STATISTICAL COMPUTATION AND SIMULATION, C 22(1985), 2, 1985, 127-145. C C REQUIRED SUBPROGRAMS C AFC() : A DOUBLE-PRECISION FUNCTION TO EVALUATE C THE LOGARITHM OF THE FACTORIAL. C RAND(): A UNIFORM (0,1) RANDOM NUMBER GENERATOR. C C ARGUMENTS C NN1 : NUMBER OF WHITE BALLS (INPUT) C NN2 : NUMBER OF BLACK BALLS (INPUT) C KK : NUMBER OF BALLS TO BE DRAWN (INPUT) C ISEED : RANDOM NUMBER SEED (INPUT AND OUTPUT) C JX : NUMBER OF WHITE BALLS DRAWN (OUTPUT) C C STRUCTURAL VARIABLES C REJECT: LOGICAL FLAG TO REJECT THE VARIATE GENERATE BY H2PE. C SETUP1: LOGICAL FLAG TO SETUP FOR NEW VALUES OF NN1 OR NN2. C SETUP2: LOGICAL FLAG TO SETUP FOR NEW VALUES OF KK. C IX : INTEGER CANDIDATE VALUE. C M : DISTRIBUTION MODE. C MINJX : DISTRIBUTION LOWER BOUND. C MAXJX : DISTRIBUTION UPPER BOUND. C KS : SAVED VALUE OF KK FROM THE LAST CALL TO H2PEC. C N1S : SAVED VALUE OF NN1 FROM THE LAST CALL TO H2PEC. C N2S : SAVED VALUE OF NN2 FROM THE LAST CALL TO H2PEC. C K,N1,N2: ALTERNATE VARIABLES FOR KK, NN1, AND NN2 C (ALWAYS (N1 .LE. N2) AND (K .LE. (N1+N2)/2)). C TN : TOTAL NUMBER OF WHITE AND BLACK BALLS C C INVERSE-TRANSFORMATION VARIABLES C CON : NATURAL LOGARITHM OF SCALE. C P : CURRENT SCALED PROBABILITY FOR THE INVERSE CDF. C SCALE : A BIG CONSTANT (1.E25) USED TO SCALE THE C PROBABILITY TO AVOID NUMERICAL UNDERFLOW C U : THE UNIFORM VARIATE BETWEEN (0, 1.E25). C W : SCALED HYPERGEOMETRIC PROBABILITY OF MINJX. C C H2PE VARIABLES C S : DISTRIBUTION STANDARD DEVIATION. C D : HALF THE AREA OF THE RECTANGLE. C XL : LEFT END OF THE RECTANGLE. C XR : RIGHT END OF THE RECTANGLE. C A : A SCALING CONSTANT. C KL : HIGHEST POINT OF THE LEFT-TAIL REGION. C KR : HIGHEST POINT OF THE RIGHT-TAIL REGION. C LAMDL : RATE FOR THE LEFT EXPONENTIAL TAIL. C LAMDR : RATE FOR THE RIGHT EXPONENTIAL TAIL. C P1 : AREA OF THE RECTANGLE. C P2 : AREA OF THE LEFT EXPONENTIAL TAIL PLUS P1. C P3 : AREA OF THE RIGHT EXPONENTIAL TAIL PLUS P2. C U : A UNIFORM (0,P3) RANDOM VARIATE USED FIRST TO SELECT C ONE OF THE THREE REGIONS AND THEN CONDITIONALLY TO C GENERATE A VALUE FROM THE REGION. C V : U(0,1) RANDOM NUMBER USED TO GENERATE THE RANDOM C VALUE OR TO ACCEPT OR REJECT THE CANDIDATE VALUE. C F : THE HEIGHT OF THE SCALED DENSITY FUNCTION USED IN THE C ACCEPT/REJECT DECISION WHEN BOTH M AND IX ARE SMALL. C I : INDEX FOR EXPLICIT CALCULATION OF F FOR H2PE. C C THE FOLLOWING VARIABLES ARE TEMPORARY VARIABLES USED IN C COMPUTING THE UPPER AND LOWER BOUNDS OF THE NATURAL LOGARITHM C OF THE SCALED DENSITY. THE DETAILED DESCRIPTION IS GIVEN IN C PROPOSITIONS 2 AND 3 OF THE APPENDIX IN THE REFERENCE. C Y, Y1, YM, YN, YK, NK, R, S, T, E, G, DG, GU, GL, XM, C XN, XK, NM C C Y : PRELIMINARY CONTINUOUS CANDIDATE VALUE, FLOAT(IX) C UB : UPPER BOUND FOR THE NATURAL LOGARITHM OF THE SCALED C DENSITY. C ALV : NATURAL LOGARITHM OF THE ACCEPT/REJECT VARIATE V. C DR, DS, DT, DE: ONE OF MANY TERMS SUBTRACTED FROM THE UPPER C BOUND TO OBTAIN THE LOWER BOUND ON THE NATURAL C LOGARITHM OF THE SCALED DENSITY. C DELTAU: A CONSTANT, THE VALUE 0.0034 IS OBTAINED BY SETTING C N1 = N2 = 200, K = 199, M = 100, AND Y = 50 IN C THE FUNCTION DELTA_U IN LEMMA 1 AND ROUNDING THE C VALUE TO FOUR DECIMAL PLACES. C DELTAL: A CONSTANT, THE VALUE 0.0078 IS OBTAINED BY SETTING C N1 = N2 = 200, K = 199, M = 100, AND Y = 50 IN C THE FUNCTION DELTA_L IN LEMMA 1 AND ROUNDING THE C VALUE TO FOUR DECIMAL PLACES. C SAVE CCCCC SEPTEMBER 1995. USE DLNGAM FUNCTION IN PLACE OF AFC CCCCC DOUBLE PRECISION AFC,CON,P,SCALE,U,W,A,XL,XR DOUBLE PRECISION DLNGAM,CON,P,SCALE,U,W,A,XL,XR REAL KL,KR,LAMDL,LAMDR,NK,NM CCCCC AUGUST 1995. ADD FOLLOWING ARRAY FOR DATAPLOT CCCCC UNIFORM RANDOM NUMBER GENERATOR. REAL XTEMP(1) C LOGICAL REJECT,SETUP1,SETUP2 DATA KS,N1S,N2S/-1,-1,-1/ DATA CON,DELTAL,DELTAU,SCALE/57.56462733D0,0.0078,0.0034,1.D25/ C C*****CHECK PARAMETER VALIDITY C IF ( (NN1 .LT. 0) .OR. $ (NN2 .LT. 0) .OR. $ (KK .LT. 0) .OR. $ (KK .GT. NN1 + NN2 ) ) THEN JX = -1 RETURN ENDIF C C*****IF NEW PARAMETER VALUES, INITIALIZE C REJECT = .TRUE. SETUP1 = .FALSE. SETUP2 = .FALSE. IF ((NN1 .NE. N1S) .OR. (NN2 .NE. N2S)) THEN SETUP1 = .TRUE. SETUP2 = .TRUE. ELSEIF (KK .NE. KS) THEN SETUP2 = .TRUE. ENDIF C IF (SETUP1) THEN N1S = NN1 N2S = NN2 TN = NN1 + NN2 IF (NN1 .LE. NN2) THEN N1 = NN1 N2 = NN2 ELSE N1 = NN2 N2 = NN1 ENDIF ENDIF C IF (SETUP2) THEN KS = KK IF (KK+KK .GE. TN) THEN K = TN - KK ELSE K = KK ENDIF ENDIF C IF (SETUP1 .OR. SETUP2) THEN M = INT ((K+1.) * (N1+1.) / (TN+2.)) MINJX = MAX (0, K-N2) MAXJX = MIN (N1, K) ENDIF C C*****GENERATE RANDOM VARIATE C IF (MINJX .EQ. MAXJX) THEN C C ...DEGENERATE DISTRIBUTION... C IX = MAXJX RETURN ELSEIF (M-MINJX .LT. 10) THEN C C ...INVERSE TRANSFORMATION... C IF (SETUP1 .OR. SETUP2) THEN IF (K .LT. N2) THEN CCCCC SEPTEMBER 1995. USE DLNGAM INSTEAD OF AFC CCCCC W = EXP (CON + AFC(N2) + AFC(N1+N2-K) CCCCC$ - AFC(N2-K) - AFC(N1+N2)) W = EXP (CON + DLNGAM(DBLE(N2+1))+DLNGAM(DBLE(N1+N2-K+1)) $ - DLNGAM(DBLE(N2-K+1)) - DLNGAM(DBLE(N1+N2+1))) ELSE CCCCC SEPTEMBER 1995. USE DLNGAM INSTEAD OF AFC CCCCC W = EXP (CON + AFC(N1) + AFC(K) CCCCC$ - AFC(K-N2) - AFC(N1+N2)) W = EXP (CON + DLNGAM(DBLE(N1+1)) + DLNGAM(DBLE(K+1)) $ - DLNGAM(DBLE(K-N2+1)) - DLNGAM(DBLE(N1+N2+1))) ENDIF ENDIF C 10 P = W IX = MINJX CCCCC SEPTEMBER 1995. REPLACE RAND WITH DATAPLOT UNIFORM RANDOM CCCCC NUMBER GENERATOR. NTEMP=1 CALL UNIRAN(NTEMP,ISEED,XTEMP) U = XTEMP(1)*SCALE CCCCCC U = RAND (ISEED) * SCALE 20 IF (U .GT. P) THEN U = U - P P = P * (N1-IX)*(K-IX) IX = IX + 1 P = P / IX / (N2-K+IX) IF (IX .GT. MAXJX) GO TO 10 GO TO 20 ENDIF ELSE C C ...H2PE... C IF (SETUP1 .OR. SETUP2) THEN S = SQRT ((TN-K) * K * N1 * N2 / (TN-1) / TN /TN) C C ...REMARK: D IS DEFINED IN REFERENCE WITHOUT INT. C THE TRUNCATION CENTERS THE CELL BOUNDARIES AT 0.5 C D = INT (1.5*S) + .5 XL = M - D + .5 XR = M + D + .5 CCCCC SEPTEMBER 1995. USE DLNGAM INSTEAD OF AFC CCCCC A = AFC(M) + AFC(N1-M) + AFC(K-M) + AFC(N2-K+M) CCCCC KL = EXP (A - AFC(INT(XL)) - AFC(INT(N1-XL)) CCCCC$ - AFC(INT(K-XL)) - AFC(INT(N2-K+XL))) CCCCC KR = EXP (A - AFC(INT(XR-1)) - AFC(INT(N1-XR+1)) CCCCC$ - AFC(INT(K-XR+1)) - AFC(INT(N2-K+XR-1))) A = DLNGAM(DBLE(M+1)) + DLNGAM(DBLE(N1-M+1)) + 1 DLNGAM(DBLE(K-M+1)) + DLNGAM(DBLE(N2-K+M+1)) KL = EXP (A - DLNGAM(DBLE(INT(XL)+1)) - 1 DLNGAM(DBLE(INT(N1-XL)+1)) 1 - DLNGAM(DBLE(INT(K-XL)+1)) - 1 DLNGAM(DBLE(INT(N2-K+XL)+1))) KR = EXP(A-DLNGAM(DBLE(INT(XR-1)+1)) - 1 DLNGAM(DBLE(INT(N1-XR+1)+1)) 1 - DLNGAM(DBLE(INT(K-XR+1)+1)) - 1 DLNGAM(DBLE(INT(N2-K+XR-1)+1))) LAMDL = -LOG (XL * (N2-K+XL) / (N1-XL+1) / (K-XL+1)) LAMDR = -LOG ((N1-XR+1) * (K-XR+1) / XR / (N2-K+XR)) P1 = D + D P2 = P1 + KL / LAMDL P3 = P2 + KR / LAMDR ENDIF C 30 CONTINUE CCCCC AUGUST 1995. REPLACE RAND WITH DATAPLOT UNIFORM RANDOM CCCCC NUMBER GENERATOR. NTEMP=1 CALL UNIRAN(NTEMP,ISEED,XTEMP) U = XTEMP(1) * P3 CALL UNIRAN(NTEMP,ISEED,XTEMP) V = XTEMP(1) CCC30 U = RAND (ISEED) * P3 CCCCC V = RAND (ISEED) IF (U .LT. P1) THEN C C ...RECTANGULAR REGION... C IX = XL + U ELSEIF (U .LE. P2) THEN C C ...LEFT TAIL... C IX = XL + LOG(V)/LAMDL IF (IX .LT. MINJX) GO TO 30 V = V * (U-P1) * LAMDL ELSE C C ...RIGHT TAIL... C IX = XR - LOG(V)/LAMDR IF (IX .GT. MAXJX) GO TO 30 V = V * (U-P2) * LAMDR ENDIF C C ...ACCEPTANCE/REJECTION TEST... C IF (M .LT. 100 .OR. IX .LE. 50) THEN C C ...EXPLICIT EVALUATION... C F = 1.0 IF (M .LT. IX) THEN DO 40 I = M+1,IX 40 F = F * (N1-I+1) * (K-I+1) / (N2-K+I) / I ELSEIF (M .GT. IX) THEN DO 50 I = IX+1,M 50 F = F * I * (N2-K+I) / (N1-I) / (K-I) ENDIF IF (V .LE. F) THEN REJECT = .FALSE. ENDIF ELSE C C ...SQUEEZE USING UPPER AND LOWER BOUNDS... C Y = IX Y1 = Y + 1. YM = Y - M YN = N1 - Y + 1. YK = K - Y + 1. NK = N2 - K + Y1 R = -YM / Y1 S = YM / YN T = YM / YK E = -YM / NK G = YN * YK / (Y1*NK) - 1. DG = 1. IF (G .LT. 0.) DG = 1.+G GU = G * (1.+G*(-.5+G/3.)) GL = GU - .25 * (G*G)**2 / DG XM = M + .5 XN = N1 - M + .5 XK = K - M + .5 NM = N2 - K + XM UB = Y * GU - M * GL + DELTAU $ + XM * R * (1.+R*(-.5+R/3.)) $ + XN * S * (1.+S*(-.5+S/3.)) $ + XK * T * (1.+T*(-.5+T/3.)) $ + NM * E * (1.+E*(-.5+E/3.)) C C ...TEST AGAINST UPPER BOUND... C ALV = LOG(V) IF (ALV .GT. UB) THEN REJECT = .TRUE. ELSE C C ...TEST AGAINST LOWER BOUND... C DR = XM * (R*R)**2 IF (R .LT. 0.) DR = DR / (1.+R) DS = XN * (S*S)**2 IF (S .LT. 0.) DS = DS / (1.+S) DT = XK * (T*T)**2 IF (T .LT. 0.) DT = DT / (1.+T) DE = NM * (E*E)**2 IF (E .LT. 0.) DE = DE / (1.+E) IF (ALV .LT. UB-.25*(DR+DS+DT+DE) $ +(Y+M)*(GL-GU)-DELTAL) THEN REJECT = .FALSE. ELSE C C ...STIRLING'S FORMULA TO MACHINE ACCURACY... C CCCCC SEPTEMBER 1995. USE DLNGAM INSTEAD OF AFC CCCCC IF (ALV .LE. (A - AFC(IX) - AFC(N1-IX) CCCCC$ - AFC(K-IX) - AFC(N2-K+IX)) ) THEN IF (ALV .LE.(A-DLNGAM(DBLE(IX+1)) - $ DLNGAM(DBLE(N1-IX+1)) $ - DLNGAM(DBLE(K-IX+1)) $ - DLNGAM(DBLE(N2-K+IX+1)))) $ THEN REJECT = .FALSE. ELSE REJECT = .TRUE. ENDIF ENDIF ENDIF ENDIF IF (REJECT) GO TO 30 ENDIF C C*****RETURN APPROPRIATE VARIATE C IF (KK + KK .GE. TN) THEN IF (NN1 .GT. NN2) THEN IX = KK - NN2 + IX ELSE IX = NN1 - IX ENDIF ELSE IF (NN1 .GT. NN2) IX = KK - IX ENDIF JX = IX RETURN END DOUBLE PRECISION FUNCTION I0INT(XVALUE) C C DESCRIPTION: C This program computes the integral of the modified Bessel C function I0(x) using the definition C C I0INT(x) = {integral 0 to x} I0(t) dt C C The program uses Chebyshev expansions, the coefficients of C which are given to 20 decimal places. C C C ERROR RETURNS: C If |XVALUE| larger than a certain limit, the value of C I0INT would cause an overflow. If such a situation occurs C the programs prints an error message, and returns the C value sign(XVALUE)*XMAX, where XMAX is the largest C acceptable floating-pt. value. C C C MACHINE-DEPENDENT CONSTANTS: C C NTERM1 - The no. of terms to be used from the array ARI01. C The recommended value is such that C ABS(ARI01(NTERM1)) < EPS/100 C C NTERM2 - The no. of terms to be used from the array ARI0A. C The recommended value is such that C ABS(ARI0A(NTERM2)) < EPS/100 C C XLOW - The value below which I0INT(x) = x, to machine precision. C The recommended value is C sqrt(12*EPS). C C XHIGH - The value above which overflow will occur. The C recommended value is C ln(XMAX) + 0.5*ln(ln(XMAX)) + ln(2). C C For values of EPS and XMAX refer to the file MACHCON.TXT. C C The machine-dependent constants are computed internally by C using the D1MACH subroutine. C C C INTRINSIC FUNCTIONS USED: C C EXP , LOG , SQRT C C C OTHER MISCFUN SUBROUTINES USED: C C CHEVAL , ERRPRN, D1MACH C C C AUTHOR: C C Dr. Allan J. MacLeod, C Dept. of Mathematics and Statistics, C University of Paisley, C High St., C Paisley, C SCOTLAND C PA1 2BE C C (e-mail : macl_ms0@paisley.ac.uk ) C C C LATEST REVISION: C 23 January, 1996 C INTEGER IND,NTERM1,NTERM2 DOUBLE PRECISION ARI01(0:28),ARI0A(0:33), 1 ATEEN,CHEVAL,HALF,LNR2PI,ONEHUN,T,TEMP,THREE,THIRT6, 2 X,XHIGH,XLOW,XVALUE,ZERO C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOMC.INC' CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C CCCCC CHARACTER FNNAME*6,ERRMSG*26 CCCCC DATA FNNAME/'I0INT '/ CCCCC DATA ERRMSG/'SIZE OF ARGUMENT TOO LARGE'/ DATA ZERO,HALF,THREE/ 0.0 D 0 , 0.5 D 0 , 3.0 D 0 / DATA ATEEN,THIRT6,ONEHUN/ 18.0 D 0 , 36.0 D 0 , 100.0 D 0/ DATA LNR2PI/0.91893 85332 04672 74178 D 0/ DATA ARI01(0)/ 0.41227 90692 67815 16801 D 0/ DATA ARI01(1)/ -0.34336 34515 00815 19562 D 0/ DATA ARI01(2)/ 0.22667 58871 57512 42585 D 0/ DATA ARI01(3)/ -0.12608 16471 87422 60032 D 0/ DATA ARI01(4)/ 0.60124 84628 77799 0271 D -1/ DATA ARI01(5)/ -0.24801 20462 91335 8248 D -1/ DATA ARI01(6)/ 0.89277 33895 65563 897 D -2/ DATA ARI01(7)/ -0.28325 37299 36696 605 D -2/ DATA ARI01(8)/ 0.79891 33904 17129 94 D -3/ DATA ARI01(9)/ -0.20053 93366 09648 90 D -3/ DATA ARI01(10)/ 0.44168 16783 01431 3 D -4/ DATA ARI01(11)/-0.82237 70422 46068 D -5/ DATA ARI01(12)/ 0.12005 97942 19015 D -5/ DATA ARI01(13)/-0.11350 86500 4889 D -6/ DATA ARI01(14)/ 0.69606 01446 6 D -9/ DATA ARI01(15)/ 0.18062 27728 36 D -8/ DATA ARI01(16)/-0.26039 48137 0 D -9/ DATA ARI01(17)/-0.16618 8103 D -11/ DATA ARI01(18)/ 0.51050 0232 D -11/ DATA ARI01(19)/-0.41515 879 D -12/ DATA ARI01(20)/-0.73681 38 D -13/ DATA ARI01(21)/ 0.12793 23 D -13/ DATA ARI01(22)/ 0.10324 7 D -14/ DATA ARI01(23)/-0.30379 D -15/ DATA ARI01(24)/-0.1789 D -16/ DATA ARI01(25)/ 0.673 D -17/ DATA ARI01(26)/ 0.44 D -18/ DATA ARI01(27)/-0.14 D -18/ DATA ARI01(28)/-0.1 D -19/ DATA ARI0A(0)/ 2.03739 65457 11432 87070 D 0/ DATA ARI0A(1)/ 0.19176 31647 50331 0248 D -1/ DATA ARI0A(2)/ 0.49923 33451 92881 47 D -3/ DATA ARI0A(3)/ 0.22631 87103 65981 5 D -4/ DATA ARI0A(4)/ 0.15868 21082 85561 D -5/ DATA ARI0A(5)/ 0.16507 85563 6318 D -6/ DATA ARI0A(6)/ 0.23850 58373 640 D -7/ DATA ARI0A(7)/ 0.39298 51823 04 D -8/ DATA ARI0A(8)/ 0.46042 71419 9 D -9/ DATA ARI0A(9)/ -0.70725 58172 D -10/ DATA ARI0A(10)/-0.67471 83961 D -10/ DATA ARI0A(11)/-0.20269 62001 D -10/ DATA ARI0A(12)/-0.87320 338 D -12/ DATA ARI0A(13)/ 0.17552 0014 D -11/ DATA ARI0A(14)/ 0.60383 944 D -12/ DATA ARI0A(15)/-0.39779 83 D -13/ DATA ARI0A(16)/-0.80490 48 D -13/ DATA ARI0A(17)/-0.11589 55 D -13/ DATA ARI0A(18)/ 0.82731 8 D -14/ DATA ARI0A(19)/ 0.28229 0 D -14/ DATA ARI0A(20)/-0.77667 D -15/ DATA ARI0A(21)/-0.48731 D -15/ DATA ARI0A(22)/ 0.7279 D -16/ DATA ARI0A(23)/ 0.7873 D -16/ DATA ARI0A(24)/-0.785 D -17/ DATA ARI0A(25)/-0.1281 D -16/ DATA ARI0A(26)/ 0.121 D -17/ DATA ARI0A(27)/ 0.214 D -17/ DATA ARI0A(28)/-0.27 D -18/ DATA ARI0A(29)/-0.36 D -18/ DATA ARI0A(30)/ 0.7 D -19/ DATA ARI0A(31)/ 0.6 D -19/ DATA ARI0A(32)/-0.2 D -19/ DATA ARI0A(33)/-0.1 D -19/ C C Start computation C IND = 1 X = XVALUE IF ( XVALUE .LT. ZERO ) THEN IND = -1 X = -X ENDIF C C Compute the machine-dependent constants. C T = LOG(D1MACH(2)) XHIGH = T + LOG(T)*HALF - LOG(HALF) C C Error test C IF ( X .GT. XHIGH ) THEN CCCCC CALL ERRPRN(FNNAME,ERRMSG) WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,101)X CALL DPWRST('XXX','BUG ') I0INT = EXP ( XHIGH - LNR2PI - HALF * LOG(XHIGH) ) IF ( IND .EQ. -1 ) I0INT = -I0INT RETURN ENDIF 999 FORMAT(1X) 101 FORMAT('***** ERROR FROM I0INT--SIZE OF THE INPUT ARGUMENT ', 1 'IS TOO LARGE, ARGUMENT = ',G15.7) C C Continue with machine-constants C TEMP = D1MACH(3) T = TEMP / ONEHUN IF ( X .LE. ATEEN ) THEN DO 10 NTERM1 = 28 , 0 , -1 IF ( ABS(ARI01(NTERM1)) .GT. T ) GOTO 19 10 CONTINUE 19 XLOW = SQRT ( THIRT6 * TEMP / THREE ) ELSE DO 40 NTERM2 = 33 , 0 , -1 IF ( ABS(ARI0A(NTERM2)) .GT. T ) GOTO 49 40 CONTINUE 49 ENDIF C C Code for 0 <= |x| <= 18 C IF ( X .LE. ATEEN ) THEN IF ( X .LT. XLOW ) THEN I0INT = X ELSE T = ( THREE * X - ATEEN ) / ( X + ATEEN ) I0INT = X * EXP(X) * CHEVAL(NTERM1,ARI01,T) ENDIF ELSE C C Code for |x| > 18 C T = ( THIRT6 / X - HALF ) - HALF TEMP = X - HALF*LOG(X) - LNR2PI + LOG(CHEVAL(NTERM2,ARI0A,T)) I0INT = EXP(TEMP) ENDIF IF ( IND .EQ. -1 ) I0INT = -I0INT RETURN END DOUBLE PRECISION FUNCTION I0ML0(XVALUE) C C DESCRIPTION: C C This program calculates the function I0ML0 defined as C C I0ML0(x) = I0(x) - L0(x) C C where I0(x) is the modified Bessel function of the first kind of C order 0, and L0(x) is the modified Struve function of order 0. C C The code uses Chebyshev expansions with the coefficients C given to an accuracy of 20D. C C C ERROR RETURNS: C C The coefficients are only suitable for XVALUE >= 0.0. If C XVALUE < 0.0, an error message is printed and the function C returns the value 0.0 C C C MACHINE-DEPENDENT PARAMETERS: C C NTERM1 - INTEGER - The number of terms required for the array C AI0L0. The recommended value is such that C ABS(AI0L0(NTERM1)) < EPS/100 C C NTERM2 - INTEGER - The number of terms required for the array C AI0L0A. The recommended value is such that C ABS(AI0L0A(NTERM2)) < EPS/100 C C XLOW - DOUBLE PRECISION - The value below which I0ML0(x) = 1 to machine C precision. The recommended value is C EPSNEG C C XHIGH - DOUBLE PRECISION - The value above which I0ML0(x) = 2/(pi*x) to C machine precision. The recommended value is C SQRT(800/EPS) C C For values of EPS, and EPSNEG see the file MACHCON.TXT C C The machine-dependent constants are computed internally by C using the D1MACH subroutine. C C C INTRINSIC FUNCTIONS USED: C C SQRT C C C OTHER MISCFUN SUBROUTINES USED: C C CHEVAL , ERRPRN, D1MACH C C C AUTHOR: C Dr. Allan J. MacLeod C Dept. of Mathematics and Statistics C University of Paisley C High St. C Paisley C SCOTLAND C PA1 2BE C C ( e-mail: macl_ms0@paisley.ac.uk ) C C C LATEST REVISION: C 23 January, 1996 C INTEGER NTERM1,NTERM2 DOUBLE PRECISION AI0L0(0:23),AI0L0A(0:23),ATEHUN,CHEVAL, 1 FORTY,ONE,ONEHUN,SIX,SIXTEN,T,TWOBPI,TWO88,X,XHIGH, 2 XLOW,XSQ,XVALUE,ZERO C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOMC.INC' CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C CCCCC CHARACTER FNNAME*6,ERRMSG*14 CCCCC DATA FNNAME/'I0ML0 '/ CCCCC DATA ERRMSG/'ARGUMENT < 0.0'/ DATA ZERO,ONE/ 0.0 D 0 , 1.0 D 0 / DATA SIX,SIXTEN/ 6.0 D 0 , 16.0 D 0 / DATA FORTY,ONEHUN/ 40.0 D 0 , 100.0 D 0 / DATA TWO88,ATEHUN/ 288.0 D 0 , 800.0 D 0 / DATA TWOBPI/0.63661 97723 67581 34308 D 0/ DATA AI0L0(0)/ 0.52468 73679 14855 99138 D 0/ DATA AI0L0(1)/ -0.35612 46069 96505 86196 D 0/ DATA AI0L0(2)/ 0.20487 20286 40099 27687 D 0/ DATA AI0L0(3)/ -0.10418 64052 04026 93629 D 0/ DATA AI0L0(4)/ 0.46342 11095 54842 9228 D -1/ DATA AI0L0(5)/ -0.17905 87192 40349 8630 D -1/ DATA AI0L0(6)/ 0.59796 86954 81143 177 D -2/ DATA AI0L0(7)/ -0.17177 75476 93565 429 D -2/ DATA AI0L0(8)/ 0.42204 65446 91714 22 D -3/ DATA AI0L0(9)/ -0.87961 78522 09412 5 D -4/ DATA AI0L0(10)/ 0.15354 34234 86922 3 D -4/ DATA AI0L0(11)/-0.21978 07695 84743 D -5/ DATA AI0L0(12)/ 0.24820 68393 6666 D -6/ DATA AI0L0(13)/-0.20327 06035 607 D -7/ DATA AI0L0(14)/ 0.90984 19842 1 D -9/ DATA AI0L0(15)/ 0.25617 93929 D -10/ DATA AI0L0(16)/-0.71060 9790 D -11/ DATA AI0L0(17)/ 0.32716 960 D -12/ DATA AI0L0(18)/ 0.23002 15 D -13/ DATA AI0L0(19)/-0.29210 9 D -14/ DATA AI0L0(20)/-0.3566 D -16/ DATA AI0L0(21)/ 0.1832 D -16/ DATA AI0L0(22)/-0.10 D -18/ DATA AI0L0(23)/-0.11 D -18/ DATA AI0L0A(0)/ 2.00326 51024 11606 43125 D 0/ DATA AI0L0A(1)/ 0.19520 68515 76492 081 D -2/ DATA AI0L0A(2)/ 0.38239 52356 99083 28 D -3/ DATA AI0L0A(3)/ 0.75342 80817 05443 6 D -4/ DATA AI0L0A(4)/ 0.14959 57655 89707 8 D -4/ DATA AI0L0A(5)/ 0.29994 05312 10557 D -5/ DATA AI0L0A(6)/ 0.60769 60482 2459 D -6/ DATA AI0L0A(7)/ 0.12399 49554 4506 D -6/ DATA AI0L0A(8)/ 0.25232 62552 649 D -7/ DATA AI0L0A(9)/ 0.50463 48573 32 D -8/ DATA AI0L0A(10)/0.97913 23623 0 D -9/ DATA AI0L0A(11)/0.18389 11524 1 D -9/ DATA AI0L0A(12)/0.33763 09278 D -10/ DATA AI0L0A(13)/0.61117 9703 D -11/ DATA AI0L0A(14)/0.10847 2972 D -11/ DATA AI0L0A(15)/0.18861 271 D -12/ DATA AI0L0A(16)/0.32803 45 D -13/ DATA AI0L0A(17)/0.56564 7 D -14/ DATA AI0L0A(18)/0.93300 D -15/ DATA AI0L0A(19)/0.15881 D -15/ DATA AI0L0A(20)/0.2791 D -16/ DATA AI0L0A(21)/0.389 D -17/ DATA AI0L0A(22)/0.70 D -18/ DATA AI0L0A(23)/0.16 D -18/ C C Start computation C X = XVALUE C C Error test C IF ( X .LT. ZERO ) THEN CCCCC CALL ERRPRN(FNNAME,ERRMSG) WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,101)X CALL DPWRST('XXX','BUG ') I0ML0 = ZERO RETURN ENDIF 999 FORMAT(1X) 101 FORMAT('***** ERROR FROM I0ML0--ARGUMENT MUST BE ', 1 'NON-NEGATIVE, ARGUMENT = ',G15.7) C C Compute the machine-dependent constants. C XSQ = D1MACH(3) T = XSQ / ONEHUN IF ( X .LE. SIXTEN ) THEN DO 10 NTERM1 = 23 , 0 , -1 IF ( ABS(AI0L0(NTERM1)) .GT. T ) GOTO 19 10 CONTINUE 19 XLOW = XSQ ELSE DO 40 NTERM2 = 23 , 0 , -1 IF ( ABS(AI0L0A(NTERM2)) .GT. T ) GOTO 49 40 CONTINUE 49 XHIGH = SQRT ( ATEHUN / XSQ ) ENDIF C C Code for x <= 16 C IF ( X .LE. SIXTEN ) THEN IF ( X .LT. XLOW ) THEN I0ML0 = ONE RETURN ELSE T = ( SIX * X - FORTY ) / ( X + FORTY ) I0ML0 = CHEVAL(NTERM1,AI0L0,T) RETURN ENDIF ELSE C C Code for x > 16 C IF ( X .GT. XHIGH ) THEN I0ML0 = TWOBPI / X ELSE XSQ = X * X T = ( ATEHUN - XSQ ) / ( TWO88 + XSQ ) I0ML0 = CHEVAL(NTERM2,AI0L0A,T) * TWOBPI / X ENDIF ENDIF RETURN END DOUBLE PRECISION FUNCTION I1ML1(XVALUE) C C DESCRIPTION: C C This program calculates the function I1ML1 defined as C C I1ML1(x) = I1(x) - L1(x) C C where I1(x) is the modified Bessel function of the first kind of C order 1, and L1(x) is the modified Struve function of order 1. C C The code uses Chebyshev expansions with the coefficients C given to an accuracy of 20D. C C C ERROR RETURNS: C C The coefficients are only suitable for XVALUE >= 0.0. If C XVALUE < 0.0, an error message is printed and the function C returns the value 0.0 C C C MACHINE-DEPENDENT PARAMETERS: C C NTERM1 - INTEGER - The number of terms required for the array C AI1L1. The recommended value is such that C ABS(AI1L1(NTERM1)) < EPS/100 C C NTERM2 - INTEGER - The number of terms required for the array C AI1L1A. The recommended value is such that C ABS(AI1L1A(NTERM2)) < EPS/100 C C XLOW - DOUBLE PRECISION - The value below which I1ML1(x) = x/2 to machine C precision. The recommended value is C 2*EPSNEG C C XHIGH - DOUBLE PRECISION - The value above which I1ML1(x) = 2/pi to C machine precision. The recommended value is C SQRT(800/EPS) C C For values of EPS, and EPSNEG see the file MACHCON.TXT C C The machine-dependent constants are computed internally by C using the D1MACH subroutine. C C C INTRINSIC FUNCTIONS USED: C C ABS , SQRT C C C OTHER MISCFUN SUBROUTINES USED: C C CHEVAL , ERRPRN, D1MACH C C C AUTHOR: C Dr. Allan J. MacLeod C Dept. of Mathematics and Statistics C University of Paisley C High St. C Paisley C SCOTLAND C PA1 2BE C C (e-mail: macl_ms0@paisley.ac.uk ) C C C LATEST REVISION: C 23 January, 1996 C INTEGER NTERM1,NTERM2 DOUBLE PRECISION AI1L1(0:23),AI1L1A(0:25),ATEHUN,CHEVAL, 1 FORTY,ONE,ONEHUN,SIX,SIXTEN,T,TWO,TWOBPI,TWO88, 2 X,XHIGH,XLOW,XSQ,XVALUE,ZERO CCCCC CHARACTER FNNAME*6,ERRMSG*14 CCCCC DATA FNNAME/'I1ML1 '/ CCCCC DATA ERRMSG/'ARGUMENT < 0.0'/ 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 DATA ZERO,ONE,TWO/ 0.0 D 0 , 1.0 D 0 , 2.0 D 0 / DATA SIX,SIXTEN,FORTY/ 6.0 D 0 , 16.0 D 0 , 40.0 D 0 / DATA ONEHUN,TWO88,ATEHUN/ 100.0 D 0 , 288.0 D 0 , 800.0 D 0 / DATA TWOBPI/0.63661 97723 67581 34308 D 0/ DATA AI1L1(0)/ 0.67536 36906 23505 76137 D 0/ DATA AI1L1(1)/ -0.38134 97109 72665 59040 D 0/ DATA AI1L1(2)/ 0.17452 17077 51339 43559 D 0/ DATA AI1L1(3)/ -0.70621 05887 23502 5061 D -1/ DATA AI1L1(4)/ 0.25173 41413 55880 3702 D -1/ DATA AI1L1(5)/ -0.78709 85616 06423 321 D -2/ DATA AI1L1(6)/ 0.21481 43686 51922 006 D -2/ DATA AI1L1(7)/ -0.50862 19971 79062 36 D -3/ DATA AI1L1(8)/ 0.10362 60828 04423 30 D -3/ DATA AI1L1(9)/ -0.17954 47212 05724 7 D -4/ DATA AI1L1(10)/ 0.25978 82745 15414 D -5/ DATA AI1L1(11)/-0.30442 40632 4667 D -6/ DATA AI1L1(12)/ 0.27202 39894 766 D -7/ DATA AI1L1(13)/-0.15812 61441 90 D -8/ DATA AI1L1(14)/ 0.18162 09172 D -10/ DATA AI1L1(15)/ 0.64796 7659 D -11/ DATA AI1L1(16)/-0.54113 290 D -12/ DATA AI1L1(17)/-0.30831 1 D -14/ DATA AI1L1(18)/ 0.30563 8 D -14/ DATA AI1L1(19)/-0.9717 D -16/ DATA AI1L1(20)/-0.1422 D -16/ DATA AI1L1(21)/ 0.84 D -18/ DATA AI1L1(22)/ 0.7 D -19/ DATA AI1L1(23)/-0.1 D -19/ DATA AI1L1A(0)/ 1.99679 36189 67891 36501 D 0/ DATA AI1L1A(1)/ -0.19066 32614 09686 132 D -2/ DATA AI1L1A(2)/ -0.36094 62241 01744 81 D -3/ DATA AI1L1A(3)/ -0.68418 47304 59982 0 D -4/ DATA AI1L1A(4)/ -0.12990 08228 50942 6 D -4/ DATA AI1L1A(5)/ -0.24715 21887 05765 D -5/ DATA AI1L1A(6)/ -0.47147 83969 1972 D -6/ DATA AI1L1A(7)/ -0.90208 19982 592 D -7/ DATA AI1L1A(8)/ -0.17304 58637 504 D -7/ DATA AI1L1A(9)/ -0.33232 36701 59 D -8/ DATA AI1L1A(10)/-0.63736 42173 5 D -9/ DATA AI1L1A(11)/-0.12180 23975 6 D -9/ DATA AI1L1A(12)/-0.23173 46832 D -10/ DATA AI1L1A(13)/-0.43906 8833 D -11/ DATA AI1L1A(14)/-0.82847 110 D -12/ DATA AI1L1A(15)/-0.15562 249 D -12/ DATA AI1L1A(16)/-0.29131 12 D -13/ DATA AI1L1A(17)/-0.54396 5 D -14/ DATA AI1L1A(18)/-0.10117 7 D -14/ DATA AI1L1A(19)/-0.18767 D -15/ DATA AI1L1A(20)/-0.3484 D -16/ DATA AI1L1A(21)/-0.643 D -17/ DATA AI1L1A(22)/-0.118 D -17/ DATA AI1L1A(23)/-0.22 D -18/ DATA AI1L1A(24)/-0.4 D -19/ DATA AI1L1A(25)/-0.1 D -19/ C C Start computation C X = XVALUE C C Error test C IF ( X .LT. ZERO ) THEN CCCCC CALL ERRPRN(FNNAME,ERRMSG) WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,101)X CALL DPWRST('XXX','BUG ') I1ML1 = ZERO RETURN ENDIF 999 FORMAT(1X) 101 FORMAT('***** ERROR FROM I1ML1--ARGUMENT MUST BE ', 1 'NON-NEGATIVE, ARGUMENT = ',G15.7) C C Compute the machine-dependent constants. C XSQ = D1MACH(3) T = XSQ / ONEHUN IF ( X .LE. SIXTEN ) THEN DO 10 NTERM1 = 23 , 0 , -1 IF ( ABS(AI1L1(NTERM1)) .GT. T ) GOTO 19 10 CONTINUE 19 XLOW = XSQ + XSQ ELSE DO 40 NTERM2 = 25 , 0 , -1 IF ( ABS(AI1L1A(NTERM2)) .GT. T ) GOTO 49 40 CONTINUE 49 XHIGH = SQRT ( ATEHUN / XSQ ) ENDIF C C Code for x <= 16 C IF ( X .LE. SIXTEN ) THEN IF ( X .LT. XLOW ) THEN I1ML1 = X / TWO RETURN ELSE T = ( SIX * X - FORTY ) / ( X + FORTY ) I1ML1 = CHEVAL(NTERM1,AI1L1,T) * X / TWO RETURN ENDIF ELSE C C Code for x > 16 C IF ( X .GT. XHIGH ) THEN I1ML1 = TWOBPI ELSE XSQ = X * X T = ( ATEHUN - XSQ ) / ( TWO88 + XSQ ) I1ML1 = CHEVAL(NTERM2,AI1L1A,T) * TWOBPI ENDIF ENDIF RETURN END SUBROUTINE IBCDF(X,ALPHA,BETA,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE INVERTED BETA DISTRIBUTION C WITH SHAPE PARAMETERS ALPHA AND BETA. C THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS C THE PROBABILITY DENSITY FUNCTION C IBPDF(X,A,B) = X**(ALPHA-1)/ C [BETA(ALPHA,BETA)*(1+X)**(ALPHA+BETA), C X, ALPHA, BETA > 0 C THE CUMULATIVE DISTRIBUTION IS COMPUTED BY C ALPHAMERICALLY INTEGRATING THE PDF FUNCTION. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C --ALPHA = THE DEGREES OF FREEDOM PARAMETER C --BETA = THE SKEWNESS PARAMETER C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION C FUNCTION VALUE CDF FOR THE INVERTED BETA DISTRIBUTION C WITH SHAPE PARAMETERS ALPHA AND BETA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--DQAGI. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS C UNIVARIATE DISTRIBUTIONS--VOLUME II", SECOND EDITION, C JOHN WILEY, 1994. C --EVANS, HASTINGS, AND PEACOCK, "STATISTICAL C DISTRIBUTIONS", THIRD EDITION, JOHN WILEY, 2000. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION ALPHAMBER--2003.12 C ORIGINAL VERSION--DECEMBER 2003. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C INTEGER LIMIT INTEGER LENW PARAMETER(LIMIT=200) PARAMETER(LENW=4*LIMIT) INTEGER INF INTEGER NEVAL INTEGER IER INTEGER LAST INTEGER IWORK(LIMIT) REAL ALPHA REAL BETA REAL X REAL CDF DOUBLE PRECISION EPSABS DOUBLE PRECISION EPSREL DOUBLE PRECISION RESULT DOUBLE PRECISION DCDF DOUBLE PRECISION DX DOUBLE PRECISION DA DOUBLE PRECISION ABSERR DOUBLE PRECISION WORK(LENW) C DOUBLE PRECISION IBFUN EXTERNAL IBFUN C DOUBLE PRECISION DALPHA DOUBLE PRECISION DBETA COMMON/IBCOM/DALPHA,DBETA C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,ALPHAMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C C-----START POINT----------------------------------------------------- C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C CDF=0.0 IF(ALPHA.LE.0.0)THEN WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,102) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,104)ALPHA CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF IF(BETA.LE.0.0)THEN WRITE(ICOUT,103) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,102) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,104)BETA CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF IF(X.LE.0.0)THEN WRITE(ICOUT,106) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,104)X CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 101 FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER, ALPHA, TO THE') 102 FORMAT(' IBCDF ROUTINE IS NON-POSITIVE.') 103 FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER, BETA, TO THE') 104 FORMAT(' THE VALUE OF THE ARGUMENT IS ',E15.7,' ******') 106 FORMAT('***** ERROR--THE FIRST ARGUMENT TO THE IBCDF ROUTINE ', 1 'IS NON-POSITIVE.') C C C ************************************ C ** STEP 1-- ** C ** COMPUTE THE DENSITY FUNCTION ** C ************************************ C INF=+1 EPSABS=1.0D-7 EPSREL=1.0D-7 IER=0 IKEY=3 CDF=0.0D0 C DA=1.0D-7 DX=DBLE(X) DALPHA=DBLE(ALPHA) DBETA=DBLE(BETA) C CCCCC REPLACE WITH A CODE FOR DEFINITE INTEGRAL. CCCCC CALL DQAGI(IBFUN,DX,INF,EPSABS,EPSREL,DCDF,ABSERR,NEVAL, CCCCC1 IER,LIMIT,LENW,LAST,IWORK,WORK) C CCCCC DCDF=1.0D0 - DCDF C CALL DQAG(IBFUN,DA,DX,EPSABS,EPSREL,IKEY,DCDF,ABSERR,NEVAL, 1 IER,LIMIT,LENW,LAST,IWORK,WORK) CDF=REAL(DCDF) C IF(IER.EQ.1)THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR FROM IBCDF--') 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 IBCDF--') 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 IBCDF--') 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 IBCDF--') 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 IBCDF--') 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 IBCDF--') 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 IBFUN(DX) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE INVERTED BETA DISTRIBUTION C WITH SHAPE PARAMETERS ALPHA AND BETA. C THIS DISTRIBUTION IS DEFINED FOR X > 0 AND HAS C THE PROBABILITY DENSITY FUNCTION C IBPDF(X,A,B) = X**(ALPHA-1)/ C [BETA(ALPHA,BETA)*(1+X)**(ALPHA+BETA), C X, ALPHA, BETA > 0 C IDENTICAL TO IBPDF, C BUT DEFINE AS FUNCTION TO BE USED FOR INTEGRATION C CODE CALLED BY IBCDF. C INPUT ARGUMENTS--DX = THE DOUBLE PRECISION VALUE AT C WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C OUTPUT ARGUMENTS--IBFUN = THE DOUBLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY C FUNCTION VALUE PDF FOR THE SKEW-T DISTRIBUTION C WITH SHAPE PARAMETERS ALPHA AND BETA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--DLBETA. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS C UNIVARIATE DISTRIBUTIONS--VOLUME II", SECOND EDITION, C JOHN WILEY, 1994. C --EVANS, HASTINGS, AND PEACOCK, "STATISTICAL C DISTRIBUTIONS", THIRD EDITION, JOHN WILEY, 2000. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2003.12 C ORIGINAL VERSION--DECEMBER 2003. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C EXTERNAL DLBETA C DOUBLE PRECISION DLBETA DOUBLE PRECISION DX DOUBLE PRECISION DPDF DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 C DOUBLE PRECISION DALPHA DOUBLE PRECISION DBETA COMMON/IBCOM/DALPHA,DBETA 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 DTERM1=(DALPHA-1.0D0)*DLOG(DX) DTERM2=DLBETA(DALPHA,DBETA) DTERM3=(DALPHA+DBETA)*DLOG(1.0D0+DX) C DPDF=DTERM1 - DTERM2 - DTERM3 IF(DPDF.LT.LOG(CPUMAX))THEN DPDF=DEXP(DPDF) ELSE WRITE(ICOUT,501) CALL DPWRST('XXX','BUG ') DPDF=LOG(CPUMAX) ENDIF 501 FORMAT('***** WARNING FROM INVERTED BETA PDF--OVERFLOW ', 1 'DETECTED.') C 9000 CONTINUE IBFUN=DPDF RETURN END REAL FUNCTION IBFU2(X) C C PURPOSE--IBPPF CALLS FZERO TO FIND A ROOT FOR THE PERCENT C POINT FUNCTION. IBFU2 IS THE FUNCTION FOR WHICH C THE ZERO IS FOUND. IT IS: C P - IBCDF(X,LAMBDA) C WHERE P IS THE DESIRED PERCENT POINT. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY C FUNCTION VALUE IBFU2. C PRINTING--NONE. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--IBCDF. 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 I", SECOND EDITION, C JOHN WILEY, 1994, PAGE 454. C --AZZALINI HAS AUTHORED A NUMBER OF PAPERS ON THIS C DISTRIBUTION. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATION INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2003.12 C ORIGINAL VERSION--DECEMBER 2003. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C REAL P COMMON/IB2COM/P C DOUBLE PRECISION DALPHA DOUBLE PRECISION DBETA COMMON/IBCOM/DALPHA,DBETA 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 IBCDF(X,REAL(DALPHA),REAL(DBETA),CDF) IBFU2=P - CDF C 9999 CONTINUE RETURN END SUBROUTINE IBPDF(X,ALPHA,BETA,PDF) C C NOTE--INVERTED BETA PDF IS: C IBPDF(X,A,B) = X**(ALPHA-1)/ C [BETA(ALPHA,BETA)*(1+X)**(ALPHA+BETA), C X > 0 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 REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS C UNIVARIATE DISTRIBUTIONS--VOLUME II", SECOND EDITION, C JOHN WILEY, 1994. C --EVANS, HASTINGS, AND PEACOCK, "STATISTICAL C DISTRIBUTIONS", THIRD EDITION, JOHN WILEY, 2000. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2003/5 C ORIGINAL VERSION--MAY 2003. C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C EXTERNAL DLBETA C DOUBLE PRECISION DLBETA DOUBLE PRECISION DX DOUBLE PRECISION DALPHA DOUBLE PRECISION DBETA DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DPDF 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(ALPHA.LE.0.0)THEN WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,102) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,104)ALPHA CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF IF(BETA.LE.0.0)THEN WRITE(ICOUT,103) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,102) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,104)BETA CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF IF(X.LE.0.0)THEN WRITE(ICOUT,106) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,104)X CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 101 FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER, ALPHA, TO THE') 102 FORMAT(' IBPDF ROUTINE IS NON-POSITIVE.') 103 FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER, BETA, TO THE') 104 FORMAT(' THE VALUE OF THE ARGUMENT IS ',E15.7,' ******') 106 FORMAT('***** ERROR--THE FIRST ARGUMENT TO THE IBPDF ROUTINE ', 1 'IS NON-POSITIVE.') C DX=DBLE(X) DALPHA=DBLE(ALPHA) DBETA=DBLE(BETA) C DTERM1=(DALPHA-1.0D0)*LOG(DX) DTERM2=DLBETA(DALPHA,DBETA) DTERM3=(DALPHA+DBETA)*LOG(1.0D0+DX) C DPDF=DTERM1 - DTERM2 - DTERM3 IF(DPDF.LT.LOG(CPUMAX))THEN DPDF=DEXP(DPDF) ELSE WRITE(ICOUT,501) CALL DPWRST('XXX','BUG ') DPDF=LOG(CPUMAX) ENDIF 501 FORMAT('***** WARNING FROM INVERTED BETA PDF--OVERFLOW ', 1 'DETECTED.') PDF=REAL(DPDF) C 9000 CONTINUE RETURN END SUBROUTINE IBPPF(P,ALPHA,BETA,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE INVERTED BETA DISTRIBUTION C WITH SHAPE PARAMETERS ALPHA AND BETA. C THIS DISTRIBUTION IS DEFINED FOR POSITIVE X AND THE C PERCENT POINT FUNCTION IS COMPUTED BY C NUMERICALLY INVERTING THE CDF FUNCTION. C INPUT ARGUMENTS--P = THE SINGLE PRECISION VALUE AT C WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. C --ALPHA = THE FIRST SHAPE PARAMETER C --BETA = THE SECOND SHAPE PARAMETER C OUTPUT ARGUMENTS--PPF = THE SINGLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PERCENT POINT C FUNCTION VALUE PPF. C PRINTING--NONE. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--FZERO. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS C UNIVARIATE DISTRIBUTIONS--VOLUME II", SECOND EDITION, C JOHN WILEY, 1994. C --EVANS, HASTINGS, AND PEACOCK, "STATISTICAL C DISTRIBUTIONS", THIRD EDITION, JOHN WILEY, 2000. 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 ALPHAMBER--2003.12 C ORIGINAL VERSION--DECEMBER 2003. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C REAL PPF C REAL IBFU2 EXTERNAL IBFU2 C REAL P2 COMMON/IB2COM/P2 C DOUBLE PRECISION DALPHA DOUBLE PRECISION DBETA COMMON/IBCOM/DALPHA,DBETA C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,ALPHAMBPC,ALPHAMCPW,ALPHAMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C PPF=0.0 IF(ALPHA.LE.0.0)THEN WRITE(ICOUT,101) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,102) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,104)ALPHA CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF IF(BETA.LE.0.0)THEN WRITE(ICOUT,103) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,102) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,104)BETA CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 101 FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER, ALPHA, TO THE') 102 FORMAT(' IBPPF ROUTINE IS NON-POSITIVE.') 103 FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER, BETA, TO THE') 104 FORMAT(' THE VALUE OF THE ARGUMENT IS ',E15.7,' ******') 106 FORMAT('***** ERROR--THE FIRST ARGUMENT TO THE IBPPF ROUTINE ', 1 'IS NON-POSITIVE.') C C IF(P.LT.0.0.OR.P.GE.1.0)THEN WRITE(ICOUT,61) 61 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT ', 1 'TO THE IBPPF SUBROUTINE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,62) 62 FORMAT(' IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL ***') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,63)P 63 FORMAT(' VALUE OF ARGUMENT = ',G15.7) CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9000 ENDIF C IF(P.EQ.0.0)THEN PPF=0.0 GOTO9000 ENDIF C C STEP 1: FIND BRACKETING INTERVAL. LOWER BOUND IS ZERO. START WITH C 10 AS GUESS FOR UPPER BOUND. MULTIPLY BY 10 UNTIL C BRACKETING INTERVAL FOUND. C XLOW=0.0000001 XUP2=10.0 200 CONTINUE CALL IBCDF(XUP2,ALPHA,BETA,PTEMP) IF(PTEMP.GT.P)THEN XUP=XUP2 ELSE XUP2=XUP2*10.0 IF(XUP2.GT.CPUMAX/100.)THEN WRITE(ICOUT,201) 201 FORMAT('***** ERROR FROM IBPPF--UNABLE TO FIND A ', 1 'BRACKETING INTERVAL') CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF GOTO200 ENDIF C 300 CONTINUE AE=1.E-6 RE=1.E-6 P2=P DALPHA=DBLE(ALPHA) DBETA=DBLE(BETA) CALL FZERO(IBFU2,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 IBPPF--') 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 IBPPF--') 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 IBPPF--') 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 IBPPF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,143) 143 FORMAT(' MAXIMUM ITERATIONS EXCEEDED.') CALL DPWRST('XXX','BUG ') ENDIF C 9000 CONTINUE RETURN END SUBROUTINE IBRAN(N,ALPHA,BETA,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE INVERTED BETA DISTRIBUTION C WITH SINGLE PRECISION SHAPE PARAMETERS = ALPHA AND BETA. C THE PROTOTYPE INVERTED BETA DISTRIBUTION USED C HEREIN CAN BE EXPRESSED AS THE RATIO OF TWO INDEPENDENT C GAMMA DISTRIBUTIONS WITH SHAPE PARAMETERS ALPHA AND C BETA, RESPECTIVELY. 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 GREATER THAN 0.0. C --BETA = THE SINGLE PRECISION VALUE OF THE C SECOND SHAPE PARAMETER. C BETA SHOULD BE GREATER THAN 0.0. 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 INVERTED BETA 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 GREATER THAN C OR EQUAL TO 0.0. C --BETA SHOULD BE GREATER THAN C OR EQUAL TO 0.0. C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN, GAMRAN. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--EVANS, HASTINGS AND PEACOCK, "STATISTICAL C DISTRIBUTIONS--THIRD EDITION", WILEY, 2000. C PAGES 41-42. 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 (1966) C EXCEPTION--HOLLARITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--2003.5 C ORIGINAL VERSION--MAY 2003. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)THEN WRITE(ICOUT, 5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF IF(ALPHA.LE.0.0)THEN WRITE(ICOUT,16) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALPHA CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF IF(BETA.LT.0.0)THEN WRITE(ICOUT,26) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)BETA CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 5 FORMAT('***** FATAL ERROR--THE NUMBER OF REQUESTED INVERTED ', 1'BETA RANDOM NUMBERS IS NON-POSITIVE.') 16 FORMAT('***** FATAL ERROR--THE FIRST SHAPE PARAMETER FOR THE ', 1'INVERTED BETA IS LESS THAN 0.0 *****') 26 FORMAT('***** FATAL ERROR--THE SECOND SHAPE PARAMETER FOR THE ', 1'INVERTED BETA IS LESS THAN 0.0 *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') C C GENERATE N BETA RANDOM NUMBERS BY USING THE FACT THAT THE C INVERTED BETA IS A RATIO OF TWO INDEPENDENT GAMMA VARIATES. C NTEMP=1 DO100I=1,N C CALL GAMRAN(NTEMP,ALPHA,ISEED,XG1) CALL GAMRAN(NTEMP,BETA,ISEED,XG2) X(I)=0.0 IF(XG2.GT.0.0)X(I)=XG1/XG2 C 100 CONTINUE C 9000 CONTINUE RETURN END INTEGER FUNCTION IDAMAX(N,DX,INCX) C***BEGIN PROLOGUE IDAMAX C***DATE WRITTEN 791001 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D1A2 C***KEYWORDS BLAS,DOUBLE PRECISION,LINEAR ALGEBRA,MAXIMUM COMPONENT, C VECTOR C***AUTHOR LAWSON, C. L., (JPL) C HANSON, R. J., (SNLA) C KINCAID, D. R., (U. OF TEXAS) C KROGH, F. T., (JPL) C***PURPOSE Find largest component of d.p. vector C***DESCRIPTION C C B L A S Subprogram C Description of Parameters C C --Input-- C N number of elements in input vector(s) C DX double precision vector with N elements C INCX storage spacing between elements of DX C C --Output-- C IDAMAX smallest index (zero if N .LE. 0) C C Find smallest index of maximum magnitude of double precision DX. C IDAMAX = first I, I = 1 to N, to minimize ABS(DX(1-INCX+I*INCX) C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 C***ROUTINES CALLED (NONE) C***END PROLOGUE IDAMAX C DOUBLE PRECISION DX(1),DMAX,XMAG C***FIRST EXECUTABLE STATEMENT IDAMAX IDAMAX = 0 IF(N.LE.0) RETURN IDAMAX = 1 IF(N.LE.1)RETURN IF(INCX.EQ.1)GOTO 20 C C CODE FOR INCREMENTS NOT EQUAL TO 1. C DMAX = DABS(DX(1)) NS = N*INCX II = 1 DO 10 I = 1,NS,INCX XMAG = DABS(DX(I)) IF(XMAG.LE.DMAX) GO TO 5 IDAMAX = II DMAX = XMAG 5 II = II + 1 10 CONTINUE RETURN C C CODE FOR INCREMENTS EQUAL TO 1. C 20 DMAX = DABS(DX(1)) DO 30 I = 2,N XMAG = DABS(DX(I)) IF(XMAG.LE.DMAX) GO TO 30 IDAMAX = I DMAX = XMAG 30 CONTINUE RETURN END SUBROUTINE IGACDF(X,ALPHA,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE INVERTED GAMMA DISTRIBUTION C WITH POSITIVE SHAPE PARAMETER ALPHA. C THIS DISTRIBUTION IS DEFINED FOR ALL POSITIVE X. C THE PROBABILITY DENSITY FUNCTION IS GIVEN C IN THE REFERENCES BELOW. C THE CDF FOR THE STANDARD FORM OF THE DISTRIBUTION IS C F(X,ALPHA) = GAMMAIP(1/X,ALPHA) C WHERE GAMMAIP = GAMMAI(ALPHA,X)/GAMMA(ALPHA). C THE CDF IS CAN BE COMPUTED WITH THE SLATEC ROUTINE C DGAMIC. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C X SHOULD BE NON-NEGATIVE. C --ALPHA = A POSITIVE SHAPE PARAMETER C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION C FUNCTION VALUE CDF FOR THE INVERTED GAMMA DISTRIBUTION C WITH SHAPE PARAMETER ALPHA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE NON-NEGATIVE. C --ALPHA SHOULD BE A POSITIVE NUMBER. C OTHER DATAPAC SUBROUTINES NEEDED--GAMMIP. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--EVANS, HASTINGS, AND PEACOCK, "STATISTICAL C DISTRIBUTIONS", THIRD EDITION, WILEY, 2000, C GAMMA CHAPTER. 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/6 C ORIGINAL VERSION--JUNE 2004. PREVIOUSLY IMPLEMENTED C AS SPECIAL CASE OF GGDCDF C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DALPHA DOUBLE PRECISION DTERM1 DOUBLE PRECISION DCDF DOUBLE PRECISION DGAMIP C C--------------------------------------------------------------------- C INCLUDE 'DPCOMC.INC' C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(X.LE.0.0)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF IF(ALPHA.LE.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALPHA CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF 4 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT ', 1'TO THE IGACDF SUBROUTINE IS NON-POSITIVE *****') 15 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1'IGACDF SUBROUTINE IS NON-POSITIVE *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C C IF(X.LE.R1MACH(1))THEN CDF=0.0 RETURN ENDIF C DX=DBLE(X) DALPHA=DBLE(ALPHA) C DCDF=1.0D0 - DGAMIP(DALPHA,1.0D0/DX) CDF=REAL(DCDF) C 9999 CONTINUE RETURN END SUBROUTINE IGAPDF(X,ALPHA,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE INVERTED GAMMA DISTRIBUTION C WITH POSITIVE SHAPE PARAMETER ALPHA. C THIS DISTRIBUTION IS DEFINED FOR ALL POSITIVE X. C THE PDF FOR THE STANDARD FORM OF THE DISTRIBUTION IS C F(X,ALPHA) = X**(-(ALPHA+1))*EXP(-1/X)/GAMMA(ALPHA) C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C X SHOULD BE NON-NEGATIVE. C --ALPHA = A POSITIVE SHAPE PARAMETER C OUTPUT ARGUMENTS--PDF = THE SINGLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY C FUNCTION VALUE PDF FOR THE INVERTED GAMMA DISTRIBUTION C WITH SHAPE PARAMETER ALPHA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE NON-NEGATIVE. C --ALPHA AND X SHOULD BE POSITIVE NUMBERS. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--EVANS, HASTINGS, AND PEACOCK, "STATISTICAL C DISTRIBUTIONS", THIRD EDITION, WILEY, 2000, C GAMMA CHAPTER. 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/6 C ORIGINAL VERSION--JUNE 2004. PREVIOUSLY COMPUTED USING C GENERALIZED GAMMA WITH C=-1 C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DALPHA DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DTERM4 DOUBLE PRECISION DPDF DOUBLE PRECISION DLNGAM C C--------------------------------------------------------------------- C INCLUDE 'DPCOMC.INC' C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(X.LE.0.0)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF IF(ALPHA.LE.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALPHA CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF 4 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT ', 1'TO THE IGAPDF SUBROUTINE IS NON-POSITIVE *****') 15 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1'IGAPDF SUBROUTINE IS NON-POSITIVE *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C IF(X.LE.R1MACH(1))THEN PDF=0.0 RETURN ENDIF C DX=DBLE(X) DALPHA=DBLE(ALPHA) C DTERM1=-(DALPHA+1.0D0)*DLOG(DX) DTERM2=-1.0D0/DX DTERM3=DLNGAM(DALPHA) DTERM4=DTERM1+DTERM2-DTERM3 DPDF=0.0D0 IF(DTERM4.GE.-80.0D0)DPDF=DEXP(DTERM4) PDF=REAL(DPDF) C 9999 CONTINUE RETURN END SUBROUTINE IGAPPF(P,ALPHA,PPF) C C PURPOSE --PERCENT POINT FUNCTION FOR THE INVERTED GAMMA C DISTRIBUTION. USES A BISECTION METHOD. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004/6 C ORIGINAL VERSION--JUNE 2004. PREVIOUSLY IMPLEMENTED AS C SPECIAL CASE OF GGDPPF C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DP DOUBLE PRECISION DALPHA DOUBLE PRECISION EPS DOUBLE PRECISION SIG DOUBLE PRECISION ZERO DOUBLE PRECISION DMEAN DOUBLE PRECISION DSD DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION XL DOUBLE PRECISION XR DOUBLE PRECISION XINC DOUBLE PRECISION X DOUBLE PRECISION FXL DOUBLE PRECISION FXR DOUBLE PRECISION P1 DOUBLE PRECISION FCS DOUBLE PRECISION XRML DOUBLE PRECISION DCDF DOUBLE PRECISION CDFL DOUBLE PRECISION CDFR DOUBLE PRECISION DLNGAM DOUBLE PRECISION DGAMIP C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DATA EPS /0.0001D0/ DATA SIG /1.0D-5/ DATA ZERO /0.0D0/ DATA MAXIT /5000/ C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(P.LT.0.0.OR.P.GE.1.0)THEN WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF C IF(ALPHA.LE.0.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALPHA CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF IF(ALPHA.LT.0.1)THEN WRITE(ICOUT,25) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALPHA CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF 1 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE ', 1' IGAPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1] INTERVAL.') 15 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1'IGAPDF SUBROUTINE IS NON-POSITIVE *****') 25 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1'IGAPDF SUBROUTINE IS < 0.1') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C IF(P.EQ.0.)THEN PPF=0. GOTO9999 ENDIF C C FIND BRACKETING INTERVAL. C DP=DBLE(P) DALPHA=DBLE(ALPHA) C XL=0.0D0 IF(ALPHA.GT.1.0)THEN DMEAN=1.0D0/(DALPHA-1.0D0) ELSE IF(ALPHA.GE.0.9)THEN DMEAN=10.0 ELSEIF(ALPHA.GE.0.5)THEN DMEAN=50.0 ELSEIF(ALPHA.GE.0.1)THEN DMEAN=100.0 IF(P.GT.0.75)DMEAN=10000 ELSE DMEAN=500.0 IF(P.GT.0.75)DMEAN=100000 ENDIF ENDIF IF(ALPHA.GT.2.0)THEN DSD=DSQRT(1.0D0/((DALPHA-1.0D0)**2*(DALPHA-2.0))) ELSEIF(ALPHA.GE.0.9)THEN DSD=3.0 ELSEIF(ALPHA.GE.0.5)THEN DSD=10.0 ELSEIF(ALPHA.GE.0.1)THEN IF(P.LE.0.75)THEN DSD=1000.0 ELSE DSD=10000.0 ENDIF ELSE IF(P.LE.0.75)THEN DSD=1000.0 ELSE DSD=5000.0 ENDIF ENDIF C XR=DMEAN XINC=DSD ICOUNT=0 MAXCNT=10000 C 91 CONTINUE IF(XL.LE.0.0D0)THEN CDFL=0.0D0 ELSE CDFL=1.0D0 - DGAMIP(DALPHA,1.0D0/XL) ENDIF IF(XR.LE.0.0D0)XR=XL+DMEAN CDFR=1.0D0 - DGAMIP(DALPHA,1.0D0/XR) IF(CDFL.LT.DP .AND. CDFR.LT.DP)THEN XL=XR XR=XL+XINC ELSEIF(CDFL.GT.DP .AND. CDFR.GT.DP)THEN XL=XL-XINC IF(XL.LT.0.0D0)XL=0.0D0 ELSE GOTO99 ENDIF ICOUNT=ICOUNT+1 IF(ICOUNT.GT.MAXCNT)THEN WRITE(ICOUT,96) CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF 96 FORMAT('***** FATAL ERROR--IGAPPF UNABLE TO FIND BRACKETING ', * 'INTERVAL. *****') GOTO91 C C BISECTION METHOD C 99 CONTINUE IC = 0 FXL = -DP FXR = 1.0D0 - DP 105 CONTINUE X = (XL+XR)*0.5D0 DCDF=1.0D0 - DGAMIP(DALPHA,1.0D0/X) P1=DCDF PPF=REAL(X) FCS = P1 - DP IF(FCS*FXL.GT.ZERO)GOTO110 XR = X FXR = FCS GOTO115 110 CONTINUE XL = X FXL = FCS 115 CONTINUE XRML = XR - XL IF(XRML.LE.SIG .AND. ABS(FCS).LE.EPS)GOTO9999 IC = IC + 1 IF(IC.LE.MAXIT)GOTO105 WRITE(ICOUT,130) CALL DPWRST('XXX','BUG ') 130 FORMAT('***** FATAL ERROR--IGAPPF ROUTINE DID NOT CONVERGE. ***') GOTO9999 C 9999 CONTINUE RETURN END SUBROUTINE IGARAN(N,GAMMA,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE INVERTED GAMMA DISTRIBUTION C WITH TAIL LENGTH PARAMETER VALUE = GAMMA. C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --GAMMA = THE SINGLE PRECISION VALUE OF THE C TAIL LENGTH PARAMETER. C GAMMA SHOULD BE POSITIVE. C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR C (OF DIMENSION AT LEAST N) C INTO WHICH THE GENERATED C RANDOM SAMPLE WILL BE PLACED. C OUTPUT--A RANDOM SAMPLE OF SIZE N C FROM THE INVERTED GAMMA DISTRIBUTION C WITH TAIL LENGTH PARAMETER VALUE = GAMMA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C --GAMMA SHOULD BE POSITIVE. C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN. C FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--XX C --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--1, 2ND. ED., 1994. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--2001.10 C ORIGINAL VERSION--OCTOBER 2001. C UPDATED VERSION--JANUARY 2005. BUG IF ROUTINE CALLED MORE C THAN ONCE, RESET AA AND AAA C AND STORE IN COMMON C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*) C COMMON/SGAMM/AA,AAA C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)THEN WRITE(ICOUT, 5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF IF(GAMMA.LE.0.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)GAMMA CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ', 1'IGARAN SUBROUTINE IS NON-POSITIVE *****') 15 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ', 1'IGARAN 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 CCCCC CALL UNIRAN(N,ISEED,X) AA=0.0 AAA=0.0 C C GENERATE N INVERTED GAMMA DISTRIBUTION RANDOM NUMBERS C USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD. C C NOTE 6/2004: USE RELATIONSHIP TO GAMMA DISTRIBUTION. C CCCCC C=-1.0 DO100I=1,N ATEMP=SGAMMA(ISEED,GAMMA) X(I)=1.0/ATEMP CCCCC CALL GGDPPF(X(I),GAMMA,C,XTEMP) CCCCC X(I)=XTEMP 100 CONTINUE C 9000 CONTINUE RETURN END SUBROUTINE IGCDF(X,GAMMA,AMU,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE INVERSE GAUSSIAN DISTRIBUTION C WITH TAIL LENGTH PARAMETER = GAMMA C AND SHAPE PARAMETER = MU. C THE INVERSE GAUSSIAN DISTRIBUTION USED C HEREIN IS DEFINED FOR ALL NON-NEGATIVE X, C AND HAS THE PROBABILITY DENSITY FUNCTION C AS GIVEN IN VOLUME 4, PAGE 246, BOTTOM C OF ENCYCLOPEDIA OF STATISTICAL SCIENCES C AND GENERAL CUMULATIVE DISTRIBUTION FUNCTION C AS GIVEN IN VOLUME 4, PAGE 247, COLUMN 1 C OF ENCYCLOPEDIA OF STATISTICAL SCIENCES C NOTE--THE GENERAL INVERSE GAUSSIAN DISTRIBUTION-- C GOES FROM 0 TO INFINITY C HAS MEAN = MU C HAS STANDARD DEVIATION = SQRT((MU**3)/GAMMA) C HAS SHAPE PARAMETER = GAMMA C IS HIGHLY-SKEWED AND LONG-TAILED FOR SMALL GAMMA C IS SYMMETRIC AND MODERATE-TAILED FOR KARGE GAMMA C APPROACHES NORMALITY AS GAMMA APPROACHES INFINITY 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 --GAMMA = THE SHAPE PARAMETER C GAMMA SHOULD BE POSITIVE. C --AMU = THE SHAPE PARAMETER C AMU 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 INVERSE GAUSSIAN DISTRIBUTION C WITH TAIL LENGTH PARAMETER = GAMMA C AND WITH SHAPE PARAMETER = MU C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE NON-NEGATIVE. C --GAMMA AND AMU SHOULD BE POSITIVE. C OTHER DATAPAC SUBROUTINES NEEDED--NORCDF. C FORTRAN LIBRARY SUBROUTINES NEEDED--EXP. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--KOTZ & JOHNSON, ENCYCLOPEDIA OF STAT SCIENCES C VOLUME 4, PAGE 247, COLUMN 1. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C 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--90.6 C ORIGINAL VERSION--MAY 1990. C UPDATED --JANUARY 1995. NEW CDF DEFINITION & REWRITTEN C UPDATED --DECEMBER 1998. USE DOUBLE PRECISION C UPDATED --OCTOBER 2001. BUG FIX. MISSING SOME C DOUBLE PRECISION DECLARATIONS C UPDATED --DECEMBER 2003. GENERAL CASE FOR MU (I.E., C DON'T ASSUME MU=1) C C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DCDF DOUBLE PRECISION DGAMMA DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 CCCCC OCTOBER 2001. ADD FOLLOWING 3 LINES DOUBLE PRECISION DTERM4 DOUBLE PRECISION DTERM5 DOUBLE PRECISION DTERM6 DOUBLE PRECISION DTRM12 DOUBLE PRECISION DTRM14 DOUBLE PRECISION DMU DOUBLE PRECISION DPI C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(GAMMA.LE.0)THEN WRITE(ICOUT,51) 51 FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER ', 1 'TO THE IGCDF SUBROUTINE IS NON-POSITIVE *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)GAMMA 52 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9000 ENDIF C IF(AMU.LE.0)THEN WRITE(ICOUT,71) 71 FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER ', 1 'TO THE IGCDF SUBROUTINE IS NON-POSITIVE *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)GAMMA CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9000 ENDIF C DX=DBLE(X) DGAMMA=DBLE(GAMMA) C IF(DX.LE.0.0D0)THEN CDF=0.0 ELSEIF(DX.GT.0.0)THEN DMU=DBLE(AMU) DPI=3.1415926535 8979323846 2643383279 503 D0 DTERM1=DSQRT(DGAMMA/DX) DTERM2=(-1.0D0+DX/DMU) DTERM3=2.0D0*DGAMMA/DMU DTERM4=(1.0D0+DX/DMU) DTRM12=DTERM1*DTERM2 DTRM14=(-DTERM1*DTERM4) CALL NODCDF(DTRM12,DTERM5) CALL NODCDF(DTRM14,DTERM6) DCDF=DTERM5+DEXP(DTERM3)*DTERM6 CDF=REAL(DCDF) GOTO9000 ENDIF C 9000 CONTINUE RETURN END SUBROUTINE IGCDF2(DX,DGAMMA,DMU,DCDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE INVERSE GAUSSIAN DISTRIBUTION C WITH TAIL LENGTH PARAMETER = GAMMA C AND LOCATION PARAMETER = 1. C THE INVERSE GAUSSIAN DISTRIBUTION USED C HEREIN IS DEFINED FOR ALL NON-NEGATIVE X, C AND HAS THE PROBABILITY DENSITY FUNCTION C AS GIVEN IN VOLUME 4, PAGE 246, BOTTOM C OF ENCYCLOPEDIA OF STATISTICAL SCIENCES C WITH MU = 1 C AND GENERAL CUMULATIVE DISTRIBUTION FUNCTION C AS GIVEN IN VOLUME 4, PAGE 247, COLUMN 1 C OF ENCYCLOPEDIA OF STATISTICAL SCIENCES C WITH MU = 1 C NOTE--THE GENERAL INVERSE GAUSSIAN DISTRIBUTION-- C GOES FROM 0 TO INFINITY C HAS MEAN = MU (HERE = 1) C HAS STANDARD DEVIATION = SQRT((MU**3)/GAMMA) C HAS SHAPE PARAMETER = GAMMA C IS HIGHLY-SKEWED AND LONG-TAILED FOR SMALL GAMMA C IS SYMMETRIC AND MODERATE-TAILED FOR KARGE GAMMA C APPROACHES NORMALITY AS GAMMA APPROACHES INFINITY C NOTE--TO OBTAIN THE CDF FOR GENERAL MU, C COMPUTE THE CDF FOR X AROUND 1, AND THEN C SIMPLY SCALE UP THE HORIZONTAL AXIS X BY THE DESIRED MU C AS IN Y2 = MU*Y 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 --GAMMA = THE SHAPE PARAMETER C GAMMA SHOULD BE POSITIVE. C --MU = THE SHAPE PARAMETER C MU 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 INVERSE GAUSSIAN DISTRIBUTION C WITH TAIL LENGTH PARAMETER = GAMMA C AND WITH SHAPE PARAMETER = MU C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE NON-NEGATIVE. C --GAMMA SHOULD BE POSITIVE. C OTHER DATAPAC SUBROUTINES NEEDED--NORCDF. C FORTRAN LIBRARY SUBROUTINES NEEDED--EXP. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--KOTZ & JOHNSON, ENCYCLOPEDIA OF STAT SCIENCES C VOLUME 4, PAGE 247, COLUMN 1. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C 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--90.6 C ORIGINAL VERSION--MAY 1990. C UPDATED --JANUARY 1995. NEW CDF DEFINITION & REWRITTEN C UPDATED --DECEMBER 1998. USE DOUBLE PRECISION C UPDATED --DECEMBER 2003. FULL SUPPORT FOR MU C C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DCDF DOUBLE PRECISION DGAMMA DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DTERM5 DOUBLE PRECISION DTERM6 DOUBLE PRECISION DTRM12 DOUBLE PRECISION DTRM14 DOUBLE PRECISION DMU DOUBLE PRECISION DPI C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT 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(DGAMMA.LE.0D0)THEN WRITE(ICOUT,51) 51 FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER ', 1 'TO THE IGCDF2 SUBROUTINE IS NON-POSITIVE *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)DGAMMA 52 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',D15.8,' *****') CALL DPWRST('XXX','BUG ') DCDF=0.0D0 GOTO9000 ENDIF C IF(DMU.LE.0D0)THEN WRITE(ICOUT,61) 61 FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER ', 1 'TO THE IGCDF2 SUBROUTINE IS NON-POSITIVE *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)DMU CALL DPWRST('XXX','BUG ') DCDF=0.0D0 GOTO9000 ENDIF C IF(DX.LE.0.0D0)THEN DCDF=0.0 ELSEIF(DX.GT.0.0)THEN DPI=3.1415926535 8979323846 2643383279 503 D0 DTERM1=DSQRT(DGAMMA/DX) DTERM2=(-1.0D0+DX/DMU) DTERM3=2.0D0*DGAMMA/DMU DTERM4=(1.0D0+DX/DMU) DTRM12=DTERM1*DTERM2 DTRM14=(-DTERM1*DTERM4) CALL NODCDF(DTRM12,DTERM5) CALL NODCDF(DTRM14,DTERM6) DCDF=DTERM5+DEXP(DTERM3)*DTERM6 GOTO9000 ENDIF C 9000 CONTINUE RETURN END SUBROUTINE IGCHA(X,GAMMA,AMU,HAZ) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE HAZARD C FUNCTION VALUE FOR THE INVERSE GAUSSIAN DISTRIBUTION C WITH TAIL LENGTH PARAMETER = GAMMA C AND SHAPE PARAMETER = MU. C THE INVERSE GAUSSIAN DISTRIBUTION USED C HEREIN IS DEFINED FOR ALL POSITIVE X, C AND HAS THE PROBABILITY DENSITY FUNCTION C AS GIVEN IN VOLUME 4, PAGE 246, BOTTOM C OF ENCYCLOPEDIA OF STATISTICAL SCIENCES C NOTE--THE GENERAL INVERSE GAUSSIAN DISTRIBUTION-- C GOES FROM 0 TO INFINITY C HAS MEAN = MU C HAS STANDARD DEVIATION = SQRT((MU**3)/GAMMA) C HAS SHAPE PARAMETER = GAMMA C IS HIGHLY-SKEWED AND LONG-TAILED FOR SMALL GAMMA C IS SYMMETRIC AND MODERATE-TAILED FOR KARGE GAMMA C APPROACHES NORMALITY AS GAMMA APPROACHES INFINITY C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE CUMULATIVE HAZARD C FUNCTION IS TO BE EVALUATED. C X SHOULD BE POSITIVE. C --GAMMA = THE SHAPE PARAMETER C GAMMA SHOULD BE POSITIVE. C --AMU = THE SHAPE PARAMETER C AMU SHOULD BE POSITIVE. C OUTPUT ARGUMENTS--HAZ = THE SINGLE PRECISION CUMULATIVE HAZARD C FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION CUMULATIVE HAZARD C FUNCTION VALUE FOR THE INVERSE GAUSSIAN DISTRIBUTION C WITH TAIL LENGTH PARAMETER = GAMMA C AND WITH SHAPE PARAMETER = MU C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE POSITIVE. C --GAMMA AND MU SHOULD BE POSITIVE. 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--KOTZ & JOHNSON, ENCYCLOPEDIA OF STAT SCIENCES C VOLUME 4, PAGE 246, BOTTOM. 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--98.4 C ORIGINAL VERSION--APRIL 1998. C UPDATED --DECEMBER 2003. 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(GAMMA.LE.0)THEN WRITE(ICOUT,51) 51 FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER FOR THE ', 1 'IGCHA SUBROUTINE IS NON-POSITIVE *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)GAMMA 52 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') CALL DPWRST('XXX','BUG ') HAZ=0.0 GOTO9000 ENDIF C IF(AMU.LE.0)THEN WRITE(ICOUT,71) 71 FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER FOR THE ', 1 'IGCHA SUBROUTINE IS NON-POSITIVE *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)AMU CALL DPWRST('XXX','BUG ') HAZ=0.0 GOTO9000 ENDIF C IF(X.LT.0.0)THEN WRITE(ICOUT,61) 61 FORMAT('***** ERROR--THE FIRST INPUT ', 1 'ARGUMENT TO THE IGCHA SUBROUTINE IS NON-POSITIVE *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)X CALL DPWRST('XXX','BUG ') HAZ=0.0 GOTO9000 ENDIF C IF(X.EQ.0.0)THEN HAZ=0.0 GOTO9000 ENDIF C IF(X.GT.0.0)THEN CALL IGCDF(X,GAMMA,AMU,CDF) CDF=1.0-CDF IF(CDF.GT.0.0)THEN HAZ=-LOG(CDF) ELSE WRITE(ICOUT,162)X 162 FORMAT('***** FOR THE VALUE OF THE ARGUMENT ',E15.8, 1 ' THE CDF IS ESSENTIALLY 1, CUMULATIVE HAZARD SET TO 0.') CALL DPWRST('XXX','BUG ') HAZ=0.0 ENDIF ENDIF C 9000 CONTINUE RETURN END CHARACTER*1 FUNCTION IGET(ICURS, ISTRNG, LNGTH) C PART OF ACM 591 FOR ANOVA C ****************************** IGET ****************************** IGE 10 C IGE 20 C USED BY THE MAIN PROGRAM AND SCAN TO SEQUENTIALLY RETRIEVE CHARAC- IGE 30 C TERS FROM THE INPUT BUFFER. IGE 40 C IGE 50 C ARGUMENTS - ICURS = POSITION IN CHARACTER STRING; ISTRNG = CHARAC- IGE 60 C TER STRING (INPUT BUFFER); LNGTH = LENGTH OF STRING. IGE 70 C IGE 80 C ****************************************************************** IGE 90 DIMENSION ISTRNG(LNGTH) CHARACTER*1 IBLANK, IPLUS, ICOMMA, ISTRNG DATA IBLANK /1H /, IPLUS /1H+/, ICOMMA /1H,/ 10 IGET = ISTRNG(ICURS) ICURS = ICURS + 1 IF (ICURS.GT.LNGTH) RETURN IF (IGET.EQ.IBLANK .OR. IGET.EQ.IPLUS) GO TO 10 IF (IGET.EQ.ICOMMA) GO TO 10 RETURN END SUBROUTINE IGHAZ(X,GAMMA,AMU,HAZ) C C PURPOSE--THIS SUBROUTINE COMPUTES THE HAZARD C FUNCTION VALUE FOR THE INVERSE GAUSSIAN DISTRIBUTION C WITH TAIL LENGTH PARAMETER = GAMMA C AND SHAPE PARAMETER = MU. C THE INVERSE GAUSSIAN DISTRIBUTION USED C HEREIN IS DEFINED FOR ALL POSITIVE X, C AND HAS THE PROBABILITY DENSITY FUNCTION C AS GIVEN IN VOLUME 4, PAGE 246, BOTTOM C OF ENCYCLOPEDIA OF STATISTICAL SCIENCES C NOTE--THE GENERAL INVERSE GAUSSIAN DISTRIBUTION-- C GOES FROM 0 TO INFINITY C HAS MEAN = MU (HERE = 1) C HAS STANDARD DEVIATION = SQRT((MU**3)/GAMMA) C HAS SHAPE PARAMETER = GAMMA C IS HIGHLY-SKEWED AND LONG-TAILED FOR SMALL GAMMA C IS SYMMETRIC AND MODERATE-TAILED FOR KARGE GAMMA C APPROACHES NORMALITY AS GAMMA APPROACHES INFINITY C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C X SHOULD BE POSITIVE. C --GAMMA = THE SHAPE PARAMETER C GAMMA SHOULD BE POSITIVE. C --MU = THE SHAPE PARAMETER C MU SHOULD BE POSITIVE. C OUTPUT ARGUMENTS--HAZ = THE SINGLE PRECISION HAZARD C FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION HAZARD C FUNCTION VALUE FOR THE INVERSE GAUSSIAN DISTRIBUTION C WITH TAIL LENGTH PARAMETER = GAMMA C AND WITH SHAPE PARAMETER = MU C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE POSITIVE. C --GAMMA AND MU SHOULD BE POSITIVE. 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--KOTZ & JOHNSON, ENCYCLOPEDIA OF STAT SCIENCES C VOLUME 4, PAGE 246, BOTTOM. 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--98.4 C ORIGINAL VERSION--APRIL 1998. C UPDATED VERSION--DECEMBER 2003. 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(GAMMA.LE.0)THEN WRITE(ICOUT,51) 51 FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER FOR THE ', 1 'IGHAZ SUBROUTINE IS NON-POSITIVE *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)GAMMA 52 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') CALL DPWRST('XXX','BUG ') HAZ=0.0 GOTO9000 ENDIF C IF(AMU.LE.0)THEN WRITE(ICOUT,71) 71 FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER FOR THE ', 1 'IGHAZ SUBROUTINE IS NON-POSITIVE *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)AMU CALL DPWRST('XXX','BUG ') HAZ=0.0 GOTO9000 ENDIF C IF(X.LT.0.0)THEN WRITE(ICOUT,61) 61 FORMAT('***** ERROR--THE FIRST INPUT ', 1 'ARGUMENT TO THE IGHAZ SUBROUTINE IS NON-POSITIVE *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)X CALL DPWRST('XXX','BUG ') HAZ=0.0 GOTO9000 ENDIF C IF(X.EQ.0.0)THEN HAZ=0.0 GOTO9000 ENDIF C IF(X.GT.0.0)THEN CALL IGPDF(X,GAMMA,AMU,PDF) CALL IGCDF(X,GAMMA,AMU,CDF) CDF=1.0-CDF IF(CDF.GT.0.0)THEN HAZ=PDF/CDF ELSE WRITE(ICOUT,162)X 162 FORMAT('***** FOR THE VALUE OF THE ARGUMENT, ', 1 E15.8,', THE CDF IS ESSENTIALLY 1, HAZARD SET TO 0.') CALL DPWRST('XXX','BUG ') HAZ=0.0 ENDIF ENDIF C 9000 CONTINUE RETURN END SUBROUTINE IGPDF(X,GAMMA,AMU,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE INVERSE GAUSSIAN DISTRIBUTION C WITH TAIL LENGTH PARAMETER = GAMMA C AND LOCATION PARAMETER = MU. C THE INVERSE GAUSSIAN DISTRIBUTION USED C HEREIN IS DEFINED FOR ALL POSITIVE X, C AND HAS THE PROBABILITY DENSITY FUNCTION C AS GIVEN IN VOLUME 4, PAGE 246 C OF ENCYCLOPEDIA OF STATISTICAL SCIENCES C NOTE--THE GENERAL INVERSE GAUSSIAN DISTRIBUTION-- C GOES FROM 0 TO INFINITY C HAS MEAN = MU C HAS STANDARD DEVIATION = SQRT((MU**3)/GAMMA) C HAS SHAPE PARAMETER = GAMMA C IS HIGHLY-SKEWED AND LONG-TAILED FOR SMALL GAMMA C IS SYMMETRIC AND MODERATE-TAILED FOR KARGE GAMMA C APPROACHES NORMALITY AS GAMMA APPROACHES INFINITY C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C X SHOULD BE POSITIVE. C --GAMMA = THE SHAPE PARAMETER C GAMMA SHOULD BE POSITIVE. C --MU = THE SHAPE PARAMETER MU. 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 INVERSE GAUSSIAN DISTRIBUTION C WITH TAIL LENGTH PARAMETER = GAMMA C AND WITH SHAPE PARAMETER = MU C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X, GAMMA, M SHOULD BE POSITIVE. 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--KOTZ & JOHNSON, ENCYCLOPEDIA OF STAT SCIENCES C VOLUME 4, PAGE 246, BOTTOM. 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--90.6 C ORIGINAL VERSION--MAY 1990. C UPDATED --JANUARY 1995. NEW PDF DEFINITION AND C REWRITTEN C UPDATED --DECEMBER 2003. USE GENERAL VALUE OF MU C INSTEAD OF ASSUMING MU=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 DOUBLE PRECISION DPI DOUBLE PRECISION DX DOUBLE PRECISION DGAMMA DOUBLE PRECISION DMU DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DPDF C DATA DPI / 3.1415926535 8979323846 2643383279 503 D0 / C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(GAMMA.LE.0)THEN WRITE(ICOUT,51) 51 FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER FOR THE ', 1 'IGPDF SUBROUTINE IS NON-POSITIVE *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)GAMMA 52 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9000 ENDIF C IF(AMU.LE.0)THEN WRITE(ICOUT,71) 71 FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER FOR THE ', 1 'IGPDF SUBROUTINE IS NON-POSITIVE *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)AMU CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9000 ENDIF C IF(X.LT.0.0)THEN WRITE(ICOUT,61) 61 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE ', 1 'IGPDF SUBROUTINE IS NON-POSITIVE *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)X CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9000 ENDIF C IF(X.EQ.0.0)THEN PDF=0.0 GOTO9000 ENDIF C IF(X.GT.0.0)THEN DMU=DBLE(AMU) DX=DBLE(X) DGAMMA=DBLE(GAMMA) DTERM1=0.5D0*DLOG(DGAMMA/(2.0D0*DPI*DX**3)) DTERM2=(-DGAMMA/(2.0D0*DMU*DMU*DX)) DTERM3=(DX-DMU)**2 DPDF=DTERM1 + DTERM2*DTERM3 DPDF=DEXP(DPDF) PDF=REAL(DPDF) ENDIF C 9000 CONTINUE RETURN END SUBROUTINE IGPPF(P,GAMMA,AMU,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE INVERSE GAUSSIAN DISTRIBUTION C WITH TAIL LENGTH PARAMETER = GAMMA C AND SHAPE PARAMETER = MU. C THE INVERSE GAUSSIAN DISTRIBUTION USED C HEREIN IS DEFINED FOR ALL POSITIVE X, C AND HAS THE PROBABILITY DENSITY FUNCTION C AS GIVEN IN VOLUME 4, PAGE 246, BOTTOM C OF ENCYCLOPEDIA OF STATISTICAL SCIENCES C NOTE--THE GENERAL INVERSE GAUSSIAN DISTRIBUTION-- C GOES FROM 0 TO INFINITY C HAS MEAN = MU (HERE = 1) C HAS STANDARD DEVIATION = SQRT((MU**3)/GAMMA) C HAS SHAPE PARAMETER = GAMMA C IS HIGHLY-SKEWED AND LONG-TAILED FOR SMALL GAMMA C IS SYMMETRIC AND MODERATE-TAILED FOR KARGE GAMMA C APPROACHES NORMALITY AS GAMMA APPROACHES INFINITY C THE PERCENT POINT FUNCTION IS NOT IN CLOSED FORM 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 --GAMMA = THE SHAPE PARAMETER C GAMMA SHOULD BE POSITIVE. C --AMU = THE SHAPE PARAMETER C AMU SHOULD BE POSITIVE. C OUTPUT ARGUMENTS--PPF = THE SINGLE PRECISION PERCENT POINT C FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PERCENT POINT C FUNCTION VALUE PPF FOR THE INVERSE GAUSSIAN DISRIBUTION C WITH SHAPE PARAMETER GAMMA C AND SHAPE PARAMETER MU C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--P SHOULD BE BETWEEN C 0.0 (INCLUSIVELY) AND 1.0 (EXCLUSIVELY). C --GAMMA SHOULD BE POSITIVE C OTHER DATAPAC SUBROUTINES NEEDED--IGCDF, NORCDF C FORTRAN LIBRARY SUBROUTINES NEEDED-- C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--KOTZ & JOHNSON, ENCYCLOPEDIA OF STAT SCIENCES C VOLUME 4, PAGE 247, COLUMN 1. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C 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--90.6 C ORIGINAL VERSION--MAY 1990. C UPDATED --JANUARY 1995. NEW CDF DEFINITION & REWRITTEN C UPDATED --DECEMBER 2003. SUPPORT FOR MU NOT EQUAL 1 C C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DGAMMA DOUBLE PRECISION DMU DOUBLE PRECISION DCDF C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(GAMMA.LE.0)THEN WRITE(ICOUT,51) 51 FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER ', 1 'TO THE IGPPF SUBROUTINE IS NON-POSITIVE *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)GAMMA 52 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9000 ENDIF C IF(AMU.LE.0)THEN WRITE(ICOUT,71) 71 FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER ', 1 'TO THE IGPPF SUBROUTINE IS NON-POSITIVE *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)AMU CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9000 ENDIF C IF(P.LT.0.0.OR.P.GE.1.0)THEN WRITE(ICOUT,61) 61 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT ', 1 'TO THE IGPPF SUBROUTINE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,62) 62 FORMAT(' IS OUTSIDE THE ALLOWABLE [0,1) INTERVAL ***') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)P CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9000 ENDIF C IBUG=0.0 C TOL=0.000001 MAXIT=500 XMIN=0.0 C IF(P.EQ.0.0)THEN PPF=XMIN GOTO9000 ENDIF C C FROM THE KARLIN-STUDDEN INEQUALITY (PATEL/KAPADIA/OWEN, P. 30) C (BUT TRUE ONLY FOR X >= 1.5*MU) C FOR THE PROTOTYPE INVERSE GAUSSIAN DISTRIBUTION, C MU = MU (AND HERE MU = 1) CCCCC XMAX=10.0**30 SD=SQRT(AMU**3/GAMMA) XMAX=AMU/(2.0*(1.0-P)) C DGAMMA=DBLE(GAMMA) DMU=DBLE(AMU) C XLOW=XMIN XUP=XMAX C CCCCC HOPEFULLY, SAM SAUNDERS CAN GIVE ME A BETTER CCCCC FIRST APPROXIMATION TO G(P) THAN MY 1.0 ! CCCCC XMID=1.0 XMID=AMU IF(IBUG.EQ.1)THEN WRITE(ICOUT,101)XMID,AMU,SD 101 FORMAT('XMID,AMU,SD = ',3E15.7) CALL DPWRST('XXX','BUG ') ENDIF C ICOUNT=0 C 200 CONTINUE X=XMID DX=DBLE(X) CALL IGCDF2(DX,DGAMMA,DMU,DCDF) PCALC=REAL(DCDF) C IF(PCALC.EQ.P)THEN PPF=XMID GOTO9000 ELSEIF(PCALC.GT.P)THEN C 220 CONTINUE XUP=XMID X=XMID/2.0 IF(X.LE.XLOW)GOTO221 XMID=X IF(IBUG.EQ.1)THEN WRITE(ICOUT,101)XMID CALL DPWRST('XXX','BUG ') ENDIF DX=DBLE(X) CALL IGCDF2(DX,DGAMMA,DMU,DCDF) PCALC=REAL(DCDF) IF(PCALC.EQ.P)THEN PPF=XMID GOTO9000 ENDIF IF(PCALC.GT.P)GOTO220 XLOW=X 221 CONTINUE XMID=(XLOW+XUP)/2.0 IF(IBUG.EQ.1)THEN WRITE(ICOUT,101)XMID CALL DPWRST('XXX','BUG ') ENDIF C ELSE C 210 CONTINUE XLOW=XMID X=XMID*2.0 IF(X.GE.XUP)GOTO211 XMID=X IF(IBUG.EQ.1)THEN WRITE(ICOUT,101)XMID CALL DPWRST('XXX','BUG ') ENDIF DX=DBLE(X) CALL IGCDF2(DX,DGAMMA,DMU,DCDF) PCALC=REAL(DCDF) IF(PCALC.EQ.P)THEN PPF=XMID GOTO9000 ENDIF IF(PCALC.LT.P)GOTO210 XUP=X 211 CONTINUE XMID=(XLOW+XUP)/2.0 IF(IBUG.EQ.1)THEN WRITE(ICOUT,101)XMID CALL DPWRST('XXX','BUG ') ENDIF ENDIF C XDEL=ABS(XMID-XLOW) ICOUNT=ICOUNT+1 IF(XDEL.LT.TOL.OR.ICOUNT.GT.MAXIT)THEN PPF=XMID GOTO9000 ENDIF GOTO200 C 9000 CONTINUE RETURN END SUBROUTINE IGRAN(N,GAMMA,AMU,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE INVERSE GAUSSIAN DISTRIBUTION C WITH SHAPE PARAMETER VALUE = GAMMA C AND LOCATION PARAMETER MU = 1. C THE PROTOTYPE INVERSE GAUSSIAN DISTRIBUTION USED C HEREIN IS DEFINED FOR ALL POSITIVE X, C AND HAS THE PROBABILITY DENSITY FUNCTION C AS GIVEN IN VOLUME 4, PAGE 246, BOTTOM C OF ENCYCLOPEDIA OF STATISTICAL SCIENCES C WITH MU = 1 C NOTE--THE GENERAL INVERSE GAUSSIAN DISTRIBUTION-- C GOES FROM 0 TO INFINITY C HAS MEAN = MU (HERE = 1) C HAS STANDARD DEVIATION = SQRT((MU**3)/GAMMA) C HAS SHAPE PARAMETER = GAMMA C IS HIGHLY-SKEWED AND LONG-TAILED FOR SMALL GAMMA C IS SYMMETRIC AND MODERATE-TAILED FOR KARGE GAMMA C APPROACHES NORMALITY AS GAMMA APPROACHES INFINITY C NOTE--TO OBTAIN THE PDF FOR GENERAL MU, C COMPUTE THE PDF FOR X AROUND 1, AND THEN C SIMPLY SCALE UP THE HORIZONTAL AXIS X BY THE DESIRED MU C AS IN Y2 = MU*Y C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --GAMMA = THE SINGLE PRECISION VALUE OF THE C TAIL LENGTH PARAMETER. C GAMMA SHOULD BE POSITIVE. C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR C (OF DIMENSION AT LEAST N) C INTO WHICH THE GENERATED C RANDOM SAMPLE WILL BE PLACED. C OUTPUT--A RANDOM SAMPLE OF SIZE N C FROM THE INVERSE GAUSSIAN DISTRIBUTION C WITH TAIL LENGTH PARAMETER VALUE = GAMMA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C --GAMMA SHOULD BE POSITIVE. C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE HEREIN. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--KOTZ & JOHNSON, ENCYCLOPEDIA OF STAT SCIENCES C VOLUME 4, PAGE 247, COLUMN 1 (FOR CDF). C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--90.6 C ORIGINAL VERSION--MAY 1990. C UPDATED --JANUARY 1995. NEW CDF DEFINITION & REWRITTEN C UPDATED --NOVEMBER 2003. USE MICHEAL/SCHUCANY/HAAS C METHOD (FROM JAMES GENTLE C "RANDOM NUMBER GENERATION AND C MONTE CARLO METHODS", SECOND C EDITION, SPRINGER-VARLANG, C 2003, P. 193. 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,51) 51 FORMAT('***** FATAL ERROR--THE REQUESTED NUMBER OF INVERSE ', 1 'GAUSSIAN RANDOM NUMBERS IS NON-POSITIVE *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)N 52 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF C IF(GAMMA.LE.0.0)THEN WRITE(ICOUT,61) 61 FORMAT('***** FATAL ERROR--THE GAMMA SHAPE PARAMETER FOR THE', 1 ' INVERSE GAUSSIAN') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,62) 62 FORMAT(' RANDOM NUMBERS IS NON-POSITIVE *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,63)GAMMA 63 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF C IF(AMU.LE.0.0)THEN WRITE(ICOUT,71) 71 FORMAT('***** FATAL ERROR--THE MU SHAPE PARAMETER FOR THE', 1 ' INVERSE GAUSSIAN') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,72) 72 FORMAT(' RANDOM NUMBERS IS NON-POSITIVE *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,63)AMU CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF C C GENERATE N UNIFORM (0,1) RANDOM NUMBERS; C CCCCC CALL UNIRAN(N,ISEED,X) C C GENERATE N INVERSE GAUSSIAN DISTRIBUTION RANDOM NUMBERS C USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD. C CCCCC DO100I=1,N CCCCC XI=X(I) CCCCC CALL IGPPF(XI,GAMMA,X(I)) C 100 CONTINUE C C MICHEAL/SCHUCANY/HAAS ALGORITHM. C C GENERATE N NORMAL (0,1) RANDOM NUMBERS; C CALL NORRAN(N,ISEED,X) C NTEMP=1 DO100I=1,N Y=X(I)*X(I) X1=AMU + AMU*AMU*Y/(2.0*GAMMA) - 1 (AMU/(2.0*GAMMA))*SQRT(4.0*AMU*GAMMA*Y + AMU*AMU*Y*Y) CALL UNIRAN(NTEMP,ISEED,X(I)) U=X(I) IF(U.LE.AMU/(AMU+X1))THEN X(I)=X1 ELSE X(I)=AMU*AMU/X1 ENDIF 100 CONTINUE C 9000 CONTINUE RETURN END SUBROUTINE IMTQL2(NM,N,D,E,Z,IERR) C***BEGIN PROLOGUE IMTQL2 C***DATE WRITTEN 760101 (YYMMDD) C***REVISION DATE 830518 (YYMMDD) C***CATEGORY NO. D4A5,D4C2A C***KEYWORDS EIGENVALUES,EIGENVECTORS,EISPACK C***AUTHOR SMITH, B. T., ET AL. C***PURPOSE Computes eigenvalues and eigenvectors of symmetric C tridiagonal matrix using implicit QL method. C***DESCRIPTION C C This subroutine is a translation of the ALGOL procedure IMTQL2, C NUM. MATH. 12, 377-383(1968) by Martin and Wilkinson, C as modified in NUM. MATH. 15, 450(1970) by Dubrulle. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 241-248(1971). C C This subroutine finds the eigenvalues and eigenvectors C of a SYMMETRIC TRIDIAGONAL matrix by the implicit QL method. C The eigenvectors of a FULL SYMMETRIC matrix can also C be found if TRED2 has been used to reduce this C full matrix to tridiagonal form. 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 D contains the diagonal elements of the input matrix. C C E contains the subdiagonal elements of the input matrix C in its last N-1 positions. E(1) is arbitrary. C C Z contains the transformation matrix produced in the C reduction by TRED2, if performed. If the eigenvectors C of the tridiagonal matrix are desired, Z must contain C the identity matrix. C C On OUTPUT C C D contains the eigenvalues in ASCENDING order. If an C error exit is made, the eigenvalues are correct but C UNORDERED for indices 1,2,...,IERR-1. C C E has been destroyed. C C Z contains orthonormal eigenvectors of the symmetric C tridiagonal (or full) matrix. If an error exit is made, C Z contains the eigenvectors associated with the stored C eigenvalues. C C IERR is set to C ZERO for normal return, C J if the J-th eigenvalue has not been C determined after 30 iterations. C C Calls PYTHAG(A,B) for sqrt(A**2 + B**2). C C Questions and comments should be directed to B. S. Garbow, C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY C ------------------------------------------------------------------ C***REFERENCES B. T. SMITH, J. M. BOYLE, J. J. DONGARRA, B. S. GARBOW, C Y. IKEBE, V. C. KLEMA, C. B. MOLER, *MATRIX EIGEN- C SYSTEM ROUTINES - EISPACK GUIDE*, SPRINGER-VERLAG, C 1976. C***ROUTINES CALLED PYTHAG C***END PROLOGUE IMTQL2 C INTEGER I,J,K,L,M,N,II,NM,MML,IERR REAL D(N),E(N),Z(NM,N) REAL B,C,F,G,P,R,S,S1,S2 REAL PYTHAG C C***FIRST EXECUTABLE STATEMENT IMTQL2 IERR = 0 IF (N .EQ. 1) GO TO 1001 C DO 100 I = 2, N 100 E(I-1) = E(I) C E(N) = 0.0E0 C DO 240 L = 1, N J = 0 C .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT .......... 105 DO 110 M = L, N IF (M .EQ. N) GO TO 120 S1 = ABS(D(M)) + ABS(D(M+1)) S2 = S1 + ABS(E(M)) IF (S2 .EQ. S1) GO TO 120 110 CONTINUE C 120 P = D(L) IF (M .EQ. L) GO TO 240 IF (J .EQ. 30) GO TO 1000 J = J + 1 C .......... FORM SHIFT .......... G = (D(L+1) - P) / (2.0E0 * E(L)) R = PYTHAG(G,1.0E0) G = D(M) - P + E(L) / (G + SIGN(R,G)) S = 1.0E0 C = 1.0E0 P = 0.0E0 MML = M - L C .......... FOR I=M-1 STEP -1 UNTIL L DO -- .......... DO 200 II = 1, MML I = M - II F = S * E(I) B = C * E(I) IF (ABS(F) .LT. ABS(G)) GO TO 150 C = G / F R = SQRT(C*C+1.0E0) E(I+1) = F * R S = 1.0E0 / R C = C * S GO TO 160 150 S = F / G R = SQRT(S*S+1.0E0) E(I+1) = G * R C = 1.0E0 / R S = S * C 160 G = D(I+1) - P R = (D(I) - G) * S + 2.0E0 * C * B P = S * R D(I+1) = G + P G = C * R - B C .......... FORM VECTOR .......... DO 180 K = 1, N F = Z(K,I+1) Z(K,I+1) = S * Z(K,I) + C * F Z(K,I) = C * Z(K,I) - S * F 180 CONTINUE C 200 CONTINUE C D(L) = D(L) - P E(L) = G E(M) = 0.0E0 GO TO 105 240 CONTINUE C .......... ORDER EIGENVALUES AND EIGENVECTORS .......... DO 300 II = 2, N I = II - 1 K = I P = D(I) C DO 260 J = II, N IF (D(J) .GE. P) GO TO 260 K = J P = D(J) 260 CONTINUE C IF (K .EQ. I) GO TO 300 D(K) = D(I) D(I) = P C DO 280 J = 1, N P = Z(J,I) Z(J,I) = Z(J,K) Z(J,K) = P 280 CONTINUE C 300 CONTINUE C GO TO 1001 C .......... SET ERROR -- NO CONVERGENCE TO AN C EIGENVALUE AFTER 30 ITERATIONS .......... 1000 IERR = L 1001 RETURN END SUBROUTINE INITDA(IBUGIN) C C PURPOSE--THIS IS SUBROUTING INITDA. C (THE DA AT THE END OF INITDA STANDS FOR DATA) C THIS SUBROUTINE INITIALIZES DATA VARIABLES 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--82/7 C ORIGINAL VERSION--NOVEMBER 1980. C UPDATED --AUGUST 1981. C UPDATED --MAY 1982. C UPDATED --FEBRUARY 1989. SOFT-CODING (ALAN) C UPDATED --JULY 1989. MAXCP1/2/3/4/5/6 C UPDATED --JANUARY 1998. ADD MAXROM, MAXCOM C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IBLANK CHARACTER*4 IBUGIN C C--------------------------------------------------------------------- C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCODA.INC' CCCCC THE FOLLOWING LINE WAS ADDED JULY 1989 INCLUDE 'DPCOM2.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IF(IBUGIN.EQ.'OFF')GOTO99 WRITE(ICOUT,90) 90 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,95) 95 FORMAT('***** AT THE BEGINNING OF INITDA--') CALL DPWRST('XXX','BUG ') 99 CONTINUE C IBLANK=' ' IZERO=0 ZERO=0.0 C C ***************************************************** C ** INITIALIZE ** C ** THE MAXIMUM TOTAL NUMBER OF OBSERVATIONS, AND ** C ** THE TOTAL NUMBER OF OBSERVATIONS ** C ***************************************************** C CCCCC MAXNK=10000 MAXNK=MAXOBW NK=0 C C ************************************************************ C ** INITIALIZE ** C ** THE MAXIMUM NUMBER OF OBSERVATIONS PER VARIABLE, AND ** C ** THE NUMBER OF OBSERVATIONS PER VARIABLE ** C ************************************************************ C CCCCC IDEMXN=1000 ALAN HAS THIS ON THE CYBER IDEMXN=MAXOBV MAXN=IDEMXN N=0 C C ******************************************** C ** INITIALIZE ** C ** THE MAXIMUM NUMBER OF VARIABLES, AND ** C ** THE NUMBER OF VARIABLES (COLUMNS) ** C ******************************************** C CCCCC IDEMXC=10 CCCCC IDEMXC=MAXNK/IDEMXN ALAN HAS THIS ON THE CYBER IDEMXC=MAXOBW/MAXOBV MAXCOL=IDEMXC NUMCOL=0 C CCCCC THE FOLLOWING 6 LINES WERE ADDED JULY 1989 MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C C **************************************************************** C ** INITIALIZE C ** THE MAXIMUM TOTAL NUMBER OF CHARACTERS FOR ALL FUNCTIONS, AN C ** THE TOTAL NUMBER OF CHARACTERS FOR ALL FUNCTIONS C **************************************************************** C CCCCC MAXCHF=1000 MAXCHF=MAXF1 NUMCHF=0 C C ******************************************** C ** INITIALIZE ** C ** THE MAXIMUM NUMBER OF FUNCTIONS, AND ** C ** THE NUMBER OF FUNCTIONS ** C ******************************************** C CCCCC MAXFUN=100 MAXFUN=MAXFN2 NUMFUN=0 C C ********************************************** C ** INITIALIZE THE MAXIMUM TOTAL NUMBER OF ** C ** CHARACTERS (THAT WILL BE PRINTED) ** C ** (IN THE STATUS COMMAND OUTPUT) ** C ** FOR THE LAST MODEL FITTED. ** C ********************************************** C CCCCC MAXCHM=200 MAXCHM=MAXF3 NUMCHM=0 C C ********************************************** C ** INITIALIZE ** C ** THE MAXIMUM NUMBER OF CONSTRAINTS, AND ** C ** THE NUMBER OF CONSTRAINTS ** C ********************************************** C MAXCON=100 NUMCON=0 C CCCCC FOLLOWING SECTION ADDED JANUARY 1998. C ********************************************** C ** INITIALIZE ** C ** THE MAXIMUM NUMBER OF ROWS AND COLUMNS ** C ** IN A MATRIX ** C ********************************************** C MAXCOM=100 MAXROM=(46*MAXOBV/3)/100 C C ******************************* C ** EXIT AND RETURN TO MAIN ** C ******************************* C 9000 CONTINUE IF(IBUGIN.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9911) 9911 FORMAT('***** AT THE END OF INITDA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)MAXN,N 9012 FORMAT('MAXN,N = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)MAXCOL,NUMCOL 9013 FORMAT('MAXCOL,NUMCOL = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)MAXNK,NK 9014 FORMAT('MAXNK,NK = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)MAXCHF,NUMCHF 9015 FORMAT('MAXCHF,NUMCHF = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)MAXCHM,NUMCHM 9016 FORMAT('MAXCHM,NUMCHM = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9017)MAXCON,NUMCON 9017 FORMAT('MAXCON,NUMCON = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9021)MAXOBV,MAXOBW 9021 FORMAT('MAXOBV,MAXOBW = ',2I8) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE INITDB C C PURPOSE--THIS IS SUBROUTING INITDB. C (THE DB AT THE END OF INITDB STANDS FOR DEBUGGI C THIS SUBROUTINE INITIALIZES DEBUGGING VARIABLES AND PARAMETERS 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--82/7 C ORIGINAL VERSION--NOVEMBER 1980. C UPDATED --AUGUST 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOMC.INC' INCLUDE 'DPCODB.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IF(IBUGIN.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF INITDB--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52) 52 FORMAT(' NOTE--SINCE IBUGIN WILL BE SET TO OFF ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53) 53 FORMAT(' WITHIN THIS SUBROUTINE, THERE WILL BE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54) 54 FORMAT(' NO MESSAGE AT THE END OF THIS SUBROUTINE.') CALL DPWRST('XXX','BUG ') 90 CONTINUE C C *********************************************** C ** INITIALIZE THE BUG VECTOR ** C ** (THE VECTOR WHERE THE BUG PARAMETERS ** C ** ARE PLACED) ** C *********************************************** C MAXBUG=100 NUMBUG=0 C DO100I=1,MAXBUG IH1BUG(I)='OFF' CCCCC IH1BUG(I)='ON' 100 CONTINUE C C ******************************* C ** EXIT AND RETURN TO MAIN ** C ******************************* C 9000 CONTINUE IF(IBUGIN.EQ.'OFF')GOTO9999 WRITE(ICOUT,9990) 9990 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9995) 9995 FORMAT('***** AT THE END OF INITDB--') CALL DPWRST('XXX','BUG ') 9999 CONTINUE C RETURN END SUBROUTINE INITDE(IBUGIN) C C PURPOSE--THIS IS SUBROUTING INITDE. C (THE DE AT THE END OF INITDE C STANDS FOR DESIGN OF EXPERIMENTS C THIS SUBROUTINE INITIALIZES DESIGN-OF-EXPERIMENT C PARAMETERS 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--89/6 C ORIGINAL VERSION--MAY 1989. C UPDATED --AUGUST 1993. BUG FIX C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IBUGIN CCCCC AUGUST 1993. COMPILE ERROR ON RS-6000, ADD FOLLOWING LINE CHARACTER*4 ITEXT C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCODE.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IF(IBUGIN.EQ.'OFF')GOTO99 WRITE(ICOUT,90) 90 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,95) 95 FORMAT('***** AT THE BEGINNING OF INITDE--') CALL DPWRST('XXX','BUG ') 99 CONTINUE C C *********************************************** C ** SET THE DESIGN OF EXPERIMENT SETTINGS ** C ** IDEXDE = DEPTH INTO INTERACTION TERMS ** C ** 1 = MAIN EFFECTS ONLY ** C ** 2 = UP TO 2-TERM INTERACTIONS** C ** ETC. ** C ** DEXWID = WIDTH ON THE PLOT ACROSS ** C ** ALL LEVELS WITHIN A FACTOR ** C ** IDEXHA = HORIZONTAL AXIS VARIABLE ** C ** DEFAULT = 'FACT' ** C ** CAN ALSO HAVE 'TERM' ** C *********************************************** C IDEDED=1 DEFDEW=0.4 IDEFHA='FACT' C IDEXDE=1 DEXWID=0.4 IDEXHA='FACT' C C ************************************************** C ** INITIALIZE EXPERIMENTAL SIMULATION SETTINGS ** C ************************************************** C ************************************************** C ** INITIALIZE EXPERIMENTAL SIMULATION SETTINGS ** C ** GMEAN = GRAND MEAN ** C ** NUMB = TOTAL NUMBER OF COEFFICIENTS **(EXCLUDING GRA C ** INDEXB(.) = INDEX FOR COEFFICIENTS (EXCLU**DING GRAND MEA C ** B(.) = COEFFICIENTS (EXCLUDING GRAND** MEAN) C ** GSD = GENERAL STANDARD DEVIATION ** C ** = SD OF ERROR IN Y = GRAND MEAN** + ERROR C ** NUMS = XX ** C ** BMINT = INTERCEPT FOR GRAND MEAN DRIF**T IN TIME C ** BMSLOP = SLOPE FOR GRAND MEAN DRIF**T IN TIME C ** DSINT = INTERCEPT FOR SD DRIF**T IN TIME C ** DSSLOP = SLOPE FOR SD DRIF**T IN TIME C ************************************************** C ISIMID=0 IAUTH='BOXB' ITEXT='TECH' IPAGE=17 C GMEAN=71.25 NUMB=7 INDEXB(1)=1 INDEXB(2)=2 INDEXB(3)=3 INDEXB(4)=12 INDEXB(5)=13 INDEXB(6)=23 INDEXB(7)=123 B(1)=23.0 B(2)=(-5.0) B(3)=1.5 B(4)=1.5 B(5)=10.0 B(6)=0.0 B(7)=0.5 C CCCCC GSD=0.1 GSD=0.0 NUMS=0 C BMINT=0.0 BMSLOP=0.0 C DSINT=0.0 DSSLOP=0.0 C C ******************************* C ** EXIT AND RETURN TO MAIN ** C ******************************* C 9000 CONTINUE IF(IBUGIN.EQ.'OFF')GOTO9999 WRITE(ICOUT,9990) 9990 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9995) 9995 FORMAT('***** AT THE END OF INITDE--') CALL DPWRST('XXX','BUG ') 9999 CONTINUE C RETURN END FUNCTION INITDS (OS, NOS, ETA) C***BEGIN PROLOGUE INITDS C***PURPOSE Determine the number of terms needed in an orthogonal C polynomial series so that it meets a specified accuracy. C***LIBRARY SLATEC (FNLIB) C***CATEGORY C3A2 C***TYPE DOUBLE PRECISION (INITS-S, INITDS-D) C***KEYWORDS CHEBYSHEV, FNLIB, INITIALIZE, ORTHOGONAL POLYNOMIAL, C ORTHOGONAL SERIES, SPECIAL FUNCTIONS C***AUTHOR Fullerton, W., (LANL) C***DESCRIPTION C C Initialize the orthogonal series, represented by the array OS, so C that INITDS is the number of terms needed to insure the error is no C larger than ETA. Ordinarily, ETA will be chosen to be one-tenth C machine precision. C C Input Arguments -- C OS double precision array of NOS coefficients in an orthogonal C series. C NOS number of coefficients in OS. C ETA single precision scalar containing requested accuracy of C series. C C***REFERENCES (NONE) C***ROUTINES CALLED XERMSG C***REVISION HISTORY (YYMMDD) C 770601 DATE WRITTEN C 890531 Changed all specific intrinsics to generic. (WRB) C 890831 Modified array declarations. (WRB) C 891115 Modified error message. (WRB) C 891115 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) C***END PROLOGUE INITDS DOUBLE PRECISION OS(*) 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***FIRST EXECUTABLE STATEMENT INITDS IF (NOS .LT. 1) THEN WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,12) CALL DPWRST('XXX','BUG ') INITDS = 0.D0 RETURN ENDIF 11 FORMAT('***** ERROR FROM INITDS. THE NUMBER OF ') 12 FORMAT(' COEFFICIENTS IS LESS THAN 1. *****') C ERR = 0. DO 10 II = 1,NOS I = NOS + 1 - II ERR = ERR + ABS(REAL(OS(I))) IF (ERR.GT.ETA) GO TO 20 10 CONTINUE C 20 IF (I .EQ. NOS) THEN WRITE(ICOUT,21) 21 FORMAT('***** ERROR FROM INITDS. CHEBYSHEV SERIES TOO ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,22) 22 FORMAT(' SHORT FOR SPECIFIED ACCURACY. *****') CALL DPWRST('XXX','BUG ') ENDIF INITDS = I C RETURN END BLOCK DATA INITD1 C C PURPOSE--THIS IS BLOCK DATA ROUTINE INITD20 C THIS INITIALIZES THE REAL DATA ARRAYS (ONCE). USE BLOCK C DATA FOR SPEED (DONE AT LOAD TIME, NOT AT RUN TIME) C THIS SUBROUTINE INITIALIZES DATA VARIABLES 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--82/7 C UPDATED --OCTOBER 1993. DIFFERENT SYNTAX (SGI VERSION C BOMBS ON OLD SYNTAX) C C--------------------------------------------------------------------- C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCODA.INC' C C-----START POINT----------------------------------------------------- C CCCCC DATA (ISUB(I),I=1,MAXOBV) /MAXOBV*0/ CCCCC DATA (I1DATA(I),I=1,100) /100*0/ C CCCCC DATA (PARLIM(I),I=1,100) /100*0./ C DATA ISUB /MAXOBV*0/ DATA I1DATA /100*0/ C DATA PARLIM /100*0./ C END BLOCK DATA INITD2 C C PURPOSE--THIS IS BLOCK DATA ROUTINE INITD20 C THIS INITIALIZES THE REAL DATA ARRAYS (ONCE). USE BLOCK C DATA FOR SPEED (DONE AT LOAD TIME, NOT AT RUN TIME) C THIS SUBROUTINE INITIALIZES DATA VARIABLES 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--82/7 C ORIGINAL VERSION--OCTOBER 1991. C UPDATED --OCTOBER 1993. DIFFERENT SYNTAX (SGI VERSION C BOMBS ON OLD SYNTAX) C C--------------------------------------------------------------------- C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCODA.INC' C C-----START POINT----------------------------------------------------- C CCCCC DATA (PRED(I),I=1,MAXOBV) /MAXOBV*0./ CCCCC DATA (RES(I),I=1,MAXOBV) /MAXOBV*0./ C DATA PRED /MAXOBV*0./ DATA RES /MAXOBV*0./ C END BLOCK DATA INITD3 C C PURPOSE--THIS IS BLOCK DATA ROUTINE INITD21 C THIS INITIALIZES THE REAL DATA ARRAYS (ONCE). USE BLOCK C DATA FOR SPEED (DONE AT LOAD TIME, NOT AT RUN TIME) C THIS SUBROUTINE INITIALIZES DATA VARIABLES 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--82/7 C ORIGINAL VERSION--OCTOBER 1991. C UPDATED --OCTOBER 1993. DIFFERENT SYNTAX (SGI VERSION C BOMBS ON OLD SYNTAX) C C--------------------------------------------------------------------- C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCODA.INC' C C-----START POINT----------------------------------------------------- C CCCCC DATA (X(I),I=1,MAXPOP) /MAXPOP*0./ DATA X /MAXPOP*0./ C END BLOCK DATA INITD4 C C PURPOSE--THIS IS BLOCK DATA ROUTINE INITD22 C THIS INITIALIZES THE REAL DATA ARRAYS (ONCE). USE BLOCK C DATA FOR SPEED (DONE AT LOAD TIME, NOT AT RUN TIME) C THIS SUBROUTINE INITIALIZES DATA VARIABLES 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--82/7 C ORIGINAL VERSION--OCTOBER 1991. C UPDATED --OCTOBER 1993. DIFFERENT SYNTAX (SGI VERSION C BOMBS ON OLD SYNTAX) C C--------------------------------------------------------------------- C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCODA.INC' C C-----START POINT----------------------------------------------------- C C CCCCC DATA (YPLOT(I),I=1,MAXPOP) /MAXPOP*0./ DATA YPLOT /MAXPOP*0./ C END BLOCK DATA INITD5 C C PURPOSE--THIS IS BLOCK DATA ROUTINE INITD23 C THIS INITIALIZES THE REAL DATA ARRAYS (ONCE). USE BLOCK C DATA FOR SPEED (DONE AT LOAD TIME, NOT AT RUN TIME) C THIS SUBROUTINE INITIALIZES DATA VARIABLES 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--82/7 C ORIGINAL VERSION--OCTOBER 1991. C UPDATED --OCTOBER 1993. DIFFERENT SYNTAX (SGI VERSION C BOMBS ON OLD SYNTAX) C C--------------------------------------------------------------------- C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCODA.INC' C C-----START POINT----------------------------------------------------- C CCCCC DATA ((AMATR1(I,J),I=1,100),J=1,100) /10000*0./ DATA AMATR1 /10000*0./ C END BLOCK DATA INITD6 C C PURPOSE--THIS IS BLOCK DATA ROUTINE INITD21 C THIS INITIALIZES THE REAL DATA ARRAYS (ONCE). USE BLOCK C DATA FOR SPEED (DONE AT LOAD TIME, NOT AT RUN TIME) C THIS SUBROUTINE INITIALIZES DATA VARIABLES 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--82/7 C ORIGINAL VERSION--OCTOBER 1991. C UPDATED --OCTOBER 1993. DIFFERENT SYNTAX (SGI VERSION C BOMBS ON OLD SYNTAX) C C--------------------------------------------------------------------- C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCODA.INC' C C-----START POINT----------------------------------------------------- C CCCCC DATA (X3D(I),I=1,MAXPOP) /MAXPOP*0./ DATA X3D /MAXPOP*0./ C END BLOCK DATA INID7A C C PURPOSE--THIS IS BLOCK DATA ROUTINE INID7A C THIS INITIALIZES THE REAL DATA ARRAY D(.). C BLOCK DATA IS USED FOR SPEED C SINCE DONE AT LOAD TIME--NOT AT RUN TIME. 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 LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--92/10 C ORIGINAL VERSION--SEPTEMBER 1992. C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCODA.INC' C C-----START POINT----------------------------------------------------- C CCCCC DATA (D(I),I=1,MAXPOP) /MAXPOP*0./ DATA D /MAXPOP*0./ C END BLOCK DATA INID7B C C PURPOSE--THIS IS BLOCK DATA ROUTINE INID7B C THIS INITIALIZES THE REAL DATA ARRAY DSIZE(.). C BLOCK DATA IS USED FOR SPEED C SINCE DONE AT LOAD TIME--NOT AT RUN TIME. 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 LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--92/10 C ORIGINAL VERSION--SEPTEMBER 1992. C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCODA.INC' C C-----START POINT----------------------------------------------------- C CCCCC DATA (DSIZE(I),I=1,MAXPOP) /MAXPOP*0./ DATA DSIZE /MAXPOP*0./ C END BLOCK DATA INID7C C C PURPOSE--THIS IS BLOCK DATA ROUTINE INID7C C THIS INITIALIZES THE REAL DATA ARRAY DSYMB(.). C BLOCK DATA IS USED FOR SPEED C SINCE DONE AT LOAD TIME--NOT AT RUN TIME. 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 LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--92/10 C ORIGINAL VERSION--SEPTEMBER 1992. C UPDATED --OCTOBER 1993. DIFFERENT SYNTAX (SGI VERSION C BOMBS ON OLD SYNTAX) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCODA.INC' C C-----START POINT----------------------------------------------------- C CCCCC DATA (DSYMB(I),I=1,MAXPOP) /MAXPOP*0./ DATA DSYMB /MAXPOP*0./ C END BLOCK DATA INID7D C C PURPOSE--THIS IS BLOCK DATA ROUTINE INID7D C THIS INITIALIZES THE REAL DATA ARRAY DCOLOR(.). C BLOCK DATA IS USED FOR SPEED C SINCE DONE AT LOAD TIME--NOT AT RUN TIME. 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 LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--92/10 C ORIGINAL VERSION--SEPTEMBER 1992. C UPDATED --OCTOBER 1993. DIFFERENT SYNTAX (SGI VERSION C BOMBS ON OLD SYNTAX) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCODA.INC' C C-----START POINT----------------------------------------------------- C CCCCC DATA (DCOLOR(I),I=1,MAXPOP) /MAXPOP*0./ DATA DCOLOR /MAXPOP*0./ C END BLOCK DATA INID7E C C PURPOSE--THIS IS BLOCK DATA ROUTINE INID7E C THIS INITIALIZES THE REAL DATA ARRAY DFILL(.). C BLOCK DATA IS USED FOR SPEED C SINCE DONE AT LOAD TIME--NOT AT RUN TIME. 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 LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--92/10 C ORIGINAL VERSION--SEPTEMBER 1992. C UPDATED --OCTOBER 1993. DIFFERENT SYNTAX (SGI VERSION C BOMBS ON OLD SYNTAX) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCODA.INC' C C-----START POINT----------------------------------------------------- C CCCCC DATA (DFILL(I),I=1,MAXPOP) /MAXPOP*0./ DATA DFILL /MAXPOP*0./ C END BLOCK DATA INITD8 C C PURPOSE--THIS IS BLOCK DATA ROUTINE INITD22 C THIS INITIALIZES THE REAL DATA ARRAYS (ONCE). USE BLOCK C DATA FOR SPEED (DONE AT LOAD TIME, NOT AT RUN TIME) C THIS SUBROUTINE INITIALIZES DATA VARIABLES 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--82/7 C ORIGINAL VERSION--OCTOBER 1991. C UPDATED --OCTOBER 1993. DIFFERENT SYNTAX (SGI VERSION C BOMBS ON OLD SYNTAX) C C--------------------------------------------------------------------- C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCODA.INC' C C-----START POINT----------------------------------------------------- C C CCCCC DATA (X2PLOT(I),I=1,MAXPOP) /MAXPOP*0./ DATA X2PLOT /MAXPOP*0./ C END BLOCK DATA INITD9 C C PURPOSE--THIS IS BLOCK DATA ROUTINE INITD22 C THIS INITIALIZES THE REAL DATA ARRAYS (ONCE). USE BLOCK C DATA FOR SPEED (DONE AT LOAD TIME, NOT AT RUN TIME) C THIS SUBROUTINE INITIALIZES DATA VARIABLES 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--82/7 C ORIGINAL VERSION--OCTOBER 1991. C UPDATED --OCTOBER 1993. DIFFERENT SYNTAX (SGI VERSION C BOMBS ON OLD SYNTAX) C C--------------------------------------------------------------------- C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCODA.INC' C C-----START POINT----------------------------------------------------- C C CCCCC DATA (XPLOT(I),I=1,MAXPOP) /MAXPOP*0./ DATA XPLOT /MAXPOP*0./ C END BLOCK DATA INITDZ C C PURPOSE--THIS IS BLOCK DATA ROUTINE INITD22 C THIS INITIALIZES THE REAL DATA ARRAYS (ONCE). USE BLOCK C DATA FOR SPEED (DONE AT LOAD TIME, NOT AT RUN TIME) C THIS SUBROUTINE INITIALIZES DATA VARIABLES 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--82/7 C ORIGINAL VERSION--OCTOBER 1991. C UPDATED --OCTOBER 1993. DIFFERENT SYNTAX (SGI VERSION C BOMBS ON OLD SYNTAX) C C--------------------------------------------------------------------- C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCODA.INC' C C-----START POINT----------------------------------------------------- C C CCCCC DATA (TAGPLO(I),I=1,MAXPOP) /MAXPOP*0./ DATA TAGPLO /MAXPOP*0./ C END SUBROUTINE INITH2(IHNAME,IHNAM2,IUSE,IN,IVSTAR,IVSTOP, 1IVALUE,VALUE,NUMNAM,MAXN,MAXCOL,IBUGIN) C C PURPOSE--ENTER INFORMATION ABOUT THE C PRED (= PREDICTED VALUES) VECTOR AND C RES (= RESIDUALS ) VECTOR C INTO THE HOUEKEEPING TABLES. 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--82/7 C ORIGINAL VERSION--NOVEMBER 1980. C UPDATED --AUGUST 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHNAME CHARACTER*4 IHNAM2 CHARACTER*4 IUSE CHARACTER*4 IBUGIN C C--------------------------------------------------------------------- C DIMENSION IHNAME(*) DIMENSION IHNAM2(*) DIMENSION IUSE(*) DIMENSION IN(*) DIMENSION IVSTAR(*) DIMENSION IVSTOP(*) DIMENSION IVALUE(*) DIMENSION VALUE(*) 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(IBUGIN.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF INITH2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)NUMNAM,MAXCOL,MAXN,CPUMAX 52 FORMAT('NUMNAM,MAXCOL,MAXN,CPUMAX = ',3I8,E15.7) CALL DPWRST('XXX','BUG ') 90 CONTINUE C NUMNAM=NUMNAM+1 IHNAME(NUMNAM)='PRED' IHNAM2(NUMNAM)=' ' IUSE(NUMNAM)='V' IVALUE(NUMNAM)=MAXCOL+1 VALUE(NUMNAM)=IVALUE(NUMNAM) IN(NUMNAM)=MAXN N=IN(NUMNAM) ICOLVJ=IVALUE(NUMNAM) IVSTAR(NUMNAM)=MAXN*(ICOLVJ-1)+1 IVSTOP(NUMNAM)=MAXN*(ICOLVJ-1)+N C NUMNAM=NUMNAM+1 IHNAME(NUMNAM)='RES' IHNAM2(NUMNAM)=' ' IUSE(NUMNAM)='V' IVALUE(NUMNAM)=MAXCOL+2 VALUE(NUMNAM)=IVALUE(NUMNAM) IN(NUMNAM)=MAXN N=IN(NUMNAM) ICOLVJ=IVALUE(NUMNAM) IVSTAR(NUMNAM)=MAXN*(ICOLVJ-1)+1 IVSTOP(NUMNAM)=MAXN*(ICOLVJ-1)+N C NUMNAM=NUMNAM+1 IHNAME(NUMNAM)='INFI' IHNAM2(NUMNAM)='NITY' IUSE(NUMNAM)='P' VALUE(NUMNAM)=CPUMAX CCCCC ITEMP=2**(NUMBPW-2) CCCCC ITEMP2=ITEMP-1 CCCCC IVALUE(NUMNAM)=ITEMP2+ITEMP IVALUE(NUMNAM)=999999 IN(NUMNAM)=1 C NUMNAM=NUMNAM+1 IHNAME(NUMNAM)='PI ' IHNAM2(NUMNAM)=' ' IUSE(NUMNAM)='P' VALUE(NUMNAM)=3.1415926535898 IVALUE(NUMNAM)=VALUE(NUMNAM) IN(NUMNAM)=1 C NUMNAM=NUMNAM+1 IHNAME(NUMNAM)='YPLO' IHNAM2(NUMNAM)='T ' IUSE(NUMNAM)='V' IVALUE(NUMNAM)=MAXCOL+3 VALUE(NUMNAM)=IVALUE(NUMNAM) IN(NUMNAM)=MAXN N=IN(NUMNAM) ICOLVJ=IVALUE(NUMNAM) IVSTAR(NUMNAM)=MAXN*(ICOLVJ-1)+1 IVSTOP(NUMNAM)=MAXN*(ICOLVJ-1)+N C NUMNAM=NUMNAM+1 IHNAME(NUMNAM)='XPLO' IHNAM2(NUMNAM)='T ' IUSE(NUMNAM)='V' IVALUE(NUMNAM)=MAXCOL+4 VALUE(NUMNAM)=IVALUE(NUMNAM) IN(NUMNAM)=MAXN N=IN(NUMNAM) ICOLVJ=IVALUE(NUMNAM) IVSTAR(NUMNAM)=MAXN*(ICOLVJ-1)+1 IVSTOP(NUMNAM)=MAXN*(ICOLVJ-1)+N C NUMNAM=NUMNAM+1 IHNAME(NUMNAM)='X2PL' IHNAM2(NUMNAM)='OT ' IUSE(NUMNAM)='V' IVALUE(NUMNAM)=MAXCOL+5 VALUE(NUMNAM)=IVALUE(NUMNAM) IN(NUMNAM)=MAXN N=IN(NUMNAM) ICOLVJ=IVALUE(NUMNAM) IVSTAR(NUMNAM)=MAXN*(ICOLVJ-1)+1 IVSTOP(NUMNAM)=MAXN*(ICOLVJ-1)+N C NUMNAM=NUMNAM+1 IHNAME(NUMNAM)='TAGP' IHNAM2(NUMNAM)='LOT ' IUSE(NUMNAM)='V' IVALUE(NUMNAM)=MAXCOL+6 VALUE(NUMNAM)=IVALUE(NUMNAM) IN(NUMNAM)=MAXN N=IN(NUMNAM) ICOLVJ=IVALUE(NUMNAM) IVSTAR(NUMNAM)=MAXN*(ICOLVJ-1)+1 IVSTOP(NUMNAM)=MAXN*(ICOLVJ-1)+N C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** 9000 CONTINUE IF(IBUGIN.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF INITH2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)NUMNAM,MAXCOL,MAXN,CPUMAX 9012 FORMAT('NUMNAM,MAXCOL,MAXN,CPUMAX = ',3I8,E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE INITOD(IBUGIN) C C PURPOSE--THIS IS SUBROUTING INITOD. C (THE OD AT THE END OF INITOD STANDS FOR OUTPUT C THIS SUBROUTINE INITIALIZES OUTPUT DEVICE VARIABLES AND PARAMETER 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--82.6 C ORIGINAL VERSION--SEPTEMBER 1980. C UPDATED --AUGUST 1981. C UPDATED --MARCH 1982. C UPDATED --MAY 1982. C UPDATED --FEBRUARY 1989. SOFT-CODE SETTINGS (ALAN) C UPDATED --FEBRUARY 1989. DEVICE ... OFFSET (ALAN) C UPDATED --FEBRUARY 1989. DEVICE-DEPENDENT COMMON (ALAN) C UPDATED --MARCH 1990. X11 DEVICE COMMON C UPDATED --MAY 1990. DEVICE DEPENDENT COMMON UPDATES C UPDATED --NOVEMBER 1990. POSTSCRIPT MARGINS (ALAN) C UPDATED --JANUARY 1991. DEFINE REGIS COLOR TABLES (ALAN) C UPDATED --MAY 1991. TURBO-C SETTINGS (JJF) C UPDATED --MAY 1991. COSMETIC BLOCKING (JJF) C UPDATED --OCTOBER 1991. ADDED POSTSCRIPT SPACE (ALAN) C UPDATED --MAY 1992. POSTCRIPT INITIAL BLANK PAGE C UPDATED --MAY 1992. ADD IBM/TURBOC COMMENT LINES C UPDATED --MAY 1992. (RE)ADD ICOMLI AND NCOMLI C UPDATED --MAY 1992. IDCODE(.) TO AVOID UNDEF. IN PLOTG2 C UPDATED --JUNE 1992.ICOMLI/NCOMLI => PLOTFC/NPLOTF C UPDATED --JULY 1992.TCPLFI & TCTEFI: OFF => CLOS C UPDATED --SEPTEMBER 1993. DECLARE DUMMY ISUBRO C UPDATED --JUNE 1994. HARDWARE FILL SWITCHES C UPDATED --FEBRUARY 1996. MOVE CALL TCINCO BACK TO MAIN C UPDATED --JULY 1996. LAHEY DEVICE DRIVER C UPDATED --JULY 1996. DEVICE ... FONT C UPDATED --NOVEMBER 1996. MICROSOFT QWIN DEVICE DRIVER C UPDATED --APRIL 1997. CHANGE IX11PM DEFAULT C UPDATED --APRIL 1997. ADD DPCOPM C UPDATED --OCTOBER 1997. IX11W2 C UPDATED --DECEMBER 1997. IGENFA C UPDATED --FEBRUARY 1998. IPRNTR C UPDATED --MARCH 2002. SVG DEVICE C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IBUGIN C CCCCC THE FOLLOWING LINE WAS ADDED SEPTEMBER 1993 CHARACTER*4 ISUBRO C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCOSU.INC' INCLUDE 'DPCOPC.INC' INCLUDE 'DPCODV.INC' INCLUDE 'DPCOST.INC' CCCCC THE FOLLOWING INCLUDE STATEMENT WAS INSERTED FEBRUARY 1989 INCLUDE 'DPCOGR.INC' CCCCC THE FOLLOWING INCLUDE STATEMENT WAS INSERTED 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 CCCCC THE FOLLOWING LINE WAS ADDED SEPTEMBER 1993 CCCCC TO ALLOW AN ARGUMENT MATCH SEPTEMBER 1993 CCCCC IN THE CALL TO TCINCO(ISUBRO) SEPTEMBER 1993 ISUBRO='DUMM' C IF(IBUGIN.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF INITOD--') CALL DPWRST('XXX','BUG ') 90 CONTINUE C C **************************************** C ** TREAT THE NUMBER OF DEVICES CASE ** C **************************************** C CCCCC THE FOLLOWING SINGLE LINE FIX WAS INSERTED FEBRUARY 1989 CCCCC MAXDEV=10 MAXDEV=MAXDV NUMDEV=1 C C ********************************************** C ** TREAT THE DEVICE ... MANUFACTURER CASE ** C ********************************************** C IDEFMA='TEKT' IDEFMO='4014' IDEFM2=' ' IDEFM3=' ' C DO1110I=1,MAXDEV IDMANU(I)=' ' IDMODE(I)=' ' IDMOD2(I)=' ' IDMOD3(I)=' ' 1110 CONTINUE C IDMANU(1)=IDEFMA IDMODE(1)=IDEFMO IDMOD2(1)=IDEFM2 IDMOD3(1)=IDEFM3 C C ************************************** C ** TREAT THE DEVICE ... POWER CASE ** C ************************************** C IDEFPO='ON' C DO1210I=1,MAXDEV IDPOWE(I)='OFF' 1210 CONTINUE C IDPOWE(1)=IDEFPO C C ******************************************** C ** TREAT THE DEVICE ... CONTINUOUS CASE ** C ******************************************** C IDEFCN='ON' C DO1310I=1,MAXDEV IDCONT(I)='ON' 1310 CONTINUE C IDCONT(1)=IDEFCN C C ******************************************** C ** TREAT THE DEVICE ... COLOR CASE ** C ******************************************** C IDEFDC='OFF' C DO1410I=1,MAXDEV IDCOLO(I)='OFF' 1410 CONTINUE C IDCOLO(1)=IDEFDC C C ************************************************* C ** TREAT THE DEVICE ... PICTURE POINTS CASE ** C ************************************************* C IDEFVP=3124 IDEFHP=4096 CCCCC IDEFVP=781 CCCCC IDEFHP=1024 C DO1510I=1,MAXDEV IDNVPP(I)=(-999) IDNHPP(I)=(-999) 1510 CONTINUE C IDNVPP(1)=IDEFVP IDNHPP(1)=IDEFHP C C ******************************************** C ** TREAT THE DEVICE ... UNIT NUMBER CASE ** C ******************************************** C CCCCC IDEFUN=6 CCCCC THE FOLLOWING SINGLE LINE FIX WAS INSERTED FEBRUARY 1989 CCCCC IDEFUN=IPR IDEFUN=IPRGR C DO1610I=1,MAXDEV IDUNIT(I)=IDEFUN CCCCC THE FOLLOWING LINE WAS ADDED TO AVOID PLOTG2 UNDEFINED ERROR MAY 1992 CCCCC THE FOLLOWING LINE WAS CHANGED FROM CHAR TO INT OCTOBER 1992 CCCCC IDCODE(I)='JUNK' IDCODE(I)=0 1610 CONTINUE C C ************************************************************** C ** TREAT THE DEVICE ... OFFSET CASE FEBRUARY 1989 ** C ************************************************************** C CCCCC IDEFUN=6 IDEFOV=0 IDEFOH=0 C DO1620I=1,MAXDEV IDNVOF(I)=IDEFOV IDNHOF(I)=IDEFOH 1620 CONTINUE C C ******************************************** C ** TREAT THE DEVICE ... BAUD RATE CASE ** C ******************************************** C IDEFBA=1200 C DO1710I=1,MAXDEV IDBAUD(I)=IDEFBA 1710 CONTINUE CCCCC ADD FOLLOWING SECTION JULY 1996. C C ******************************************** C ** TREAT THE DEVICE ... FONT CASE ** C ******************************************** C IDEFFN='OFF' C DO1810I=1,MAXDEV IDFONT(I)=IDEFFN 1810 CONTINUE C C ******************************************** C ** TREAT THE HARDCOPY CASE ** C ******************************************** C ICOPSW='OFF' NUMCOP=1 C C ******************************************** C ** TREAT THE SET PRINTER CASE ** C ******************************************** C IPRNTR=' ' NCPRNT=0 C C ********************************************* C ** TREAT THE FILE CASE ** C ** (FILE, CALCOMP, VERSATEC, ZETA, ETC.) ** C ********************************************* C C ******************************* C ** TREAT THE METAFILE CASE ** C ******************************* C C ************************************************************** C ** TREAT THE DEVICE-DEPENDENT COMMON CASE FEBRUARY 1989 ** C ************************************************************** C C----------CALCOMP---------- C ICALSW='OFF' ICALCL=4 ICALCC=-999 PCALTH=0.05 C FOLLOWING LINES ADDED FOR CALCOMP MAY, 1990. ICALPF='OFF' ICALPM(1)='BLAC' ICALPM(2)='RED' ICALPM(3)='BLUE' ICALPM(4)='GREE' ICALPM(5)='BLAC' ICALPM(6)='RED' ICALPM(7)='BLUE' ICALPM(8)='GREE' ICALPM(9)='BLAC' ICALPM(10)='RED' ICALPM(11)='BLUE' ICALPM(12)='GREE' ICALPM(13)='BLAC' ICALPM(14)='RED' ICALPM(15)='BLUE' ICALPM(16)='GREE' C CCCCC ADD LAHEY DEVICE INITIALIZATION JULY 1996. C----------CALCOMP---------- C ILAHSW='OFF' ILAHPA='OFF' ILAHGR='DIRE' ILAHCL='OFF' ILAHSW='OFF' ILAHNC=8 ILAHCC=-999 PLAHTH=0.05 C FOLLOWING LINES ADDED FOR LAHCOMP MAY, 1990. ILAHPF='OFF' ILAHPM(1)='BLAC' ILAHPM(2)='RED' ILAHPM(3)='BLUE' ILAHPM(4)='GREE' ILAHPM(5)='BLAC' ILAHPM(6)='RED' ILAHPM(7)='BLUE' ILAHPM(8)='GREE' ILAHPM(9)='BLAC' ILAHPM(10)='RED' ILAHPM(11)='BLUE' ILAHPM(12)='GREE' ILAHPM(13)='BLAC' ILAHPM(14)='RED' ILAHPM(15)='BLUE' ILAHPM(16)='GREE' C CCCCC ADD MICROSOFT QWIN DEVICE INITIALIZATION NOVEMBER 1996. C----------QUICK-WIN---------- C IQWNF2=15 IQWNBC=0 IQWNFC='TEXT' CCCCC MARCH 2002: SET COLOR MODE IN MSFORT.F (ALLOW TO BE SET CCCCC VIA COMMAND LINE ARGUMENT CCCCC IQWNCL='VGA' IQWNFZ='COURIER' IQWNPF='OFF' IQWNPM(1)='BLAC' IQWNPM(2)='RED' IQWNPM(3)='BLUE' IQWNPM(4)='GREE' IQWNPM(5)='BLAC' IQWNPM(6)='RED' IQWNPM(7)='BLUE' IQWNPM(8)='GREE' IQWNPM(9)='BLAC' IQWNPM(10)='RED' IQWNPM(11)='BLUE' IQWNPM(12)='GREE' IQWNPM(13)='BLAC' IQWNPM(14)='RED' IQWNPM(15)='BLUE' IQWNPM(16)='GREE' C CCCCC ADD LAHEY WINTERACTOR DEVICE INITIALIZATION NOVEMBER 1996. C----------QUICK-WIN---------- C IWINFN='FIXE' IWINCL='RGB' IWINHP=600 IWINVP=450 C C----------ZETA---------- C IZETSW='OFF' IZETCL=4 IZETCC=-999 PZETTH=0.05 C FOLLOWING LINES ADDED FOR ZETA MAY, 1990. IZETPF='OFF' IZETPM(1)='BLAC' IZETPM(2)='RED' IZETPM(3)='BLUE' IZETPM(4)='GREE' IZETPM(5)='BLAC' IZETPM(6)='RED' IZETPM(7)='BLUE' IZETPM(8)='GREE' IZETPM(9)='BLAC' IZETPM(10)='RED' IZETPM(11)='BLUE' IZETPM(12)='GREE' IZETPM(13)='BLAC' IZETPM(14)='RED' IZETPM(15)='BLUE' IZETPM(16)='GREE' C C----------HP PCL---------- C IPCLLM=60 IPCLRM=60 IPCLTM=50 IPCLBM=100 IPC2LM=50 IPC2RM=100 IPC2TM=60 IPC2BM=60 PCLPPI=300. IPCLFN='COUR' IPCLFC='COUR' C C----------QUIC---------- C IQUILM=85 IQUIRM=25 IQUITM=100 IQUIBM=25 IQU2LM=70 IQU2RM=25 IQU2TM=60 IQU2BM=25 QUIPPI=300. IQUIFN=10 IQUIFC=10 C C----------POSTSCRIPT---------- C PSTPPI=300. C NOVEMBER, 1990. MARGIN DEFAULTS CHANGED (PREVIOUSLY HARDCODED TO 75, SET C TO 1/4 INCH PLUS A SMALL FUDGE FACTOR). IDEFMG=INT(PSTPPI/4.0)+10 IPSTLM=IDEFMG IPSTRM=IDEFMG IPSTTM=IDEFMG IPSTBM=IDEFMG IPS2LM=IDEFMG IPS2RM=IDEFMG IPS2TM=IDEFMG IPS2BM=IDEFMG CCCCC IPSTFN='TROM' CCCCC IPSTFC='TROM' CCCCC ABOVE TWO LINES FIXED JULY 1989 IPSTFN='HELB' IPSTFC='HELB' IPSTPS=12 IPSTPC=12 CCCCC JUNE 1994. FOLLOWING LINE ADDED. IPSTFS='ON' C FOLLOWING LINES ADDED OCTOBER 1991 C MAKE POSTSCRIPT FONTS TABLE DRIVEN FOR EASIER UPDATING IPSTSP='OFF' IPSTMF=34 IPSTT1( 1)='TROM' IPSTT2( 1)='Times-Roman' IPSTT1( 2)='TITA' IPSTT2( 2)='Times-Italic' IPSTT1( 3)='TBOL' IPSTT2( 3)='Times-Bold' IPSTT1( 4)='TBIT' IPSTT2( 4)='Times-BoldItalic' IPSTT1( 5)='HELV' IPSTT2( 5)='Helvetica' IPSTT1( 6)='HELO' IPSTT2( 6)='Helvetica-Oblique' IPSTT1( 7)='HELB' IPSTT2( 7)='Helvetica-Bold' IPSTT1( 8)='HEBO' IPSTT2( 8)='Helvetica-BoldOblique' IPSTT1( 9)='COUR' IPSTT2( 9)='Courier' IPSTT1(10)='COBL' IPSTT2(10)='Courier-Oblique' IPSTT1(11)='CBOL' IPSTT2(11)='Courier-Bold' IPSTT1(12)='CBOB' IPSTT2(12)='Courier-BoldOblique' IPSTT1(13)='AGBK' IPSTT2(13)='AvantGarde-Book' IPSTT1(14)='AGBO' IPSTT2(14)='AvantGarde-BookOblique' IPSTT1(15)='AGDE' IPSTT2(15)='AvantGarde-Demi' IPSTT1(16)='AGDO' IPSTT2(16)='AvantGarde-DemiOblique' IPSTT1(17)='BKDE' IPSTT2(17)='Bookman-Demi' IPSTT1(18)='BKDI' IPSTT2(18)='Bookman-DemiItalic' IPSTT1(19)='BKLT' IPSTT2(19)='Bookman-Light' IPSTT1(20)='BKLI' IPSTT2(20)='Bookman-LightItalic' IPSTT1(21)='HELN' IPSTT2(21)='Helvetica-Narrow' IPSTT1(22)='HENB' IPSTT2(22)='Helvetica-Narrow-Bold' IPSTT1(23)='HNBO' IPSTT2(23)='Helvetica-Narrow-BoldOblique' IPSTT1(24)='HENO' IPSTT2(24)='Helvetica-Narrow-Oblique' IPSTT1(25)='NCSR' IPSTT2(25)='NewCenturySchlbk-Roman' IPSTT1(26)='NCSB' IPSTT2(26)='NewCenturySchlbk-Bold' IPSTT1(27)='NCSI' IPSTT2(27)='NewCenturySchlbk-Italic' IPSTT1(28)='CSBI' IPSTT2(28)='NewCenturySchlbk-BoldItalic' IPSTT1(29)='PALR' IPSTT2(29)='Palatino-Roman' IPSTT1(30)='PALB' IPSTT2(30)='Palatino-Bold' IPSTT1(31)='PALI' IPSTT2(31)='Palatino-Italic' IPSTT1(32)='PABI' IPSTT2(32)='Palatino-BoldItalic' IPSTT1(33)='ZAPF' IPSTT2(33)='ZapfChancery-MediumItalic' IPSTT1(34)='SYMB' IPSTT2(34)='Symbol' DO910I=IPSTMF+1,100 IPSTT1(I)=' ' IPSTT2(I)=' ' 910 CONTINUE C END OF CHANGE CCCCC THE FOLLOWING LINE WAS ADDED MAY 1992 (JJF) CCCCC SEE ALSO DPCODV.INC MAY 1992 IPSTBP='OFF' C C----------SUN---------- C CCCCC IVSNAM=0 ISUNCL=0 PSUNTH=0.1 C C----------CGM---------- C ICGMSW='OFF' C C----------GENERAL---------- C IGENFA=1 C C C----------DEC REGIS---------- C PREGTH=0.1 CCCCC ABOVE COLOR DEFINITIONS FOR REGIS ADDED JANUARY, 1991. IRGHUE(1)= 260 IRGHUE(2)= 280 IRGHUE(3)= 0 IRGHUE(4)= 0 IRGHUE(5)= 300 IRGHUE(6)= 0 IRGHUE(7)= 40 IRGHUE(8)= 300 IRGHUE(9)= 0 IRGHUE(10)= 0 IRGHUE(11)= 30 IRGHUE(12)= 0 IRGHUE(13)= 0 IRGHUE(14)=320 IRGHUE(15)=330 IRGHUE(16)=320 IRGHUE(17)=150 IRGHUE(18)=300 IRGHUE(19)=120 IRGHUE(20)=160 IRGHUE(21)=180 IRGHUE(22)=180 IRGHUE(23)=240 IRGHUE(24)=240 IRGHUE(25)=180 IRGHUE(26)=240 IRGHUE(27)=240 IRGHUE(28)=200 IRGHUE(29)=240 IRGHUE(30)=210 IRGHUE(31)=240 IRGHUE(32)=280 IRGHUE(33)=270 IRGHUE(34)=200 IRGHUE(35)=300 IRGHUE(36)= 0 IRGHUE(37)= 0 IRGHUE(38)=180 IRGHUE(39)= 60 IRGHUE(40)= 80 IRGHUE(41)=120 IRGHUE(42)= 60 IRGHUE(43)= 40 IRGHUE(44)= 20 IRGHUE(45)=120 IRGHUE(46)= 60 IRGHUE(47)=120 IRGHUE(48)=120 IRGHUE(49)=100 IRGHUE(50)= 90 IRGHUE(51)= 80 IRGHUE(52)=120 IRGHUE(53)=160 IRGHUE(54)=140 IRGHUE(55)= 60 IRGHUE(56)=300 IRGHUE(57)=340 IRGHUE(58)=300 IRGHUE(59)= 60 IRGHUE(60)= 60 IRGHUE(61)=180 IRGHUE(62)= 0 IRGHUE(63)=180 IRGHUE(64)=220 IRGLGT(1)= 65 IRGLGT(2)= 50 IRGLGT(3)= 0 IRGLGT(4)= 50 IRGLGT(5)= 50 IRGLGT(6)= 35 IRGLGT(7)= 35 IRGLGT(8)= 80 IRGLGT(9)= 65 IRGLGT(10)= 50 IRGLGT(11)= 50 IRGLGT(12)= 25 IRGLGT(13)= 35 IRGLGT(14)= 50 IRGLGT(15)= 50 IRGLGT(16)= 35 IRGLGT(17)= 50 IRGLGT(18)= 50 IRGLGT(19)= 35 IRGLGT(20)= 50 IRGLGT(21)= 65 IRGLGT(22)= 80 IRGLGT(23)= 50 IRGLGT(24)= 25 IRGLGT(25)= 25 IRGLGT(26)= 35 IRGLGT(27)= 50 IRGLGT(28)= 35 IRGLGT(29)= 35 IRGLGT(30)= 50 IRGLGT(31)= 65 IRGLGT(32)= 35 IRGLGT(33)= 50 IRGLGT(34)= 50 IRGLGT(35)= 25 IRGLGT(36)= 33 IRGLGT(37)= 66 IRGLGT(38)= 50 IRGLGT(39)= 50 IRGLGT(40)= 35 IRGLGT(41)= 50 IRGLGT(42)= 65 IRGLGT(43)= 50 IRGLGT(44)= 65 IRGLGT(45)= 65 IRGLGT(46)= 80 IRGLGT(47)= 50 IRGLGT(48)= 25 IRGLGT(49)= 65 IRGLGT(50)= 50 IRGLGT(51)= 50 IRGLGT(52)= 35 IRGLGT(53)= 35 IRGLGT(54)= 65 IRGLGT(55)= 80 IRGLGT(56)= 80 IRGLGT(57)= 65 IRGLGT(58)= 65 IRGLGT(59)= 25 IRGLGT(60)= 50 IRGLGT(61)= 80 IRGLGT(62)= 99 IRGLGT(63)= 50 IRGLGT(64)= 65 IRGSAT(1)= 60 IRGSAT(2)= 60 IRGSAT(3)= 0 IRGSAT(4)= 100 IRGSAT(5)= 25 IRGSAT(6)= 25 IRGSAT(7)= 60 IRGSAT(8)= 25 IRGSAT(9)= 25 IRGSAT(10)= 60 IRGSAT(11)=100 IRGSAT(12)= 25 IRGSAT(13)= 60 IRGSAT(14)= 60 IRGSAT(15)=100 IRGSAT(16)= 60 IRGSAT(17)=100 IRGSAT(18)=100 IRGSAT(19)= 60 IRGSAT(20)= 60 IRGSAT(21)= 60 IRGSAT(22)= 60 IRGSAT(23)=100 IRGSAT(24)= 25 IRGSAT(25)= 25 IRGSAT(26)= 60 IRGSAT(27)= 60 IRGSAT(28)= 60 IRGSAT(29)= 25 IRGSAT(30)=100 IRGSAT(31)= 25 IRGSAT(32)= 60 IRGSAT(33)=100 IRGSAT(34)= 60 IRGSAT(35)= 25 IRGSAT(36)= 0 IRGSAT(37)= 0 IRGSAT(38)= 25 IRGSAT(39)=100 IRGSAT(40)= 60 IRGSAT(41)= 60 IRGSAT(42)= 60 IRGSAT(43)= 60 IRGSAT(44)= 60 IRGSAT(45)= 25 IRGSAT(46)= 60 IRGSAT(47)=100 IRGSAT(48)= 25 IRGSAT(49)= 60 IRGSAT(50)=100 IRGSAT(51)= 60 IRGSAT(52)= 25 IRGSAT(53)= 60 IRGSAT(54)= 60 IRGSAT(55)= 25 IRGSAT(56)= 60 IRGSAT(57)= 60 IRGSAT(58)= 60 IRGSAT(59)= 25 IRGSAT(60)= 25 IRGSAT(61)= 25 IRGSAT(62)= 0 IRGSAT(63)=100 IRGSAT(64)= 60 C C VT-240 ALLOWS 4 ACTIVE COLOR MAPS. RESERVE 0 FOR THE BACKGROUND COLOR C AND 1-3 FOR THE FOREGROUND COLORS. I DON'T HAVE ANY VT-340 DOCUMENTATION C SO NOT SURE IF VT-340 ALLOWS MORE. FOR NOW, SET MAXIMUM FOREGROUND COLORS C TO 3 (AND SET DEFAULT TO WHITE, YELLOW, AND RED (BACKGROUND IS BLUE). C NOTE: 340 ALLOWS 16 COLORS (BUT ONE RESERVED FOR BACKGROUND). C IREGMC=3 IREGPM(1)=62 IREGPM(2)=63 IREGPM(3)=47 IREGPM(4)=3 IREGPM(5)=23 IREGPM(6)=18 IREGPM(7)=4 IREGPM(8)=41 IREGPM(9)=59 IREGPM(10)=39 IREGPM(11)=64 IREGPM(12)=54 IREGPM(13)=20 IREGPM(14)=51 IREGPM(15)=37 IREGPM(16)=35 C END CHANGE C C----------HP 2622------------ C P262TH=0.1 C C----------HP 7221------------ C P722TH=0.1 C C----------HP-GL-------------- C PHPGTH=0.1 C ADDED FOLLOWING LINES FOR HP MAY, 1990. IHPGSW='OFF' IHPGPF='OFF' IHPGCL=4 IHPGPM(1)='BLAC' IHPGPM(2)='RED' IHPGPM(3)='BLUE' IHPGPM(4)='GREE' IHPGPM(5)='BLAC' IHPGPM(6)='RED' IHPGPM(7)='BLUE' IHPGPM(8)='GREE' IHPGPM(9)='BLAC' IHPGPM(10)='RED' IHPGPM(11)='BLUE' IHPGPM(12)='GREE' IHPGPM(13)='BLAC' IHPGPM(14)='RED' IHPGPM(15)='BLUE' IHPGPM(16)='GREE' C C----------TEKTRONIX---------- C PTEKTH=0.1 C C----------GENERAL------------ C C ADDED FOLLOWING LINES JANUARY, 1990 (PREVIOUSLY DONE IN MAIN) CCCCC JANUARY 1995. MODIFY DEFAULT FOR FRONTEND CCCCC IJUSSW='OFF' IJUSSW='ON' IRFLSW='OFF' IFNTSW='OFF' IPTHSW='OFF' PPENSW=0.1 C C----------X11 CASE----------- C C ADDED FOLLOWING LINES MARCH, 1990 FOR X11 IX11CS='BUTT' IX11JS='MITER' CCCCC CHANGE DEFAULT. APRIL 1997 CCCCC IX11PM='OFF' IX11PM='ON' IX11FN='8X13' IX11OF='OFF' IX11PA='OFF ' IX11DN='DEFAULT' CCCCC JUNE 1994. FOLLOWING LINE ADDED. IX11FS='ON' C CCCCC ADD FOLLOWING SECTION. APRIL 1997 NUMPXM=0 ICURPM=0 IPXMFL='OFF' IPXMFB='pixmap.' IPXMNC=7 DO1010I=1,MAXPM IPXMFN(I)=' ' IPXMCM(I)=' ' 1010 CONTINUE CCCCC ADD FOLLOWING SECTION. OCTOBER 1997 IX11W2=' ' C C----------TURBO-C FOR IBM-PC------------- C CCCCC THE INITIALIZATION OF THE TURBO-C DRIVER FOR IBM-PC MAY 1993 CCCCC WAS MOVED TO TCINCO.FOR WITHIN TCDRIV.FOR MAY 1993 CCCCC THE CALL TO TCINCO WAS MOVED BACK TO MAIN FEBRUARY 1996 CCCCC CALL TCINCO(ISUBRO) C CCCCC ADD LAHEY WINTERACTOR DEVICE INITIALIZATION NOVEMBER 1996. C C----------SVG (SCALABLE VECTOR GRAPHICS)------ C ISVGOS='OFF' ISVGCS='PIXE' ISVGCA='BUTT' ISVGJS='MITE' ISVGFS='NONZ' ISVGSS='INTE' ISVGST='norm' ISVGFW='bold' ISVGFN='sans-serif' ISVGSS='INTE' ISVGSN='dataplot.css' ISVGCN=0 C C----------LATEX------------------------------- C ILATOS='OFF' ILATCO='OFF' ILATFS='OFF' ILATLT='HARD' C C ******************************* C ** EXIT AND RETURN TO MAIN ** C ******************************* C 9000 CONTINUE IF(IBUGIN.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF INITOD--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)MAXDEV,NUMDEV 9012 FORMAT('MAXDEV,NUMDEV = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IDEFMA,IDEFMO,IDEFM2,IDEFM3 9013 FORMAT('IDEFMA,IDEFMO,IDEFM2,IDEFM3 = ',A4,2X,A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)IDEFPO,IDEFCN,IDEFDC 9014 FORMAT('IDEFPO,IDEFCN,IDEFDC = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)IDEFVP,IDEFHP,IDEFUN 9015 FORMAT('IDEFVP,IDEFHP,IDEFUN = ',3I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)ICOPSW,NUMCOP 9016 FORMAT('ICOPSW,NUMCOP = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9017)IDMANU(1) 9017 FORMAT('IDMANU(1) = ',A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE INITSU(IBUGIN) C C PURPOSE--THIS IS SUBROUTING INITSU. C (THE SU AT THE END OF INITSU STANDS FOR SUPPORT C THIS SUBROUTINE INITIALIZES SUPPORT VARIABLES AND PARAMETERS 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--82.6 C ORIGINAL VERSION--NOVEMBER 1980. C UPDATED --MARCH 1981. C UPDATED --AUGUST 1981. C UPDATED --MAY 1982. C UPDATED --MAY 1990. COMMENT CHARACTER C UPDATED --AUGUST 1992. VECTOR PLOT PARAMETERS C UPDATED --OCTOBER 1992. CHANGE ICOMFL TO ICOMSW C UPDATED --NOVEMBER 1992. ANDREWS PLOT PARAM. (ALAN) C UPDATED --MAY 1993. MINMAX FOR EV1/EV2/WEIB DIST. C UPDATED --JULY 1993. FRACTAL ITERATIONS, FRACTAL C TYPE, PRINCIPLE COMPONENT TYPE C UPDATED --JANUARY 1994. WEIB MINMAX TO DPCOS2.INC C UPDATED --FEBRUARY 1994. DEFAULT FOR FITSD C UPDATED --JUNE 1994. OPTIMIZATION TOLERANCE C UPDATED --FEBRUARY 1995. OPTIMIZATION METHOD C UPDATED --JULY 1995. FIT ADDITIVE CONSTANT C UPDATED --APRIL 1997. SET NETSCAPE C UPDATED --APRIL 1997. SET CONTROL CHART C UPDATED --APRIL 1997. SET CONTROL CHART WEIGHT
C UPDATED --AUGUST 1997. 3 SWITCHES FOR RECIPE C UPDATED --APRIL 1998. RECIPE FIT FACTORS C UPDATED --MAY 1998. KAPLAN-MEIER C UPDATED --MAY 1998. CENSORING TYPE <1/2> C UPDATED --JUNE 1998. MATRIX SCALE C UPDATED --SEPTEMBER 1998. PERCENT POINT PLOT BINNED/UNBINNED C UPDATED --SEPTEMBER 1998. QUANTILE-QUANTILE PLOT BINNED/UNBINNED C UPDATED --MARCH 1999. SET WEB HANDBOOK C UPDATED --SEPTEMBER 1999. SET SCATTER PLOT MATRIX OPTIONS C UPDATED --NOVEMBER 1999. SET PARAMETER EXPANSION OPTION C UPDATED --JANUARY 2000. SET SORT DIRECTION C UPDATED --OCTOBER 2000. SET MANDEL PAULE C UPDATED --MARCH 2001. SET SUPERSCRIPT HORI SCALE C UPDATED --MARCH 2001. SET SUPERSCRIPT VERT SCALE C UPDATED --APRIL 2001. SET ORTHOGONAL DISTANCE C TRUST REGION RADIUS C UPDATED --APRIL 2001. SET ORTHOGONAL DISTANCE C STOP TOLERANCE C UPDATED --APRIL 2001. SET ORTHOGONAL DISTANCE C PARAMETER TOLERANCE C UPDATED --APRIL 2001. SET ORTHOGONAL DISTANCE C PRINT OPTION C UPDATED --JULY 2001. SET KERNEL DENSITY OPTIONS C UPDATED --MARCH 2002. SET BOX PLOT WIDTH C UPDATED --MAY 2002. SET RANDOM NUMBER GENERATOR C UPDATED --JUNE 2002. SET NUMBER OF CP C UPDATED --JUNE 2002. ICAPTY C UPDATED --JULY 2002. SET COVARIANCE TYPE C UPDATED --JULY 2002. SET CORRELATION TYPE C UPDATED --JULY 2002. SET FILE TYPE QUOTE C UPDATED --JULY 2002. SET BOOTSTRAP FIT METHOD C UPDATED --NOVEMBER 2002. SET QWIN SYSTEM C UPDATED --NOVEMBER 2002. SET GHOSTVIEW PRINTER ON C UPDATED --NOVEMBER 2002. SET GHOSTVIEW PATH C UPDATED --JANUARY 2003. SET GHOSTSCRIPT PATH C UPDATED --JANUARY 2003. SET POSTSCRIPT BOUNDING BOX C UPDATED --JANUARY 2003. SET POSTSCRIPT CONVERT C UPDATED --JANUARY 2003. SET HTML HEADER FILE C UPDATED --JANUARY 2003. SET HTML FOOTER FILE C UPDATED --FEBRUARY 2003. SET MAXIMUM RECORD LENGTH C UPDATED --FEBRUARY 2003. SET AUTOCOREELATION LAG ZERO C UPDATED --MARCH 2003. SET PARALLEL COORDINATES C STANDARDIZE C UPDATED --MARCH 2003. SET BOOTSTRAP GROUPS C UPDATED --SEPTEMBER 2003. SET TABLE TITLE C UPDATED --SEPTEMBER 2003. SET TABLE BORDER C UPDATED --SEPTEMBER 2003. SET TABLE SPACING C UPDATED --SEPTEMBER 2003. SET TABLE WIDTH C UPDATED --SEPTEMBER 2003. SET TABLE HEIGHT C UPDATED --JANUARY 2004. SET READ VARIABLE LABEL C UPDATED --JANUARY 2004. SET CONVERT CHARACTER C UPDATED --JANUARY 2004. SET READ DELIMITER C UPDATED --JANUARY 2004. SET READ MISSING VALUE C UPDATED --JUNE 2004. SET DEFAULT POSTSCRIPT COLOR C UPDATED --JUNE 2004. SET ASYMMETRIC LAPLACE C DEFINITION C UPDATED --JULY 2004. SET GOMPERTZ-MAKEHAM C DEFINITION C UPDATED --AUGUST 2004. GIVE MINMAX DEFAULT VALUE C UPDATED --AUGUST 2004. SET BESSEL I FUNCTION C DEFINITION C UPDATED --AUGUST 2004. SET BESSEL K FUNCTION C DEFINITION C UPDATED --SEPTEMBER 2004. SET PROBABILITY PLOT DATA C POINTS C UPDATED --SEPTEMBER 2004. SET PPCC PLOT DATA POINTS C UPDATED --SEPTEMBER 2004. SET PPCC PLOT AXIS POINTS C UPDATED --SEPTEMBER 2004. SET PPCC PLOT AXIS ORDER C UPDATED --SEPTEMBER 2004. SET HISTOGRAM CLASS WIDTH C UPDATED --SEPTEMBER 2004. SET ASH WEIGHTING C UPDATED --OCTOBER 2004. SET READ PAD MISSING COLUMNS C UPDATED --OCTOBER 2004. SET READ SUBSET C UPDATED --OCTOBER 2004. SET CENSORED PROBABILITY PLOT C UPDATED --OCTOBER 2004. SET CENSORED PPCC PLOT C UPDATED --OCTOBER 2004. SET MAXIMUM LIKELIHOOD PERCENTILES C UPDATED --OCTOBER 2004. SET EXPONENTIAL BIAS CORRECTED C UPDATED --NOVEMBER 2004. SET WEIBULL BIAS CORRECTED C UPDATED --NOVEMBER 2004. SET GUMBELL BIAS CORRECTED C UPDATED --NOVEMBER 2004. SET MATRIX CORRELATION DIRECTION C UPDATED --NOVEMBER 2004. SET MATRIX COVARIANCE DIRECTION C UPDATED --DECEMBER 2004. SET GUI C UPDATED --DECEMBER 2004. SET MAXIMUM LIKELIHOOD RELIABILITY C UPDATED --FEBRUARY 2005. SET DISTRIBUTIONAL BOOTSTRAP C UPDATED --FEBRUARY 2005. SET RTF POINT SIZE C UPDATED --FEBRUARY 2005. SET RTF FIXED FONT C UPDATED --FEBRUARY 2005. SET RTF PROPORTIONAL FONT C UPDATED --MARCH 2005. SET LINE PRINTER COLUMNS C UPDATED --APRIL 2005. SET DECIMAL POINT C UPDATED --APRIL 2005. SET PEAKS OVER THRESHOLD C METHOD C UPDATED --APRIL 2005. SET PEAKS OVER THRESHOLD C DISTRIBUTION C UPDATED --APRIL 2005. SET PEAKS OVER THRESHOLD C ITERATIONS C UPDATED --APRIL 2005. SET PEAKS OVER THRESHOLD C NUMBER POINTS C UPDATED --APRIL 2005. SET PEAKS OVER THRESHOLD C INITIAL THRESHOLD C UPDATED --APRIL 2005. SET PEAKS OVER THRESHOLD C INCREMENT C UPDATED --APRIL 2005. SET PEAKS OVER THRESHOLD C PERIOD C UPDATED --APRIL 2005. SET PEAKS OVER THRESHOLD C TOLERANCE C UPDATED --APRIL 2005. SET PEAKS OVER THRESHOLD C LOAD FACTOR C UPDATED --APRIL 2005. SET PEAKS OVER THRESHOLD C X AXIS C UPDATED --MAY 2005. SET FRECHET BIAS CORRECTION C UPDATED --JULY 2005. SET LOG GAMMA DEFINITION C UPDATED --JULY 2005. SET SKEW NORMAL DEFINITION C UPDATED --SEPTEMBER 2005. IMACSC C UPDATED --SEPTEMBER 2005. NMACAG C UPDATED --SEPTEMBER 2005. IMACAR C UPDATED --JANUARY 2006. ICAPSC C UPDATED --FEBRUARY 2006. IGLDDF C UPDATED --MAY 2006. IPPCBW C UPDATED --MAY 2006. IBGEDF C UPDATED --JUNE 2006. IFORFM C UPDATED --JUNE 2006. 10 SWITCHES FOR CONSENSUS C MEAN (IMPACM - IFAICM) C UPDATED --JULY 2006. IGETDF C UPDATED --JULY 2006. PCHSLM C UPDATED --AUGUST 2006. ICONDF C UPDATED --OCTOBER 2006. I4PLDI C UPDATED --OCTOBER 2006. PMAXLO C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IBUGIN C C--------------------------------------------------------------------- C C-----COMMON---------------------------------------------------------- C CHARACTER*1 IBASLC C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCOMC.INC' INCLUDE 'DPCOHK.INC' INCLUDE 'DPCODG.INC' INCLUDE 'DPCOSU.INC' CCCCC THE FOLLOWING LINE (FOR WEIBULL MINMAX) WAS ADDED JANUARY 1994 INCLUDE 'DPCOS2.INC' INCLUDE 'DPCOGR.INC' CCCCC THE FOLLOWING LINE (FOR SET NETSCAPE) WAS ADDED APRIL 1997 INCLUDE 'DPCOST.INC' INCLUDE 'DPCOHO.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IF(IBUGIN.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55) 55 FORMAT('***** AT THE BEGINNING OF INITSU--') CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ****************************** C ** TREAT THE ADD CASE ** C ** TREAT THE CALL CASE ** C ** TREAT THE EXECUTE CASE ** C ** TREAT THE RUN CASE ** C ****************************** C C C **************************** C ** TREAT THE ANGLE CASE ** C **************************** C THESE HAVE BEEN COMMENTED OUT BECAUSE C THE ANGLE WILL BE SET IN SUBROUTINE INITDG C CCCCC DEFANG=0.0 CCCCC ANGLE=DEFANG C C ********************************** C ** TREAT THE ANGLE UNITS CASE ** C ********************************** C THESE HAVE BEEN COMMENTED OUT BECAUSE C THE ANGLE UNITS WILL BE SET IN SUBROUTINE INITDG C CCCCC IDEANU='RADI' CCCCC IANGLU=IDEANU C C *************************** C ** TREAT THE BAUD CASE ** C *************************** C CCCCC IDEFBA=1200 C IDEFBA IS SET IN SUBROUTINE INITOD C BECAUSE MAININ CALLS INITOD BEFORE CALLING INITSU IBAUD=IDEFBA IGBAUD=IBAUD C C ************************************** C ** TREAT THE CLASS ... LOWER CASE ** C ************************************** C CLLIMI(1)=CPUMIN CLLIMI(3)=CPUMIN C C ************************************** C ** TREAT THE CLASS ... UPPER CASE ** C ************************************** C CLLIMI(2)=CPUMAX CLLIMI(4)=CPUMAX C C ************************************** C ** TREAT THE CLASS ... WIDTH CASE ** C ************************************** C CLWIDT(1)=CPUMIN CLWIDT(2)=CPUMIN C C ******************************************** C ** TREAT THE MAXIMUM RECORD LENGTH CASE ** C ** NOTE: THIS SHOULD COME BEFORE COLUMN ** C ** LIMITS CASE ** C ******************************************** C IDEFRL=255 NUMRCM=IDEFRL C C ************************************ C ** TREAT THE COLUMN LIMITS CASE ** C ************************************ C IDEFC1=1 CCCCC IDEFC2=132 IDEFC2=IDEFRL IFCOL1=IDEFC1 IFCOL2=IDEFC2 DO3010I=1,50 IFCOLL(I)=-1 IFCOLU(I)=-1 3010 CONTINUE C C ****************************** C ** TREAT THE COMMENT CASE ** C ****************************** C C *************************** C ** TREAT THE COPY CASE ** C *************************** C C C ********************************** C ** TREAT THE CURSOR SIZE CASE ** C ********************************** C DEFCSZ=1.0 ACURSZ=DEFCSZ C C ****************************** C ** TREAT THE DEGREES CASE ** C ****************************** C C C ******************************** C ** TREAT THE DIMENSION CASE ** C ******************************** C C ********************************** C ** TREAT THE ERASE DELAY CASE ** C ********************************** C DEFERD=1.0 ERASDE=DEFERD AGERDE=ERASDE C C ************************************** C ** TREAT THE HARDCOPY DELAY CASE ** C ************************************** C DEFHAD=1.0 HARDDE=DEFERD AGCODE=HARDDE C C ***************************** C ** TREAT THE DELETE CASE ** C ***************************** C C C *************************************** C ** TREAT THE DOUBLE PRECISION CASE ** C *************************************** C C C *************************** C ** TREAT THE ECHO CASE ** C *************************** C IECHO='OFF' C C **************************** C ** TRE***** AT THE END CASE ** C ** TREAT THE EXIT CASE ** C ** TREAT THE HALT CASE ** C ** TREAT THE STOP CASE ** C **************************** C C C ******************************* C ** TREAT THE ERASE CASE ** C ** TREAT THE PAGE CASE ** C ** TREAT THE NEW PAGE CASE ** C ******************************* C C C ********************************************* C ** TREAT THE DEMODULATION FREQUENCY CASE ** C ********************************************* C DEFDMF=-1.0 DEMOFR=DEFDMF C C **************************** C ** TREAT THE GRADS CASE ** C **************************** C C C *************************** C ** TREAT THE HELP CASE ** C *************************** C C C *************************** C ** TREAT THE HOST CASE ** C *************************** C DO300I=1,10 IDEFHO(I)=' ' 300 CONTINUE C NOTE--THE SPECIFICATION OF THE HOST C HAS BEEN MOVED TO THE MAIN ROUTINE. C SEARCH FOR IHOST1= AND IHOST2= C IN THE MAIN ROUTINE AND CHANGE IT TO YOUR HOST. CCCCC IDEFHO(1)='VAX ' CCCCC IDEFHO(2)='11/7' CCCCC IDEFHO(3)='80 ' CCCCC IDEFHO(4)='VMS ' CCCCC IDEFHO(5)=' ' C DO500I=1,10 IHOST(I)=IDEFHO(I) 500 CONTINUE C C ************************************** C ** TREAT THE FIT CONSTRAINTS CASE ** C ************************************** C C ********************************************* C ** TREAT THE FIT STANDARD DEVIATION CASE ** C ********************************************* C CCCCC CHANGE DEFAULT TO MATCH DPFIT2. FEBRUARY 1994. CCCCC DEFFSD=0.000005 DEFFSD=0.0000001 FITSD=DEFFSD C C ************************************* C ** TREAT THE FIT ITERATIONS CASE ** C ************************************* C IDEFNI=50 IFITIT=IDEFNI C C ******************************** C ** TREAT THE FIT POWER CASE ** C ******************************** C DEFFPW=2.0 FITPOW=DEFFPW C CCCCC THE FOLLOWING SECTION WAS ADDED JULY 1995 C ********************************************** C ** TREAT THE FIT ADDITIVE CONSTANT CASE ** C ********************************************** C IFITAC='ON' C C C **************************** C ** TREAT THE KNOTS CASE ** C **************************** C IKNOTS='OFF' IDEFK1=' ' IDEFK2=' ' IKNOT1=IDEFK1 IKNOT2=IDEFK2 C C ******************************* C ** TREAT THE MESSAGE CASE ** C ** TREAT THE CONSOLE CASE ** C ** TREAT THE OPERAT0R CASE ** C ******************************* C C C **************************** C ** TREAT THE MACRO CASE ** C **************************** C C C *************************** C ** TREAT THE NAME CASE ** C *************************** C C C **************************************** C ** TREAT THE POLYNOMIAL DEGREE CASE ** C **************************************** C IDEFDG=1 IDEG=IDEFDG C C ******************************** C ** TREAT THE PRECISION CASE ** C ******************************** C IDEFPR='SING' IHMXPR='SING' IPREC=IDEFPR C C ******************************** C ** TREAT THE PRE-ERASE CASE ** C ******************************** C IPREER='ON' C C ******************************* C ** TREAT THE PRINTING CASE ** C ******************************* C IPRINT='ON' IPRIN2=IPRINT C C ****************************************** C ** TREAT THE QUADRUPLE PRECISION CASE ** C ****************************************** C C C ****************************** C ** TREAT THE RADIANS CASE ** C ****************************** C C C *************************** C ** TREAT THE READ CASE ** C *************************** C C C **************************** C ** TREAT THE RESET CASE ** C **************************** C C C ****************************** C ** TREAT THE RESTORE CASE ** C ****************************** C C C ***************************** C ** TREAT THE RETAIN CASE ** C ** TREAT THE PACK CASE ** C ***************************** C C ******************************** C ** TREAT THE RING BELL CASE ** C ******************************** C C C ********************************* C ** TREAT THE ROW LIMITS CASE ** C ********************************* C IDEFR1=1 IDEFR2=I1MACH(9) IFROW1=IDEFR1 IFROW2=IDEFR2 C C *************************** C ** TREAT THE SAVE CASE ** C *************************** C C C ****************************************** C ** TREAT THE SEPARATOR CHARACTOR CASE ** C ****************************************** C IDEFTC=';' ITERCH=IDEFTC C C ****************************************** C ** TREAT THE CONTINUE CHARACTER CASE ** C ****************************************** C IDEFCC='... ' ICONCH=IDEFCC C C ****************************************** C ** TREAT THE COMMENT CHARACTER CASE ** C ****************************************** C IDEFCZ='. ' ICOMCH=IDEFCZ CCCCC THE FOLLOWING LINE WAS CHANGED OCTOBER 1992 CCCCC ICOMFL='OFF ' ICOMSW='OFF ' CCCCC FOLLOWING BLOCK OF CODE ADDED AUGUST 1992. C C ****************************************** C ** TREAT THE VECTOR FORMAT CASE ** C ** TREAT THE VECTOR ARROW CASE ** C ****************************************** C IDEFVF='ANGL' IVCFMT=IDEFVF IDEFVA='FIXE' IVCARR=IDEFVA IDEFVO='CLOS' IVCOPN=IDEFVO C CCCCC FOLLOWING BLOCK OF CODE ADDED NOVEMBER 1992. C C ****************************************** C ** TREAT THE ANDREW INCREMENT CASE ** C ****************************************** C DEFAIN=0.1 ANDINC=DEFAIN C CCCCC FOLLOWING BLOCK OF CODE ADDED JULY 1993 C ****************************************** C ** TREAT THE FRACTAL ITERATIONS CASE ** C ** TREAT THE FRACTAL TYPE CASE ** C ****************************************** C IDEFFT='BARN' IFRATY=IDEFVF IDEFFI=MAXPOP IFRAIT=IDEFFI C CCCCC FOLLOWING BLOCK OF CODE ADDED JULY 1993 C *********************************************** C ** TREAT THE PRINCIPLE COMPONENTS TYPE CASE ** C *********************************************** C IDEFPT='DACR' IPCMTY=IDEFPT C C ********************************** C ** TREAT THE SERIAL READ CASE ** C ********************************** C C C *************************************** C ** TREAT THE SINGLE PRECISION CASE ** C *************************************** C C C *************************** C ** TREAT THE SKIP CASE ** C *************************** C IDEFSK=0 ISKIP=IDEFSK C C ***************************** C ** TREAT THE STATUS CASE ** C ***************************** C C C ************************************** C ** TREAT THE SUBSET MESSAGES CASE ** C ************************************** C ISUBMS='ON' C C **************************** C ** TREAT THE TIME CASE ** C ** TREAT THE CLOCK CASE ** C **************************** C DO700I=1,10 ICLOCK(I)=0 700 CONTINUE C C *************************************** C ** TREAT THE TRIPLE PRECISION CASE ** C *************************************** C C C ****************************** C ** TREAT THE WEIGHTS CASE ** C ****************************** C IWEIGH='OFF' IDEFW1=' ' IDEFW2=' ' IWEIG1=IDEFW1 IWEIG2=IDEFW2 C C **************************** C ** TREAT THE WRITE CASE ** C ** TREAT THE PRINT CASE ** C **************************** C C C ************************ C ** TREAT THE . CASE ** C ************************ C C *********************************** C ** TREAT THE FILTER WIDTH CASE ** C *********************************** C DEFFW=3.0 FILWID=DEFFW C C ******************************* C ** TREAT THE FEEDBACK CASE ** C ******************************* C IFEEDB='ON' IFEED2=IFEEDB C C ************************************ C ** TREAT THE ROOT ACCURACY CASE ** C ************************************ C DEFRAC=0.000001 ROOTAC=DEFRAC C C ********************************************* C ** TREAT THE OPTIMIZATION TOLERANCE CASE ** C ********************************************* C DEFOAC=0.00001 OPTACC=DEFOAC C C ********************************************* C ** TREAT THE OPTIMIZATION METHOD CASE ** C ********************************************* C IDEFOM='LINE' IOPTME=IDEFOM IDEFHS='FINI' IOPTHE=IDEFHS C CCCCC THE FOLLOWING SECTION WAS ADDED MAY 1993 CCCCC AUGUST 2004: SET DEFAULT TO 1 (THIS IS THE MORE COMMON CCCCC CASE FOR THE WEIBULL DISTRIBUTION) C C *************************************** C ** TREAT THE EV1/EV2/WEIBULL ** C ** DISTRIBUTION SPECIFICATION CASE ** C *************************************** C MINMAX=0 CCCCC MINMAX=1 C CCCCC THE FOLLOWING SECTION WAS ADDED APRIL 1997 C C *************************************** C ** TREAT THE SET NETSCAPE ** C ** CASE ** C *************************************** C INETSW='NEW' C CCCCC THE FOLLOWING SECTION WAS ADDED APRIL 1997 C C *************************************** C ** TREAT THE SET CONTROL CHART ** C ** CASE ** C *************************************** C ICCHPR='DATA' C CCCCC THE FOLLOWING SECTION WAS ADDED APRIL 1997 C C ******************************************* C ** TREAT THE SET CONTROL CHART WEIGHTING * C **
CASE ** C ******************************************* C ICCHWT='RIGH' C CCCCC THE FOLLOWING SECTION WAS ADDED AUGUST 1997 C C ************************************************* C ** TREAT THE RECIPE SATTERWAITE APPROXIMATION ** C ** CASE ** C ************************************************* C IDEFSA='ON' IRECSA=IDEFSA C CCCCC THE FOLLOWING SECTION WAS ADDED AUGUST 1997 C C ************************************************* C ** TREAT THE RECIPE OUTPUT ** C ** CASE ** C ************************************************* C IDEFTN='TOL' IRECTN=IDEFTN C CCCCC THE FOLLOWING SECTION WAS ADDED AUGUST 1997 C C ************************************************* C ** TREAT THE RECIPE PROBABILITY CONTENT ** C ************************************************* C DEFRPC=0.90 RECIPC=DEFRPC C CCCCC THE FOLLOWING SECTION WAS ADDED AUGUST 1997 C C ************************************************* C ** TREAT THE RECIPE CONFIDENCE ** C ************************************************* C DEFRCO=0.95 RECICO=DEFRCO C CCCCC THE FOLLOWING SECTION WAS ADDED AUGUST 1997 C C ************************************************* C ** TREAT THE RECIPE DEGREE ** C ************************************************* C DEFRDG=1.0 RECIDG=DEFRDG C CCCCC THE FOLLOWING SECTION WAS ADDED AUGUST 1997 C C ************************************************* C ** TREAT THE RECIPE FACTORS ** C ************************************************* C DEFRFA=0. RECIFA=DEFRFA C CCCCC THE FOLLOWING SECTION WAS ADDED APRIL 1998 C C ************************************************* C ** TREAT THE RECIPE FACTORS ** C ************************************************* C DEFRFF=0. RECIFF=DEFRFF C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1997 C C ************************************************* C ** TREAT THE RECIPE SIMCOV REPLICATES ** C ************************************************* C IDEFR7=10000 IRECR1=IDEFR7 C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1997 C C ************************************************* C ** TREAT THE RECIPE SIMPVT REPLICATES ** C ************************************************* C IDEFR8=10000 IRECR2=IDEFR8 C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1997 C C ************************************************* C ** TREAT THE RECIPE CORRELATIONS ** C ************************************************* C IDEFR9=11 IRECC1=IDEFR9 C CCCCC THE FOLLOWING SECTION WAS ADDED MAY 1998 C C ******************************************* C ** TREAT THE SET KAPLAN-MEIER ** C ** CASE ** C ******************************************* C IKAPSW='RELI' C CCCCC THE FOLLOWING SECTION WAS ADDED MAY 1998 C C ******************************************* C ** TREAT THE SET CENSORING TYPE ** C ** <1/2 > CASE ** C ******************************************* C ICENTY='NONE' C CCCCC THE FOLLOWING SECTION WAS ADDED JUNE 1998 C C ******************************************* C ** TREAT THE SET MATRIX SCALE ** C ** CASE ** C ******************************************* C IMATSC='NONE' C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1998 C C ******************************************* C ** TREAT THE SET PERCENT POINT PLOT ** C ** CASE ** C ******************************************* C IPPTBI='BINN' C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1998 C C ******************************************* C ** TREAT THE SET QUANTILE-QUANTILE PLOT ** C ** CASE ** C ******************************************* C IQQPBI='BINN' C CCCCC THE FOLLOWING SECTION WAS ADDED MARCH 1999 C C ******************************************* C ** TREAT THE SET HANDBOOK URL ** C ******************************************* C NCHURL=40 IHBURL(1:40)='http://www.itl.nist.gov/div898/handbook/' C CCCCC THE FOLLOWING SECTION WAS ADDED JULY 1999 C C ******************************************* C ** TREAT THE SET AUTOCORRELATION BAND ** C ** CASE ** C ******************************************* C IAUTCP='WHIT' C CCCCC THE FOLLOWING SECTION WAS ADDED FEBRUARY 2003 C C ******************************************* C ** TREAT THE SET AUTOCORRELATION LAG ** C ** ZERO CASE ** C ******************************************* C IAUTL0='ON' C CCCCC THE FOLLOWING SECTION WAS ADDED MARCH 2003 C C ******************************************* C ** TREAT THE SET PARALLEL COORDINATES ** C ** STANDARDIZE CASE** C ******************************************* C IPCCST='USCO' C CCCCC THE FOLLOWING SECTION WAS ADDED MARCH 2003 C C ******************************************* C ** TREAT THE SET BOOTSTRAP GROUPS ** C ** CASE ** C ******************************************* C IBOOGR='INDE' C CCCCC THE FOLLOWING SECTION WAS ADDED MAY 2003 C C ******************************************* C ** TREAT THE SET MULTIVARIATE NORMAL ** C ** CASE ** C ******************************************* C IMVNTY='SADM' C CCCCC THE FOLLOWING SECTION WAS ADDED MARCH 2002 C C ******************************************* C ** TREAT THE SET BOX PLOT WIDTH ** C ** CASE ** C ******************************************* C IBXPWI='VARI' C CCCCC THE FOLLOWING SECTION WAS ADDED MARCH 2002 C C ******************************************* C ** TREAT THE SET 4-PLOT MULTIPLOT ** C ** CASE ** C ******************************************* C I4PLMC='OFF' C CCCCC THE FOLLOWING SECTION WAS ADDED MARCH 2002 C C ******************************************* C ** TREAT THE SET 6-PLOT MULTIPLOT ** C ** CASE ** C ******************************************* C I6PLMC='OFF' C CCCCC THE FOLLOWING SECTION WAS ADDED MAY 2002 C C ******************************************* C ** TREAT THE SET RANDOM NUMBER GENERATOR** C ** CASE ** C ******************************************* C IRANAL='FIBO' C CCCCC THE FOLLOWING SECTION WAS ADDED JANUARY 2000 C C ************************************************** C ** TREAT THE SET CROSS TABULATE PLOT DIMENSION ** C ** <1/2> CASE ** C ************************************************** C ICTBDI='1' C CCCCC THE FOLLOWING SECTION WAS ADDED NOVEMBER 1999 C C ******************************************* C ** TREAT THE SET PARAMETER EXPANSION ** C ** CASE ** C ******************************************* C IEXPPA='NUME' C CCCCC THE FOLLOWING SECTION WAS ADDED JANUARY 2000 C C ******************************************* C ** TREAT THE SET SORT DIRECTION ** C ** CASE ** C ******************************************* C ISORDI='ASCE' C CCCCC THE FOLLOWING SECTION WAS ADDED FEBRUARY 2000 C C ************************************************ C ** TREAT THE SET DEX CONTOUR PLOT DIRECTION ** C ** CASE ** C ************************************************ C IDCPDI='MAXI' C CCCCC THE FOLLOWING SECTION WAS ADDED OCTOBER 2000 C C **************************************************** C ** TREAT THE SET MANDEL PAULE ** C **************************************************** C IMANPA='REGU' C CCCCC THE FOLLOWING SECTION WAS ADDED MARCH 2001 C C **************************************************** C ** TREAT THE SET LOCATION STATISTIC ** C **************************************************** C ISTALO='MEAN' C CCCCC THE FOLLOWING SECTION WAS ADDED MARCH 2001 C C **************************************************** C ** TREAT THE SET SCALE STATISTIC ** C **************************************************** C ISTASC='SD ' C CCCCC THE FOLLOWING SECTION WAS ADDED MARCH 2001 C C **************************************************** C ** TREAT THE SET SUPERSCRIPT HORI SCALE ** C **************************************************** C PSUPXS=0.5 C CCCCC THE FOLLOWING SECTION WAS ADDED MARCH 2001 C C **************************************************** C ** TREAT THE SET SUPERSCRIPT VERT SCALE ** C **************************************************** C PSUPYS=0.5 C CCCCC THE FOLLOWING SECTION WAS ADDED APRIL 2001 C C **************************************************** C ** TREAT THE SET ORTHOGONAL DISTANCE TRUST ** C ** REGION RADIUS ** C **************************************************** C PODRTF=-1.0 C CCCCC THE FOLLOWING SECTION WAS ADDED APRIL 2001 C C **************************************************** C ** TREAT THE SET ORTHOGONAL DISTANCE STOP ** C ** TOLERANCE ** C **************************************************** C PODRST=-1.0 C CCCCC THE FOLLOWING SECTION WAS ADDED APRIL 2001 C C **************************************************** C ** TREAT THE SET ORTHOGONAL DISTANCE ** C ** PARAMETER TOLERANCE ** C **************************************************** C PODRPT=-1.0 C CCCCC THE FOLLOWING SECTION WAS ADDED APRIL 2001 C C **************************************************** C ** TREAT THE SET ORTHOGONAL DISTANCE ** C ** PRINT OPTION ** C **************************************************** C IODRPO='DEFA' C CCCCC THE FOLLOWING SECTION WAS ADDED APRIL 2001 C C **************************************************** C ** TREAT THE ORTHOGONAL DISTANCE DELTA VARIABLES ** C **************************************************** C DO7993I=1,20 IODRD1(I)='OFF ' IODRD2(I)=' ' IODRD3(I)='OFF ' IODRD4(I)=' ' IODRE1(I)='ON ' IODRE2(I)=' ' IWEIN1(I)='OFF ' IWEIN2(I)=' ' 7993 CONTINUE C CCCCC THE FOLLOWING SECTION WAS ADDED JULY 2001 C C **************************************************** C ** TREAT THE KERNEL DENSITY OPTIONS: ** C ** KERNEL DENSITY WINDOW ** C ** KERNEL DENSITY POINTS ** C ** KERNEL DENSITY TYPE ** C **************************************************** C IDEFKF='GAUS' IKDETY=IDEFKF IDEFKN=256 IKDENP=IDEFKN DEFKWI=CPUMIN PKDEWI=DEFKWI C CCCCC THE FOLLOWING SECTION WAS ADDED FEBRUARY 2000 C C ************************************************ C ** TREAT THE SET DEX CONTOUR PLOT MODEL ** C ** CASE ** C ************************************************ C IDCPFI='LINE' C CCCCC THE FOLLOWING SECTION WAS ADDED JUNE 2002 C C ************************************************ C ** TREAT THE ICAPTY SWITCH ** C ************************************************ C ICAPTY='TEXT' C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1999 C C *********************************************** C ** TREAT THE SET SCATTER PLOT MATRIX LABELS ** C ** CASE ** C *********************************************** C ISPMLA='ON' C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1999 C C *********************************************** C ** TREAT THE SET SCATTER PLOT MATRIX DIAGONAL* C ** CASE ** C *********************************************** C ISPMDI='BLAN' C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1999 C C *********************************************** C ** TREAT THE SET SCATTER PLOT MATRIX FIT ** C ** CASE ** C *********************************************** C ISPMFI='NONE' C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1999 C C ******************************************************* C ** TREAT THE SET SCATTER PLOT MATRIX LOWER DIAGONAL ** C ** CASE ** C ******************************************************* C ISPMLD='ON' C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1999 C C ******************************************************* C ** TREAT THE SET SCATTER PLOT MATRIX TAG ** C ** CASE ** C ******************************************************* C ISPMTA='OFF' C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1999 C C ******************************************************* C ** TREAT THE SET SCATTER PLOT MATRIX PLOT TYPE ** C ** CASE ** C ******************************************************* C ISPMPT='PLOT' C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1999 C C ******************************************************* C ** TREAT THE SET SCATTER PLOT MATRIX FRAME ** C ** CASE ** C ******************************************************* C ISPMFR='DEFA' C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1999 C C ******************************************************* C ** TREAT THE SET SCATTER PLOT MATRIX X AXIS ** C ** CASE ** C ******************************************************* C ISPMXA='ALTE' C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1999 C C ******************************************************* C ** TREAT THE SET SCATTER PLOT MATRIX Y AXIS ** C ** CASE ** C ******************************************************* C ISPMYA='ALTE' C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1999 C C ******************************************************* C ** TREAT THE SET SCATTER PLOT MATRIX STATISTIC TYPE ** C ** CASE ** C ******************************************************* C ISPMST='MEAN' ISPMS2=' ' ISPMS3=' ' ISPMS4=' ' C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1999 C C ******************************************************* C ** TREAT THE SET SCATTER PLOT MATRIX LIMITS ** C ** CASE ** C ******************************************************* C DO8001I=1,25 PSPLLL(I)=CPUMIN PSPLUL(I)=CPUMIN PSPLSL(I)=CPUMIN PSPLSU(I)=CPUMIN 8001 CONTINUE C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1999 C C ******************************************************* C ** TREAT THE SET MATRIX PLOT TIC LABEL DISPLACEMENT** C ** CASE ** C ******************************************************* C PSPMTD=CPUMIN ISPMTD='NORM' C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1999 C C *********************************************** C ** TREAT THE SET SCATTER PLOT MATRIX CORRELAT* C ** CASE ** C *********************************************** C ISPMCC='OFF' C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1999 C C *********************************************** C ** TREAT THE SET SCATTER PLOT MATRIX X2LABEL* C ** CASE ** C *********************************************** C ISPX2L='OFF' ISPX2P='DEFAULT' ISPX2S='DEFAULT' C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1999 C C ******************************************************* C ** TREAT THE SET CONDITIONING PLOT LABEL ** C ** CASE ** C ******************************************************* C ICPLLA='ON' C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1999 C C ******************************************************* C ** TREAT THE SET CONDITIONING PLOT TAG ** C ** CASE ** C ******************************************************* C ICPLTA='OFF' C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1999 C C ******************************************************* C ** TREAT THE SET CONDITIONING PLOT PLOT TYPE ** C ** CASE ** C ******************************************************* C ICPLPT='PLOT' C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1999 C C ******************************************************* C ** TREAT THE SET CONDITIONING PLOT FIT ** C ** CASE ** C ******************************************************* C ICPLFI='NONE' C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1999 C C ******************************************************* C ** TREAT THE SET CONDITIONING PLOT FRAME ** C ** CASE ** C ******************************************************* C ICPLFR='DEFA' C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1999 C C ******************************************************* C ** TREAT THE SET CONDITIONING PLOT MATRIX X AXIS ** C ** CASE ** C ******************************************************* C ICPLXA='ALTE' C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1999 C C ******************************************************* C ** TREAT THE SET CONDITIONING PLOT MATRIX Y AXIS ** C ** CASE ** C ******************************************************* C ICPLYA='ALTE' C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1999 C C ******************************************************* C ** TREAT THE SET CONDITIONING PLOT PRE-SORT ** C ** CASE ** C ******************************************************* C CCCCC THIS OPTION WAS REMOVED. CCCCC ICPLPS='ON' C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1999 C C ******************************************************* C ** TREAT THE SET CONDITIONING PLOT STATISTIC TYPE ** C ** CASE ** C ******************************************************* C ICPLST='MEAN' ICPLS2=' ' ICPLS3=' ' ICPLS4=' ' C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1999 C C ******************************************************* C ** TREAT THE SET CONDITION PLOT NAME OF ** C ** PROBABILITY PLOT CASE ** C ******************************************************* C ICPLP1=' ' ICPLP2=' ' ICPLP3=' ' ICPLP4=' ' ICPLP5=' ' C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1999 C C ******************************************************* C ** TREAT THE SET CONDITION PLOT NAME OF ** C ** PPCC PLOT CASE ** C ******************************************************* C ICPLC1=' ' IcPLC2=' ' ICPLC3=' ' ICPLC4=' ' ICPLC5=' ' C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1999 C C ******************************************************* C ** TREAT THE SET CONDITION PLOT CORRELATION ** C ** CASE ** C ******************************************************* C ICPLCC='OFF' C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1999 C C *********************************************** C ** TREAT THE SET CONDITION PLOT X2LABEL ** C ** CASE ** C *********************************************** C ICPX2L='OFF' C C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1999 C C ******************************************************* C ** TREAT THE SET CONDITION PLOT RESPONSE VARIABLES ** C ** CASE ** C ******************************************************* C PCPLRV=1.0 C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1999 C C ******************************************************* C ** TREAT THE SET CONDIT PLOT TIC LABEL DISPLACEMENT** C ** CASE ** C ******************************************************* C PCPLTD=CPUMIN ICPLTD='NORM' C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1999 C C ******************************************************* C ** TREAT THE SET CONDITION PLOT TAG VARIABLES ** C ** CASE ** C ******************************************************* C PCPLTV=1.0 C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1999 C C ******************************************************* C ** TREAT THE SET CONDITION PLOT LIMITS ** C ** CASE ** C ******************************************************* C DO8013I=1,25 PCPXLL(I)=CPUMIN PCPXUL(I)=CPUMIN PCPYLL(I)=CPUMIN PCPYUL(I)=CPUMIN 8013 CONTINUE C C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1999 C C ******************************************************* C ** TREAT THE SET FACTOR PLOT LABEL ** C ** CASE ** C ******************************************************* C IFPLLA='ON' C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1999 C C ******************************************************* C ** TREAT THE SET FACTOR PLOT CORRELATION ** C ** CASE ** C ******************************************************* C IFPLCC='OFF' C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1999 C C ******************************************************* C ** TREAT THE SET FACTOR PLOT TAG ** C ** CASE ** C ******************************************************* C IFPLTA='OFF' C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1999 C C ******************************************************* C ** TREAT THE SET FACTOR PLOT PLOT TYPE ** C ** CASE ** C ******************************************************* C IFPLPT='PLOT' C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1999 C C ******************************************************* C ** TREAT THE SET FACTOR PLOT FIT ** C ** CASE ** C ******************************************************* C IFPLFI='NONE' C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1999 C C ******************************************************* C ** TREAT THE SET FACTOR PLOT FRAME ** C ** CASE ** C ******************************************************* C IFPLFR='USER' C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1999 C C ******************************************************* C ** TREAT THE SET FACTOR PLOT MATRIX X AXIS ** C ** CASE ** C ******************************************************* C IFPLXA='ALTE' C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1999 C C ******************************************************* C ** TREAT THE SET FACTOR PLOT MATRIX Y AXIS ** C ** CASE ** C ******************************************************* C IFPLYA='ALTE' C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1999 C C ******************************************************* C ** TREAT THE SET FACTOR PLOT PRE-SORT ** C ** CASE ** C ******************************************************* C CCCCC THIS OPTION WAS REMOVED. CCCCC IFPLPS='ON' C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1999 C C ******************************************************* C ** TREAT THE SET FACTOR PLOT STATISTIC TYPE ** C ** CASE ** C ******************************************************* C IFPLST='MEAN' IFPLS2=' ' IFPLS3=' ' IFPLS4=' ' C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1999 C C ******************************************************* C ** TREAT THE SET FACTOR PLOT RESPONSE VARIABLES ** C ** CASE ** C ******************************************************* C PFPLRV=1.0 C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1999 C C ******************************************************* C ** TREAT THE SET FACTOR PLOT TIC LABEL DISPLACEMENT** C ** CASE ** C ******************************************************* C PFPLTD=CPUMIN IFPLTD='NORM' C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1999 C C ******************************************************* C ** TREAT THE SET FACTOR PLOT LIMITS ** C ** CASE ** C ******************************************************* C DO8003I=1,25 PFPXLL(I)=CPUMIN PFPXUL(I)=CPUMIN PFPYLL(I)=CPUMIN PFPYUL(I)=CPUMIN 8003 CONTINUE C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1999 C C ******************************************************* C ** TREAT THE SET FACTOR PLOT CORRELATION ** C ** CASE ** C ******************************************************* C IFPLCC='OFF' C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1999 C C *********************************************** C ** TREAT THE SET FACTOR PLOT X2LABEL ** C ** CASE ** C *********************************************** C IFPX2L='OFF' C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1999 C C ******************************************************* C ** TREAT THE SET FACTOR PLOT NAME OF ** C ** PROBABILITY PLOT CASE ** C ******************************************************* C IFPLP1=' ' IFPLP2=' ' IFPLP3=' ' IFPLP4=' ' IFPLP5=' ' C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1999 C C ******************************************************* C ** TREAT THE SET FACTOR PLOT NAME OF ** C ** PPCC PLOT CASE ** C ******************************************************* C IFPLC1=' ' IFPLC2=' ' IFPLC3=' ' IFPLC4=' ' IFPLC5=' ' C CCCCC THE FOLLOWING SECTION WAS ADDED JUNE 2002 C C *********************************************** C ** TREAT THE SET NUMBER OF CP CASE ** C *********************************************** C INUMCP=10 C CCCCC THE FOLLOWING SECTION WAS ADDED JUNE 2002 C C *********************************************** C ** TREAT THE SET CAPTURE LINES CASE ** C *********************************************** C DO8110I=1,MAXCLI ICAPLI(1)=25 8110 CONTINUE C CCCCC THE FOLLOWING SECTION WAS ADDED JUNE 2002 C C *********************************************** C ** TREAT THE SET CAPTURE BOX CASE ** C *********************************************** C ICAPBX='OFF' C CCCCC THE FOLLOWING SECTION WAS ADDED JUNE 2002 C C ************************************************** C ** TREAT THE SET CAPTURE NUMBER CASE ** C ************************************************** C ICAPNM='OFF' C CCCCC THE FOLLOWING SECTION WAS ADDED JULY 2002 C C ************************************************** C ** TREAT THE SET QUANTILE METHOD CASE* C ************************************************** C IQUAME='ORDE' C CCCCC THE FOLLOWING SECTION WAS ADDED JULY 2002 C C ************************************************** C ** TREAT THE SET QUANTILE STANDARD ERROR METHOD * C ** * C ************************************************** C IQUASE='MJ' C CCCCC THE FOLLOWING SECTION WAS ADDED JULY 2002 C C ************************************************** C ** TREAT THE SET COVARIANCE TYPE * C ** * C ************************************************** C ICOVTY='DEFAU' C CCCCC THE FOLLOWING SECTION WAS ADDED JULY 2002 C C ************************************************** C ** TREAT THE SET CORRELATION TYPE * C ** * C ************************************************** C ICORTY='DEFA' C CCCCC THE FOLLOWING SECTION WAS ADDED JULY 2002 C C ************************************************** C ** TREAT THE SET FILE NAME QUOTE * C ** * C ************************************************** C IFILQU='OFF' C CCCCC THE FOLLOWING SECTION WAS ADDED JULY 2002 C C ************************************************** C ** TREAT THE SET BOOTSTRAP FIT METHOD * C ** * C ************************************************** C IBOOME='RESI' C CCCCC THE FOLLOWING SECTION WAS ADDED NOVEMBER 2002 C C ************************************************** C ** TREAT THE SET QWIN SYSTEM * C ************************************************** C IQWNSY='SYST' C CCCCC THE FOLLOWING SECTION WAS ADDED NOVEMBER 2002 C C ************************************************** C ** TREAT THE SET GHOSTVIEW PRINTER * C ************************************************** C IPRNGS='OFF' C CCCCC THE FOLLOWING SECTION WAS ADDED JANUARY 2003 C C ************************************************** C ** TREAT THE SET POSTSCRIPT BOUNDING BOX * C ** * C ************************************************** C IPSTBB='FLOA' C CCCCC THE FOLLOWING SECTION WAS ADDED JANUARY 2003 C C ************************************************** C ** TREAT THE SET POSTSCRIPT CONVERT * C ** * C ************************************************** C IPSTDV='NULL' C CCCCC THE FOLLOWING SECTION WAS ADDED NOVEMBER 2002 C C ************************************************** C ** TREAT THE SET GHOSTVIEW PATH * C ************************************************** C FOR UNIX, "\" IS ESCAPE CHARACTER, SO DON'T INSERT THIS CHARACTER C DIRECTLY (CAN GET COMPILE ERRORS). C CALL DPCONA(92,IBASLC) NCGSPA=19 IGSVPA='C: GHOSTGUM GSVIEW ' IGSVPA(3:3)=IBASLC IGSVPA(12:12)=IBASLC IGSVPA(19:19)=IBASLC C CCCCC THE FOLLOWING SECTION WAS ADDED JANUARY 2003 C C ************************************************** C ** TREAT THE SET GHOSTSCRIPT PATH * C ************************************************** C C FOR UNIX, "\" IS ESCAPE CHARACTER, SO DON'T INSERT THIS CHARACTER C DIRECTLY (CAN GET COMPILE ERRORS). C CALL DPCONA(92,IBASLC) IF(IHOST1.EQ.'IBM-')THEN NCGHPA=17 IGSTPA='C: GS GS7.04 BIN ' IGSTPA(3:3)=IBASLC IGSTPA(6:6)=IBASLC IGSTPA(13:13)=IBASLC IGSTPA(17:17)=IBASLC ELSE IGSTPA=' ' NCGHPA=0 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED JANUARY 2003 C C ************************************************** C ** TREAT THE SET HTML HEADER FILE * C ************************************************** C IHTMHE='NULL' NCHTMH=-1 C CCCCC THE FOLLOWING SECTION WAS ADDED JANUARY 2003 C C ************************************************** C ** TREAT THE SET HTML FOOTER FILE * C ************************************************** C IHTMFO='NULL' NCHTMF=-1 C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 2003 C C ************************************************** C ** TREAT THE SET LATEX HEADER FILE * C ************************************************** C ILATHE='NULL' NCLATH=-1 C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 2003 C C ************************************************** C ** TREAT THE SET LATEX FOOTER FILE * C ************************************************** C ILATFO='NULL' NCLATF=-1 C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 2003 C C ************************************************** C ** TREAT THE SET TABLE BORDER * C ************************************************** C ITABBR='RULE' C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 2003 C C ************************************************** C ** TREAT THE SET TABLE SPACING * C ************************************************** C ITABSP=0 C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 2003 C C ************************************************** C ** TREAT THE SET TABLE WIDTH * C ************************************************** C ITABWD=0 C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 2003 C C ************************************************** C ** TREAT THE SET TABLE HEIGHT * C ************************************************** C ITABHT=0 C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 2003 C C ************************************************** C ** TREAT THE SET TABLE TITLE * C ************************************************** C ITABTI=' ' NCTABT=0 C CCCCC THE FOLLOWING SECTION WAS ADDED JANUARY 2004 C C ***************************************************** C ** TREAT THE SET READ VARIAVLE LABEL ** C ***************************************************** C IVARLA='OFF' C CCCCC THE FOLLOWING SECTION WAS ADDED JANUARY 2004 C C ***************************************************** C ** TREAT THE SET CONVERT CHARACTER ** C ***************************************************** C IGRPAU='ERRO' C CCCCC THE FOLLOWING SECTION WAS ADDED JANUARY 2004 C C ***************************************************** C ** TREAT THE SET READ DELIMITER ** C ***************************************************** C IREADL=',' C C CCCCC THE FOLLOWING SECTION WAS ADDED JANUARY 2004 C C ***************************************************** C ** TREAT THE SET READ MISSING VALUE ** C ***************************************************** C PREAMV=0.0 C CCCCC THE FOLLOWING SECTION WAS ADDED MARCH 2004 C C ***************************************************** C ** TREAT THE SET GEOMETRIC DEFINITION ** C ** ** C ***************************************************** C IGEODF='KOTZ' C CCCCC THE FOLLOWING SECTION WAS ADDED MARCH 2004 C C ***************************************************** C ** TREAT THE SET PPCC PLOT ** C ** ** C ***************************************************** C IPPCCC='LINE' C CCCCC THE FOLLOWING SECTION WAS ADDED MAY 2004 C C ***************************************************** C ** TREAT THE SET PPCC FORMAT ** C ** <3D/TRACE> ** C ***************************************************** C IPPCFO='TRAC' C C CCCCC THE FOLLOWING SECTION WAS ADDED MARCH 2004 C C ***************************************************** C ** TREAT THE SET HYPERGEOMETRIC MAXIMUM LIKELIHOOD** C ** ** C ***************************************************** C IHYPTY='ACCE' C CCCCC THE FOLLOWING SECTION WAS ADDED JUNE 2004 C C ***************************************************** C ** TREAT THE SET POSTSCRIPT DEFAULT COLOR ** C ** ** C ***************************************************** C IPSTDC='OFF' C CCCCC THE FOLLOWING SECTION WAS ADDED JUNE 2004 C C ***************************************************** C ** TREAT THE SET ASYMMETRIC LAPLACE DEFINITION ** C ** ** C ***************************************************** C IADEDF='K' C CCCCC THE FOLLOWING SECTION WAS ADDED JUNE 2004 C C ***************************************************** C ** TREAT THE SET GENERALIZED PARETO DEFINITION ** C ** ** C ***************************************************** C IGEPDF='SIMI' C CCCCC THE FOLLOWING SECTION WAS ADDED OCTOBER 2005 C C ***************************************************** C ** TREAT THE SET GENERALIZED PARETO MLE STARTING ** C ** VALUES ** C ***************************************************** C IGEPSV='EPER' C CCCCC THE FOLLOWING SECTION WAS ADDED JULY 2004 C C ***************************************************** C ** TREAT THE SET GOMPERTZ-MAKEM O DEFINITION ** C ** ** C ***************************************************** C IMAKDF='REPA' C CCCCC THE FOLLOWING SECTION WAS ADDED AUGUST 2004 C C ***************************************************** C ** TREAT THE SET BESSEL I FUNCTION DEFINITION ** C ** <1/2> ** C ***************************************************** C IBEIDF='1' C CCCCC THE FOLLOWING SECTION WAS ADDED AUGUST 2004 C C ***************************************************** C ** TREAT THE SET BESSEL K FUNCTION DEFINITION ** C ** <1/2> ** C ***************************************************** C IBEKDF='1' C CCCCC THE FOLLOWING SECTION WAS ADDED AUGUST 2004 C C ***************************************************** C ** TREAT THE SET PROBABILITY PLOT DATA POINTS ** C ** ** C ***************************************************** C IPPLDP=0 C CCCCC THE FOLLOWING SECTION WAS ADDED AUGUST 2004 C C ***************************************************** C ** TREAT THE SET PPCC PLOT DATA POINTS ** C ** ** C ***************************************************** C IPPCDP=0 C CCCCC THE FOLLOWING SECTION WAS ADDED AUGUST 2004 C C ***************************************************** C ** TREAT THE SET PPCC PLOT AXIS POINTS ** C ** ** C ***************************************************** C IPPCAP(1)=0 IPPCAP(2)=0 C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 2004 C C ***************************************************** C ** TREAT THE SET PPCC PLOT AXIS ORDER ** C ** ** C ***************************************************** C IPPCAO='DEFA' C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 2004 C C ***************************************************** C ** TREAT THE SET HISTOGRAM CLASS WIDTH ** C ** ** C ***************************************************** C IHSTCW='DEFA' C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 2004 C C ***************************************************** C ** TREAT THE SET ASH WEIGHTING ** C ** ** C ***************************************************** C IASHWT='TRIA' C CCCCC THE FOLLOWING SECTION WAS ADDED OCTOBER 2004 C C ***************************************************** C ** TREAT THE SET READ PAD MISSING COLUMNS ** C ** ** C ***************************************************** C IREAPD='OFF' C CCCCC THE FOLLOWING SECTION WAS ADDED OCTOBER 2004 C C ***************************************************** C ** TREAT THE SET READ SUBSET ** C ** ** C ***************************************************** C IREASB='P-D' C CCCCC THE FOLLOWING SECTION WAS ADDED OCTOBER 2004 C C ***************************************************** C ** TREAT THE SET PROBABILITY PLOT ** C ** ** C ***************************************************** C IPPLCN='UNIM' C CCCCC THE FOLLOWING SECTION WAS ADDED OCTOBER 2004 C C ***************************************************** C ** TREAT THE SET PPCC PLOT ** C ** ** C ***************************************************** C IPPCCN='UNIM' C CCCCC THE FOLLOWING SECTION WAS ADDED OCTOBER 2004 C C ***************************************************** C ** TREAT THE SET MAXIMUM LIKELIHOOD QUANTILE ** C ** ** C ***************************************************** C IQUAVR='NONE' C CCCCC THE FOLLOWING SECTION WAS ADDED DECEMBER 2004 C C ***************************************************** C ** TREAT THE SET MAXIMUM LIKELIHOOD RELIABILITY ** C ** ** C ***************************************************** C IRELVR='NONE' C CCCCC THE FOLLOWING SECTION WAS ADDED OCTOBER 2004 C C ***************************************************** C ** TREAT THE SET EXPONENTIAL BIAS CORRECTED ** C ** ** C ***************************************************** C IEXPBC='OFF' C CCCCC THE FOLLOWING SECTION WAS ADDED NOVEMBER 2004 C C ***************************************************** C ** TREAT THE SET WEIBULL BIAS CORRECTED ** C ** ** C ***************************************************** C IWEIBC='OFF' C CCCCC THE FOLLOWING SECTION WAS ADDED NOVEMBER 2004 C C ***************************************************** C ** TREAT THE SET GUMBEL BIAS CORRECTED ** C ** ** C ***************************************************** C IGUMBC='OFF' C CCCCC THE FOLLOWING SECTION WAS ADDED NOVEMBER 2004 C C ***************************************************** C ** TREAT THE SET MATRIX CORRELATION DIRECTION ** C ** ** C ***************************************************** C ICORDI='COLU' C CCCCC THE FOLLOWING SECTION WAS ADDED NOVEMBER 2004 C C ***************************************************** C ** TREAT THE SET MATRIX COVARIANCE DIRECTION ** C ** ** C ***************************************************** C ICOVDI='COLU' C CCCCC THE FOLLOWING SECTION WAS ADDED DECEMBER 2004 C C ***************************************************** C ** TREAT THE SET GUI ** C ***************************************************** C IGUIFL='OFF' C CCCCC THE FOLLOWING SECTION WAS ADDED FEBRUARY 2005 C C ***************************************************** C ** TREAT THE SET DISTRIBUTIONAL BOOTSTRAP ** C ** ** C ***************************************************** C IBOOPA='NONP' C CCCCC THE FOLLOWING SECTION WAS ADDED FEBRUARY 2005 C C ***************************************************** C ** TREAT THE SET RTF POINT SIZE ** C ***************************************************** C IRTFPS=20 C CCCCC THE FOLLOWING SECTION WAS ADDED FEBRUARY 2005 C C ***************************************************** C ** TREAT THE SET RTF FIXED FONT ** C ***************************************************** C IRTFFF='Courier New' NCRTF1=11 C CCCCC THE FOLLOWING SECTION WAS ADDED FEBRUARY 2005 C C ***************************************************** C ** TREAT THE SET RTF PROPORTIONAL FONT ** C ***************************************************** C IRTFFP='Times New Roman' NCRTF1=15 C CCCCC THE FOLLOWING SECTION WAS ADDED FEBRUARY 2005 C C ***************************************************** C ** TREAT THE SET PARAMETER EXPAND DIGIT ** C ***************************************************** C IEXPDI=-1 C CCCCC THE FOLLOWING SECTION WAS ADDED MARCH 2005 C C ***************************************************** C ** TREAT THE SET LINE PRINTER COLUMNS <80/130> ** C ***************************************************** C ILPRCO=80 C CCCCC THE FOLLOWING SECTION WAS ADDED APRIL 2005 C C ***************************************************** C ** TREAT THE SET DECIMAL POINT ** C ***************************************************** C IDECPT='.' C CCCCC THE FOLLOWING SECTION WAS ADDED APRIL 2005 C C ***************************************************** C ** TREAT THE SET PEAKS OVER THRESHOLD METHOD * C ***************************************************** C IPOTME='DEHA' C CCCCC THE FOLLOWING SECTION WAS ADDED APRIL 2005 C C ***************************************************** C ** TREAT THE SET PEAKS OVER THRESHOLD LOAD FACTOR ** C ** ** C ***************************************************** C IPOTLF='OFF ' C CCCCC THE FOLLOWING SECTION WAS ADDED APRIL 2005 C C ***************************************************** C ** TREAT THE SET PEAKS OVER THRESHOLD X AXIS ** C ** ** C ***************************************************** C IPOTAX='POIN' C CCCCC THE FOLLOWING SECTION WAS ADDED APRIL 2005 C C ***************************************************** C ** TREAT THE SET PEAKS OVER THRESHOLD DISTRIBUTION * C ** * C ***************************************************** C IPOTDI='GPAR' C CCCCC THE FOLLOWING SECTION WAS ADDED APRIL 2005 C C ***************************************************** C ** TREAT THE SET PEAKS OVER THRESHOLD ITERATIONS * C ** * C ***************************************************** C IPOTIT=30 C CCCCC THE FOLLOWING SECTION WAS ADDED APRIL 2005 C C ***************************************************** C ** TREAT THE SET PEAKS OVER THRESHOLD INITIAL * C ** POINTS * C ***************************************************** C IPOTNP=-1 C CCCCC THE FOLLOWING SECTION WAS ADDED APRIL 2005 C C ***************************************************** C ** TREAT THE SET PEAKS OVER THRESHOLD INITIAL * C ** THRESHOLD * C ***************************************************** C PPOTTH=CPUMIN C CCCCC THE FOLLOWING SECTION WAS ADDED APRIL 2005 C C ***************************************************** C ** TREAT THE SET PEAKS OVER THRESHOLD INCREMENT * C ** * C ***************************************************** C PPOTIN=-1.0 C CCCCC THE FOLLOWING SECTION WAS ADDED APRIL 2005 C C ***************************************************** C ** TREAT THE SET PEAKS OVER THRESHOLD PERIOD * C ** * C ***************************************************** C PPOTPE=-1.0 C CCCCC THE FOLLOWING SECTION WAS ADDED APRIL 2005 C C ***************************************************** C ** TREAT THE SET PEAKS OVER THRESHOLD TOLERANCE * C ** * C ***************************************************** C PPOTTO=0.05 C CCCCC THE FOLLOWING SECTION WAS ADDED MAY 2005 C C ***************************************************** C ** TREAT THE SET FRECHET BIAS CORRECTED ** C ** ** C ***************************************************** C IFREBC='OFF' C CCCCC THE FOLLOWING SECTION WAS ADDED MAY 2005 C C ***************************************************** C ** TREAT THE SET GRUBBS ONE SIDED ** C ***************************************************** C IGRU1S='ON' C CCCCC THE FOLLOWING SECTION WAS ADDED JULY 2005 C C ***************************************************** C ** TREAT THE SET LOG GAMMA DEFINITION ** C ** ** C ***************************************************** C ILGADF='DEFA' C CCCCC THE FOLLOWING SECTION WAS ADDED JULY 2005 C C ***************************************************** C ** TREAT THE SET SKEW NORMAL DEFINITION ** C ** ** C ***************************************************** C ISKNDF='DEFA' C CCCCC THE FOLLOWING SECTION WAS ADDED JANUARY 2006 C C ***************************************************** C ** TREAT THE CAPTURE SCREEN ** C ***************************************************** C ICAPSC='OFF ' C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 2005 C C ***************************************************** C ** INITIATILE MACCRO ARGUMENTS ** C ***************************************************** C NMACAG=0 IDEFMS='$' IMACSC=IDEFMS IMACAR(1)=' ' IMACAR(2)=' ' IMACAR(3)=' ' IMACAR(4)=' ' IMACAR(5)=' ' IMACAR(6)=' ' IMACAR(7)=' ' IMACAR(8)=' ' IMACAR(9)=' ' IMACAR(10)=' ' C CCCCC THE FOLLOWING SECTION WAS ADDED FEBRUARY 2006 C C ***************************************************** C ** TREAT THE SET GENERALIZED TUKEY-LAMBDA ** C ** DEFINITION: ** C ***************************************************** C IGLDDF='FMKL' C CCCCC THE FOLLOWING SECTION WAS ADDED MARCH 2006 C C ***************************************************** C ** TREAT THE SET LOCAL FILES ** C ***************************************************** C ITMPFI='PID' C CCCCC THE FOLLOWING SECTION WAS ADDED MAY 2006 C C ***************************************************** C ** TREAT THE SET PPCC PLOT LOCATION SCALE ** C ** ** C ***************************************************** C IPPCBW='DEFA' C CCCCC THE FOLLOWING SECTION WAS ADDED MAY 2006 C C ***************************************************** C ** TREAT THE SET BETA GEOMETRIC DEFINITION ** C ** ** C ***************************************************** C IBGEDF='UNSH' C CCCCC THE FOLLOWING SECTION WAS ADDED JUNE 2006 C C ***************************************************** C ** TREAT THE SET FORTRAN FORMAT CONTROL ** C ** ** C ***************************************************** C IFORFM='ON' C CCCCC THE FOLLOWING SECTION WAS ADDED JUNE 2006 C C ***************************************************** C ** TREAT THE SET MANDEL PAULE ** C ** SET MODIFIED MANDEL PAULE ** C ** SET VANGEL RUHKIN ** C ** SET BOB ** C ** SET SCHILLER EBERHARDT ** C ** SET METHOD OF MEANS ** C ** SET GRAYBILL DEAL ** C ** SET GRAND MEANS ** C ** SET GENERALIZED CONFIDENCE INTERVALS ** C ** SET DERSIMONIAN LAIRD ** C ** SET FAIRWEATHER ** C ** ** C ***************************************************** C IMPACM='ON' IMMPCM='ON' IVRUCM='ON' IBOBCM='ON' ISCECM='ON' IMOMCM='ON' IGRDCM='ON' IGMECM='ON' IGCICM='ON' IDSLCM='ON' IFAICM='ON' IBCPCM='ON' C CCCCC THE FOLLOWING SECTION WAS ADDED JULY 2006 C C ***************************************************** C ** TREAT THE SET GEETA DEFINITION ** C ** ** C ***************************************************** C IGETDF='MU ' C CCCCC THE FOLLOWING SECTION WAS ADDED JULY 2006 C C ***************************************************** C ** TREAT THE SET CHISQUARE LIMIT ** C ***************************************************** C PCHSLM=1000000.0 C CCCCC THE FOLLOWING SECTION WAS ADDED OCTOBER 2006 C C ***************************************************** C ** TREAT THE SET MAXWELL LOCATION ** C ***************************************************** C PMAXLO=0.0 C CCCCC THE FOLLOWING SECTION WAS ADDED AUGUST 2006 C C ***************************************************** C ** TREAT THE SET CONSUL DEFINITION ** C ** ** C ***************************************************** C ICONDF='MU ' C CCCCC THE FOLLOWING SECTION WAS ADDED OCTOBER 2006 C C ***************************************************** C ** TREAT THE SET 4PLOT DISTRIBUTION ** C ** ** C ***************************************************** C I4PLDI='NORM' C C ******************************* C ** EXIT AND RETURN TO MAIN ** C ******************************* C 9000 CONTINUE IF(IBUGIN.EQ.'OFF')GOTO9999 WRITE(ICOUT,9990) 9990 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9995) 9995 FORMAT('***** AT THE END OF INITSU--') CALL DPWRST('XXX','BUG ') 9999 CONTINUE C RETURN END SUBROUTINE INIT3D(IBUGIN) C C PURPOSE--THIS IS SUBROUTING INIT3D. C (THE 3D AT THE END OF INIT3D STANDS FOR 3-DIMENSION) C THIS SUBROUTINE INITIALIZES 3-D VARIABLES AND PARAMETERS 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--88/10 C ORIGINAL VERSION--SEPTEMBER 1988. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IBUGIN C CCCCC CHARACTER*4 IDEFGC C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCOMC.INC' INCLUDE 'DPCO3D.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IF(IBUGIN.EQ.'OFF')GOTO99 WRITE(ICOUT,90) 90 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,95) 95 FORMAT('***** AT THE BEGINNING OF INIT3D--') CALL DPWRST('XXX','BUG ') 99 CONTINUE C C ************************************************** C ** SET THE 3-D GENERAL SETTINGS ** C ************************************************** C IVISSW='ON' I3DPRO='PERS' C AEYEXC=CPUMIN AEYEYC=CPUMIN AEYEZC=CPUMIN C AORIXC=CPUMIN AORIYC=CPUMIN AORIZC=CPUMIN C C ************************************************** C ** SET THE 3-D PEDESTAL ATTRIBUTES ** C ************************************************** C IDEPGC='WHIT' IDEPGP='SOLI' IDEPGR='OFF' IDEPCO='BLUE' C IPEDGC=IDEPGC IPEDGP=IDEPGP IPEDGR=IDEPGR IPEDCO=IDEPCO IPEDSW='OFF' C ADEPBA=CPUMIN ADEPSZ=CPUMIN C APEDBA=ADEPBA APEDSZ=ADEPSZ C C ************************************************** C ** SET THE 3-D BASEPLANE ATTRIBUTES ** C ************************************************** C IDBSGC='WHIT' IDBSGP='SOLI' IDBSGR='OFF' IDBSCO='BLUE' C IBSPGC=IDBSGC IBSPGP=IDBSGP IBSPGR=IDBSGR IBSPCO=IDBSCO IBSPSW='OFF' C C ************************************************** C ** SET THE 3-D BACKPLANE ATTRIBUTES ** C ************************************************** C IDBKGC='WHIT' IDBKGP='SOLI' IDBKGR='OFF' IDBKCO='BLUE' C IBKPGC=IDBKGC IBKPGP=IDBKGP IBKPGR=IDBKGR IBKPCO=IDBKCO IBKPSW='OFF' C C ************************************************** C ** SET THE 3-D SIDEFACE ATTRIBUTES ** C ************************************************** C IDSDGC='WHIT' IDSDGP='SOLI' IDSDGR='OFF' IDSDCO='BLUE' C ISDFGC=IDSDGC ISDFGP=IDSDGP ISDFGR=IDSDGR ISDFCO=IDSDCO ISDFSW='OFF' C C ************************************************** C ** SET THE RAW 3-D DATA ** C ************************************************** C X3DMIN=CPUMIN Y3DMIN=CPUMIN Z3DMIN=CPUMIN C X3DMAX=CPUMIN Y3DMAX=CPUMIN Z3DMAX=CPUMIN C X3DMID=CPUMIN Y3DMID=CPUMIN Z3DMID=CPUMIN C X3DRAN=CPUMIN Y3DRAN=CPUMIN Z3DRAN=CPUMIN C X3DEYE=CPUMIN Y3DEYE=CPUMIN Z3DEYE=CPUMIN C X3DORI=CPUMIN Y3DORI=CPUMIN Z3DORI=CPUMIN C D3DCXX=CPUMIN D3DCXY=CPUMIN D3DCXZ=CPUMIN D3DCYX=CPUMIN D3DCYY=CPUMIN D3DCYZ=CPUMIN D3DCZX=CPUMIN D3DCZY=CPUMIN D3DCZZ=CPUMIN C C ******************************* C ** EXIT AND RETURN TO MAIN ** C ******************************* C 9000 CONTINUE IF(IBUGIN.EQ.'OFF')GOTO9999 WRITE(ICOUT,9990) 9990 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9995) 9995 FORMAT('***** AT THE END OF INIT3D--') CALL DPWRST('XXX','BUG ') 9999 CONTINUE C RETURN END FUNCTION INITS (OS, NOS, ETA) C***BEGIN PROLOGUE INITS C***PURPOSE Determine the number of terms needed in an orthogonal C polynomial series so that it meets a specified accuracy. C***LIBRARY SLATEC (FNLIB) C***CATEGORY C3A2 C***TYPE SINGLE PRECISION (INITS-S, INITDS-D) C***KEYWORDS CHEBYSHEV, FNLIB, INITIALIZE, ORTHOGONAL POLYNOMIAL, C ORTHOGONAL SERIES, SPECIAL FUNCTIONS C***AUTHOR Fullerton, W., (LANL) C***DESCRIPTION C C Initialize the orthogonal series, represented by the array OS, so C that INITS is the number of terms needed to insure the error is no C larger than ETA. Ordinarily, ETA will be chosen to be one-tenth C machine precision. C C Input Arguments -- C OS single precision array of NOS coefficients in an orthogonal C series. C NOS number of coefficients in OS. C ETA single precision scalar containing requested accuracy of C series. C C***REFERENCES (NONE) C***ROUTINES CALLED XERMSG C***REVISION HISTORY (YYMMDD) C 770401 DATE WRITTEN C 890831 Modified array declarations. (WRB) C 891115 Modified error message. (WRB) C 891115 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) C***END PROLOGUE INITS REAL OS(*) 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***FIRST EXECUTABLE STATEMENT INITS IF (NOS .LT. 1) THEN WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,12) CALL DPWRST('XXX','BUG ') INITS = 0.0 RETURN ENDIF 11 FORMAT('***** ERROR FROM INITS. THE NUMBER OF ') 12 FORMAT(' COEFFICIENTS IS LESS THAN 1. *****') C ERR = 0. DO 10 II = 1,NOS I = NOS + 1 - II ERR = ERR + ABS(OS(I)) IF (ERR.GT.ETA) GO TO 20 10 CONTINUE C 20 IF (I .EQ. NOS) THEN WRITE(ICOUT,21) 21 FORMAT('***** ERROR FROM INITS. CHEBYSHEV SERIES TOO ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,22) 22 FORMAT(' SHORT FOR SPECIFIED ACCURACY. *****') CALL DPWRST('XXX','BUG ') ENDIF INITS = I C RETURN END SUBROUTINE INOUT(XA,YA,X,Y,NP,IO) 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 C AND ATAN2D TO ATAN2 C (ATAN2D IS A VAX DOUB. PREC. ATAN2) C (ALAN HECKERT). C C--------------------------------------------------------------------- C DIMENSION X(*) DIMENSION Y(*) C C-----START POINT----------------------------------------------------- C AS=0. XX=X(1)-XA YY=Y(1)-YA CCCCC A0=ATAN2D(YY,XX) A0=ATAN2(YY,XX) DO 10 N=2,NP+1 M=MOD(N-1,NP)+1 XX=X(M)-XA YY=Y(M)-YA CCCCC A=ATAN2D(YY,XX) A=ATAN2(YY,XX) DA=A-A0 IF (DA.LT.-180.) DA=DA+360. IF (DA.GT.180.) DA=DA-360. AS=AS+DA A0=A 10 CONTINUE IF (ABS(AS).LT.180.) THEN IO=0 ELSE IO=1 END IF RETURN END SUBROUTINE INTARR(X,NX,IWRITE,Y,NY,IBUGA3,IERROR) C C PURPOSE--COMPUTE INTERARRIVAL TIMES OF A SERIES OF FAILURE C TIMES. C SORT FAILURE TIMES C Y(1) = X(1) C Y(2) = X(2)-X(1) C Y(2) = X(3)-X(2) C Y(3) = X(4)-X(3) C ETC. C NOTE--IT IS PERMISSIBLE TO HAVE THE OUTPUT VECTOR Y(.) C BEING IDENTICAL TO THE INPUT VECTOR X(.). 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--98/5 C ORIGINAL VERSION--MAY 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 DIMENSION X(*) DIMENSION Y(*) 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='INTA' ISUBN2='RR ' 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 INTARR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)NX 53 FORMAT('NX = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,NX 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 SEQUENTIAL DIFFERENCE. ** C ************************************** C CALL SORT(X,NX,X) NXM1=NX-1 IF(NXM1.LT.1)GOTO150 DO100I=NX,2,-1 IP1=I-1 Y(I)=X(I)-X(IP1) 100 CONTINUE Y(1)=X(1) NY=NX GOTO190 C 150 CONTINUE IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,151) 151 FORMAT('***** ERROR IN INTARR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,152) 152 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,153) 153 FORMAT(' IN THE VARIABLE FOR WHICH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,154) 154 FORMAT(' THE INTERARRIVAL TIMES ARE TO BE COMPUTED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,155) 155 FORMAT(' MUST BE 2 OR LARGER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,156) 156 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,157)NX 157 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 1'.') CALL DPWRST('XXX','BUG ') C 190 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE C IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF INTARR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)NX,NY 9013 FORMAT('NX,NY = ',2I8) CALL DPWRST('XXX','BUG ') DO9015I=1,NX WRITE(ICOUT,9016)I,X(I),Y(I) 9016 FORMAT('I,X(I),Y(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE INTERP(Y,X,N,X2,N2,IWRITE,Y2,IBUGG3,ISUBRO,IERROR) CCCCC ADD ISUBRO ARGUMENT MAY, 1994. CCCCC SUBROUTINE INTERP(Y,X,N,X2,N2,IWRITE,Y2,IBUGG3,IERROR) C C PURPOSE--COMPUTE SPLINE INTERPOLATION OF A VARIABLE C (GENERATE INTERPOLATED POINTS). C INPUT ARGUMENTS--Y = SINGLE PRECISION VARIABLE C CONTAINING THE ORIGINAL C VERTICAL AXIS DATA POINTS. C --X = SINGLE PRECISION VARIABLE C CONTAINING THE ORIGINAL C HORIZONTAL AXIS DATA POINTS. C --X2 = SINGLE PRECISION VARIABLE C CONTAINING THE DESIRED C HORIZONTAL AXIS INTERPOLATION C POINTS. C OUTPUT ARGUMENTS--Y2 = SINGLE PRECISION VARIABLE C CONTAINING THE COMPUTED C VERTICAL AXIS INTERPOLATION C POINTS. C NOTE--IT IS PROBABLY NOT PERMISSIBLE TO HAVE THE OUTPUT VECTOR Y2(.) C BEING IDENTICAL TO THE INPUT VECTOR Y(.) C NOTE--THIS SUBROUTINE DOES NOT ASSUME THAT THE INPUT C DATA IS ALREADY SORTED ACCORDING TO THE C HORIZONTAL AXIS VARIABLE. C SUCH SORTING IS DOEN HEREIN. C CAUTION--THE INPUT VECTORS Y AND X ARE SORTED HEREIN C AND SO MAY BE DIFFERENT UPON LEAVING THIS SUBROUTINE C THAN UPON ENTERING THIS SUBROUTINE. 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--87/4 C ORIGINAL VERSION--APRIL 1987. C UPDATED --MAY 1989. SORT THE INPUT DATA C UPDATED --JUNE 1990. TEMPORARY ARRAYS TO GARBAGE COMMON. C ARRAY DECLARATIONS MOVED FROM INTER2 C UPDATED --MAY 1994. ADD ISUBRO ARGUMENT C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGG3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION Y(*) DIMENSION X(*) DIMENSION X2(*) DIMENSION Y2(*) C DIMENSION YTEMP(MAXOBV) DIMENSION YDIST(MAXOBV) DIMENSION XDIST(MAXOBV) C DIMENSION DELX(MAXOBV) DIMENSION DELY(MAXOBV) DIMENSION DERIV(MAXOBV) DIMENSION DELX6(MAXOBV) DIMENSION P(MAXOBV) DIMENSION B(MAXOBV) DIMENSION Z(MAXOBV) DIMENSION C(4,MAXOBV) DIMENSION A(MAXOBV,3) CCCCC FOLLOWING LINES ADDED JUNE, 1990 INCLUDE 'DPCOZZ.INC' INCLUDE 'DPCOZ2.INC' EQUIVALENCE (G2RBAG(IGAR11),YTEMP(1)) EQUIVALENCE (G2RBAG(IGAR12),YDIST(1)) EQUIVALENCE (G2RBAG(IGAR13),XDIST(1)) EQUIVALENCE (G2RBAG(IGAR14),DELX(1)) EQUIVALENCE (G2RBAG(IGAR15),DELY(1)) EQUIVALENCE (G2RBAG(IGAR16),DERIV(1)) EQUIVALENCE (G2RBAG(IGAR17),DELX6(1)) EQUIVALENCE (G2RBAG(IGAR18),P(1)) EQUIVALENCE (G2RBAG(IGAR19),B(1)) EQUIVALENCE (G2RBAG(IGAR20),Z(1)) EQUIVALENCE (G2RBAG(IGAR21),C(1,1)) EQUIVALENCE (G2RBAG(IGAR25),A(1,1)) CCCCC END CHANGE 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='INTE' ISUBN2='RP ' C IERROR='NO' C IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'TERP')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF INTERP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)N 52 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,Y(I),X(I) 56 FORMAT('I,Y(I),X(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE WRITE(ICOUT,62)N2 62 FORMAT('N2 = ',I8) CALL DPWRST('XXX','BUG ') DO65I=1,N2 WRITE(ICOUT,66)I,X2(I) 66 FORMAT('I,X2(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 65 CONTINUE 90 CONTINUE C C **************************************** C ** STEP 11-- ** C ** SORT THE INPUT DATA ACCORDING ** C ** TO THE HORIZONTAL AXIS VARIABLE ** C **************************************** C CCCCC THE FOLLOWING LINE WAS INSERTED MAY 1989 CALL SORTC(X,Y,N,X,Y) C C ******************************************************** C ** STEP 12-- ** C ** DETERMINE THE NUMBER OF DISTINCT X VALUES ** C ******************************************************** C ISTEPN='12' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'TERP') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NDIST=0 DO1210I=1,N IF(NDIST.EQ.0)GOTO1220 DO1215I2=1,NDIST IF(X(I).EQ.XDIST(I2))GOTO1210 1215 CONTINUE 1220 CONTINUE NDIST=NDIST+1 XDIST(NDIST)=X(I) 1210 CONTINUE C CALL SORT(XDIST,NDIST,XDIST) C C ***************************************************** C ** STEP 13-- ** C ** IF ALL DISTINCT (THAT IS, NO REPLICATION), ** C ** (THAT IS, HAVE NO REPLICATION), ** C ** THEN COPY OVER Y VALUES. ** C ** IF NOT ALL DISTINCT ** C ** (THAT IS, HAVE SOME REPLICATION), ** C ** THEN COMPUTE A MEAN VALUE OVER THE REPLICATES ** C ** AND TREAT THAT AS THE COMMON VALUE. ** C ** THE CORE OF THE INTERPOLATION CODE ** C ** IS EXPECTING SORTED, DISTINCT X VALUES. ** C ***************************************************** C IF(NDIST.EQ.N)GOTO1310 GOTO1320 C 1310 CONTINUE DO1311K=1,NDIST YDIST(K)=Y(K) 1311 CONTINUE GOTO1390 C 1320 CONTINUE DO1321K=1,NDIST TAG=XDIST(K) J=0 DO1322I=1,N IF(X(I).EQ.TAG)GOTO1323 GOTO1322 1323 CONTINUE J=J+1 YTEMP(J)=Y(I) 1322 CONTINUE NI=J CALL MEAN(YTEMP,NI,IWRITE,YMEAN,IBUGG3,IERROR) YDIST(K)=YMEAN 1321 CONTINUE GOTO1390 C 1390 CONTINUE C C ******************************************** C ** STEP 14-- ** C ** COMPUTE INTERPOLATED VALUES ** C ******************************************** C CCCCC THE REMAINDER OF THIS SUBROUTINE WAS REPLACED MAY 1989 CCCCC BY A CALL TO INTER2 MAY 1989 C CCCCC JUNE, 1990. MOVE SOME DIMENSIONING FROM INTER2 TO INTERP CALL INTER2(YDIST,XDIST,NDIST,X2,N2,Y2, 1DELX,DELY,DERIV,DELX6,P,B,Z,C,A,MAXOBV, CCCCC ADD ISUBRO ARGUMENT MAY, 1994. CCCCC1IBUGG3,IERROR) 1IBUGG3,ISUBRO,IERROR) C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'TERP')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF INTERP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)N,N2 9012 FORMAT('N,N2 = ',2I8) CALL DPWRST('XXX','BUG ') DO9015I=1,N WRITE(ICOUT,9016)A(I,1),A(I,2),A(I,3) 9016 FORMAT('A(I,1),A(I,2),A(I,3) = ',3E15.7) CALL DPWRST('XXX','BUG ') 9015 CONTINUE DO9025I=1,N WRITE(ICOUT,9026)DELX(I),DELY(I),DERIV(I),DELX6(I),B(I),Z(I) 9026 FORMAT('DELX(I),DELY(I),DERIV(I),DELX6(I),B(I),Z(I) = ', 16F10.5) CALL DPWRST('XXX','BUG ') 9025 CONTINUE DO9035I=1,N WRITE(ICOUT,9036)C(1,I),C(2,I),C(3,I),C(4,I) 9036 FORMAT('C(1,I),C(2,I),C(3,I),C(4,I) = ',4F10.5) CALL DPWRST('XXX','BUG ') 9035 CONTINUE WRITE(ICOUT,9041)N2 9041 FORMAT('N2 = ',I8) CALL DPWRST('XXX','BUG ') DO9042I=1,N2 WRITE(ICOUT,9043)I,X2(I),Y2(I) 9043 FORMAT('I,X2(I),Y2(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 9042 CONTINUE WRITE(ICOUT,9051)NDIST 9051 FORMAT('NDIST = ',I8) CALL DPWRST('XXX','BUG ') DO9052I=1,NDIST WRITE(ICOUT,9053)I,XDIST(I),YDIST(I) 9053 FORMAT('I,XDIST(I),YDIST(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 9052 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE INTER2(Y,X,N,X2,N2,Y2, 1DELX,DELY,DERIV,DELX6,P,B,Z,C,A,MAXOBV, 1IBUGG3,ISUBRO,IERROR) CCCCC1IBUGG3,IERROR) CCCCC MAY, 1994. ADD ISUBRO ARGUMENT CCCCC JUNE, 1990. SOME DIMENSIONING MOVED FROM INTER2 TO INTERP C C PURPOSE--COMPUTE SPLINE INTERPOLATION OF A VARIABLE C (GENERATE INTERPOLATED POINTS). C INPUT ARGUMENTS--Y = SINGLE PRECISION VARIABLE C CONTAINING THE ORIGINAL C VERTICAL AXIS DATA POINTS. C --X = SINGLE PRECISION VARIABLE C CONTAINING THE ORIGINAL C HORIZONTAL AXIS DATA POINTS. C --X2 = SINGLE PRECISION VARIABLE C CONTAINING THE DESIRED C HORIZONTAL AXIS INTERPOLATION C POINTS. C OUTPUT ARGUMENTS--Y2 = SINGLE PRECISION VARIABLE C CONTAINING THE COMPUTED C VERTICAL AXIS INTERPOLATION C POINTS. C NOTE--IT IS PROBABLY NOT PERMISSIBLE TO HAVE THE OUTPUT VECTOR Y2(.) C BEING IDENTICAL TO THE INPUT VECTOR Y(.) C NOTE--THIS SUBROUTINE DOES NOT ASSUME THAT THE INPUT C DATA IS ALREADY SORTED ACCORDING TO THE C HORIZONTAL AXIS VARIABLE. C SUCH SORTING IS DOEN HEREIN. C CAUTION--THE INPUT VECTORS Y AND X ARE SORTED HEREIN C AND SO MAY BE DIFFERENT UPON LEAVING THIS SUBROUTINE C THAN UPON ENTERING THIS SUBROUTINE. 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--87/4 C ORIGINAL VERSION--APRIL 1987. C UPDATED --MAY 1989. SORT THE INPUT DATA C UPDATED --JUNE 1990. MOVE DIMENSIONS FROM INTER2 TO INTERP C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IBUGG3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CCCCC CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C CCCCC JUNE, 1990. FOLLOWING INCLUDE FILE NO LONGER NEEDED CCCCC INCLUDE 'DPCOPA.INC' C DIMENSION Y(*) DIMENSION X(*) DIMENSION X2(*) DIMENSION Y2(*) C CCCCC JUNE, 1990. FOLLOWING DIMENSIONS NOW DONE IN INTERP CCCCC DIMENSION DELX(MAXOBV) CCCCC DIMENSION DELY(MAXOBV) CCCCC DIMENSION DERIV(MAXOBV) CCCCC DIMENSION DELX6(MAXOBV) CCCCC DIMENSION P(MAXOBV) CCCCCCDIMENSION B(MAXOBV) CCCCC DIMENSION Z(MAXOBV) DIMENSION DELX(*) DIMENSION DELY(*) DIMENSION DERIV(*) DIMENSION DELX6(*) DIMENSION P(*) DIMENSION B(*) DIMENSION Z(*) DIMENSION C(4,MAXOBV) DIMENSION A(MAXOBV,3) 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='INTE' ISUBN2='RP ' C IERROR='NO' C IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'TER2')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF INTER2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)N 52 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,Y(I),X(I) 56 FORMAT('I,Y(I),X(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE WRITE(ICOUT,62)N2 62 FORMAT('N2 = ',I8) CALL DPWRST('XXX','BUG ') DO65I=1,N2 WRITE(ICOUT,66)I,X2(I) 66 FORMAT('I,X2(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 65 CONTINUE 90 CONTINUE C NM1=N-1 NM2=N-2 C C ******************************************** C ** STEP 21-- ** C ** FORM FIRST DIFFERENCES AND THE RATIOS ** C ******************************************** C DO2100I=1,NM1 IP1=I+1 DELX(I)=X(IP1)-X(I) DELY(I)=Y(IP1)-Y(I) DERIV(I)=DELY(I)/DELX(I) DELX6(I)=DELX(I)/6.0 2100 CONTINUE C C ********************************** C ** STEP 22-- ** C ** FORM DIFFERENCES OF RATIOS ** C ********************************** C DO2200I=2,NM1 IM1=I-1 B(I)=DERIV(I)-DERIV(IM1) 2200 CONTINUE C C ********************** C ** STEP 23-- C ********************** C A(1,2)=(-1.0-DELX(1)/DELX(2)) A(1,3)=DELX(1)/DELX(2) A(2,3)=DELX6(2)-DELX6(1)*A(1,3) A(2,2)=2.0*(DELX6(1)+DELX6(2))-DELX6(1)*A(1,2) A(2,3)=A(2,3)/A(2,2) B(2)=B(2)/A(2,2) C C **************************************** C ** STEP 24-- C **************************************** C DO2400I=3,NM1 IM1=I-1 A(I,2)=2.0*(DELX6(IM1)+DELX6(I))-DELX6(IM1)*A(IM1,3) B(I)=B(I)-DELX6(IM1)*B(IM1) A(I,3)=DELX6(I)/A(I,2) B(I)=B(I)/A(I,2) 2400 CONTINUE C C **************************************** C ** STEP 25-- C **************************************** C Q=DELX(NM2)/DELX(NM1) A(N,1)=1.0+Q+A(NM2,3) A(N,2)=(-Q-A(N,1)*A(NM1,3)) B(N)=B(NM2)-A(N,1)*B(NM1) Z(N)=B(N)/A(N,2) C C **************************************** C ** STEP 26-- C **************************************** C DO2600I=1,NM2 K=N-I KP1=K+1 Z(K)=B(K)-A(K,3)*Z(KP1) 2600 CONTINUE Z(1)=(-A(1,2)*Z(2)-A(1,3)*Z(3)) C C **************************************** C ** STEP 27-- ** C **************************************** C DO2700I=1,NM1 IP1=I+1 Q=1.0/(6.0*DELX(I)) C(1,I)=Z(I)*Q C(2,I)=Z(IP1)*Q C(3,I)=Y(I)/DELX(I)-Z(I)*DELX6(I) C(4,I)=Y(IP1)/DELX(I)-Z(IP1)*DELX6(I) 2700 CONTINUE C C **************************************** C ** STEP 28-- C ** PRINT OUT Z'S C **************************************** C IF(IBUGG3.EQ.'OFF')GOTO2890 DO2800I=1,N WRITE(ICOUT,2810)I,Z(I) 2810 FORMAT('I,Z(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 2800 CONTINUE 2890 CONTINUE C C **************************************** C ** STEP 31-- C ** COMPUTE INTERPOLATION VALUES C **************************************** C DO3100J=1,N2 XT=X2(J) IF(X(1).GT.XT)GOTO3110 GOTO3119 C 3110 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3111) 3111 FORMAT('***** ERROR IN INTER2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3112) 3112 FORMAT(' AN ATTEMPT WAS MADE TO COMPUTE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3113) 3113 FORMAT(' A SMOOTHED VALUE BEYOND THE RANGE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3114) 3114 FORMAT(' OF THE DATA--SUCH EXTRAPOLATION') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3115) 3115 FORMAT(' IS UNRELIABLE AND NOT PERMITTED.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3116)X(1) 3116 FORMAT(' SMALLEST DATA POINT X(1) = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3117)XT 3117 FORMAT(' ATTEMPTED EXTRAPOLATION POINT = ',E15.7) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 3119 CONTINUE C DO3200I=1,N I2=I IF(X(I).EQ.XT)GOTO3210 IF(X(I).GT.XT)GOTO3220 3200 CONTINUE C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3201) 3201 FORMAT('***** ERROR IN INTER2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3202) 3202 FORMAT(' AN ATTEMPT WAS MADE TO COMPUTE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3203) 3203 FORMAT(' A SMOOTHED VALUE BEYOND THE RANGE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3204) 3204 FORMAT(' OF THE DATA--SUCH EXTRAPOLATION') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3205) 3205 FORMAT(' IS UNRELIABLE AND NOT PERMITTED.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3206)X(1) 3206 FORMAT(' LARGEST DATA POINT X(1) = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3207)XT 3207 FORMAT(' ATTEMPTED EXTRAPOLATION POINT = ',E15.7) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 3210 CONTINUE Y2(J)=Y(I2) GOTO3100 C 3220 CONTINUE K=I2-1 KP1=K+1 DELU=X(KP1)-XT DELL=XT-X(K) TERM1=DELU*(C(1,K)*DELU**2+C(3,K)) TERM2=DELL*(C(2,K)*DELL**2+C(4,K)) Y2(J)=TERM1+TERM2 3100 CONTINUE C C **************************************** C ** STEP 41-- C ** IF CALLED FOR, C ** WRITE OUT INTERPOLATION VALUES C **************************************** C IF(IBUGG3.EQ.'OFF')GOTO4190 DO4100J=1,N2 WRITE(ICOUT,4110)X2(J),Y2(J) CALL DPWRST('XXX','BUG ') 4110 FORMAT('X2(J),Y2(J) = ',2E15.7) 4100 CONTINUE 4190 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'TER2')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF INTER2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)N,N2 9012 FORMAT('N,N2 = ',2I8) CALL DPWRST('XXX','BUG ') DO9015I=1,N WRITE(ICOUT,9016)A(I,1),A(I,2),A(I,3) 9016 FORMAT('A(I,1),A(I,2),A(I,3) = ',3E15.7) CALL DPWRST('XXX','BUG ') 9015 CONTINUE DO9025I=1,N WRITE(ICOUT,9026)DELX(I),DELY(I),DERIV(I),DELX6(I),B(I),Z(I) 9026 FORMAT('DELX(I),DELY(I),DERIV(I),DELX6(I),B(I),Z(I) = ', 16F10.5) CALL DPWRST('XXX','BUG ') 9025 CONTINUE DO9035I=1,N WRITE(ICOUT,9036)C(1,I),C(2,I),C(3,I),C(4,I) 9036 FORMAT('C(1,I),C(2,I),C(3,I),C(4,I) = ',4F10.5) CALL DPWRST('XXX','BUG ') 9035 CONTINUE WRITE(ICOUT,9041)N2 9041 FORMAT('N2 = ',I8) CALL DPWRST('XXX','BUG ') DO9042I=1,N2 WRITE(ICOUT,9043)I,X2(I),Y2(I) 9043 FORMAT('I,X2(I),Y2(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 9042 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE INTRV(XT,LXT,X,ILO,ILEFT,MFLAG) C***BEGIN PROLOGUE INTRV C***DATE WRITTEN 800901 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. E3,K6 C***KEYWORDS B-SPLINE,DATA FITTING,INTERPOLATION,SPLINE C***AUTHOR AMOS, D. E., (SNLA) C***PURPOSE Computes the largest integer ILEFT in 1.LE.ILEFT.LE.LXT C such that XT(ILEFT).LE.X where XT(*) is a subdivision C of the X interval. C***DESCRIPTION C C Written by Carl de Boor and modified by D. E. Amos C C Reference C SIAM J. Numerical Analysis, 14, No. 3, June 1977, pp. 441-472. C C Abstract C INTRV is the INTERV routine of the reference. C C INTRV computes the largest integer ILEFT in 1 .LE. ILEFT .LE. C LXT such that XT(ILEFT) .LE. X where XT(*) is a subdivision of C the X interval. Precisely, C C X .LT. XT(1) 1 -1 C if XT(I) .LE. X .LT. XT(I+1) then ILEFT=I , MFLAG=0 C XT(LXT) .LE. X LXT 1, C C That is, when multiplicities are present in the break point C to the left of X, the largest index is taken for ILEFT. C C Description of Arguments C Input C XT - XT is a knot or break point vector of length LXT C LXT - length of the XT vector C X - argument C ILO - an initialization parameter which must be set C to 1 the first time the spline array XT is C processed by INTRV. C C Output C ILO - ILO contains information for efficient process- C ing after the initial call, and ILO must not be C changed by the user. Distinct splines require C distinct ILO parameters. C ILEFT - largest integer satisfying XT(ILEFT) .LE. X C MFLAG - signals when X lies out of bounds C C Error Conditions C None C***REFERENCES C. DE BOOR, *PACKAGE FOR CALCULATING WITH B-SPLINES*, C SIAM JOURNAL ON NUMERICAL ANALYSIS, VOLUME 14, NO. 3, C JUNE 1977, PP. 441-472. C***ROUTINES CALLED (NONE) C***END PROLOGUE INTRV C C INTEGER IHI, ILEFT, ILO, ISTEP, LXT, MFLAG, MIDDLE REAL X, XT DIMENSION XT(LXT) C***FIRST EXECUTABLE STATEMENT INTRV IHI = ILO + 1 IF (IHI.LT.LXT) GO TO 10 IF (X.GE.XT(LXT)) GO TO 110 IF (LXT.LE.1) GO TO 90 ILO = LXT - 1 IHI = LXT C 10 IF (X.GE.XT(IHI)) GO TO 40 IF (X.GE.XT(ILO)) GO TO 100 C C *** NOW X .LT. XT(IHI) . FIND LOWER BOUND ISTEP = 1 20 IHI = ILO ILO = IHI - ISTEP IF (ILO.LE.1) GO TO 30 IF (X.GE.XT(ILO)) GO TO 70 ISTEP = ISTEP*2 GO TO 20 30 ILO = 1 IF (X.LT.XT(1)) GO TO 90 GO TO 70 C *** NOW X .GE. XT(ILO) . FIND UPPER BOUND 40 ISTEP = 1 50 ILO = IHI IHI = ILO + ISTEP IF (IHI.GE.LXT) GO TO 60 IF (X.LT.XT(IHI)) GO TO 70 ISTEP = ISTEP*2 GO TO 50 60 IF (X.GE.XT(LXT)) GO TO 110 IHI = LXT C C *** NOW XT(ILO) .LE. X .LT. XT(IHI) . NARROW THE INTERVAL 70 MIDDLE = (ILO+IHI)/2 IF (MIDDLE.EQ.ILO) GO TO 100 C NOTE. IT IS ASSUMED THAT MIDDLE = ILO IN CASE IHI = ILO+1 IF (X.LT.XT(MIDDLE)) GO TO 80 ILO = MIDDLE GO TO 70 80 IHI = MIDDLE GO TO 70 C *** SET OUTPUT AND RETURN 90 MFLAG = -1 ILEFT = 1 RETURN 100 MFLAG = 0 ILEFT = ILO RETURN 110 MFLAG = 1 ILEFT = LXT RETURN END SUBROUTINE INTVEC(Y,X,N,NUMVAR,IWRITE,XYINT,IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C INTEGRAL OF THE DATA IN THE INPUT VECTOR Y (IF NUMVAR = 1) C OR OF THE INTEGRAL OF Y (VERTICALLY) C WITH RESPECT TO X (HORIZONTALLY) (IF NUMVAR = 2). C NOTE--WHEN NUMVAR = 1, IT IS ASSUMED THAT THE C HORIZONTAL AXIS VARIABLE IS EQUALLY-SPACED C WITH UNIT SPACING. C NOTE--THE TRAPEZOID RULE IS USED. C INPUT ARGUMENTS--Y = THE SINGLE PRECISION VECTOR OF C VERTICAL AXIS OBSERVATIONS. C --X = THE SINGLE PRECISION VECTOR OF C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X. C OUTPUT ARGUMENTS--XYINT = THE SINGLE PRECISION VALUE OF THE C COMPUTED SAMPLE INTEGRAL. C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE C SAMPLE INTEGRAL. 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 INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--82.6 C ORIGINAL VERSION--JANUARY 1979. C UPDATED --JUNE 1979. C UPDATED --JULY 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 DOUBLE PRECISION DXI DOUBLE PRECISION DYI DOUBLE PRECISION DXIM1 DOUBLE PRECISION DYIM1 DOUBLE PRECISION DDELX DOUBLE PRECISION DDELY DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DSUM C DIMENSION X(*) DIMENSION Y(*) 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='INTV' ISUBN2='EC ' C IERROR='NO' C DXI=0.0D0 DYI=0.0D0 DXIM1=0.0D0 DYIM1=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 INTVEC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N,NUMVAR 53 FORMAT('N,NUMVAR = ',2I8) 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 ** COMPUTE (NUMERICAL) INTEGRAL ** 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 INTVEC--') 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 INTEGRAL 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 INTVEC--', 1'THE THIRD INPUT ARGUMENT (N) HAS THE VALUE 1') CALL DPWRST('XXX','BUG ') XYINT=0.0 GOTO9000 129 CONTINUE C IF(NUMVAR.EQ.1.OR.NUMVAR.EQ.2)GOTO139 IERROR='YES' 130 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,131) 131 FORMAT('***** INTERNAL ERROR IN INTVEC--', 1'THE FOURTH INPUT ARGUMENT (NUMVAR) HAS VALUE OTHER THAN 1 OR 2') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,132)NUMVAR 132 FORMAT(' NUMVAR = ',I8) CALL DPWRST('XXX','BUG ') GOTO9000 139 CONTINUE C HOLD=Y(1) DO145I=2,N IF(Y(I).NE.HOLD)GOTO149 145 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,146)HOLD 146 FORMAT('***** NON-FATAL DIAGNOSTIC IN INTVEC--', 1'THE FIRST INPUT ARGUMENT (A VECTOR Y) HAS ALL ELEMENTS = ', 1E15.7) CALL DPWRST('XXX','BUG ') GOTO190 149 CONTINUE C IF(NUMVAR.LE.1)GOTO159 HOLD=X(1) DO155I=2,N IF(Y(I).NE.HOLD)GOTO159 155 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,156)HOLD 156 FORMAT('***** NON-FATAL DIAGNOSTIC IN INTVEC--', 1'THE SECOND INPUT ARGUMENT (A VECTOR X) HAS ALL ELEMENTS = ', 1E15.7) CALL DPWRST('XXX','BUG ') XYINT=0.0 GOTO9000 159 CONTINUE C 190 CONTINUE C C **************************************** C ** STEP 2-- ** C ** COMPUTE THE (NUMERICAL) INTEGRAL ** C **************************************** C DSUM=0.0D0 I=1 IF(NUMVAR.EQ.1)DXI=I IF(NUMVAR.EQ.2)DXI=X(I) DYI=Y(1) DO200I=2,N DXIM1=DXI DYIM1=DYI IF(NUMVAR.EQ.1)DXI=I IF(NUMVAR.EQ.2)DXI=X(I) DYI=Y(I) DDELX=DXI-DXIM1 DDELY=DYI-DYIM1 DTERM1=DYIM1*DDELX DTERM2=DDELY*DDELX/2.0D0 DSUM=DSUM+DTERM1+DTERM2 200 CONTINUE XYINT=DSUM C C ******************************* C ** STEP 3-- ** C ** WRITE OUT A LINE ** C ** OF SUMMARY INFORMATION. ** C ******************************* C IF(IFEEDB.EQ.'OFF')GOTO890 IF(IWRITE.EQ.'OFF')GOTO890 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,811)N,XYINT 811 FORMAT('THE (TRAPEZOID RULE) INTEGRAL 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 INTVEC--') 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)DXI,DYI,DXIM1,DYIM1 9014 FORMAT('DXI,DYI,DXIM1,DYIM1 = ',4D15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)XYINT 9015 FORMAT('XYINT = ',E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE INT2D(Z,Y,X,N,Y2,NY,X2,NX,IWRITE,Z2,N2, 1IBUGG3,ISUBRO,IERROR) C C PURPOSE--COMPUTE BIVARIATE INTERPOLATION OF SCATTERED DATA. C THE INTERPOLATION IS GENERATED ON A GRID. C THE BILINEAR INTERPOLATION WORKS ON DATA THAT FORMS A C GRID TO POINTS NOT ON THE GRID WHILE THIS ROUTINE C INTERPOLATES NON-GRIDDED DATA TO FORM A GRID. C A TYPICAL USE OF THIS ROUTINE IS TO GENERATE A CONTOUR C PLOT FROM NON-GRIDDED DATA. C (GENERATE INTERPOLATED POINTS). C INPUT ARGUMENTS--Z = SINGLE PRECISION VARIABLE C CONTAINING THE ORIGINAL C Z AXIS DATA POINTS. C --Y = SINGLE PRECISION VARIABLE C CONTAINING THE ORIGINAL C VERTICAL AXIS DATA POINTS. C --X = SINGLE PRECISION VARIABLE C CONTAINING THE ORIGINAL C HORIZONTAL AXIS DATA POINTS. C --Y2 = SINGLE PRECISION VARIABLE C CONTAINING THE DESIRED C VERTICAL AXIS INTERPOLATION C --X2 = SINGLE PRECISION VARIABLE C CONTAINING THE DESIRED C HORIZONTAL AXIS INTERPOLATION C POINTS. C OUTPUT ARGUMENTS--Z2 = SINGLE PRECISION VARIABLE C CONTAINING THE COMPUTED C Z AXIS INTERPOLATION C POINTS. C NOTE--IT IS PROBABLY NOT PERMISSIBLE TO HAVE THE OUTPUT VECTOR C Y2(.) BEING IDENTICAL TO THE INPUT VECTOR Y(.) C NOTE--THIS SUBROUTINE DOES NOT ASSUME THAT THE INPUT C DATA IS ALREADY SORTED ACCORDING TO THE C HORIZONTAL AXIS VARIABLE. C SUCH SORTING IS DOEN HEREIN. C CAUTION--THE INPUT VECTORS Y AND X ARE SORTED HEREIN C AND SO MAY BE DIFFERENT UPON LEAVING THIS SUBROUTINE C THAN UPON ENTERING THIS SUBROUTINE. 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--94/5 C ORIGINAL VERSION--MAY 1994. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGG3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN CHARACTER*4 ISUBRO C CHARACTER*4 IHP CHARACTER*4 IHP2 CHARACTER*4 IHWUSE CHARACTER*4 MESSAG C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION Z(*) DIMENSION Y(*) DIMENSION X(*) DIMENSION X2(*) DIMENSION Y2(*) DIMENSION Z2(*) C DIMENSION YTEMP(MAXOBV) DIMENSION XTEMP(MAXOBV) DIMENSION YDIST(MAXOBV) DIMENSION XDIST(MAXOBV) DIMENSION ZDIST(MAXOBV) DIMENSION ZTEMP2(MAXOBV) DIMENSION ZTEMP(MAXOBV) DIMENSION XNEW(MAXOBV) DIMENSION YNEW(MAXOBV) DIMENSION IWORK(7*MAXOBV) DIMENSION WORK(7*MAXOBV) C INCLUDE 'DPCOZZ.INC' INCLUDE 'DPCOZ2.INC' INCLUDE 'DPCOZI.INC' EQUIVALENCE (G2RBAG(IGAR11),YTEMP(1)) EQUIVALENCE (G2RBAG(IGAR12),YDIST(1)) EQUIVALENCE (G2RBAG(IGAR13),XDIST(1)) EQUIVALENCE (G2RBAG(IGAR14),ZDIST(1)) EQUIVALENCE (G2RBAG(IGAR15),ZTEMP2(1)) EQUIVALENCE (G2RBAG(IGAR16),ZTEMP(1)) EQUIVALENCE (G2RBAG(IGAR17),XTEMP(1)) EQUIVALENCE (G2RBAG(IGAR18),XNEW(1)) EQUIVALENCE (G2RBAG(IGAR19),YNEW(1)) EQUIVALENCE (G2RBAG(IGAR20),WORK(1)) EQUIVALENCE (IGARBG(1),IWORK(1)) CCCCC END CHANGE C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C INCLUDE 'DPCOHK.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 ISUBN1='INT2' ISUBN2='D ' C IERROR='NO' C IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'NT2D')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF INT2D--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)N 52 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,Z(I),Y(I),X(I) 56 FORMAT('I,Z(I),Y(I),X(I) = ',I8,3E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE WRITE(ICOUT,62)NX,NY 62 FORMAT('NX, NY = ',2I8) CALL DPWRST('XXX','BUG ') DO65I=1,NX WRITE(ICOUT,66)I,X2(I) 66 FORMAT('I,X2(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 65 CONTINUE DO75I=1,NY WRITE(ICOUT,76)I,Y2(I) 76 FORMAT('I,Y2(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 75 CONTINUE 90 CONTINUE C C **************************************** C ** STEP 11-- ** C ** SORT THE INPUT DATA ACCORDING ** C ** TO THE HORIZONTAL AXIS VARIABLE ** C **************************************** C ISTEPN='11' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'NT2D') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO1010,I=1,N XTEMP(I)=X(I) 1010 CONTINUE C CALL SORTC(X,Y,N,X,Y) CALL SORTC(XTEMP,Z,N,XTEMP,Z) C C ******************************************************* C ** STEP 12-- ** C ** DETERMINE THE NUMBER OF DISTINCT X VALUES ** C ******************************************************* C ISTEPN='12' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'NT2D') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NDISTX=0 DO1210I=1,N IF(NDISTX.EQ.0)GOTO1220 DO1215I2=1,NDISTX IF(X(I).EQ.XDIST(I2))GOTO1210 1215 CONTINUE 1220 CONTINUE NDISTX=NDISTX+1 XDIST(NDISTX)=X(I) 1210 CONTINUE C CALL SORT(XDIST,NDISTX,XDIST) C C ******************************************************* C ** STEP 13-- ** C ** DETERMINE THE NUMBER OF DISTINCT Y VALUES ** C ******************************************************* C ISTEPN='13' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'NT2D') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NDISTY=0 DO1310I=1,N IF(NDISTY.EQ.0)GOTO1320 DO1315I2=1,NDISTY IF(Y(I).EQ.YDIST(I2))GOTO1310 1315 CONTINUE 1320 CONTINUE NDISTY=NDISTY+1 YDIST(NDISTY)=Y(I) 1310 CONTINUE C CALL SORT(YDIST,NDISTY,YDIST) C C ******************************************************* C ** STEP 14-- ** C ** SORT Y ASSOCIATED WITH EACH DISTINCT X VALUE ** C ** CHECK FOR REPLICATION OF POINTS ** C ** IF ALL DISTINCT (THAT IS, NO REPLICATION), ** C ** (THAT IS, HAVE NO REPLICATION), ** C ** THEN COPY OVER Z VALUES. ** C ** IF NOT ALL DISTINCT ** C ** (THAT IS, HAVE SOME REPLICATION), ** C ** THEN COMPUTE A MEAN VALUE OVER THE REPLICATES ** C ** AND TREAT THAT AS THE COMMON VALUE. ** C ******************************************************* C ISTEPN='14' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'NT2D') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMZ=0 ISTART=1 DO1410I=1,NDISTX XT=XDIST(I) ICOUNT=0 DO1420J=ISTART,N IF(X(J).EQ.XT)THEN IF(ICOUNT.EQ.0)IFRST=J ICOUNT=ICOUNT+1 YTEMP(ICOUNT)=Y(J) ZTEMP(ICOUNT)=Z(J) ILAST=J ELSEIF(X(J).GT.XT)THEN GOTO1421 ENDIF 1420 CONTINUE 1421 CONTINUE C ISTART=ILAST+1 CALL SORTC(YTEMP,ZTEMP,ICOUNT,YTEMP,ZTEMP) DO1471K=1,NDISTY TAG=YDIST(K) J=0 DO1472II=1,ICOUNT IF(YTEMP(II).EQ.TAG)THEN J=J+1 ZTEMP2(J)=ZTEMP(II) END IF 1472 CONTINUE NI=J IF(NI.EQ.1)THEN NUMZ=NUMZ+1 ZDIST(NUMZ)=ZTEMP2(1) XNEW(NUMZ)=XT YNEW(NUMZ)=TAG ELSE IF(NI.GT.1)THEN CALL MEAN(ZTEMP2,NI,IWRITE,ZMEAN,IBUGG3,IERROR) NUMZ=NUMZ+1 ZDIST(NUMZ)=ZMEAN XNEW(NUMZ)=XT YNEW(NUMZ)=TAG ENDIF 1471 CONTINUE C 1410 CONTINUE C C ******************************************************* C ** STEP 15-- ** C ** DETERMINE THE NUMBER OF DISTINCT X VALUES ** C ** FOR THE INTERPOLATION POINTS ** C ******************************************************* C ISTEPN='15' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'NT2D') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NDISTX=0 DO1510I=1,NX IF(NDISTX.EQ.0)GOTO1520 DO1515I2=1,NDISTX IF(X2(I).EQ.XDIST(I2))GOTO1510 1515 CONTINUE 1520 CONTINUE NDISTX=NDISTX+1 XDIST(NDISTX)=X2(I) 1510 CONTINUE C CALL SORT(XDIST,NDISTX,XDIST) C C ******************************************************* C ** STEP 16-- ** C ** DETERMINE THE NUMBER OF DISTINCT Y VALUES ** C ** FOR THE INTERPOLATION POINTS ** C ******************************************************* C ISTEPN='16' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'NT2D') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NDISTY=0 DO1610I=1,NY IF(NDISTY.EQ.0)GOTO1620 DO1615I2=1,NDISTY IF(Y2(I).EQ.YDIST(I2))GOTO1610 1615 CONTINUE 1620 CONTINUE NDISTY=NDISTY+1 YDIST(NDISTY)=Y2(I) 1610 CONTINUE C CALL SORT(YDIST,NDISTY,YDIST) C N2=NDISTX*NDISTY IF(N2.LE.MAXOBV)GOTO1699 C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1651) 1651 FORMAT('***** ERROR IN INT2D--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1652) 1652 FORMAT(' THE NUMBER OF REQUESTED INTERPOLATION POINTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1653)MAXOBV 1653 FORMAT(' WILL EXCEED THE MAXIMUM ALLOWABLE OF ',I8,'.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1654) 1654 FORMAT(' THE NUMBER OF DISTINCT X AND Y INTERPOLATION') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1655)NDISTX,NDISTY 1655 FORMAT(' IS ',I8,' AND ',I8,' RESPECTIVELY. *****') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 1699 CONTINUE C C ******************************************** C ** STEP 17-- ** C ** CHECK FOR USER PARAMETER NPPR ** C ******************************************** C 1700 CONTINUE NPPR=10 C ANPPR=10.0 IHP='NPPR' IHP2=' ' 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')GOTO1710 ANPPR=VALUE(ILOCP) 1710 CONTINUE C NPPR=INT(ANPPR+0.5) IF(NPPR.GE.3)GOTO1719 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1711) 1711 FORMAT('***** ERROR IN INT2D--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1712) 1712 FORMAT(' THE AVERAGE NUMBER OF POINTS PER REGION MUST') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1714) 1714 FORMAT(' BE GREATER THAN OR EQUAL TO 3;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1715) 1715 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1716)NPPR 1716 FORMAT(' THE CURRENT VALUE OF NPPR IS ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1717) 1717 FORMAT(' A VALUE OF 10 WILL BE USED') CALL DPWRST('XXX','BUG ') NPPR=10 1719 CONTINUE C C C C ******************************************** C ** STEP 18-- ** C ** COMPUTE INTERPOLATED VALUES ** C ******************************************** C NIWK=7*MAXOBV NWK=7*MAXOBV CALL INT2D2(ZDIST,YNEW,XNEW,N,YDIST,NY,XDIST,NX,Z2,N2, 1NPPR,NIWK,NWK,WORK,IWORK, 1IBUGG3,ISUBRO,IERROR) C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'NT2D')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF INT2D--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)N,N2 9012 FORMAT('N,N2 = ',2I8) CALL DPWRST('XXX','BUG ') DO9042I=1,N2 WRITE(ICOUT,9043)I,X2(I),Y2(I),Z2(I) 9043 FORMAT('I,X2(I),Y2(I),Z2(I) = ',I8,3E15.7) CALL DPWRST('XXX','BUG ') 9042 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE INT2D2(Z,Y,X,N,Y2,NY,X2,NX,Z2,N2, 1NPPR,NIWK,NWK,WORK,IWORK, 1IBUGG3,ISUBRO,IERROR) C C PURPOSE--COMPUTE BI-VARIATE INTERPOLATION OF A VARIABLE C (GENERATE INTERPOLATED POINTS). C THIS ROUTINE STARTS FROM SCATTERED DATA AND INTERPOLATES C POINTS ON A GRID. NOTE THAT X2 AND Y2 DEFINE THE GRID C TO INTERPOLATE OVER. C THIS ROUTINE USES THE LOTPS ROUTINE WRITTEN BY RICHARD C FRANKE OF THE NAVAL POSTGRADUATE SCHOOL. C INPUT ARGUMENTS--Z = SINGLE PRECISION VARIABLE C CONTAINING THE ORIGINAL C Z AXIS DATA POINTS. C --Y = SINGLE PRECISION VARIABLE C CONTAINING THE ORIGINAL C VERTICAL AXIS DATA POINTS. C --X = SINGLE PRECISION VARIABLE C CONTAINING THE ORIGINAL C HORIZONTAL AXIS DATA POINTS. C --Y2 = SINGLE PRECISION VARIABLE C CONTAINING THE DESIRED C VERTICAL AXIS INTERPOLATION C --X2 = SINGLE PRECISION VARIABLE C CONTAINING THE DESIRED C HORIZONTAL AXIS INTERPOLATION C POINTS. C OUTPUT ARGUMENTS--Z2 = SINGLE PRECISION VARIABLE C CONTAINING THE COMPUTED C VERTICAL AXIS INTERPOLATION C POINTS. C NOTE--IT IS PROBABLY NOT PERMISSIBLE TO HAVE THE OUTPUT VECTOR C Z2(.) BEING IDENTICAL TO THE INPUT VECTOR Z(.) C NOTE--THE X AND Y POINTS ARE ASSUMED TO LIE ON A RECTANGULAR GRID 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--94/5 C ORIGINAL VERSION--MAY 1994. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IBUGG3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C C DIMENSION Z(*) DIMENSION Y(*) DIMENSION X(*) DIMENSION Z2(*) DIMENSION Y2(*) DIMENSION X2(*) DIMENSION WORK(*) DIMENSION IWORK(*) 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='INT2' ISUBN2='D2 ' C IERROR='NO' C DO10I=1,N2 Z2(I)=0.0 10 CONTINUE C IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'T2D2')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF INT2D2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)NX,NY 52 FORMAT('NX, NY = ',2I8) CALL DPWRST('XXX','BUG ') DO54I=1,N WRITE(ICOUT,53)I,X(I),Y(I),Z(I) CALL DPWRST('XXX','BUG ') 53 FORMAT('I,X(I),Y(I),Z(I) = ',I8,3E15.7) CALL DPWRST('XXX','BUG ') 54 CONTINUE WRITE(ICOUT,62)N2 62 FORMAT('N2 = ',I8) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C **************************************** C ** STEP 31-- C ** COMPUTE INTERPOLATION VALUES C **************************************** C IMODE=1 CALL LOTPS(IMODE,NPPR,N,X,Y,Z,NX,X2,NY,Y2,IWORK,NIWK,NIWKU, 1WORK,NWK,NWKU,Z2,KERR) IF(KERR.GT.0)THEN IERROR='YES' GOTO9000 ENDIF C 3100 CONTINUE C C **************************************** C ** STEP 41-- C ** IF CALLED FOR, C ** WRITE OUT INTERPOLATION VALUES C **************************************** C IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'T2D2')GOTO4190 J1=0 DO4100I=1,NX DO4110J=1,NY J1=J1+1 WRITE(ICOUT,4112)X2(I),Y2(J),Z2(J1) CALL DPWRST('XXX','BUG ') 4112 FORMAT('I,J,X2(I),Y2(J),Z2(I,J) = ',2I8,3E15.7) 4110 CONTINUE 4100 CONTINUE 4190 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'T2D2')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF INT2D2--') CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END INTEGER FUNCTION ISAMAX(N,SX,INCX) C***BEGIN PROLOGUE ISAMAX C***DATE WRITTEN 791001 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D1A2 C***KEYWORDS BLAS,LINEAR ALGEBRA,MAXIMUM COMPONENT,VECTOR C***AUTHOR LAWSON, C. L., (JPL) C HANSON, R. J., (SNLA) C KINCAID, D. R., (U. OF TEXAS) C KROGH, F. T., (JPL) C***PURPOSE Find largest component of s.p. vector C***DESCRIPTION C C B L A S Subprogram C Description of Parameters C C --Input-- C N number of elements in input vector(s) C SX single precision vector with N elements C INCX storage spacing between elements of SX C C --Output-- C ISAMAX smallest index (zero if N .LE. 0) C C Find smallest index of maximum magnitude of single precision SX. C ISAMAX = first I, I = 1 to N, to minimize ABS(SX(1-INCX+I*INCX) C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 C***ROUTINES CALLED (NONE) C***END PROLOGUE ISAMAX C REAL SX(*),SMAX,XMAG C***FIRST EXECUTABLE STATEMENT ISAMAX ISAMAX = 0 IF(N.LE.0) RETURN ISAMAX = 1 IF(N.LE.1)RETURN IF(INCX.EQ.1)GOTO 20 C C CODE FOR INCREMENTS NOT EQUAL TO 1. C SMAX = ABS(SX(1)) NS = N*INCX II = 1 DO 10 I=1,NS,INCX XMAG = ABS(SX(I)) IF(XMAG.LE.SMAX) GO TO 5 ISAMAX = II SMAX = XMAG 5 II = II + 1 10 CONTINUE RETURN C C CODE FOR INCREMENTS EQUAL TO 1. C 20 SMAX = ABS(SX(1)) DO 30 I = 2,N XMAG = ABS(SX(I)) IF(XMAG.LE.SMAX) GO TO 30 ISAMAX = I SMAX = XMAG 30 CONTINUE RETURN END subroutine isort (n, ix) c----------------------------------------------------------------------- c Name: ISORT (Used by Fisher Exact Test) c c Purpose: Shell sort for an integer vector. c c Usage: CALL ISORT (N, IX) c c Arguments: c N - Lenth of vector IX. (Input) c IX - Vector to be sorted. (Input/output) c----------------------------------------------------------------------- c SPECIFICATIONS FOR ARGUMENTS integer n, ix(*) c SPECIFICATIONS FOR LOCAL VARIABLES integer i, ikey, il(10), it, iu(10), j, kl, ku, m c SPECIFICATIONS FOR SUBROUTINES CCCCC external prterr c Sort IX CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C m = 1 i = 1 j = n 10 if (i .ge. j) go to 40 kl = i ku = j ikey = i j = j + 1 c Find element in first half 20 i = i + 1 if (i .lt. j) then if (ix(ikey) .gt. ix(i)) go to 20 end if c Find element in second half 30 j = j - 1 if (ix(j) .gt. ix(ikey)) go to 30 c Interchange if (i .lt. j) then it = ix(i) ix(i) = ix(j) ix(j) = it go to 20 end if it = ix(ikey) ix(ikey) = ix(j) ix(j) = it c Save upper and lower subscripts of c the array yet to be sorted if (m .lt. 11) then if (j-kl .lt. ku-j) then il(m) = j + 1 iu(m) = ku i = kl j = j - 1 else il(m) = kl iu(m) = j - 1 i = j + 1 j = ku end if m = m + 1 go to 10 else CCCCC call prterr (20, 'This should never occur.') WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** ERROR FROM ISORT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013) 9013 FORMAT(' This should never occur.') CALL DPWRST('XXX','BUG ') end if c Use another segment 40 m = m - 1 if (m .eq. 0) go to 9000 i = il(m) j = iu(m) go to 10 c 9000 return end SUBROUTINE IWECDF(X,GAMMA,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE INVERTED WEIBULL C DISTRIBUTION WITH SINGLE PRECISION C TAIL LENGTH PARAMETER = GAMMA. C THE INVERTED WEIBULL DISTRIBUTION USED C HEREIN IS DEFINED FOR ALL POSITIVE X, C AND HAS THE CUMULATIVE DISTRIBUTION FUNCTION C F(X) = EXP(-(X**(-GAMMA))). 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 --GAMMA = THE SHAPE PARAMETER C GAMMA SHOULD BE POSITIVE. C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION C FUNCTION VALUE CDF FOR THE WEIBULL DISTRIBUTION C WITH TAIL LENGTH PARAMETER = GAMMA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE NON-NEGATIVE. C --GAMMA SHOULD BE POSITIVE. 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--XX C --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--1, XX. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--2001.9 C ORIGINAL VERSION--SEPTEMBER 2001. C C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DGAMMA DOUBLE PRECISION DCDF C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C CDF=0.0 C IF(GAMMA.LE.0)THEN WRITE(ICOUT,15) 15 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1 'IWECDF SUBROUTINE IS NON-POSITIVE *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)GAMMA 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9000 ENDIF C IF(X.LE.0.0)THEN CDF=0.0 ELSE DGAMMA=DBLE(GAMMA) DX=DBLE(X) DCDF=DEXP(-(DX**(-DGAMMA))) CDF=REAL(DCDF) ENDIF C 9000 CONTINUE C RETURN END SUBROUTINE IWEPDF(X,GAMMA,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE INVERTED WEIBULL C DISTRIBUTION WITH SINGLE PRECISION C TAIL LENGTH PARAMETER = GAMMA. C THE INVERTED WEIBULL DISTRIBUTION USED C HEREIN IS DEFINED FOR ALL POSITIVE X, C AND HAS THE PROBABILITY DENSITY FUNCTION C F(X) = GAMMA*(X**(-GAMMA-1))*EXP(-(X**(-GAMMA))). C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C --GAMMA = THE SHAPE PARAMETER C GAMMA SHOULD BE POSITIVE. C OUTPUT ARGUMENTS--PDF = THE SINGLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY C FUNCTION VALUE PDF FOR THE WEIBULL DISTRIBUTION C WITH TAIL LENGHT PARAMETER = GAMMA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--GAMMA SHOULD BE POSITIVE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--EXP. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--XX C --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--1, XX. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--2001.9 C ORIGINAL VERSION--SEPTEMBER 2001. C DOUBLE PRECISION DX DOUBLE PRECISION DGAMMA DOUBLE PRECISION DPDF C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(GAMMA.LE.0)THEN WRITE(ICOUT,15) 15 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1 'IWEPDF SUBROUTINE IS NON-POSITIVE *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)GAMMA 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9000 ENDIF C IF(X.LE.0.0)THEN PDF=0.0 ELSE DGAMMA=DBLE(GAMMA) DX=DBLE(X) DPDF=DGAMMA*(DX**(-DGAMMA-1.0D0))*DEXP(-(DX**(-DGAMMA))) PDF=REAL(DPDF) ENDIF C 9000 CONTINUE RETURN END SUBROUTINE IWEPPF(P,GAMMA,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE INVERTED WEIBULL C DISTRIBUTION WITH SINGLE PRECISION C TAIL LENGTH PARAMETER = GAMMA. C THE INVERTED WEIBULL DISTRIBUTION USED C HEREIN IS DEFINED FOR ALL POSITIVE X, C AND HAS THE PERCENT POINT FUNCTION C G(P) = -[LOG(P)]**(-1/GAMMA) C NOTE THAT THE PERCENT POINT FUNCTION OF A DISTRIBUTION C IS IDENTICALLY THE SAME AS THE INVERSE CUMULATIVE C DISTRIBUTION FUNCTION OF THE DISTRIBUTION. C INPUT ARGUMENTS--P = THE SINGLE PRECISION VALUE C (BETWEEN 0.0 (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 OUTPUT ARGUMENTS--PPF = THE SINGLE PRECISION PERCENT C POINT FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION . C VALUE PPF FOR THE WEIBULL DISTRIBUTION C WITH TAIL LENGTH PARAMETER VALUE = GAMMA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--GAMMA SHOULD BE POSITIVE. C --P SHOULD BE BETWEEN 0.0 (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--XX C --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--1, XX. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--2001.9 C ORIGINAL VERSION--SEPTEMBER 2001. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C DOUBLE PRECISION DP DOUBLE PRECISION DGAMMA DOUBLE PRECISION DPPF C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C 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 GOTO9000 ENDIF IF(GAMMA.LE.0.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)GAMMA CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9000 ENDIF 1 FORMAT('***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO THE ', 1'IWEPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') 15 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1'IWEPPF SUBROUTINE IS NON-POSITIVE *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C DGAMMA=DBLE(GAMMA) DP=DBLE(P) DTERM1=-DLOG(DP) DTERM2=-1.0D0/DGAMMA DPPF=DTERM1**DTERM2 PPF=REAL(DPPF) C 9000 CONTINUE RETURN END SUBROUTINE IWERAN(N,GAMMA,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE INVERTED WEIBULL DISTRIBUTION C WITH TAIL LENGTH PARAMETER VALUE = GAMMA. C THE PROTOTYPE WEIBULL DISTRIBUTION USED C HEREIN IS DEFINED FOR ALL POSITIVE X, C AND HAS THE PROBABILITY DENSITY FUNCTION C F(X) = GAMMA * (X**(-GAMMA-1)) * EXP(-(X**-GAMMA)). C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --GAMMA = THE SINGLE PRECISION VALUE OF THE C TAIL LENGTH PARAMETER. C GAMMA SHOULD BE POSITIVE. C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR C (OF DIMENSION AT LEAST N) C INTO WHICH THE GENERATED C RANDOM SAMPLE WILL BE PLACED. C OUTPUT--A RANDOM SAMPLE OF SIZE N C FROM THE INVERTED WEIBULL DISTRIBUTION C WITH TAIL LENGTH PARAMETER VALUE = GAMMA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C --GAMMA SHOULD BE POSITIVE. C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN. C FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--XX C --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--1, 2ND. ED., 1994. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--2001.9 C ORIGINAL VERSION--SEPTEMBER 2001. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)THEN WRITE(ICOUT, 5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF IF(GAMMA.LE.0.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)GAMMA CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ', 1'IWERAN SUBROUTINE IS NON-POSITIVE *****') 15 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ', 1'IWERAN 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 INVERTED WEIBULL DISTRIBUTION RANDOM NUMBERS C USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD. C DO100I=1,N CALL IWEPPF(X(I),GAMMA,XTEMP) X(I)=XTEMP 100 CONTINUE C 9000 CONTINUE RETURN END integer function iwork (iwkmax, iwkpt, number, itype) c----------------------------------------------------------------------- c Name: IWORK c c Purpose: Routine for allocating workspace. c c Usage: IWORK (IWKMAX, IWKPT, NUMBER, ITYPE) c c Arguments: c IWKMAX - Maximum length of workspace. (Input) c IWKPT - Amount of workspace currently allocated. (Input/output) c NUMBER - Number of elements of workspace desired. (Input) c ITYPE - Worspace type. (Input) c ITYPE TYPE c 2 Integer c 3 Real c 4 Double Precision c IWORK - Index in RWRK, DWRK, or IWRK of the beginning of the c first element in the workspace array. (Output) c----------------------------------------------------------------------- c SPECIFICATIONS FOR ARGUMENTS integer iwkmax, iwkpt, number, itype c SPECIFICATIONS FOR INTRINSICS intrinsic mod integer mod c SPECIFICATIONS FOR SUBROUTINES CCCCC external prterr c CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C iwork = iwkpt if (itype.eq.2 .or. itype.eq.3) then iwkpt = iwkpt + number else if (mod(iwork,2) .ne. 0) iwork = iwork + 1 iwkpt = iwkpt + 2*number iwork = iwork/2 end if if (iwkpt .gt. iwkmax+1) then CCCCC call prterr (40, 'Out of workspace.') WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** ERROR FROM IWORK--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013) 9013 FORMAT(' Out of workspace.') CALL DPWRST('XXX','BUG ') end if return end DOUBLE PRECISION FUNCTION J1FUN(DX) C C PURPOSE--THIS FUNCTION COMPUTES THE FOLLOWING FUNCTION: C J(X,A) = INTEGRAL[0 to X][T**(A-1)*LOG(T)*EXP(-T)]dt C THIS FUNCTION IS USED IN COMPUTING MAXIMUM LIKELIHOOD C ESTIMATES FOR THE GAMMA DISTRIBUTION FOR MULTIPLY C CENSORED DATA. C INPUT ARGUMENTS--DX = THE DOUBLE PRECISION VALUE AT C WHICH THE J(X,A) FUNCTION IS TO BE C EVALUATED. C OUTPUT ARGUMENTS--J1FUN = THE DOUBLE PRECISION FUNCTION VALUE. C OUTPUT--THE DOUBLE PRECISION VALUE FOR THE J(X,A) FUNCTION. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--DLOG. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN C ENGINEERING", CAMBRIDGE UNIVERSITY PRESS, C 1999, CHAPTER 13. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C 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.11 C ORIGINAL VERSION--NOVEMBER 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C C DOUBLE PRECISION DX C DOUBLE PRECISION DA COMMON/J1COM/DA C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C C-----START POINT----------------------------------------------------- C C ************************************ C ** STEP 1-- ** C ** COMPUTE THE DENSITY FUNCTION ** C ************************************ C J1FUN=DX**(DA-1.0D0)*DLOG(DX)*DEXP(-DX) C RETURN END DOUBLE PRECISION FUNCTION J2FUN(DX) C C PURPOSE--THIS FUNCTION COMPUTES THE FOLLOWING FUNCTION: C J(X,A) = INTEGRAL[0 to X] C [T**(A-1)*(LOG(T)**2)**EXP(-T)]dt C THIS FUNCTION IS USED IN COMPUTING THE STANDARD C ERRORS OF THE MAXIMUM LIKELIHOOD ESTIMATES FOR THE C GAMMA DISTRIBUTION FOR MULTIPLY CENSORED DATA. C INPUT ARGUMENTS--DX = THE DOUBLE PRECISION VALUE AT C WHICH THE J(X,A) FUNCTION IS TO BE C EVALUATED. C OUTPUT ARGUMENTS--J2FUN = THE DOUBLE PRECISION FUNCTION VALUE. C OUTPUT--THE DOUBLE PRECISION VALUE FOR THE J(X,A) FUNCTION. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--DLOG. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN C ENGINEERING", CAMBRIDGE UNIVERSITY PRESS, C 1999, CHAPTER 13. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C 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.11 C ORIGINAL VERSION--NOVEMBER 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C C DOUBLE PRECISION DX C DOUBLE PRECISION DA COMMON/J1COM/DA C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C C-----START POINT----------------------------------------------------- C C ************************************ C ** STEP 1-- ** C ** COMPUTE THE DENSITY FUNCTION ** C ************************************ C J2FUN=DX**(DA-1.0D0)*(DLOG(DX)**2)*DEXP(-DX) C RETURN END DOUBLE PRECISION FUNCTION J0INT(XVALUE) C C DESCRIPTION: C C This function calculates the integral of the Bessel C function J0, defined as C C J0INT(x) = {integral 0 to x} J0(t) dt C C The code uses Chebyshev expansions whose coefficients are C given to 20 decimal places. C C C ERROR RETURNS: C C If the value of |x| is too large, it is impossible to C accurately compute the trigonometric functions used. An C error message is printed, and the function returns the C value 1.0. C C C MACHINE-DEPENDENT CONSTANTS: C C NTERM1 - The no. of terms to be used from the array C ARJ01. The recommended value is such that C ABS(ARJ01(NTERM1)) < EPS/100, provided that C C NTERM2 - The no. of terms to be used from the array C ARJ0A1. The recommended value is such that C ABS(ARJ0A1(NTERM2)) < EPS/100, provided that C C NTERM3 - The no. of terms to be used from the array C ARJ0A2. The recommended value is such that C ABS(ARJ0A2(NTERM3)) < EPS/100, provided that C C XLOW - The value of |x| below which J0INT(x) = x to C machine-precision. The recommended value is C sqrt(12*EPSNEG) C C XHIGH - The value of |x| above which it is impossible C to calculate (x-pi/4) accurately. The recommended C value is 1/EPSNEG C C For values of EPS and EPSNEG for various machine/compiler C combinations refer to the file MACHCON.TXT. C C The machine-dependent constants are computed internally by C using the D1MACH subroutine. C C C INTRINSIC FUNCTIONS USED: C C COS , SIN , SQRT C C C OTHER MISCFUN SUBROUTINES USED: C C CHEVAL , ERRPRN, D1MACH C C C AUTHOR: C Dr. Allan J. MacLeod, C Dept. of Mathematics and Statistics, C University of Paisley, C Paisley, C SCOTLAND C PA1 2BE C C (e-mail: macl_ms0@paisley.ac.uk ) C C C LATEST REVISION: C 23 January, 1996 C INTEGER IND,NTERM1,NTERM2,NTERM3 DOUBLE PRECISION ARJ01(0:23),ARJ0A1(0:21),ARJ0A2(0:18), 1 CHEVAL,FIVE12,ONE,ONEHUN,ONE28,PIB41,PIB411,PIB412, 2 PIB42,RT2BPI,SIXTEN,T,TEMP,TWELVE,X,XHIGH,XLOW, 3 XMPI4,XVALUE,ZERO CCCCC CHARACTER FNNAME*6,ERRMSG*26 CCCCC DATA FNNAME/'J0INT '/ CCCCC DATA ERRMSG/'ARGUMENT TOO LARGE IN SIZE'/ 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 DATA ZERO,ONE/ 0.0 D 0 , 1.0 D 0 / DATA TWELVE,SIXTEN/ 12.0 D 0 , 16.0 D 0 / DATA ONEHUN,ONE28,FIVE12/ 100.0 D 0 , 128.0 D 0 , 512 D 0 / DATA RT2BPI/0.79788 45608 02865 35588 D 0/ DATA PIB411,PIB412/ 201.0 D 0 , 256.0 D 0/ DATA PIB42/0.24191 33974 48309 61566 D -3/ DATA ARJ01(0)/ 0.38179 27932 16901 73518 D 0/ DATA ARJ01(1)/ -0.21275 63635 05053 21870 D 0/ DATA ARJ01(2)/ 0.16754 21340 72157 94187 D 0/ DATA ARJ01(3)/ -0.12853 20977 21963 98954 D 0/ DATA ARJ01(4)/ 0.10114 40545 57788 47013 D 0/ DATA ARJ01(5)/ -0.91007 95343 20156 8859 D -1/ DATA ARJ01(6)/ 0.64013 45264 65687 3103 D -1/ DATA ARJ01(7)/ -0.30669 63029 92675 4312 D -1/ DATA ARJ01(8)/ 0.10308 36525 32506 4201 D -1/ DATA ARJ01(9)/ -0.25567 06503 99956 918 D -2/ DATA ARJ01(10)/ 0.48832 75580 57983 04 D -3/ DATA ARJ01(11)/-0.74249 35126 03607 7 D -4/ DATA ARJ01(12)/ 0.92226 05637 30861 D -5/ DATA ARJ01(13)/-0.95522 82830 7083 D -6/ DATA ARJ01(14)/ 0.83883 55845 986 D -7/ DATA ARJ01(15)/-0.63318 44888 58 D -8/ DATA ARJ01(16)/ 0.41560 50422 1 D -9/ DATA ARJ01(17)/-0.23955 29307 D -10/ DATA ARJ01(18)/ 0.12228 6885 D -11/ DATA ARJ01(19)/-0.55697 11 D -13/ DATA ARJ01(20)/ 0.22782 0 D -14/ DATA ARJ01(21)/-0.8417 D -16/ DATA ARJ01(22)/ 0.282 D -17/ DATA ARJ01(23)/-0.9 D -19/ DATA ARJ0A1(0)/ 1.24030 13303 75189 70827 D 0/ DATA ARJ0A1(1)/ -0.47812 53536 32280 693 D -2/ DATA ARJ0A1(2)/ 0.66131 48891 70667 8 D -4/ DATA ARJ0A1(3)/ -0.18604 27404 86349 D -5/ DATA ARJ0A1(4)/ 0.83627 35565 080 D -7/ DATA ARJ0A1(5)/ -0.52585 70367 31 D -8/ DATA ARJ0A1(6)/ 0.42606 36325 1 D -9/ DATA ARJ0A1(7)/ -0.42117 61024 D -10/ DATA ARJ0A1(8)/ 0.48894 6426 D -11/ DATA ARJ0A1(9)/ -0.64834 929 D -12/ DATA ARJ0A1(10)/ 0.96172 34 D -13/ DATA ARJ0A1(11)/-0.15703 67 D -13/ DATA ARJ0A1(12)/ 0.27871 2 D -14/ DATA ARJ0A1(13)/-0.53222 D -15/ DATA ARJ0A1(14)/ 0.10844 D -15/ DATA ARJ0A1(15)/-0.2342 D -16/ DATA ARJ0A1(16)/ 0.533 D -17/ DATA ARJ0A1(17)/-0.127 D -17/ DATA ARJ0A1(18)/ 0.32 D -18/ DATA ARJ0A1(19)/-0.8 D -19/ DATA ARJ0A1(20)/ 0.2 D -19/ DATA ARJ0A1(21)/-0.1 D -19/ DATA ARJ0A2(0)/ 1.99616 09630 13416 75339 D 0/ DATA ARJ0A2(1)/ -0.19037 98192 46668 161 D -2/ DATA ARJ0A2(2)/ 0.15397 10927 04422 6 D -4/ DATA ARJ0A2(3)/ -0.31145 08832 8103 D -6/ DATA ARJ0A2(4)/ 0.11108 50971 321 D -7/ DATA ARJ0A2(5)/ -0.58666 78712 3 D -9/ DATA ARJ0A2(6)/ 0.41399 26949 D -10/ DATA ARJ0A2(7)/ -0.36539 8763 D -11/ DATA ARJ0A2(8)/ 0.38557 568 D -12/ DATA ARJ0A2(9)/ -0.47098 00 D -13/ DATA ARJ0A2(10)/ 0.65022 0 D -14/ DATA ARJ0A2(11)/-0.99624 D -15/ DATA ARJ0A2(12)/ 0.16700 D -15/ DATA ARJ0A2(13)/-0.3028 D -16/ DATA ARJ0A2(14)/ 0.589 D -17/ DATA ARJ0A2(15)/-0.122 D -17/ DATA ARJ0A2(16)/ 0.27 D -18/ DATA ARJ0A2(17)/-0.6 D -19/ DATA ARJ0A2(18)/ 0.1 D -19/ C C Start computation C X = XVALUE IND = 1 IF ( X .LT. ZERO ) THEN X = -X IND = -1 ENDIF C C Compute the machine-dependent constants. C TEMP = D1MACH(3) XHIGH = ONE / TEMP C C Error test C IF ( X .GT. XHIGH ) THEN CCCCC CALL ERRPRN(FNNAME,ERRMSG) WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,101)X CALL DPWRST('XXX','BUG ') J0INT = ONE IF ( IND .EQ. -1 ) J0INT = -J0INT RETURN ENDIF 999 FORMAT(1X) 101 FORMAT('***** ERROR FROM J0INT--SIZE OF THE INPUT ARGUMENT ', 1 'IS TOO LARGE, ARGUMENT = ',G15.7) C C continue with constants C T = TEMP / ONEHUN IF ( X .LE. SIXTEN ) THEN DO 10 NTERM1 = 23 , 0 , -1 IF ( ABS(ARJ01(NTERM1)) .GT. T ) GOTO 19 10 CONTINUE 19 XLOW = SQRT ( TWELVE * TEMP ) ELSE DO 40 NTERM2 = 21 , 0 , -1 IF ( ABS(ARJ0A1(NTERM2)) .GT. T ) GOTO 49 40 CONTINUE 49 DO 50 NTERM3 = 18 , 0 , -1 IF ( ABS(ARJ0A2(NTERM3)) .GT. T ) GOTO 59 50 CONTINUE 59 ENDIF C C Code for 0 <= |x| <= 16 C IF ( X .LE. SIXTEN ) THEN IF ( X .LT. XLOW ) THEN J0INT = X ELSE T = X * X / ONE28 - ONE J0INT = X * CHEVAL(NTERM1,ARJ01,T) ENDIF ELSE C C Code for |x| > 16 C T = FIVE12 / ( X * X ) - ONE PIB41 = PIB411 / PIB412 XMPI4 = ( X - PIB41 ) - PIB42 TEMP = COS(XMPI4) * CHEVAL(NTERM2,ARJ0A1,T) / X TEMP = TEMP - SIN(XMPI4) * CHEVAL(NTERM3,ARJ0A2,T) J0INT = ONE - RT2BPI * TEMP / SQRT(X) ENDIF IF ( IND .EQ. -1 ) J0INT = -J0INT RETURN END SUBROUTINE JACELL(AX,AMC,SNR,CNR,DNR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE JACOBIAN ELLIPTIC C FUNCTIONS. C INPUT ARGUMENTS--X = THE SINGLE PRECISION INPUT ARGUMENT C AMC = THE SINGLE PRECISION VALUE FOR THE C PARAMETER OF THE FUNCTIONS C OUTPUT ARGUMENTS--SN = THE SINGLE PRECISION VALUE OF THE SN C FUNCTION. C --CN = THE SINGLE PRECISION VALUE OF THE CN C FUNCTION. C --DN = THE SINGLE PRECISION VALUE OF THE DN C FUNCTION. 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--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN. C REFERENCES--"NUMERICAL CALCULATION OF ELLIPTIC INTEGRALS AND C ELLIPTIC FUNCTIONS", BULIRSCH, NUMERISCHE MATHEMATIK, C VOL. 7, PP. 78-90, 1965. C THE ROUTINE HERE IS A FORTRAN TRANSLATION OF THE C ALGOL-60 CODE GIVEN IN THE REFERENCE. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-975-2855 C ORIGINAL VERSION--NOVEMBER 1994. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C INCLUDE 'DPCOMC.INC' 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 PARAMETER (MAXELE=13) LOGICAL B0 DOUBLE PRECISION AM(MAXELE) DOUBLE PRECISION AN(MAXELE) DOUBLE PRECISION MC, C1, CA, X, A, B, C, D DOUBLE PRECISION SN, DN, CN C DATA C1 / 3.96825396825D-4/ DATA CA / 0.0001D0 / C C--------------------------------------------------------------------- C C-----START POINT----------------------------------------------------- C X=DBLE(AX) MC=DBLE(AMC) DO10I=1,MAXELE AN(I)=0.0D0 AM(I)=0.0D0 10 CONTINUE C IF(MC.EQ.0.0D0)GOTO1000 B0=.TRUE. IF(MC.LT.0.0D0)THEN B0=.TRUE. ELSE B0=.FALSE. ENDIF IF(B0)THEN D=1.0D0-MC MC=-MC/D D=SQRT(D) X=D*X ENDIF DN=1.0D0 A=1.0D0 DO100I=1,MAXELE L=I AM(I)=A MC=DSQRT(MC) AN(I)=MC C=0.5D0*(A+MC) IF(DABS(A-MC).LE.CA*A)GOTO199 MC=A*MC A=C 100 CONTINUE 199 CONTINUE X=C*X SN=DSIN(X) CN=DCOS(X) IF(SN.EQ.0.0D0)GOTO299 A=CN/SN C=A*C DO200I=L,1,-1 B=AM(I) A=C*A C=DN*C DN=(AN(I)+A)/(B+A) A=C/B 200 CONTINUE A=1.0D0/DSQRT(C*C+1.0D0) IF(SN.LT.0.0D0)THEN SN=-A ELSE SN=A ENDIF CN=C*SN 299 CONTINUE IF(B0)THEN A=DN DN=CN CN=A SN=SN/D ENDIF GOTO9999 C 1000 CONTINUE D=DEXP(X) A=1.0D0/D B=A+D CN=2.0D0/B DN=2.0D0/B IF(DABS(X).LT.0.3D0)THEN D=X*X*X SN=CN*(D*((1.0D0/3.0D0)+D*X*C1)+DSIN(X)) ELSE SN=(D-A)/B ENDIF GOTO9999 C 9999 CONTINUE SNR=SNGL(SN) CNR=SNGL(CN) DNR=SNGL(DN) RETURN END SUBROUTINE JACKIN(A1,A2,IWRITE, 1Y3,N3,IBUGA3,ISUBRO,IERROR) C C PURPOSE--GENERATE A JACKNIFE INDEX C THIS WILL BE SEQUENCE 1 1 N WITH A SINGLE ELEMENT C DELETED C INPUT ARGUMENTS--A1 = ELEMENT TO DELETE C --A2 = SIZE OF SEQUENCE C OUTPUT ARGUMENTS--Y3 = JACKNIFE INDEX C C NOTE--IF A2 IS SMALLER THAN 1 OR LARGER THAN A1, C THEN THIS WILL BE INTERPRETED AS A NON-OPERATION. 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--93/10 C ORIGINAL VERSION--OCTOBER 1993. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DIMENSION Y3(*) 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='JACK' ISUBN2='IN ' C IERROR='NO' C IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'CKIN')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF JACKIN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3,ISUBRO,IWRITE 52 FORMAT('IBUGA3,ISUBRO,IWRITE = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)A1,A2 53 FORMAT('A1,A2 = ',2F8.2) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ************************************* C ** CONSTRUCT A JACKNIFE INDEX ** C ************************************* C C ******************************************** C ** STEP 11-- ** C ** CHECK NUMBER OF INPUT OBSERVATIONS. ** C ******************************************** C NSKIP=A1+0.5 N1=A2+0.5 IF(NSKIP.LT.1.OR.NSKIP.GT.N1)GOTO1110 GOTO1119 C 1110 CONTINUE IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1111) 1111 FORMAT('***** ERROR IN JACKIN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1112) 1112 FORMAT(' THE ELEMENT TO SKIP MUST BE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1113)N1 1113 FORMAT(' BETWEEN 1 AND ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1116) 1116 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1117)NSKIP 1117 FORMAT(' THE ELEMENT TO SKIP IS = ',I8,'.') CALL DPWRST('XXX','BUG ') GOTO9000 1119 CONTINUE C DO1300I=1,N1 Y3(I)=REAL(I) 1300 CONTINUE Y3(NSKIP)=0.0 N3=N1 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 JACKIN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,ISUBRO,IWRITE 9012 FORMAT('IBUGA3,ISUBRO,IWRITE = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IERROR 9013 FORMAT('IERROR = ',A4) CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,9017)N1,N2,N3 C9017 FORMAT('N1,N2,N3 = ',3I8) WRITE(ICOUT,9017)N1,N3 9017 FORMAT('N1,N3 = ',2I8) CALL DPWRST('XXX','BUG ') IF(N3.LE.0)GOTO9043 DO9041I=1,N3 WRITE(ICOUT,9042)I,Y3(I) 9042 FORMAT('I,Y3(I) = ',I8,E13.5) CALL DPWRST('XXX','BUG ') 9041 CONTINUE 9043 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE JACOBP(DEGREE,ALFA,BETA,X,F,FD,E,ED,FLAGF,FLAGD) C C PURPOSE--THIS SUBROUTINE COMPUTES THE JACOBI C POLYNOMIAL OF ORDER N. C INPUT ARGUMENTS--DEGREE = THE INTEGER VALUE FOR THE ORDER OF C THE POLYNOMIAL C ALPHA = THE DOUBLE PRECISION VALUE FOR THE C FIRST SHAPE PARAMETER C BETA = THE DOUBLE PRECISION VALUE FOR THE C SECOND SHAPE PARAMETER C X = THE DOUBLE PRECISION VALUE FOR THE C INPUT ARGUMENT C OUTPUT ARGUMENTS--F = THE DOUBLE PRECISION VALUE OF THE C JACOBI POLYNOMIAL. C FD = THE DOUBLE PRECISION VALUE OF THE C DERIVATIVE OF THE JACOBI POLYNOMIAL. C E = THE SINGLE PRECISION VALUE OF THE C RELATIVE ERROR OF F C ED = THE SINGLE PRECISION VALUE OF THE C RELATIVE ERROR OF FD C FLAGF = THE INTEGER VALUE WHICH SPECIFIES C WHETHER F IS RELATIVE OR ABSOLUTE ERROR C FLAGD = THE INTEGER VALUE WHICH SPECIFIES C WHETHER FD IS RELATIVE OR ABSOLUTE ERROR 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 "ALGORITHM 332. JACOBI POLYNOMIALS", WITTE, C COMMUNICATIONS OF THE ACM, VOL. 11, 1968. C FOLLOWING CODE USES ACM ALGORTHM 332 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 A, ALF, ALFA, B, BET, BETA DOUBLE PRECISION C, D, F, FD, G, H, P, PD, Q, QD DOUBLE PRECISION T1, T2, U, V, W, X C REAL E, ED, EG, E1, E2, S, Y C INTEGER I, J, K, M, N, DEGREE, FLAGF, FLAGD C DIMENSION U(25), V(25), W(25), P(25), PD(25), Q(25), QD(25) C DATA M /-2/ DATA ALF /-2.0D0/ DATA BET /-2.0D0/ CCCCC DATA Y /3.0E-26/ DATA RMXINT /134217727. / C C-----START POINT----------------------------------------------------- C CCCCC IF(X.LT.-1.0.OR.X.GT.1.0)THEN CCCCC WRITE(ICOUT,104) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,46)X CCCCC CALL DPWRST('XXX','BUG ') CCCCC GOTO9999 CCCCC ENDIF CC104 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 1ST INPUT ARGUMENT ', CCCCC1'TO THE JACOBP SUBROUTINE IS OUTSIDE THE (-1,1) INTERVAL *****') CCC46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') IF(DEGREE.LT.0 .OR. DEGREE.GT.25)THEN WRITE(ICOUT,106) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') GOTO12 ENDIF 106 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 2ND INPUT ARGUMENT ', 1'TO THE JACOBP SUBROUTINE IS OUTSIDE THE (0,25) INTERVAL *****') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') C CALL SPDIV(RMXINT,2.0,IND,RESULT) ETA=RESULT+1.0 CALL SPDIV(1.0,ETA,IND,ETA) Y=ETA C IF(DEGREE.EQ.0)THEN F=1.0D0 E=0.0 FD=0.0D0 ED=0.0 FLAGF=2 FLAGD=2 GOTO12 ENDIF C C CALCULATE THE U(J), V(J), W(J), IN THE RECURRENCE RELATION. C P(J) = P(J-1)*(U(J)+V(J)*X)-P(J-2)*W(J) C M = DEGREE ALF = ALFA BET = BETA A = ALF+BET B = ALF-BET U(1) = B/2.0D0 V(1) = 1.0D0+A/2.0D0 W(1) = 0.0D0 C IF(DEGREE.EQ.1)GOTO5 C U(2) = A*B*(A+3.0D0)/(4.0D0*(A+2.0D0)**2) V(2) = (A+3.0D0)*(A+4.0D0)/(4.0D0*(A+2.0D0)) W(2) = (1.0D0 + ALF)*(1.0D0 + BET)*(A+4.0D0) W(2) = W(2)/(2.0D0*(A+2.0D0)**2) I = 2 K = DEGREE - 1 C IF((DEGREE.EQ.2) .OR. (I.GT.K))GOTO5 C DO4J=I,K A = DBLE(2*J+2) D = ALF+BET A = A+D B = D*(A-1.0D0)*(ALF-BET) C = DBLE(J+1) C = 2.0D0*C*(A-2.0D0)*(C+D) U(J+1) = B/C D = A*(A-1.0D0)*(A-2.0D0) V(J+1) = D/C D = J A = 2.0D0*(D+ALF)*(D+BET)*A W(J+1) = A/C 4 CONTINUE C C FIND THE STARTING VALUES FOR J=1 AND J=2 FOR USE IN THE RECURSION. C 5 CONTINUE T1 = V(1)*X P(1) = U(1)+T1 S = Y*DMAX1(DABS(U(1)),DABS(T1)) Q(1) = P(1)+S PD(1) = V(1) QD(1) = V(1) C IF(DEGREE.EQ.1)GOTO7 C T1 = V(2)*X G = U(2)+T1 EG = Y*DMAX1(DABS(U(2)),DABS(T1)) H = G+EG T1 = G*P(1) E1 = DABS(EG*P(1)) P(2) = T1 - W(2) S = Y*DABS(W(2)) S = AMAX1(E1,S) Q(2) = H*Q(1)-W(2)+S PD(2) = G*PD(1)+V(2)*P(1) QD(2) = H*QD(1)+V(2)*Q(1) C IF(DEGREE.EQ.2)GOTO7 C C USE THE RECURSION C DO6J=3,DEGREE T2 = V(J)*X G = U(J)+T2 EG = Y*DMAX1(DABS(U(J)),DABS(T2)) H = G+EG T1 = G*P(J-1) T2 = W(J)*P(J-2) E1 = DABS(EG*P(J-1)) E2 = DABS(T2)*Y P(J) = T1 - T2 S = AMAX1(E1,E2) Q(J) = H*Q(J-1)-W(J)*Q(J-2)+S PD(J) = G*PD(J-1)-W(J)*PD(J-2) QD(J) = H*QD(J-1)-W(J)*QD(J-2) PD(J) = PD(J)+V(J)*P(J-1) QD(J) = QD(J)+V(J)*Q(J-1) 6 CONTINUE C C PREPARE THE OUTPUT C 7 CONTINUE N = DEGREE F = P(N) IF(DABS(F).LT.Y)THEN E=DABS(F-Q(N)) FLAGF = 1 ELSE E=DABS(1.0D0-Q(N)/F) FLAGF = 0 ENDIF FD = PD(N) IF(DABS(FD).LT.Y)THEN ED=DABS(FD-QD(N)) FLAGD=1 ELSE ED=DABS(1.0D0-QD(N)/FD) FLAGD=0 ENDIF GOTO12 C 12 CONTINUE RETURN END SUBROUTINE JAIRY (X, RX, C, AI, DAI) C***BEGIN PROLOGUE JAIRY C***SUBSIDIARY C***PURPOSE Subsidiary to BESJ and BESY C***LIBRARY SLATEC C***TYPE SINGLE PRECISION (JAIRY-S, DJAIRY-D) C***AUTHOR Amos, D. E., (SNLA) C Daniel, S. L., (SNLA) C Weston, M. K., (SNLA) C***DESCRIPTION C C JAIRY computes the Airy function AI(X) C and its derivative DAI(X) for ASYJY C C INPUT C C X - Argument, computed by ASYJY, X unrestricted C RX - RX=SQRT(ABS(X)), computed by ASYJY C C - C=2.*(ABS(X)**1.5)/3., computed by ASYJY C C OUTPUT C C AI - Value of function AI(X) C DAI - Value of the derivative DAI(X) C C***SEE ALSO BESJ, BESY C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 750101 DATE WRITTEN C 891009 Removed unreferenced variable. (WRB) C 891214 Prologue converted to Version 4.0 format. (BAB) C 900328 Added TYPE section. (WRB) C 910408 Updated the AUTHOR section. (WRB) C***END PROLOGUE JAIRY C INTEGER I, J, M1, M1D, M2, M2D, M3, M3D, M4, M4D, N1, N1D, N2, 1 N2D, N3, N3D, N4, N4D REAL A, AI, AJN, AJP, AK1, AK2, AK3, B, C, CCV, CON2, CON3, 1 CON4, CON5, CV, DA, DAI, DAJN, DAJP, DAK1, DAK2, DAK3, DB, EC, 2 E1, E2, FPI12, F1, F2, RTRX, RX, SCV, T, TEMP1, TEMP2, TT, X DIMENSION AJP(19), AJN(19), A(15), B(15) DIMENSION AK1(14), AK2(23), AK3(14) DIMENSION DAJP(19), DAJN(19), DA(15), DB(15) DIMENSION DAK1(14), DAK2(24), DAK3(14) SAVE N1, N2, N3, N4, M1, M2, M3, M4, FPI12, CON2, 1 CON3, CON4, CON5,AK1, AK2, AK3, AJP, AJN, A, B, 2 N1D, N2D, N3D, N4D, M1D, M2D, M3D, M4D, 3 DAK1, DAK2, DAK3, DAJP, DAJN, DA, DB DATA N1,N2,N3,N4/14,23,19,15/ DATA M1,M2,M3,M4/12,21,17,13/ DATA FPI12,CON2,CON3,CON4,CON5/ 1 1.30899693899575E+00, 5.03154716196777E+00, 3.80004589867293E-01, 2 8.33333333333333E-01, 8.66025403784439E-01/ DATA AK1(1), AK1(2), AK1(3), AK1(4), AK1(5), AK1(6), AK1(7), 1 AK1(8), AK1(9), AK1(10),AK1(11),AK1(12),AK1(13), 2 AK1(14) / 2.20423090987793E-01,-1.25290242787700E-01, 3 1.03881163359194E-02, 8.22844152006343E-04,-2.34614345891226E-04, 4 1.63824280172116E-05, 3.06902589573189E-07,-1.29621999359332E-07, 5 8.22908158823668E-09, 1.53963968623298E-11,-3.39165465615682E-11, 6 2.03253257423626E-12,-1.10679546097884E-14,-5.16169497785080E-15/ DATA AK2(1), AK2(2), AK2(3), AK2(4), AK2(5), AK2(6), AK2(7), 1 AK2(8), AK2(9), AK2(10),AK2(11),AK2(12),AK2(13),AK2(14), 2 AK2(15),AK2(16),AK2(17),AK2(18),AK2(19),AK2(20),AK2(21), 3 AK2(22),AK2(23) / 2.74366150869598E-01, 5.39790969736903E-03, 4-1.57339220621190E-03, 4.27427528248750E-04,-1.12124917399925E-04, 5 2.88763171318904E-05,-7.36804225370554E-06, 1.87290209741024E-06, 6-4.75892793962291E-07, 1.21130416955909E-07,-3.09245374270614E-08, 7 7.92454705282654E-09,-2.03902447167914E-09, 5.26863056595742E-10, 8-1.36704767639569E-10, 3.56141039013708E-11,-9.31388296548430E-12, 9 2.44464450473635E-12,-6.43840261990955E-13, 1.70106030559349E-13, 1-4.50760104503281E-14, 1.19774799164811E-14,-3.19077040865066E-15/ DATA AK3(1), AK3(2), AK3(3), AK3(4), AK3(5), AK3(6), AK3(7), 1 AK3(8), AK3(9), AK3(10),AK3(11),AK3(12),AK3(13), 2 AK3(14) / 2.80271447340791E-01,-1.78127042844379E-03, 3 4.03422579628999E-05,-1.63249965269003E-06, 9.21181482476768E-08, 4-6.52294330229155E-09, 5.47138404576546E-10,-5.24408251800260E-11, 5 5.60477904117209E-12,-6.56375244639313E-13, 8.31285761966247E-14, 6-1.12705134691063E-14, 1.62267976598129E-15,-2.46480324312426E-16/ DATA AJP(1), AJP(2), AJP(3), AJP(4), AJP(5), AJP(6), AJP(7), 1 AJP(8), AJP(9), AJP(10),AJP(11),AJP(12),AJP(13),AJP(14), 2 AJP(15),AJP(16),AJP(17),AJP(18), 3 AJP(19) / 7.78952966437581E-02,-1.84356363456801E-01, 4 3.01412605216174E-02, 3.05342724277608E-02,-4.95424702513079E-03, 5-1.72749552563952E-03, 2.43137637839190E-04, 5.04564777517082E-05, 6-6.16316582695208E-06,-9.03986745510768E-07, 9.70243778355884E-08, 7 1.09639453305205E-08,-1.04716330588766E-09,-9.60359441344646E-11, 8 8.25358789454134E-12, 6.36123439018768E-13,-4.96629614116015E-14, 9-3.29810288929615E-15, 2.35798252031104E-16/ DATA AJN(1), AJN(2), AJN(3), AJN(4), AJN(5), AJN(6), AJN(7), 1 AJN(8), AJN(9), AJN(10),AJN(11),AJN(12),AJN(13),AJN(14), 2 AJN(15),AJN(16),AJN(17),AJN(18), 3 AJN(19) / 3.80497887617242E-02,-2.45319541845546E-01, 4 1.65820623702696E-01, 7.49330045818789E-02,-2.63476288106641E-02, 5-5.92535597304981E-03, 1.44744409589804E-03, 2.18311831322215E-04, 6-4.10662077680304E-05,-4.66874994171766E-06, 7.15218807277160E-07, 7 6.52964770854633E-08,-8.44284027565946E-09,-6.44186158976978E-10, 8 7.20802286505285E-11, 4.72465431717846E-12,-4.66022632547045E-13, 9-2.67762710389189E-14, 2.36161316570019E-15/ DATA A(1), A(2), A(3), A(4), A(5), A(6), A(7), 1 A(8), A(9), A(10), A(11), A(12), A(13), A(14), 2 A(15) / 4.90275424742791E-01, 1.57647277946204E-03, 3-9.66195963140306E-05, 1.35916080268815E-07, 2.98157342654859E-07, 4-1.86824767559979E-08,-1.03685737667141E-09, 3.28660818434328E-10, 5-2.57091410632780E-11,-2.32357655300677E-12, 9.57523279048255E-13, 6-1.20340828049719E-13,-2.90907716770715E-15, 4.55656454580149E-15, 7-9.99003874810259E-16/ DATA B(1), B(2), B(3), B(4), B(5), B(6), B(7), 1 B(8), B(9), B(10), B(11), B(12), B(13), B(14), 2 B(15) / 2.78593552803079E-01,-3.52915691882584E-03, 3-2.31149677384994E-05, 4.71317842263560E-06,-1.12415907931333E-07, 4-2.00100301184339E-08, 2.60948075302193E-09,-3.55098136101216E-11, 5-3.50849978423875E-11, 5.83007187954202E-12,-2.04644828753326E-13, 6-1.10529179476742E-13, 2.87724778038775E-14,-2.88205111009939E-15, 7-3.32656311696166E-16/ DATA N1D,N2D,N3D,N4D/14,24,19,15/ DATA M1D,M2D,M3D,M4D/12,22,17,13/ DATA DAK1(1), DAK1(2), DAK1(3), DAK1(4), DAK1(5), DAK1(6), 1 DAK1(7), DAK1(8), DAK1(9), DAK1(10),DAK1(11),DAK1(12), 2 DAK1(13),DAK1(14)/ 2.04567842307887E-01,-6.61322739905664E-02, 3-8.49845800989287E-03, 3.12183491556289E-03,-2.70016489829432E-04, 4-6.35636298679387E-06, 3.02397712409509E-06,-2.18311195330088E-07, 5-5.36194289332826E-10, 1.13098035622310E-09,-7.43023834629073E-11, 6 4.28804170826891E-13, 2.23810925754539E-13,-1.39140135641182E-14/ DATA DAK2(1), DAK2(2), DAK2(3), DAK2(4), DAK2(5), DAK2(6), 1 DAK2(7), DAK2(8), DAK2(9), DAK2(10),DAK2(11),DAK2(12), 2 DAK2(13),DAK2(14),DAK2(15),DAK2(16),DAK2(17),DAK2(18), 3 DAK2(19),DAK2(20),DAK2(21),DAK2(22),DAK2(23), 4 DAK2(24) / 2.93332343883230E-01,-8.06196784743112E-03, 5 2.42540172333140E-03,-6.82297548850235E-04, 1.85786427751181E-04, 6-4.97457447684059E-05, 1.32090681239497E-05,-3.49528240444943E-06, 7 9.24362451078835E-07,-2.44732671521867E-07, 6.49307837648910E-08, 8-1.72717621501538E-08, 4.60725763604656E-09,-1.23249055291550E-09, 9 3.30620409488102E-10,-8.89252099772401E-11, 2.39773319878298E-11, 1-6.48013921153450E-12, 1.75510132023731E-12,-4.76303829833637E-13, 2 1.29498241100810E-13,-3.52679622210430E-14, 9.62005151585923E-15, 3-2.62786914342292E-15/ DATA DAK3(1), DAK3(2), DAK3(3), DAK3(4), DAK3(5), DAK3(6), 1 DAK3(7), DAK3(8), DAK3(9), DAK3(10),DAK3(11),DAK3(12), 2 DAK3(13),DAK3(14)/ 2.84675828811349E-01, 2.53073072619080E-03, 3-4.83481130337976E-05, 1.84907283946343E-06,-1.01418491178576E-07, 4 7.05925634457153E-09,-5.85325291400382E-10, 5.56357688831339E-11, 5-5.90889094779500E-12, 6.88574353784436E-13,-8.68588256452194E-14, 6 1.17374762617213E-14,-1.68523146510923E-15, 2.55374773097056E-16/ DATA DAJP(1), DAJP(2), DAJP(3), DAJP(4), DAJP(5), DAJP(6), 1 DAJP(7), DAJP(8), DAJP(9), DAJP(10),DAJP(11),DAJP(12), 2 DAJP(13),DAJP(14),DAJP(15),DAJP(16),DAJP(17),DAJP(18), 3 DAJP(19) / 6.53219131311457E-02,-1.20262933688823E-01, 4 9.78010236263823E-03, 1.67948429230505E-02,-1.97146140182132E-03, 5-8.45560295098867E-04, 9.42889620701976E-05, 2.25827860945475E-05, 6-2.29067870915987E-06,-3.76343991136919E-07, 3.45663933559565E-08, 7 4.29611332003007E-09,-3.58673691214989E-10,-3.57245881361895E-11, 8 2.72696091066336E-12, 2.26120653095771E-13,-1.58763205238303E-14, 9-1.12604374485125E-15, 7.31327529515367E-17/ DATA DAJN(1), DAJN(2), DAJN(3), DAJN(4), DAJN(5), DAJN(6), 1 DAJN(7), DAJN(8), DAJN(9), DAJN(10),DAJN(11),DAJN(12), 2 DAJN(13),DAJN(14),DAJN(15),DAJN(16),DAJN(17),DAJN(18), 3 DAJN(19) / 1.08594539632967E-02, 8.53313194857091E-02, 4-3.15277068113058E-01,-8.78420725294257E-02, 5.53251906976048E-02, 5 9.41674060503241E-03,-3.32187026018996E-03,-4.11157343156826E-04, 6 1.01297326891346E-04, 9.87633682208396E-06,-1.87312969812393E-06, 7-1.50798500131468E-07, 2.32687669525394E-08, 1.59599917419225E-09, 8-2.07665922668385E-10,-1.24103350500302E-11, 1.39631765331043E-12, 9 7.39400971155740E-14,-7.32887475627500E-15/ DATA DA(1), DA(2), DA(3), DA(4), DA(5), DA(6), DA(7), 1 DA(8), DA(9), DA(10), DA(11), DA(12), DA(13), DA(14), 2 DA(15) / 4.91627321104601E-01, 3.11164930427489E-03, 3 8.23140762854081E-05,-4.61769776172142E-06,-6.13158880534626E-08, 4 2.87295804656520E-08,-1.81959715372117E-09,-1.44752826642035E-10, 5 4.53724043420422E-11,-3.99655065847223E-12,-3.24089119830323E-13, 6 1.62098952568741E-13,-2.40765247974057E-14, 1.69384811284491E-16, 7 8.17900786477396E-16/ DATA DB(1), DB(2), DB(3), DB(4), DB(5), DB(6), DB(7), 1 DB(8), DB(9), DB(10), DB(11), DB(12), DB(13), DB(14), 2 DB(15) /-2.77571356944231E-01, 4.44212833419920E-03, 3-8.42328522190089E-05,-2.58040318418710E-06, 3.42389720217621E-07, 4-6.24286894709776E-09,-2.36377836844577E-09, 3.16991042656673E-10, 5-4.40995691658191E-12,-5.18674221093575E-12, 9.64874015137022E-13, 6-4.90190576608710E-14,-1.77253430678112E-14, 5.55950610442662E-15, 7-7.11793337579530E-16/ C***FIRST EXECUTABLE STATEMENT JAIRY IF (X.LT.0.0E0) GO TO 90 IF (C.GT.5.0E0) GO TO 60 IF (X.GT.1.20E0) GO TO 30 T = (X+X-1.2E0)*CON4 TT = T + T J = N1 F1 = AK1(J) F2 = 0.0E0 DO 10 I=1,M1 J = J - 1 TEMP1 = F1 F1 = TT*F1 - F2 + AK1(J) F2 = TEMP1 10 CONTINUE AI = T*F1 - F2 + AK1(1) C J = N1D F1 = DAK1(J) F2 = 0.0E0 DO 20 I=1,M1D J = J - 1 TEMP1 = F1 F1 = TT*F1 - F2 + DAK1(J) F2 = TEMP1 20 CONTINUE DAI = -(T*F1-F2+DAK1(1)) RETURN C 30 CONTINUE T = (X+X-CON2)*CON3 TT = T + T J = N2 F1 = AK2(J) F2 = 0.0E0 DO 40 I=1,M2 J = J - 1 TEMP1 = F1 F1 = TT*F1 - F2 + AK2(J) F2 = TEMP1 40 CONTINUE RTRX = SQRT(RX) EC = EXP(-C) AI = EC*(T*F1-F2+AK2(1))/RTRX J = N2D F1 = DAK2(J) F2 = 0.0E0 DO 50 I=1,M2D J = J - 1 TEMP1 = F1 F1 = TT*F1 - F2 + DAK2(J) F2 = TEMP1 50 CONTINUE DAI = -EC*(T*F1-F2+DAK2(1))*RTRX RETURN C 60 CONTINUE T = 10.0E0/C - 1.0E0 TT = T + T J = N1 F1 = AK3(J) F2 = 0.0E0 DO 70 I=1,M1 J = J - 1 TEMP1 = F1 F1 = TT*F1 - F2 + AK3(J) F2 = TEMP1 70 CONTINUE RTRX = SQRT(RX) EC = EXP(-C) AI = EC*(T*F1-F2+AK3(1))/RTRX J = N1D F1 = DAK3(J) F2 = 0.0E0 DO 80 I=1,M1D J = J - 1 TEMP1 = F1 F1 = TT*F1 - F2 + DAK3(J) F2 = TEMP1 80 CONTINUE DAI = -RTRX*EC*(T*F1-F2+DAK3(1)) RETURN C 90 CONTINUE IF (C.GT.5.0E0) GO TO 120 T = 0.4E0*C - 1.0E0 TT = T + T J = N3 F1 = AJP(J) E1 = AJN(J) F2 = 0.0E0 E2 = 0.0E0 DO 100 I=1,M3 J = J - 1 TEMP1 = F1 TEMP2 = E1 F1 = TT*F1 - F2 + AJP(J) E1 = TT*E1 - E2 + AJN(J) F2 = TEMP1 E2 = TEMP2 100 CONTINUE AI = (T*E1-E2+AJN(1)) - X*(T*F1-F2+AJP(1)) J = N3D F1 = DAJP(J) E1 = DAJN(J) F2 = 0.0E0 E2 = 0.0E0 DO 110 I=1,M3D J = J - 1 TEMP1 = F1 TEMP2 = E1 F1 = TT*F1 - F2 + DAJP(J) E1 = TT*E1 - E2 + DAJN(J) F2 = TEMP1 E2 = TEMP2 110 CONTINUE DAI = X*X*(T*F1-F2+DAJP(1)) + (T*E1-E2+DAJN(1)) RETURN C 120 CONTINUE T = 10.0E0/C - 1.0E0 TT = T + T J = N4 F1 = A(J) E1 = B(J) F2 = 0.0E0 E2 = 0.0E0 DO 130 I=1,M4 J = J - 1 TEMP1 = F1 TEMP2 = E1 F1 = TT*F1 - F2 + A(J) E1 = TT*E1 - E2 + B(J) F2 = TEMP1 E2 = TEMP2 130 CONTINUE TEMP1 = T*F1 - F2 + A(1) TEMP2 = T*E1 - E2 + B(1) RTRX = SQRT(RX) CV = C - FPI12 CCV = COS(CV) SCV = SIN(CV) AI = (TEMP1*CCV-TEMP2*SCV)/RTRX J = N4D F1 = DA(J) E1 = DB(J) F2 = 0.0E0 E2 = 0.0E0 DO 140 I=1,M4D J = J - 1 TEMP1 = F1 TEMP2 = E1 F1 = TT*F1 - F2 + DA(J) E1 = TT*E1 - E2 + DB(J) F2 = TEMP1 E2 = TEMP2 140 CONTINUE TEMP1 = T*F1 - F2 + DA(1) TEMP2 = T*E1 - E2 + DB(1) E1 = CCV*CON5 + 0.5E0*SCV E2 = SCV*CON5 - 0.5E0*CCV DAI = (TEMP1*E1-TEMP2*E2)*RTRX RETURN END SUBROUTINE JNSN(XBAR, SD, RB1, BB2, ITYPE, GAMMA, DELTA, $ XLAM, XI, IFAULT) CSTART OF AS 99 C C ALGORITHM AS 99 APPL. STATIST. (1976) VOL.25, P.180 C C FINDS TYPE AND PARAMETERS OF A JOHNSON CURVE C WITH GIVEN FIRST FOUR MOMENTS C REAL XBAR, SD, RB1, BB2, GAMMA, DELTA, XLAM, XI, TOL, $ B1, B2, Y, X, U, W, ZERO, ONE, TWO, THREE, FOUR, HALF, $ QUART, ZABS, ZEXP, ZLOG, ZSIGN, ZSQRT LOGICAL FAULT C DATA TOL /0.01/ DATA ZERO, QUART, HALF, ONE, TWO, THREE, FOUR $ /0.0, 0.25, 0.5, 1.0, 2.0, 3.0, 4.0/ C ZABS(X) = ABS(X) ZEXP(X) = EXP(X) ZLOG(X) = ALOG(X) ZSIGN(X, Y) = SIGN(X, Y) ZSQRT(X) = SQRT(X) C IFAULT = 1 IF (SD .LT. ZERO) RETURN IFAULT = 0 XI = ZERO XLAM = ZERO GAMMA = ZERO DELTA = ZERO IF (SD .GT. ZERO) GOTO 10 ITYPE = 5 XI = XBAR RETURN 10 B1 = RB1 * RB1 B2 = BB2 FAULT = .FALSE. C C TEST WHETHER LOGNORMAL (OR NORMAL) REQUESTED C IF (B2 .GE. ZERO) GOTO 30 20 IF (ZABS(RB1) .LE. TOL) GOTO 70 GOTO 80 C C TEST FOR POSITION RELATIVE TO BOUNDARY LINE C 30 IF (B2 .GT. B1 + TOL + ONE) GOTO 60 IF (B2 .LT. B1 + ONE) GOTO 50 C C ST DISTRIBUTION C 40 ITYPE = 5 Y = HALF + HALF * ZSQRT(ONE - FOUR / (B1 + FOUR)) IF (RB1 .GT. ZERO) Y = ONE - Y X = SD / ZSQRT(Y * (ONE - Y)) XI = XBAR - Y * X XLAM = XI + X DELTA = Y RETURN 50 IFAULT = 2 RETURN 60 IF (ZABS(RB1) .GT. TOL .OR. ZABS(B2 - THREE) .GT. TOL) GOTO 80 C C NORMAL DISTRIBUTION C 70 ITYPE = 4 DELTA = ONE / SD GAMMA = -XBAR / SD RETURN C C TEST FOR POSITION RELATIVE TO LOGNORMAL LINE C 80 X = HALF * B1 + ONE Y = ZABS(RB1) * ZSQRT(QUART * B1 + ONE) U = (X + Y) ** (ONE / THREE) W = U + ONE / U - ONE U = W * W * (THREE + W * (TWO + W)) - THREE IF (B2 .LT. ZERO .OR. FAULT) B2 = U X = U - B2 IF (ZABS(X) .GT. TOL) GOTO 90 C C LOGNORMAL (SL) DISTRIBUTION C ITYPE = 1 XLAM = ZSIGN(ONE, RB1) U = XLAM * XBAR X = ONE / ZSQRT(ZLOG(W)) DELTA = X Y = HALF * X * ZLOG(W * (W - ONE) / (SD * SD)) GAMMA = Y XI = XLAM * (U - ZEXP((HALF / X - Y) / X)) RETURN C C SB OR SU DISTRIBUTION C 90 IF (X .GT. ZERO) GOTO 100 ITYPE = 2 CALL SUFIT(XBAR, SD, RB1, B2, GAMMA, DELTA, XLAM, XI) RETURN 100 ITYPE = 3 CALL SBFIT(XBAR, SD, RB1, B2, GAMMA, DELTA, XLAM, XI, FAULT) IF (.NOT. FAULT) RETURN C C FAILURE - TRY TO FIT APPROXIMATE RESULT C IFAULT = 3 IF (B2 .GT. B1 + TWO) GOTO 20 GOTO 40 END SUBROUTINE JSBCDF(X,ALPHA1,ALPHA2,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE JOHNSON SB SYSTEM DISTRIBUTION. C THIS DISTRIBUTION CAN BE DEFINED IN TERMS OF THE C NORMAL DISTRIBUTION: C F(X) = NORCDF(ALPHA1 + ALPHA2*LOG(X/(1-X)) C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE C AT WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C X SHOULD BE POSITIVE. C --ALPHA1 = FIRST SHAPE PARAMETER C --ALPHA2 = SECOND SHAPE PARAMETER C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION C FUNCTION VALUE CDF FOR THE JOHNSON SB C DISTRIBUTION. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE POSITIVE. C OTHER DATAPAC SUBROUTINES NEEDED--NORCDF. C FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN. C REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--1, 2ND ED., 1994, PAGE 34. 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--SEPTEMBER 2001. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C DOUBLE PRECISION DARG 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--------------------------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(X.LE.0.0)THEN CDF=0.0 GOTO9000 ENDIF IF(X.GE.1.0)THEN CDF=1.0 GOTO9000 ENDIF C IF(ALPHA2.LE.0.0)THEN WRITE(ICOUT,14) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALPHA1 CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9000 ENDIF C 14 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE JSBCDF ') 15 FORMAT(' SUBROUTINE IS NON-POSITIVE.') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C C-----START POINT----------------------------------------------------- C CDF=0.0 C ARG=ALPHA1 + ALPHA2*ALOG(X/(1.0-X)) DARG=DBLE(ARG) CALL NODCDF(DARG,DCDF) CDF=REAL(DCDF) C 9000 CONTINUE RETURN END SUBROUTINE JSBPDF(X,ALPHA1,ALPHA2,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE JOHNSON SB SYSTEM DISTRIBUTION. C THIS DISTRIBUTION CAN BE DEFINED IN TERMS OF THE C NORMAL DISTRIBUTION: C F(X) = (ALPHA2/(X*(1-X))* C NORPDF(ALPHA1 + ALPHA2*LOG(X/(1-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 POSITIVE. C --ALPHA1 = FIRST SHAPE PARAMETER C --ALPHA2 = SECOND SHAPE PARAMETER C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY C FUNCTION VALUE PDF FOR THE JOHNSON SB C DISTRIBUTION. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE POSITIVE. C OTHER DATAPAC SUBROUTINES NEEDED--NORPDF. C FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN. C REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--1, 2ND ED., 1994, PAGE 34. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-975-2855 C ORIGINAL VERSION--SEPTEMBER 2001. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C DOUBLE PRECISION DARG DOUBLE PRECISION DX 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--------------------------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(X.LE.0.0 .OR. X.GE.1.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 GOTO9000 ENDIF C IF(ALPHA2.LE.0.0)THEN WRITE(ICOUT,14) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALPHA1 CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9000 ENDIF C 4 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE JSBPDF ') 5 FORMAT(' SUBROUTINE IS OUTSIDE THE (0,1) INTERVAL.') 14 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE JSBPDF ') 15 FORMAT(' SUBROUTINE IS NON-POSITIVE.') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C C-----START POINT----------------------------------------------------- C PDF=0.0 C ARG=ALPHA1 + ALPHA2*ALOG(X/(1.0-X)) DARG=DBLE(ARG) CALL NODPDF(DARG,DPDF) DX=DBLE(X) DPDF=(DBLE(ALPHA2)/(DX*(1.0D0-DX)))*DPDF PDF=REAL(DPDF) C 9000 CONTINUE RETURN END SUBROUTINE JSBPPF(P,ALPHA1,ALPHA2,PPF) C C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2001/9 C ORIGINAL VERSION--SEPTEMBER 2001. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES---------------- C DOUBLE PRECISION DCDF DOUBLE PRECISION DALPH1 DOUBLE PRECISION DALPH2 DOUBLE PRECISION DX DOUBLE PRECISION DARG DOUBLE PRECISION DP DOUBLE PRECISION EPS DOUBLE PRECISION SIG DOUBLE PRECISION ZERO DOUBLE PRECISION A DOUBLE PRECISION B DOUBLE PRECISION AB DOUBLE PRECISION XL DOUBLE PRECISION XR DOUBLE PRECISION XRML DOUBLE PRECISION FXL DOUBLE PRECISION FXR DOUBLE PRECISION FCS 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 /1.0D-6/ DATA SIG /1.0D-5/ DATA ZERO /0.D0/ DATA MAXIT /3000/ C C-----START POINT--------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(P.LE.0.0)THEN PPF=0.0 GOTO9999 ELSEIF(P.GE.1.0)THEN PPF=1.0 GOTO9999 ENDIF C IF(ALPHA2.LE.0.0)THEN WRITE(ICOUT,14) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALPHA1 CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF C 4 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE JSBPPF ') 5 FORMAT(' SUBROUTINE IS NON-POSITIVE.') 14 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE JSBPPF ') 15 FORMAT(' SUBROUTINE IS NON-POSITIVE.') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C A = ALPHA1 B = ALPHA2 DP = DBLE(P) C IERR=0 IC = 0 AB = A/B XL = 0.0D0 XR = 1.0D0 FXL = -DP FXR = 1.0D0 - DP C IF(FXL*FXR .GT. ZERO)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF C C BISECTION METHOD C 105 CONTINUE DX = (XL+XR)*0.5D0 DALPH1=DBLE(A) DALPH2=DBLE(B) DARG=DALPH1 + DALPH2*DLOG(DX/(1.0D0-DX)) CALL NODCDF(DARG,DCDF) P1=DCDF PPF=REAL(DX) C FCS = P1 - DP IF(FCS*FXL.GT.ZERO)GOTO110 XR = DX FXR = FCS GOTO115 110 CONTINUE XL = DX 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--JSBPPF ROUTINE DID NOT CONVERGE. ', 1 '***') GOTO9999 C 9999 CONTINUE RETURN END SUBROUTINE JSBRAN(N,ALPHA1,ALPHA2,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE JOHNSON SB DISTRIBUTION C WITH SHAPE PARAMETER VALUES = ALPHA1, ALPHA2. C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --ALPHA1 = THE SINGLE PRECISION VALUE OF THE C FIRST SHAPE PARAMETER. C ALPHA1 SHOULD BE POSITIVE. C --ALPHA2 = THE SINGLE PRECISION VALUE OF THE C SECOND SHAPE PARAMETER. C ALPHA2 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 JOHNSON SB DISTRIBUTION C WITH SHAPE PARAMETER VALUES = ALPHA1 AND ALPHA2. 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 --ALPHA2 SHOULD BE POSITIVE. C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2001.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'JSBRAN SUBROUTINE IS NON-POSITIVE *****') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') C C GENERATE N STANDARD NORMAL RANDOM NUMBERS; C CALL NORRAN(N,ISEED,X) C C GENERATE N JOHNSON SB DISTRIBUTION RANDOM NUMBERS C USING APPLIED STATISTICS ALGORITHM AS100. C ITYPE=3 ALOC=0.0 SCALE=1.0 DO100I=1,N XTEMP=X(I) XTEMP2=AJV(XTEMP,ITYPE,ALPHA1,ALPHA2,SCALE,ALOC,IFAULT) X(I)=XTEMP2 100 CONTINUE C 9000 CONTINUE RETURN END SUBROUTINE JSUCDF(X,ALPHA1,ALPHA2,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE JOHNSON SU SYSTEM DISTRIBUTION. C THIS DISTRIBUTION CAN BE DEFINED IN TERMS OF THE C NORMAL DISTRIBUTION: C F(X) = NORCDF(ALPHA1 + ALPHA2*LOG(X + SQRT(x**2+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 POSITIVE. C --ALPHA1 = FIRST SHAPE PARAMETER C --ALPHA2 = SECOND SHAPE PARAMETER C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION C FUNCTION VALUE CDF FOR THE JOHNSON SU C DISTRIBUTION. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE POSITIVE. C OTHER DATAPAC SUBROUTINES NEEDED--NORCDF. C FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN. C REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--1, 2ND ED., 1994, PAGE 34. 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--SEPTEMBER 2001. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C DOUBLE PRECISION DARG 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--------------------------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(ALPHA2.LE.0.0)THEN WRITE(ICOUT,14) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALPHA1 CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9000 ENDIF C 14 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE JSUCDF ') 15 FORMAT(' SUBROUTINE IS NON-POSITIVE.') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C C-----START POINT----------------------------------------------------- C CDF=0.0 C ARG=ALPHA1 + ALPHA2*ALOG(X + SQRT(X**2+1)) DARG=DBLE(ARG) CALL NODCDF(DARG,DCDF) CDF=REAL(DCDF) C 9000 CONTINUE RETURN END SUBROUTINE JSUPDF(X,ALPHA1,ALPHA2,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE JOHNSON SU SYSTEM DISTRIBUTION. C THIS DISTRIBUTION CAN BE DEFINED IN TERMS OF THE C NORMAL DISTRIBUTION: C F(X) = (ALPHA2/SQRT(X**2 + 1))* C NORPDF(ALPHA1 + ALPHA2*LOG(X + SQRT(X**2+1))) C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE C AT WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C X SHOULD BE POSITIVE. C --ALPHA1 = FIRST SHAPE PARAMETER C --ALPHA2 = SECOND SHAPE PARAMETER C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY C FUNCTION VALUE PDF FOR THE JOHNSON SU C DISTRIBUTION. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE POSITIVE. C OTHER DATAPAC SUBROUTINES NEEDED--NORPDF. C FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN. C REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--1, 2ND ED., 1994, PAGE 34. 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--SEPTEMBER 2001. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C DOUBLE PRECISION DARG DOUBLE PRECISION DX 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--------------------------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(ALPHA2.LE.0.0)THEN WRITE(ICOUT,14) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALPHA1 CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9000 ENDIF C 14 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE JSUPDF ') 15 FORMAT(' SUBROUTINE IS NON-POSITIVE.') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C C-----START POINT----------------------------------------------------- C PDF=0.0 C ARG=ALPHA1 + ALPHA2*ALOG(X + SQRT(X**2+1.0)) DARG=DBLE(ARG) CALL NODPDF(DARG,DPDF) DX=DBLE(X) DPDF=(DBLE(ALPHA2)/DSQRT(DX*DX+1.0D0))*DPDF PDF=REAL(DPDF) C 9000 CONTINUE RETURN END SUBROUTINE JSUPPF(P,ALPHA1,ALPHA2,PPF) C C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--THE PERCENT POINT FUNCTION FOR THE JOHNSON SU C FUNCTION IS: C G(P,ALPHA1,ALPHA2) = SINH[(NORPPF(P) - ALPHA1)/ALPHA2] C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2001/9 C ORIGINAL VERSION--SEPTEMBER 2001. C UPDATED --NOVEMBER 2003. USE CLOSED FORMULA BASED C ON NORPPF C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES---------------- C DOUBLE PRECISION DPPF DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 CCCCC DOUBLE PRECISION DCDF CCCCC DOUBLE PRECISION DALPH1 CCCCC DOUBLE PRECISION DALPH2 CCCCC DOUBLE PRECISION DX CCCCC DOUBLE PRECISION DARG CCCCC DOUBLE PRECISION EPS CCCCC DOUBLE PRECISION SIG CCCCC DOUBLE PRECISION ZERO CCCCC DOUBLE PRECISION XL CCCCC DOUBLE PRECISION XR CCCCC DOUBLE PRECISION XINC CCCCC DOUBLE PRECISION DP CCCCC DOUBLE PRECISION A CCCCC DOUBLE PRECISION B CCCCC DOUBLE PRECISION AB CCCCC DOUBLE PRECISION FXL CCCCC DOUBLE PRECISION FXR CCCCC DOUBLE PRECISION FCS CCCCC DOUBLE PRECISION P1 CCCCC DOUBLE PRECISION XRML 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 /1.0D-6/ CCCCC DATA SIG /1.0D-5/ CCCCC DATA ZERO /0./ CCCCC DATA MAXIT /3000/ C C-----START POINT--------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(P.LE.0.0)THEN PPF=0.0 GOTO9999 ELSEIF(P.GE.1.0)THEN PPF=0.0 GOTO9999 ENDIF C IF(ALPHA2.LE.0.0)THEN WRITE(ICOUT,14) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALPHA1 CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF C 4 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE JSUPPF ') 5 FORMAT(' SUBROUTINE IS NON-POSITIVE.') 14 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE JSUPPF ') 15 FORMAT(' SUBROUTINE IS NON-POSITIVE.') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C C NOTE: NOVEMBER 2003. USE CLOSED FORM SOLUTION FOR PPF FUNCTION. C CALL NODPPF(DBLE(P),DTERM1) DTERM2=(DTERM1 - DBLE(ALPHA1))/DBLE(ALPHA2) DTERM3=(DEXP(DTERM2) - DEXP(-DTERM2))/2.0D0 PPF=REAL(DTERM3) C C FIND BRACKETING INTERVAL. C CCCCC IF(ALPHA1.GE.-1.0)THEN CCCCC XL=-20.0D0 CCCCC XINC=20.0D0 CCCCC ELSEIF(ALPHA1.GE.-1.0)THEN CCCCC XL=-50.0D0 CCCCC XINC=50.0D0 CCCCC ELSE CCCCC XL=-100.0D0 CCCCC XINC=100.0D0 CCCCC ENDIF CCCCC XR=XL+XINC CCCCC ICOUNT=0 CCCCC MAXCNT=50000 C CCC91 CONTINUE CCCCC CALL JSUCDF(REAL(XL),ALPHA1,ALPHA2,CDFL) CCCCC CALL JSUCDF(REAL(XR),ALPHA1,ALPHA2,CDFR) CCCCC IF(CDFL.LT.P .AND. CDFR.LT.P)THEN CCCCC XR=XR + XINC CCCCC ELSEIF(CDFL.GT.P .AND. CDFR.GT.P)THEN CCCCC XL=XL - XINC CCCCC ELSE CCCCC GOTO99 CCCCC ENDIF CCCCC ICOUNT=ICOUNT+1 CCCCC IF(ICOUNT.GT.MAXCNT)THEN CCCCC WRITE(ICOUT,96) CCCCC CALL DPWRST('XXX','BUG ') CCCCC PPF=0.0 CCCCC GOTO9999 CCCCC ENDIF CCC96 FORMAT('***** FATAL ERROR--JSUPPF UNABLE TO FIND BRACKETING ', CCCCC* 'INTERVAL. *****') CCCCC GOTO91 C CCC99 CONTINUE CCCCC A = DBLE(ALPHA1) CCCCC B = DBLE(ALPHA2) CCCCC DP=DBLE(P) C CCCCC IERR=0 CCCCC IC = 0 CCCCC AB = A/B CCCCC FXL = -DP CCCCC FXR = 1.0D0 - DP C CCCCC IF(FXL*FXR .GT. ZERO)THEN CCCCC WRITE(ICOUT,4) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,5) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,46)P CCCCC CALL DPWRST('XXX','BUG ') CCCCC PPF=0.0 CCCCC GOTO9999 CCCCC ENDIF C C BISECTION METHOD C CC105 CONTINUE CCCCC DX = (XL+XR)*0.5D0 CCCCC DALPH1=DBLE(A) CCCCC DALPH2=DBLE(B) CCCCC DARG=DALPH1 + DALPH2*DLOG(DX + DSQRT(DX**2 + 1.0D0)) CCCCC CALL NODCDF(DARG,DCDF) CCCCC P1=REAL(DCDF) CCCCC PPF=REAL(DX) C CCCCC FCS = P1 - DP CCCCC IF(FCS*FXL.GT.ZERO)GOTO110 CCCCC XR = DX CCCCC FXR = FCS CCCCC GOTO115 CC110 CONTINUE CCCCC XL = DX CCCCC FXL = FCS CC115 CONTINUE CCCCC XRML = XR - XL CCCCC IF(XRML.LE.SIG .AND. ABS(FCS).LE.EPS)GOTO9999 CCCCC IC = IC + 1 CCCCC IF(IC.LE.MAXIT)GOTO105 CCCCC WRITE(ICOUT,130) CCCCC CALL DPWRST('XXX','BUG ') CC130 FORMAT('***** FATAL ERROR--JSUPPF ROUTINE DID NOT CONVERGE. ', CCCCC1 '***') CCCCC GOTO9999 C 9999 CONTINUE RETURN END SUBROUTINE JSURAN(N,ALPHA1,ALPHA2,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE JOHNSON SU DISTRIBUTION C WITH SHAPE PARAMETER VALUES = ALPHA1, ALPHA2. C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --ALPHA1 = THE SINGLE PRECISION VALUE OF THE C FIRST SHAPE PARAMETER. C ALPHA1 SHOULD BE POSITIVE. C --ALPHA2 = THE SINGLE PRECISION VALUE OF THE C SECOND SHAPE PARAMETER. C ALPHA2 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 JOHNSON SU DISTRIBUTION C WITH SHAPE PARAMETER VALUES = ALPHA1 AND ALPHA2. 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 --ALPHA2 SHOULD BE POSITIVE. C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2001.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'JSURAN SUBROUTINE IS NON-POSITIVE *****') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') C C GENERATE N STANDARD NORMAL RANDOM NUMBERS; C CALL NORRAN(N,ISEED,X) C C GENERATE N JOHNSON SU DISTRIBUTION RANDOM NUMBERS C USING APPLIED STATISTICS ALGORITHM. C C GENERATE N JOHNSON SU DISTRIBUTION RANDOM NUMBERS C USING APPLIED STATISTICS ALGORITHM AS100. C ITYPE=2 ALOC=0.0 SCALE=1.0 DO100I=1,N XTEMP=X(I) XTEMP2=AJV(XTEMP,ITYPE,ALPHA1,ALPHA2,SCALE,ALOC,IFAULT) X(I)=XTEMP2 100 CONTINUE C 9000 CONTINUE RETURN END DOUBLE PRECISION FUNCTION K0INT(XVALUE) C C DESCRIPTION: C C This function calculates the integral of the modified Bessel function C defined by C C K0INT(x) = {integral 0 to x} K0(t) dt C C The code uses Chebyshev expansions, whose coefficients are C given to 20 decimal places. C C C ERROR RETURNS: C C If XVALUE < 0.0, the function is undefined. An error message is C printed and the function returns the value 0.0. C C C MACHINE-DEPENDENT CONSTANTS: C C NTERM1 - The no. of terms to be used in the array AK0IN1. The C recommended value is such that C ABS(AK0IN1(NTERM1)) < EPS/100, C C NTERM2 - The no. of terms to be used in the array AK0IN2. The C recommended value is such that C ABS(AK0IN2(NTERM2)) < EPS/100, C C NTERM3 - The no. of terms to be used in the array AK0INA. The C recommended value is such that C ABS(AK0INA(NTERM3)) < EPS/100, C C XLOW - The value below which K0INT = x * ( const - ln(x) ) to C machine precision. The recommended value is C sqrt (18*EPSNEG). C C XHIGH - The value above which K0INT = pi/2 to machine precision. C The recommended value is C - log (2*EPSNEG) C C For values of EPS and EPSNEG refer to the file MACHCON.TXT. C C The machine-dependent constants are computed internally by C using the D1MACH subroutine. C C C INTRINSIC FUNCTIONS USED: C C EXP , LOG , SQRT C C C OTHER MISCFUN SUBROUTINES USED: C C CHEVAL , ERRPRN, D1MACH C C C AUTHOR: C Dr. Allan J. MacLeod, C Dept. of Mathematics and Statistics, C University of Paisley, C High St., C Paisley, C SCOTLAND C C (e-mail: macl_ms0@paisley.ac.uk ) C C C LATEST REVISION: C 23 January, 1996 C INTEGER NTERM1,NTERM2,NTERM3 DOUBLE PRECISION AK0IN1(0:15),AK0IN2(0:15),AK0INA(0:27), 1 CHEVAL,CONST1,CONST2,EIGHTN,FVAL,HALF, 2 ONEHUN,PIBY2,RT2BPI,SIX,T,TEMP,TWELVE,X, 3 XHIGH,XLOW,XVALUE,ZERO C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOMC.INC' CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C CCCCC CHARACTER FNNAME*8,ERRMSG*14 CCCCC DATA FNNAME/'K0INT '/ CCCCC DATA ERRMSG/'ARGUMENT < 0.0'/ DATA ZERO,HALF,SIX/ 0.0 D 0 , 0.5 D 0 , 6.0 D 0 / DATA TWELVE,EIGHTN,ONEHUN/ 12.0 D 0 , 18.0 D 0 , 100.0 D 0 / DATA CONST1/1.11593 15156 58412 44881 D 0/ DATA CONST2/-0.11593 15156 58412 44881 D 0/ DATA PIBY2/1.57079 63267 94896 61923 D 0/ DATA RT2BPI/0.79788 45608 02865 35588 D 0/ DATA AK0IN1/16.79702 71446 47109 59477 D 0, 1 9.79134 68767 68894 07070 D 0, 2 2.80501 31604 43379 39300 D 0, 3 0.45615 62053 18885 02068 D 0, 4 0.47162 24457 07476 0784 D -1, 5 0.33526 51482 69698 289 D -2, 6 0.17335 18119 38747 27 D -3, 7 0.67995 18893 64702 D -5, 8 0.20900 26835 9924 D -6, 9 0.51660 38469 76 D -8, X 0.10485 70833 1 D -9, 1 0.17782 9320 D -11, 2 0.25568 44 D -13, 3 0.31557 D -15, 4 0.338 D -17, 5 0.3 D -19/ DATA AK0IN2/10.76266 55822 78091 74077 D 0, 1 5.62333 47984 99975 11550 D 0, 2 1.43543 66487 92908 67158 D 0, 3 0.21250 41014 37438 96043 D 0, 4 0.20365 37393 10000 9554 D -1, 5 0.13602 35840 95623 632 D -2, 6 0.66753 88699 20909 3 D -4, 7 0.25043 00357 07337 D -5, 8 0.74064 23741 728 D -7, 9 0.17697 47043 14 D -8, X 0.34857 75254 D -10, 1 0.57544 785 D -12, 2 0.80748 1 D -14, 3 0.9747 D -16, 4 0.102 D -17, 5 0.1 D -19/ DATA AK0INA(0)/ 1.91172 06544 50604 53895 D 0/ DATA AK0INA(1)/ -0.41830 64565 76958 1085 D -1/ DATA AK0INA(2)/ 0.21335 25080 68147 486 D -2/ DATA AK0INA(3)/ -0.15859 49728 45041 81 D -3/ DATA AK0INA(4)/ 0.14976 24699 85835 1 D -4/ DATA AK0INA(5)/ -0.16795 59553 22241 D -5/ DATA AK0INA(6)/ 0.21495 47247 8804 D -6/ DATA AK0INA(7)/ -0.30583 56654 790 D -7/ DATA AK0INA(8)/ 0.47494 64133 43 D -8/ DATA AK0INA(9)/ -0.79424 66043 2 D -9/ DATA AK0INA(10)/ 0.14156 55532 5 D -9/ DATA AK0INA(11)/-0.26678 25359 D -10/ DATA AK0INA(12)/ 0.52814 9717 D -11/ DATA AK0INA(13)/-0.10926 3199 D -11/ DATA AK0INA(14)/ 0.23518 838 D -12/ DATA AK0INA(15)/-0.52479 91 D -13/ DATA AK0INA(16)/ 0.12101 91 D -13/ DATA AK0INA(17)/-0.28763 2 D -14/ DATA AK0INA(18)/ 0.70297 D -15/ DATA AK0INA(19)/-0.17631 D -15/ DATA AK0INA(20)/ 0.4530 D -16/ DATA AK0INA(21)/-0.1190 D -16/ DATA AK0INA(22)/ 0.319 D -17/ DATA AK0INA(23)/-0.87 D -18/ DATA AK0INA(24)/ 0.24 D -18/ DATA AK0INA(25)/-0.7 D -19/ DATA AK0INA(26)/ 0.2 D -19/ DATA AK0INA(27)/-0.1 D -19/ C C Start computation C X = XVALUE C C Error test C IF ( X .LT. ZERO ) THEN CCCCC CALL ERRPRN(FNNAME,ERRMSG) WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,101)X CALL DPWRST('XXX','BUG ') K0INT = ZERO RETURN ENDIF 999 FORMAT(1X) 101 FORMAT('***** ERROR FROM I0INT--ARGUMENT MUST BE ', 1 'NON-NEGATIVE, ARGUMENT = ',G15.7) C C Compute the machine-dependent constants. C TEMP = D1MACH(3) T = TEMP / ONEHUN IF ( X .LE. SIX ) THEN DO 10 NTERM1 = 15 , 0 , -1 IF ( ABS(AK0IN1(NTERM1)) .GT. T ) GOTO 19 10 CONTINUE 19 DO 20 NTERM2 = 15 , 0 , -1 IF ( ABS(AK0IN2(NTERM2)) .GT. T ) GOTO 29 20 CONTINUE 29 XLOW = SQRT ( EIGHTN * TEMP ) ELSE DO 40 NTERM3 = 27 , 0 , -1 IF ( ABS(AK0INA(NTERM3)) .GT. T ) GOTO 49 40 CONTINUE 49 XHIGH = - LOG ( TEMP + TEMP ) ENDIF C C Code for 0 <= XVALUE <= 6 C IF ( X .LE. SIX ) THEN IF ( X .LT. XLOW ) THEN FVAL = X IF ( X .GT. ZERO ) THEN FVAL = FVAL * ( CONST1 - LOG(X) ) ENDIF K0INT = FVAL ELSE T = ( ( X * X ) / EIGHTN - HALF ) - HALF FVAL = ( CONST2 + LOG(X) ) * CHEVAL(NTERM2,AK0IN2,T) K0INT = X * ( CHEVAL(NTERM1,AK0IN1,T) - FVAL ) ENDIF C C Code for x > 6 C ELSE FVAL = PIBY2 IF ( X .LT. XHIGH ) THEN T = ( TWELVE / X - HALF ) - HALF TEMP = EXP(-X) * CHEVAL(NTERM3,AK0INA,T) FVAL = FVAL - TEMP / ( SQRT(X) * RT2BPI) ENDIF K0INT = FVAL ENDIF RETURN END SUBROUTINE KAPCDF(X,AK,BETA,THETA,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DENSITY C FUNCTION VALUE FOR THE MIELKE'S BETA-KAPPA DISTRIBUTION C WITH POSITIVE SHAPE PARAMETERS K, BETA, AND THETA. C THIS DISTRIBUTION IS DEFINED FOR X > 0. C THE PDF FOR THE DISTRIBUTION IS C F(X) = (K/B)*(X/B)**(K-1)/[1+(X/B)**T]**(1+(K/T)) C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C X SHOULD BE POSITIVE C --AK = A POSITIVE SHAPE PARAMETER C --BETA = A POSITIVE SHAPE PARAMETER C --THETA = A POSITIVE SHAPE PARAMETER C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION C FUNCTION VALUE CDF FOR THE MIELKE'S BETA-KAPPA C DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE POSITIVE. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--2, 2ND ED, 1994, PAGE 351. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--96/1 C ORIGINAL VERSION--JANUARY 1996. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX, DK, DT, DB CCCCC DOUBLE PRECISION DTERM1, DTERM2, DTERM3 DOUBLE PRECISION DTERM1, DTERM2 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 C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(X.LE.0)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ENDIF 5 FORMAT('***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO THE ', 1'KAPCDF SUBROUTINE IS NON-POSITIVE *****') IF(AK.LE.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)AK CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ENDIF 15 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1'KAPCDF SUBROUTINE IS NON-POSITIVE *****') IF(BETA.LE.0)THEN WRITE(ICOUT,25) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)BETA CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ENDIF 25 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ', 1'KAPCDF SUBROUTINE IS NON-POSITIVE *****') IF(THETA.LE.0)THEN WRITE(ICOUT,35) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)THETA CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ENDIF 35 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ', 1'KAPCDF SUBROUTINE IS NON-POSITIVE *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C DX=DBLE(X) DK=DBLE(AK) DB=DBLE(BETA) DT=DBLE(THETA) C DTERM1=DT*DLOG(DX/DB) - DLOG(1.0D0+(DX/DB)**DT) DTERM2=(DK/DT)*DTERM1 DCDF=0.0D0 IF(DTERM2.GE.-80.0D0)DCDF=DEXP(DTERM2) CDF=REAL(DCDF) C 9999 CONTINUE RETURN END SUBROUTINE KAPPDF(X,AK,BETA,THETA,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE MIELKE'S BETA-KAPPA DISTRIBUTION C WITH POSITIVE SHAPE PARAMETERS K, BETA, AND THETA. C THIS DISTRIBUTION IS DEFINED FOR X > 0. C THE PDF FOR THE STANDARD FORM OF THE DISTRIBUTION IS C F(X) = (K/B)*(X/B)**(K-1)/[1+(X/B)**T]**(1+(K/T)) 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 --AK = A POSITIVE SHAPE PARAMETER C --BETA = A POSITIVE SHAPE PARAMETER C --THETA = A POSITIVE SHAPE PARAMETER C OUTPUT ARGUMENTS--PDF = THE SINGLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY C FUNCTION VALUE PDF FOR THE MIELKE'S BETA-KAPPA C DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE POSITIVE. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--2, 2ND ED, 1994, PAGE 351. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--96/1 C ORIGINAL VERSION--JANUARY 1996. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX, DK, DT, DB DOUBLE PRECISION DTERM1, DTERM2, DTERM3 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 C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(X.LE.0)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF 5 FORMAT('***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO THE ', 1'KAPPDF SUBROUTINE IS NON-POSITIVE *****') IF(AK.LE.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)AK CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF 15 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1'KAPPDF SUBROUTINE IS NON-POSITIVE *****') IF(BETA.LE.0)THEN WRITE(ICOUT,25) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)BETA CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF 25 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ', 1'KAPPDF SUBROUTINE IS NON-POSITIVE *****') IF(THETA.LE.0)THEN WRITE(ICOUT,35) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)THETA CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF 35 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ', 1'KAPPDF SUBROUTINE IS NON-POSITIVE *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C DX=DBLE(X) DK=DBLE(AK) DB=DBLE(BETA) DT=DBLE(THETA) C DTERM1=DLOG(DK) + (DK-1.0D0)*DLOG(DX/DB) DTERM2=DLOG(DB) + (1.0D0 + (DK/DT))*DLOG(1.0D0 + (DX/DB)**DT) DTERM3=DTERM1-DTERM2 DPDF=0.0D0 IF(DTERM3.GE.-80.0D0)DPDF=DEXP(DTERM3) PDF=REAL(DPDF) C 9999 CONTINUE RETURN END SUBROUTINE KAPPPF(P,AK,BETA,THETA,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE MIELKE'S BETA-KAPPA DISTRIBUTION C WITH POSITIVE SHAPE PARAMETERS K, BETA, AND THETA. C THIS DISTRIBUTION IS DEFINED FOR X > 0. C THE PDF FOR THE STANDARD FORM OF THE DISTRIBUTION IS C F(X) = (K/B)*(X/B)**(K-1)/[1+(X/B)**T]**(1+(K/T)) 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 --AK = A POSITIVE SHAPE PARAMETER C --BETA = A POSITIVE SHAPE PARAMETER C --THETA = A POSITIVE SHAPE PARAMETER C OUTPUT ARGUMENTS--PDF = THE SINGLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY C FUNCTION VALUE PDF FOR THE MIELKE'S BETA-KAPPA C DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE POSITIVE. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--2, 2ND ED, 1994, PAGE 351. C THE JOHNSON AND KOTZ BOOK APPEARS TO HAVE AN C ERROR IN THE PPF FORMULA C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--95/10 C ORIGINAL VERSION--OCTOBER 1995. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DP, DK, DT, DB DOUBLE PRECISION DTERM1, DTERM2, DTERM3, DTERM4, DTERM5 DOUBLE PRECISION DPPF C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(P.LE.0.0.OR.P.GE.1.0)THEN WRITE(ICOUT,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' KAPPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL.') IF(AK.LE.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)AK CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF 15 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1'KAPPPF SUBROUTINE IS NON-POSITIVE *****') IF(BETA.LE.0)THEN WRITE(ICOUT,25) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)BETA CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF 25 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ', 1'KAPPPF SUBROUTINE IS NON-POSITIVE *****') IF(THETA.LE.0)THEN WRITE(ICOUT,35) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)THETA CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF 35 FORMAT('***** FATAL ERROR--THE THIRD INPUT ARGUMENT TO THE ', 1'KAPPPF SUBROUTINE IS NON-POSITIVE *****') C 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C DP=DBLE(P) DK=DBLE(AK) DB=DBLE(BETA) DT=DBLE(THETA) C DTERM1=DLOG(DB) DTERM2=(1.0D0/DT) DTERM3=DP**(DT/DK) DTERM4=DLOG(-DTERM3/(DTERM3-1.0D0)) DTERM5=DTERM1 + DTERM2*DTERM4 DPPF=0.0D0 IF(DTERM5.GE.-80.0D0)DPPF=DEXP(DTERM5) PPF=REAL(DPPF) C 9999 CONTINUE RETURN END SUBROUTINE KAPRAN(N,AK,BETA,THETA,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE MIELKE'S BETA-KAPPA DISTRIBUTION C WITH SHAPE PARAMETERs = K, BETA, THETA. C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --K = THE SINGLE PRECISION VALUE OF THE C K SHAPE PARAMETER. C ANU SHOULD BE A POSITIVE INTEGER. C --BETA = THE SINGLE PRECISION VALUE OF THE C BETA SHAPE PARAMETER. C --THETA = THE SINGLE PRECISION VALUE OF THE C THETA 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 MIELKE'S BETA-KAPPA DISTRIBUTION C WITH DEGREES OF FREEDOM PARAMETER VALUE = ANU. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C --ANU SHOULD BE POSITIVE. C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--2003.7 C ORIGINAL VERSION--JULY 2003. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)THEN WRITE(ICOUT, 5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 5 FORMAT('***** FATAL ERROR--THE REQUESTED NUMBER OF MIELKE ', 1 'BETA-KAPPA RANDOM NUMBERS IS NON-POSITIVE.') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) C IF(AK.LE.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)AK CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF 15 FORMAT('***** FATAL ERROR--THE FIRST SHAPE PARAMETER (K) FOR ', 1'THE MIELKE BETA-KAPPA RANDOM NUMBERS IS NON-POSITIVE') IF(BETA.LE.0)THEN WRITE(ICOUT,25) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)BETA CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF 25 FORMAT('***** FATAL ERROR--THE SECOND SHAPE PARAMETER (BETA) ', 1'FOR THE MIELKE BETA-KAPPA RANDOM NUMBERS IS NON-POSITIVE') IF(THETA.LE.0)THEN WRITE(ICOUT,35) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)THETA CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF 35 FORMAT('***** FATAL ERROR--THE THIRD SHAPE PARAMETER (THETA) ', 1'FOR THE MIELKE BETA-KAPPA RANDOM NUMBERS IS NON-POSITIVE') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C C GENERATE N UNIFORM (0,1) RANDOM NUMBERS; C CALL UNIRAN(N,ISEED,X) C C GENERATE N MIELKE'S BETA-KAPPA DISTRIBUTION RANDOM C NUMBERS USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD. C DO100I=1,N CALL KAPPPF(X(I),AK,BETA,THETA,XTEMP) X(I)=XTEMP 100 CONTINUE C 9999 CONTINUE RETURN END SUBROUTINE KCONS(Y,X,XIDTEM,TEMP,N,IWRITE,YOUT,NUMSET, 1ISUBRO,IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE K CONSISTENCY STATISTIC C OF THE DATA IN THE INPUT VECTOR Y WITH LAB ID C VECTOR X. THE K CONSISTENCY STATISTIC IS DEFINED AS: C C K(i) = SD(i)/Sr C C WITH SD(i) DENOTING THE STANDARD DEVIATION OF C LAB i AND THE REPEATABILITY STANDARD DEVIATION, C RESPECTIVELY. THE REPEATABILITY STANDARD C DEVIATION IS DEFINED AS: C C Sr = SQRT(SUM[i=1 to p][s(i)**2/p] C C WITH C p = NUMBER OF LABS C s(i) = STANDARD DEVIATION OF GROUP i. C C INPUT ARGUMENTS--Y = THE SINGLE PRECISION VECTOR OF C (UNSORTED OR SORTED) OBSERVATIONS. C --X = THE SINGLE PRECISION VECTOR OF C GROUP ID's. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR Y. C OUTPUT ARGUMENTS--YOUT = THE SINGLE PRECISION VECTOR OF THE C COMPUTED SAMPLE K CONSISTENCY C STATISTIC. C --NUMSET = THE INTEGER VALUE CONTAINING THE C NUMBER OF GROUPS IN X C OUTPUT--THE COMPUTED SINGLE PRECISION VECTOR OF THE C SAMPLE K CONSISTENCY STATISTIC. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--SORT, DISTIN, SD. C FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--"Standard Practice for Conducting an C Interlaboratory Study to Determine the Precision C of a Test Method", ASTM International, C 100 Barr Harbor Drive, PO BOX C700, C West Conshohoceken, PA 19428-2959, USA. C This document is in support of C ASTM Standard E 691 - 99. 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 LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2005.2 C ORIGINAL VERSION--FEBRUARY 2005. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DOUBLE PRECISION DSUM C DIMENSION Y(*) DIMENSION X(*) DIMENSION YOUT(*) DIMENSION XIDTEM(*) DIMENSION TEMP(*) 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='KCON' ISUBN2='S ' C IERROR='NO' C IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CONS')THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF KCONS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3,ISUBRO,N 52 FORMAT('IBUGA3,ISUBRO,N = ',A4,1X,A4,1X,I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,Y(I),X(I) 56 FORMAT('I,Y(I),X(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE ENDIF C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C AN=N C IF(N.LE.1)THEN IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN COMPUTING K CONSISTENCY STATISTIC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,112) 112 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS IN THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,114) 114 FORMAT(' VARIABLES FOR WHICH THE K CONSISTENCY ', 1 'STATISTIC') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,115) 115 FORMAT(' IS TO BE COMPUTED MUST BE 2 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 = ',I8,'.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF C C **************************************************** C ** STEP 2-- ** C ** COMPUTE THE K CONSISTENCY STATISTIC ** C **************************************************** C IWRITE='OFF' CALL DISTIN(X,N,IWRITE,XIDTEM,NUMSET,IBUGA3,IERROR) CALL SORT(XIDTEM,NUMSET,XIDTEM) C IF(NUMSET.LT.1)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,192) 192 FORMAT(' NUMBER OF LABS NUMSET < 1') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF C DSUM=0.0D0 J=0 DO1110ISET1=1,NUMSET K=0 DO1130I=1,N IF(XIDTEM(ISET1).EQ.X(I))THEN K=K+1 TEMP(K)=Y(I) ENDIF 1130 CONTINUE NTEMP=K CALL SD(TEMP,NTEMP,IWRITE,XSD,IBUGA3,IERROR) DSUM=DSUM + DBLE(XSD)**2 YOUT(ISET1)=XSD IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CONS')THEN WRITE(ICOUT,1131)NUMSET,XSD 1131 FORMAT('***** GROUP ',I8,' SD = ',G15.7) CALL DPWRST('XXX','BUG ') ENDIF 1110 CONTINUE C XREP=REAL(DSQRT(DSUM/DBLE(NUMSET))) DO1150I=1,NUMSET YOUT(I)=YOUT(I)/XREP 1150 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CONS')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF KCONS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,ISUBRO,IERROR 9012 FORMAT('IBUGA3,ISUBRO,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N,NUMSET 9013 FORMAT('N,NUMSET = ',I8,1X,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)XREP 9015 FORMAT('XREP = ',E15.7) CALL DPWRST('XXX','BUG ') DO9018I=1,NUMSET WRITE(ICOUT,9019)I,YOUT(I) 9019 FORMAT('I,YOUT(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 9018 CONTINUE ENDIF C RETURN END SUBROUTINE KCONS2(Y,X1,X2,XIDTEM,XIDTE2,TEMP,N, 1IWRITE,YOUT,TAG,NOUT, 1ISUBRO,IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE K CONSISTENCY STATISTIC C OF THE DATA IN THE INPUT VECTOR Y WITH LAB ID C VECTOR X. THE K CONSISTENCY STATISTIC IS DEFINED AS: C C K(i) = SD(i)/Sr C C WITH SD(i) DENOTING THE STANDARD DEVIATION OF C LAB i AND THE REPEATABILITY STANDARD DEVIATION, C RESPECTIVELY. THE REPEATABILITY STANDARD C DEVIATION IS DEFINED AS: C C Sr = SQRT(SUM[i=1 to p][s(i)**2/p] C C WITH C p = NUMBER OF LABS C s(i) = STANDARD DEVIATION OF GROUP i. C C THE DISTINCTION BETWEEN KCONS AND KCONS2 IS THAT C KCONS IS USED TO COMPUTE THE K CONSISTENCY STATISTIC C FOR A SINGLE MATERIAL WHILE KCONS2 COMPUTES THE C K CONSISTENCY STATISTIC FOR MULTIPLE MATERIALS. C C INPUT ARGUMENTS--Y = THE SINGLE PRECISION VECTOR OF C (UNSORTED OR SORTED) OBSERVATIONS. C --X1 = THE SINGLE PRECISION VECTOR OF C GROUP ID's. C --X2 = THE SINGLE PRECISION VECTOR OF C MATERIAL ID's. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR Y. C OUTPUT ARGUMENTS--YOUT = THE SINGLE PRECISION VECTOR OF THE C COMPUTED SAMPLE K CONSISTENCY C STATISTIC. C --TAG = THE SINGLE PRECISION VECTOR OF THE C MATERIAL ID's. C --NOUT = THE INTEGER VALUE CONTAINING THE C NUMBER OF VALUES IN YOUT C OUTPUT--THE COMPUTED SINGLE PRECISION VECTOR OF THE C SAMPLE K CONSISTENCY STATISTIC. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--SORT, DISTIN, SD. C FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--"Standard Practice for Conducting an C Interlaboratory Study to Determine the Precision C of a Test Method", ASTM International, C 100 Barr Harbor Drive, PO BOX C700, C West Conshohoceken, PA 19428-2959, USA. C This document is in support of C ASTM Standard E 691 - 99. 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 LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2005.2 C ORIGINAL VERSION--FEBRUARY 2005. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DOUBLE PRECISION DSUM C DIMENSION Y(*) DIMENSION X1(*) DIMENSION X2(*) DIMENSION YOUT(*) DIMENSION TAG(*) DIMENSION XIDTEM(*) DIMENSION XIDTE2(*) DIMENSION TEMP(*) 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='KCON' ISUBN2='S2 ' C IERROR='NO' C IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ONS2')THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF KCONS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3,ISUBRO,N 52 FORMAT('IBUGA3,ISUBRO,N = ',A4,1X,A4,1X,I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,Y(I),X1(I),X2(I) 56 FORMAT('I,Y(I),X1(I),X2(I) = ',I8,3G15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE ENDIF C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C AN=N C IF(N.LE.1)THEN IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN COMPUTING K CONSISTENCY STATISTIC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,112) 112 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS IN THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,114) 114 FORMAT(' VARIABLES FOR WHICH THE K CONSISTENCY ', 1 'STATISTIC') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,115) 115 FORMAT(' IS TO BE COMPUTED MUST BE 2 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 = ',I8,'.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF C C **************************************************** C ** STEP 2-- ** C ** COMPUTE THE K CONSISTENCY STATISTIC ** C **************************************************** C IWRITE='OFF' CALL DISTIN(X1,N,IWRITE,XIDTEM,NUMSE1,IBUGA3,IERROR) CALL SORT(XIDTEM,NUMSE1,XIDTEM) CALL DISTIN(X2,N,IWRITE,XIDTE2,NUMSE2,IBUGA3,IERROR) CALL SORT(XIDTE2,NUMSE2,XIDTEM) C IF(NUMSE1.LT.1)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,192) 192 FORMAT(' NUMBER OF LABS NUMSE1 < 1') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF C IF(NUMSE2.LT.1)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,194) 194 FORMAT(' NUMBER OF MATERIALS NUMSE2 < 1') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF C J=0 DO1110ISET2=1,NUMSE2 C DSUM=0.0D0 DO1130ISET1=1,NUMSE1 C K=0 DO1140I=1,N IF(XIDTEM(ISET1).EQ.X1(I).AND.XIDTE2(ISET2).EQ.X2(I))THEN K=K+1 TEMP(K)=Y(I) ENDIF 1140 CONTINUE NTEMP=K C CALL SD(TEMP,NTEMP,IWRITE,XSD,IBUGA3,IERROR) DSUM=DSUM + DBLE(XSD)**2 NOUT=(ISET2-1)*NUMSE1 + ISET1 YOUT(NOUT)=XSD IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ONS2')THEN WRITE(ICOUT,1141)NUMSE1,NUMSE2,XSD 1141 FORMAT('***** GROUP ',I8,' SD = ',G15.7) CALL DPWRST('XXX','BUG ') ENDIF 1130 CONTINUE C XREP=REAL(DSQRT(DSUM/DBLE(NUMSE1))) DO1150I=(ISET2-1)*NUMSE1+1,ISET2*NUMSE1 YOUT(I)=YOUT(I)/XREP 1150 CONTINUE C 1110 CONTINUE NOUT=NUMSE1*NUMSE2 C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ONS2')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF KCONS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,ISUBRO,IERROR 9012 FORMAT('IBUGA3,ISUBRO,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N,NUMSE1,NUMSE2,XREP 9013 FORMAT('N,NUMSE1,NUMSE2,XREP = ',I8,1X,I8,1X,I8,G15.7) CALL DPWRST('XXX','BUG ') DO9018I=1,NOUT WRITE(ICOUT,9019)I,TAG(I),YOUT(I) 9019 FORMAT('I,TAG(I),YOUT(I) = ',I8,2G15.7) CALL DPWRST('XXX','BUG ') 9018 CONTINUE ENDIF C RETURN END SUBROUTINE KENTAU(X,Y,N,IWRITE,XTEMP,YTEMP,MAXNXT,XYKTAU, 1IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE KENDELL'S TAU COEFFICIENT C BETWEEN THE 2 SETS OF DATA IN THE INPUT VECTORS X AND Y. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF C (UNSORTED OR SORTED) OBSERVATIONS C WHICH CONSTITUTE THE FIRST SET C OF DATA. C --Y = THE SINGLE PRECISION VECTOR OF C (UNSORTED OR SORTED) OBSERVATIONS C WHICH CONSTITUTE THE SECOND SET C OF DATA. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X, OR EQUIVALENTLY, C THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR Y. C OUTPUT ARGUMENTS--XYKTAU = THE SINGLE PRECISION VALUE OF THE C COMPUTED KENDELL'S TAU C COEFFICIENT BETWEEN THE 2 SETS OF C DATA IN THE INPUT VECTORS X AND Y. C THIS SINGLE PRECISION VALUE C WILL BE BETWEEN -1.0 AND 1.0 C (INCLUSIVELY). C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE C KENDELL'S TAU BETWEEN THE 2 SETS C OF DATA IN THE INPUT VECTORS X AND Y. C OTHER DATAPAC SUBROUTINES NEEDED--SORTC. C FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--W. J. CONOVER, "PRACTICAL NON-PARAMETRIC C STATISTICS", THIRD EDITION, WILEY, 1999, C PP. 318-322. 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/10 C ORIGINAL VERSION--OCTOBER 2004. 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 DIMENSION X(*) DIMENSION Y(*) C DIMENSION XTEMP(*) DIMENSION YTEMP(*) 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='KENT' ISUBN2='AU ' C IERROR='NO' C IF(IBUGA3.EQ.'ON')THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF KENTAU--') 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 ENDIF C C ******************************************** C ** COMPUTE RANK CORRELATION COEFFICIENT ** C ******************************************** C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C AN=N C IF(N.LT.1.OR.N.GT.MAXNXT)THEN IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN KENDELLS TAU--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,112) 112 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS IN THE ', 1 'VARIABLES FOR') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,114) 114 FORMAT(' WHICH THE KENDELLS TAU COEFFICIENT IS TO BE ', 1 '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 ENDIF C IF(N.EQ.1)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,121) 121 FORMAT('***** WARNING IN KENDELLS TAU--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,123) 123 FORMAT(' THE NUMBER OF PAIRS (N) HAS THE VALUE 1.') CALL DPWRST('XXX','BUG ') XYKTAU=1.0 GOTO9000 ENDIF C C ************************************************* C ** STEP 2-- ** C ** COMPUTE THE RANK CORRELATION COEFFICIENT. ** C ************************************************* C CALL SORTC(X,Y,N,XTEMP,YTEMP) C ANC=0.0 AND=0.0 C NM1=N-1 DO200J=1,NM1 M=J+1 DO300I=M,N ANUM=Y(J) - Y(I) ADENOM=X(J) - X(I) IF(ADENOM.NE.0.0)THEN RATIO=ANUM/ADENOM IF(RATIO.GT.0.0)THEN ANC=ANC+1.0 ELSEIF(RATIO.LT.0.0)THEN AND=AND+1.0 ELSE ANC=ANC+0.5 AND=AND+0.5 ENDIF ENDIF 300 CONTINUE 200 CONTINUE XYKTAU=(ANC-AND)/(ANC+AND) 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,XYKTAU 811 FORMAT('THE KENDELLS TAU COEFFICIENT 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.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF KENTAU--') 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)ANC,AND 9014 FORMAT('ANC,AND = ',2G15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)XYKTAU 9015 FORMAT('XYKTAU = ',E15.7) CALL DPWRST('XXX','BUG ') ENDIF C RETURN END SUBROUTINE KLVNA(X,BER,BEI,GER,GEI,DER,DEI,HER,HEI) C C ====================================================== C Purpose: Compute Kelvin functions ber x, bei x, ker x C and kei x, and their derivatives ( x > 0 ) C Input : x --- Argument of Kelvin functions C Output: BER --- ber x C BEI --- bei x C GER --- ker x C GEI --- kei x C DER --- ber'x C DEI --- bei'x C HER --- ker'x C HEI --- kei'x C ================================================ C IMPLICIT DOUBLE PRECISION (A-H,O-Z) PI=3.141592653589793D0 EL=.5772156649015329D0 EPS=1.0D-15 IF (X.EQ.0.0D0) THEN BER=1.0D0 BEI=0.0D0 GER=1.0D+300 GEI=-0.25D0*PI DER=0.0D0 DEI=0.0D0 HER=-1.0D+300 HEI=0.0D0 RETURN ENDIF X2=0.25D0*X*X X4=X2*X2 IF (DABS(X).LT.10.0D0) THEN BER=1.0D0 R=1.0D0 DO 10 M=1,60 R=-0.25D0*R/(M*M)/(2.0D0*M-1.0D0)**2*X4 BER=BER+R IF (DABS(R).LT.DABS(BER)*EPS) GO TO 15 10 CONTINUE 15 BEI=X2 R=X2 DO 20 M=1,60 R=-0.25D0*R/(M*M)/(2.0D0*M+1.0D0)**2*X4 BEI=BEI+R IF (DABS(R).LT.DABS(BEI)*EPS) GO TO 25 20 CONTINUE 25 GER=-(DLOG(X/2.0D0)+EL)*BER+0.25D0*PI*BEI R=1.0D0 GS=0.0D0 DO 30 M=1,60 R=-0.25D0*R/(M*M)/(2.0D0*M-1.0D0)**2*X4 GS=GS+1.0D0/(2.0D0*M-1.0D0)+1.0D0/(2.0D0*M) GER=GER+R*GS IF (DABS(R*GS).LT.DABS(GER)*EPS) GO TO 35 30 CONTINUE 35 GEI=X2-(DLOG(X/2.0D0)+EL)*BEI-0.25D0*PI*BER R=X2 GS=1.0D0 DO 40 M=1,60 R=-0.25D0*R/(M*M)/(2.0D0*M+1.0D0)**2*X4 GS=GS+1.0D0/(2.0D0*M)+1.0D0/(2.0D0*M+1.0D0) GEI=GEI+R*GS IF (DABS(R*GS).LT.DABS(GEI)*EPS) GO TO 45 40 CONTINUE 45 DER=-0.25D0*X*X2 R=DER DO 50 M=1,60 R=-0.25D0*R/M/(M+1.0D0)/(2.0D0*M+1.0D0)**2*X4 DER=DER+R IF (DABS(R).LT.DABS(DER)*EPS) GO TO 55 50 CONTINUE 55 DEI=0.5D0*X R=DEI DO 60 M=1,60 R=-0.25D0*R/(M*M)/(2.D0*M-1.D0)/(2.D0*M+1.D0)*X4 DEI=DEI+R IF (DABS(R).LT.DABS(DEI)*EPS) GO TO 65 60 CONTINUE 65 R=-0.25D0*X*X2 GS=1.5D0 HER=1.5D0*R-BER/X-(DLOG(X/2.D0)+EL)*DER+0.25*PI*DEI DO 70 M=1,60 R=-0.25D0*R/M/(M+1.0D0)/(2.0D0*M+1.0D0)**2*X4 GS=GS+1.0D0/(2*M+1.0D0)+1.0D0/(2*M+2.0D0) HER=HER+R*GS IF (DABS(R*GS).LT.DABS(HER)*EPS) GO TO 75 70 CONTINUE 75 R=0.5D0*X GS=1.0D0 HEI=0.5D0*X-BEI/X-(DLOG(X/2.D0)+EL)*DEI-0.25*PI*DER DO 80 M=1,60 R=-0.25D0*R/(M*M)/(2*M-1.0D0)/(2*M+1.0D0)*X4 GS=GS+1.0D0/(2.0D0*M)+1.0D0/(2*M+1.0D0) HEI=HEI+R*GS IF (DABS(R*GS).LT.DABS(HEI)*EPS) RETURN 80 CONTINUE ELSE PP0=1.0D0 PN0=1.0D0 QP0=0.0D0 QN0=0.0D0 R0=1.0D0 KM=18 IF (DABS(X).GE.40.0) KM=10 FAC=1.0D0 DO 85 K=1,KM FAC=-FAC XT=0.25D0*K*PI-INT(0.125D0*K)*2.0D0*PI CS=COS(XT) SS=SIN(XT) R0=0.125D0*R0*(2.0D0*K-1.0D0)**2/K/X RC=R0*CS RS=R0*SS PP0=PP0+RC PN0=PN0+FAC*RC QP0=QP0+RS 85 QN0=QN0+FAC*RS XD=X/DSQRT(2.0D0) XE1=DEXP(XD) XE2=DEXP(-XD) XC1=1.D0/DSQRT(2.0D0*PI*X) XC2=DSQRT(.5D0*PI/X) CP0=DCOS(XD+0.125D0*PI) CN0=DCOS(XD-0.125D0*PI) SP0=DSIN(XD+0.125D0*PI) SN0=DSIN(XD-0.125D0*PI) GER=XC2*XE2*(PN0*CP0-QN0*SP0) GEI=XC2*XE2*(-PN0*SP0-QN0*CP0) BER=XC1*XE1*(PP0*CN0+QP0*SN0)-GEI/PI BEI=XC1*XE1*(PP0*SN0-QP0*CN0)+GER/PI PP1=1.0D0 PN1=1.0D0 QP1=0.0D0 QN1=0.0D0 R1=1.0D0 FAC=1.0D0 DO 90 K=1,KM FAC=-FAC XT=0.25D0*K*PI-INT(0.125D0*K)*2.0D0*PI CS=DCOS(XT) SS=DSIN(XT) R1=0.125D0*R1*(4.D0-(2.0D0*K-1.0D0)**2)/K/X RC=R1*CS RS=R1*SS PP1=PP1+FAC*RC PN1=PN1+RC QP1=QP1+FAC*RS QN1=QN1+RS 90 CONTINUE HER=XC2*XE2*(-PN1*CN0+QN1*SN0) HEI=XC2*XE2*(PN1*SN0+QN1*CN0) DER=XC1*XE1*(PP1*CP0+QP1*SP0)-HEI/PI DEI=XC1*XE1*(PP1*SP0-QP1*CP0)+HER/PI ENDIF RETURN END SUBROUTINE KROBOV( NDIM, MINVLS, MAXVLS, FUNCTN, ABSEPS, RELEPS, & ABSERR, FINEST, INFORM ) * * Automatic Multidimensional Integration Subroutine * * AUTHOR: Alan Genz * Department of Mathematics * Washington State University * Pulman, WA 99164-3113 * Email: AlanGenz@wsu.edu * * Last Change: 4/15/98 * * KROBOV computes an approximation to the integral * * 1 1 1 * I I ... I F(X) dx(NDIM)...dx(2)dx(1) * 0 0 0 * * * KROBOV uses randomized Korobov rules. The primary references are * "Randomization of Number Theoretic Methods for Multiple Integration" * R. Cranley and T.N.L. Patterson, SIAM J Numer Anal, 13, pp. 904-14, * and * "Optimal Parameters for Multidimensional Integration", * P. Keast, SIAM J Numer Anal, 10, pp.831-838. * *************** Parameters ******************************************** ****** Input parameters * NDIM Number of variables, must exceed 1, but not exceed 40 * MINVLS Integer minimum number of function evaluations allowed. * MINVLS must not exceed MAXVLS. If MINVLS < 0 then the * routine assumes a previous call has been made with * the same integrand and continues that calculation. * MAXVLS Integer maximum number of function evaluations allowed. * FUNCTN EXTERNALly declared user defined function to be integrated. * It must have parameters (NDIM,Z), where Z is a real array * of dimension NDIM. * ABSEPS Required absolute accuracy. * RELEPS Required relative accuracy. ****** Output parameters * MINVLS Actual number of function evaluations used. * ABSERR Estimated absolute accuracy of FINEST. * FINEST Estimated value of integral. * INFORM INFORM = 0 for normal exit, when * ABSERR <= MAX(ABSEPS, RELEPS*ABS(FINEST)) * and * INTVLS <= MAXCLS. * INFORM = 1 If MAXVLS was too small to obtain the required * accuracy. In this case a value FINEST is returned with * estimated absolute accuracy ABSERR. ************************************************************************ EXTERNAL FUNCTN INTEGER NDIM, MINVLS, MAXVLS, INFORM, NP, PLIM, NLIM, & SAMPLS, I, INTVLS, MINSMP PARAMETER ( PLIM = 20, NLIM = 100, MINSMP = 6 ) INTEGER C(PLIM,NLIM), P(PLIM) DOUBLE PRECISION FUNCTN, ABSEPS, RELEPS, FINEST, ABSERR, DIFINT, & FINVAL, VARSQR, VAREST, VARPRD, VALUE DOUBLE PRECISION ALPHA(NLIM), X(NLIM), VK(NLIM), ONE PARAMETER ( ONE = 1 ) SAVE P, C, SAMPLS, NP, VAREST C DATA P( 1), ( C( 1,I), I = 1, 99 ) / 113, & 42, 54, 55, 32, 13, 26, 26, 13, 26, & 14, 13, 26, 35, 2, 2, 2, 2, 56, & 28, 7, 7, 28, 4, 49, 4, 40, 48, & 5, 35, 27, 16, 16, 2, 2, 7, 28, & 4, 49, 4, 56, 8, 2, 2, 56, 7, & 16, 28, 7, 7, 28, 4, 49, 4, 37, & 55, 21, 33, 40, 16, 16, 28, 7, 16, & 28, 4, 49, 4, 56, 35, 2, 2, 2, & 16, 16, 28, 4, 16, 28, 4, 49, 4, & 40, 40, 5, 42, 27, 16, 16, 28, 4, & 16, 28, 4, 49, 4, 8, 8, 2, 2/ DATA P( 2), ( C( 2,I), I = 1, 99 ) / 173, & 64, 34, 57, 9, 72, 86, 16, 75, 75, & 70, 42, 2, 86, 62, 62, 30, 30, 5, & 42, 70, 70, 70, 53, 70, 70, 53, 42, & 62, 53, 53, 53, 69, 75, 5, 53, 86, & 2, 5, 30, 75, 59, 2, 69, 5, 5, & 63, 62, 5, 69, 30, 44, 30, 86, 86, & 2, 69, 5, 5, 2, 2, 61, 69, 17, & 2, 2, 2, 53, 69, 2, 2, 86, 69, & 13, 2, 2, 37, 43, 65, 2, 2, 30, & 86, 45, 16, 32, 18, 86, 86, 86, 9, & 63, 63, 11, 76, 76, 76, 63, 60, 70/ DATA P( 3), ( C( 3,I), I = 1, 99 ) / 263, & 111, 67, 98, 36, 48, 110, 2, 131, 2, & 2, 124, 124, 48, 2, 2, 124, 124, 70, & 70, 48, 126, 48, 126, 56, 65, 48, 48, & 70, 2, 92, 124, 92, 126, 131, 124, 70, & 70, 70, 20, 105, 70, 2, 2, 27, 108, & 27, 39, 2, 131, 131, 92, 92, 48, 2, & 126, 20, 126, 2, 2, 131, 38, 117, 2, & 131, 68, 58, 38, 90, 38, 108, 38, 2, & 131, 131, 131, 68, 14, 94, 131, 131, 131, & 108, 18, 131, 56, 85, 117, 117, 9, 131, & 131, 55, 92, 92, 92, 131, 131, 48, 48/ DATA P( 4), ( C( 4,I), I = 1, 99 ) / 397, & 151, 168, 46, 197, 69, 64, 2, 198, 191, & 134, 134, 167, 124, 16, 124, 124, 124, 124, & 141, 134, 128, 2, 2, 32, 32, 32, 31, & 31, 64, 64, 99, 4, 4, 167, 124, 124, & 124, 124, 124, 124, 107, 85, 79, 85, 111, & 85, 128, 31, 31, 31, 31, 64, 167, 4, & 107, 167, 124, 124, 124, 124, 124, 124, 107, & 183, 2, 2, 2, 62, 32, 31, 31, 31, & 31, 31, 167, 4, 107, 167, 124, 124, 124, & 124, 124, 124, 107, 142, 184, 184, 65, 65, & 183, 31, 31, 31, 31, 31, 167, 4, 107/ DATA P( 5), ( C( 5,I), I = 1, 99 ) / 593, & 229, 40, 268, 42, 153, 294, 71, 2, 130, & 199, 199, 199, 149, 199, 149, 153, 130, 149, & 149, 15, 119, 294, 31, 82, 260, 122, 209, & 209, 122, 296, 130, 130, 260, 260, 30, 206, & 94, 209, 94, 122, 209, 209, 122, 122, 209, & 130, 2, 130, 130, 38, 38, 79, 82, 94, & 82, 122, 122, 209, 209, 122, 122, 168, 220, & 62, 60, 168, 282, 282, 82, 209, 122, 94, & 209, 122, 122, 122, 122, 258, 148, 286, 256, & 256, 62, 62, 82, 122, 82, 82, 122, 122, & 122, 209, 122, 15, 79, 79, 79, 79, 168/ DATA P( 6), ( C( 6,I), I = 1, 99 ) / 907, & 264, 402, 406, 147, 452, 153, 224, 2, 2, & 224, 224, 449, 101, 182, 449, 101, 451, 181, & 181, 101, 101, 377, 85, 453, 453, 453, 85, & 197, 451, 2, 2, 101, 449, 449, 449, 173, & 173, 2, 453, 453, 2, 426, 66, 367, 426, & 101, 453, 2, 32, 32, 32, 101, 2, 2, & 453, 223, 147, 449, 290, 2, 453, 2, 83, & 223, 101, 453, 2, 83, 83, 147, 2, 453, & 147, 147, 147, 147, 147, 147, 147, 453, 153, & 153, 147, 2, 224, 290, 320, 453, 147, 431, & 383, 290, 290, 2, 162, 162, 147, 2, 162/ DATA P( 7), ( C( 7,I), I = 1, 99 ) / 1361, & 505, 220, 195, 410, 199, 248, 460, 471, 2, & 331, 662, 547, 209, 547, 547, 209, 2, 680, & 680, 629, 370, 574, 63, 63, 259, 268, 259, & 547, 209, 209, 209, 547, 547, 209, 209, 547, & 547, 108, 63, 63, 108, 63, 63, 108, 259, & 268, 268, 547, 209, 209, 209, 209, 547, 209, & 209, 209, 547, 108, 63, 63, 63, 405, 285, & 234, 259, 259, 259, 259, 209, 209, 209, 209, & 209, 209, 209, 209, 547, 289, 289, 234, 285, & 316, 2, 410, 259, 259, 259, 268, 209, 209, & 209, 209, 547, 547, 209, 209, 209, 285, 316/ DATA P( 8), ( C( 8,I), I = 1, 99 ) / 2053, & 468, 635, 849, 687, 948, 37, 1014, 513, 2, & 2, 2, 2, 2, 1026, 2, 2, 1026, 201, & 201, 2, 1026, 413, 1026, 1026, 2, 2, 703, & 703, 2, 2, 393, 393, 678, 413, 1026, 2, & 2, 1026, 1026, 2, 405, 953, 2, 1026, 123, & 123, 953, 953, 123, 405, 794, 123, 647, 613, & 1026, 647, 768, 953, 405, 953, 405, 918, 918, & 123, 953, 953, 918, 953, 536, 405, 70, 124, & 1005, 529, 207, 405, 405, 953, 953, 123, 918, & 918, 953, 405, 918, 953, 468, 405, 794, 794, & 647, 613, 548, 405, 953, 405, 953, 123, 918/ DATA P( 9), ( C( 9,I), I = 1, 99 ) / 3079, & 1189, 1423, 287, 186, 341, 77, 733, 733, 1116, & 2, 1539, 2, 2, 2, 2, 2, 1116, 847, & 1174, 2, 827, 713, 910, 944, 139, 1174, 1174, & 1539, 1397, 1397, 1174, 370, 33, 1210, 2, 370, & 1423, 370, 370, 1423, 1423, 1423, 434, 1423, 901, & 139, 1174, 427, 427, 200, 1247, 114, 114, 1441, & 139, 728, 1116, 1174, 139, 113, 113, 113, 1406, & 1247, 200, 200, 200, 200, 1247, 1247, 27, 427, & 427, 1122, 1122, 696, 696, 427, 1539, 435, 1122, & 758, 1247, 1247, 1247, 200, 200, 200, 1247, 114, & 27, 118, 118, 113, 118, 453, 453, 1084, 1406/ DATA P(10), ( C(10,I), I = 1, 99 ) / 4621, & 1764, 1349, 1859, 693, 78, 438, 531, 68, 2234, & 2310, 2310, 2310, 2, 2310, 2310, 2102, 2102, 178, & 314, 921, 1074, 1074, 1074, 2147, 314, 1869, 178, & 178, 1324, 1324, 510, 2309, 1541, 1541, 1541, 1541, & 342, 1324, 1324, 1324, 1324, 510, 570, 570, 2197, & 173, 1202, 998, 1324, 1324, 178, 1324, 1324, 1541, & 1541, 1541, 342, 1541, 886, 178, 1324, 1324, 1324, & 510, 784, 784, 501, 652, 1541, 1541, 1324, 178, & 1324, 178, 1324, 1541, 342, 1541, 2144, 784, 2132, & 1324, 1324, 1324, 1324, 510, 652, 1804, 1541, 1541, & 1541, 2132, 1324, 1324, 1324, 178, 510, 1541, 652/ DATA P(11), ( C(11,I), I = 1, 99 ) / 6947, & 2872, 1238, 387, 2135, 235, 1565, 221, 1515, 2950, & 486, 3473, 2, 2950, 982, 2950, 3122, 2950, 3172, & 2091, 2091, 9, 3449, 3122, 2846, 3122, 3122, 1947, & 2846, 3122, 772, 1387, 2895, 1387, 3, 3, 3, & 1320, 1320, 2963, 2963, 1320, 1320, 2380, 108, 1284, & 702, 1429, 907, 3220, 3125, 1320, 2963, 1320, 1320, & 2963, 1320, 1639, 3168, 1660, 2895, 2895, 2895, 2895, & 1639, 1297, 1639, 404, 3168, 2963, 2943, 2943, 550, & 1387, 1387, 2895, 2895, 2895, 1387, 2895, 1387, 2895, & 1320, 1320, 2963, 1320, 1320, 1320, 2963, 1320, 2, & 3473, 2, 3473, 772, 2550, 9, 1320, 2963, 1320/ DATA P(12), ( C(12,I), I = 1, 99 ) / 10427, & 4309, 2339, 4154, 4480, 4967, 630, 5212, 2592, 4715, & 1808, 1808, 5213, 2, 216, 4014, 3499, 3499, 4204, & 2701, 2701, 5213, 4157, 1209, 4157, 4460, 335, 4460, & 1533, 4575, 4013, 4460, 1881, 2701, 4030, 4030, 1881, & 4030, 1738, 249, 335, 57, 2561, 2561, 2561, 1533, & 1533, 1533, 4013, 4013, 4013, 4013, 4013, 1533, 856, & 856, 468, 468, 468, 2561, 468, 2022, 2022, 2434, & 138, 4605, 1100, 2561, 2561, 57, 57, 3249, 468, & 468, 468, 57, 468, 1738, 313, 856, 6, 3877, & 468, 557, 468, 57, 468, 4605, 2022, 2, 4605, & 138, 1100, 57, 2561, 57, 57, 2022, 5213, 3249/ DATA P(13), ( C(13,I), I = 1, 99 ) / 15641, & 6610, 1658, 3022, 2603, 5211, 265, 4985, 3, 4971, & 2127, 1877, 1877, 2, 2925, 3175, 3878, 1940, 1940, & 1940, 5117, 5117, 5771, 5117, 5117, 5117, 5117, 5117, & 5771, 5771, 5117, 3658, 3658, 3658, 3658, 3658, 3658, & 5255, 2925, 2619, 1714, 4100, 6718, 6718, 4100, 2322, & 842, 4100, 6718, 5119, 4728, 5255, 5771, 5771, 5771, & 5117, 5771, 5117, 5117, 5117, 5117, 5117, 5117, 5771, & 5771, 1868, 4483, 4728, 3658, 5255, 3658, 5255, 3658, & 3658, 5255, 5255, 3658, 6718, 6718, 842, 2322, 6718, & 4100, 6718, 4100, 4100, 5117, 5771, 5771, 5117, 5771, & 5771, 5771, 5771, 5117, 5117, 5117, 5771, 5771, 1868/ DATA P(14), ( C(14,I), I = 1, 99 ) / 23473, & 9861, 7101, 6257, 7878, 11170, 11638, 7542, 2592, 2591, & 6074, 1428, 8925, 11736, 8925, 5623, 5623, 1535, 6759, & 9953, 9953, 11459, 9953, 7615, 7615, 11377, 11377, 2762, & 11734, 11459, 6892, 1535, 6759, 4695, 1535, 6892, 2, & 2, 6892, 6892, 4177, 4177, 6339, 6950, 1226, 1226, & 1226, 4177, 6892, 6890, 3640, 3640, 1226, 10590, 10590, & 6950, 6950, 6950, 1226, 6950, 6950, 7586, 7586, 7565, & 7565, 3640, 3640, 6950, 7565, 6950, 3599, 3599, 3599, & 2441, 4885, 4885, 4885, 7565, 7565, 1226, 1226, 1226, & 6950, 7586, 1346, 2441, 6339, 3640, 6950, 10590, 6339, & 6950, 6950, 6950, 1226, 1226, 6950, 836, 6891, 7565/ DATA P(15), ( C(15,I), I = 1, 99 ) / 35221, & 13482, 5629, 6068, 11974, 4732, 14946, 12097, 17609, 11740, & 15170, 10478, 10478, 17610, 2, 2, 7064, 7064, 7064, & 5665, 1771, 2947, 4453, 12323, 17610, 14809, 14809, 5665, & 5665, 2947, 2947, 2947, 2947, 12323, 12323, 4453, 4453, & 2026, 11772, 2026, 11665, 12323, 12323, 3582, 2940, 2940, & 6654, 4449, 9254, 11470, 304, 304, 11470, 304, 11470, & 6156, 9254, 11772, 6654, 11772, 6156, 11470, 11470, 11772, & 11772, 11772, 11470, 11470, 304, 11470, 11470, 304, 11470, & 304, 11470, 304, 304, 304, 6654, 11508, 304, 304, & 6156, 3582, 11470, 11470, 11470, 17274, 6654, 6654, 6744, & 6711, 6654, 6156, 3370, 6654, 12134, 3370, 6654, 3582/ DATA P(16), ( C(16,I), I = 1, 99 ) / 52837, & 13482, 5629, 6068, 11974, 4732, 14946, 12097, 17609, 11740, & 15170, 10478, 10478, 17610, 2, 2, 7064, 7064, 7064, & 5665, 1771, 2947, 4453, 12323, 17610, 14809, 14809, 5665, & 5665, 2947, 2947, 2947, 2947, 12323, 12323, 4453, 4453, & 2026, 11772, 2026, 11665, 12323, 12323, 3582, 2940, 2940, & 6654, 4449, 9254, 11470, 304, 304, 11470, 304, 11470, & 6156, 9254, 11772, 6654, 11772, 6156, 11470, 11470, 11772, & 11772, 11772, 11470, 11470, 304, 11470, 11470, 304, 11470, & 304, 11470, 304, 304, 304, 6654, 11508, 304, 304, & 6156, 3582, 11470, 11470, 11470, 17274, 6654, 6654, 6744, & 6711, 6654, 6156, 3370, 6654, 12134, 3370, 6654, 3582/ DATA P(17), ( C(17,I), I = 1, 99 ) / 79259, & 34566, 38838, 23965, 17279, 35325, 33471, 330, 36050, 26419, & 3012, 38428, 36430, 36430, 36755, 39629, 5749, 5749, 36755, & 5749, 14353, 14353, 14353, 32395, 32395, 32395, 32395, 32396, & 32396, 32396, 32396, 27739, 14353, 36430, 36430, 36430, 15727, & 38428, 28987, 28987, 27739, 38428, 27739, 18786, 14353, 15727, & 28987, 19151, 19757, 19757, 19757, 14353, 22876, 19151, 24737, & 24737, 4412, 30567, 30537, 19757, 30537, 19757, 30537, 30537, & 4412, 24737, 28987, 19757, 19757, 19757, 30537, 30537, 33186, & 4010, 4010, 4010, 17307, 15217, 32789, 37709, 4010, 4010, & 4010, 33186, 33186, 4010, 11057, 39388, 33186, 1122, 15089, & 39629, 2, 2, 23899, 16466, 16466, 17038, 9477, 9260/ DATA P(18), ( C(18,I), I = 1, 99 ) / 118891, & 31929, 40295, 2610, 5177, 17271, 23770, 9140, 952, 39631, & 3, 11424, 49719, 38267, 25172, 2, 2, 59445, 2, & 59445, 38267, 44358, 14673, 53892, 14674, 14673, 14674, 41368, & 17875, 17875, 30190, 20444, 55869, 15644, 25499, 15644, 20983, & 44358, 15644, 15644, 485, 41428, 485, 485, 485, 41428, & 53798, 50230, 53798, 50253, 50253, 35677, 35677, 17474, 7592, & 4098, 17474, 485, 41428, 485, 41428, 485, 41428, 485, & 41428, 41428, 41428, 41428, 41428, 9020, 22816, 4098, 4098, & 4098, 7592, 42517, 485, 50006, 50006, 22816, 22816, 9020, & 485, 41428, 41428, 41428, 41428, 50006, 485, 41428, 41428, & 41428, 41428, 22816, 41428, 41428, 485, 485, 485, 9020/ DATA P(19), ( C(19,I), I = 1, 99 ) / 178349, & 73726, 16352, 16297, 74268, 60788, 8555, 1077, 25486, 86595, & 59450, 19958, 62205, 62205, 4825, 4825, 89174, 89174, 62205, & 19958, 62205, 19958, 27626, 63080, 62205, 62205, 62205, 19958, & 8914, 83856, 30760, 47774, 47774, 19958, 62205, 39865, 39865, & 74988, 75715, 75715, 74988, 34522, 74988, 74988, 25101, 44621, & 44621, 44621, 25101, 25101, 25101, 44621, 47768, 41547, 44621, & 10273, 74988, 74988, 74988, 74988, 74988, 74988, 34522, 34522, & 67796, 67796, 30208, 2, 67062, 18500, 29251, 29251, 2, & 67796, 67062, 38649, 59302, 6225, 67062, 6475, 6225, 46772, & 38649, 67062, 46772, 46772, 67062, 46772, 25372, 67062, 6475, & 25372, 67062, 67062, 67062, 6225, 67062, 67062, 68247, 80676/ DATA P(20), ( C(20,I), I = 1, 99 )/ 267523, & 103650, 50089, 70223, 41805, 74847,112775, 40889, 64866, 44053, & 1754,129471, 13630, 53467, 53467, 61378,133761, 2,133761, & 2,133761,133761, 65531, 65531, 65531, 38080,133761,133761, & 131061, 5431, 65531, 78250, 11397, 38841, 38841,107233,107233, & 111286, 19065, 38841, 19065, 19065, 16099,127638, 82411, 96659, & 96659, 82411, 96659, 82411, 51986,101677, 39264, 39264,101677, & 39264, 39264, 47996, 96659, 82411, 47996, 10971, 10004, 82411, & 96659, 82411, 82411, 82411, 96659, 96659, 96659, 82411, 96659, & 51986,110913, 51986, 51986,110913, 82411, 54713, 54713, 22360, & 117652, 22360, 78250, 78250, 91996, 22360, 91996, 97781, 91996, & 97781, 91996, 97781, 97781, 91996, 97781, 97781, 36249, 39779/ C INFORM = 1 INTVLS = 0 IF ( MINVLS .GE. 0 ) THEN FINEST = 0 VAREST = 0 SAMPLS = MINSMP DO 100 I = 1, PLIM NP = I IF ( MINVLS .LT. 2*SAMPLS*P(I) ) GO TO 10 100 CONTINUE SAMPLS = MAX( MINSMP, MINVLS/( 2*P(NP) ) ) ENDIF 10 VK(1) = ONE/P(NP) DO 200 I = 2, NDIM VK(I) = MOD( C(NP,NDIM-1)*VK(I-1), ONE ) 200 CONTINUE FINVAL = 0 VARSQR = 0 DO 300 I = 1, SAMPLS CALL KROSUM( NDIM, VALUE, P(NP), VK, FUNCTN, ALPHA, X ) DIFINT = ( VALUE - FINVAL )/I FINVAL = FINVAL + DIFINT VARSQR = ( I - 2 )*VARSQR/I + DIFINT**2 300 CONTINUE INTVLS = INTVLS + 2*SAMPLS*P(NP) VARPRD = VAREST*VARSQR FINEST = FINEST + ( FINVAL - FINEST )/( 1 + VARPRD ) IF ( VARSQR .GT. 0 ) VAREST = ( 1 + VARPRD )/VARSQR ABSERR = 3*SQRT( VARSQR/( 1 + VARPRD ) ) IF ( ABSERR .GT. MAX( ABSEPS, ABS(FINEST)*RELEPS ) ) THEN IF ( NP .LT. PLIM ) THEN NP = NP + 1 ELSE SAMPLS = MIN( 3*SAMPLS/2, ( MAXVLS - INTVLS )/( 2*P(NP) ) ) SAMPLS = MAX( MINSMP, SAMPLS ) ENDIF IF ( INTVLS + 2*SAMPLS*P(NP) .LE. MAXVLS ) GO TO 10 ELSE INFORM = 0 ENDIF MINVLS = INTVLS C RETURN END SUBROUTINE KROMVN( N, LOWER, UPPER, INFIN, CORREL, MAXPTS, & ABSEPS, RELEPS, ERROR, VALUE, INFORM ) * * A subroutine for computing multivariate normal probabilities. * This subroutine uses an algorithm given in the paper * "Numerical Computation of Multivariate Normal Probabilities", in * J. of Computational and Graphical Stat., 1(1992), pp. 141-149, by * Alan Genz * Department of Mathematics * Washington State University * Pullman, WA 99164-3113 * Email : AlanGenz@wsu.edu * * Parameters * * N INTEGER, the number of variables. * LOWER REAL, array of lower integration limits. * UPPER REAL, array of upper integration limits. * INFIN INTEGER, array of integration limits flags: * if INFIN(I) < 0, Ith limits are (-infinity, infinity); * if INFIN(I) = 0, Ith limits are (-infinity, UPPER(I)]; * if INFIN(I) = 1, Ith limits are [LOWER(I), infinity); * if INFIN(I) = 2, Ith limits are [LOWER(I), UPPER(I)]. * CORREL REAL, array of correlation coefficients; the correlation * coefficient in row I column J of the correlation matrix * should be stored in CORREL( J + ((I-2)*(I-1))/2 ), for J < I. * MAXPTS INTEGER, maximum number of function values allowed. This * parameter can be used to limit the time. A sensible * strategy is to start with MAXPTS = 1000*N, and then * increase MAXPTS if ERROR is too large. * ABSEPS REAL absolute error tolerance. * RELEPS REAL relative error tolerance. * ERROR REAL estimated absolute error, with 99% confidence level. * VALUE REAL estimated value for the integral * INFORM INTEGER, termination status parameter: * if INFORM = 0, normal completion with ERROR < EPS; * if INFORM = 1, completion with ERROR > EPS and MAXPTS * function vaules used; increase MAXPTS to * decrease ERROR; * if INFORM = 2, N > 100 or N < 1. * EXTERNAL MVNFNC INTEGER N, INFIN(*), MAXPTS, INFORM, INFIS, IVLS DOUBLE PRECISION CORREL(*), LOWER(*), UPPER(*), RELEPS, ABSEPS, & ERROR, VALUE, E, D, MVNNIT, MVNFNC IF ( N .GT. 100 .OR. N .LT. 1 ) THEN INFORM = 2 VALUE = 0 ERROR = 1 ELSE INFORM = MVNNIT(N, CORREL, LOWER, UPPER, INFIN, INFIS, D, E) IF ( N-INFIS .EQ. 0 ) THEN VALUE = 1 ERROR = 0 ELSE IF ( N-INFIS .EQ. 1 ) THEN VALUE = E - D ERROR = 2E-16 ELSE * * Call the lattice rule integration subroutine * IVLS = 0 CALL KROBOV( N-INFIS-1, IVLS, MAXPTS, MVNFNC, & ABSEPS, RELEPS, ERROR, VALUE, INFORM ) ENDIF ENDIF END SUBROUTINE KROMVT(N, NU, LOWER, UPPER, INFIN, CORREL, MAXPTS, * ABSEPS, RELEPS, ERROR, VALUE, INFORM) * * A subroutine for computing multivariate t probabilities. * Alan Genz * Department of Mathematics * Washington State University * Pullman, WA 99164-3113 * Email : AlanGenz@wsu.edu * * Parameters * * N INTEGER, the number of variables. * NU INTEGER, the number of degrees of freedom. * LOWER REAL, array of lower integration limits. * UPPER REAL, array of upper integration limits. * INFIN INTEGER, array of integration limits flags: * if INFIN(I) < 0, Ith limits are (-infinity, infinity); * if INFIN(I) = 0, Ith limits are (-infinity, UPPER(I)]; * if INFIN(I) = 1, Ith limits are [LOWER(I), infinity); * if INFIN(I) = 2, Ith limits are [LOWER(I), UPPER(I)]. * CORREL REAL, array of correlation coefficients; the correlation * coefficient in row I column J of the correlation matrix * should be stored in CORREL( J + ((I-2)*(I-1))/2 ), for J < I. * MAXPTS INTEGER, maximum number of function values allowed. This * parameter can be used to limit the time. A sensible * strategy is to start with MAXPTS = 1000*N, and then * increase MAXPTS if ERROR is too large. * ABSEPS REAL absolute error tolerance. * RELEPS REAL relative error tolerance. * ERROR REAL estimated absolute error, with 99% confidence level. * VALUE REAL estimated value for the integral * INFORM INTEGER, termination status parameter: * if INFORM = 0, normal completion with ERROR < EPS; * if INFORM = 1, completion with ERROR > EPS and MAXPTS * function vaules used; increase MAXPTS to * decrease ERROR; * if INFORM = 2, N > 20 or N < 1. * EXTERNAL FNCMVT INTEGER N, NU, INFIN(*), MAXPTS, INFORM, INFIS, IVLS DOUBLE PRECISION * CORREL(*), LOWER(*), UPPER(*), RELEPS, ABSEPS, * ERROR, VALUE, E, D, MVTNIT IF ( N .GT. 20 .OR. N .LT. 1 ) THEN INFORM = 2 VALUE = 0 ERROR = 1 RETURN ENDIF INFORM = MVTNIT( N, NU, CORREL, LOWER, UPPER, INFIN, INFIS, D, E ) IF ( N-INFIS .EQ. 0 ) THEN VALUE = 1 ERROR = 0 ELSE IF ( N-INFIS .EQ. 1 ) THEN VALUE = E - D ERROR = 2E-16 ELSE * * Call the lattice rule integration integration subroutine * IVLS = 0 CALL KROBOV( N-INFIS-1, IVLS, MAXPTS, FNCMVT, ABSEPS, RELEPS, * ERROR, VALUE, INFORM ) ENDIF RETURN END SUBROUTINE KROSUM( NDIM, SUMKRO, PRIME, VK, FUNCTN, ALPHA, X ) EXTERNAL FUNCTN INTEGER NDIM, PRIME, K, J DOUBLE PRECISION SUMKRO, VK(*), FUNCTN, ALPHA(*), X(*), ONE, UNI PARAMETER ( ONE = 1 ) SUMKRO = 0 DO 100 J = 1, NDIM ALPHA(J) = UNI() 100 CONTINUE DO 200 K = 1, PRIME DO 300 J = 1, NDIM X(J) = MOD( K*VK(J) + ALPHA(J), ONE ) X(J) = ABS( 2*X(J) - 1 ) 300 CONTINUE SUMKRO = SUMKRO + ( FUNCTN(NDIM,X) - SUMKRO )/( 2*K - 1 ) DO 400 J = 1, NDIM X(J) = 1 - X(J) 400 CONTINUE SUMKRO = SUMKRO + ( FUNCTN(NDIM,X) - SUMKRO )/( 2*K ) 200 CONTINUE C RETURN END SUBROUTINE L1DIS(AMAT,AMAT2,MAXROM,MAXCOM,NR1,NC1,ICASE,IWRITE, 1IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C L1 NORM DISTANCE OF A MATRIX. THE FORMULA IS: C Dij=SUM|(Xik - Xjk)| C THE SUMMATION IS 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 L1 NORM DISTANCES. C OUTPUT--MATRIX OF L1 NORM 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 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--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='L1NO' 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 L1DIS--') 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 L1 NORM DISTANCE * C ******************************** C IF(ICASE.EQ.'ROW ')THEN DO5861I=1,NR1 DO5863J=1,I IF(I.EQ.J)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) 5865 CONTINUE AMAT2(I,J)=REAL(DSUM) 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) 5965 CONTINUE AMAT2(I,J)=REAL(DSUM) 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 L1 NORM 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 L1DIS--') 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 LABEL(NO, ICHAR, LIST, IOUT, N, LV, LOA) C ROUTINE FROM ACM 591 FOR ANOVA C ****************************** LABEL ***************************** LAB 10 C LAB 20 C DETERMINES THE SUBSCRIPTS OF THE PRIMARY ARRAY; CALCULATES COEFFI- LAB 30 C CIENTS FOR MAPPING THE SECONDARY ARRAY INTO THE PRIMARY ARRAY. LAB 40 C ALSO PREPARES LABELS FOR THE G-INVERSE SOLUTION AND CLASSIFICATION LAB 50 C MEANS; EACH LABEL IS AN ALPHANUMERIC ARRAY OF SIZE 10. LAB 60 C LAB 70 C LAB 80 C (OUT) ARGUMENTS (IN) LAB 90 C LAB 100 C LOA NO ICHAR LIST LAB 110 C LAB 120 C PRIMARY SUBSCRIPTS M-I+1 0 LLIM LAB 130 C MAP COEFFICIENTS M-I+1 0 LLIM LAB 140 C MODEL TERM LABEL LER(I) BLANK LE LAB 150 C SUBSCRIPTS LABEL M-I+1 . LS LAB 160 C LAB 170 C IN COMPUTING NO, I IS THE POSITION OF THE LAB 180 C ARRAY WITHIN THE M ARRAYS (IN VECTOR A OF LAB 190 C W) OR, FOR MODEL TERM LABELS, THE VALUE LAB 200 C OF THE E/R LIST (ARRAY LER) FOR THAT TERM LAB 210 C LAB 220 C (SEE MAIN PROGRAM COMMENTS FOR DESCRIPTION OF OTHER ARGUMENTS) LAB 230 C LAB 240 C ****************************************************************** LAB 250 DIMENSION LIST(N), LV(N), LOA(10) CHARACTER*1 IBLANK C CHARACTER*4 IFEEDB CHARACTER*4 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 / C C MAP COEFFICIENTS: (NO=2**N-I+1,ICHAR=0,LIST=LLIM) C LABELS: MODEL TERM (NO=LER(I),ICHAR= ,LIST=LE) C SUBSCRIPTS (NO=2**N-I+1,ICHAR=.,LIST=LS) C NUM = NO - 1 DO 10 I=N,10 CNIST LOA(I) = IBLANK LOA(I) = -1 10 CONTINUE DO 20 I=1,N LOA(I) = ICHAR 20 CONTINUE IF (NUM.EQ.0) GO TO 60 I = 0 J = 0 30 I = I + 1 40 J = J + 1 NUM = NUM - LV(J) IF (NUM.GE.0) GO TO 50 NUM = NUM + LV(J) CNIST IF (ICHAR.NE.IBLANK) GO TO 30 IF (ICHAR.NE.-1) GO TO 30 GO TO 40 50 LOA(I) = LIST(J) IF (NUM.NE.0) GO TO 30 60 IF (ICHAR.EQ.0) GO TO 70 CNIST WRITE (ICOUT,99999) (LOA(K),K=1,10) 99999 FORMAT (1H , 10A1) CALL DPWRST('XXX','BUG ') RETURN 70 DO 90 I=1,N IF (LOA(I).EQ.0) GO TO 90 LOA(I) = 1 DO 80 J=I,N IF (LOA(J).EQ.0) GO TO 80 LOA(I) = IABS(LOA(I)*LOA(J)) 80 CONTINUE 90 CONTINUE RETURN END SUBROUTINE LAGUE(X,AN,ALN) C C PURPOSE--THIS SUBROUTINE COMPUTES THE LAGUERRE POLYNOMIAL OF C 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 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) = (((2.*N+1)-x)*L(n)-N*L(N-1))/(N+1) C FIRST FEW TERMS ARE FROM TABLE 22.10 OF ABRAMOWITZ C AND STEGUM. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-975-2855 C ORIGINAL VERSION--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 LAGUERRE 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 LAGUERRE 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=0.5*(X**2 - 4.0*X + 2.0) ELSEIF(N.EQ.3)THEN DLN=(-DX**3 + 9.0D0*DX**2 -18.0D0*DX + 6.0D0)/6.0D0 ALN=REAL(DLN) ELSE DLN1=(-DX**3 + 9.0D0*DX**2 -18.0D0*DX + 6.0D0)/6.0D0 DLN2=0.5D0*(DX**2 - 4.0D0*DX + 2.0D0) DO1000I=4,N DN2=DBLE(I)-1.0D0 DLN=(((2.0D0*DN2+1.0D0)-DX)*DLN1-DN2*DLN2)/(DN2+1.0D0) DLN2=DLN1 DLN1=DLN 1000 CONTINUE ALN=REAL(DLN) ENDIF C 9999 CONTINUE RETURN END SUBROUTINE LAGUEL(X,AN,ALPHA,IFLAG,ALN) C C PURPOSE--THIS SUBROUTINE COMPUTES THE GENERALIZED 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 ALPHA = THE SINGLE PRECISION VALUE FOR THE C PARAMETER OF THE FUNCTION (SHOULD BE C IFLAG = "NORM" FOR NORMALIZED, "UNNO" FOR C UNNORMALIZED C OUTPUT ARGUMENTS--ALN = THE SINGLE PRECISION VALUE OF THE C 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) = (((2.*N+1)-x)*L(n)-N*L(N-1))/(N+1) C FIRST FEW TERMS ARE FROM TABLE 22.10 OF ABRAMOWITZ C AND STEGUM. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-975-2855 C ORIGINAL VERSION--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 CHARACTER*4 IFLAG DOUBLE PRECISION DX DOUBLE PRECISION DALPHA DOUBLE PRECISION DN, DN2 DOUBLE PRECISION DLN, DLN1, DLN2 DOUBLE PRECISION AJ, BJ, CJ DOUBLE PRECISION DFACT DOUBLE PRECISION DGAMR 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 LAGUERRE 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 LAGUERRE SUBROUTINE IS NEGATIVE *****') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') C DX=DBLE(X) DALPHA=DBLE(ALPHA) DN=DBLE(N) C IF(IFLAG.EQ.'NORM')GOTO2000 IF(N.LE.0)THEN DLN=1.0D0 ELSEIF(N.EQ.1)THEN DLN=-DX+DALPHA+1.0D0 ELSEIF(N.EQ.2)THEN DLN=0.5D0* 1 (2.D0+3.D0*DALPHA+DALPHA*DALPHA-4.D0*DX-2.D0*DALPHA*DX+DX*DX) ELSE DLN1=0.5D0* 1 (2.D0+3.D0*DALPHA+DALPHA*DALPHA-4.D0*DX-2.D0*DALPHA*DX+DX*DX) DLN2=-DX+DALPHA+1.0D0 DO1000I=3,N DN2=DBLE(I)-1.0D0 DLN=(((2.0D0*DN2+DALPHA+1.0D0)-DX)*DLN1-(DN2+DALPHA)*DLN2)/ 1 (DN2+1.0D0) CCCCC DN2=DBLE(I) CCCCC AJ=(2.D0*DN2-1.0D0+DALPHA)/DN2 CCCCC BJ=-1.D0/DN2 CCCCC CJ=(DN2-1.0D0+DALPHA)/DN2 CCCCC DLN=(AJ+BJ*DX)*DLN1 - CJ*DLN2 DLN2=DLN1 DLN1=DLN 1000 CONTINUE ENDIF ALN=REAL(DLN) GOTO9999 C 2000 CONTINUE IF(N.LE.0)THEN DLN=1.0D0 ELSEIF(N.EQ.1)THEN DLN=-DX+DALPHA+1.0D0 DFACT=(-1.0D0)**1/DGAMR(2.0D0) DLN=DLN/DFACT ELSEIF(N.EQ.2)THEN DLN=2.D0+3.D0*DALPHA+DALPHA*DALPHA-4.D0*DX-2.D0*DALPHA*DX+DX*DX DFACT=(-1.0D0)**2/DGAMR(3.0D0) DLN=DLN/DFACT ELSE DLN1=0.5D0* 1 (2.D0+3.D0*DALPHA+DALPHA*DALPHA-4.D0*DX-2.D0*DALPHA*DX+DX*DX) DLN2=-DX+DALPHA+1.0D0 DO2100I=3,N DN2=DBLE(I) AJ=(2.D0*DN2-1.0D0+DALPHA)/DN2 BJ=-1.D0/DN2 CJ=(DN2-1.0D0+DALPHA)/DN2 DLN=(AJ+BJ*DX)*DLN1 - CJ*DLN2 DLN2=DLN1 DLN1=DLN 2100 CONTINUE ENDIF DFACT=(-1.0D0)**N/DGAMR(DN+1.0D0) DLN=DLN/DFACT ALN=REAL(DLN) GOTO9999 C 9999 CONTINUE RETURN END SUBROUTINE LAGUER(A,M,X,EPS,POLISH) C C SOURCE--NUMERICAL RECIPES, C PRESS, FLANNERY, TEUKOLSKY, AND VETTERLING, C CAMBRIDGE UNIVERSITY PRESS, 1986. C COMPLEX A(*),X,DX,X1,B,D,F,G,H,SQ,GP,GM,G2,ZERO,XX,WW LOGICAL POLISH PARAMETER (ZERO=(0.,0.),TINY=1.E-15,MAXIT=100) C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IF (POLISH) THEN DXOLD=CABS(X) NPOL=0 ENDIF C DO 12 ITER=1,MAXIT B=A(M+1) D=ZERO F=ZERO DO 11 J=M,1,-1 F=X*F+D D=X*D+B B=X*B+A(J) 11 CONTINUE IF(CABS(B).LE.TINY) THEN DX=ZERO ELSE IF(CABS(D).LE.TINY.AND.CABS(F).LE.TINY)THEN DX=CMPLX(CABS(B/A(M+1))**(1./M),0.) ELSE G=D/B G2=G*G H=G2-2.*F/B XX=(M-1)*(M*H-G2) YY=ABS(REAL(XX)) ZZ=ABS(AIMAG(XX)) IF(YY.LT.TINY.AND.ZZ.LT.TINY) THEN SQ=ZERO ELSE IF (YY.GE.ZZ) THEN WW=(1.0/YY)*XX SQ=SQRT(YY)*CSQRT(WW) ELSE WW=(1.0/ZZ)*XX SQ=SQRT(ZZ)*CSQRT(WW) ENDIF GP=G+SQ GM=G-SQ IF(CABS(GP).LT.CABS(GM)) GP=GM DX=M/GP ENDIF X1=X-DX IF(X.EQ.X1)RETURN X=X1 IF (POLISH) THEN NPOL=NPOL+1 CDX=CABS(DX) IF(NPOL.GT.9.AND.CDX.GE.DXOLD)RETURN DXOLD=CDX ELSE IF(CABS(DX).LE.EPS*CABS(X))RETURN ENDIF 12 CONTINUE C WRITE(ICOUT,555) 555 FORMAT('ERROR IN LAGUER--TOO MANY ITERATIONS') CALL DPWRST('XXX','BUG ') C RETURN END SUBROUTINE LAMCDF(X,ALAMBA,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE (TUKEY) LAMBDA DISTRIBUTION C WITH TAIL LENGTH PARAMETER VALUE = ALAMBA. C IN GENERAL, THE PROBABILITY DENSITY FUNCTION C FOR THIS DISTRIBUTION IS NOT SIMPLE. C THE PERCENT POINT FUNCTION FOR THIS DISTRIBUTION IS C G(P) = ((P**ALAMBA)-((1-P)**ALAMBA))/ALAMBA C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C --ALAMBA = THE SINGLE PRECISION VALUE OF LAMBDA C (THE TAIL LENGTH 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 TUKEY LAMBDA DISTRIBUTION C WITH TAIL LENGTH PARAMETER = ALAMBA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--FOR ALAMBA NON-POSITIVE, NO RESTRICTIONS ON X. C --FOR ALAMBA POSITIVE, X SHOULD BE BETWEEN (-1/ALAMBA) C AND (+1/ALAMBA), INCLUSIVELY. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN. C REFERENCES--HASTINGS, MOSTELLER, TUKEY, AND WINDSOR, C 'LOW MOMENTS FOR SMALL SAMPLES: A COMPARATIVE C STUDY OF ORDER STATISTICS', ANNALS OF C MATHEMATICAL STATISTICS, 18, 1947, C PAGES 413-426. 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 42-44, 53-58. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-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 C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(ALAMBA.LE.0.0)GOTO90 XMAX=1.0/ALAMBA XMIN=-XMAX IF(X.LT.XMIN.OR.X.GT.XMAX)GOTO50 GOTO90 50 CONTINUE WRITE(ICOUT,2) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3) CALL DPWRST('XXX','BUG ') IF(X.LT.XMIN)CDF=0.0 IF(X.GT.XMAX)CDF=1.0 RETURN 90 CONTINUE 2 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENNT') 3 FORMAT(' TO THE LAMCDF SUBROUTINE IS OUTSIDE THE USUAL') 4 FORMAT(' +-(1/ALAMBA) INTERVAL *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C C-----START POINT----------------------------------------------------- C IF(ALAMBA.GT.0.0)GOTO110 GOTO120 C 110 XMAX=1.0/ALAMBA XMIN=-XMAX IF(X.LE.XMIN)CDF=0.0 IF(X.GE.XMAX)CDF=1.0 IF(X.LE.XMIN.OR.X.GE.XMAX)RETURN C 120 CONTINUE IF(-0.001.LT.ALAMBA.AND.ALAMBA.LT.0.001)GOTO150 GOTO170 150 IF(X.GE.0.0)GOTO160 CDF=EXP(X)/(1.0+EXP(X)) RETURN 160 CDF=1.0/(1.0+EXP(-X)) RETURN C 170 IF(-0.001.LT.ALAMBA.AND.ALAMBA.LT.0.001)GOTO150 PMIN=0.0 PMID=0.5 PMAX=1.0 PLOWER=PMIN PUPPER=PMAX ICOUNT=0 210 XCALC=(PMID**ALAMBA-(1.0-PMID)**ALAMBA)/ALAMBA IF(XCALC.EQ.X)GOTO240 IF(XCALC.GT.X)GOTO220 PLOWER=PMID PMID=(PMID+PUPPER)/2.0 GOTO230 220 PUPPER=PMID PMID=(PMID+PLOWER)/2.0 230 PDEL=ABS(PMID-PLOWER) ICOUNT=ICOUNT+1 IF(PDEL.LT.0.000001.OR.ICOUNT.GT.30)GOTO240 GOTO210 240 CDF=PMID RETURN C END SUBROUTINE LAMN(N,X,NM,BL1,DL1,IERROR) C C ========================================================= C Purpose: Compute lambda functions and their derivatives C Input: x --- Argument of lambda function C n --- Order of lambda function C Output: BL(n) --- Lambda function of order n C DL(n) --- Derivative of lambda function C NM --- Highest order computed C Routines called: C MSTA1 and MSTA2 for computing the start C point for backward recurrence C ========================================================= C PARAMETER(MAXORD=500) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION BL(0:MAXORD),DL(0:MAXORD) CHARACTER*4 IERROR C IF(N.GT.MAXORD)THEN IERROR='YES' RETURN ENDIF C NM=N IF (DABS(X).LT.1.0D-100) THEN DO 10 K=0,N BL(K)=0.0D0 10 DL(K)=0.0D0 BL(0)=1.0D0 DL(1)=0.5D0 GOTO9999 ENDIF IF (X.LE.12.0D0) THEN X2=X*X DO 25 K=0,N BK=1.0D0 R=1.0D0 DO 15 I=1,50 R=-0.25D0*R*X2/(I*(I+K)) BK=BK+R IF (DABS(R).LT.DABS(BK)*1.0D-15) GO TO 20 15 CONTINUE 20 BL(K)=BK 25 IF (K.GE.1) DL(K-1)=-0.5D0*X/K*BK UK=1.0D0 R=1.0D0 DO 30 I=1,50 R=-0.25D0*R*X2/(I*(I+N+1.0D0)) UK=UK+R IF (DABS(R).LT.DABS(UK)*1.0D-15) GO TO 35 30 CONTINUE 35 DL(N)=-0.5D0*X/(N+1.0D0)*UK GOTO9999 ENDIF IF (N.EQ.0) NM=1 M=MSTA1(X,200) IF (M.LT.NM) THEN NM=M ELSE M=MSTA2(X,NM,15) ENDIF BS=0.0D0 F0=0.0D0 F1=1.0D-100 DO 40 K=M,0,-1 F=2.0D0*(K+1.0D0)*F1/X-F0 IF (K.LE.NM) BL(K)=F IF (K.EQ.2*INT(K/2)) BS=BS+2.0D0*F F0=F1 40 F1=F BG=BS-F DO 45 K=0,NM 45 BL(K)=BL(K)/BG R0=1.0D0 DO 50 K=1,NM R0=2.0D0*R0*K/X 50 BL(K)=R0*BL(K) DL(0)=-0.5D0*X*BL(1) DO 55 K=1,NM 55 DL(K)=2.0D0*K/X*(BL(K-1)-BL(K)) C 9999 CONTINUE BL1=BL(NM) DL1=DL(NM) RETURN END SUBROUTINE LAMPDF(X,ALAMBA,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE (TUKEY) LAMBDA DISTRIBUTION C WITH TAIL LENGTH PARAMETER VALUE = ALAMBA. C IN GENERAL, THE PROBABILITY DENSITY FUNCTION C FOR THIS DISTRIBUTION IS NOT SIMPLE. C THE PERCENT POINT FUNCTION FOR THIS DISTRIBUTION IS C G(P) = ((P**ALAMBA)-((1-P)**ALAMBA))/ALAMBA C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C --ALAMBA = THE SINGLE PRECISION VALUE OF LAMBDA C (THE TAIL LENGTH PARAMETER). C OUTPUT ARGUMENTS--PDF = THE SINGLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY C FUNCTION VALUE PDF FOR THE TUKEY LAMBDA DISTRIBUTION C WITH TAIL LENGTH PARAMETER = ALAMBA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--FOR ALAMBA NON-POSITIVE, NO RESTRICTIONS ON X. C --FOR ALAMBA POSITIVE, X SHOULD BE BETWEEN (-1/ALAMBA) C AND (+1/ALAMBA), INCLUSIVELY. C OTHER DATAPAC SUBROUTINES NEEDED--LAMCDF. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN. C REFERENCES--HASTINGS, MOSTELLER, TUKEY, AND WINDSOR, C 'LOW MOMENTS FOR SMALL SAMPLES: A COMPARATIVE C STUDY OF ORDER STATISTICS', ANNALS OF C MATHEMATICAL STATISTICS, 18, 1947, C PAGES 413-426. 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 42-44, 53-58. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-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 C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(ALAMBA.LE.0.0)GOTO90 XMAX=1.0/ALAMBA XMIN=-XMAX IF(X.LT.XMIN.OR.X.GT.XMAX)GOTO50 GOTO90 50 CONTINUE WRITE(ICOUT,2) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') IF(X.LT.XMIN)PDF=0.0 IF(X.GT.XMAX)PDF=1.0 RETURN 90 CONTINUE 2 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENNT') 3 FORMAT(' TO THE LAMPDF SUBROUTINE IS OUTSIDE THE USUAL') 4 FORMAT(' +-(1/ALAMBA) INTERVAL *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C C-----START POINT----------------------------------------------------- C IF(ALAMBA.GT.0.0)GOTO110 GOTO150 110 XMAX=1.0/ALAMBA XMIN=-XMAX IF(X.GT.XMIN.AND.X.LT.XMAX)GOTO150 IF(X.LT.XMIN.OR.X.GT.XMAX)PDF=0.0 IF(X.EQ.XMIN.AND.ALAMBA.LT.1.0)PDF=0.0 IF(X.EQ.XMAX.AND.ALAMBA.LT.1.0)PDF=0.0 IF(X.EQ.XMIN.AND.ALAMBA.EQ.1.0)PDF=0.5 IF(X.EQ.XMAX.AND.ALAMBA.EQ.1.0)PDF=0.5 IF(X.EQ.XMIN.AND.ALAMBA.GT.1.0)PDF=1.0 IF(X.EQ.XMAX.AND.ALAMBA.GT.1.0)PDF=1.0 RETURN C 150 CALL LAMCDF(X,ALAMBA,CDF) SF =CDF**(ALAMBA-1.0)+(1.0-CDF)**(ALAMBA-1.0) PDF=1.0/SF RETURN C END SUBROUTINE LAMPPC(X,N,ALAMBA,IWRITE,Y,W,MAXNYW,PPCC,IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE TUKEY LAMBDA C PROBABILITY PLOT CORRELATION COEFFICIENT C (WITH TAIL LENGTH PARAMETER VALUE = ALAMBA). C IN GENERAL, THE PROBABILITY DENSITY FUNCTION C FOR THIS DISTRIBUTION IS NOT SIMPLE. C THE PERCENT POINT FUNCTION FOR THIS DISTRIBUTION IS C G(P) = ((P**ALAMBA)-((1-P)**ALAMBA)) / ALAMBA 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 LAMBDA 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 LAMBDA DISTRIBUTION C WITH TAIL LENGTH PARAMETER VALUE = ALAMBA. 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 --ALAMBA = THE SINGLE PRECISION VALUE OF LAMBDA C (THE TAIL LENGTH PARAMETER). C OUTPUT ARGUMENTS--PPCC = THE SINGLE PRECISION VALUE OF THE C COMPUTED TUKEY LAMBDA PPCC. C OUTPUT--NONE. C PRINTING--YES. C OTHER DATAPAC SUBROUTINES NEEDED--SORT, UNIMED. C FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG. 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 --HAHN AND SHAPIRO, STATISTICAL METHODS IN ENGINEERING, C 1967, PAGES 260-308. C --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--1, 1970, PAGES 154-165. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--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='LAMP' 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 LAMPPC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N,ALAMBA 53 FORMAT('N,ALAMBA = ',I8,E15.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 TUKEY LAMBDA ** 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 LAMPPC--') 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 TUKEY LAMBDA 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 LAMPPC--', 1'THE SECOND 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 LAMPPC--', 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 TUKEY LAMBDA ** C ** PROBABILITY PLOT CORRELATION COEFFICIENT. ** C ************************************************* C CALL SORT(X,N,Y) C CALL UNIMED(N,W) C IF(-0.001.LT.ALAMBA.AND.ALAMBA.LT.0.001)GOTO210 GOTO220 210 CONTINUE DO215I=1,N Q=W(I) W(I)=ALOG(1/(1.0-Q)) 215 CONTINUE GOTO290 220 CONTINUE DO225I=1,N Q=W(I) W(I)=(Q**ALAMBA-(1.0-Q)**ALAMBA)/ALAMBA 225 CONTINUE GOTO290 290 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)ALAMBA 811 FORMAT('THE TUKEY LAMBDA ',F10.5,' PROBABILITY PLOT ', 1'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 LAMPPC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N,ALAMBA 9013 FORMAT('N,ALAMBA = ',I8,E15.7) 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 LAMPPF(P,ALAMBA,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE (TUKEY) LAMBDA DISTRIBUTION C WITH TAIL LENGTH PARAMETER VALUE = ALAMBA. C IN GENERAL, THE PROBABILITY DENSITY FUNCTION C FOR THIS DISTRIBUTION IS NOT SIMPLE. C THE PERCENT POINT FUNCTION FOR THIS DISTRIBUTION IS C G(P) = ((P**ALAMBA)-((1-P)**ALAMBA))/ALAMBA 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 --ALAMBA = THE SINGLE PRECISION VALUE OF LAMBDA C (THE TAIL LENGTH PARAMETER). C OUTPUT ARGUMENTS--PPF = THE SINGLE PRECISION PERCENT C POINT FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PERCENT POINT C FUNCTION VALUE PPF FOR THE TUKEY LAMBDA DISTRIBUTION C WITH TAIL LENGTH PARAMETER = ALAMBA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--IF ALAMBA IS POSITIVE, C THEN P SHOULD BE BETWEEN 0.0 AND 1.0, INCLUSIVELY. C IF ALAMBA IS NON-POSITIVE, C THEN P SHOULD BE BETWEEN 0.0 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--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 PAGES 53-58. C --FILLIBEN, 'THE PERCENT POINT FUNCTION', C (UNPUBLISHED MANUSCRIPT), 1970, PAGES 28-31. C --HASTINGS, MOSTELLER, TUKEY, AND WINDSOR, C 'LOW MOMENTS FOR SMALL SAMPLES: A COMPARATIVE C STUDY OF ORDER STATISTICS', ANNALS OF C MATHEMATICAL STATISTICS, 18, 1947, C PAGES 413-426. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--82.6 C ORIGINAL VERSION--JUNE 1972. C UPDATED --SEPTEMBER 1975. C UPDATED --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(ALAMBA.LE.0.0.AND.P.LE.0.0)GOTO50 IF(ALAMBA.LE.0.0.AND.P.GE.1.0)GOTO50 IF(ALAMBA.GT.0.0.AND.P.LT.0.0)GOTO50 IF(ALAMBA.GT.0.0.AND.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'LAMPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C IF(-0.001.LT.ALAMBA.AND.ALAMBA.LT.0.001)GOTO150 GOTO250 150 PPF=ALOG(P/(1.0-P)) RETURN C 250 PPF= (P**ALAMBA-(1.0-P)**ALAMBA)/ALAMBA RETURN C END SUBROUTINE LAMRAN(N,ALAMBA,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE (TUKEY) LAMBDA DISTRIBUTION C WITH TAIL LENGTH PARAMETER VALUE = ALAMBA. C IN GENERAL, THE PROBABILITY DENSITY FUNCTION C FOR THIS DISTRIBUTION IS NOT SIMPLE. C THE PERCENT POINT FUNCTION FOR THIS DISTRIBUTION IS C G(P) = ((P**ALAMBA)-((1-P)**ALAMBA))/ALAMBA C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --ALAMBA = THE SINGLE PRECISION VALUE OF LAMBDA C (THE TAIL LENGTH 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 (TUKEY) LAMBDA DISTRIBUTION C WITH TAIL LENGTH PARAMETER VALUE = 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 OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN. C FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--TOCHER, THE ART OF SIMULATION, C 1963, PAGES 14-15. C --HAMMERSLEY AND HANDSCOMB, MONTE CARLO METHODS, C 1964, PAGE 36. C --FILLIBEN, SIMPLE AND ROBUST LINEAR ESTIMATION C OF THE LOCATION PARAMETER OF A SYMMETRIC C DISTRIBUTION (UNPUBLISHED PH.D. DISSERTATION, C PRINCETON UNIVERSITY), 1969, PAGES 21-44, 53-58. C --FILLIBEN, 'THE PERCENT POINT FUNCTION', C (UNPUBLISHED MANUSCRIPT), 1970, PAGES 28-31. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--82.6 C ORIGINAL VERSION--JUNE 1972. C UPDATED --SEPTEMBER 1975. C UPDATED --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 ALAMB2=ALAMBA 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'LAMRAN 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 LAMBDA DISTRIBUTION RANDOM NUMBERS C USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD. C DO100I=1,N Q=X(I) IF(-0.001.LT.ALAMB2.AND.ALAMB2.LT.0.001)X(I)=ALOG(Q/(1.0-Q)) IF(-0.001.LT.ALAMB2.AND.ALAMB2.LT.0.001)GOTO100 X(I)=(Q**ALAMB2-(1.0-Q)**ALAMB2)/ALAMB2 100 CONTINUE C RETURN END SUBROUTINE LAMSF(P,ALAMBA,SF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE SPARSITY C FUNCTION VALUE FOR THE (TUKEY) LAMBDA DISTRIBUTION C WITH TAIL LENGTH PARAMETER VALUE = ALAMBA. C IN GENERAL, THE PROBABILITY DENSITY FUNCTION C FOR THIS DISTRIBUTION IS NOT SIMPLE. C THE PERCENT POINT FUNCTION FOR THIS DISTRIBUTION IS C G(P) = ((P**ALAMBA)-((1-P)**ALAMBA))/ALAMBA 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 --ALAMBA = THE SINGLE PRECISION VALUE OF LAMBDA C (THE TAIL LENGTH PARAMETER). C OUTPUT ARGUMENTS--SF = THE SINGLE PRECISION C SPARSITY FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION SPARSITY C FUNCTION VALUE SF FOR THE TUKEY LAMBDA DISTRIBUTION C WITH TAIL LENGTH PARAMETER = ALAMBA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--IF ALAMBA IS POSITIVE, C THEN P SHOULD BE BETWEEN 0.0 AND 1.0, INCLUSIVELY. C IF ALAMBA IS NON-POSITIVE, C THEN P SHOULD BE BETWEEN 0.0 AND 1.0, EXCLUSIVELY. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN. C 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 PAGES 53-58. C --FILLIBEN, 'THE PERCENT POINT FUNCTION', C (UNPUBLISHED MANUSCRIPT), 1970, PAGES 28-31. C --HASTINGS, MOSTELLER, TUKEY, AND WINDSOR, C 'LOW MOMENTS FOR SMALL SAMPLES: A COMPARATIVE C STUDY OF ORDER STATISTICS', ANNALS OF C MATHEMATICAL STATISTICS, 18, 1947, C PAGES 413-426. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-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 C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(ALAMBA.LE.0.0.AND.P.LE.0.0)GOTO50 IF(ALAMBA.LE.0.0.AND.P.GE.1.0)GOTO50 IF(ALAMBA.GT.0.0.AND.P.LT.0.0)GOTO50 IF(ALAMBA.GT.0.0.AND.P.GT.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 LAMSF') 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 SF=P**(ALAMBA-1.0)+(1.0-P)**(ALAMBA-1.0) C RETURN END SUBROUTINE LAMV(V,X,VM,VL1,DL1,IERROR) C C ========================================================= C Purpose: Compute lambda function with arbitrary order v, C and their derivative C Input : x --- Argument of lambda function C v --- Order of lambda function C Output: VL(n) --- Lambda function of order n+v0 C DL(n) --- Derivative of lambda function C VM --- Highest order computed C Routines called: C (1) MSTA1 and MSTA2 for computing the starting C point for backward recurrence C (2) GAM0 for computing gamma function (|x| 1) C (USE SLATEC VERSION: DGAMMA) C ========================================================= C PARAMETER(MAXORD=500) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION VL(0:MAXORD),DL(0:MAXORD) CHARACTER*4 IERROR C IF(V.GT.REAL(MAXORD))THEN IERROR='YES' RETURN ENDIF C PI=3.141592653589793D0 RP2=0.63661977236758D0 X=DABS(X) X2=X*X N=INT(V) V0=V-N VM=V IF (X.LE.12.0D0) THEN DO 25 K=0,N VK=V0+K BK=1.0D0 R=1.0D0 DO 10 I=1,50 R=-0.25D0*R*X2/(I*(I+VK)) BK=BK+R IF (DABS(R).LT.DABS(BK)*1.0D-15) GO TO 15 10 CONTINUE 15 CONTINUE VL(K)=BK UK=1.0D0 R=1.0D0 DO 20 I=1,50 R=-0.25D0*R*X2/(I*(I+VK+1.0D0)) UK=UK+R IF (DABS(R).LT.DABS(UK)*1.0D-15) GO TO 25 20 CONTINUE 25 DL(K)=-0.5D0*X/(VK+1.0D0)*UK GOTO9999 ENDIF K0=11 IF (X.GE.35.0D0) K0=10 IF (X.GE.50.0D0) K0=8 DO 40 J=0,1 VV=4.0D0*(J+V0)*(J+V0) PX=1.0D0 RP=1.0D0 DO 30 K=1,K0 RP=-0.78125D-2*RP*(VV-(4.0*K-3.0)**2.0)*(VV- & (4.0*K-1.0)**2.0)/(K*(2.0*K-1.0)*X2) 30 PX=PX+RP QX=1.0D0 RQ=1.0D0 DO 35 K=1,K0 RQ=-0.78125D-2*RQ*(VV-(4.0*K-1.0)**2.0)*(VV- & (4.0*K+1.0)**2.0)/(K*(2.0*K+1.0)*X2) 35 QX=QX+RQ QX=0.125D0*(VV-1.0D0)*QX/X XK=X-(0.5D0*(J+V0)+0.25D0)*PI A0=DSQRT(RP2/X) CK=DCOS(XK) SK=DSIN(XK) IF (J.EQ.0) BJV0=A0*(PX*CK-QX*SK) IF (J.EQ.1) BJV1=A0*(PX*CK-QX*SK) 40 CONTINUE IF (V0.EQ.0.0D0) THEN GA=1.0D0 ELSE CCCCC USE SLATEC GAMMA FUNCTION CCCCC CALL GAM0(V0,GA) GA=DGAMMA(V0) GA=V0*GA ENDIF FAC=(2.0D0/X)**V0*GA VL(0)=BJV0 DL(0)=-BJV1+V0/X*BJV0 VL(1)=BJV1 DL(1)=BJV0-(1.0D0+V0)/X*BJV1 R0=2.0D0*(1.0D0+V0)/X IF (N.LE.1) THEN VL(0)=FAC*VL(0) DL(0)=FAC*DL(0)-V0/X*VL(0) VL(1)=FAC*R0*VL(1) DL(1)=FAC*R0*DL(1)-(1.0D0+V0)/X*VL(1) GOTO9999 ENDIF IF (N.GE.2.AND.N.LE.INT(0.9*X)) THEN F0=BJV0 F1=BJV1 DO 45 K=2,N F=2.0D0*(K+V0-1.0D0)/X*F1-F0 F0=F1 F1=F 45 VL(K)=F ELSE IF (N.GE.2) THEN M=MSTA1(X,200) IF (M.LT.N) THEN N=M ELSE M=MSTA2(X,N,15) ENDIF F2=0.0D0 F1=1.0D-100 DO 50 K=M,0,-1 F=2.0D0*(V0+K+1.0D0)/X*F1-F2 IF (K.LE.N) VL(K)=F F2=F1 50 F1=F IF (DABS(BJV0).GT.DABS(BJV1)) CS=BJV0/F IF (DABS(BJV0).LE.DABS(BJV1)) CS=BJV1/F2 DO 55 K=0,N 55 VL(K)=CS*VL(K) ENDIF VL(0)=FAC*VL(0) DO 65 J=1,N RC=FAC*R0 VL(J)=RC*VL(J) DL(J-1)=-0.5D0*X/(J+V0)*VL(J) 65 R0=2.0D0*(J+V0+1)/X*R0 DL(N)=2.0D0*(V0+N)*(VL(N-1)-VL(N))/X VM=N+V0 C 9999 CONTINUE VL1=VL(N) DL1=DL(N) RETURN END DOUBLE PRECISION FUNCTION LANCDF(X) * From CERNLIB, remame DISLAN to LANCDF * * $Id: dislan.F,v 1.1.1.1 1996/04/01 15:02:43 mclareni Exp $ * * $Log: dislan.F,v $ * Revision 1.1.1.1 1996/04/01 15:02:43 mclareni * Mathlib gen * * IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION P1(0:4),P2(0:3),P3(0:3),P4(0:3),P5(0:3),P6(0:3) DIMENSION Q1(0:4),Q2(0:3),Q3(0:3),Q4(0:3),Q5(0:3),Q6(0:3) DIMENSION A1(1:3),A2(1:3) DATA (P1(I),I=0,4),(Q1(I),I=0,4) 1/ 0.25140 91491D+0,-0.62505 80444D-1, 0.14583 81230D-1, 2 -0.21088 17737D-2, 0.74112 47290D-3, 3 1.0 ,-0.55711 75625D-2, 0.62253 10236D-1, 4 -0.31373 78427D-2, 0.19314 96439D-2/ DATA (P2(I),I=0,3),(Q2(I),I=0,3) 1/ 0.28683 28584D+0, 0.35643 63231D+0, 0.15235 18695D+0, 2 0.22513 04883D-1, 3 1.0 , 0.61911 36137D+0, 0.17207 21448D+0, 4 0.22785 94771D-1/ DATA (P3(I),I=0,3),(Q3(I),I=0,3) 1/ 0.28683 29066D+0, 0.30038 28436D+0, 0.99509 51941D-1, 2 0.87338 27185D-2, 3 1.0 , 0.42371 90502D+0, 0.10956 31512D+0, 4 0.86938 51567D-2/ DATA (P4(I),I=0,3),(Q4(I),I=0,3) 1/ 0.10003 51630D+1, 0.45035 92498D+1, 0.10858 83880D+2, 2 0.75360 52269D+1, 3 1.0 , 0.55399 69678D+1, 0.19335 81111D+2, 4 0.27213 21508D+2/ DATA (P5(I),I=0,3),(Q5(I),I=0,3) 1/ 0.10000 06517D+1, 0.49094 14111D+2, 0.85055 44753D+2, 2 0.15321 53455D+3, 3 1.0 , 0.50099 28881D+2, 0.13998 19104D+3, 4 0.42000 02909D+3/ DATA (P6(I),I=0,3),(Q6(I),I=0,3) 1/ 0.10000 00983D+1, 0.13298 68456D+3, 0.91621 49244D+3, 2 -0.96050 54274D+3, 3 1.0 , 0.13398 87843D+3, 0.10559 90413D+4, 4 0.55322 24619D+3/ DATA (A1(I),I=1,3) 1/-0.45833 33333D+0, 0.66753 47222D+0,-0.16417 41416D+1/ DATA (A2(I),I=1,3) 1/ 1.0 ,-0.42278 43351D+0,-0.20434 03138D+1/ V=X IF(V .LT. -5.5) THEN U=EXP(V+1.0) LANCDF=0.3989422803*EXP(-1/U)*SQRT(U)* 1 (1.0+(A1(1)+(A1(2)+A1(3)*U)*U)*U) ELSEIF(V .LT. -1.0) THEN U=EXP(-V-1.0) LANCDF=(EXP(-U)/SQRT(U))* 1 (P1(0)+(P1(1)+(P1(2)+(P1(3)+P1(4)*V)*V)*V)*V)/ 2 (Q1(0)+(Q1(1)+(Q1(2)+(Q1(3)+Q1(4)*V)*V)*V)*V) ELSEIF(V .LT. 1.0) THEN LANCDF=(P2(0)+(P2(1)+(P2(2)+P2(3)*V)*V)*V)/ 1 (Q2(0)+(Q2(1)+(Q2(2)+Q2(3)*V)*V)*V) ELSEIF(V .LT. 4.0) THEN LANCDF=(P3(0)+(P3(1)+(P3(2)+P3(3)*V)*V)*V)/ 1 (Q3(0)+(Q3(1)+(Q3(2)+Q3(3)*V)*V)*V) ELSEIF(V .LT. 12.0) THEN U=1.0/V LANCDF=(P4(0)+(P4(1)+(P4(2)+P4(3)*U)*U)*U)/ 1 (Q4(0)+(Q4(1)+(Q4(2)+Q4(3)*U)*U)*U) ELSEIF(V .LT. 50.0) THEN U=1.0/V LANCDF=(P5(0)+(P5(1)+(P5(2)+P5(3)*U)*U)*U)/ 1 (Q5(0)+(Q5(1)+(Q5(2)+Q5(3)*U)*U)*U) ELSEIF(V .LT. 300.0) THEN U=1.0/V LANCDF=(P6(0)+(P6(1)+(P6(2)+P6(3)*U)*U)*U)/ 1 (Q6(0)+(Q6(1)+(Q6(2)+Q6(3)*U)*U)*U) ELSE U=1.0/(V-V*LOG(V)/(V+1.0)) LANCDF=1.0-(A2(1)+(A2(2)+A2(3)*U)*U)*U ENDIF RETURN END DOUBLE PRECISION FUNCTION LANDIF(X) * From CERNLIB. Rename DIFLAN to LANDIF * * $Id: diflan.F,v 1.1.1.1 1996/04/01 15:02:43 mclareni Exp $ * * $Log: diflan.F,v $ * Revision 1.1.1.1 1996/04/01 15:02:43 mclareni * Mathlib gen * * IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION P1(0:4),P2(0:4),P3(0:4),P4(0:4),P5(0:4),P6(0:4),P7(0:5) DIMENSION Q1(0:4),Q2(0:4),Q3(0:4),Q4(0:4),Q5(0:4),Q6(0:4),Q7(0:5) DIMENSION A1(1:6),A2(1:3) DATA (P1(I),I=0,4),(Q1(I),I=0,4) 1/-0.30620 16156E-1,-0.12514 24734E+0,-0.95514 20540E-1, 2 -0.26943 56206E-1,-0.26175 52485E-2, 3 1.0 , 0.11777 46655E+1, 0.61309 93990E+0, 4 0.15727 03422E+0, 0.17262 95027E-1/ DATA (P2(I),I=0,4),(Q2(I),I=0,4) 1/-0.15491 26548E-1,-0.75512 22105E-1,-0.25986 23886E-1, 2 0.54712 70049E-2, 0.21522 70275E-2, 3 1.0 , 0.99974 60723E+0, 0.49882 64176E+0, 4 0.12891 04987E+0, 0.16396 32530E-1/ DATA (P3(I),I=0,4),(Q3(I),I=0,4) 1/-0.15471 35743E-1,-0.73041 84799E-1,-0.15341 51353E-1, 2 0.35687 80079E-2,-0.92961 96751E-4, 3 1.0 , 0.83941 07748E+0, 0.41280 36830E+0, 4 0.10502 22892E+0, 0.17008 94650E-1/ DATA (P4(I),I=0,4),(Q4(I),I=0,4) 1/-0.15462 73317E-1,-0.68561 27408E-1, 0.46112 67324E-2, 2 -0.25499 45537E-3, 0.58761 90635E-5, 3 1.0 , 0.54532 66037E+0, 0.28025 11577E+0, 4 0.47491 21515E-1, 0.10962 78827E-1/ DATA (P5(I),I=0,4),(Q5(I),I=0,4) 1/ 0.86420 27131E-5,-0.74742 91951E-3, 0.29356 78494E-1, 2 -0.27696 95199E+1,-0.77695 42153E+1, 3 1.0 , 0.90003 29289E+0, 0.34619 66768E+2, 4 0.46668 93094E+1, 0.19264 64264E+3/ DATA (P6(I),I=0,4),(Q6(I),I=0,4) 1/-0.20124 96309E+1,-0.27484 32206E+3,-0.57590 40086E+4, 2 -0.16000 68673E+5, 0.53346 52087E+5, 3 1.0 , 0.12295 70501E+3, 0.18746 82285E+4, 4 0.56780 25130E+4, 0.52823 54475E5/ DATA (P7(I),I=0,5),(Q7(I),I=0,5) 1/-0.20015 84932E+1,-0.24074 20185E+4,-0.54566 69704E+6, 2 -0.28170 17048E+8,-0.20643 92982E+9, 0.90496 05994E+9, 3 1.0 , 0.11829 29609E+4, 0.25522 99337E+6, 4 0.11392 05796E+8, 0.39347 02081E+8, 0.21080 69087E+9/ DATA (A1(I),I=1,6) 1/-0.45833 33333E+0, 0.86805 55556E-3,-0.28525 27006E-2, 2 0.53868 92562E-2,-0.14312 07031E-1, 0.50629 96176E-1/ DATA (A2(I),I=1,3) 1/-0.75367 06011E+1,-0.96018 56962E+1, 0.17146 15239E+3/ V=X IF(V .LT. -2.6D0) THEN U=EXP(V+1.0D0) LANDIF=0.3989422803D0*(EXP(-1.0D0/U)/U**1.5)* 1 (1.0D0+(A1(1)+(A1(2)+(A1(3)+ 1 (A1(4)+(A1(5)+A1(6)*U)*U)*U)*U)*U)*U) ELSEIF(V .LT. -1.75D0) THEN LANDIF=(P1(0)+(P1(1)+(P1(2)+(P1(3)+P1(4)*V)*V)*V)*V)/ 1 (Q1(0)+(Q1(1)+(Q1(2)+(Q1(3)+Q1(4)*V)*V)*V)*V) ELSEIF(V .LT. -1.25D0) THEN LANDIF=(P2(0)+(P2(1)+(P2(2)+(P2(3)+P2(4)*V)*V)*V)*V)/ 1 (Q2(0)+(Q2(1)+(Q2(2)+(Q2(3)+Q2(4)*V)*V)*V)*V) ELSEIF(V .LT. 0.5D0) THEN LANDIF=(P3(0)+(P3(1)+(P3(2)+(P3(3)+P3(4)*V)*V)*V)*V)/ 1 (Q3(0)+(Q3(1)+(Q3(2)+(Q3(3)+Q3(4)*V)*V)*V)*V) ELSEIF(V .LT. 5.0D0) THEN LANDIF=(P4(0)+(P4(1)+(P4(2)+(P4(3)+P4(4)*V)*V)*V)*V)/ 1 (Q4(0)+(Q4(1)+(Q4(2)+(Q4(3)+Q4(4)*V)*V)*V)*V) ELSEIF(V .LT. 15.D0) THEN U=1.0D0/V LANDIF=(P5(0)+(P5(1)+(P5(2)+(P5(3)+P5(4)*U)*U)*U)*U)/ 1 (Q5(0)+(Q5(1)+(Q5(2)+(Q5(3)+Q5(4)*U)*U)*U)*U) ELSEIF(V .LT. 50.0D0) THEN U=1.0D0/V LANDIF=U**3*(P6(0)+(P6(1)+(P6(2)+(P6(3)+P6(4)*U)*U)*U)*U)/ 1 (Q6(0)+(Q6(1)+(Q6(2)+(Q6(3)+Q6(4)*U)*U)*U)*U) ELSEIF(V .LT. 300.0D0) THEN U=1.0D0/V LANDIF=U**3* 1 (P7(0)+(P7(1)+(P7(2)+(P7(3)+(P7(4)+P7(5)*U)*U)*U)*U)*U)/ 2 (Q7(0)+(Q7(1)+(Q7(2)+(Q7(3)+(Q7(4)+Q7(5)*U)*U)*U)*U)*U) ELSE U=V-V*LOG(V)/(V+1.0D0) U=1.0D0/(U-U*(U+LOG(U)-V)/(U+1.0D0)) LANDIF=-U**3*(2.0D0+(A2(1)+(A2(2)+A2(3)*U)*U)*U) ENDIF RETURN END DOUBLE PRECISION FUNCTION LANPDF(X) * From CERNLIB, Rename LANPDF to LANPDF * * $Id: denlan.F,v 1.1.1.1 1996/04/01 15:02:43 mclareni Exp $ * * $Log: denlan.F,v $ * Revision 1.1.1.1 1996/04/01 15:02:43 mclareni * Mathlib gen * * IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION P1(0:4),P2(0:4),P3(0:4),P4(0:4),P5(0:4),P6(0:4) DIMENSION Q1(0:4),Q2(0:4),Q3(0:4),Q4(0:4),Q5(0:4),Q6(0:4) DIMENSION A1(1:3),A2(1:2) DATA (P1(I),I=0,4),(Q1(I),I=0,4) 1/ 0.42598 94875D+0,-0.12497 62550D+0, 0.39842 43700D-1, 2 -0.62982 87635D-2, 0.15111 62253D-2, 3 1.0 ,-0.33882 60629D+0, 0.95943 93323D-1, 4 -0.16080 42283D-1, 0.37789 42063D-2/ DATA (P2(I),I=0,4),(Q2(I),I=0,4) 1/ 0.17885 41609D+0, 0.11739 57403D+0, 0.14888 50518D-1, 2 -0.13949 89411D-2, 0.12836 17211D-3, 3 1.0 , 0.74287 95082D+0, 0.31539 32961D+0, 4 0.66942 19548D-1, 0.87906 09714D-2/ DATA (P3(I),I=0,4),(Q3(I),I=0,4) 1/ 0.17885 44503D+0, 0.93591 61662D-1, 0.63253 87654D-2, 2 0.66116 67319D-4,-0.20310 49101D-5, 3 1.0 , 0.60978 09921D+0, 0.25606 16665D+0, 4 0.47467 22384D-1, 0.69573 01675D-2/ DATA (P4(I),I=0,4),(Q4(I),I=0,4) 1/ 0.98740 54407D+0, 0.11867 23273D+3, 0.84927 94360D+3, 2 -0.74377 92444D+3, 0.42702 62186D+3, 3 1.0 , 0.10686 15961D+3, 0.33764 96214D+3, 4 0.20167 12389D+4, 0.15970 63511D+4/ DATA (P5(I),I=0,4),(Q5(I),I=0,4) 1/ 0.10036 75074D+1, 0.16757 02434D+3, 0.47897 11289D+4, 2 0.21217 86767D+5,-0.22324 94910D+5, 3 1.0 , 0.15694 24537D+3, 0.37453 10488D+4, 4 0.98346 98876D+4, 0.66924 28357D+5/ DATA (P6(I),I=0,4),(Q6(I),I=0,4) 1/ 0.10008 27619D+1, 0.66491 43136D+3, 0.62972 92665D+5, 2 0.47555 46998D+6,-0.57436 09109D+7, 3 1.0 , 0.65141 01098D+3, 0.56974 73333D+5, 4 0.16591 74725D+6,-0.28157 59939D+7/ DATA (A1(I),I=1,3) 1/ 0.41666 66667D-1,-0.19965 27778D-1, 0.27095 38966D-1/ DATA (A2(I),I=1,2) 1/-0.18455 68670D+1,-0.42846 40743D+1/ V=X IF(V .LT. -5.5) THEN U=EXP(V+1.0) LANPDF=0.3989422803*(EXP(-1.0/U)/SQRT(U))* 1 (1.0+(A1(1)+(A1(2)+A1(3)*U)*U)*U) ELSEIF(V .LT. -1.0) THEN U=EXP(-V-1.0) LANPDF=EXP(-U)*SQRT(U)* 1 (P1(0)+(P1(1)+(P1(2)+(P1(3)+P1(4)*V)*V)*V)*V)/ 2 (Q1(0)+(Q1(1)+(Q1(2)+(Q1(3)+Q1(4)*V)*V)*V)*V) ELSEIF(V .LT. 1.0) THEN LANPDF=(P2(0)+(P2(1)+(P2(2)+(P2(3)+P2(4)*V)*V)*V)*V)/ 1 (Q2(0)+(Q2(1)+(Q2(2)+(Q2(3)+Q2(4)*V)*V)*V)*V) ELSEIF(V .LT. 5.0) THEN LANPDF=(P3(0)+(P3(1)+(P3(2)+(P3(3)+P3(4)*V)*V)*V)*V)/ 1 (Q3(0)+(Q3(1)+(Q3(2)+(Q3(3)+Q3(4)*V)*V)*V)*V) ELSEIF(V .LT. 12.0) THEN U=1.0/V LANPDF=U**2*(P4(0)+(P4(1)+(P4(2)+(P4(3)+P4(4)*U)*U)*U)*U)/ 1 (Q4(0)+(Q4(1)+(Q4(2)+(Q4(3)+Q4(4)*U)*U)*U)*U) ELSEIF(V .LT. 50.0) THEN U=1.0/V LANPDF=U**2*(P5(0)+(P5(1)+(P5(2)+(P5(3)+P5(4)*U)*U)*U)*U)/ 1 (Q5(0)+(Q5(1)+(Q5(2)+(Q5(3)+Q5(4)*U)*U)*U)*U) ELSEIF(V .LT. 300.0) THEN U=1.0/V LANPDF=U**2*(P6(0)+(P6(1)+(P6(2)+(P6(3)+P6(4)*U)*U)*U)*U)/ 1 (Q6(0)+(Q6(1)+(Q6(2)+(Q6(3)+Q6(4)*U)*U)*U)*U) ELSE U=1.0/(V-V*LOG(V)/(V+1.0)) LANPDF=U**2*(1.0+(A2(1)+A2(2)*U)*U) ENDIF RETURN END DOUBLE PRECISION FUNCTION LANPPF(X) * From CERNLIB, rename LANPPF to LANPPF * * $Id: ranlan.F,v 1.1.1.1 1996/04/01 15:02:43 mclareni Exp $ * * $Log: ranlan.F,v $ * Revision 1.1.1.1 1996/04/01 15:02:43 mclareni * Mathlib gen * * IMPLICIT DOUBLE PRECISION (A-H,O-Z) C REAL CPUMIN REAL CPUMAX CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DIMENSION F(6:982) DATA (F(I),I= 6,100) A/ -2.244733, B -2.204365,-2.168163,-2.135219,-2.104898,-2.076740,-2.050397, C -2.025605,-2.002150,-1.979866,-1.958612,-1.938275,-1.918760, D -1.899984,-1.881879,-1.864385,-1.847451,-1.831030,-1.815083, E -1.799574,-1.784473,-1.769751,-1.755383,-1.741346,-1.727620, F -1.714187,-1.701029,-1.688130,-1.675477,-1.663057,-1.650858, G -1.638868,-1.627078,-1.615477,-1.604058,-1.592811,-1.581729, H -1.570806,-1.560034,-1.549407,-1.538919,-1.528565,-1.518339, I -1.508237,-1.498254,-1.488386,-1.478628,-1.468976,-1.459428, J -1.449979,-1.440626,-1.431365,-1.422195,-1.413111,-1.404112, K -1.395194,-1.386356,-1.377594,-1.368906,-1.360291,-1.351746, L -1.343269,-1.334859,-1.326512,-1.318229,-1.310006,-1.301843, M -1.293737,-1.285688,-1.277693,-1.269752,-1.261863,-1.254024, N -1.246235,-1.238494,-1.230800,-1.223153,-1.215550,-1.207990, O -1.200474,-1.192999,-1.185566,-1.178172,-1.170817,-1.163500, P -1.156220,-1.148977,-1.141770,-1.134598,-1.127459,-1.120354, Q -1.113282,-1.106242,-1.099233,-1.092255/ DATA (F(I),I=101,200) A/-1.085306,-1.078388,-1.071498,-1.064636,-1.057802,-1.050996, B -1.044215,-1.037461,-1.030733,-1.024029,-1.017350,-1.010695, C -1.004064, -.997456, -.990871, -.984308, -.977767, -.971247, D -.964749, -.958271, -.951813, -.945375, -.938957, -.932558, E -.926178, -.919816, -.913472, -.907146, -.900838, -.894547, F -.888272, -.882014, -.875773, -.869547, -.863337, -.857142, G -.850963, -.844798, -.838648, -.832512, -.826390, -.820282, H -.814187, -.808106, -.802038, -.795982, -.789940, -.783909, I -.777891, -.771884, -.765889, -.759906, -.753934, -.747973, J -.742023, -.736084, -.730155, -.724237, -.718328, -.712429, K -.706541, -.700661, -.694791, -.688931, -.683079, -.677236, L -.671402, -.665576, -.659759, -.653950, -.648149, -.642356, M -.636570, -.630793, -.625022, -.619259, -.613503, -.607754, N -.602012, -.596276, -.590548, -.584825, -.579109, -.573399, O -.567695, -.561997, -.556305, -.550618, -.544937, -.539262, P -.533592, -.527926, -.522266, -.516611, -.510961, -.505315, Q -.499674, -.494037, -.488405, -.482777/ DATA (F(I),I=201,300) A/ -.477153, -.471533, -.465917, -.460305, -.454697, -.449092, B -.443491, -.437893, -.432299, -.426707, -.421119, -.415534, C -.409951, -.404372, -.398795, -.393221, -.387649, -.382080, D -.376513, -.370949, -.365387, -.359826, -.354268, -.348712, E -.343157, -.337604, -.332053, -.326503, -.320955, -.315408, F -.309863, -.304318, -.298775, -.293233, -.287692, -.282152, G -.276613, -.271074, -.265536, -.259999, -.254462, -.248926, H -.243389, -.237854, -.232318, -.226783, -.221247, -.215712, I -.210176, -.204641, -.199105, -.193568, -.188032, -.182495, J -.176957, -.171419, -.165880, -.160341, -.154800, -.149259, K -.143717, -.138173, -.132629, -.127083, -.121537, -.115989, L -.110439, -.104889, -.099336, -.093782, -.088227, -.082670, M -.077111, -.071550, -.065987, -.060423, -.054856, -.049288, N -.043717, -.038144, -.032569, -.026991, -.021411, -.015828, O -.010243, -.004656, .000934, .006527, .012123, .017722, P .023323, .028928, .034535, .040146, .045759, .051376, Q .056997, .062620, .068247, .073877/ DATA (F(I),I=301,400) A/ .079511, .085149, .090790, .096435, .102083, .107736, B .113392, .119052, .124716, .130385, .136057, .141734, C .147414, .153100, .158789, .164483, .170181, .175884, D .181592, .187304, .193021, .198743, .204469, .210201, E .215937, .221678, .227425, .233177, .238933, .244696, F .250463, .256236, .262014, .267798, .273587, .279382, G .285183, .290989, .296801, .302619, .308443, .314273, H .320109, .325951, .331799, .337654, .343515, .349382, I .355255, .361135, .367022, .372915, .378815, .384721, J .390634, .396554, .402481, .408415, .414356, .420304, K .426260, .432222, .438192, .444169, .450153, .456145, L .462144, .468151, .474166, .480188, .486218, .492256, M .498302, .504356, .510418, .516488, .522566, .528653, N .534747, .540850, .546962, .553082, .559210, .565347, O .571493, .577648, .583811, .589983, .596164, .602355, P .608554, .614762, .620980, .627207, .633444, .639689, Q .645945, .652210, .658484, .664768/ DATA (F(I),I=401,500) A/ .671062, .677366, .683680, .690004, .696338, .702682, B .709036, .715400, .721775, .728160, .734556, .740963, C .747379, .753807, .760246, .766695, .773155, .779627, D .786109, .792603, .799107, .805624, .812151, .818690, E .825241, .831803, .838377, .844962, .851560, .858170, F .864791, .871425, .878071, .884729, .891399, .898082, G .904778, .911486, .918206, .924940, .931686, .938446, H .945218, .952003, .958802, .965614, .972439, .979278, I .986130, .992996, .999875, 1.006769, 1.013676, 1.020597, J 1.027533, 1.034482, 1.041446, 1.048424, 1.055417, 1.062424, K 1.069446, 1.076482, 1.083534, 1.090600, 1.097681, 1.104778, L 1.111889, 1.119016, 1.126159, 1.133316, 1.140490, 1.147679, M 1.154884, 1.162105, 1.169342, 1.176595, 1.183864, 1.191149, N 1.198451, 1.205770, 1.213105, 1.220457, 1.227826, 1.235211, O 1.242614, 1.250034, 1.257471, 1.264926, 1.272398, 1.279888, P 1.287395, 1.294921, 1.302464, 1.310026, 1.317605, 1.325203, Q 1.332819, 1.340454, 1.348108, 1.355780/ DATA (F(I),I=501,600) A/ 1.363472, 1.371182, 1.378912, 1.386660, 1.394429, 1.402216, B 1.410024, 1.417851, 1.425698, 1.433565, 1.441453, 1.449360, C 1.457288, 1.465237, 1.473206, 1.481196, 1.489208, 1.497240, D 1.505293, 1.513368, 1.521465, 1.529583, 1.537723, 1.545885, E 1.554068, 1.562275, 1.570503, 1.578754, 1.587028, 1.595325, F 1.603644, 1.611987, 1.620353, 1.628743, 1.637156, 1.645593, G 1.654053, 1.662538, 1.671047, 1.679581, 1.688139, 1.696721, H 1.705329, 1.713961, 1.722619, 1.731303, 1.740011, 1.748746, I 1.757506, 1.766293, 1.775106, 1.783945, 1.792810, 1.801703, J 1.810623, 1.819569, 1.828543, 1.837545, 1.846574, 1.855631, K 1.864717, 1.873830, 1.882972, 1.892143, 1.901343, 1.910572, L 1.919830, 1.929117, 1.938434, 1.947781, 1.957158, 1.966566, M 1.976004, 1.985473, 1.994972, 2.004503, 2.014065, 2.023659, N 2.033285, 2.042943, 2.052633, 2.062355, 2.072110, 2.081899, O 2.091720, 2.101575, 2.111464, 2.121386, 2.131343, 2.141334, P 2.151360, 2.161421, 2.171517, 2.181648, 2.191815, 2.202018, Q 2.212257, 2.222533, 2.232845, 2.243195/ DATA (F(I),I=601,700) A/ 2.253582, 2.264006, 2.274468, 2.284968, 2.295507, 2.306084, B 2.316701, 2.327356, 2.338051, 2.348786, 2.359562, 2.370377, C 2.381234, 2.392131, 2.403070, 2.414051, 2.425073, 2.436138, D 2.447246, 2.458397, 2.469591, 2.480828, 2.492110, 2.503436, E 2.514807, 2.526222, 2.537684, 2.549190, 2.560743, 2.572343, F 2.583989, 2.595682, 2.607423, 2.619212, 2.631050, 2.642936, G 2.654871, 2.666855, 2.678890, 2.690975, 2.703110, 2.715297, H 2.727535, 2.739825, 2.752168, 2.764563, 2.777012, 2.789514, I 2.802070, 2.814681, 2.827347, 2.840069, 2.852846, 2.865680, J 2.878570, 2.891518, 2.904524, 2.917588, 2.930712, 2.943894, K 2.957136, 2.970439, 2.983802, 2.997227, 3.010714, 3.024263, L 3.037875, 3.051551, 3.065290, 3.079095, 3.092965, 3.106900, M 3.120902, 3.134971, 3.149107, 3.163312, 3.177585, 3.191928, N 3.206340, 3.220824, 3.235378, 3.250005, 3.264704, 3.279477, O 3.294323, 3.309244, 3.324240, 3.339312, 3.354461, 3.369687, P 3.384992, 3.400375, 3.415838, 3.431381, 3.447005, 3.462711, Q 3.478500, 3.494372, 3.510328, 3.526370/ DATA (F(I),I=701,800) A/ 3.542497, 3.558711, 3.575012, 3.591402, 3.607881, 3.624450, B 3.641111, 3.657863, 3.674708, 3.691646, 3.708680, 3.725809, C 3.743034, 3.760357, 3.777779, 3.795300, 3.812921, 3.830645, D 3.848470, 3.866400, 3.884434, 3.902574, 3.920821, 3.939176, E 3.957640, 3.976215, 3.994901, 4.013699, 4.032612, 4.051639, F 4.070783, 4.090045, 4.109425, 4.128925, 4.148547, 4.168292, G 4.188160, 4.208154, 4.228275, 4.248524, 4.268903, 4.289413, H 4.310056, 4.330832, 4.351745, 4.372794, 4.393982, 4.415310, I 4.436781, 4.458395, 4.480154, 4.502060, 4.524114, 4.546319, J 4.568676, 4.591187, 4.613854, 4.636678, 4.659662, 4.682807, K 4.706116, 4.729590, 4.753231, 4.777041, 4.801024, 4.825179, L 4.849511, 4.874020, 4.898710, 4.923582, 4.948639, 4.973883, M 4.999316, 5.024942, 5.050761, 5.076778, 5.102993, 5.129411, N 5.156034, 5.182864, 5.209903, 5.237156, 5.264625, 5.292312, O 5.320220, 5.348354, 5.376714, 5.405306, 5.434131, 5.463193, P 5.492496, 5.522042, 5.551836, 5.581880, 5.612178, 5.642734, Q 5.673552, 5.704634, 5.735986, 5.767610/ DATA (F(I),I=801,900) A/ 5.799512, 5.831694, 5.864161, 5.896918, 5.929968, 5.963316, B 5.996967, 6.030925, 6.065194, 6.099780, 6.134687, 6.169921, C 6.205486, 6.241387, 6.277630, 6.314220, 6.351163, 6.388465, D 6.426130, 6.464166, 6.502578, 6.541371, 6.580553, 6.620130, E 6.660109, 6.700495, 6.741297, 6.782520, 6.824173, 6.866262, F 6.908795, 6.951780, 6.995225, 7.039137, 7.083525, 7.128398, G 7.173764, 7.219632, 7.266011, 7.312910, 7.360339, 7.408308, H 7.456827, 7.505905, 7.555554, 7.605785, 7.656608, 7.708035, I 7.760077, 7.812747, 7.866057, 7.920019, 7.974647, 8.029953, J 8.085952, 8.142657, 8.200083, 8.258245, 8.317158, 8.376837, K 8.437300, 8.498562, 8.560641, 8.623554, 8.687319, 8.751955, L 8.817481, 8.883916, 8.951282, 9.019600, 9.088889, 9.159174, M 9.230477, 9.302822, 9.376233, 9.450735, 9.526355, 9.603118, N 9.681054, 9.760191, 9.840558, 9.922186,10.005107,10.089353, O 10.174959,10.261958,10.350389,10.440287,10.531693,10.624646, P 10.719188,10.815362,10.913214,11.012789,11.114137,11.217307, Q 11.322352,11.429325,11.538283,11.649285/ DATA (F(I),I=901,982) A/11.762390,11.877664,11.995170,12.114979,12.237161,12.361791, B 12.488946,12.618708,12.751161,12.886394,13.024498,13.165570, C 13.309711,13.457026,13.607625,13.761625,13.919145,14.080314, D 14.245263,14.414134,14.587072,14.764233,14.945778,15.131877, E 15.322712,15.518470,15.719353,15.925570,16.137345,16.354912, F 16.578520,16.808433,17.044929,17.288305,17.538873,17.796967, G 18.062943,18.337176,18.620068,18.912049,19.213574,19.525133, H 19.847249,20.180480,20.525429,20.882738,21.253102,21.637266, I 22.036036,22.450278,22.880933,23.329017,23.795634,24.281981, J 24.789364,25.319207,25.873062,26.452634,27.059789,27.696581, K 28.365274,29.068370,29.808638,30.589157,31.413354,32.285060, L 33.208568,34.188705,35.230920,36.341388,37.527131,38.796172, M 40.157721,41.622399,43.202525,44.912465,46.769077,48.792279, N 51.005773,53.437996,56.123356,59.103894/ IF(X.LT.0.000001D0 .OR. X.GT.0.999999D0)THEN WRITE(ICOUT, 5) 5 FORMAT('**** ERROR IN LANPPF: ARGUMENT NOT IN THE ', 1 '(0.000001,0.999999) INTERVAL') CALL DPWRST('XXX','BUG ') RETURN ENDIF U=1000.0D0*X I=U U=U-I IF(I .GE. 70 .AND. I .LE. 800) THEN LANPPF=F(I)+U*(F(I+1)-F(I)) ELSEIF(I .GE. 7 .AND. I .LE. 980) THEN LANPPF= 1 F(I)+U*(F(I+1)-F(I)-0.25D0* 1 (1.0D0-U)*(F(I+2)-F(I+1)-F(I)+F(I-1))) ELSEIF(I. LT. 7) THEN V=LOG(X) U=1.0D0/V LANPPF=((0.99858950D0+(3.45213058D1+1.70854528D1*U)*U)/ 1 (1.0D0 +(3.41760202D1+4.01244582D0 *U)*U))* 2 (-LOG(-0.91893853D0-V)-1.0D0) ELSE C C NOTE: I HAD A BIT OF A PROBLEM WITH LAST CASE. RECODE C SLIGHTLY. C X=X*10**6 + 0.1 I=X I=1000000-I U=I U=U/(1.0D0*10**6) CCCCC U=1.0D0-X V=U**2 IF(X .LE. 0.999D0) THEN LANPPF=(1.00060006D0+2.63991156D2*U+4.37320068D3*V)/ 1 ((1.0D0 +2.57368075D2*U+3.41448018D3*V)*U) ELSE CCCCC print *,'u,v=',u,v D1 = 1.00001538D0 D2 = 6.075141193D0*10**3 D3 = 7.34266409D0*10**5 D4 = 6.06511919D0*10**3 D5 = 6.94021044D0*10**5 DNUM = D1 + D2*U + D3*V DDEN = (1.0D0 + D4*U + D5*V)*U LANPPF = DNUM/DDEN CCCCC LANPPF=(1.00001538D0+6.07514119D3*U+7.34266409D5*V)/ CCCCC1 ((1.0D0 +6.06511919D3*U+6.94021044D5*V)*U) ENDIF ENDIF RETURN END SUBROUTINE LANRAN(N,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE LANDAU 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 LANDAU DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--2003.4 C ORIGINAL VERSION--APRIL 2003. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*) DOUBLE PRECISION LANPPF 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'LANRAN 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 LANDAU DISTRIBUTION RANDOM NUMBERS C USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD. C DO100I=1,N 105 CONTINUE IF(X(I).LT.0.000001 .OR. X(I).GT.0.999999)THEN CALL UNIRAN(1,ISEED,X(I)) IF(X(I).LT.0.000001 .OR. X(I).GT.0.999999)GOTO105 ENDIF XTEMP=REAL(LANPPF(DBLE(X(I)))) X(I)=XTEMP 100 CONTINUE C 9000 CONTINUE RETURN END DOUBLE PRECISION FUNCTION LANXM1(X) * From CERNLIB, rename XM1LAN to LANXM1 * * $Id: xm1lan.F,v 1.1.1.1 1996/04/01 15:02:44 mclareni Exp $ * * $Log: xm1lan.F,v $ * Revision 1.1.1.1 1996/04/01 15:02:44 mclareni * Mathlib gen * * IMPLICIT DOUBLE PRECISION (A-H, O-Z) C DIMENSION P1(0:4),P2(0:4),P3(0:4),P4(0:3),P5(0:3) DIMENSION Q1(0:4),Q2(0:4),Q3(0:4),Q4(0:3),Q5(0:3) DIMENSION A0(0:5),A1(1:3),A2(1:4) DATA (P1(I),I=0,4),(Q1(I),I=0,4) 1/-0.89493 74280E+0, 0.46317 83434E+0,-0.40533 32915E-1, 2 0.15800 75560E-1,-0.34238 74194E-2, 3 1.0 , 0.10029 30749E+0, 0.35752 71633E-1, 4 -0.19158 82099E-2, 0.48110 72364E-4/ DATA (P2(I),I=0,4),(Q2(I),I=0,4) 1/-0.89333 84046E+0, 0.11612 96496E+0, 0.12000 82940E+0, 2 0.21856 99725E-1, 0.21288 92058E-2, 3 1.0 , 0.49355 31886E+0, 0.10663 47067E+0, 4 0.12501 61833E-1, 0.54942 43254E-3/ DATA (P3(I),I=0,4),(Q3(I),I=0,4) 1/-0.89333 22067E+0, 0.23395 44896E+0, 0.82576 53222E-1, 2 0.14112 26998E-1, 0.28922 40953E-3, 3 1.0 , 0.36165 38408E+0, 0.66280 26743E-1, 4 0.48392 98984E-2, 0.52483 10361E-4/ DATA (P4(I),I=0,3),(Q4(I),I=0,3) 1/ 0.93584 19425E+0, 0.67168 31438E+2,-0.67650 69077E+3, 2 0.90266 61865E+3, 3 1.0 , 0.77525 62854E+2,-0.56378 11998E+3, 4 -0.55131 56752E+3/ DATA (P5(I),I=0,3),(Q5(I),I=0,3) 1/ 0.94893 35583E+0, 0.55612 46706E+3, 0.32082 74617E+5, 2 -0.48899 26524E+5, 3 1.0 , 0.60282 75940E+3, 0.37169 62017E+5, 4 0.36862 72898E+5/ DATA (A0(I),I=0,5) 1/-0.42278 43351E+0,-0.15443 13298E+0, 0.42278 43351E+0, 2 0.32764 96874E+1, 0.20434 03138E+1,-0.86812 96500E+1/ DATA (A1(I),I=1,3) 1/-0.45833 33333E+0, 0.66753 47222E+0,-0.16417 41416E+1/ DATA (A2(I),I=1,4) 1/-0.19583 33333E+1, 0.55633 68056E+1,-0.21113 52961E+2, 2 0.10069 46266E+3/ V=X IF(V .LT. -4.5D0) THEN U=EXP(V+1.0) LANXM1=V-U*(1.0D0+(A2(1)+(A2(2)+(A2(3)+A2(4)*U)*U)*U)*U)/ 1 (1.0D0+(A1(1)+(A1(2)+A1(3)*U)*U)*U) ELSEIF(V .LT. -2.0D0) THEN LANXM1=(P1(0)+(P1(1)+(P1(2)+(P1(3)+P1(4)*V)*V)*V)*V)/ 1 (Q1(0)+(Q1(1)+(Q1(2)+(Q1(3)+Q1(4)*V)*V)*V)*V) ELSEIF(V .LT. 2.0D0) THEN LANXM1=(P2(0)+(P2(1)+(P2(2)+(P2(3)+P2(4)*V)*V)*V)*V)/ 1 (Q2(0)+(Q2(1)+(Q2(2)+(Q2(3)+Q2(4)*V)*V)*V)*V) ELSEIF(V .LT. 10.0D0) THEN LANXM1=(P3(0)+(P3(1)+(P3(2)+(P3(3)+P3(4)*V)*V)*V)*V)/ 1 (Q3(0)+(Q3(1)+(Q3(2)+(Q3(3)+Q3(4)*V)*V)*V)*V) ELSEIF(V .LT. 40.0D0) THEN U=1.0D0/V LANXM1=LOG(V)*(P4(0)+(P4(1)+(P4(2)+P4(3)*U)*U)*U)/ 1 (Q4(0)+(Q4(1)+(Q4(2)+Q4(3)*U)*U)*U) ELSEIF(V .LT. 200.0D0) THEN U=1.0D0/V LANXM1=LOG(V)*(P5(0)+(P5(1)+(P5(2)+P5(3)*U)*U)*U)/ 1 (Q5(0)+(Q5(1)+(Q5(2)+Q5(3)*U)*U)*U) ELSE U=V-V*LOG(V)/(V+1.0D0) V=1.0D0/(U-U*(U+LOG(U)-V)/(U+1.0D0)) U=-LOG(V) LANXM1= 1 (U+A0(0)+(-U+A0(1)+(A0(2)*U+A0(3)+(A0(4)*U+A0(5))*V)*V)*V) 1 /(1.0D0-(1.0D0-(A0(2)+A0(4)*V)*V)*V) ENDIF RETURN END DOUBLE PRECISION FUNCTION LANXM2(X) * From Cernlib, renam XM2LAN to LANXM2 * $Id: xm2lan.F,v 1.1.1.1 1996/04/01 15:02:45 mclareni Exp $ * * $Log: xm2lan.F,v $ * Revision 1.1.1.1 1996/04/01 15:02:45 mclareni * Mathlib gen * * IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION P1(0:4),P2(0:4),P3(0:3),P4(0:4),P5(0:3) DIMENSION Q1(0:4),Q2(0:4),Q3(0:3),Q4(0:4),Q5(0:3) DIMENSION A0(0:6),A1(1:3),A2(0:3),A3(0:3) DATA (P1(I),I=0,4),(Q1(I),I=0,4) 1/ 0.11698 37582E+1,-0.48348 74539E+0, 0.43837 74644E+0, 2 0.32871 75228E-2, 0.18791 29206E-1, 3 1.0 , 0.17951 54326E+0, 0.46127 95899E-1, 4 0.21834 59337E-2, 0.72266 23623E-4/ DATA (P2(I),I=0,4),(Q2(I),I=0,4) 1/ 0.11579 39823E+1,-0.38428 09495E+0, 0.33175 32899E+0, 2 0.35476 06781E-1, 0.67256 45279E-2, 3 1.0 , 0.29168 24021E+0, 0.52598 53480E-1, 4 0.38400 11061E-2, 0.99503 24173E-4/ DATA (P3(I),I=0,3),(Q3(I),I=0,3) 1/ 0.11781 91282E+1, 0.10116 23342E+2,-0.12855 85291E+2, 2 0.36413 61437E+2, 3 1.0 , 0.86141 60194E+1, 0.31189 29630E+2, 4 0.15143 51300E+0/ DATA (P4(I),I=0,4),(Q4(I),I=0,4) 1/ 0.10307 63698E+1, 0.12167 58660E+3, 0.16374 31386E+4, 2 -0.21714 66507E+4, 0.70101 68358E+4, 3 1.0 , 0.10224 87911E+3, 0.13776 46350E+4, 4 0.36991 84961E+4, 0.42513 15610E+4/ DATA (P5(I),I=0,3),(Q5(I),I=0,3) 1/ 0.10100 84827E+1, 0.39442 24824E+3, 0.17730 25353E+5, 2 -0.70759 63938E+5, 3 1.0 , 0.36059 50254E+3, 0.13927 84158E+5, 4 -0.18816 80027E+5/ DATA (A0(I),I=0,6) 1/-0.20434 03138E+1,-0.84556 86702E+0,-0.30886 26596E+0, 2 0.58213 46754E+1, 0.42278 43351E+0, 0.65529 93748E+1, 3 -0.10767 14945E+2/ DATA (A1(I),I=1,3) 1/-0.45833 33333E+0, 0.66753 47222E+0,-0.16417 41416E+1/ DATA (A2(I),I=0,3) 1/-0.19583 33333E+1, 0.55633 68056E+1,-0.21113 52961E+2, 2 0.10069 46266E+3/ DATA (A3(I),I=0,3) 1/-1.0 , 0.44583 33333E+1,-0.21167 53472E+2, 2 0.11636 74359E+3/ V=X IF(V .LT. -4.5D0) THEN U=EXP(V+1.0D0) LANXM2=V**2-2.0D0*U**2* 1 (V/U+A2(0)*V+A3(0)+(A2(1)*V+A3(1)+(A2(2)*V+A3(2)+ 2 (A2(3)*V+A3(3))*U)*U)*U)/ 3 (1.0D0+(A1(1)+(A1(2)+A1(3)*U)*U)*U) ELSEIF(V .LT. -2.0D0) THEN LANXM2=(P1(0)+(P1(1)+(P1(2)+(P1(3)+P1(4)*V)*V)*V)*V)/ 1 (Q1(0)+(Q1(1)+(Q1(2)+(Q1(3)+Q1(4)*V)*V)*V)*V) ELSEIF(V .LT. 2.0D0) THEN LANXM2=(P2(0)+(P2(1)+(P2(2)+(P2(3)+P2(4)*V)*V)*V)*V)/ 1 (Q2(0)+(Q2(1)+(Q2(2)+(Q2(3)+Q2(4)*V)*V)*V)*V) ELSEIF(V .LT. 5.0D0) THEN U=1.0D0/V LANXM2=V*(P3(0)+(P3(1)+(P3(2)+P3(3)*U)*U)*U)/ 1 (Q3(0)+(Q3(1)+(Q3(2)+Q3(3)*U)*U)*U) ELSEIF(V .LT. 50.0D0) THEN U=1.0D0/V LANXM2=V*(P4(0)+(P4(1)+(P4(2)+(P4(3)+P4(4)*U)*U)*U)*U)/ 1 (Q4(0)+(Q4(1)+(Q4(2)+(Q4(3)+Q4(4)*U)*U)*U)*U) ELSEIF(V .LT. 200.0D0) THEN U=1.0D0/V LANXM2=V*(P5(0)+(P5(1)+(P5(2)+P5(3)*U)*U)*U)/ 1 (Q5(0)+(Q5(1)+(Q5(2)+Q5(3)*U)*U)*U) ELSE U=V-V*LOG(V)/(V+1.0D0) V=1.0D0/(U-U*(U+LOG(U)-V)/(U+1.0D0)) U=-LOG(V) LANXM2=(1.0D0/V+U**2+A0(0)+A0(1)*U+(-U**2+A0(2)*U+A0(3)+ 1 (A0(4)*U**2+A0(5)*U+A0(6))*V)*V)/(1.0D0-(1.0D0-A0(4)*V)*V) ENDIF RETURN END Function lcmrnd(ix) C C THIS FUNCTION USED BY THE "R250" RANDOM NUMBER GENERATOR C C The minimal standard PRNG for 31 bit unsigned integers C designed with automatic overflow protection C uses ix as the seed value if it is greater than zero C otherwise it is ignored Integer*4 ix Integer*4 a, b, m, q, r Integer*4 hi, lo, test Integer*4 x SAVE x Parameter (a = 16807, b = 0, m = 2147483647) Parameter (q = 127773, r = 2836) C If ( ix .gt. 0 ) x = ix C hi = x / q lo = mod( x, q ) test = a * lo - r * hi if ( test .gt. 0 ) then x = test else x = test + m endif C lcmrnd = x C return End SUBROUTINE LATCON(IA,IWIDTH,IB,IWIDT2,MAXWID,ISUBRO,IERROR) C C PURPOSE--CONVERT DATAPLOT SPECIAL CHARACTERS (E.G., GREEK C CHARACTERS, SUBSCRIPTS, SUPERSCRIPTS, MATH SYMBOLS) C FROM DATAPLOT CODING TO COMPARABLE LATEX CODING. C C INPUT ARGUMENTS--IA = INITIAL CHARACTER STRING C IWIDTH = NUMBER OF CHARACTERS IN IA C ISUBRO = BUG TRACE VARIABLE C OUTPUT ARGUMENTS--IB = OUTPUT CHARACTER STRING C IWIDT2 = NUMBER OF CHARACTERS IN IB C IERROR = HOLLERITH VARIABLE C C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-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/2 C ORIGINAL VERSION--FEBRUARY 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*(*) IA CHARACTER*(*) IB C CHARACTER*4 ICASFL CHARACTER*4 IBASLC C CHARACTER*4 ISUBRO CHARACTER*4 IERROR C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IF(ISUBRO.EQ.'ON')THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF LATCON--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IWIDTH,MAXWID,ISUBRO,IERROR 52 FORMAT('IWIDTH,MAXWID,ISUBRO,IERROR = ',I8,2X,I8,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)(IA(I:I),I=1,MIN(100,IWIDTH)) 53 FORMAT('(IA(I),I=1,IWIDTH) = ',100A1) CALL DPWRST('XXX','BUG ') ENDIF C IBASLC=CHAR(92) C C ***************************************************** C ** THE FOLLOWING CODE WILL SEARCH FOR DATAPLOT'S ** C ** SPECIAL CHARACTER CODES AND CONVERT THEM TO ** C ** EQUIVALENT LATEX CODES. ** C ***************************************************** C C C UC() = UPPER CASE C LC() = LOWER CASE C MU() = GREEK MU C NU() = GREEK NU C XI() = GREEK XI C PI() = GREEK PI C LT() = LESS THAN C GT() = GREATER THAN C +-() = + OR - C -+() = - OR + C SP() = SPACE C SUB() = ENTER SUBSCRIPT MODE C SUP() = ENTER SUPERSCRIPT MODE C ETA() = GREEK ETA C RHO() = GREEK RHO C TAU() = GREEK TAU C PHI() = GREEK PHI C CHI() = GREEK CHI C PSI() = GREEK PSI C DEL() = VECTOR PRODUCT C UNSB() = LEAVE SUBSCRIPT MODE C UNSP() = LEAVE SUPERSCRIPT MODE C ALPH() = GREEK ALPHA C BETA() = GREEK BETA C GAMM() = GREEK GAMMA C DELT() = GREEK DELTA C EPSI() = GREEK EPSILON C ZETA() = GREEK ZETA C THET() = GREEK THETA C IOTA() = GREEK IOTA C KAPP() = GREEK KAPPA C LAMB() = GREEK LAMBDA C OMIC() = GREEK OMICON C SIGM() = GREEK SIGMA C UPSI() = GREEK UPSILON C OMEG() = GREEK OMEGA C PART() = PARTIAL DERIVATIVE C INTE() = INTEGRAL C CINT() = CIRCULAR INTEGRAL C SUMM() = SUMMATION C PROD() = PRODUCT C INFI() = INFINITY C TIME() = TIMES C DOTP() = DOT PRODUCT C DIVI() = DIVISION C LTEQ() = LESS THAN OR EQUAL TO C GTEQ() = GREATER THAN OR EQUAL TO C NOT=() = NOT EQUAL C APPR() = APPROXIMATELY EQUAL TO C EQUI() = EQUIVALENCE C VARI() = VARIES C TILD() = TILDE C CARA() = CARAT C PRIM() = PRIME C RADI() = RADICAL C LRAD() = LARGE RADICAL C SUBS() = SUBSET C SUPE() = SUPERSET C UNIO() = UNION C INTR() = INTERSECTION C ELEM() = IS AN ELEMENT OF C THEX() = THERE EXISTS C THFO() = THEREFORE C LAPO() = LEFT APOSTROPHE C RAPO() = RIGHT APOSTROPHE C LBRA() = LEFT BRACKET C RBRA() = RIGHT BRACKET C LCBR() = LEFT CURLY BRACKET C RCBR() = RIGHT CURLY BRACKET C LELB() = LEFT ELBOW C RELB() = RIGHT ELBOW C LACC() = LEFT ACCENT C BREV() = BREVE C RQUO() = RIGHT QUOTE C LQUO() = LEFT QUOTE C NASP() = NORMAL ASPIRATE (NOT CURRENTLY SUPPORTED) C IASP() = INVERTED ASPIRATE (NOT CURRENTLY SUPPORTED) C RARR() = RIGHT ARROW C LARR() = LEFT ARROW C UARR() = UP ARROW C DARR() = DOWN ARROW C PARA() = PARAGRAPH C DAGG() = DAGGER C DDAG() = DOUBLE DAGGER C VBAR() = VERTICAL BAR C DVBA() = DOUBLE VERTICAL BAR C LVBA() = LONG VERTICAL BAR C HBAR() = HORIZONTAL BAR C LHBA() = LONG HORIZONTAL BAR C DEGR() = DEGREE C IWIDT2=0 IB(1:MAXWID)=' ' ICASFL='UPPE' ISUBFL=0 ISUPFL=0 NSKIP=0 C IF(IWIDTH.GE.4)THEN NTEMP=IWIDTH-3 DO100I=1,NTEMP C IF(ISUBRO.EQ.'TCON')THEN WRITE(ICOUT,151)I,IWIDT2,NSKIP,IA(I:I) 151 FORMAT('I,IWIDT2,NSKIP,IA(I:I) = ',3I8,A1) CALL DPWRST('XXX','BUG ') ENDIF C IF(NSKIP.GT.0)THEN NSKIP=NSKIP-1 GOTO100 ENDIF C C SET UPPER CASE FLAG C IF((IA(I:I).EQ.'U'.OR.IA(I:I).EQ.'u') .AND. 1 (IA(I+1:I+1).EQ.'C'.OR.IA(I+1:I+1).EQ.'c') .AND. 1 IA(I+2:I+2).EQ.'(' .AND. IA(I+3:I+3).EQ.')')THEN ICASFL='UPPE' NSKIP=3 C C SET LOWER CASE FLAG C ELSEIF((IA(I:I).EQ.'L'.OR.IA(I:I).EQ.'l') .AND. 1 (IA(I+1:I+1).EQ.'C'.OR.IA(I+1:I+1).EQ.'c') .AND. 1 IA(I+2:I+2).EQ.'(' .AND. IA(I+3:I+3).EQ.')')THEN ICASFL='UPPE' NSKIP=3 C C SET SPACE C ELSEIF((IA(I:I).EQ.'S'.OR.IA(I:I).EQ.'s') .AND. 1 (IA(I+1:I+1).EQ.'P'.OR.IA(I+1:I+1).EQ.'p') .AND. 1 IA(I+2:I+2).EQ.'(' .AND. IA(I+3:I+3).EQ.')')THEN IWIDT2=IWIDT2+1 IB(IWIDT2:IWIDT2)=' ' NSKIP=3 C C SET GREEK MU = $\mu$ C ELSEIF((IA(I:I).EQ.'M'.OR.IA(I:I).EQ.'m') .AND. 1 (IA(I+1:I+1).EQ.'U'.OR.IA(I+1:I+1).EQ.'u') .AND. 1 IA(I+2:I+2).EQ.'(' .AND. IA(I+3:I+3).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+4 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='$ mu$' IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+4 NSKIP=3 C C SET GREEK NU = $\nu$ C ELSEIF((IA(I:I).EQ.'N'.OR.IA(I:I).EQ.'n') .AND. 1 (IA(I+1:I+1).EQ.'U'.OR.IA(I+1:I+1).EQ.'u') .AND. 1 IA(I+2:I+2).EQ.'(' .AND. IA(I+3:I+3).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+4 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='$ nu$' IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+4 NSKIP=3 C C SET GREEK XI = $\xi$ OR $\XI$ C ELSEIF((IA(I:I).EQ.'X'.OR.IA(I:I).EQ.'x') .AND. 1 (IA(I+1:I+1).EQ.'i'.OR.IA(I+1:I+1).EQ.'i') .AND. 1 IA(I+2:I+2).EQ.'(' .AND. IA(I+3:I+3).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+4 IF(NLAST.GT.MAXWID)GOTO8010 IF(ICASFL.EQ.'UPPE')THEN IB(IWIDT2:NLAST)='$ Xi$' ELSE IB(IWIDT2:NLAST)='$ xi$' ENDIF IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+4 NSKIP=3 C C SET GREEK PI = $\pi$ OR $\PI$ C ELSEIF((IA(I:I).EQ.'P'.OR.IA(I:I).EQ.'p') .AND. 1 (IA(I+1:I+1).EQ.'I'.OR.IA(I+1:I+1).EQ.'i') .AND. 1 IA(I+2:I+2).EQ.'(' .AND. IA(I+3:I+3).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+4 IF(NLAST.GT.MAXWID)GOTO8010 IF(ICASFL.EQ.'UPPE')THEN IB(IWIDT2:NLAST)='$ Pi$' ELSE IB(IWIDT2:NLAST)='$ pi$' ENDIF IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+4 NSKIP=3 C C SET LESS THAN = < C ELSEIF((IA(I:I).EQ.'L'.OR.IA(I:I).EQ.'L') .AND. 1 (IA(I+1:I+1).EQ.'T'.OR.IA(I+1:I+1).EQ.'t') .AND. 1 IA(I+2:I+2).EQ.'(' .AND. IA(I+3:I+3).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='<' NSKIP=3 C C SET GREATER THAN = > C ELSEIF((IA(I:I).EQ.'G'.OR.IA(I:I).EQ.'g') .AND. 1 (IA(I+1:I+1).EQ.'T'.OR.IA(I+1:I+1).EQ.'t') .AND. 1 IA(I+2:I+2).EQ.'(' .AND. IA(I+3:I+3).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='>' NSKIP=3 C C SET +/- = $\pm$ C ELSEIF(IA(I:I).EQ.'+' .AND. IA(I+1:I+1).EQ.'-' .AND. 1 IA(I+2:I+2).EQ.'(' .AND. IA(I+3:I+3).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+4 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='$ pm$' IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+4 NSKIP=3 C C SET -/+ = $\mp$ C ELSEIF(IA(I:I).EQ.'-' .AND. IA(I+1:I+1).EQ.'+' .AND. 1 IA(I+2:I+2).EQ.'(' .AND. IA(I+3:I+3).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+4 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='$ mp$' IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+4 NSKIP=3 C C SET SUBSCRIPT MODE = $_{ C ELSEIF(I.LE.IWIDTH-4.AND. 1 (IA(I:I).EQ.'S'.OR.IA(I:I).EQ.'s') .AND. 1 (IA(I+1:I+1).EQ.'U'.OR.IA(I+1:I+1).EQ.'u') .AND. 1 (IA(I+2:I+2).EQ.'B'.OR.IA(I+2:I+2).EQ.'b') .AND. 1 IA(I+3:I+3).EQ.'(' .AND. IA(I+4:I+4).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+2 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='$_{' IWIDT2=IWIDT2+2 ISUBFL=ISUBFL+1 NSKIP=4 C C SET SUPERSCRIPT MODE = $^{ C ELSEIF(I.LE.IWIDTH-4.AND. 1 (IA(I:I).EQ.'S'.OR.IA(I:I).EQ.'s') .AND. 1 (IA(I+1:I+1).EQ.'U'.OR.IA(I+1:I+1).EQ.'u') .AND. 1 (IA(I+2:I+2).EQ.'P'.OR.IA(I+2:I+2).EQ.'p') .AND. 1 IA(I+3:I+3).EQ.'(' .AND. IA(I+4:I+4).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+2 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='$^{' IWIDT2=IWIDT2+2 ISUPFL=ISUPFL+1 NSKIP=4 C C SET GREEK ETA = $\eta$ C ELSEIF(I.LE.IWIDTH-4.AND. 1 (IA(I:I).EQ.'E'.OR.IA(I:I).EQ.'e') .AND. 1 (IA(I+1:I+1).EQ.'T'.OR.IA(I+1:I+1).EQ.'t') .AND. 1 (IA(I+2:I+2).EQ.'A'.OR.IA(I+2:I+2).EQ.'a') .AND. 1 IA(I+3:I+3).EQ.'(' .AND. IA(I+4:I+4).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+5 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='$ eta$' IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+5 NSKIP=4 C C SET GREEK RHO = $\rho$ C ELSEIF(I.LE.IWIDTH-4.AND. 1 (IA(I:I).EQ.'R'.OR.IA(I:I).EQ.'r') .AND. 1 (IA(I+1:I+1).EQ.'H'.OR.IA(I+1:I+1).EQ.'h') .AND. 1 (IA(I+2:I+2).EQ.'O'.OR.IA(I+2:I+2).EQ.'o') .AND. 1 IA(I+3:I+3).EQ.'(' .AND. IA(I+4:I+4).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+5 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='$ rho$' IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+5 NSKIP=4 C C SET GREEK TAU = $\tau$ C ELSEIF(I.LE.IWIDTH-4.AND. 1 (IA(I:I).EQ.'T'.OR.IA(I:I).EQ.'t') .AND. 1 (IA(I+1:I+1).EQ.'A'.OR.IA(I+1:I+1).EQ.'a') .AND. 1 (IA(I+2:I+2).EQ.'U'.OR.IA(I+2:I+2).EQ.'u') .AND. 1 IA(I+3:I+3).EQ.'(' .AND. IA(I+4:I+4).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+5 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='$ tau$' IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+5 NSKIP=4 C C SET GREEK PHI = $\phi$ or $\Ph$} C ELSEIF(I.LE.IWIDTH-4.AND. 1 (IA(I:I).EQ.'P'.OR.IA(I:I).EQ.'p') .AND. 1 (IA(I+1:I+1).EQ.'H'.OR.IA(I+1:I+1).EQ.'h') .AND. 1 (IA(I+2:I+2).EQ.'I'.OR.IA(I+2:I+2).EQ.'i') .AND. 1 IA(I+3:I+3).EQ.'(' .AND. IA(I+4:I+4).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+5 IF(NLAST.GT.MAXWID)GOTO8010 IF(ICASFL.EQ.'UPPE')THEN IB(IWIDT2:NLAST)='$ Phi$' ELSE IB(IWIDT2:NLAST)='$ phi$' ENDIF IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+5 NSKIP=4 C C SET GREEK CHI = $\chi$ C ELSEIF(I.LE.IWIDTH-4.AND. 1 (IA(I:I).EQ.'P'.OR.IA(I:I).EQ.'p') .AND. 1 (IA(I+1:I+1).EQ.'H'.OR.IA(I+1:I+1).EQ.'h') .AND. 1 (IA(I+2:I+2).EQ.'I'.OR.IA(I+2:I+2).EQ.'i') .AND. 1 IA(I+3:I+3).EQ.'(' .AND. IA(I+4:I+4).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+5 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='$ chi$' IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+5 NSKIP=4 C C SET GREEK PSI = $\psi$ or $\Psi$ C ELSEIF(I.LE.IWIDTH-4.AND. 1 (IA(I:I).EQ.'P'.OR.IA(I:I).EQ.'p') .AND. 1 (IA(I+1:I+1).EQ.'S'.OR.IA(I+1:I+1).EQ.'s') .AND. 1 (IA(I+2:I+2).EQ.'I'.OR.IA(I+2:I+2).EQ.'i') .AND. 1 IA(I+3:I+3).EQ.'(' .AND. IA(I+4:I+4).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+5 IF(NLAST.GT.MAXWID)GOTO8010 IF(ICASFL.EQ.'UPPE')THEN IB(IWIDT2:NLAST)='$ Psi$' ELSE IB(IWIDT2:NLAST)='$ psi$' ENDIF IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+5 NSKIP=4 C C SET VECTOR PRODUCT = I DON'T KNOW IF THERE IS A LATEX C EQUIVALENT C CCCCC ELSEIF((IA(I:I).EQ.'D'.OR.IA(I:I).EQ.'d') .AND. CCCCC1 (IA(I+1:I+1).EQ.'E'.OR.IA(I+1:I+1).EQ.'e') .AND. CCCCC1 (IA(I+2:I+2).EQ.'L'.OR.IA(I+2:I+2).EQ.'l') .AND. CCCCC1 IA(I+3:I+3).EQ.'(' .AND. IA(I+4:I+4).EQ.')')THEN CCCCC IWIDT2=IWIDT2+1 CCCCC NLAST=IWIDT2+5 CCCCC IF(NLAST.GT.MAXWID)GOTO8010 CCCCC IB(IWIDT2:NLAST)='$ chi$' CCCCC IB(IWIDT2+1:IWIDT2+1)=IBASLC CCCCC IWIDT2=IWIDT2+5 CCCCC NSKIP=4 C C SET UNSUBSCRIPT MODE = }$ C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'U'.OR.IA(I:I).EQ.'u') .AND. 1 (IA(I+1:I+1).EQ.'N'.OR.IA(I+1:I+1).EQ.'n') .AND. 1 (IA(I+2:I+2).EQ.'S'.OR.IA(I+2:I+2).EQ.'s') .AND. 1 (IA(I+3:I+3).EQ.'B'.OR.IA(I+3:I+3).EQ.'b') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+1 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='}$' IWIDT2=IWIDT2+1 ISUBFL=ISUBFL-1 NSKIP=5 C C SET UNSUPERSCRIPT MODE = }$ C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'U'.OR.IA(I:I).EQ.'u') .AND. 1 (IA(I+1:I+1).EQ.'N'.OR.IA(I+1:I+1).EQ.'n') .AND. 1 (IA(I+2:I+2).EQ.'S'.OR.IA(I+2:I+2).EQ.'s') .AND. 1 (IA(I+3:I+3).EQ.'P'.OR.IA(I+3:I+3).EQ.'p') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+1 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='}$' IWIDT2=IWIDT2+1 ISUPFL=ISUPFL-1 NSKIP=5 C C SET GREEK ALPHA = $\alpha$ C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'A'.OR.IA(I:I).EQ.'a') .AND. 1 (IA(I+1:I+1).EQ.'L'.OR.IA(I+1:I+1).EQ.'l') .AND. 1 (IA(I+2:I+2).EQ.'P'.OR.IA(I+2:I+2).EQ.'p') .AND. 1 (IA(I+3:I+3).EQ.'H'.OR.IA(I+3:I+3).EQ.'h') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+7 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='$ alpha$' IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+7 NSKIP=5 C C SET GREEK BETA = $\beta$ C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'B'.OR.IA(I:I).EQ.'b') .AND. 1 (IA(I+1:I+1).EQ.'E'.OR.IA(I+1:I+1).EQ.'e') .AND. 1 (IA(I+2:I+2).EQ.'T'.OR.IA(I+2:I+2).EQ.'t') .AND. 1 (IA(I+3:I+3).EQ.'A'.OR.IA(I+3:I+3).EQ.'a') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+6 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='$ beta$' IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+6 NSKIP=5 C C SET GREEK GAMMA = $\gamma$ or $\Gamma$ C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'G'.OR.IA(I:I).EQ.'g') .AND. 1 (IA(I+1:I+1).EQ.'A'.OR.IA(I+1:I+1).EQ.'a') .AND. 1 (IA(I+2:I+2).EQ.'M'.OR.IA(I+2:I+2).EQ.'m') .AND. 1 (IA(I+3:I+3).EQ.'M'.OR.IA(I+3:I+3).EQ.'m') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+7 IF(NLAST.GT.MAXWID)GOTO8010 IF(ICASFL.EQ.'UPPE')THEN IB(IWIDT2:NLAST)='$ Gamma$' ELSE IB(IWIDT2:NLAST)='$ gamma$' ENDIF IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+7 NSKIP=5 C C SET GREEK DELTA = $\delta$ or $\Delta$ C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'D'.OR.IA(I:I).EQ.'d') .AND. 1 (IA(I+1:I+1).EQ.'E'.OR.IA(I+1:I+1).EQ.'e') .AND. 1 (IA(I+2:I+2).EQ.'L'.OR.IA(I+2:I+2).EQ.'l') .AND. 1 (IA(I+3:I+3).EQ.'T'.OR.IA(I+3:I+3).EQ.'t') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+7 IF(NLAST.GT.MAXWID)GOTO8010 IF(ICASFL.EQ.'UPPE')THEN IB(IWIDT2:NLAST)='$ Delta$' ELSE IB(IWIDT2:NLAST)='$ delta$' ENDIF IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+7 NSKIP=5 C C SET GREEK EPSILON = $\epsilon$ C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'E'.OR.IA(I:I).EQ.'e') .AND. 1 (IA(I+1:I+1).EQ.'P'.OR.IA(I+1:I+1).EQ.'p') .AND. 1 (IA(I+2:I+2).EQ.'S'.OR.IA(I+2:I+2).EQ.'s') .AND. 1 (IA(I+3:I+3).EQ.'I'.OR.IA(I+3:I+3).EQ.'i') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+9 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='$ epsilon$' IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+9 NSKIP=5 C C SET GREEK ZETA = $\zeta$ C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'Z'.OR.IA(I:I).EQ.'z') .AND. 1 (IA(I+1:I+1).EQ.'E'.OR.IA(I+1:I+1).EQ.'e') .AND. 1 (IA(I+2:I+2).EQ.'T'.OR.IA(I+2:I+2).EQ.'t') .AND. 1 (IA(I+3:I+3).EQ.'A'.OR.IA(I+3:I+3).EQ.'a') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+6 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='$ zeta$' IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+6 NSKIP=5 C C SET GREEK THETA = $\theta$ or $\Theta$ C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'T'.OR.IA(I:I).EQ.'t') .AND. 1 (IA(I+1:I+1).EQ.'H'.OR.IA(I+1:I+1).EQ.'h') .AND. 1 (IA(I+2:I+2).EQ.'E'.OR.IA(I+2:I+2).EQ.'e') .AND. 1 (IA(I+3:I+3).EQ.'T'.OR.IA(I+3:I+3).EQ.'t') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+7 IF(NLAST.GT.MAXWID)GOTO8010 IF(ICASFL.EQ.'UPPE')THEN IB(IWIDT2:NLAST)='$ Theta$' ELSE IB(IWIDT2:NLAST)='$ theta$' ENDIF IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+7 NSKIP=5 C C SET GREEK IOTA = $\iota$ C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'I'.OR.IA(I:I).EQ.'i') .AND. 1 (IA(I+1:I+1).EQ.'O'.OR.IA(I+1:I+1).EQ.'o') .AND. 1 (IA(I+2:I+2).EQ.'T'.OR.IA(I+2:I+2).EQ.'t') .AND. 1 (IA(I+3:I+3).EQ.'A'.OR.IA(I+3:I+3).EQ.'a') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+6 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='$ iota$' IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+6 NSKIP=5 C C SET GREEK KAPPA = $\kappa$ C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'K'.OR.IA(I:I).EQ.'k') .AND. 1 (IA(I+1:I+1).EQ.'A'.OR.IA(I+1:I+1).EQ.'a') .AND. 1 (IA(I+2:I+2).EQ.'P'.OR.IA(I+2:I+2).EQ.'p') .AND. 1 (IA(I+3:I+3).EQ.'P'.OR.IA(I+3:I+3).EQ.'p') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+7 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='$ kappa$' IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+7 NSKIP=5 C C SET GREEK LAMBDA = $\lambda$ or $\Lambda$ C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'L'.OR.IA(I:I).EQ.'l') .AND. 1 (IA(I+1:I+1).EQ.'A'.OR.IA(I+1:I+1).EQ.'a') .AND. 1 (IA(I+2:I+2).EQ.'M'.OR.IA(I+2:I+2).EQ.'m') .AND. 1 (IA(I+3:I+3).EQ.'B'.OR.IA(I+3:I+3).EQ.'b') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+8 IF(NLAST.GT.MAXWID)GOTO8010 IF(ICASFL.EQ.'UPPE')THEN IB(IWIDT2:NLAST)='$ Lambda$' ELSE IB(IWIDT2:NLAST)='$ lambda$' ENDIF IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+8 NSKIP=5 C C SET GREEK OMICON = $\omicon$ C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'O'.OR.IA(I:I).EQ.'o') .AND. 1 (IA(I+1:I+1).EQ.'M'.OR.IA(I+1:I+1).EQ.'m') .AND. 1 (IA(I+2:I+2).EQ.'I'.OR.IA(I+2:I+2).EQ.'i') .AND. 1 (IA(I+3:I+3).EQ.'C'.OR.IA(I+3:I+3).EQ.'c') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+8 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='$ omicon$' IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+8 NSKIP=5 C C SET GREEK SIGMA = $\sigma$ or $\Sigma$ C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'S'.OR.IA(I:I).EQ.'s') .AND. 1 (IA(I+1:I+1).EQ.'I'.OR.IA(I+1:I+1).EQ.'i') .AND. 1 (IA(I+2:I+2).EQ.'G'.OR.IA(I+2:I+2).EQ.'g') .AND. 1 (IA(I+3:I+3).EQ.'M'.OR.IA(I+3:I+3).EQ.'m') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+7 IF(NLAST.GT.MAXWID)GOTO8010 IF(ICASFL.EQ.'UPPE')THEN IB(IWIDT2:NLAST)='$ Sigma$' ELSE IB(IWIDT2:NLAST)='$ sigma$' ENDIF IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+7 NSKIP=5 C C SET GREEK UPSILON = $\upsilon$ or $\Upsilon$ C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'U'.OR.IA(I:I).EQ.'u') .AND. 1 (IA(I+1:I+1).EQ.'P'.OR.IA(I+1:I+1).EQ.'p') .AND. 1 (IA(I+2:I+2).EQ.'S'.OR.IA(I+2:I+2).EQ.'s') .AND. 1 (IA(I+3:I+3).EQ.'I'.OR.IA(I+3:I+3).EQ.'i') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+10 IF(NLAST.GT.MAXWID)GOTO8010 IF(ICASFL.EQ.'UPPE')THEN IB(IWIDT2:NLAST)='$ Upsilon$' ELSE IB(IWIDT2:NLAST)='$ upsilon$' ENDIF IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+10 NSKIP=5 C C SET GREEK OMEGA = $\omega$ or $\Omega$ C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'O'.OR.IA(I:I).EQ.'o') .AND. 1 (IA(I+1:I+1).EQ.'M'.OR.IA(I+1:I+1).EQ.'m') .AND. 1 (IA(I+2:I+2).EQ.'E'.OR.IA(I+2:I+2).EQ.'e') .AND. 1 (IA(I+3:I+3).EQ.'G'.OR.IA(I+3:I+3).EQ.'g') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+7 IF(NLAST.GT.MAXWID)GOTO8010 IF(ICASFL.EQ.'UPPE')THEN IB(IWIDT2:NLAST)='$ Omega$' ELSE IB(IWIDT2:NLAST)='$ omega$' ENDIF IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+7 NSKIP=5 C C SET PARTIAL DERIVATIVE = $\partial$ C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'P'.OR.IA(I:I).EQ.'p') .AND. 1 (IA(I+1:I+1).EQ.'A'.OR.IA(I+1:I+1).EQ.'a') .AND. 1 (IA(I+2:I+2).EQ.'R'.OR.IA(I+2:I+2).EQ.'r') .AND. 1 (IA(I+3:I+3).EQ.'T'.OR.IA(I+3:I+3).EQ.'t') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+9 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='$ partial$' IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+9 NSKIP=5 C C SET INTEGRAL = $\int$ C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'I'.OR.IA(I:I).EQ.'i') .AND. 1 (IA(I+1:I+1).EQ.'N'.OR.IA(I+1:I+1).EQ.'n') .AND. 1 (IA(I+2:I+2).EQ.'T'.OR.IA(I+2:I+2).EQ.'t') .AND. 1 (IA(I+3:I+3).EQ.'E'.OR.IA(I+3:I+3).EQ.'e') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+5 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='$ int$' IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+5 NSKIP=5 C C SET CIRCULAR INTEGRAL = $\oint$ C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'C'.OR.IA(I:I).EQ.'c') .AND. 1 (IA(I+1:I+1).EQ.'I'.OR.IA(I+1:I+1).EQ.'i') .AND. 1 (IA(I+2:I+2).EQ.'N'.OR.IA(I+2:I+2).EQ.'n') .AND. 1 (IA(I+3:I+3).EQ.'T'.OR.IA(I+3:I+3).EQ.'t') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+6 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='$ oint$' IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+6 NSKIP=5 C C SET SUMMATION = $\sum$ C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'S'.OR.IA(I:I).EQ.'s') .AND. 1 (IA(I+1:I+1).EQ.'U'.OR.IA(I+1:I+1).EQ.'u') .AND. 1 (IA(I+2:I+2).EQ.'M'.OR.IA(I+2:I+2).EQ.'m') .AND. 1 (IA(I+3:I+3).EQ.'M'.OR.IA(I+3:I+3).EQ.'m') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+5 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='$ sum$' IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+5 NSKIP=5 C C SET PRODUCT = $\prod$ C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'P'.OR.IA(I:I).EQ.'p') .AND. 1 (IA(I+1:I+1).EQ.'R'.OR.IA(I+1:I+1).EQ.'r') .AND. 1 (IA(I+2:I+2).EQ.'O'.OR.IA(I+2:I+2).EQ.'o') .AND. 1 (IA(I+3:I+3).EQ.'D'.OR.IA(I+3:I+3).EQ.'d') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+6 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='$ prod$' IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+6 NSKIP=5 C C SET INFINITY = $\infty$ C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'I'.OR.IA(I:I).EQ.'i') .AND. 1 (IA(I+1:I+1).EQ.'N'.OR.IA(I+1:I+1).EQ.'n') .AND. 1 (IA(I+2:I+2).EQ.'F'.OR.IA(I+2:I+2).EQ.'f') .AND. 1 (IA(I+3:I+3).EQ.'I'.OR.IA(I+3:I+3).EQ.'i') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+7 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='$ infty$' IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+7 NSKIP=5 C C SET TIMES = $\times$ C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'T'.OR.IA(I:I).EQ.'t') .AND. 1 (IA(I+1:I+1).EQ.'I'.OR.IA(I+1:I+1).EQ.'i') .AND. 1 (IA(I+2:I+2).EQ.'M'.OR.IA(I+2:I+2).EQ.'m') .AND. 1 (IA(I+3:I+3).EQ.'E'.OR.IA(I+3:I+3).EQ.'e') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+7 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='$ times$' IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+7 NSKIP=5 C C SET DOT PRODUCT = $\cdot$ C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'D'.OR.IA(I:I).EQ.'d') .AND. 1 (IA(I+1:I+1).EQ.'O'.OR.IA(I+1:I+1).EQ.'o') .AND. 1 (IA(I+2:I+2).EQ.'T'.OR.IA(I+2:I+2).EQ.'t') .AND. 1 (IA(I+3:I+3).EQ.'P'.OR.IA(I+3:I+3).EQ.'p') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+6 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='$ cdot$' IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+6 NSKIP=5 C C SET DIVISION = $\div$ C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'D'.OR.IA(I:I).EQ.'d') .AND. 1 (IA(I+1:I+1).EQ.'I'.OR.IA(I+1:I+1).EQ.'i') .AND. 1 (IA(I+2:I+2).EQ.'V'.OR.IA(I+2:I+2).EQ.'v') .AND. 1 (IA(I+3:I+3).EQ.'I'.OR.IA(I+3:I+3).EQ.'i') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+5 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='$ div$' IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+5 NSKIP=5 C C SET LESS THAN OR EQUAL TO = $\le$ C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'L'.OR.IA(I:I).EQ.'l') .AND. 1 (IA(I+1:I+1).EQ.'T'.OR.IA(I+1:I+1).EQ.'t') .AND. 1 (IA(I+2:I+2).EQ.'E'.OR.IA(I+2:I+2).EQ.'e') .AND. 1 (IA(I+3:I+3).EQ.'Q'.OR.IA(I+3:I+3).EQ.'q') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+4 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='$ le$' IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+4 NSKIP=5 C C SET GREATER THAN OR EQUAL TO = $\ge$ C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'G'.OR.IA(I:I).EQ.'g') .AND. 1 (IA(I+1:I+1).EQ.'T'.OR.IA(I+1:I+1).EQ.'t') .AND. 1 (IA(I+2:I+2).EQ.'E'.OR.IA(I+2:I+2).EQ.'e') .AND. 1 (IA(I+3:I+3).EQ.'Q'.OR.IA(I+3:I+3).EQ.'q') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+4 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='$ ge$' IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+4 NSKIP=5 C C SET GREATER THAN OR EQUAL TO = $\ge$ C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'G'.OR.IA(I:I).EQ.'g') .AND. 1 (IA(I+1:I+1).EQ.'T'.OR.IA(I+1:I+1).EQ.'t') .AND. 1 (IA(I+2:I+2).EQ.'E'.OR.IA(I+2:I+2).EQ.'e') .AND. 1 (IA(I+3:I+3).EQ.'Q'.OR.IA(I+3:I+3).EQ.'q') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+4 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='$ ge$' IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+4 NSKIP=5 C C SET NOT EQUAL TO = $\ne$ C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'N'.OR.IA(I:I).EQ.'n') .AND. 1 (IA(I+1:I+1).EQ.'O'.OR.IA(I+1:I+1).EQ.'o') .AND. 1 (IA(I+2:I+2).EQ.'T'.OR.IA(I+2:I+2).EQ.'t') .AND. 1 (IA(I+3:I+3).EQ.'='.OR.IA(I+3:I+3).EQ.'=') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+4 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='$ ne$' IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+4 NSKIP=5 C C SET APPROXIMATELY = $\approx$ C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'A'.OR.IA(I:I).EQ.'a') .AND. 1 (IA(I+1:I+1).EQ.'P'.OR.IA(I+1:I+1).EQ.'p') .AND. 1 (IA(I+2:I+2).EQ.'P'.OR.IA(I+2:I+2).EQ.'p') .AND. 1 (IA(I+3:I+3).EQ.'R'.OR.IA(I+3:I+3).EQ.'r') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+8 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='$ approx$' IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+8 NSKIP=5 C C SET EQUIVALENCE = $\equiv$ C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'E'.OR.IA(I:I).EQ.'e') .AND. 1 (IA(I+1:I+1).EQ.'Q'.OR.IA(I+1:I+1).EQ.'q') .AND. 1 (IA(I+2:I+2).EQ.'U'.OR.IA(I+2:I+2).EQ.'u') .AND. 1 (IA(I+3:I+3).EQ.'I'.OR.IA(I+3:I+3).EQ.'i') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+7 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='$ equiv$' IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+7 NSKIP=5 C C SET VARIES = I DON'T KNOW HOW TO DO THIS ONE C CCCCC ELSEIF((IA(I:I).EQ.'E'.OR.IA(I:I).EQ.'e') .AND. CCCCC1 (IA(I+1:I+1).EQ.'Q'.OR.IA(I+1:I+1).EQ.'q') .AND. CCCCC1 (IA(I+2:I+2).EQ.'U'.OR.IA(I+2:I+2).EQ.'u') .AND. CCCCC1 (IA(I+3:I+3).EQ.'I'.OR.IA(I+3:I+3).EQ.'i') .AND. CCCCC1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN CCCCC IWIDT2=IWIDT2+1 CCCCC NLAST=IWIDT2+7 CCCCC IF(NLAST.GT.MAXWID)GOTO8010 CCCCC IB(IWIDT2:NLAST)='$ equiv$' CCCCC IB(IWIDT2+1:IWIDT2+1)=IBASLC CCCCC IWIDT2=IWIDT2+7 CCCCC NSKIP=5 C C SET TILDE = ~ C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'T'.OR.IA(I:I).EQ.'t') .AND. 1 (IA(I+1:I+1).EQ.'I'.OR.IA(I+1:I+1).EQ.'i') .AND. 1 (IA(I+2:I+2).EQ.'L'.OR.IA(I+2:I+2).EQ.'l') .AND. 1 (IA(I+3:I+3).EQ.'D'.OR.IA(I+3:I+3).EQ.'d') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='~' NSKIP=5 C C SET CARAT = ^ C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'C'.OR.IA(I:I).EQ.'c') .AND. 1 (IA(I+1:I+1).EQ.'A'.OR.IA(I+1:I+1).EQ.'a') .AND. 1 (IA(I+2:I+2).EQ.'R'.OR.IA(I+2:I+2).EQ.'r') .AND. 1 (IA(I+3:I+3).EQ.'A'.OR.IA(I+3:I+3).EQ.'a') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='^' NSKIP=5 C C SET RADICAL = $\sqrt$ C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'R'.OR.IA(I:I).EQ.'r') .AND. 1 (IA(I+1:I+1).EQ.'A'.OR.IA(I+1:I+1).EQ.'a') .AND. 1 (IA(I+2:I+2).EQ.'D'.OR.IA(I+2:I+2).EQ.'d') .AND. 1 (IA(I+3:I+3).EQ.'I'.OR.IA(I+3:I+3).EQ.'i') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+6 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='$ sqrt$' IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+6 NSKIP=5 C C SET LARGE RADICAL = $\sqrt$ C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'L'.OR.IA(I:I).EQ.'l') .AND. 1 (IA(I+1:I+1).EQ.'R'.OR.IA(I+1:I+1).EQ.'r') .AND. 1 (IA(I+2:I+2).EQ.'A'.OR.IA(I+2:I+2).EQ.'a') .AND. 1 (IA(I+3:I+3).EQ.'D'.OR.IA(I+3:I+3).EQ.'d') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+6 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='$ sqrt$' IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+6 NSKIP=5 C C SET SUBSET = $\subset$ C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'S'.OR.IA(I:I).EQ.'s') .AND. 1 (IA(I+1:I+1).EQ.'U'.OR.IA(I+1:I+1).EQ.'u') .AND. 1 (IA(I+2:I+2).EQ.'B'.OR.IA(I+2:I+2).EQ.'b') .AND. 1 (IA(I+3:I+3).EQ.'S'.OR.IA(I+3:I+3).EQ.'s') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+8 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='$ subset$' IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+8 NSKIP=5 C C SET SUPERSET = $\supset$ C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'S'.OR.IA(I:I).EQ.'s') .AND. 1 (IA(I+1:I+1).EQ.'U'.OR.IA(I+1:I+1).EQ.'u') .AND. 1 (IA(I+2:I+2).EQ.'P'.OR.IA(I+2:I+2).EQ.'p') .AND. 1 (IA(I+3:I+3).EQ.'E'.OR.IA(I+3:I+3).EQ.'e') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+8 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='$ supset$' IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+8 NSKIP=5 C C SET UNION = $\cup$ C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'U'.OR.IA(I:I).EQ.'u') .AND. 1 (IA(I+1:I+1).EQ.'N'.OR.IA(I+1:I+1).EQ.'n') .AND. 1 (IA(I+2:I+2).EQ.'I'.OR.IA(I+2:I+2).EQ.'i') .AND. 1 (IA(I+3:I+3).EQ.'O'.OR.IA(I+3:I+3).EQ.'o') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+5 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='$ cup$' IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+5 NSKIP=5 C C SET INTERSECTION = $\cap$ C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'I'.OR.IA(I:I).EQ.'i') .AND. 1 (IA(I+1:I+1).EQ.'N'.OR.IA(I+1:I+1).EQ.'n') .AND. 1 (IA(I+2:I+2).EQ.'T'.OR.IA(I+2:I+2).EQ.'t') .AND. 1 (IA(I+3:I+3).EQ.'R'.OR.IA(I+3:I+3).EQ.'r') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+5 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='$ cap$' IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+5 NSKIP=5 C C SET IS AN ELEMENT OF = $\in$ C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'E'.OR.IA(I:I).EQ.'e') .AND. 1 (IA(I+1:I+1).EQ.'L'.OR.IA(I+1:I+1).EQ.'l') .AND. 1 (IA(I+2:I+2).EQ.'E'.OR.IA(I+2:I+2).EQ.'e') .AND. 1 (IA(I+3:I+3).EQ.'M'.OR.IA(I+3:I+3).EQ.'m') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+4 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='$ in$' IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+4 NSKIP=5 C C SET THERE EXISTS = $\exists$ C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'T'.OR.IA(I:I).EQ.'t') .AND. 1 (IA(I+1:I+1).EQ.'H'.OR.IA(I+1:I+1).EQ.'h') .AND. 1 (IA(I+2:I+2).EQ.'E'.OR.IA(I+2:I+2).EQ.'e') .AND. 1 (IA(I+3:I+3).EQ.'X'.OR.IA(I+3:I+3).EQ.'x') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+8 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='$ exists$' IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+8 NSKIP=5 C C SET THEREFORE = I DON'T KNOW WHAT THIS SHOULD BE C CCCCC ELSEIF((IA(I:I).EQ.'T'.OR.IA(I:I).EQ.'t') .AND. CCCCC1 (IA(I+1:I+1).EQ.'H'.OR.IA(I+1:I+1).EQ.'h') .AND. CCCCC1 (IA(I+2:I+2).EQ.'E'.OR.IA(I+2:I+2).EQ.'e') .AND. CCCCC1 (IA(I+3:I+3).EQ.'X'.OR.IA(I+3:I+3).EQ.'x') .AND. CCCCC1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN CCCCC IWIDT2=IWIDT2+1 CCCCC NLAST=IWIDT2+8 CCCCC IF(NLAST.GT.MAXWID)GOTO8010 CCCCC IB(IWIDT2:NLAST)='$ exists$' CCCCC IB(IWIDT2+1:IWIDT2+1)=IBASLC CCCCC IWIDT2=IWIDT2+8 CCCCC NSKIP=5 C C SET LEFT APOSTROPHE = ` C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'L'.OR.IA(I:I).EQ.'l') .AND. 1 (IA(I+1:I+1).EQ.'A'.OR.IA(I+1:I+1).EQ.'a') .AND. 1 (IA(I+2:I+2).EQ.'P'.OR.IA(I+2:I+2).EQ.'p') .AND. 1 (IA(I+3:I+3).EQ.'O'.OR.IA(I+3:I+3).EQ.'o') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='`' NSKIP=5 C C SET RIGHT APOSTROPHE = ' C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'R'.OR.IA(I:I).EQ.'r') .AND. 1 (IA(I+1:I+1).EQ.'A'.OR.IA(I+1:I+1).EQ.'a') .AND. 1 (IA(I+2:I+2).EQ.'P'.OR.IA(I+2:I+2).EQ.'p') .AND. 1 (IA(I+3:I+3).EQ.'O'.OR.IA(I+3:I+3).EQ.'o') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)="`" NSKIP=5 C C SET LEFT BRACKET = [ C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'L'.OR.IA(I:I).EQ.'l') .AND. 1 (IA(I+1:I+1).EQ.'B'.OR.IA(I+1:I+1).EQ.'b') .AND. 1 (IA(I+2:I+2).EQ.'R'.OR.IA(I+2:I+2).EQ.'r') .AND. 1 (IA(I+3:I+3).EQ.'A'.OR.IA(I+3:I+3).EQ.'a') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='[' NSKIP=5 C C SET LEFT CURLY BRACKET = { C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'L'.OR.IA(I:I).EQ.'l') .AND. 1 (IA(I+1:I+1).EQ.'C'.OR.IA(I+1:I+1).EQ.'c') .AND. 1 (IA(I+2:I+2).EQ.'B'.OR.IA(I+2:I+2).EQ.'b') .AND. 1 (IA(I+3:I+3).EQ.'R'.OR.IA(I+3:I+3).EQ.'r') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='{' NSKIP=5 C C SET RIGHT CURLY BRACKET = } C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'R'.OR.IA(I:I).EQ.'r') .AND. 1 (IA(I+1:I+1).EQ.'C'.OR.IA(I+1:I+1).EQ.'c') .AND. 1 (IA(I+2:I+2).EQ.'B'.OR.IA(I+2:I+2).EQ.'b') .AND. 1 (IA(I+3:I+3).EQ.'R'.OR.IA(I+3:I+3).EQ.'r') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='}' NSKIP=5 C C SET RIGHT BRACKET = ] C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'R'.OR.IA(I:I).EQ.'r') .AND. 1 (IA(I+1:I+1).EQ.'B'.OR.IA(I+1:I+1).EQ.'b') .AND. 1 (IA(I+2:I+2).EQ.'R'.OR.IA(I+2:I+2).EQ.'r') .AND. 1 (IA(I+3:I+3).EQ.'A'.OR.IA(I+3:I+3).EQ.'a') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)=']' NSKIP=5 C C SET LEFT ELBOW = I DON'T KNOW HOW TO DO THIS ONE C CCCCC ELSEIF((IA(I:I).EQ.'L'.OR.IA(I:I).EQ.'l') .AND. CCCCC1 (IA(I+1:I+1).EQ.'E'.OR.IA(I+1:I+1).EQ.'e') .AND. CCCCC1 (IA(I+2:I+2).EQ.'L'.OR.IA(I+2:I+2).EQ.'l') .AND. CCCCC1 (IA(I+3:I+3).EQ.'B'.OR.IA(I+3:I+3).EQ.'b') .AND. CCCCC1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN CCCCC IWIDT2=IWIDT2+1 CCCCC NLAST=IWIDT2+8 CCCCC IF(NLAST.GT.MAXWID)GOTO8010 CCCCC IB(IWIDT2:NLAST)='$ exists$' CCCCC IB(IWIDT2+1:IWIDT2+1)=IBASLC CCCCC IWIDT2=IWIDT2+8 CCCCC NSKIP=5 C C SET RIGHT ELBOW = I DON'T KNOW HOW TO DO THIS ONE C CCCCC ELSEIF((IA(I:I).EQ.'R'.OR.IA(I:I).EQ.'r') .AND. CCCCC1 (IA(I+1:I+1).EQ.'E'.OR.IA(I+1:I+1).EQ.'e') .AND. CCCCC1 (IA(I+2:I+2).EQ.'L'.OR.IA(I+2:I+2).EQ.'l') .AND. CCCCC1 (IA(I+3:I+3).EQ.'B'.OR.IA(I+3:I+3).EQ.'b') .AND. CCCCC1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN CCCCC IWIDT2=IWIDT2+1 CCCCC NLAST=IWIDT2+8 CCCCC IF(NLAST.GT.MAXWID)GOTO8010 CCCCC IB(IWIDT2:NLAST)='$ exists$' CCCCC IB(IWIDT2+1:IWIDT2+1)=IBASLC CCCCC IWIDT2=IWIDT2+8 CCCCC NSKIP=5 C C SET LEFT ACCENT = $\`$ C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'L'.OR.IA(I:I).EQ.'l') .AND. 1 (IA(I+1:I+1).EQ.'A'.OR.IA(I+1:I+1).EQ.'a') .AND. 1 (IA(I+2:I+2).EQ.'C'.OR.IA(I+2:I+2).EQ.'c') .AND. 1 (IA(I+3:I+3).EQ.'C'.OR.IA(I+3:I+3).EQ.'c') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+4 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='$ `$' IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+4 NSKIP=5 C C SET BREVE = $\vee$ C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'B'.OR.IA(I:I).EQ.'b') .AND. 1 (IA(I+1:I+1).EQ.'R'.OR.IA(I+1:I+1).EQ.'r') .AND. 1 (IA(I+2:I+2).EQ.'E'.OR.IA(I+2:I+2).EQ.'e') .AND. 1 (IA(I+3:I+3).EQ.'V'.OR.IA(I+3:I+3).EQ.'v') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+5 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='$ vee$' IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+5 NSKIP=5 C C SET LEFT QUOTE = " C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'L'.OR.IA(I:I).EQ.'l') .AND. 1 (IA(I+1:I+1).EQ.'Q'.OR.IA(I+1:I+1).EQ.'q') .AND. 1 (IA(I+2:I+2).EQ.'U'.OR.IA(I+2:I+2).EQ.'u') .AND. 1 (IA(I+3:I+3).EQ.'O'.OR.IA(I+3:I+3).EQ.'o') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='"' NSKIP=5 C C SET RIGHT QUOTE = " C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'R'.OR.IA(I:I).EQ.'r') .AND. 1 (IA(I+1:I+1).EQ.'Q'.OR.IA(I+1:I+1).EQ.'q') .AND. 1 (IA(I+2:I+2).EQ.'U'.OR.IA(I+2:I+2).EQ.'u') .AND. 1 (IA(I+3:I+3).EQ.'O'.OR.IA(I+3:I+3).EQ.'o') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='"' NSKIP=5 C C SET RIGHT ARROW = $\rightarrow$ C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'R'.OR.IA(I:I).EQ.'r') .AND. 1 (IA(I+1:I+1).EQ.'A'.OR.IA(I+1:I+1).EQ.'a') .AND. 1 (IA(I+2:I+2).EQ.'R'.OR.IA(I+2:I+2).EQ.'r') .AND. 1 (IA(I+3:I+3).EQ.'R'.OR.IA(I+3:I+3).EQ.'r') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+12 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='$ rightarrow$' IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+12 NSKIP=5 C C SET LEFT ARROW = $\leftarrow$ C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'L'.OR.IA(I:I).EQ.'l') .AND. 1 (IA(I+1:I+1).EQ.'A'.OR.IA(I+1:I+1).EQ.'a') .AND. 1 (IA(I+2:I+2).EQ.'R'.OR.IA(I+2:I+2).EQ.'r') .AND. 1 (IA(I+3:I+3).EQ.'R'.OR.IA(I+3:I+3).EQ.'r') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+11 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='$ leftarrow$' IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+11 NSKIP=5 C C SET DOWN ARROW = $\downarrow$ C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'D'.OR.IA(I:I).EQ.'d') .AND. 1 (IA(I+1:I+1).EQ.'A'.OR.IA(I+1:I+1).EQ.'a') .AND. 1 (IA(I+2:I+2).EQ.'R'.OR.IA(I+2:I+2).EQ.'r') .AND. 1 (IA(I+3:I+3).EQ.'R'.OR.IA(I+3:I+3).EQ.'r') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+11 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='$ downarrow$' IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+11 NSKIP=5 C C SET UP ARROW = $\uparrow$ C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'U'.OR.IA(I:I).EQ.'u') .AND. 1 (IA(I+1:I+1).EQ.'A'.OR.IA(I+1:I+1).EQ.'a') .AND. 1 (IA(I+2:I+2).EQ.'R'.OR.IA(I+2:I+2).EQ.'r') .AND. 1 (IA(I+3:I+3).EQ.'R'.OR.IA(I+3:I+3).EQ.'r') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+9 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='$ uparrow$' IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+9 NSKIP=5 C C SET PARAGRAP = NOT SURE ABOUT THIS ONE C CCCCC ELSEIF((IA(I:I).EQ.'U'.OR.IA(I:I).EQ.'u') .AND. CCCCC1 (IA(I+1:I+1).EQ.'A'.OR.IA(I+1:I+1).EQ.'a') .AND. CCCCC1 (IA(I+2:I+2).EQ.'R'.OR.IA(I+2:I+2).EQ.'r') .AND. CCCCC1 (IA(I+3:I+3).EQ.'R'.OR.IA(I+3:I+3).EQ.'r') .AND. CCCCC1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN CCCCC IWIDT2=IWIDT2+1 CCCCC NLAST=IWIDT2+9 CCCCC IF(NLAST.GT.MAXWID)GOTO8010 CCCCC IB(IWIDT2:NLAST)='$ uparrow$' CCCCC IB(IWIDT2+1:IWIDT2+1)=IBASLC CCCCC IWIDT2=IWIDT2+9 CCCCC NSKIP=5 C C SET DAGGER = $\dagger$ C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'D'.OR.IA(I:I).EQ.'d') .AND. 1 (IA(I+1:I+1).EQ.'A'.OR.IA(I+1:I+1).EQ.'a') .AND. 1 (IA(I+2:I+2).EQ.'G'.OR.IA(I+2:I+2).EQ.'g') .AND. 1 (IA(I+3:I+3).EQ.'G'.OR.IA(I+3:I+3).EQ.'g') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+8 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='$ dagger$' IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+8 NSKIP=5 C C SET DOUBLE DAGGER = $\ddagger$ C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'D'.OR.IA(I:I).EQ.'d') .AND. 1 (IA(I+1:I+1).EQ.'D'.OR.IA(I+1:I+1).EQ.'d') .AND. 1 (IA(I+2:I+2).EQ.'A'.OR.IA(I+2:I+2).EQ.'a') .AND. 1 (IA(I+3:I+3).EQ.'G'.OR.IA(I+3:I+3).EQ.'g') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+9 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='$ ddagger$' IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+9 NSKIP=5 C C SET VERTICAL BAR = $\mid$ C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'V'.OR.IA(I:I).EQ.'v') .AND. 1 (IA(I+1:I+1).EQ.'B'.OR.IA(I+1:I+1).EQ.'b') .AND. 1 (IA(I+2:I+2).EQ.'A'.OR.IA(I+2:I+2).EQ.'a') .AND. 1 (IA(I+3:I+3).EQ.'R'.OR.IA(I+3:I+3).EQ.'r') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+5 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='$ mid$' IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+5 NSKIP=5 C C SET LONG VERTICAL BAR = $\mid$ C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'L'.OR.IA(I:I).EQ.'l') .AND. 1 (IA(I+1:I+1).EQ.'V'.OR.IA(I+1:I+1).EQ.'v') .AND. 1 (IA(I+2:I+2).EQ.'B'.OR.IA(I+2:I+2).EQ.'b') .AND. 1 (IA(I+3:I+3).EQ.'A'.OR.IA(I+3:I+3).EQ.'a') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+5 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='$ mid$' IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+5 NSKIP=5 C C SET HORIZONTAL BAR = DON'T KNOW HOW TO DO THIS ONE C CCCCC ELSEIF((IA(I:I).EQ.'H'.OR.IA(I:I).EQ.'h') .AND. CCCCC1 (IA(I+1:I+1).EQ.'B'.OR.IA(I+1:I+1).EQ.'b') .AND. CCCCC1 (IA(I+2:I+2).EQ.'A'.OR.IA(I+2:I+2).EQ.'a') .AND. CCCCC1 (IA(I+3:I+3).EQ.'R'.OR.IA(I+3:I+3).EQ.'r') .AND. CCCCC1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN CCCCC IWIDT2=IWIDT2+1 CCCCC NLAST=IWIDT2+5 CCCCC IF(NLAST.GT.MAXWID)GOTO8010 CCCCC IB(IWIDT2:NLAST)='$ mid$' CCCCC IB(IWIDT2+1:IWIDT2+1)=IBASLC CCCCC IWIDT2=IWIDT2+5 CCCCC NSKIP=5 C C SET LONG HORIZONTAL BAR = DON'T KNOW HOW TO DO THIS ONE C CCCCC ELSEIF((IA(I:I).EQ.'L'.OR.IA(I:I).EQ.'l') .AND. CCCCC1 (IA(I+1:I+1).EQ.'H'.OR.IA(I+1:I+1).EQ.'h') .AND. CCCCC1 (IA(I+2:I+2).EQ.'B'.OR.IA(I+2:I+2).EQ.'b') .AND. CCCCC1 (IA(I+3:I+3).EQ.'A'.OR.IA(I+3:I+3).EQ.'a') .AND. CCCCC1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN CCCCC IWIDT2=IWIDT2+1 CCCCC NLAST=IWIDT2+5 CCCCC IF(NLAST.GT.MAXWID)GOTO8010 CCCCC IB(IWIDT2:NLAST)='$ mid$' CCCCC IB(IWIDT2+1:IWIDT2+1)=IBASLC CCCCC IWIDT2=IWIDT2+5 CCCCC NSKIP=5 C C SET DEGREE = $\deg$ C ELSEIF(I.LE.IWIDTH-5.AND. 1 (IA(I:I).EQ.'D'.OR.IA(I:I).EQ.'d') .AND. 1 (IA(I+1:I+1).EQ.'E'.OR.IA(I+1:I+1).EQ.'e') .AND. 1 (IA(I+2:I+2).EQ.'G'.OR.IA(I+2:I+2).EQ.'g') .AND. 1 (IA(I+3:I+3).EQ.'R'.OR.IA(I+3:I+3).EQ.'r') .AND. 1 IA(I+4:I+4).EQ.'(' .AND. IA(I+5:I+5).EQ.')')THEN IWIDT2=IWIDT2+1 NLAST=IWIDT2+5 IF(NLAST.GT.MAXWID)GOTO8010 IB(IWIDT2:NLAST)='$ deg$' IB(IWIDT2+1:IWIDT2+1)=IBASLC IWIDT2=IWIDT2+5 NSKIP=5 ELSE IWIDT2=IWIDT2+1 IB(IWIDT2:IWIDT2)=IA(I:I) ENDIF 100 CONTINUE ELSE DO190I=1,IWIDTH IWIDT2=IWIDT2+1 IB(IWIDT2:IWIDT2)=IA(I:I) 190 CONTINUE GOTO9000 ENDIF C ISTRT=IWIDTH-2 ISTRT=ISTRT+NSKIP IF(ISTRT.LE.IWIDTH)THEN DO200I=ISTRT,IWIDTH IWIDT2=IWIDT2+1 IB(IWIDT2:IWIDT2)=IA(I:I) 200 CONTINUE ENDIF C IF(ISUBFL.GT.0)THEN DO300I=1,ISUBFL IWIDT2=IWIDT2+1 IB(IWIDT2:IWIDT2+1)='}$' IWIDT2=IWIDT2+1 300 CONTINUE ENDIF C IF(ISUPFL.GT.0)THEN DO400I=1,ISUPFL IWIDT2=IWIDT2+1 IB(IWIDT2:IWIDT2+1)='}$' IWIDT2=IWIDT2+1 400 CONTINUE ENDIF C GOTO9000 C 8010 CONTINUE WRITE(ICOUT,8011) 8011 FORMAT('***** ERROR IN CONVERTING DATAPLOT SPECIAL ', 1 'CHARACTERS TO EQUIVALENT LATEX--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8013) 8013 FORMAT(' MAXIMUM NUMBER OF CHARACTERS, ',I5,',', 1 'IN LATEX STRING EXCEEDED.') CALL DPWRST('XXX','BUG ') GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(ISUBRO.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF LATCON--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IWIDTH,ISUBRO,IERROR 9012 FORMAT('IWIDTH,ISUBRO,IERROR = ',I8,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)(IB(I:I),I=1,MIN(100,IWIDT2)) 9014 FORMAT('(IB(I:I),I=1,IWIDT2) = ',100A1) CALL DPWRST('XXX','BUG ') ENDIF C RETURN END SUBROUTINE LBECDF(X,ALPHA,BETA,C,D,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE LOG-BETA DISTRIBUTION. C THE LOG-BETA CDF IS COMPUTED AS: C C LBECDF(X;ALPHA,BETA,C,D) = BETCDF(Z;ALPHA,BETA,C,D) C 0 < C <= X <= D C ALPHA, BETA > 0 C C WHERE C C Z = (LOG(X) - LOG(C)/(LOG(D) - LOG(C)) C C AND BETCDF IS THE BETA CUMULATIVE DISTRIBUTION C FUNCTION. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE C AT WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C X SHOULD BE POSITIVE. C --ALPHA = THE SINGLE PRECISION VALUE OF THE C FIRST SHAPE PARAMETER C --BETA = THE SINGLE PRECISION VALUE OF THE C SECOND SHAPE PARAMETER C --C = THE SINGLE PRECISION VALUE OF THE C THIRD (LOWER LIMIT) SHAPE PARAMETER C --D = THE SINGLE PRECISION VALUE OF THE C FOURTH (UPPER LIMIT) SHAPE PARAMETER C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION C FUNCTION VALUE CDF FOR THE LOG-BETA DISTRIBUTION. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE > C. C OTHER DATAPAC SUBROUTINES NEEDED--BETCDF. C FORTRAN LIBRARY SUBROUTINES NEEDED--LOG. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN. C REFERENCES--NADARAJAH AND GUPTA (2004). "APPLICATIONS OF THE C BETA DISTRIBUTION" in "HANDBOOK OF THE BETA C DISTRIBUTION", EDITED BY GUPTA AND NADARAJAH, C MARCEL-DEKKER, PP.100-102. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-975-2855 C ORIGINAL VERSION--MAY 2006. 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(ALPHA.LE.0.0)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALPHA CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ENDIF 4 FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER (ALPHA) TO ', 1 'THE LBECDF SUBROUTINE IS NON-POSITIVE.') C IF(BETA.LE.0.0)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)BETA CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ENDIF 5 FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER (BETA) TO ', 1 'THE LBECDF SUBROUTINE IS NON-POSITIVE.') C IF(C.LE.0.0)THEN WRITE(ICOUT,6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)C CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ENDIF 6 FORMAT('***** ERROR--THE LOWER LIMIT PARAMETER TO ', 1 'THE LBECDF SUBROUTINE IS NON-POSITIVE.') C IF(X.LE.C)THEN CDF=0.0 CCCCC WRITE(ICOUT,7) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,46)X CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,48)C CCCCC CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 7 FORMAT('***** ERROR--THE FIRST ARGUMENT TO THE LBECDF ', 1 'SUBROUTINE IS LESS THAN THE LOWER LIMIT.') C IF(D.LE.C)THEN WRITE(ICOUT,8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,48)C CALL DPWRST('XXX','BUG ') WRITE(ICOUT,49)D CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ENDIF 8 FORMAT('***** ERROR--THE UPPER LIMIT TO THE LBECDF ', 1 'SUBROUTINE IS LESS THAN THE LOWER LIMIT.') C IF(X.GE.D)THEN CCCCC WRITE(ICOUT,9) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,46)X CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,49)D CCCCC CALL DPWRST('XXX','BUG ') CDF=1.0 GOTO9999 ENDIF 9 FORMAT('***** ERROR--THE FIRST ARGUMENT TO THE LBECDF ', 1 'SUBROUTINE IS GREATER THAN THE UPPER LIMIT.') C 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) 48 FORMAT('***** THE VALUE OF THE LOWER LIMIT IS ',G15.7) 49 FORMAT('***** THE VALUE OF THE UPPER LIMIT IS ',G15.7) C C-----START POINT--------------------------------------------------- C CDF=0.0 Z=(LOG(X) - LOG(C))/(LOG(D) - LOG(C)) CALL BETCDF(Z,ALPHA,BETA,CDF) C 9999 CONTINUE RETURN END SUBROUTINE LBEPDF(X,ALPHA,BETA,C,D,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE LOG-BETA DISTRIBUTION. C THE LOG-BETA PDF IS COMPUTED AS: C C LBEPDF(X;ALPHA,BETA,C,D) = BETPDF(Z;ALPHA,BETA,C,D) C 0 < C <= X <= D C ALPHA, BETA > 0 C C WHERE C C Z = (LOG(X) - LOG(C)/(LOG(D) - LOG(C)) C C AND BETPDF IS THE BETA PROBABILITY DENSITY C FUNCTION. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE C AT WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C X SHOULD BE POSITIVE. 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 --C = THE SINGLE PRECISION VALUE OF THE C THIRD (LOWER LIMIT) SHAPE PARAMETER C --D = THE SINGLE PRECISION VALUE OF THE C FOURTH (UPPER LIMIT) SHAPE PARAMETER C OUTPUT ARGUMENTS--PDF = THE SINGLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY C FUNCTION VALUE PDF FOR THE LOG-BETA DISTRIBUTION. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE > C. C OTHER DATAPAC SUBROUTINES NEEDED--BETPDF. C FORTRAN LIBRARY SUBROUTINES NEEDED--LOG. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN. C REFERENCES--NADARAJAH AND GUPTA (2004). "APPLICATIONS OF THE C BETA DISTRIBUTION" in "HANDBOOK OF THE BETA C DISTRIBUTION", EDITED BY GUPTA AND NADARAJAH, C MARCEL-DEKKER, PP.100-102. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-975-2855 C ORIGINAL VERSION--MAY 2006. 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(ALPHA.LE.0.0)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALPHA CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF 4 FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER (ALPHA) TO ', 1 'THE LBEPDF SUBROUTINE IS NON-POSITIVE.') C IF(BETA.LE.0.0)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)BETA CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF 5 FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER (BETA) TO ', 1 'THE LBEPDF SUBROUTINE IS NON-POSITIVE.') C IF(C.LE.0.0)THEN WRITE(ICOUT,6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)C CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF 6 FORMAT('***** ERROR--THE LOWER LIMIT PARAMETER TO ', 1 'THE LBEPDF SUBROUTINE IS NON-POSITIVE.') C IF(X.LE.C)THEN WRITE(ICOUT,7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') WRITE(ICOUT,48)C CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF 7 FORMAT('***** ERROR--THE FIRST ARGUMENT TO THE LBEPDF ', 1 'SUBROUTINE IS LESS THAN THE LOWER LIMIT.') C IF(D.LE.C)THEN WRITE(ICOUT,8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,48)C CALL DPWRST('XXX','BUG ') WRITE(ICOUT,49)D CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF 8 FORMAT('***** ERROR--THE UPPER LIMIT TO THE LBEPDF ', 1 'SUBROUTINE IS LESS THAN THE LOWER LIMIT.') C IF(X.GE.D)THEN WRITE(ICOUT,9) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') WRITE(ICOUT,49)D CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF 9 FORMAT('***** ERROR--THE FIRST ARGUMENT TO THE LBEPDF ', 1 'SUBROUTINE IS GREATER THAN THE UPPER LIMIT.') C 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) 48 FORMAT('***** THE VALUE OF THE LOWER LIMIT IS ',G15.7) 49 FORMAT('***** THE VALUE OF THE UPPER LIMIT IS ',G15.7) C C-----START POINT--------------------------------------------------- C PDF=0.0 Z=(LOG(X) - LOG(C))/(LOG(D) - LOG(C)) CALL BETPDF(Z,ALPHA,BETA,PDF) PDF=PDF/(X*(LOG(D)-LOG(C))) C 9999 CONTINUE RETURN END SUBROUTINE LBEPPF(P,ALPHA,BETA,C,D,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE LOG-BETA DISTRIBUTION. C THE LOG-BETA PPF IS COMPUTED AS: C C LBEPPF(P;ALPHA,BETA,C,D) = EXP(LOG(C)+ C (LOG(D) - LOG(C))*BETPPF(P;ALPHA,BETA,C,D)) C 0 < C <= X <= D C ALPHA, BETA > 0 C C BETPPF IS THE BETA PERCENT POINT FUNCTION. C INPUT ARGUMENTS--P = THE SINGLE PRECISION VALUE C AT WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. 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 --C = THE SINGLE PRECISION VALUE OF THE C THIRD (LOWER LIMIT) SHAPE PARAMETER C --D = THE SINGLE PRECISION VALUE OF THE C FOURTH (UPPER LIMIT) SHAPE PARAMETER C OUTPUT ARGUMENTS--PPF = THE SINGLE PRECISION PERCENT POINT C FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PERCENT POINT C FUNCTION VALUE CDF FOR THE LOG-BETA DISTRIBUTION. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--0 < P < 1, ALPHA, BETA, C > 0, D > C C OTHER DATAPAC SUBROUTINES NEEDED--BETPPF. C FORTRAN LIBRARY SUBROUTINES NEEDED--EXP. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN. C REFERENCES--NADARAJAH AND GUPTA (2004). "APPLICATIONS OF THE C BETA DISTRIBUTION" in "HANDBOOK OF THE BETA C DISTRIBUTION", EDITED BY GUPTA AND NADARAJAH, C MARCEL-DEKKER, PP.100-102. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-975-2855 C ORIGINAL VERSION--MAY 2006. 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(ALPHA.LE.0.0)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)ALPHA CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF 4 FORMAT('***** ERROR--THE FIRST SHAPE PARAMETER (ALPHA) TO ', 1 'THE LBECDF SUBROUTINE IS NON-POSITIVE.') C IF(BETA.LE.0.0)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)BETA CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF 5 FORMAT('***** ERROR--THE SECOND SHAPE PARAMETER (BETA) TO ', 1 'THE LBECDF SUBROUTINE IS NON-POSITIVE.') C IF(C.LT.0.0)THEN WRITE(ICOUT,6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)C CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF 6 FORMAT('***** ERROR--THE LOWER LIMIT PARAMETER TO ', 1 'THE LBECDF SUBROUTINE IS NON-POSITIVE.') C IF(D.LE.C)THEN WRITE(ICOUT,8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,48)C CALL DPWRST('XXX','BUG ') WRITE(ICOUT,49)D CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF 8 FORMAT('***** ERROR--THE UPPER LIMIT TO THE LBECDF ', 1 'SUBROUTINE IS LESS THAN THE LOWER LIMIT.') C IF(P.LE.0.0 .OR. P.GE.1.0)THEN PPF=0.0 WRITE(ICOUT,7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)P CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 7 FORMAT('***** ERROR--THE FIRST ARGUMENT TO LBECDF ', 1 'IS OUTSIDE THE (0,1) INTERVAL.') C 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) 48 FORMAT('***** THE VALUE OF THE LOWER LIMIT IS ',G15.7) 49 FORMAT('***** THE VALUE OF THE UPPER LIMIT IS ',G15.7) C C-----START POINT--------------------------------------------------- C PPF=0.0 CALL BETPPF(P,ALPHA,BETA,PPF) PPF=EXP(LOG(C) + PPF*(LOG(D)-LOG(C))) C 9999 CONTINUE RETURN END SUBROUTINE LBERAN(N,ALPHA,BETA,C,D,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE LOG-BETA DISTRIBUTION WITH SINGLE PRECISION C SHAPE PARAMETERS ALPHA AND BETA AND LOWER AND UPPER C LIMIT PARAMETERS C AND D. C THE LOG-BETA PDF IS COMPUTED AS: C C LBEPDF(X;ALPHA,BETA,C,D) = BETPDF(Z;ALPHA,BETA,C,D) C 0 < C <= X <= D C ALPHA, BETA > 0 C C WHERE C C Z = (LOG(X) - LOG(C)/(LOG(D) - LOG(C)) C C AND BETPDF IS THE BETA PROBABILITY DENSITY C FUNCTION. C C LIKEWISE, LOG-BETA RANDOM NUMBERS ARE GENERATED C BY APPLYING THE APPROPRIATE TRANSFORMATION TO C BETA RANDOM NUMBERS. C 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 --C = THE SINGLE PRECISION VALUE OF THE C THIRD (LOWER LIMIT) SHAPE PARAMETER C --D = THE SINGLE PRECISION VALUE OF THE C FOURTH (UPPER LIMIT) 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 LOG-BETA DISTRIBUTION C WITH SHAPE PARAMETER VALUES ALPHA, BETA, C, AND D. 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 > 0 C --BETA > 0 C --C > 0 C --D > C C OTHER DATAPAC SUBROUTINES NEEDED--BETRAN. C FORTRAN LIBRARY SUBROUTINES NEEDED--LOG. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--NADARAJAH AND GUPTA (2004). "APPLICATIONS OF THE C BETA DISTRIBUTION" in "HANDBOOK OF THE BETA C DISTRIBUTION", EDITED BY GUPTA AND NADARAJAH, C MARCEL-DEKKER, PP.100-102. 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 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 DIMENSION X(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)THEN WRITE(ICOUT, 5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF LOG-BETA ', 1' RANDOM NUMBERS IS NON-POSITIVE *****') C IF(ALPHA.LE.0.0)THEN WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALPHA CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 11 FORMAT('***** ERROR--THE ALPHA SHAPE PARAMETER ', 1 'FOR LOG-BETA RANDOM NUMBERS IS NON-POSITIVE.') C IF(BETA.LE.0.0)THEN WRITE(ICOUT,12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)BETA CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 12 FORMAT('***** ERROR--THE BETA SHAPE PARAMETER ', 1 'FOR LOG-BETA RANDOM NUMBERS IS NON-POSITIVE.') C IF(C.LE.0.0)THEN WRITE(ICOUT,13) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)C CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 13 FORMAT('***** ERROR--THE LOWER LIMIT PARAMETER C ', 1 'FOR LOG-BETA RANDOM NUMBERS IS NON-POSITIVE.') C IF(D.LE.C)THEN WRITE(ICOUT,16) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)C CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)D CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 16 FORMAT('***** ERROR--THE UPPER LIMIT PARAMETER D ', 1 'FOR LOG-BETA RANDOM NUMBERS IS NON-POSITIVE.') C 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) C CALL BETRAN(N,ALPHA,BETA,ISEED,X) DO100I=1,N X(I)=EXP(LOG(C) + (LOG(D)-LOG(C))*X(I)) 100 CONTINUE C 9000 CONTINUE RETURN END SUBROUTINE LCTCDF(X,N,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE LEADS IN COIN TOSSING C DISTRIBUTION ON THE INTERVAL (0,N). C THIS DISTRIBUTION HAS MEAN = N/2 C AND STANDARD DEVIATION = SQRT(N(N+1)/8) C THIS DISTRIBUTION HAS THE PROBABILITY C MASS FUNCTION: C C P(X;N) = (2*X)!(2*N-2*X)!*2**(-2*N)/ C X!*X!*(N-X)!*(N-X)! C X = 0, 1, ..., N C C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C N = THE INTEGER VALUE THAT SPECIFIES C THE MAXIMUM VALUE C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION C FUNCTION VALUE CDF. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE BETWEEN 0 AND N, 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 274-275. 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 DOUBLE PRECISION DX DOUBLE PRECISION DN DOUBLE PRECISION DNUM DOUBLE PRECISION DENOM DOUBLE PRECISION DPDF DOUBLE PRECISION DCDF 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 CDF=0.0 C IF(N.LT.0)THEN WRITE(ICOUT,12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)N CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 12 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1 'LCTCDF SUBROUTINE IS LESS THAN 0.') C IX=INT(X+0.5) IF(IX.LT.0 .OR. IX.GT.N)THEN WRITE(ICOUT,2) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)IX CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 2 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE ', 1 'LCTCDF SUBROUTINE IS OUTSIDE THE (0,N) INTERVAL') C 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) C C-----START POINT----------------------------------------------------- C DN=DBLE(N) C DCDF=0.0D0 DO100I=0,IX DX=DBLE(I) DNUM=DLNGAM(2.0D0*DX+1) + DLNGAM(2.0D0*DN-2.0D0*DX+1) 1 -2.0D0*DN*DLOG(2.0D0) DENOM=2.0D0*(DLNGAM(DX+1.0D0) + DLNGAM(DN-DX+1)) DPDF=DEXP(DNUM-DENOM) DCDF=DCDF + DPDF 100 CONTINUE CDF=REAL(DCDF) C 9000 CONTINUE RETURN END SUBROUTINE LCTPDF(X,N,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE LEADS IN COIN TOSSING C DISTRIBUTION ON THE INTERVAL (0,N). C THIS DISTRIBUTION HAS MEAN = N/2 C AND STANDARD DEVIATION = SQRT(N(N+1)/8) C THIS DISTRIBUTION HAS THE PROBABILITY C MASS FUNCTION: C C P(X;N) = (2*X)!(2*N-2*X)!*2**(-2*N)/ C X!*X!*(N-X)!*(N-X)! C X = 0, 1, ..., N C C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C N = THE INTEGER VALUE THAT SPECIFIES C THE MAXIMUM VALUE 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 N, 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 274-275. 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 DOUBLE PRECISION DX DOUBLE PRECISION DN DOUBLE PRECISION DNUM DOUBLE PRECISION DENOM 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(N.LT.0)THEN WRITE(ICOUT,12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)N CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 12 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1 'LCTPDF SUBROUTINE IS LESS THAN 0.') C IX=INT(X+0.5) IF(IX.LT.0 .OR. IX.GT.N)THEN WRITE(ICOUT,2) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)IX CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 2 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE ', 1 'LCTPDF SUBROUTINE IS OUTSIDE THE (0,N) INTERVAL') C 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) C C-----START POINT----------------------------------------------------- C DX=DBLE(IX) DN=DBLE(N) DNUM=DLNGAM(2.0D0*DX+1) + DLNGAM(2.0D0*DN-2.0D0*DX+1) 1 -2.0D0*DN*DLOG(2.0D0) DENOM=2.0D0*(DLNGAM(DX+1.0D0) + DLNGAM(DN-DX+1)) DPDF=DEXP(DNUM-DENOM) PDF=REAL(DPDF) C 9000 CONTINUE RETURN END SUBROUTINE LCTPPF(P,N,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE LEADS IN COIN TOSSING C DISTRIBUTION ON THE INTERVAL (0,N). C THIS DISTRIBUTION HAS MEAN = N/2 C AND STANDARD DEVIATION = SQRT(N(N+1)/8) C THIS DISTRIBUTION HAS THE PROBABILITY C MASS FUNCTION: C C P(X;N) = (2*X)!(2*N-2*X)!*2**(-2*N)/ C X!*X!*(N-X)!*(N-X)! C X = 0, 1, ..., N C C INPUT ARGUMENTS--P = THE SINGLE PRECISION VALUE AT C WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. C N = THE INTEGER VALUE THAT SPECIFIES C THE MAXIMUM VALUE C OUTPUT ARGUMENTS--PPF = THE SINGLE PRECISION PERCENT POINT C 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--0 <= P <= 1 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 274-275. 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 DOUBLE PRECISION DP DOUBLE PRECISION DX DOUBLE PRECISION DN DOUBLE PRECISION DNUM DOUBLE PRECISION DENOM DOUBLE PRECISION DPDF DOUBLE PRECISION DCDF DOUBLE PRECISION DPPF 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 PPF=0.0 C IF(N.LT.0)THEN WRITE(ICOUT,12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)N CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 12 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1 'LCTPPF SUBROUTINE IS LESS THAN 0.') C IF(P.LT.0.0 .OR. P.GT.1.0)THEN WRITE(ICOUT,2) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)P CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 2 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO ', 1 'LCTPPF IS OUTSIDE THE (0,1) INTERVAL') C 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) C C-----START POINT----------------------------------------------------- C C P = 0 AND P = 1 CASES C IF(P.LE.0.0)THEN PPF=0.0 GOTO9000 ELSEIF(P.GE.1.0)THEN PPF=REAL(N) GOTO9000 ENDIF C DP=DBLE(P) DN=DBLE(N) C DCDF=0.0D0 DO100I=0,N DX=DBLE(I) DNUM=DLNGAM(2.0D0*DX+1) + DLNGAM(2.0D0*DN-2.0D0*DX+1) 1 -2.0D0*DN*DLOG(2.0D0) DENOM=2.0D0*(DLNGAM(DX+1.0D0) + DLNGAM(DN-DX+1)) DPDF=DEXP(DNUM-DENOM) DCDF=DCDF + DPDF C IF(DCDF.GE.DP)THEN PPF=REAL(I) GOTO9000 ENDIF C 100 CONTINUE C PPF=REAL(N) GOTO9000 C 9000 CONTINUE RETURN END SUBROUTINE LCTRAN(N,NPAR,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE LEADS IN COIN TOSSING DISTRIBUTION C WITH SHAPE PARAMETERS NPAR. C THIS DISTRIBUTION IS DEFINED FOR C NON-NEGATIVE INTEGERS IN THE RANGE 0 TO NPAR. C THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION C C P(X;N) = (2*X)!(2*N-2*X)!*2**(-2*N)/ C X!*X!*(N-X)!*(N-X)! C X = 0, 1, ..., N C C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --NPAR = THE INTEGER VALUE C OF 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 LEADS IN COIN TOSSING DISTRIBUTION C WITH SHAPE PARAMETERS N AND NPAR. 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 --NPAR > 0 C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN, LCTPPF 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. 242-244. 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 INTEGER N INTEGER NPAR DIMENSION X(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)THEN WRITE(ICOUT, 5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF C IF(NPAR.LE.0.0)THEN WRITE(ICOUT,12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)NPAR CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF ', 1'LEADS IN COIN TOSSING RANDOM NUMBERS IS NON-POSITIVE') 12 FORMAT('***** ERROR--THE NPAR PARAMETER FOR THE ', 1'LEADS IN COIN TOSSING RANDOM NUMBERS IS NON-POSITIVE') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) C C 100 CONTINUE C CALL UNIRAN(N,ISEED,X) DO100I=1,N XTEMP=X(I) CALL LCTPPF(XTEMP,NPAR,PPF) X(I)=PPF 100 CONTINUE C 9999 CONTINUE C RETURN END SUBROUTINE LDECDF(X,ALPHA,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE LOG DOUBLE EXPONENTIAL C (LAPLACE) DISTRIBUTION. C THIS DISTRIBUTION IS DEFINED FOR ALL POSITIVE X AND C HAS THE CUMULATIVE DISTRIBUTION FUNCTION C F(X) = 0.5*X**ALPHA 0 < X < 1 C = 1.0 - 0.5*X**ALPHA X >= 1 C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C --ALPHA = THE SINLE PRECISION SHAPE PARAMETER C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION C FUNCTION VALUE CDF. C PRINTING--NONE. 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. C REFERENCES--XX C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-975-2899 C ORIGINAL VERSION--SEPTEMBER 2001. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DALPHA 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--------------------------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS. C NO INPUT ARGUMENT ERRORS POSSIBLE C FOR THIS DISTRIBUTION. C CDF=0.0 C IF(X.LE.0.0)THEN WRITE(ICOUT,15) 15 FORMAT('***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO THE ', 1 'LDECDF SUBROUTINE IS NON-POSITIVE *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF C IF(ALPHA.LE.0.0)THEN WRITE(ICOUT,25) 25 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1 'LDECDF SUBROUTINE IS NON-POSITIVE *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALPHA CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF C C-----START POINT----------------------------------------------------- C DX=DBLE(X) DALPHA=DBLE(ALPHA) C IF(X.LT.1.0)THEN DCDF=0.5D0*DX**DALPHA ELSE DCDF=1.0D0 - 0.5D0*DX**(-DALPHA) ENDIF CDF=REAL(DCDF) C 9000 CONTINUE RETURN END SUBROUTINE LDEPDF(X,ALPHA,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE LOG DOUBLE EXPONENTIAL C (LAPLACE) DISTRIBUTION. C THIS DISTRIBUTION IS DEFINED FOR ALL POSITIVE X AND C HAS THE PROBABILITY DENSITY FUNCTION C F(X) = (ALPHA/2)*X**(ALPHA-1) 0 < X < 1 C = (ALPHA/2)*X**(-ALPHA-1) X>= 1 C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C --ALPHA = THE SINLE PRECISION SHAPE PARAMETER C OUTPUT ARGUMENTS--PDF = THE SINGLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY C FUNCTION VALUE PDF. C PRINTING--NONE. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--EXP, LOG. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN. C REFERENCES--XX C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C PHONE: 301-975-2899 C ORIGINAL VERSION--SEPTEMBER 2001. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DALPHA DOUBLE PRECISION DTWO DOUBLE PRECISION DPDF DOUBLE PRECISION DTERM C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C--------------------------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS. C PDF=0.0 C IF(X.LE.0.0)THEN WRITE(ICOUT,15) 15 FORMAT('***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO THE ', 1 'LDEPDF SUBROUTINE IS NON-POSITIVE *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF C IF(ALPHA.LE.0.0)THEN WRITE(ICOUT,25) 25 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1 'LDEPDF SUBROUTINE IS NON-POSITIVE *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALPHA CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF C C-----START POINT----------------------------------------------------- C DX=DBLE(X) DALPHA=DBLE(ALPHA) DTWO=DLOG(2.0D0) C IF(X.LT.1.0)THEN DTERM=DLOG(DALPHA) - DTWO + (DALPHA-1.0D0)*DLOG(DX) DPDF=DEXP(DTERM) ELSE DTERM=DLOG(DALPHA) - DTWO + (-DALPHA-1.0D0)*DLOG(DX) DPDF=DEXP(DTERM) ENDIF PDF=REAL(DPDF) C 9000 CONTINUE RETURN END SUBROUTINE LDEPPF(P,ALPHA,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE LOG DOUBLE EXPONENTIAL C (LAPLACE) DISTRIBUTION. C THIS DISTRIBUTION IS DEFINED FOR ALL POSITIVE X AND C HAS THE PERCENT POINT FUNCTION C G(P) = SQRT(2*P) 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 --ALPHA = THE SINLE PRECISION SHAPE PARAMETER 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--ALOG. 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 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 (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--2001/9 C ORIGINAL VERSION--SEPTEMBER 2001. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C DOUBLE PRECISION DP DOUBLE PRECISION DALPHA DOUBLE PRECISION DPPF C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(P.LE.0.0.OR.P.GE.1.0)THEN WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ', 1'LDEPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C IF(ALPHA.LE.0.0)THEN WRITE(ICOUT,25) 25 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1 'LDEPPF SUBROUTINE IS NON-POSITIVE *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALPHA CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF C AONE=1.0 DP=DBLE(P) DALPHA=DBLE(ALPHA) CALL LDECDF(AONE,ALPHA,CDF) C IF(P.LT.CDF)THEN DPPF=(2.0D0*DP)**(1.0D0/DALPHA) ELSE DPPF=(2.0D0*(1.0D0-DP))**(-1.0D0/DALPHA) ENDIF PPF=REAL(DPPF) C 9000 CONTINUE RETURN END SUBROUTINE LDERAN(N,ALPHA,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE LOG DOUBLE EXPONENTIAL DISTRIBUTION C WITH TAIL LENGTH PARAMETER VALUE = ALPHA. C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --ALPHA = THE SINGLE PRECISION VALUE OF THE C TAIL LENGTH PARAMETER. C ALPHA 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 LOG DOUBLE EXPONENTIAL DISTRIBUTION C WITH TAIL LENGTH PARAMETER VALUE = 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 --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 REFERENCES--KOZUBOWSKI AND PODGORSKI, "LOG-LAPLACE C DISTRIBUTIONS", PAPER DOWNLOADED FROM THEIR C WEB SITE. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2001.10 C ORIGINAL VERSION--OCTOBER 2001. C UPDATED --MARCH 2006. COMPUTE RANDOM NUMBERS C AS RATIO OF UNIFORMS C NOTE: THIS SEEMS TO GENERATE C EXCESIVELY LARGE NUMBERS, SO C REVERT BACK TO PPF ALGORITHM C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*) DIMENSION Y(2) C DOUBLE PRECISION DALPHA DOUBLE PRECISION DY1 DOUBLE PRECISION DY2 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(ALPHA.LE.0.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)ALPHA CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF LOG DOUBLE ', 1'EXPONENTIAL RANDOM NUMBERS IS NON-POSITIVE.') 15 FORMAT('***** ERROR--THE SHAPE PARAMETER FOR THE LOG DOUBLE', 1' EXPONENTIAL 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 LOG DOUBLE EXPONENTIAL DISTRIBUTION RANDOM NUMBERS C USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD. C C NOTE 3/2006: LOG DOUBLE EXPONENTIAL CAN BE REPRESENTED AS C U1**(1/ALPHA)/U2**(1/ALPHA) C C RUNNING SOME SIMULATIONS SEEMS TO SHOW THAT THE RATIO OF C UNIFORM METHOD RESULTS IN SOME EXCESSIVELY LARGE RANDOM C NUMBERS. C IALG=0 IF(IALG.EQ.0)THEN CALL UNIRAN(N,ISEED,X) DO100I=1,N CALL LDEPPF(X(I),ALPHA,XTEMP) X(I)=XTEMP 100 CONTINUE ELSE NTEMP=2 DALPHA=DBLE(ALPHA) DO200I=1,N CALL UNIRAN(NTEMP,ISEED,Y) DY1=DBLE(Y(1)) DY2=DBLE(Y(2)) X(I)=REAL(DY1**(1.0D0/DALPHA)/DY2**(1.0D0/DALPHA)) 200 CONTINUE ENDIF C 9000 CONTINUE RETURN END SUBROUTINE LEGNDR(X,AN,PN) C C PURPOSE--THIS SUBROUTINE COMPUTES THE LEGENDRE 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--PN = THE SINGLE PRECISION VALUE OF THE C LEGENDRE 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 P(N+1) = X*P(N)+(N/N+1)*(X*P(N)-P(N-1)) C FIRST FEW TERMS ARE FROM TABLE 22.9 OF ABRAMOWITZ C AND STEGUM. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-975-2855 C ORIGINAL VERSION--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 DOUBLE PRECISION DPN, DPN1, DPN2 C C-----START POINT----------------------------------------------------- C CCCCC IF(X.LT.-1.0.OR.X.GT.1.0)THEN CCCCC WRITE(ICOUT,4) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,46)X CCCCC CALL DPWRST('XXX','BUG ') CCCCC GOTO9999 CCCCC ENDIF CCCC4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 1ST INPUT ARGUMENT ', CCCCC1'TO THE LEGNDR SUBROUTINE IS OUTSIDE THE (-1,1) INTERVAL *****') CCC46 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 LEGNDR 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 PN=1.0 ELSEIF(N.EQ.1)THEN PN=X ELSEIF(N.EQ.2)THEN PN=1.5*X**2-0.5 ELSEIF(N.EQ.3)THEN DPN=2.5D0*DX**3-1.5D0*DX PN=REAL(DPN) ELSE DPN1=2.5D0*DX**3-1.5D0*DX DPN2=1.5D0*DX**2-0.5D0 DO1000I=4,N DN=DBLE(I)-1.0D0 DPN=DX*DPN1+(DN/(DN+1.0D0))*(DX*DPN1-DPN2) DPN2=DPN1 DPN1=DPN 1000 CONTINUE PN=REAL(DPN) ENDIF C 9999 CONTINUE RETURN END SUBROUTINE LG1FUN (NPAR, XPAR, FVEC, IFLAG, XDATA, R) C C PURPOSE--THIS ROUTINE COMPUTES THE FUNCTIONS FOR THE C LOGNORMAL MAXIMUM LIKELIHOOD EQUATIONS FOR THE C SINGLY TIME CENSORED CASE (FROM PP. 161-162 OF BURY). C C SUM[i=1 to r][Z(I)] + M*H(Z(I)) = 0 C C SUM[i=1 to r][Z(I)**2] + M*Z*H(Z) - R = 0 C C WHERE C C C R = NUMBER OF FAILURES C M = NUMBER OF CENSORING TIMES C C = CENSORING TIME (ALL CENSORED DATA WILL HAVE C THE SAME CENSORING TIME) C Z(I) = [LOG(X(I) - UHAT]/SHAT C UHAT = FVEC(1) = CURRENT ESTIMATE OF MU PARAMETER C SHAT = FVEC(2) = CURRENT ESTIMATE OF SIGMA PARAMETER C Z = [LOG(C) - UHAT]/SHAT C H(Z) = NORPDF(Z)/(1 - NOCDF(Z)) 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--LOGNORMAL MAXIMUM LIKELIHOOD Y X C REFERENCE--KARL BURY, (1999). "STATISTICAL DISTRIBUTIONS IN C ENGINEERING", CAMBRIDGE UNIVERSITY PRESS, C PP. 161-162. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004/11 C ORIGINAL VERSION--NOVEMBER 2004. C C--------------------------------------------------------------------- C INTEGER R DOUBLE PRECISION XPAR(*) DOUBLE PRECISION FVEC(*) REAL XDATA(*) C DOUBLE PRECISION DN DOUBLE PRECISION DR DOUBLE PRECISION DM DOUBLE PRECISION DZ DOUBLE PRECISION DH DOUBLE PRECISION DX DOUBLE PRECISION UHAT DOUBLE PRECISION SHAT DOUBLE PRECISION DSUM1 DOUBLE PRECISION DSUM2 DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 C DOUBLE PRECISION C INTEGER N INTEGER M COMMON/LG1COM/C,N,M C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C DN=DBLE(N) DR=DBLE(R) DM=DBLE(M) UHAT=XPAR(1) SHAT=XPAR(2) DZ=(DLOG(C)-UHAT)/SHAT CALL NODPDF(DZ,DTERM1) CALL NODCDF(DZ,DTERM2) DH=DTERM1/(1.0D0 - DTERM2) C DTERM1=DM*DH DTERM2=DTERM1*DZ - DR DSUM1=0.0D0 DSUM2=0.0D0 C IF(R.GT.0)THEN DO100I=1,R DX=DBLE(XDATA(I)) DX=(DLOG(DX) - UHAT)/SHAT DSUM1=DSUM1 + DX DSUM2=DSUM2 + DX*DX 100 CONTINUE ENDIF C FVEC(1) = DTERM1 + DSUM1 FVEC(2) = DTERM2 + DSUM2 C RETURN END DOUBLE PRECISION FUNCTION LG2FUN (DU,DX) C C PURPOSE--THIS ROUTINE IS USED IN FINDING THE LIKELIHOOD RATIO C BASED CONFIDENCE INTERVAL FOR THE MU (=LOG(SCALE) C PARAMETER OF A 2-PARAMETER LOGNORMAL MODEL C (SINGLY TIME CENSORED SAMPLE). THE FOLLOWING C EQUATION NEEDS TO BE SOLVED. C C 2*LL(UHAT,SHAT) - 2*LL(U,S(U)) - CHSPPF(alpha,1) C C WITH C C LL(UHAT,SHAT) = -R*LOG(SHAT) - C SUM[i=1 tp r][LOG(X(I))] - C 0.5*SUM[i=1 to r] C [((LOG(X(I)) - UHAT)/SHAT)**2] + C DM*LOG(1 - NORCDF( C C LL(UHAT,SHAT) IS COMPUTED ONCE BY THE CALLING ROUTINE C AND PASSED VIA COMMON BLOCK. C C THEN GIVEN THE CURRENT GUESS FOR U, WE NEED TO C SOLVE THE FOLLOWING EQUATION FOR S: C C SUM[i=1 to r][{(LOG(X(I)-U)/S}**2] + C M*(LOG(C)-U)/S)*H(Z) - R C C WITH C C Z = (LOG(X(I))-U)/S C HZ = NORPDF(Z)/(1-NORCDF(Z)) C C WE THEN COMPUTE LL(UHAT,SHAT) WITH THESE U AND S(U) C VALUES. C C EXAMPLE--LOGNORMAL MAXIMUM LIKELIHOOD Y X C REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN ENGINEERING", C CAMBRIDGE UNIVERSITY PRESS, 1999, CHAPTER 11 (SEE C EXAMPLE 11.5). C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBUG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004/11 C ORIGINAL VERSION--NOVEMBER 2004. C C--------------------------------------------------------------------- C DOUBLE PRECISION DU DOUBLE PRECISION DX(*) C INTEGER N INTEGER IR INTEGER IM DOUBLE PRECISION DLLUS DOUBLE PRECISION DC DOUBLE PRECISION DK DOUBLE PRECISION DSIGMA COMMON/LG2COM/DLLUS,DC,DK,DSIGMA,N,IR,IM C INTEGER N2 INTEGER IR2 INTEGER IM2 DOUBLE PRECISION DU2 DOUBLE PRECISION DC2 COMMON/LG3COM/DU2,DC2,N2,IR2,IM2 C EXTERNAL LG3FUN C DOUBLE PRECISION AE DOUBLE PRECISION RE DOUBLE PRECISION XLOW DOUBLE PRECISION XUP DOUBLE PRECISION XSTRT DOUBLE PRECISION DS DOUBLE PRECISION DN DOUBLE PRECISION DR DOUBLE PRECISION DM DOUBLE PRECISION DZ DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DSUM1 DOUBLE PRECISION 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 C STEP 1: GIVEN VALUE OF SCALE PARAMETER (DB), NEED TO COMPUTE C THE SHAPE PARAMETER (WHICH IN TURN INVOLVES FINDING A C ROOT). N2=N IR2=IR IM2=IM DC2=DC DU2=DU C AE=1.D-7 RE=1.D-7 XSTRT=DSIGMA XLOW=XSTRT/5.0D0 XUP=XSTRT*5.0D0 CALL DFZER3(LG3FUN,XLOW,XUP,XSTRT,RE,AE,IFLAG,DX) DS=XLOW C C COMPUTE LL(S,G) C DN=DBLE(N) DR=DBLE(IR) DM=DBLE(IM) C DZ=(DLOG(DC) - DU)/DS CALL NODCDF(DZ,DTERM2) DTERM1=-DR*DLOG(DS) + DM*DLOG(1.0D0 - DTERM2) DSUM1=0.0D0 DSUM2=0.0D0 DO100I=1,IR DZ=DLOG(DX(I)) DSUM1=DSUM1 + DZ DSUM2=DSUM2 + ((DZ - DU)/DS)**2 100 CONTINUE DTERM2=DTERM1 - DSUM1 - 0.5D0*DSUM2 C LG2FUN=2.0*DLLUS - 2.0D0*DTERM2 - DK C RETURN END DOUBLE PRECISION FUNCTION LG3FUN (DS,DX) C C PURPOSE--THIS ROUTINE IS USED IN FINDING THE LIKELIHOOD RATIO C BASED CONFIDENCE INTERVAL FOR THE MU (=LOG(SCALE) C PARAMETER OF A 2-PARAMETER LOGNORMAL MODEL C (SINGLY TIME CENSORED SAMPLE). IT IS CALLED BY C LG2FUN TO SOLVE THE EQUATION C C SUM[i=1 to r][{(LOG(X(I)-U)/S}**2] + C M*(LOG(C)-U)/S)*H(Z) - R C C WITH C C Z = (LOG(X(I))-U)/S C HZ = NORPDF(Z)/(1-NORCDF(Z)) C C WE ARE GIVEN THE VALUE OF U AND WE NEED TO SOLVE FOR S. C C EXAMPLE--LOGNORMAL MAXIMUM LIKELIHOOD Y X C REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN ENGINEERING", C CAMBRIDGE UNIVERSITY PRESS, 1999, CHAPTER 11 (SEE C EXAMPLE 11.5). C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBUG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004/11 C ORIGINAL VERSION--NOVEMBER 2004. C C--------------------------------------------------------------------- C DOUBLE PRECISION DS DOUBLE PRECISION DX(*) C INTEGER N INTEGER IR INTEGER IM DOUBLE PRECISION DU DOUBLE PRECISION DC COMMON/LG3COM/DU,DC,N,IR,IM C DOUBLE PRECISION DN DOUBLE PRECISION DR DOUBLE PRECISION DM DOUBLE PRECISION DZ DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DSUM1 C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C DN=DBLE(N) DR=DBLE(IR) DM=DBLE(IM) C DTERM1=(DLOG(DC)-DU)/DS CALL NODPDF(DTERM1,DTERM2) CALL NODCDF(DTERM1,DTERM3) C DSUM1=0.0D0 DO100I=1,IR DZ=DX(I) DZ=(DLOG(DZ) - DU)/DS DSUM1=DSUM1 + DZ*DZ 100 CONTINUE C LG3FUN=DSUM1 + DM*DTERM1*DTERM2/(1.0D0-DTERM3) - DR C RETURN END DOUBLE PRECISION FUNCTION LG4FUN (DSIGMA,DX) C C PURPOSE--THIS ROUTINE IS USED IN FINDING THE LIKELIHOOD RATIO C BASED CONFIDENCE INTERVAL FOR THE SIGMA C PARAMETER OF A 2-PARAMETER LOGNORMAL MODEL C (SINGLY TIME CENSORED SAMPLE). THE FOLLOWING C EQUATION NEEDS TO BE SOLVED. C C 2*LL(UHAT,SHAT) - 2*LL(G(S),S) - CHSPPF(alpha,1) C C WITH C C LL(UHAT,SHAT) = -R*LOG(SHAT) - C SUM[i=1 tp r][LOG(X(I))] - C 0.5*SUM[i=1 to r] C [((LOG(X(I)) - UHAT)/SHAT)**2] + C DM*LOG(1 - NORCDF( C C LL(UHAT,SHAT) IS COMPUTED ONCE BY THE CALLING ROUTINE C AND PASSED VIA COMMON BLOCK. C C THEN GIVEN THE CURRENT GUESS FOR SIGMA, WE NEED TO C SOLVE THE FOLLOWING EQUATION FOR U: C C SUM[i=1 to r][(LOG(X(I)-U)/S] + M*H(Z) C C WITH C C Z = (LOG(X(I))-U)/S C HZ = NORPDF(Z)/(1-NORCDF(Z)) C C WE THEN COMPUTE LL(UHAT,SHAT) WITH THESE G(S) AND S C VALUES. C C EXAMPLE--LOGNORMAL MAXIMUM LIKELIHOOD Y X C REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN ENGINEERING", C CAMBRIDGE UNIVERSITY PRESS, 1999, CHAPTER 11 (SEE C EXAMPLE 11.5). C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBUG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004/11 C ORIGINAL VERSION--NOVEMBER 2004. C C--------------------------------------------------------------------- C DOUBLE PRECISION DSIGMA DOUBLE PRECISION DX(*) C INTEGER N INTEGER IR INTEGER IM DOUBLE PRECISION DLLUS DOUBLE PRECISION DC DOUBLE PRECISION DK DOUBLE PRECISION DU COMMON/LG4COM/DLLUS,DC,DK,DU,N,IR,IM C INTEGER N2 INTEGER IR2 INTEGER IM2 DOUBLE PRECISION DS2 DOUBLE PRECISION DC2 COMMON/LG5COM/DS2,DC2,N2,IR2,IM2 C EXTERNAL LG5FUN C DOUBLE PRECISION AE DOUBLE PRECISION RE DOUBLE PRECISION XLOW DOUBLE PRECISION XUP DOUBLE PRECISION XSTRT DOUBLE PRECISION DS DOUBLE PRECISION DN DOUBLE PRECISION DR DOUBLE PRECISION DM DOUBLE PRECISION DZ DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DSUM1 DOUBLE PRECISION 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 C STEP 1: GIVEN VALUE OF SHAPE PARAMETER (DSIGMA), NEED TO COMPUTE C THE SCALE PARAMETER (WHICH IN TURN INVOLVES FINDING A C ROOT). N2=N IR2=IR IM2=IM DC2=DC DS2=DSIGMA C AE=1.D-7 RE=1.D-7 XSTRT=DU XLOW=XSTRT/5.0D0 XUP=XSTRT*5.0D0 CALL DFZER3(LG5FUN,XLOW,XUP,XSTRT,RE,AE,IFLAG,DX) DU=XLOW DS=DSIGMA C C COMPUTE LL(S,G) C DN=DBLE(N) DR=DBLE(IR) DM=DBLE(IM) C DZ=(DLOG(DC) - DU)/DS CALL NODCDF(DZ,DTERM2) DTERM1=-DR*DLOG(DS) + DM*DLOG(1.0D0 - DTERM2) DSUM1=0.0D0 DSUM2=0.0D0 DO100I=1,IR DZ=DLOG(DX(I)) DSUM1=DSUM1 + DZ DSUM2=DSUM2 + ((DZ - DU)/DS)**2 100 CONTINUE DTERM2=DTERM1 - DSUM1 - 0.5D0*DSUM2 C LG4FUN=2.0*DLLUS - 2.0D0*DTERM2 - DK C RETURN END DOUBLE PRECISION FUNCTION LG5FUN (DU,DX) C C PURPOSE--THIS ROUTINE IS USED IN FINDING THE LIKELIHOOD RATIO C BASED CONFIDENCE INTERVAL FOR THE SHAPE PARAMETER, C SIGMA, OF A 2-PARAMETER LOGNORMAL MODEL C (SINGLY TIME CENSORED SAMPLE). IT IS CALLED BY C LG4FUN TO SOLVE THE EQUATION C C SUM[i=1 to r][{(LOG(X(I)-U)/S}**2] + M*H(Z) C C WITH C C Z = (LOG(X(I))-U)/S C HZ = NORPDF(Z)/(1-NORCDF(Z)) C C WE ARE GIVEN THE VALUE OF U AND WE NEED TO SOLVE FOR S. C C EXAMPLE--LOGNORMAL MAXIMUM LIKELIHOOD Y X C REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN ENGINEERING", C CAMBRIDGE UNIVERSITY PRESS, 1999, CHAPTER 11 (SEE C EXAMPLE 11.5). C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBUG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004/11 C ORIGINAL VERSION--NOVEMBER 2004. C C--------------------------------------------------------------------- C DOUBLE PRECISION DU DOUBLE PRECISION DX(*) C INTEGER N INTEGER IR INTEGER IM DOUBLE PRECISION DS DOUBLE PRECISION DC COMMON/LG5COM/DS,DC,N,IR,IM C DOUBLE PRECISION DN DOUBLE PRECISION DR DOUBLE PRECISION DM DOUBLE PRECISION DZ DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DSUM1 C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C DN=DBLE(N) DR=DBLE(IR) DM=DBLE(IM) C DTERM1=(DLOG(DC)-DU)/DS CALL NODPDF(DTERM1,DTERM2) CALL NODCDF(DTERM1,DTERM3) C DSUM1=0.0D0 DO100I=1,IR DZ=DX(I) DZ=(DLOG(DZ) - DU)/DS DSUM1=DSUM1 + DZ 100 CONTINUE C LG5FUN=DSUM1 + DM*DTERM2/(1.0D0-DTERM3) C RETURN END DOUBLE PRECISION FUNCTION LG6FUN (DXQ,DX) C C PURPOSE--THIS ROUTINE IS USED IN FINDING THE LIKELIHOOD RATIO C BASED CONFIDENCE INTERVAL FOR A GIVEN PERCENTILE C OF A 2-PARAMETER LOGNORMAL MODEL C (SINGLY TIME CENSORED SAMPLE). THE FOLLOWING C EQUATION NEEDS TO BE SOLVED. C C 2*LL(UHAT,SHAT) - 2*LL(g(xq),s(xq)) - CHSPPF(alpha,1) C C WITH C C LL(UHAT,SHAT) = -R*LOG(SHAT) - C SUM[i=1 tp r][LOG(X(I))] - C 0.5*SUM[i=1 to r] C [((LOG(X(I)) - UHAT)/SHAT)**2] + C DM*LOG(1 - NORCDF( C C LL(UHAT,SHAT) IS COMPUTED ONCE BY THE CALLING ROUTINE C AND PASSED VIA COMMON BLOCK. C C THEN GIVEN THE CURRENT MAXIMUM LIKELIHOOD ESTIMATE OF C SIGMA, WE NEED TO SOLVE THE FOLLOWING EQUATION FOR C XQ: C C C (1/B**2)*SUM[i=1 to r] C [{(LOG(X(I)/X05} + B*Z05]*LOG(X(I)/X05) + C (M/B)*(LOG(C)/X05)*H(Z) - R C C WITH C C Z05 = NORPPF(1 - ALPHA/2) C X05 = LGNPPF(P) (P IS THE DESIRED PERCENTILE) C Z = LOG(C/XQ)/B + Z05 C HZ = NORPDF(Z)/(1-NORCDF(Z)) C C WE ARE GIVEN THE VALUE OF B (= MAXIMUM LIKELIHOOD C ESTIMATE OF SIGMA) AND WE NEED TO SOLVE FOR XQ. C WE THEN COMPUTE LL(UHAT,SHAT) WITH THESE U AND S(U) C VALUES. C C EXAMPLE--LOGNORMAL MAXIMUM LIKELIHOOD Y X C REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN ENGINEERING", C CAMBRIDGE UNIVERSITY PRESS, 1999, CHAPTER 11 (SEE C EXAMPLE 11.5). C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBUG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004/11 C ORIGINAL VERSION--NOVEMBER 2004. C C--------------------------------------------------------------------- C DOUBLE PRECISION DXQ DOUBLE PRECISION DX(*) C INTEGER N INTEGER IR INTEGER IM DOUBLE PRECISION DLLUS DOUBLE PRECISION DC DOUBLE PRECISION DK DOUBLE PRECISION DSIGMA DOUBLE PRECISION DU DOUBLE PRECISION DX05 DOUBLE PRECISION DZ05 DOUBLE PRECISION SEXQP COMMON/LG6COM/DLLUS,DC,DK,DSIGMA,DU,DX05,DZ05,SEXQP,N,IR,IM C INTEGER N2 INTEGER IR2 INTEGER IM2 DOUBLE PRECISION DX052 DOUBLE PRECISION DZ052 DOUBLE PRECISION DC2 DOUBLE PRECISION DS2 COMMON/LG7COM/DX052,DZ052,DC2,DS2,N2,IR2,IM2 C EXTERNAL LG7FUN C DOUBLE PRECISION AE DOUBLE PRECISION RE DOUBLE PRECISION XLOW DOUBLE PRECISION XUP DOUBLE PRECISION XSTRT DOUBLE PRECISION DS DOUBLE PRECISION DU2 DOUBLE PRECISION DN DOUBLE PRECISION DR DOUBLE PRECISION DM DOUBLE PRECISION DZ DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DSUM1 DOUBLE PRECISION 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 C STEP 1: GIVEN VALUE OF SCALE PARAMETER (DB), NEED TO COMPUTE C THE SHAPE PARAMETER (WHICH IN TURN INVOLVES FINDING A C ROOT). C DX052=DX05 DZ052=DZ05 DC2=DC DS2=DSIGMA N2=N IR2=IR IM2=IM write(18,*) 'lg6fun: dxq,dx05,dz05=',dxq,dx05,dz05 C AE=1.D-7 RE=1.D-7 XSTRT=DXQ XLOW=XSTRT/5.0D0 XUP=XSTRT*5.0D0 write(18,*) 'lg6fun: xlow,xstrt,xup=',xlow,xstrt,xup CALL DFZER3(LG7FUN,XLOW,XUP,XSTRT,RE,AE,IFLAG,DX) DSXQ=XLOW C C COMPUTE LL(S,G) C DN=DBLE(N) DR=DBLE(IR) DM=DBLE(IM) C DU2=DLOG(DXQ) - DZ05*DSXQ DS=DSXQ write(18,*)'iflag,du2,ds=',iflag,du2,ds DZ=(DLOG(DC) - DU2)/DS CALL NODCDF(DZ,DTERM2) DTERM1=-DR*DLOG(DS) + DM*DLOG(1.0D0 - DTERM2) DSUM1=0.0D0 DSUM2=0.0D0 DO100I=1,IR DZ=DLOG(DX(I)) DSUM1=DSUM1 + DZ DSUM2=DSUM2 + ((DZ - DU2)/DS)**2 100 CONTINUE DTERM2=DTERM1 - DSUM1 - 0.5D0*DSUM2 C LG6FUN=2.0*DLLUS - 2.0D0*DTERM2 - DK write(18,*) 'dllus,dk,dterm1,dterm2,lg6fun=',dllus,dk,dterm1, 1 dterm2,lg6fun C RETURN END DOUBLE PRECISION FUNCTION LG7FUN (DXQ,DX) C C PURPOSE--THIS ROUTINE IS USED IN FINDING THE LIKELIHOOD RATIO C BASED CONFIDENCE INTERVAL FOR THE PERCENTILE FUNCTION C OF A 2-PARAMETER LOGNORMAL MODEL (SINGLY TIME CENSORED C SAMPLE). IT IS CALLED BY LG6FUN TO SOLVE THE EQUATION C C (1/B**2)*SUM[i=1 to r] C [{(LOG(X(I)/X05} + B*Z05]*LOG(X(I)/X05) + C (M/B)*(LOG(C)/X05)*H(Z) - R C C WITH C C Z05 = NORPPF(1 - ALPHA/2) C X05 = LGNPPF(P) (P IS THE DESIRED PERCENTILE) C Z = LOG(C/XQ)/B + Z05 C HZ = NORPDF(Z)/(1-NORCDF(Z)) C C WE ARE GIVEN THE VALUE OF B (= MAXIMUM LIKELIHOOD C ESTIMATE OF SIGMA) AND WE NEED TO SOLVE FOR XQ. C C THE VALUES OF Z05 AND X05 ARE CALCULATED IN DPMLL2 C AND STORED IN A COMMON BLOCK. C C EXAMPLE--LOGNORMAL MAXIMUM LIKELIHOOD Y X C REFERENCE--KARL BURY, "STATISTICAL DISTRIBUTIONS IN ENGINEERING", C CAMBRIDGE UNIVERSITY PRESS, 1999, CHAPTER 11 (SEE C EXAMPLE 11.5). C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBUG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004/11 C ORIGINAL VERSION--NOVEMBER 2004. C C--------------------------------------------------------------------- C DOUBLE PRECISION DXQ DOUBLE PRECISION DX(*) C INTEGER N INTEGER IR INTEGER IM DOUBLE PRECISION DX05 DOUBLE PRECISION DZ05 DOUBLE PRECISION DC DOUBLE PRECISION DS COMMON/LG7COM/DX05,DZ05,DC,DS,N,IR,IM C DOUBLE PRECISION DN DOUBLE PRECISION DR DOUBLE PRECISION DM DOUBLE PRECISION DZ DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DSUM1 C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C DN=DBLE(N) DR=DBLE(IR) DM=DBLE(IM) C DTERM1=(DLOG(DC/DXQ)/DS) + DZ05 CALL NODPDF(DTERM1,DTERM2) CALL NODCDF(DTERM1,DTERM3) C DSUM1=0.0D0 DO100I=1,IR DZ=DLOG(DX(I)/DXQ) DSUM1=DSUM1 + (DZ + DS*DZ05)*DZ 100 CONTINUE C LG7FUN=(1.0D0/DS**2)*DSUM1 + 1 (DM/DS)*DLOG(DC/DXQ)*DTERM2/(1.0D0-DTERM3) - DR write(18,*)'lg7fun=',lg7fun C RETURN END SUBROUTINE LGACDF(X,GAMMA,ILGADF,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE LOG-GAMMA DISTRIBUTION C WITH POSITIVE SHAPE PARAMETER GAMMA C THIS DISTRIBUTION IS DEFINED FOR ALL REAL X. C THE PDF FOR THE STANDARD FORM OF THE DISTRIBUTION IS C F(X,G) = EXP(G*X-EXP(X))/GAMMA(G) C WHERE GAMMA IS THE GAMMA FUNCTION. C THE CORRESPONDING CDF IS: C F(X,G) = I(EXP(Y)(GAMMA) C WHERE I(X)(GAMMA) IS THE INCOMPLETE GAMMA FUNCTION RATIO 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 --GAMMA = A POSITIVE SHAPE PARAMETER C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION C FUNCTION VALUE CDF FOR THE LOG GAMMA DISTRIBUTION C WITH SHAPE PARAMETER GAMMA C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE NON-NEGATIVE. C --GAMMA SHOULD BE A POSITIVE NUMBER. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--2, 1994, PAGE 89-90. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--95/10 C ORIGINAL VERSION--OCTOBER 1995. C UPDATED --JULY 2005. SUPPORT FOR RE-PARAMETERIZED C DEFINITION THAT IS USEFUL FOR C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C CHARACTER*4 ILGADF C DOUBLE PRECISION DX DOUBLE PRECISION DGAMMA DOUBLE PRECISION DCDF DOUBLE PRECISION DGAMIP DOUBLE PRECISION DTERM1 C EXTERNAL DGAMIP 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(GAMMA.LE.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)GAMMA CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ENDIF 15 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1'LGACDF SUBROUTINE IS NON-POSITIVE') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C DX=DBLE(X) DGAMMA=DBLE(GAMMA) C IF(ILGADF.EQ.'DEFA')THEN DCDF=DGAMIP(DGAMMA,DEXP(DX)) ELSE DTERM1=DGAMMA*DEXP(DX/DSQRT(DGAMMA)) DCDF=DGAMIP(DGAMMA,DTERM1) ENDIF CDF=REAL(DCDF) C 9999 CONTINUE RETURN END SUBROUTINE LGAPDF(X,GAMMA,ILGADF,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE LOG-GAMMA DISTRIBUTION C WITH POSITIVE SHAPE PARAMETER GAMMA C THIS DISTRIBUTION IS DEFINED FOR ALL REAL X. C THE PDF FOR THE STANDARD FORM OF THE DISTRIBUTION IS C F(X,G) = EXP(G*X-EXP(X))/GAMMA(G) C WHERE GAMMA IS THE GAMMA FUNCTION. C C FOR FITTING PURPOSES, THE FOLLOWING REPARAMETERIZED C PDF IS OFTEN PREFERRED: C F(X,G) = (G**(G-0.5)/GAMMA(G)* C EXP(SQRT(G)*X-G*EXP(X/SQRT(G))) 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 --GAMMA = A POSITIVE SHAPE PARAMETER C OUTPUT ARGUMENTS--PDF = THE SINGLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY C FUNCTION VALUE PDF FOR THE LOG GAMMA DISTRIBUTION C WITH SHAPE PARAMETER GAMMA C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE NON-NEGATIVE. C --GAMMA SHOULD BE A POSITIVE NUMBER. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--2, 1994, PAGE 89-90. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--95/10 C ORIGINAL VERSION--OCTOBER 1995. C UPDATED --JULY 2005. SUPPORT FOR RE-PARAMETERIZED C DEFINITION THAT IS USEFUL FOR C FITTING C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C CHARACTER*4 ILGADF C DOUBLE PRECISION DX DOUBLE PRECISION DGAMMA DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DPDF DOUBLE PRECISION DLNGAM C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(GAMMA.LE.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)GAMMA CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF 15 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1'LGAPDF SUBROUTINE IS NON-POSITIVE') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C DX=DBLE(X) DGAMMA=DBLE(GAMMA) C IF(ILGADF.EQ.'DEFA')THEN DTERM1=DGAMMA*DX - DEXP(DX) DTERM2=DTERM1-DLNGAM(DGAMMA) DPDF=0.0D0 IF(DTERM2.GE.-80.0D0)DPDF=DEXP(DTERM2) PDF=REAL(DPDF) ELSE DTERM1=(DGAMMA - 0.5D0)*DLOG(DGAMMA) - DLNGAM(DGAMMA) DTERM2=DSQRT(DGAMMA)*DX - DGAMMA*DEXP(DX/DSQRT(DGAMMA)) DTERM3=DTERM1 + DTERM2 DPDF=0.0D0 IF(DTERM3.GE.-80.0D0)DPDF=DEXP(DTERM3) PDF=REAL(DPDF) ENDIF C 9999 CONTINUE RETURN END SUBROUTINE LGAPPF(P,GAMMA,ILGADF,PPF) C C PURPOSE --PERCENT POINT FUNCTION FOR THE LOG-GAMMA C DISTRIBUTION. USES A BISECTION METHOD. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--95/10 C ORIGINAL VERSION--OCTOBER 1995. C UPDATED --JULY 2005. SUPPORT FOR RE-PARAMETERIZED C DEFINITION THAT IS USEFUL FOR C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ILGADF C CHARACTER*4 IFEEDB CHARACTER*4 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 /2000/ 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 IF(GAMMA.LE.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)GAMMA CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF C 1 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE ', 1' LGAPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL.') 15 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1'LGAPPF SUBROUTINE IS NON-POSITIVE *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C C C FIND BRACKETING INTERVAL. C XL=-50.0 XINC=25.0 ICOUNT=0 MAXCNT=10000 C 91 CONTINUE XR=XL+XINC CALL LGACDF(XL,GAMMA,ILGADF,CDFL) CALL LGACDF(XR,GAMMA,ILGADF,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('***** ERROR--LGAPPF UNABLE TO FIND A 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 LGACDF(X,GAMMA,ILGADF,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--THE LGAPPF ROUTINE DID NOT CONVERGE. ***') GOTO9999 C 9999 CONTINUE RETURN END SUBROUTINE LGARAN(N,GAMMA,ILGADF,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE LOG GAMMA DISTRIBUTION C WITH TAIL LENGTH PARAMETER VALUE = GAMMA. C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --GAMMA = THE SINGLE PRECISION VALUE OF THE C TAIL LENGTH PARAMETER. C GAMMA SHOULD BE POSITIVE. C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR C (OF DIMENSION AT LEAST N) C INTO WHICH THE GENERATED C RANDOM SAMPLE WILL BE PLACED. C OUTPUT--A RANDOM SAMPLE OF SIZE N C FROM THE LOG GAMMA DISTRIBUTION C WITH TAIL LENGTH PARAMETER VALUE = GAMMA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C --GAMMA SHOULD BE POSITIVE. C 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 --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--1, 2ND. ED., 1994. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--2001.10 C ORIGINAL VERSION--OCTOBER 2001. C UPDATED --JULY 2005. SUPPORT FOR RE-PARAMETERIZED C DEFINITION THAT IS USEFUL FOR C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*) C CHARACTER*4 ILGADF C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)THEN WRITE(ICOUT, 5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF IF(GAMMA.LE.0.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)GAMMA CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF LOG GAMMA RANDOM', 1' NUMBERS IS NON-POSITIVE.') 15 FORMAT('***** ERROR--THE SHAPE PARAMETER FOR LOG GAMMA RANDOM', 1' 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 LOG GAMMA DISTRIBUTION RANDOM NUMBERS C USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD. C DO100I=1,N CALL LGAPPF(X(I),GAMMA,ILGADF,XTEMP) X(I)=XTEMP 100 CONTINUE C 9000 CONTINUE RETURN END SUBROUTINE LGNAFR(X1,X2,SIGMA,ALOC,SCALE,AFR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE AVERAGE FAILURE RATE C (AFR) FUNCTION VALUE FOR THE LOGNORMAL DISTRIBUTION. C THE AFR IS DEFINED AS: C C AFR(X1,X2,SHAPE,LOC,SCALE) = (H(X2,SHAPE,LOC,SCALE) - C H(X1,LOC,SCALE))/(X2-X1) C C WHERE C C H(X,SHAPE,LOC,SCALE) = H((X-LOC)/SCALE,SHAPE) C C FOR THE LOGNORMAL, WE USE THE LGNCHA FUNCTION. C C INPUT ARGUMENTS--X1 = THE SINGLE PRECISION VALUE AT C WHICH THE AFR FUNCTION IS TO BE C EVALUATED. C --X2 = THE SINGLE PRECISION VALUE AT C WHICH THE AFR FUNCTION IS TO BE C EVALUATED. C --SIGMA = THE (POSITIVE) SHAPE PARAMETER C --ALOC = THE LOCATION PARAMETER C --SCALE = THE (POSITIVE) SCALE PARAMETER C OUTPUT ARGUMENTS--AFR = THE SINGLE PRECISION AVERAGE C FAILURE RATE FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION AVERAGE FAILURE RATE FOR THE C LOGNORMAL DISTRIBUTION. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--SIGMA AND SCALE SHOULD BE POSITIVE, X2 NOT EQUAL X1. C OTHER DATAPAC SUBROUTINES NEEDED--LGNCHA. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--TOBIAS AND TRINDALE, "APPLIED RELIABILITY", SECOND C EDITION, CHAPMAN AND HALL/CRC, 1995. 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--2005.3 C ORIGINAL VERSION--MARCH 2005. 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 X1MN=MIN(X1,X2) X1MX=MAX(X1,X2) IF(X1MN.EQ.X1MX)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)X1MN CALL DPWRST('XXX','BUG ') WRITE(ICOUT,48)X1MX CALL DPWRST('XXX','BUG ') AFR=0.0 GOTO9000 ELSEIF(X1MN.LT.ALOC)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X1MN CALL DPWRST('XXX','BUG ') WRITE(ICOUT,49)ALOC CALL DPWRST('XXX','BUG ') AFR=0.0 GOTO9000 ELSEIF(SIGMA.LE.0.0)THEN WRITE(ICOUT,8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)SIGMA CALL DPWRST('XXX','BUG ') AFR=0.0 GOTO9000 ELSEIF(SCALE.LE.0.0)THEN WRITE(ICOUT,6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)SCALE CALL DPWRST('XXX','BUG ') AFR=0.0 GOTO9000 ENDIF 90 CONTINUE 4 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO LGNAFR ', 1 'IS LESS THAN THE LOCATION') 5 FORMAT('***** ERROR--THE FIRST AND SECOND INPUT ARGUMENTS TO ', 1 'LGNAFR ARE EQUAL') 6 FORMAT('***** ERROR--THE FIFTH INPUT ARGUMENT TO LGNAFR ', 1 '(THE SCALE) IS NON-POSITIVE') 8 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO LGNAFR ', 1 '(THE SHAPE) IS NON-POSITIVE') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) 47 FORMAT('***** THE VALUE OF THE FIRST ARGUMENT IS ',G15.7) 48 FORMAT('***** THE VALUE OF THE SECOND ARGUMENT IS ',G15.7) 49 FORMAT('***** THE VALUE OF THE LOCATION PARAMETER IS ',G15.7) C IF(X1MN.LT.ALOC)THEN AFR=0.0 ELSE IF(X1MN.EQ.ALOC)THEN TERM1=(X1MX-ALOC)/SCALE CALL LGNCHA(TERM1,SIGMA,CHAZ1) AFR=CHAZ1/(X1MX - X1MN) ELSE TERM1=(X1MX-ALOC)/SCALE CALL LGNCHA(TERM1,SIGMA,CHAZ1) TERM2=(X1MN-ALOC)/SCALE CALL LGNCHA(TERM2,SIGMA,CHAZ2) AFR=(CHAZ1 - CHAZ2)/(X1MX - X1MN) ENDIF C 9000 CONTINUE RETURN END SUBROUTINE LGNCDF(X,SD,CDF) CCCCC SUBROUTINE LGNCDF(X,CDF) CCCCC APRIL 1995. SUPPORT SHAPE PARAMETER C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE LOGNORMAL C DISTRIBUTION. C THE LOGNORMAL DISTRIBUTION USED C HEREIN HAS MEAN = SQRT(E) = 1.64872127 C AND STANDARD DEVIATION = SQRT(E*(E-1)) = 2.16119742. C THIS DISTRIBUTION IS DEFINED FOR ALL POSITIVE X C AND HAS THE PROBABILITY DENSITY FUNCTION C F(X) = (1/(X*SQRT(2*PI))) * EXP(-ALOG(X)*ALOG(X)/2) C THE LOGNORMAL DISTRIBUTION USED HEREIN C IS THE DISTRIBUTION OF THE VARIATE X = EXP(Z) WHERE C THE VARIATE Z IS NORMALLY DISTRIBUTED C WITH MEAN = 0 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 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 LOGNORMAL C DISTRIBUTION WITH MEAN = SQRT(E) = 1.64872127 C AND STANDARD DEVIATION = SQRT(E*(E-1)) = 2.16119742. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE POSITIVE. C OTHER DATAPAC SUBROUTINES NEEDED--NORCDF. C FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN. C REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--1, 1970, PAGES 112-136. C --CRAMER, MATHEMATICAL METHODS OF STATISTICS, C 1946, PAGES 219-220. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-921-2315 C ORIGINAL VERSION--APRIL 1994. C UPDATED --JANUARY 1995. DEFINE X = 0 CASE AS 0 C UPDATED --APRIL 1995. SHAPE PARAMETER 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.0.0)GOTO50 GOTO90 50 CONTINUE WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') CDF=0.0 RETURN 90 CONTINUE 4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT') 5 FORMAT(' TO THE LGNCDF SUBROUTINE IS NEGATIVE *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C C-----START POINT----------------------------------------------------- C CDF=0.0 IF(X.EQ.0.0)RETURN IF(SD.NE.1.0)GOTO1000 ARG=ALOG(X) CALL NORCDF(ARG,CDF) GOTO9999 C 10000 CONTINUE ARG=ALOG(X)/SD CALL NORCDF(ARG,CDF) GOTO9999 C 9999 CONTINUE RETURN END SUBROUTINE LGNCHA(X,SD,HAZ) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE HAZARD C FUNCTION VALUE FOR THE LOGNORMAL C DISTRIBUTION. C THE LOGNORMAL DISTRIBUTION USED C HEREIN HAS MEAN = SQRT(E) = 1.64872127 C AND STANDARD DEVIATION = SQRT(E*(E-1)) = 2.16119742. C THIS DISTRIBUTION IS DEFINED FOR ALL POSITIVE X C AND HAS THE PROBABILITY DENSITY FUNCTION C F(X) = (1/(X*SQRT(2*PI))) * EXP(-ALOG(X)*ALOG(X)/2) C THE LOGNORMAL DISTRIBUTION USED HEREIN C IS THE DISTRIBUTION OF THE VARIATE X = EXP(Z) WHERE C THE VARIATE Z IS NORMALLY DISTRIBUTED C WITH MEAN = 0 AND STANDARD DEVIATION = 1. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE C AT WHICH THE CUMULATIVE HAZARD C FUNCTION IS TO BE EVALUATED. C X SHOULD BE POSITIVE. C OUTPUT ARGUMENTS--HAZ = THE SINGLE PRECISION CUMULATIVE HAZARD C FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION CUMULATIVE HAZARD C FUNCTION VALUE FOR THE LOGNORMAL C DISTRIBUTION WITH MEAN = SQRT(E) = 1.64872127 C AND STANDARD DEVIATION = SQRT(E*(E-1)) = 2.16119742. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE POSITIVE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN. C REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--1, 1970, PAGES 112-136. C --CRAMER, MATHEMATICAL METHODS OF STATISTICS, C 1946, PAGES 219-220. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-975-2855 C ORIGINAL VERSION--APRIL 1998. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DSD DOUBLE PRECISION DCDF DOUBLE PRECISION DHAZ C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C--------------------------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(X.LT.0.0)GOTO50 GOTO90 50 CONTINUE WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') HAZ=0.0 RETURN 90 CONTINUE 4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT') 5 FORMAT(' TO THE LGNHAZ SUBROUTINE IS NEGATIVE *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C C-----START POINT----------------------------------------------------- C HAZ=0.0 IF(X.EQ.0.0)RETURN DX=DBLE(X) DSD=DBLE(SD) CALL NODCDF(DLOG(DX)/DSD,DCDF) DCDF=1.0D0-DCDF CCCCC CALL LGNCDF(X,SD,CDF) CCCCC CDF=1.0-CDF IF(DCDF.GT.0.0D0)THEN DHAZ=-DLOG(DCDF) HAZ=REAL(DHAZ) ELSE HAZ=0.0 WRITE(ICOUT,901)X CALL DPWRST('XXX','BUG') ENDIF 901 FORMAT('****ERROR FROM LGNHAZ: FOR X = ',E15.7,' THE CDF ', 1'VALUE IS ESSENTIALLY 1.') C 9999 CONTINUE RETURN END SUBROUTINE LGNHAZ(X,SD,HAZ) C C PURPOSE--THIS SUBROUTINE COMPUTES THE LOGNORMAL C FUNCTION VALUE FOR THE LOGNORMAL C DISTRIBUTION. C THE LOGNORMAL DISTRIBUTION USED C HEREIN HAS MEAN = SQRT(E) = 1.64872127 C AND STANDARD DEVIATION = SQRT(E*(E-1)) = 2.16119742. C THIS DISTRIBUTION IS DEFINED FOR ALL POSITIVE X C AND HAS THE PROBABILITY DENSITY FUNCTION C F(X) = (1/(X*SQRT(2*PI))) * EXP(-ALOG(X)*ALOG(X)/2) C THE LOGNORMAL DISTRIBUTION USED HEREIN C IS THE DISTRIBUTION OF THE VARIATE X = EXP(Z) WHERE C THE VARIATE Z IS NORMALLY DISTRIBUTED C WITH MEAN = 0 AND STANDARD DEVIATION = 1. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE C AT WHICH THE HAZARD C FUNCTION IS TO BE EVALUATED. C X SHOULD BE POSITIVE. C OUTPUT ARGUMENTS--HAZ = THE SINGLE PRECISION HAZARD C FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION HAZARD C FUNCTION VALUE PDF FOR THE LOGNORMAL C DISTRIBUTION WITH MEAN = SQRT(E) = 1.64872127 C AND STANDARD DEVIATION = SQRT(E*(E-1)) = 2.16119742. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE POSITIVE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN. C REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--1, 1970, PAGES 112-136. C --CRAMER, MATHEMATICAL METHODS OF STATISTICS, C 1946, PAGES 219-220. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-975-2855 C ORIGINAL VERSION--APRIL 1998. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DXLOG DOUBLE PRECISION DHAZ DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DTERM4 C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT 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)GOTO50 GOTO90 50 CONTINUE WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') HAZ=0.0 RETURN 90 CONTINUE 4 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT') 5 FORMAT(' TO THE LGNHAZ SUBROUTINE IS NEGATIVE *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C C-----START POINT----------------------------------------------------- C HAZ=0.0 IF(X.EQ.0.0)RETURN CCCCC CALL LGNCDF(X,SD,CDF) CCCCC CDF=1.0-CDF CCCCC IF(CDF.GT.0.0)THEN CCCCC CALL LGNPDF(X,SD,PDF) CCCCC HAZ=PDF/CDF DX=DBLE(X) DXLOG=DLOG(DX) DTERM1=-DXLOG/DBLE(SD) CALL NODCDF(DTERM1,DTERM2) IF(DTERM2.NE.0.0D0)THEN DTERM3=DXLOG/DBLE(SD) CALL NODPDF(DTERM3,DTERM4) DHAZ=1.D0/(DX*DBLE(SD))*DTERM4/DTERM2 HAZ=REAL(DHAZ) ELSE HAZ=0.0 WRITE(ICOUT,901)X CALL DPWRST('XXX','BUG') ENDIF 901 FORMAT('****ERROR FROM LGNHAZ: FOR X = ',E15.7,' THE CDF ', 1'VALUE IS ESSENTIALLY 1.') C 9999 CONTINUE RETURN END SUBROUTINE LGNPDF(X,SD,PDF) CCCCC SUBROUTINE LGNPDF(X,PDF) CCCCC APRIL 1995. ADD SD PARAMETER (THIS IS SHAPE PARAMETER FOR CCCCC LOGNORMAL). C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE LOGNORMAL C DISTRIBUTION. C THE LOGNORMAL DISTRIBUTION USED C HEREIN HAS MEAN = SQRT(E) = 1.64872127 C AND STANDARD DEVIATION = SQRT(E*(E-1)) = 2.16119742. C THIS DISTRIBUTION IS DEFINED FOR ALL POSITIVE X C AND HAS THE PROBABILITY DENSITY FUNCTION C F(X) = (1/(X*SQRT(2*PI))) * EXP(-ALOG(X)*ALOG(X)/2) C THE LOGNORMAL DISTRIBUTION USED HEREIN C IS THE DISTRIBUTION OF THE VARIATE X = EXP(Z) WHERE C THE VARIATE Z IS NORMALLY DISTRIBUTED C WITH MEAN = 0 AND STANDARD DEVIATION = 1. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE C AT WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C X SHOULD BE POSITIVE. C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY C FUNCTION VALUE PDF FOR THE LOGNORMAL C DISTRIBUTION WITH MEAN = SQRT(E) = 1.64872127 C AND STANDARD DEVIATION = SQRT(E*(E-1)) = 2.16119742. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE POSITIVE. C OTHER DATAPAC SUBROUTINES NEEDED--NORPDF. C FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN. C REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--1, 1970, PAGES 112-136. C --CRAMER, MATHEMATICAL METHODS OF STATISTICS, C 1946, PAGES 219-220. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-975-2855 C ORIGINAL VERSION--APRIL 1994. C UPDATED --JANUARY 1995. X=0 CASE EXPLICITLY 0 C UPDATED --APRIL 1995. SUPPORT SHAPE PARAMETER 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.0.0)GOTO50 GOTO90 50 CONTINUE WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') PDF=0.0 RETURN 90 CONTINUE 4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT') 5 FORMAT(' TO THE LGNPDF SUBROUTINE IS NEGATIVE *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C C-----START POINT----------------------------------------------------- C PDF=0.0 IF(X.EQ.0.0)RETURN IF(SD.NE.1.0)GOTO1000 ARG=ALOG(X) CALL NORPDF(ARG,PDF) PDF=(1.0/X)*PDF GOTO9999 C 1000 CONTINUE ARG=ALOG(X)/SD CALL NORPDF(ARG,ARG2) PDF=(1.0/(SD*X))*ARG2 GOTO9999 C 9999 CONTINUE RETURN END SUBROUTINE LGNPPF(P,SD,PPF) CCCCC SUBROUTINE LGNPPF(P,PPF) CCCCC APRIL 1995. SUPPORT SCALE PARAMETER C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE LOGNORMAL C DISTRIBUTION. C THE LOGNORMAL DISTRIBUTION USED C HEREIN HAS MEAN = SQRT(E) = 1.64872127 C AND STANDARD DEVIATION = SQRT(E*(E-1)) = 2.16119742. C THIS DISTRIBUTION IS DEFINED FOR ALL POSITIVE X C AND HAS THE PROBABILITY DENSITY FUNCTION C F(X) = (1/(X*SQRT(2*PI))) * EXP(-ALOG(X)*ALOG(X)/2) C THE LOGNORMAL DISTRIBUTION USED HEREIN C IS THE DISTRIBUTION OF THE VARIATE X = EXP(Z) WHERE C THE VARIATE Z IS NORMALLY DISTRIBUTED C WITH MEAN = 0 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 (EXCLUSIVELY) C AND 1.0 (EXCLUSIVELY)) C AT WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. C OUTPUT ARGUMENTS--PPF = THE SINGLE PRECISION PERCENT C POINT FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION . C VALUE PPF FOR THE LOGNORMAL DISTRIBUTION C WITH MEAN = SQRT(E) = 1.64872127 C AND STANDARD DEVIATION = SQRT(E*(E-1)) = 2.16119742. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--P SHOULD BE BETWEEN 0.0 (EXCLUSIVELY) C AND 1.0 (EXCLUSIVELY). C OTHER DATAPAC SUBROUTINES NEEDED--NORPPF. C FORTRAN LIBRARY SUBROUTINES NEEDED--EXP. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN. C REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--1, 1970, PAGES 112-136. C --CRAMER, MATHEMATICAL METHODS OF STATISTICS, C 1946, PAGES 219-220. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-921-2315 C ORIGINAL VERSION--APRIL 1994. C UPDATED --JANUARY 1995. C UPDATED --APRIL 1995. SUPPORT SCALE PARAMETER C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C--------------------------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(P.LT.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 ') PPF=0.0 RETURN 90 CONTINUE 1 FORMAT( 1'***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO THE LGNPPF') 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 PPF=0.0 IF(P.EQ.0.0)RETURN IF(SD.NE.1.0)GOTO1000 CALL NORPPF(P,PPF) PPF=EXP(PPF) GOTO9999 C 1000 CONTINUE CALL NORPPF(P,PPF) PPF=EXP(PPF*SD) GOTO9999 C 9999 CONTINUE RETURN END SUBROUTINE LGNRAN(N,SIGMA,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE LOGNORMAL DISTRIBUTION. C THE PROTOTYPE LOGNORMAL DISTRIBUTION USED C HEREIN HAS MEAN = SQRT(E) = 1.64872127 C AND STANDARD DEVIATION = SQRT(E*(E-1)) = 2.16119742. C THIS DISTRIBUTION IS DEFINED FOR ALL POSITIVE X C AND HAS THE PROBABILITY DENSITY FUNCTION C F(X) = (1/(X*SQRT(2*PI))) * EXP(-ALOG(X)*ALOG(X)/2) C THE PROTOTYPE LOGNORMAL DISTRIBUTION USED HEREIN C IS THE DISTRIBUTION OF THE VARIATE X = EXP(Z) WHERE C THE VARIATE Z IS NORMALLY DISTRIBUTED C WITH MEAN = 0 AND STANDARD DEVIATION = 1. 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 LOGNORMAL DISTRIBUTION C WITH MEAN = SQRT(E) = 1.64872127 C AND STANDARD DEVIATION = SQRT(E*(E-1)) = 2.16119742. 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, EXP. 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 --CRAMER, MATHEMATICAL METHODS OF STATISTICS, C 1946, PAGES 219-220. C --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--1, 1970, PAGES 112-136. C --HASTINGS AND PEACOCK, STATISTICAL C DISTRIBUTIONS--A HANDBOOK FOR C STUDENTS AND PRACTITIONERS, 1975, C PAGE 88. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--82.6 C ORIGINAL VERSION--NOVEMBER 1975. C UPDATED --JULY 1976. C UPDATED --DECEMBER 1981. C UPDATED --MAY 1982. C UPDATED --APRIL 2003. ADD SHAPE PARAMETER SIGMA 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'LGNRAN 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 C GENERATE N LOGNORMAL RANDOM NUMBERS C USING THE DEFINITION THAT C A LOGNORMAL VARIATE C EQUALS AN EXPONETIATED NORMAL VARIATE. C DO400I=1,N X(I)=EXP(SIGMA*X(I)) 400 CONTINUE C RETURN END SUBROUTINE LIBFD1(IHLF1,IHLF2,I1,I2,ITYPE, 1IFUNZ1,IFUNZ2,IDERZ1,IDERZ2) C C PURPOSE--COMPUTE DERIVATIVES FOR C SQUARE ROOT, EXPONENTIAL, AND LOGS. C C ORIGINAL VERSION--JANUARY 1979. C UPDATED --FEBRUARY 1979. C UPDATED --JANUARY 1981. C C--------------------------------------------------------------------- C CHARACTER*4 IHLF1 CHARACTER*4 IHLF2 CHARACTER*4 ITYPE CHARACTER*4 IFUNZ1 CHARACTER*4 IFUNZ2 CHARACTER*4 IDERZ1 CHARACTER*4 IDERZ2 C DIMENSION IFUNZ1(*) DIMENSION IFUNZ2(*) DIMENSION IDERZ1(*) DIMENSION IDERZ2(*) C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C I1P1=I1+1 I1P2=I1+2 C IF(IHLF1.EQ.'SQRT'.AND.IHLF2.EQ.' ')GOTO510 IF(IHLF1.EQ.'EXP '.AND.IHLF2.EQ.' ')GOTO520 IF(IHLF1.EQ.'ALOG'.AND.IHLF2.EQ.' ')GOTO530 IF(IHLF1.EQ.'ALOG'.AND.IHLF2.EQ.'E ')GOTO530 IF(IHLF1.EQ.'ALOG'.AND.IHLF2.EQ.'10 ')GOTO540 IF(IHLF1.EQ.'LOG '.AND.IHLF2.EQ.' ')GOTO530 IF(IHLF1.EQ.'LOGE'.AND.IHLF2.EQ.' ')GOTO530 IF(IHLF1.EQ.'LOG1'.AND.IHLF2.EQ.'0 ')GOTO540 C C TREAT THE SQUARE ROOT CASE C 510 CONTINUE I2=I2+1 IDERZ1(I2)='0 ' IDERZ2(I2)=' ' I2=I2+1 IDERZ1(I2)='. ' IDERZ2(I2)=' ' I2=I2+1 IDERZ1(I2)='5 ' IDERZ2(I2)=' ' I2=I2+1 IDERZ1(I2)='* ' IDERZ2(I2)=' ' I2=I2+1 IDERZ1(I2)=IFUNZ1(I1P1) IDERZ2(I2)=IFUNZ2(I1P1) IF(ITYPE.EQ.'EXP ')I2=I2+1 IF(ITYPE.EQ.'EXP ')IDERZ1(I2)=IFUNZ1(I1P2) IF(ITYPE.EQ.'EXP ')IDERZ2(I2)=IFUNZ2(I1P2) I2=I2+1 IDERZ1(I2)='** ' IDERZ2(I2)=' ' I2=I2+1 IDERZ1(I2)='( ' IDERZ2(I2)=' ' I2=I2+1 IDERZ1(I2)='- ' IDERZ2(I2)=' ' I2=I2+1 IDERZ1(I2)='0 ' IDERZ2(I2)=' ' I2=I2+1 IDERZ1(I2)='. ' IDERZ2(I2)=' ' I2=I2+1 IDERZ1(I2)='5 ' IDERZ2(I2)=' ' I2=I2+1 IDERZ1(I2)=') ' IDERZ2(I2)=' ' IF(ITYPE.EQ.'EXP ')GOTO980 GOTO985 C C TREAT THE EXPONENTIAL CASE C 520 CONTINUE I2=I2+1 IDERZ1(I2)='EXP ' IDERZ2(I2)=' ' I2=I2+1 IDERZ1(I2)='( ' IDERZ2(I2)=' ' I2=I2+1 IDERZ1(I2)=IFUNZ1(I1P1) IDERZ2(I2)=IFUNZ2(I1P1) IF(ITYPE.EQ.'EXP ')I2=I2+1 IF(ITYPE.EQ.'EXP ')IDERZ1(I2)=IFUNZ1(I1P2) IF(ITYPE.EQ.'EXP ')IDERZ2(I2)=IFUNZ2(I1P2) I2=I2+1 IDERZ1(I2)=') ' IDERZ2(I2)=' ' IF(ITYPE.EQ.'EXP ')GOTO980 GOTO985 C C TREAT THE NATURAL LOGARITHM CASE C 530 CONTINUE I2=I2+1 IDERZ1(I2)='( ' IDERZ2(I2)=' ' I2=I2+1 IDERZ1(I2)='1 ' IDERZ2(I2)=' ' I2=I2+1 IDERZ1(I2)='/ ' IDERZ2(I2)=' ' I2=I2+1 IDERZ1(I2)='( ' IDERZ2(I2)=' ' I2=I2+1 IDERZ1(I2)=IFUNZ1(I1P1) IDERZ2(I2)=IFUNZ2(I1P1) IF(ITYPE.EQ.'EXP ')I2=I2+1 IF(ITYPE.EQ.'EXP ')IDERZ1(I2)=IFUNZ1(I1P2) IF(ITYPE.EQ.'EXP ')IDERZ2(I2)=IFUNZ2(I1P2) I2=I2+1 IDERZ1(I2)=') ' IDERZ2(I2)=' ' I2=I2+1 IDERZ1(I2)=') ' IDERZ2(I2)=' ' IF(ITYPE.EQ.'EXP ')GOTO980 GOTO985 C C TREAT THE LOGARITHM (TO THE BASE 10) CASE C 540 CONTINUE I2=I2+1 IDERZ1(I2)='( ' IDERZ2(I2)=' ' I2=I2+1 IDERZ1(I2)='1 ' IDERZ2(I2)=' ' I2=I2+1 IDERZ1(I2)='/ ' IDERZ2(I2)=' ' I2=I2+1 IDERZ1(I2)='( ' IDERZ2(I2)=' ' I2=I2+1 IDERZ1(I2)=IFUNZ1(I1P1) IDERZ2(I2)=IFUNZ2(I1P1) IF(ITYPE.EQ.'EXP ')I2=I2+1 IF(ITYPE.EQ.'EXP ')IDERZ1(I2)=IFUNZ1(I1P2) IF(ITYPE.EQ.'EXP ')IDERZ2(I2)=IFUNZ2(I1P2) I2=I2+1 IDERZ1(I2)=') ' IDERZ2(I2)=' ' I2=I2+1 IDERZ1(I2)=') ' IDERZ2(I2)=' ' I2=I2+1 IDERZ1(I2)='* ' IDERZ2(I2)=' ' I2=I2+1 IDERZ1(I2)='0 ' IDERZ2(I2)=' ' I2=I2+1 IDERZ1(I2)='. ' IDERZ2(I2)=' ' I2=I2+1 IDERZ1(I2)='4 ' IDERZ2(I2)=' ' I2=I2+1 IDERZ1(I2)='3 ' IDERZ2(I2)=' ' I2=I2+1 IDERZ1(I2)='4 ' IDERZ2(I2)=' ' I2=I2+1 IDERZ1(I2)='2 ' IDERZ2(I2)=' ' I2=I2+1 IDERZ1(I2)='9 ' IDERZ2(I2)=' ' I2=I2+1 IDERZ1(I2)='4 ' IDERZ2(I2)=' ' I2=I2+1 IDERZ1(I2)='4 ' IDERZ2(I2)=' ' I2=I2+1 IDERZ1(I2)='8 ' IDERZ2(I2)=' ' I2=I2+1 IDERZ1(I2)='1 ' IDERZ2(I2)=' ' I2=I2+1 IDERZ1(I2)='9 ' IDERZ2(I2)=' ' IF(ITYPE.EQ.'EXP ')GOTO980 GOTO985 C 980 CONTINUE 985 CONTINUE C RETURN END SUBROUTINE LIMITS( A, B, INFIN, LOWER, UPPER ) DOUBLE PRECISION A, B, LOWER, UPPER, PHI INTEGER INFIN LOWER = 0.0D0 UPPER = 1.0D0 IF ( INFIN .GE. 0 ) THEN IF ( INFIN .NE. 0 ) LOWER = PHI(A) IF ( INFIN .NE. 1 ) UPPER = PHI(B) ENDIF C RETURN END SUBROUTINE LINEAR(IT,I1,I2,XS,YS,WH,WV,N,XMAXHF,I3,I4, 1ALPHA,BETA,PRED,RES,ISUBRO,IBUGA3,IERROR) C C PURPOSE--CARRY OUT A LEAST SQUARES WEIGHTED LINEAR 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 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--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(*) 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='LINE' ISUBN2='AR ' C IERROR='NO' C IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'NEAR')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF LINEAR--') 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 LINEAR--') 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 LINEAR--') 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 LINEAR--') 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 LINEAR--') 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 ** LINEAR 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 BETA=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 LINEAR--') 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 SUMX=0.0 SUMY=0.0 SUMW=0.0 DO1320I=I1,I2 W=WH(I)*WV(I) SUMX=SUMX+W*XS(I) SUMY=SUMY+W*YS(I) SUMW=SUMW+W 1320 CONTINUE XBAR=SUMX/SUMW YBAR=SUMY/SUMW C SUM1=0.0 SUM2=0.0 DO1330I=I1,I2 W=WH(I)*WV(I) DELX=XS(I)-XBAR DELY=YS(I)-YBAR SUM1=SUM1+W*DELX*DELY SUM2=SUM2+W*DELX**2 1330 CONTINUE BETA=0.0 IF(SUM2.NE.0.0)BETA=SUM1/SUM2 ALPHA=YBAR-BETA*XBAR C DO1340I=I3,I4 PRED(I)=ALPHA+BETA*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.'NEAR')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF LINEAR--') 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,BETA 9040 FORMAT('ALPHA,BETA = ',2E15.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 LINFIT(Y,X,N, 1ALPHA,BETA,XRESSD,XRESDF,CCXY,SDALPH,SDBETA,CCALBE, 1ISUBRO,IBUGA3,IERROR) CCCCC THE ABOVE ARGUMENT LIST WAS AUGMENTED DECEMBER 1993 C C PURPOSE--CARRY OUT A LEAST SQUARES LINEAR FIT C OF THE DATA IN Y(.) AND X(.). C AFTER THE FIT IS DONE, COMPUTE PREDICTED VALUES, C RESIDUALS, RESIDUAL STANDARD DEVIATION, C RESIDUAL DEGREES OF FREEDOM. C ALSO COMPUTE THE CORRELATION COEFFICIENT. 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/SYTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--88/3 C ORIGINAL VERSION--MARCH 1988 C UPDATED --DECEMBER 1993 SDA0, SDA1, CORR01 C UPDATED --DECEMBER 1993 PROTECT RESSD/DF 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 Y(*) DIMENSION X(*) CCCCC DIMENSION PRED(*) DUE TO COMPLEXITIES WITH DP'S PRED & RES CCCCC AND TEMP STORAGE CCCCC DIMENSION RES(*) DUE TO COMPLEXITIES WITH DP'S PRED & RES CCCCC AND TEMP STORAGE CCCCC DIMENSION SDPRED(*) CCCCC DIMENSION SDRESV(*) 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='LINF' ISUBN2='IT ' C IERROR='NO' C AN=N C IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'NFIT')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF LINFIT--') 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,60)N 60 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') IF(N.LE.0)GOTO63 DO61I=1,N WRITE(ICOUT,62)I,Y(I),X(I) 62 FORMAT('I,Y(I),X(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 LINFIT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,112) 112 FORMAT(' THE INPUT SAMPLE SIZE,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,113) 113 FORMAT(' FOR WHICH A LINEAR FIT IS TO BE CARRIED OUT,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,114) 114 FORMAT(' 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 SAMPLE SIZE N = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 119 CONTINUE C C *********************************************** C ** STEP 11-- ** C ** CARRY OUT A LEAST SQUARES ** C ** LINEAR FIT ** C *********************************************** C SUMX=0.0 SUMY=0.0 DO1120I=1,N SUMX=SUMX+X(I) SUMY=SUMY+Y(I) 1120 CONTINUE XBAR=SUMX/AN YBAR=SUMY/AN C SUMXX=0.0 SUMYY=0.0 SUMXY=0.0 DO1130I=1,N DELX=X(I)-XBAR DELY=Y(I)-YBAR SUMXX=SUMXX+DELX**2 SUMYY=SUMYY+DELY**2 SUMXY=SUMXY+DELX*DELY 1130 CONTINUE BETA=0.0 IF(SUMXX.NE.0.0)BETA=SUMXY/SUMXX ALPHA=YBAR-BETA*XBAR C CCCCC DO1140I=1,N CCCCC PRED(I)=ALPHA+BETA*X(I) CCCCC RES(I)=Y(I)-PRED(I) C1140 CONTINUE C XRESDF=N-2 SUM=0.0 DO1150I=1,N SUM=SUM+(Y(I)-(ALPHA+BETA*X(I)))**2 1150 CONTINUE RESVAR=0.0 IF(XRESDF.GT.0.0)RESVAR=SUM/XRESDF XRESSD=0.0 IF(RESVAR.GT.0.0)XRESSD=SQRT(RESVAR) C C *********************************************** C ** STEP 12-- ** C ** COMPUTE CORRELATION COEFFICIENT (X,Y) ** C *********************************************** C ADENOM=0.0 IF(SUMXX.GT.0.0.AND.SUMYY.GT.0.0)ADENOM=SQRT(SUMXX)*SQRT(SUMYY) CCXY=0.0 IF(ADENOM.GT.0.0)CCXY=SUMXY/ADENOM C C ************************************ C ** STEP 13-- ** C ** COMPUTE SD OF ESTIMATES ** C ** AND CORR(ESTIMATES) ** C ************************************ C SDALPH=0.0 SDBETA=0.0 CCALBE=0.0 SUM=0.0 DO1200I=1,N SUM=SUM+X(I)*X(I) 1200 CONTINUE IF(SUMXX.GT.0.0)THEN SDALPH=XRESSD*SQRT(SUM/(AN*SUMXX)) SDBETA=XRESSD*SQRT(1/SUMXX) ENDIF IF(SUM.GT.0.0)THEN ANUM=(-XBAR) ADENOM=SQRT(SUM/AN) CCALBE=ANUM/ADENOM ENDIF C C ******************************* C ** STEP 14-- ** C ** COMPUTE SD(PRED VALUES) ** C ******************************* C CCCCC DO1300I=1,N CCCCC TERM1=1.0/AN CCCCC TERM2=0.0 CCCCC IF(SUMXX.GT.0.0)TERM2=((X(I)-XBAR)**2)/SUMXX CCCCC SDPRED(I)=SDRES*SQRT(TERM1+TERM2) CCCCC SDRESV(I)=SDRES*SQRT(1.0-TERM1-TERM2) C1300 CONTINUE C GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'NFIT')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF LINFIT--') 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,9020)N 9020 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') IF(N.LE.0)GOTO9023 DO9021I=1,N WRITE(ICOUT,9022)I,Y(I),X(I) 9022 FORMAT('I,Y(I),X(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 9021 CONTINUE 9023 CONTINUE CCCCC IF(N.LE.0)GOTO9025 CCCCC DO9026I=1,N CCCCC WRITE(ICOUT,9027)I,Y(I),X(I),SDPRED(I),SDRESV(I) C9027 FORMAT('I,Y(I),X(I),SDPRED(I),SDRESV(I) = ',I8,4E15.7) CCCCC CALL DPWRST('XXX','BUG ') C9026 CONTINUE C9025 CONTINUE WRITE(ICOUT,9031)YBAR,XBAR 9031 FORMAT('YBAR,XBAR = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9032)SUMXX,SUMYY,SUMXY 9032 FORMAT('SUMXX,SUMYY,SUMXY = ',3E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9036)ALPHA,BETA 9036 FORMAT('ALPHA,BETA = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9037)XRESSD,XRESDF 9037 FORMAT('XRESSD,XRESDF = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9038)ADENOM,CCXY 9038 FORMAT('ADENOM,CCXY = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9039)SDALPH,SDBETA,CCALBE 9039 FORMAT('SDALPH,SDBETA,CCALBE = ',3E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE LINFI2(Y,X,N, 1ALPHA,BETA, 1ISUBRO,IBUGA3,IERROR) C C PURPOSE--CARRY OUT A LEAST SQUARES LINEAR FIT C OF THE DATA IN Y(.) AND X(.). C THIS IS A MODIFIED VERSION OF LINFIT. THE C DISTINCTION IS THAT THIS VERSION HAS BEEN PRUNED C DOWN TO ONLY GENERATE THE PARAMETER ESTIMATES C (USED BY PPCC PLOT FOR ESTIMATES OF LOCATION AND C SCALE). 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/SYTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004/5 C ORIGINAL VERSION--MAY 2004 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 Y(*) 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='LINF' ISUBN2='I2 ' C IERROR='NO' C AN=N C IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'NFI2')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF LINFI2--') 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,60)N 60 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') IF(N.LE.0)GOTO63 DO61I=1,N WRITE(ICOUT,62)I,Y(I),X(I) 62 FORMAT('I,Y(I),X(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.LT.1)THEN ALPHA=0.0 BETA=1.0 GOTO9000 ENDIF C C *********************************************** C ** STEP 11-- ** C ** CARRY OUT A LEAST SQUARES ** C ** LINEAR FIT ** C *********************************************** C SUMX=0.0 SUMY=0.0 DO1120I=1,N SUMX=SUMX+X(I) SUMY=SUMY+Y(I) 1120 CONTINUE XBAR=SUMX/AN YBAR=SUMY/AN C SUMXX=0.0 SUMYY=0.0 SUMXY=0.0 DO1130I=1,N DELX=X(I)-XBAR DELY=Y(I)-YBAR SUMXX=SUMXX+DELX**2 SUMYY=SUMYY+DELY**2 SUMXY=SUMXY+DELX*DELY 1130 CONTINUE BETA=0.0 IF(SUMXX.NE.0.0)BETA=SUMXY/SUMXX ALPHA=YBAR-BETA*XBAR C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'NFI2')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF LINFI2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9031)YBAR,XBAR 9031 FORMAT('YBAR,XBAR = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9032)SUMXX,SUMYY,SUMXY 9032 FORMAT('SUMXX,SUMYY,SUMXY = ',3E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9036)ALPHA,BETA 9036 FORMAT('ALPHA,BETA = ',2E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE LININT(Y,X,N,X2,N2,IWRITE,Y2,IBUGG3,ISUBRO,IERROR) C C PURPOSE--COMPUTE LINEAR INTERPOLATION OF A VARIABLE C (GENERATE INTERPOLATED POINTS). C INPUT ARGUMENTS--Y = SINGLE PRECISION VARIABLE C CONTAINING THE ORIGINAL C VERTICAL AXIS DATA POINTS. C --X = SINGLE PRECISION VARIABLE C CONTAINING THE ORIGINAL C HORIZONTAL AXIS DATA POINTS. C --X2 = SINGLE PRECISION VARIABLE C CONTAINING THE DESIRED C HORIZONTAL AXIS INTERPOLATION C POINTS. C OUTPUT ARGUMENTS--Y2 = SINGLE PRECISION VARIABLE C CONTAINING THE COMPUTED C VERTICAL AXIS INTERPOLATION C POINTS. C NOTE--IT IS PROBABLY NOT PERMISSIBLE TO HAVE THE OUTPUT VECTOR Y2(.) C BEING IDENTICAL TO THE INPUT VECTOR Y(.) C NOTE--THIS SUBROUTINE DOES NOT ASSUME THAT THE INPUT C DATA IS ALREADY SORTED ACCORDING TO THE C HORIZONTAL AXIS VARIABLE. C SUCH SORTING IS DOEN HEREIN. C CAUTION--THE INPUT VECTORS Y AND X ARE SORTED HEREIN C AND SO MAY BE DIFFERENT UPON LEAVING THIS SUBROUTINE C THAN UPON ENTERING THIS SUBROUTINE. 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--94/5 C ORIGINAL VERSION--MAY 1994. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGG3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION Y(*) DIMENSION X(*) DIMENSION X2(*) DIMENSION Y2(*) C DIMENSION YTEMP(MAXOBV) DIMENSION YDIST(MAXOBV) DIMENSION XDIST(MAXOBV) C INCLUDE 'DPCOZZ.INC' INCLUDE 'DPCOZ2.INC' EQUIVALENCE (G2RBAG(IGAR11),YTEMP(1)) EQUIVALENCE (G2RBAG(IGAR12),YDIST(1)) EQUIVALENCE (G2RBAG(IGAR13),XDIST(1)) CCCCC END CHANGE 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='LINI' ISUBN2='NT ' C IERROR='NO' C IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'NINT')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF LININT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)N 52 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,Y(I),X(I) 56 FORMAT('I,Y(I),X(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE WRITE(ICOUT,62)N2 62 FORMAT('N2 = ',I8) CALL DPWRST('XXX','BUG ') DO65I=1,N2 WRITE(ICOUT,66)I,X2(I) 66 FORMAT('I,X2(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 65 CONTINUE 90 CONTINUE C C **************************************** C ** STEP 11-- ** C ** SORT THE INPUT DATA ACCORDING ** C ** TO THE HORIZONTAL AXIS VARIABLE ** C **************************************** C CALL SORTC(X,Y,N,X,Y) C C ******************************************************* C ** STEP 12-- ** C ** DETERMINE THE NUMBER OF DISTINCT X VALUES ** C ******************************************************* C ISTEPN='12' IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'NINT') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NDIST=0 DO1210I=1,N IF(NDIST.EQ.0)GOTO1220 DO1215I2=1,NDIST IF(X(I).EQ.XDIST(I2))GOTO1210 1215 CONTINUE 1220 CONTINUE NDIST=NDIST+1 XDIST(NDIST)=X(I) 1210 CONTINUE C CALL SORT(XDIST,NDIST,XDIST) C C ***************************************************** C ** STEP 13-- ** C ** IF ALL DISTINCT (THAT IS, NO REPLICATION), ** C ** (THAT IS, HAVE NO REPLICATION), ** C ** THEN COPY OVER Y VALUES. ** C ** IF NOT ALL DISTINCT ** C ** (THAT IS, HAVE SOME REPLICATION), ** C ** THEN COMPUTE A MEAN VALUE OVER THE REPLICATES ** C ** AND TREAT THAT AS THE COMMON VALUE. ** C ** THE CORE OF THE INTERPOLATION CODE ** C ** IS EXPECTING SORTED, DISTINCT X VALUES. ** C ***************************************************** C IF(NDIST.EQ.N)GOTO1310 GOTO1320 C 1310 CONTINUE DO1311K=1,NDIST YDIST(K)=Y(K) 1311 CONTINUE GOTO1390 C 1320 CONTINUE DO1321K=1,NDIST TAG=XDIST(K) J=0 DO1322I=1,N IF(X(I).EQ.TAG)GOTO1323 GOTO1322 1323 CONTINUE J=J+1 YTEMP(J)=Y(I) 1322 CONTINUE NI=J CALL MEAN(YTEMP,NI,IWRITE,YMEAN,IBUGG3,IERROR) YDIST(K)=YMEAN 1321 CONTINUE GOTO1390 C 1390 CONTINUE C C ******************************************** C ** STEP 14-- ** C ** COMPUTE INTERPOLATED VALUES ** C ******************************************** C CALL LININ2(YDIST,XDIST,NDIST,X2,N2,Y2,IBUGG3,ISUBRO,IERROR) C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'NINT')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF LININT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)N,N2 9012 FORMAT('N,N2 = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9051)NDIST 9051 FORMAT('NDIST = ',I8) CALL DPWRST('XXX','BUG ') DO9052I=1,NDIST WRITE(ICOUT,9053)I,XDIST(I),YDIST(I) 9053 FORMAT('I,XDIST(I),YDIST(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 9052 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE LININ2(Y,X,N,X2,N2,Y2,IBUGG3,ISUBRO,IERROR) C C PURPOSE--COMPUTE LINEAR INTERPOLATION OF A VARIABLE C (GENERATE INTERPOLATED POINTS). C INPUT ARGUMENTS--Y = SINGLE PRECISION VARIABLE C CONTAINING THE ORIGINAL C VERTICAL AXIS DATA POINTS. C --X = SINGLE PRECISION VARIABLE C CONTAINING THE ORIGINAL C HORIZONTAL AXIS DATA POINTS. C --X2 = SINGLE PRECISION VARIABLE C CONTAINING THE DESIRED C HORIZONTAL AXIS INTERPOLATION C POINTS. C OUTPUT ARGUMENTS--Y2 = SINGLE PRECISION VARIABLE C CONTAINING THE COMPUTED C VERTICAL AXIS INTERPOLATION C POINTS. C NOTE--IT IS PROBABLY NOT PERMISSIBLE TO HAVE THE OUTPUT VECTOR Y2(.) C BEING IDENTICAL TO THE INPUT VECTOR Y(.) C NOTE--THIS SUBROUTINE DOES NOT ASSUME THAT THE INPUT C DATA IS ALREADY SORTED ACCORDING TO THE C HORIZONTAL AXIS VARIABLE. C SUCH SORTING IS DOEN HEREIN. C CAUTION--THE INPUT VECTORS Y AND X ARE SORTED HEREIN C AND SO MAY BE DIFFERENT UPON LEAVING THIS SUBROUTINE C THAN UPON ENTERING THIS SUBROUTINE. 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--94/5 C ORIGINAL VERSION--MAY L 1994. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IBUGG3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C C DIMENSION Y(*) DIMENSION X(*) DIMENSION X2(*) DIMENSION Y2(*) 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='LINI' ISUBN2='N2 ' C IERROR='NO' C IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'NIN2')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF LININ2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)N 52 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,Y(I),X(I) 56 FORMAT('I,Y(I),X(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE WRITE(ICOUT,62)N2 62 FORMAT('N2 = ',I8) CALL DPWRST('XXX','BUG ') DO65I=1,N2 WRITE(ICOUT,66)I,X2(I) 66 FORMAT('I,X2(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 65 CONTINUE 90 CONTINUE C NM1=N-1 NM2=N-2 C C **************************************** C ** STEP 31-- C ** COMPUTE INTERPOLATION VALUES C **************************************** C DO3100J=1,N2 XT=X2(J) IF(X(1).GT.XT.OR.XT.GT.X(N))GOTO3110 GOTO3119 C 3110 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3111) 3111 FORMAT('***** ERROR IN LININ2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3112) 3112 FORMAT(' AN ATTEMPT WAS MADE TO COMPUTE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3113) 3113 FORMAT(' A SMOOTHED VALUE BEYOND THE RANGE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3114) 3114 FORMAT(' OF THE DATA--SUCH EXTRAPOLATION') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3115) 3115 FORMAT(' IS UNRELIABLE AND NOT PERMITTED.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3116)X(1) 3116 FORMAT(' SMALLEST DATA POINT X(1) = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3117)X(N) 3117 FORMAT(' LARGEST DATA POINT X(N) = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,3118)XT 3118 FORMAT(' ATTEMPTED EXTRAPOLATION POINT = ',E15.7) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 3119 CONTINUE C DO3200I=1,N I2=I IF(X(I).EQ.XT)GOTO3210 IF(X(I).GT.XT)GOTO3220 3200 CONTINUE C 3210 CONTINUE Y2(J)=Y(I2) GOTO3100 C 3220 CONTINUE K1=I2-1 DELX=X(I2)-X(K1) DELY=Y(I2)-Y(K1) SLOPE=DELY/DELX Y2(J)=SLOPE*(XT-X(K1))+Y(K1) C 3100 CONTINUE C C **************************************** C ** STEP 41-- C ** IF CALLED FOR, C ** WRITE OUT INTERPOLATION VALUES C **************************************** C IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'NIN2')GOTO4190 DO4100J=1,N2 WRITE(ICOUT,4110)X2(J),Y2(J) CALL DPWRST('XXX','BUG ') 4110 FORMAT('X2(J),Y2(J) = ',2E15.7) 4100 CONTINUE 4190 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGG3.EQ.'OFF'.AND.ISUBRO.NE.'NIN2')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF LININ2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)N,N2 9012 FORMAT('N,N2 = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9041)N2 9041 FORMAT('N2 = ',I8) CALL DPWRST('XXX','BUG ') DO9042I=1,N2 WRITE(ICOUT,9043)I,X2(I),Y2(I) 9043 FORMAT('I,X2(I),Y2(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 9042 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE LKCDF(X,A,B,BETA,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE LAGRANGE KATZ C DISTRIBUTION WITH SHAPE PARAMETERS A, B, AND BETA. C THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE C INTEGERS X >= 0. C C THE PROBABILITY MASS FUNCTION IS: C p(X;A,B,BETA)= C (A/BETA)/((A/BETA) + (X*B/BETA) + X)* C ((A/BETA)+X*b/BETA+X X)* C BETA**X*(1-BETA)**((A/BETA)+X*B/BETA) C X = 0, 1, 2, 3, ,... C A > 0, B > -BETA, BETA < 1 C C THE CUMULATIVE DISTRIBUTION FUNCTION IS COMPUTED C FROM THE FOLLOWING RECURRENCE RELATION: C C P(X+1) = {(A+B*(X+1)+BETA*X)/(X+1)}*(1-BETA)**(b/BETA)* C PROD[i=1 to X-1][(1 + b/(a+B*X+BETA*i)]*P(X) C WHERE P(0) = (1-BETA)**(A/BETA) AND C P(1) = A*(1-BETA)**(b/BETA)*P(0) C C INPUT ARGUMENTS--X = THE DOUBLE PRECISION VALUE AT C WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C X SHOULD BE A NON-NEGATIVE INTEGER. C --A = THE FIRST SHAPE PARAMETER C --B = THE SECOND SHAPE PARAMETER C --BETA = THE THIRD SHAPE PARAMETER C OUTPUT ARGUMENTS--CDF = THE DOUBLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION FUNCTION C VALUE CDF FOR THE LAGRANGE KATZ DISTRIBUTION WITH C SHAPE PARAMETERS A, B, AND BETA C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE A NON-NEGATIVE INTEGER C --A > 0, B > -BETA, BETA < 1 C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY C DISTRIBUTIONS", BIRKHAUSER, CHAPTER 12. 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/8 C ORIGINAL VERSION--AUGUST 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 C CHECK THE INPUT ARGUMENTS FOR ERRORS C IX=INT(X+0.5D0) IF(IX.LT.0)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') CDF=0.0D0 GOTO9000 ENDIF 4 FORMAT('***** ERROR--THE FIRST ARGUMENT TO LKCDF IS LESS ', 1'THAN 0') C IF(A.LE.0.0D0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)A CALL DPWRST('XXX','BUG ') CDF=0.0D0 GOTO9000 ENDIF 15 FORMAT('***** ERROR--THE SECOND ARGUMENT TO LKCDF IS ', 1'NON-POSITIVE.') C IF(BETA.GE.1.0D0)THEN WRITE(ICOUT,25) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)BETA CALL DPWRST('XXX','BUG ') CDF=0.0D0 GOTO9000 ENDIF 25 FORMAT('***** ERROR--THE FOURTH ARGUMENT TO LKCDF IS GREATER ', 1'THAN OR EQUAL TO 1.') C IF(B.LE.-BETA)THEN WRITE(ICOUT,35) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)B CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)BETA CALL DPWRST('XXX','BUG ') CDF=0.0D0 GOTO9000 ENDIF 35 FORMAT('***** ERROR--THE THIRD ARGUMENT TO LKCDF IS LESS ', 1'THAN OR EQUAL TO -(FOURTH ARGUMENT).') 36 FORMAT('***** THE VALUE OF THE THIRD ARGUMENT IS ',G15.7) 37 FORMAT('***** THE VALUE OF THE FOURTH ARGUMENT IS ',G15.7) C 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) C C USE THE RECURRENCE RELATION (PAGE 243 OF CONSUL AND FAMOYE): C CDF=(1.0D0 - BETA)**(A/BETA) IF(IX.EQ.0)GOTO9000 C DPDF=A*(1.0D0 - BETA)**(B/BETA)*CDF CDF=CDF + DPDF IF(IX.EQ.1)GOTO9000 C DPDFSV=DPDF DTERM1=(B/BETA)*DLOG(1.0D0 - BETA) C DO100I=2,IX DX=DBLE(I) DTERM2=DLOG(A + B*DX + BETA*(DX-1.0D0)) DTERM3=DLOG(DX) IF(DPDFSV.LE.0.0D0)THEN GOTO9000 ELSE DTERM4=DLOG(DPDFSV) ENDIF C IF(I-2.GE.1)THEN DSUM=0.0D0 DO200J=1,I-2 DSUM=DSUM + DLOG(1.0D0 + B/ 1 (A + B*(DX-1.0D0) + BETA*DBLE(J))) 200 CONTINUE ELSE DSUM=0.0D0 ENDIF C DPDF=DEXP(DTERM1 + DTERM2 - DTERM3 + DTERM4 + DSUM) CDF=CDF + DPDF DPDFSV=DPDF 100 CONTINUE C 9000 CONTINUE RETURN END SUBROUTINE LKPDF(X,A,B,BETA,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE LAGRANGE KATZ C DISTRIBUTION WITH SHAPE PARAMETERS A, B, AND BETA. C THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE C INTEGERS X >= 0. C C THE PROBABILITY MASS FUNCTION IS: C p(X;A,B,BETA)= C (A/BETA)/((A/BETA) + (X*B/BETA) + X)* C ((A/BETA)+X*b/BETA+X X)* C BETA**X*(1-BETA)**((A/BETA)+X*B/BETA) C X = 0, 1, 2, 3, ,... C A > 0, B > -BETA, BETA < 1 C C INPUT ARGUMENTS--X = THE DOUBLE PRECISION VALUE AT C WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C X SHOULD BE A NON-NEGATIVE INTEGER. C --A = THE FIRST SHAPE PARAMETER C --B = THE SECOND SHAPE PARAMETER C --BETA = THE THIRD 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 LAGRANGE KATZ DISTRIBUTION WITH C SHAPE PARAMETERS A, B, AND BETA C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE A NON-NEGATIVE INTEGER C --A > 0, B > -BETA, BETA < 1 C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY C DISTRIBUTIONS", BIRKHAUSER, CHAPTER 12. 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/8 C ORIGINAL VERSION--AUGUST 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 C CHECK THE INPUT ARGUMENTS FOR ERRORS C IX=INT(X+0.5D0) IF(IX.LT.0)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') PDF=0.0D0 GOTO9000 ENDIF 4 FORMAT('***** ERROR--THE FIRST ARGUMENT TO LKPDF IS LESS ', 1'THAN 0') C IF(A.LE.0.0D0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)A CALL DPWRST('XXX','BUG ') PDF=0.0D0 GOTO9000 ENDIF 15 FORMAT('***** ERROR--THE SECOND ARGUMENT TO LKPDF IS ', 1'NON-POSITIVE.') C IF(BETA.GE.1.0D0)THEN WRITE(ICOUT,25) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)BETA CALL DPWRST('XXX','BUG ') PDF=0.0D0 GOTO9000 ENDIF 25 FORMAT('***** ERROR--THE FOURTH ARGUMENT TO LKPDF IS GREATER ', 1'THAN OR EQUAL TO 1.') C IF(B.LE.-BETA)THEN WRITE(ICOUT,35) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)B CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)BETA CALL DPWRST('XXX','BUG ') PDF=0.0D0 GOTO9000 ENDIF 35 FORMAT('***** ERROR--THE THIRD ARGUMENT TO LKPDF IS LESS ', 1'THAN OR EQUAL TO -(FOURTH ARGUMENT).') 36 FORMAT('***** THE VALUE OF THE THIRD ARGUMENT IS ',G15.7) 37 FORMAT('***** THE VALUE OF THE FOURTH ARGUMENT IS ',G15.7) C 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) C C USE THE RECURRENCE RELATION (PAGE 243 OF CONSUL AND FAMOYE): C DX=DBLE(IX) DTERM1=A/BETA DTERM2=DX*B/BETA C DTERM3=DLOG(DTERM1) - DLOG(DTERM1 + DTERM2 + DX) DTERM4=DX*DLOG(BETA) DTERM5=(DTERM1+DTERM2)*DLOG(1.0D0 - BETA) DTERM6=DLNGAM(DTERM1 + DTERM2 + DX + 1.0D0) DTERM7=DLNGAM(DTERM1 + DTERM2 + 1.0D0) DTERM8=DLNGAM(DX + 1.0D0) DPDF=DTERM3 + DTERM4 + DTERM5 + DTERM6 - DTERM7 - DTERM8 PDF=DEXP(DPDF) C 9000 CONTINUE RETURN END SUBROUTINE LKPPF(P,A,B,BETA,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE LAGRANGE KATZ C DISTRIBUTION WITH SHAPE PARAMETERS A, B, AND BETA. C THIS DISTRIBUTION IS DEFINED FOR ALL NON-NEGATIVE C INTEGERS X >= 0. C C THE PROBABILITY MASS FUNCTION IS: C p(X;A,B,BETA)= C (A/BETA)/((A/BETA) + (X*B/BETA) + X)* C ((A/BETA)+X*b/BETA+X X)* C BETA**X*(1-BETA)**((A/BETA)+X*B/BETA) C X = 0, 1, 2, 3, ,... C A > 0, B > -BETA, BETA < 1 C C THE CUMULATIVE DISTRIBUTION FUNCTION IS COMPUTED C FROM THE FOLLOWING RECURRENCE RELATION: C C P(X+1) = {(A+B*(X+1)+BETA*X)/(X+1)}*(1-BETA)**(b/BETA)* C PROD[i=1 to X-1][(1 + b/(a+B*X+BETA*i)]*P(X) C WHERE P(0) = (1-BETA)**(A/BETA) AND C P(1) = A*(1-BETA)**(b/BETA)*P(0) C C THE PERCENT POINT FUNCTION IS COMPUTED BY SUMMING C THE CUMULATIVE DISTRIBUTION FUNCTION UNTIL THE C APPROPRIATE PROBABILITY IS REACHED. C C INPUT ARGUMENTS--P = THE DOUBLE PRECISION VALUE AT C WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. C --A = THE FIRST SHAPE PARAMETER C --B = THE SECOND SHAPE PARAMETER C --BETA = THE THIRD SHAPE PARAMETER C OUTPUT ARGUMENTS--PPF = THE DOUBLE PRECISION PERCENT POINT C FUNCTION VALUE. C OUTPUT--THE DOUBLE PRECISION PERCENT POINT FUNCTION C VALUE PPF FOR THE LAGRANGE KATZ DISTRIBUTION WITH C SHAPE PARAMETERS A, B, AND BETA C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--0 <= P < 1 C --A > 0, B > -BETA, BETA < 1 C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY C DISTRIBUTIONS", BIRKHAUSER, CHAPTER 12. 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/8 C ORIGINAL VERSION--AUGUST 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 C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(P.LT.0.0 .OR. P.GE.1.0)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PPF=0.0D0 GOTO9000 ENDIF 4 FORMAT('***** ERROR--THE FIRST ARGUMENT TO LKPPF IS OUTSIDE ', 1'THE (0,1] INTERVAL') C C IF(A.LE.0.0D0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)A CALL DPWRST('XXX','BUG ') PPF=0.0D0 GOTO9000 ENDIF 15 FORMAT('***** ERROR--THE SECOND ARGUMENT TO LKPPF IS ', 1'NON-POSITIVE.') C IF(BETA.GE.1.0D0)THEN WRITE(ICOUT,25) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)BETA CALL DPWRST('XXX','BUG ') PPF=0.0D0 GOTO9000 ENDIF 25 FORMAT('***** ERROR--THE FOURTH ARGUMENT TO LKPPF IS GREATER ', 1'THAN OR EQUAL TO 1.') C IF(B.LE.-BETA)THEN WRITE(ICOUT,35) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)B CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)BETA CALL DPWRST('XXX','BUG ') PPF=0.0D0 GOTO9000 ENDIF 35 FORMAT('***** ERROR--THE THIRD ARGUMENT TO LKPPF IS LESS ', 1'THAN OR EQUAL TO -(FOURTH ARGUMENT).') 36 FORMAT('***** THE VALUE OF THE THIRD ARGUMENT IS ',G15.7) 37 FORMAT('***** THE VALUE OF THE FOURTH ARGUMENT IS ',G15.7) C 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) C C USE THE RECURRENCE RELATION (PAGE 243 OF CONSUL AND FAMOYE): C DCDF=(1.0D0 - BETA)**(A/BETA) IF(DCDF.GE.P)THEN PPF=0.0D0 GOTO9000 ENDIF C DPDF=A*(1.0D0 - BETA)**(B/BETA)*DCDF DCDF=DCDF + DPDF IF(DCDF.GE.P)THEN PPF=1.0D0 GOTO9000 ENDIF C DPDFSV=DPDF DTERM1=(B/BETA)*DLOG(1.0D0 - BETA) C I=1 C 100 CONTINUE I=I+1 IF(DBLE(I).GE.DBLE(I1MACH(9)))THEN WRITE(ICOUT,55) 55 FORMAT('***** ERROR--THE COMPUTED PERCENT POINT VALUE ', 1 'EXCEEDS THE LARGEST MACHINE INTEGER.') CALL DPWRST('XXX','BUG ') PPF=0.0D0 GOTO9000 ENDIF DX=DBLE(I) C DTERM2=DLOG(A + B*DX + BETA*(DX-1.0D0)) DTERM3=DLOG(DX) IF(DPDFSV.LE.0.0D0)THEN PPF=DBLE(I) GOTO9000 ELSE DTERM4=DLOG(DPDFSV) ENDIF C IF(I-2.GE.1)THEN DSUM=0.0D0 DO200J=1,I-2 DSUM=DSUM + DLOG(1.0D0 + B/ 1 (A + B*(DX-1.0D0) + BETA*DBLE(J))) 200 CONTINUE ELSE DSUM=0.0D0 ENDIF C DPDF=DEXP(DTERM1 + DTERM2 - DTERM3 + DTERM4 + DSUM) DCDF=DCDF + DPDF DPDFSV=DPDF IF(DCDF.GE.P)THEN PPF=DBLE(I) GOTO9000 ENDIF GOTO100 C 9000 CONTINUE RETURN END SUBROUTINE LKRAN(N,A,B,BETA,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE LAGRANGE KATZ DISTRIBUTION C WITH SHAPE PARAMETERS A, B, AND BETA. C THE PROBABILITY MASS FUNCTION IS: C C THE PROBABILITY MASS FUNCTION IS: C p(X;A,B,BETA)= C (A/BETA)/((A/BETA) + (X*B/BETA) + X)* C ((A/BETA)+X*b/BETA+X X)* C BETA**X*(1-BETA)**((A/BETA)+X*B/BETA) C X = 0, 1, 2, 3, ,... C A > 0, B > -BETA, BETA < 1 C C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --A = THE SINGLE PRECISION VALUE C OF THE FIRST SHAPE PARAMETER. C --B = THE SINGLE PRECISION VALUE C OF THE SECOND SHAPE PARAMETER. C --BETA = 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 LAGRANGE KATZ DISTRIBUTION C WITH SHAPE PARAMETERS A, B, 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 --A > 0, BETA < 1, B > -BETA C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN, LKPPF 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, CHAPTER 12. 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/8 C ORIGINAL VERSION--AUGUST 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C REAL A REAL B REAL BETA C DOUBLE PRECISION DPPF C DIMENSION X(*) DIMENSION XTEMP(2) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C DATA PI / 3.1415926535 8979323846 E0 / C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF LAGRANGE KATZ') 6 FORMAT(' RANDOM NUMBERS IS NON-POSITIVE') C IF(A.LE.0.0)THEN WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)A CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 11 FORMAT('***** ERROR--THE A PARAMETER FOR THE LAGRANGE KATZ') 12 FORMAT(' RANDOM NUMBERS IS NON-POSITIVE.') C IF(BETA.GE.1.0)THEN WRITE(ICOUT,21) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,22) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)BETA CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 21 FORMAT('***** ERROR--THE BETA PARAMETER FOR THE LAGRANGE KATZ') 22 FORMAT(' RANDOM NUMBERS IS GREATER THAN OR EQUAL TO 1.') C IF(B.LE.-BETA)THEN WRITE(ICOUT,31) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,32) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,48)B CALL DPWRST('XXX','BUG ') WRITE(ICOUT,49)BETA CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 31 FORMAT('***** ERROR--THE B PARAMETER FOR THE LAGRANGE KATZ') 32 FORMAT(' RANDOM NUMBERS IS LESS THAN OR EQUAL TO -BETA.') C 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) 48 FORMAT('***** THE VALUE OF THE B ARGUMENT IS ',G15.7) 49 FORMAT('***** THE VALUE OF THE BETA ARGUMENT IS ',G15.7) C C GENERATE N LAGRANGE KATZ DISTRIBUTION RANDOM NUMBERS USING C THE INVERSION METHOD. C CALL UNIRAN(N,ISEED,X) DO100I=1,N ZTEMP=X(I) CALL LKPPF(DBLE(ZTEMP),DBLE(A),DBLE(B),DBLE(BETA),DPPF) X(I)=REAL(DPPF) 100 CONTINUE C 9999 CONTINUE C RETURN END SUBROUTINE LLGCDF(X,DELTA,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE LOG-LOGISTIC DISTRIBUTION. C THIS DISTRIBUTION IS DEFINED FOR ALL POSITIVE X C AND HAS THE PROBABILITY DENSITY FUNCTION C F(X,DELTA) = DELTA*X**(DELTA-1)/[1+X**DELTA)**2] C THE CUMULATIVE DISTRIBUTION FUNCTION IS C F(X,DELTA) = 1/(1+X**(-DELTA)) C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE C AT WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C X SHOULD BE POSITIVE. C --DELTA = THE POSITIVE SHAPE PARAMETER C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION C FUNCTION VALUE CDF FOR THE LOG-LOGISTIC DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE POSITIVE. C --DELTA SHOULD BE POSITIVE. C LANGUAGE--ANSI FORTRAN. C REFERENCES--"MEASURING SKEWNESS WITH RESPECT TO THE MODE", C ARNOLD AND GROENEVELD, AMERICAN STATISTICIAN, C FEBRUARY, 1995. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-975-2855 C ORIGINAL VERSION--APRIL 1995. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX, DDELTA 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(DELTA.LE.0.0)THEN WRITE(ICOUT,14) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)DELTA CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ENDIF 4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT') 14 FORMAT('***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT') 5 FORMAT(' TO THE LLGCDF SUBROUTINE IS NEGATIVE *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C C-----START POINT----------------------------------------------------- C CDF=0.0 IF(X.EQ.0.0)GOTO9999 DX=DBLE(X) DDELTA=DBLE(DELTA) C DTERM1=DLOG(1.0D0) DTERM2=DLOG(1.0D0 + DX**(-DDELTA)) DTERM3=DTERM1-DTERM2 DCDF=DEXP(DTERM3) CDF=REAL(DCDF) C 9999 CONTINUE RETURN END SUBROUTINE LLGPDF(X,DELTA,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE LOG-LOGISTIC DISTRIBUTION. C THIS DISTRIBUTION IS DEFINED FOR ALL POSITIVE X C AND HAS THE PROBABILITY DENSITY FUNCTION C F(X,DELTA) = DELTA*X**(DELTA-1)/[1+X**DELTA)**2] C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE C AT WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C X SHOULD BE POSITIVE. C --DELTA = THE POSITIVE SHAPE PARAMETER C OUTPUT ARGUMENTS--PDF = THE SINGLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY C FUNCTION VALUE PDF FOR THE LOG-LOGISTIC DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE POSITIVE. C --DELTA SHOULD BE POSITIVE. C LANGUAGE--ANSI FORTRAN. C REFERENCES--"MEASURING SKEWNESS WITH RESPECT TO THE MODE", C ARNOLD AND GROENEVELD, AMERICAN STATISTICIAN, C FEBRUARY, 1995. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-975-2855 C ORIGINAL VERSION--APRIL 1995. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX, DDELTA DOUBLE PRECISION DUL, DZ, DPDF DOUBLE PRECISION DTERM1, DTERM2, DTERM3, DTERM4 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--------------------------------------------------------------------- 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(DELTA.LE.0.0)THEN WRITE(ICOUT,14) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)DELTA CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF 4 FORMAT('***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT') 14 FORMAT('***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT') 5 FORMAT(' TO THE LLGPDF SUBROUTINE IS NEGATIVE *****') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C C-----START POINT----------------------------------------------------- C PDF=0.0 IF(X.EQ.0.0)GOTO9999 DX=DBLE(X) DDELTA=DBLE(DELTA) C C CHECK FOR VALUE OF X**DELTA THAT IS TO LARGE (SET PDF TO 0) C DUL=DLOG(DSQRT(D1MACH(2))) DZ=DDELTA*DLOG(DX) IF(DZ.GE.DUL)GOTO9999 C DTERM1=DLOG(DDELTA) DTERM2=(DDELTA-1.0D0)*DLOG(DX) DTERM3=2.0D0*DLOG(1.0D0+DX**DDELTA) DTERM4=DTERM1+DTERM2-DTERM3 IF(DTERM4.GE.-80.0D0)THEN DPDF=DEXP(DTERM4) ELSE DPDF=0.0D0 ENDIF PDF=REAL(DPDF) C 9999 CONTINUE RETURN END SUBROUTINE LLGPPF(P,DELTA,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE LOG-LOGISTIC C DISTRIBUTION. C INPUT ARGUMENTS--P = THE SINGLE PRECISION VALUE C (BETWEEN 0.0 (EXCLUSIVELY) C AND 1.0 (EXCLUSIVELY)) C AT WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. C OUTPUT ARGUMENTS--PPF = THE SINGLE PRECISION PERCENT C POINT FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION . C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--P SHOULD BE BETWEEN 0.0 (EXCLUSIVELY) C AND 1.0 (EXCLUSIVELY). C LANGUAGE--ANSI FORTRAN. C REFERENCES--"MEASURING SKEWNESS WITH RESPECT TO THE MODE", C ARNOLD AND GROENEVELD, AMERICAN STATISTICIAN, C FEBRUARY, 1995. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-921-2315 C ORIGINAL VERSION--APRIL 1995. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C DOUBLE PRECISION DTERM1, DTERM2, 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--------------------------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(DELTA.LE.0.0)THEN WRITE(ICOUT,14) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)DELTA CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF 14 FORMAT('***** NON-FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT') 5 FORMAT(' TO THE LLGPDF SUBROUTINE IS NEGATIVE *****') IF(P.LT.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 ') PPF=0.0 RETURN 90 CONTINUE 1 FORMAT( 1'***** FATAL ERROR--THE FIRST INPUT ARGUMENT TO THE LLGPPF') 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 PPF=0.0 IF(P.EQ.0.0)GOTO9999 C DTERM1=(-1.0D0/DBLE(DELTA)) DTERM2=DLOG((1.0D0-DBLE(P))/DBLE(P)) DTERM3=DTERM1*DTERM2 DPPF=DEXP(DTERM3) PPF=DPPF C 9999 CONTINUE RETURN END SUBROUTINE LLGRAN(N,DELTA,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE LOG-LOGISTIC DISTRIBUTION C WITH SHAPE PARAMETER VALUE = DELTA. C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --DELTA = THE SINGLE PRECISION VALUE OF THE C SHAPE PARAMETER. C DELTA 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 LOG-LOGISTIC DISTRIBUTION C WITH SHAPE PARAMETER VALUE = 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 --DELTA 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 INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2001.10 C ORIGINAL VERSION--OCTOBER 2001. C 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(DELTA.LE.0.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)DELTA CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ', 1'LLGRAN SUBROUTINE IS NON-POSITIVE *****') 15 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ', 1'LLGRAN 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 LOG-LOGISTIC DISTRIBUTION RANDOM NUMBERS C USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD. C DO100I=1,N CALL LLGPPF(X(I),DELTA,XTEMP) X(I)=XTEMP 100 CONTINUE C 9000 CONTINUE RETURN END SUBROUTINE LLTSLV(NR,N,A,X,B) IMPLICIT DOUBLE PRECISION (A-H,O-Z) C C PURPOSE C ------- C SOLVE AX=B WHERE A HAS THE FORM L(L-TRANSPOSE) C BUT ONLY THE LOWER TRIANGULAR PART, L, IS STORED. C C PARAMETERS C ---------- C NR --> ROW DIMENSION OF MATRIX C N --> DIMENSION OF PROBLEM C A(N,N) --> MATRIX OF FORM L(L-TRANSPOSE). C ON RETURN A IS UNCHANGED. C X(N) <-- SOLUTION VECTOR C B(N) --> RIGHT-HAND SIDE VECTOR C C NOTE C ---- C IF B IS NOT REQUIRED BY CALLING PROGRAM, THEN C B AND X MAY SHARE THE SAME STORAGE. C DIMENSION A(NR,1),X(N),B(N) C C FORWARD SOLVE, RESULT IN X C CALL FORSLV(NR,N,A,X,B) C C BACK SOLVE, RESULT IN X C CALL BAKSLV(NR,N,A,X,X) RETURN END SUBROUTINE LMRGLO(PARA,XMOM,NMOM) C===================================================== LMRGLO.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 L-MOMENT RATIOS FOR THE GENERALIZED LOGISTIC DISTRIBUTION C C PARAMETERS OF ROUTINE: C PARA * INPUT* ARRAY OF LENGTH 3. CONTAINS THE PARAMETERS OF THE C DISTRIBUTION, IN THE ORDER XI, ALPHA, K (LOCATION, C SCALE, SHAPE). C XMOM *OUTPUT* ARRAY OF LENGTH NMOM. ON EXIT, CONTAINS THE L-MOMENTS C LAMBDA-1, LAMBDA-2, TAU-3, TAU-4, ... . C NMOM * INPUT* NUMBER OF L-MOMENTS TO BE FOUND. AT MOST 20. C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DOUBLE PRECISION PARA(3),XMOM(NMOM),Z(10,20) 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/,ONE/1D0/ DATA PI/3.141592653589793238D0/ C C SMALL IS USED TO DECIDE WHETHER TO APPROXIMATE THE FIRST 2 C L-MOMENTS BY A POWER-SERIES EXPANSION WHEN G IS NEAR ZERO. C C1,C2 ARE COEFFICIENTS OF THIS POWER-SERIES EXPANSION. C C1 IS PI**2/6, C2 IS 7*PI**4/360. C DATA SMALL/1D-4/ DATA C1,C2/ * 0.16449 34066 84822 644D 1, 0.18940 65658 99449 184D 1/ C C Z-ARRAY CONTAINS COEFFICIENTS OF THE REPRESENTATIONS OF C L-MOMENT RATIOS AS POLYNOMIALS IN THE SHAPE PARAMETER K C DATA Z(1,3)/1D0/ DATA (Z(I, 4),I=1, 2)/ * 0.16666 66666 66666 667D 0, 0.83333 33333 33333 333D 0/ DATA (Z(I, 5),I=1, 2)/ * 0.41666 66666 66666 667D 0, 0.58333 33333 33333 333D 0/ DATA (Z(I, 6),I=1, 3)/ * 0.66666 66666 66666 667D-1, 0.58333 33333 33333 333D 0, * 0.35000 00000 00000 000D 0/ DATA (Z(I, 7),I=1, 3)/ * 0.23333 33333 33333 333D 0, 0.58333 33333 33333 333D 0, * 0.18333 33333 33333 333D 0/ DATA (Z(I, 8),I=1, 4)/ * 0.35714 28571 42857 143D-1, 0.42083 33333 33333 333D 0, * 0.45833 33333 33333 333D 0, 0.85119 04761 90476 190D-1/ DATA (Z(I, 9),I=1, 4)/ * 0.15099 20634 92063 492D 0, 0.51562 50000 00000 000D 0, * 0.29791 66666 66666 667D 0, 0.35466 26984 12698 413D-1/ DATA (Z(I,10),I=1, 5)/ * 0.22222 22222 22222 222D-1, 0.31889 32980 59964 727D 0, * 0.47997 68518 51851 852D 0, 0.16550 92592 59259 259D 0, * 0.13398 36860 67019 400D-1/ DATA (Z(I,11),I=1, 5)/ * 0.10650 79365 07936 508D 0, 0.44766 31393 29805 996D 0, * 0.36081 01851 85185 185D 0, 0.80390 21164 02116 402D-1, * 0.46285 27336 86067 019D-2/ DATA (Z(I,12),I=1, 6)/ * 0.15151 51515 15151 515D-1, 0.25131 61375 66137 566D 0, * 0.46969 52160 49382 716D 0, 0.22765 04629 62962 963D 0, * 0.34713 95502 64550 265D-1, 0.14727 13243 54657 688D-2/ DATA (Z(I,13),I=1, 6)/ * 0.79569 50456 95045 695D-1, 0.38976 59465 02057 613D 0, * 0.39291 73096 70781 893D 0, 0.12381 31062 61022 928D 0, * 0.13499 87139 91769 547D-1, 0.43426 15974 56041 900D-3/ DATA (Z(I,14),I=1, 7)/ * 0.10989 01098 90109 890D-1, 0.20413 29966 32996 633D 0, * 0.44773 66255 14403 292D 0, 0.27305 34428 27748 383D 0, * 0.59191 74382 71604 938D-1, 0.47768 77572 01646 091D-2, * 0.11930 26366 63747 775D-3/ DATA (Z(I,15),I=1, 7)/ * 0.61934 52050 59490 774D-1, 0.34203 17593 92870 504D 0, * 0.40701 37051 73427 396D 0, 0.16218 91928 06752 331D 0, * 0.25249 21002 35155 791D-1, 0.15509 34276 62872 107D-2, * 0.30677 82085 63922 850D-4/ DATA (Z(I,16),I=1, 8)/ * 0.83333 33333 33333 333D-2, 0.16976 83649 02293 474D 0, * 0.42219 12828 68366 202D 0, 0.30542 71728 94620 811D 0, * 0.84082 79399 72285 210D-1, 0.97243 57914 46208 113D-2, * 0.46528 02829 88616 322D-3, 0.74138 06706 96146 887D-5/ DATA (Z(I,17),I=1, 8)/ * 0.49716 60284 16028 416D-1, 0.30276 58385 89871 328D 0, * 0.41047 33000 89185 506D 0, 0.19483 90265 03251 764D 0, * 0.38659 80637 04648 526D-1, 0.34139 94076 42897 226D-2, * 0.12974 16173 71825 705D-3, 0.16899 11822 91033 482D-5/ DATA (Z(I,18),I=1, 9)/ * 0.65359 47712 41830 065D-2, 0.14387 48475 95085 690D 0, * 0.39643 28537 10259 464D 0, 0.32808 41807 20899 471D 0, * 0.10797 13931 65194 318D 0, 0.15965 33699 32077 769D-1, * 0.11012 77375 69143 819D-2, 0.33798 23645 82066 963D-4, * 0.36449 07853 33601 627D-6/ DATA (Z(I,19),I=1, 9)/ * 0.40878 45705 49276 431D-1, 0.27024 42907 25441 519D 0, * 0.40759 95245 14551 521D 0, 0.22211 14264 89320 008D 0, * 0.52846 38846 29533 398D-1, 0.59829 82392 72872 761D-2, * 0.32859 39655 65898 436D-3, 0.82617 91134 22830 354D-5, * 0.74603 37711 50646 605D-7/ DATA (Z(I,20),I=1,10)/ * 0.52631 57894 73684 211D-2, 0.12381 76557 53054 913D 0, * 0.37185 92914 44794 917D 0, 0.34356 87476 70189 607D 0, * 0.13019 86628 12524 058D 0, 0.23147 43648 99477 023D-1, * 0.20519 25194 79869 981D-2, 0.91205 82581 07571 930D-4, * 0.19023 86116 43414 884D-5, 0.14528 02606 97757 497D-7/ C U=PARA(1) A=PARA(2) G=PARA(3) IF(A.LE.ZERO.OR.DABS(G).GE.ONE)THEN WRITE(ICOUT,7000) 7000 FORMAT('***** ERROR IN GENERALIZED LOGISTIC L-MOMENTS--') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,7005) 7005 FORMAT(' PARAMETERS INVALID') CALL DPWRST('XXX','WRIT') GOTO9000 ELSEIF(NMOM.GT.20)THEN WRITE(ICOUT,7000) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,7010) 7010 FORMAT(' PARAMETER NMOM TOO LARGE') CALL DPWRST('XXX','WRIT') GOTO9000 ENDIF C C FIRST 2 MOMENTS C GG=G*G ALAM1=-G*(C1+GG*C2) ALAM2=ONE+GG*(C1+GG*C2) IF(DABS(G).GT.SMALL)ALAM2=G*PI/DSIN(G*PI) IF(DABS(G).GT.SMALL)ALAM1=(ONE-ALAM2)/G XMOM(1)=U+A*ALAM1 IF(NMOM.EQ.1)GOTO9000 XMOM(2)=A*ALAM2 IF(NMOM.EQ.2)GOTO9000 C C HIGHER MOMENTS C DO 20 M=3,NMOM KMAX=M/2 SUM=Z(KMAX,M) DO 10 K=KMAX-1,1,-1 SUM=SUM*GG+Z(K,M) 10 CONTINUE IF(M.NE.M/2*2)SUM=-G*SUM XMOM(M)=SUM 20 CONTINUE C 9000 CONTINUE RETURN C END SUBROUTINE LNHERM(X,AN,HN,ISIGN) C C PURPOSE--THIS SUBROUTINE COMPUTES THE LOGARITHM OF THE HERMITE C POLYNOMIAL OF ORDER N. THIS IS USEFUL FOR LARGER C ORDERS WHERE OVERFLOW MAY OCCUR WITH THE STANDARD C HERMITE POLYNOMIAL. C C THE HERMITE POLYNOMIAL CAN BE NEGATIVE OR POSITIVE, C SO TAKE LOG OF ABSOLUTE VALUE, SAVE SIGN IN ISIGN. C IF HERMITE POLYNOMIAL IS ZERO, THEN SET THIS FUNCTION C TO ZERO. C C THIS FUNCTION IS INTENDED FOR INTERMEDIATE PRIMARILY C FOR WHEN HIGH ORDER HERMITE POLYNOMIALS ARE USED IN C INTERMEDIATE CALCULATIONS AND LOGS CAN BE USED TO C HANDLE LARGE VALUES. C 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--HN = THE SINGLE PRECISION VALUE OF THE C LOG HERMITE 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 H(N+1) = 2.0*X*H(N)-2.0*N*H(N-1) C FIRST FEW TERMS ARE FROM TABLE 22.12 OF ABRAMOWITZ C AND STEGUM. C COMPUTE THE HERMITE POLYNOMIAL IN THE STANDARD WAY C (IN DOUBLE PRECISION), BUT TAKE LOG BEFORE CONVERTING C TO SINGLE PRECISION. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-975-2855 C ORIGINAL VERSION--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 DHN, DHN1, DHN2 C C-----START POINT----------------------------------------------------- C 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 LNHERM 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 DHN=1.0D0 ELSEIF(N.EQ.1)THEN DHN=2.0D0*DX ELSEIF(N.EQ.2)THEN DHN=4.0D0*DX**2 - 2.0D0 ELSEIF(N.EQ.3)THEN DHN=8.0D0*DX**3 - 12.0D0*DX ELSEIF(N.EQ.4)THEN DHN=16.0D0*DX**4 - 48.0D0*X**2 + 12.0D0 ELSEIF(N.EQ.5)THEN DHN=32.0D0*DX**5 - 160.0D0*DX**3 + 120.0D0*DX ELSE DHN1=32.0D0*DX**5 - 160.0D0*DX**3 + 120.0D0*DX DHN2=16.0D0*DX**4 - 48.0D0*X**2 + 12.0D0 DO1000I=6,N DN2=DBLE(I)-1.0D0 DHN=2.0D0*DX*DHN1 - 2.0D0*DN2*DHN2 DHN2=DHN1 DHN1=DHN 1000 CONTINUE ENDIF C IF(DHN.GT.0.0)THEN DHN=DLOG(DHN) ISIGN=1 ELSEIF(DHN.LT.0.D0)THEN DHN=DLOG(DABS(DHN)) ISIGN=-1 ELSE DHN=0.0D0 ISIGN=0 ENDIF C HN=REAL(DHN) C 9999 CONTINUE RETURN END SUBROUTINE LNSRCH(N,X,F,G,P,XPLS,FPLS,MXTAKE, CDPLT SUBROUTINE LNSRCH(N,X,F,G,P,XPLS,FPLS,OPTFCN,MXTAKE, + IRETCD,STEPMX,STEPTL,SX,IPR) IMPLICIT DOUBLE PRECISION (A-H,O-Z) C PURPOSE C ------- C FIND A NEXT NEWTON ITERATE BY LINE SEARCH. C C PARAMETERS C ---------- C N --> DIMENSION OF PROBLEM C X(N) --> OLD ITERATE: X[K-1] C F --> FUNCTION VALUE AT OLD ITERATE, F(X) C G(N) --> GRADIENT AT OLD ITERATE, G(X), OR APPROXIMATE C P(N) --> NON-ZERO NEWTON STEP C XPLS(N) <-- NEW ITERATE X[K] C FPLS <-- FUNCTION VALUE AT NEW ITERATE, F(XPLS) C OPTFCN --> NAME OF SUBROUTINE TO EVALUATE FUNCTION C IRETCD <-- RETURN CODE C MXTAKE <-- BOOLEAN FLAG INDICATING STEP OF MAXIMUM LENGTH USED C STEPMX --> MAXIMUM ALLOWABLE STEP SIZE 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 IPR --> DEVICE TO WHICH TO SEND OUTPUT C C INTERNAL VARIABLES C ------------------ C SLN NEWTON LENGTH C RLN RELATIVE LENGTH OF NEWTON STEP C INTEGER N,IRETCD DIMENSION SX(N) DIMENSION X(N),G(N),P(N) DIMENSION XPLS(N) LOGICAL MXTAKE C IPR=IPR MXTAKE=.FALSE. IRETCD=2 C$ WRITE(IPR,954) C$ WRITE(IPR,955) (P(I),I=1,N) TMP=0.0 DO 5 I=1,N TMP=TMP+SX(I)*SX(I)*P(I)*P(I) 5 CONTINUE SLN=SQRT(TMP) IF(SLN.LE.STEPMX) GO TO 10 C C NEWTON STEP LONGER THAN MAXIMUM ALLOWED SCL=STEPMX/SLN CALL SCLMUL(N,SCL,P,P) SLN=STEPMX C$ WRITE(IPR,954) C$ WRITE(IPR,955) (P(I),I=1,N) 10 CONTINUE SLP=DDOT(N,G,1,P,1) RLN=0. DO 15 I=1,N RLN=MAX(RLN,ABS(P(I))/MAX(ABS(X(I)),1./SX(I))) 15 CONTINUE RMNLMB=STEPTL/RLN ALMBDA=1.0 C$ WRITE(IPR,952) SLN,SLP,RMNLMB,STEPMX,STEPTL C C LOOP C CHECK IF NEW ITERATE SATISFACTORY. GENERATE NEW LAMBDA IF NECESSARY. C 100 CONTINUE IF(IRETCD.LT.2) RETURN DO 105 I=1,N XPLS(I)=X(I) + ALMBDA*P(I) 105 CONTINUE CALL OPTFCN(N,XPLS,FPLS) C$ WRITE(IPR,950) ALMBDA C$ WRITE(IPR,951) C$ WRITE(IPR,955) (XPLS(I),I=1,N) C$ WRITE(IPR,953) FPLS IF(FPLS.GT. F+SLP*1.E-4*ALMBDA) GO TO 130 C IF(FPLS.LE. F+SLP*1.E-4*ALMBDA) C THEN C C SOLUTION FOUND C IRETCD=0 IF(ALMBDA.EQ.1.0 .AND. SLN.GT. .99*STEPMX) MXTAKE=.TRUE. GO TO 100 C C SOLUTION NOT (YET) FOUND C C ELSE 130 IF(ALMBDA .GE. RMNLMB) GO TO 140 C IF(ALMBDA .LT. RMNLMB) C THEN C C NO SATISFACTORY XPLS FOUND SUFFICIENTLY DISTINCT FROM X C IRETCD=1 GO TO 100 C ELSE C C CALCULATE NEW LAMBDA C 140 IF(ALMBDA.NE.1.0) GO TO 150 C IF(ALMBDA.EQ.1.0) C THEN C C FIRST BACKTRACK: QUADRATIC FIT C TLMBDA=-SLP/(2.*(FPLS-F-SLP)) GO TO 170 C ELSE C C ALL SUBSEQUENT BACKTRACKS: CUBIC FIT C 150 T1=FPLS-F-ALMBDA*SLP T2=PFPLS-F-PLMBDA*SLP T3=1.0/(ALMBDA-PLMBDA) A=T3*(T1/(ALMBDA*ALMBDA) - T2/(PLMBDA*PLMBDA)) B=T3*(T2*ALMBDA/(PLMBDA*PLMBDA) + - T1*PLMBDA/(ALMBDA*ALMBDA) ) DISC=B*B-3.0*A*SLP IF(DISC.LE. B*B) GO TO 160 C IF(DISC.GT. B*B) C THEN C C ONLY ONE POSITIVE CRITICAL POINT, MUST BE MINIMUM C TLMBDA=(-B+SIGN(1.0D0,A)*SQRT(DISC))/(3.0*A) GO TO 165 C ELSE C C BOTH CRITICAL POINTS POSITIVE, FIRST IS MINIMUM C 160 TLMBDA=(-B-SIGN(1.0D0,A)*SQRT(DISC))/(3.0*A) C ENDIF 165 IF(TLMBDA.GT. .5*ALMBDA) TLMBDA=.5*ALMBDA C ENDIF 170 PLMBDA=ALMBDA PFPLS=FPLS IF(TLMBDA.GE. ALMBDA*.1) GO TO 180 C IF(TLMBDA.LT.ALMBDA/10.) C THEN ALMBDA=ALMBDA*.1 GO TO 190 C ELSE 180 ALMBDA=TLMBDA C ENDIF C ENDIF C ENDIF 190 GO TO 100 CC950 FORMAT(18H LNSRCH ALMBDA=,E20.13) CC951 FORMAT(29H LNSRCH NEW ITERATE (XPLS)) CC952 FORMAT(18H LNSRCH SLN =,E20.13/ CC + 18H LNSRCH SLP =,E20.13/ CC + 18H LNSRCH RMNLMB=,E20.13/ CC + 18H LNSRCH STEPMX=,E20.13/ CC + 18H LNSRCH STEPTL=,E20.13) CC953 FORMAT(19H LNSRCH F(XPLS)=,E20.13) CC954 FORMAT(26H0LNSRCH NEWTON STEP (P)) CC955 FORMAT(14H LNSRCH ,5(E20.13,3X)) END DOUBLE PRECISION FUNCTION LOBACH(XVALUE) C C DESCRIPTION: C C This function calculates the Lobachewsky function L(x), defined as C C LOBACH(x) = {integral 0 to x} ( -ln ( | cos t | ) dt C C The code uses Chebyshev expansions whose coefficients are given C to 20 decimal places. C C C ERROR RETURNS: C C If |x| too large, it is impossible to accurately reduce the C argument to the range [0,pi]. An error message is printed C and the program returns the value 0.0 C C C MACHINE-DEPENDENT CONSTANTS: C C NTERM1 - INTEGER - The no. of terms to be used of the array ARLOB1. C The recommended value is such that C ABS(ARLOB1(NTERM1)) < EPS/100 C C NTERM2 - INTEGER - The no. of terms to be used of the array ARLOB2. C The recommended value is such that C ABS(ARLOB2(NTERM2)) < EPS/100 C C XLOW1 - DOUBLE PRECISION - The value below which L(x) = 0.0 to machine-precision. C The recommended value is C cube-root ( 6*XMIN ) C C XLOW2 - DOUBLE PRECISION - The value below which L(x) = x**3/6 to C machine-precision. The recommended value is C sqrt ( 10*EPS ) C C XLOW3 - DOUBLE PRECISION - The value below which C L(pi/2) - L(pi/2-x) = x ( 1 - log(x) ) C to machine-precision. The recommended value is C sqrt ( 18*EPS ) C C XHIGH - DOUBLE PRECISION - The value of |x| above which it is impossible C to accurately reduce the argument. The C recommended value is 1 / EPS. C C For values of EPS, and XMIN, refer to the file MACHCON.TXT C C The machine-dependent constants are computed internally by C using the D1MACH subroutine. C C C INTRINSIC FUNCTIONS USED: C C INT , LOG , SQRT C C C OTHER MISCFUN SUBROUTINES USED: C C CHEVAL , ERRPRN, D1MACH C C C AUTHOR: C C Dr. Allan J. MacLeod, C Dept. of Mathematics and Statistics, C University of Paisley, C High St., C Paisley, C SCOTLAND C C ( e-mail: macl_ms0@paisley.ac.uk ) C C C LATEST UPDATE: C 23 January, 1996 C INTEGER INDPI2,INDSGN,NPI,NTERM1,NTERM2 DOUBLE PRECISION ARLOB1(0:15),ARLOB2(0:10), 1 CHEVAL,FVAL,FVAL1,HALF,LBPB21,LBPB22,LOBPIA,LOBPIB, 2 LOBPI1,LOBPI2,ONE,ONEHUN,PI,PIBY2,PIBY21,PIBY22,PIBY4,PI1, 3 PI11,PI12,PI2,SIX,T,TCON,TEN,TWO,X,XCUB,XHIGH,XLOW1, 4 XLOW2,XLOW3,XR,XVALUE,ZERO CCCCC CHARACTER FNNAME*6,ERRMSG*26 C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOMC.INC' CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C CCCCC DATA FNNAME/'LOBACH'/ CCCCC DATA ERRMSG/'ARGUMENT TOO LARGE IN SIZE'/ DATA ZERO,HALF/ 0.0 D 0 , 0.5 D 0 / DATA ONE,TWO,SIX/ 1.0 D 0 , 2.0 D 0 , 6.0 D 0 / DATA TEN,ONEHUN/ 10.0 D 0 , 100.0 D 0 / DATA LOBPIA,LOBPIB/ 1115.0 D 0 , 512.0 D 0 / DATA LOBPI2/-1.48284 69639 78694 99311 D -4/ DATA LBPB22/-7.41423 48198 93474 96556 D -5/ DATA PI11,PI12/ 201.0 D 0 , 64.0 D 0 / DATA PI2/9.67653 58979 32384 62643 D -4/ DATA PIBY22/4.83826 79489 66192 31322 D -4/ DATA TCON/3.24227 78765 54808 68620 D 0/ DATA ARLOB1/0.34464 88495 34813 00507 D 0, 1 0.58419 83571 90277 669 D -2, 2 0.19175 02969 46003 30 D -3, 3 0.78725 16064 56769 D -5, 4 0.36507 47741 5804 D -6, 5 0.18302 87272 680 D -7, 6 0.96890 33300 5 D -9, 7 0.53390 55444 D -10, 8 0.30340 8025 D -11, 9 0.17667 875 D -12, X 0.10493 93 D -13, 1 0.63359 D -15, 2 0.3878 D -16, 3 0.240 D -17, 4 0.15 D -18, 5 0.1 D -19/ DATA ARLOB2/2.03459 41803 61328 51087 D 0, 1 0.17351 85882 02740 7681 D -1, 2 0.55162 80426 09052 1 D -4, 3 0.39781 64627 6598 D -6, 4 0.36901 80289 18 D -8, 5 0.38804 09214 D -10, 6 0.44069 698 D -12, 7 0.52767 4 D -14, 8 0.6568 D -16, 9 0.84 D -18, X 0.1 D -19/ C C Start computation C X = ABS ( XVALUE ) INDSGN = 1 IF ( XVALUE .LT. ZERO ) THEN INDSGN = -1 ENDIF C C Compute the machine-dependent constants. C XR = D1MACH(3) XHIGH = ONE / XR C C Error test C IF ( X .GT. XHIGH ) THEN CCCCC CALL ERRPRN(FNNAME,ERRMSG) WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,101)X CALL DPWRST('XXX','BUG ') LOBACH = ZERO RETURN ENDIF 999 FORMAT(1X) 101 FORMAT('***** ERROR FROM LOBACH--ARGUMENT TOO LARGE. ', 1 'ARGUMENT = ',G15.7) C C continue with constants C T = XR / ONEHUN DO 10 NTERM1 = 15 , 0 , -1 IF ( ABS(ARLOB1(NTERM1)) .GT. T ) GOTO 19 10 CONTINUE 19 DO 20 NTERM2 = 10 , 0 , -1 IF ( ABS(ARLOB2(NTERM2)) .GT. T ) GOTO 29 20 CONTINUE 29 XLOW1 = ( SIX * D1MACH(1) ) ** (TWO/SIX) XLOW2 = SQRT ( TEN * XR ) T = TWO * TEN - TWO XLOW3 = SQRT ( T * XR ) C C Reduce argument to [0,pi] C PI1 = PI11/PI12 PI = PI1 + PI2 PIBY2 = PI/TWO PIBY21 = PI1/TWO PIBY4 = PIBY2/TWO NPI = INT ( X / PI ) XR = ( X - NPI * PI1 ) - NPI * PI2 C C Reduce argument to [0,pi/2] C INDPI2 = 0 IF ( XR .GT. PIBY2 ) THEN INDPI2 = 1 XR = ( PI1 - XR ) + PI2 ENDIF C C Code for argument in [0,pi/4] C IF ( XR .LE. PIBY4 ) THEN IF ( XR .LT. XLOW1 ) THEN FVAL = ZERO ELSE XCUB = XR * XR * XR IF ( XR .LT. XLOW2 ) THEN FVAL = XCUB / SIX ELSE T = ( TCON * XR * XR - HALF ) - HALF FVAL = XCUB * CHEVAL(NTERM1,ARLOB1,T) ENDIF ENDIF ELSE C C Code for argument in [pi/4,pi/2] C XR = ( PIBY21 - XR ) + PIBY22 IF ( XR .EQ. ZERO ) THEN FVAL1 = ZERO ELSE IF ( XR .LT. XLOW3 ) THEN FVAL1 = XR * ( ONE - LOG( XR ) ) ELSE T = ( TCON * XR * XR - HALF ) - HALF FVAL1 = XR * ( CHEVAL(NTERM2,ARLOB2,T) - LOG( XR ) ) ENDIF ENDIF LBPB21 = LOBPIA / ( LOBPIB + LOBPIB ) FVAL = ( LBPB21 - FVAL1 ) + LBPB22 ENDIF LOBPI1 = LOBPIA / LOBPIB C C Compute value for argument in [pi/2,pi] C IF ( INDPI2 .EQ. 1 ) THEN FVAL = ( LOBPI1 - FVAL ) + LOBPI2 ENDIF LOBACH = FVAL C C Scale up for arguments > pi C IF ( NPI .GT. 0 ) THEN LOBACH = ( FVAL + NPI * LOBPI2 ) + NPI * LOBPI1 ENDIF IF ( INDSGN .EQ. -1 ) THEN LOBACH = - LOBACH ENDIF RETURN END SUBROUTINE LOCAL (XI,YI,FI,NXG,XG,NYG,YG,NP,MP,AL,AB,C,IP,IER) C C THIS SUBROUTINE CONSTRUCTS THE LOCAL APPROXIMANTS FOR THE GRID C VERSION OF FRANKE'S METHOD. THE LOCAL APPROXIMATIONS ARE TAKEN C TO BE THE THIN PLATE SPLINES DESCRIBED BY DUCHON AND OTHERS. C C THE ARGUMENTS ARE AS FOLLOWS. C C XI - \ C YI - INPUT. THE DATA POINTS (XI,YI,FI),I=1,NPI. C FI - / C NXG - INPUT. THE NUMBER OF VERTICAL GRID LINES. C XG - INPUT. THE COORDINATES OF THE VERTICAL GRID LINES, IN C INCREASING ORDER. C NYG - INPUT. THE NUMBER OF HORIZONTAL GRID LINES. C YG - INPUT. THE COORDINATES OF THE HORIZONTAL GRID LINES, IN C INCREASING ORDER. C NP - INPUT. AN ARRAY WHICH GIVES THE INITIAL SUBSCRIPT IN C THE ARRAY MP AT WHICH THE SUBSCRIPTS FOR THE C LOCAL INTERPOLATION POINTS ARE STORED. C MP - INPUT. AN ARRAY WHICH GIVES THE SUBSCRIPTS FOR THE C LOCAL INTERPOLATION POINTS. C AL - OUTPUT. THE COEFFICIENTS FOR THE LINEAR PART OF THE C LOCAL THIN PLATE SPLINE FIT. C AB - OUTPUT. THE COEFFICIENTS FOR THE THIN PLATE SPLINES C C - OUTPUT. NOT MEANINGFUL. THIS IS A SCRATCH ARRAY USED C DURING CALCULATION OF THE LOCAL APPROXIMATIONS. C IP - OUTPUT. NOT MEANINGFUL. THIS IS A SCRATCH ARRAY USED C TO STORE PIVOT ORDER IN EQUATION SOLUTION. C IER - OUTPUT. RETURN INDICATOR. C = 0, NORMAL RETURN. C = 1, SINGULAR MATRIX HAS BEEN DETECTED IN THE C THIN PLATE SPLINE FIT. C C SUBROUTINES USED C LINPACK: SGECO,SGESL C SLATEC: XERROR C DIMENSION XI(*), YI(*), FI(*), NP(*), MP(*), AL(*), AB(*), XG(*), 1 YG(*),C(*),IP(*) C C ARITHMETIC STATEMENT FUNCTION FOR THE THIN PLATE SPLINE BASIS C FUNCTIONS. C PHI(X,Y,XP,YP) = ((X-XP)**2+(Y-YP)**2)*ALOG(((X-XP)**2+(Y-YP)**2) 1 + 1.E-20) IER = 0 IJ = 0 DO 160 J=1,NYG DO 140 I=1,NXG IJ = IJ + 1 140 CONTINUE 160 CONTINUE IJ = 0 C DO 260 J=1,NYG DY = YG(J+2)-YG(J) C DO 240 I=1,NXG DX = XG(I+2)-XG(I) IJ = IJ+1 LEND = NP(IJ+1)-NP(IJ) LEND3 = LEND + 3 IALS = (IJ-1)*3 C DO 200 LI=1,LEND MPI = NP(IJ)+LI-1 KI = MP(MPI) XKI = (XI(KI)-XG(I))/DX YKI = (YI(KI)-YG(J))/DY LIJ = LEND*LEND3 + LI C(LIJ) = 1. C(LIJ+LEND3) = XKI C(LIJ+2*LEND3) = YKI LIJ = LEND3*(LI - 1) + LEND + 1 C(LIJ) = 1. C(LIJ+1) = XKI C(LIJ+2) = YKI LIJL = LI LIJU = LEND3*(LI-1)+1 C DO 180 LJ=1,LI MPJ = NP(IJ)+LJ-1 KJ = MP(MPJ) XKJ = (XI(KJ)-XG(I))/DX YKJ = (YI(KJ)-YG(J))/DY C(LIJL) = PHI(XKI,YKI,XKJ,YKJ) C(LIJU) = C(LIJL) LIJL = LIJL + LEND3 180 LIJU = LIJU + 1 C LIJ = LEND3*LEND3 + LI C(LIJ) = FI(KI) 200 CONTINUE DO 215 LLI=1,3 LIJU = (LEND + LLI - 1)*LEND3 + LEND + 1 LIJL = LEND*LEND3 + LEND + LLI DO 210 LLJ = 1,LLI C(LIJL) = 0. C(LIJU) = 0. LIJL = LIJL + LEND3 210 LIJU = LIJU + 1 LIJ = LEND3*LEND3 + LEND + LLI C(LIJ) = 0. 215 CONTINUE C LR = LEND3*LEND3 + 1 LRR = LR + LEND3 216 CONTINUE CALL SGECO(C,LEND3,LEND3,IP,RCOND,C(LRR)) IF((.1*RCOND+1.).EQ.1.)GO TO 300 CALL SGESL(C,LEND3,LEND3,IP,C(LR),0) C DO 220 LI=1,LEND IAB = NP(IJ)+LI-1 AB(IAB) = C(LR) 220 LR = LR + 1 C AL(IALS+1) = C(LR) AL(IALS+2) = C(LR+1) AL(IALS+3) = C(LR+2) 240 CONTINUE C 260 CONTINUE C RETURN C C ERROR RETURN C 300 IER = 1 RETURN END SUBROUTINE LOEVL (XI,YI,NXG,XG,NYG,YG,NP,MP,AL,AB,NXO,XO,NYO 1,YO,FO) C C THIS SUBROUTINE EVALUATES THE INTERPOLANT FOR THE GRID VERSION OF C FRANKE'S METHOD. THE FUNCTION IS EVALUATED AT THE GRID OF POINTS C INDICATED BY NXO, XO, NYO, YO, AND THESE VALUES ARE RETURNED C IN THE ARRAY FO, WHICH IS ASSUMED TO BE DIMENSIONED (NXO,NYO). C C THE ARGUMENTS ARE AS FOLLOWS. C C XI - \ C YI - INPUT. THE DATA POINTS (XI,YI,FI),I=1,...,NPI. C FI - / C NXG - INPUT. THE NUMBER OF VERTICAL GRID LINES. C XG - INPUT. THE COORDINATES OF THE VERTICAL GRID LINES, IN C INCREASING ORDER. C NYG - INPUT. THE NUMBER OF HORIZONTAL GRID LINES. C YG - INPUT. THE COORDINATES OF THE HORIZONTAL GRID LINES, C IN INCREASING ORDER. C NP - INPUT. AN ARRAY WHICH GIVES THE INITIAL SUBSCRIPT IN C THE ARRAY MP AT WHICH THE SUBSCRIPTS FOR THE C LOCAL INTERPOLATION POINTS ARE STORED. C MP - INPUT. AN ARRAY WHICH GIVES THE SUBSCRIPTS FOR THE C LOCAL INTERPOLATION POINTS. C AL - INPUT. THE COEFFICIENTS FOR THE LINEAR PART OF THE C THIN PLATE SPLINE APPROXIMATIONS. C AB - INPUT. THE COEFFICIENTS FOR THE LOCAL THIN PLATE C SPLINE APPROXIMATIONS. C NXO - INPUT. THE NUMBER OF XO VALUES AT WHICH THE INTERPO- C LATION FUNCTION IS TO BE CALCULATED. C XO - INPUT. THE VALUES OF X AT WHICH THE INTERPOLATION C FUNCTION IS TO BE CALCULATED. C NYO - INPUT. THE NUMBER OF YO VALUES AT WHICH THE INTERPO- C LATION FUNCTION IS TO BE CALCULATED. C YO - INPUT. THE VALUES OF Y AT WHICH THE INTERPOLATION C FUNCTION IS TO BE CALCULATED. C FO - OUTPUT. VALUES OF THE INTERPOLATION FUNCTION AT THE C GRID POINTS INDICATED BY NXO, XO, NYO, YO. C FO IS ASSUMED TO BE DIMENSIONED (NXO,NYO) IN THE C CALLING PROGRAM. C DIMENSION XG(*), YG(*), XI(*), YI(*), NP(*), MP(*), FC(4), AL(*), 1AB(*), XO(*), YO(*), FO(NXO,1) C C ARITHMETIC STATEMENT FUNCTION FOR THE HERMITE CUBIC. C H3(S) = 1. - S**2*(3. - 2.*S) C C ARITHMETIC STATEMENT FUNCTION FOR THE THIN PLATE SPLINE BASIS C FUNCTIONS. C PHI(X,Y,XP,YP) = ((X-XP)**2+(Y-YP)**2)*ALOG(((X-XP)**2+(Y-YP)**2) 1 + 1.E-20) C J = 1 C DO 640 JO=1,NYO C C DETERMINE THE LOCATION OF THE POINT YO IN TERMS OF THE SMALLEST C VALUE OF J SUCH THAT YO(JO) IS IN SOME RECTANGLE (I,J). C YV = YO(JO) JJS = J+1 IF (YV.LT.YG(JJS)) JJS=1 C DO 100 JJ=JJS,NYG IF (YV.LT.YG(JJ+1)) GO TO 120 100 CONTINUE C J = NYG GO TO 140 120 J = JJ-1 140 JD = 3 IF (J.GE.1) GO TO 160 JD = 0 J = 1 GO TO 180 160 IF (J.LT.NYG) GO TO 180 JD = 6 180 DY = YG(J+2)-YG(J+1) I = 1 C DO 620 IO=1,NXO C C DETERMINE THE LOCATION OF THE POINT XO IN TERMS OF THE SMALLEST C VALUE OF I SUCH THAT XO(IO) IS IN THE RECTANGLE (I,J). C IIS = I+1 XV = XO(IO) IF (XV.LT.XG(IIS)) IIS=1 C DO 200 II=IIS,NXG IF (XV.LT.XG(II+1)) GO TO 220 200 CONTINUE C I = NXG GO TO 240 220 I = II-1 240 ID = 2 IF (I.GE.1) GO TO 260 ID = 1 I = 1 GO TO 280 260 IF (I.LT.NXG) GO TO 280 ID = 3 280 DX = XG(I+2)-XG(I+1) KD = ID+JD GO TO (300,360,300,440,520,440,300,360,300), KD C C THIS IS FOR (XO(IO),YO(JO)) POINTS IN A SINGLE RECTANGLE (I,J) C 300 FV = 0. IJ = (J-1)*NXG+I IAL = 3*IJ-2 LMAX = NP(IJ+1)-NP(IJ) DXA = XG(I+2)-XG(I) DYA = YG(J+2)-YG(J) XVD = (XV-XG(I))/DXA YVD = (YV-YG(J))/DYA C DO 320 L=1,LMAX MPS = NP(IJ)+L-1 KI = MP(MPS) XKI = (XI(KI)-XG(I))/DXA YKI = (YI(KI)-YG(J))/DYA 320 FV = FV+AB(MPS)*PHI(XKI,YKI,XVD,YVD) C 340 FV = FV + AL(IAL) + AL(IAL+1)*XVD + AL(IAL+2)*YVD GO TO 620 C C THIS IS FOR XO(IO),YO(JO)) POINTS WHICH ARE IN TWO RECTANGLES, C (I,J) AND (I+1,J). C 360 DYA = YG(J+2)-YG(J) YVD = (YV-YG(J))/DYA C DO 420 IP=1,2 FC(IP) = 0. IS = I+IP-1 IJ = (J-1)*NXG+IS IAL = 3*IJ-2 DXA = XG(IS+2)-XG(IS) XVD = (XV-XG(IS))/DXA LMAX = NP(IJ+1)-NP(IJ) C DO 380 L=1,LMAX MPS = NP(IJ)+L-1 KI = MP(MPS) XKI = (XI(KI)-XG(IS))/DXA YKI = (YI(KI)-YG(J))/DYA 380 FC(IP) = FC(IP)+AB(MPS)*PHI(XKI,YKI,XVD,YVD) C 400 FC(IP)=FC(IP)+AL(IAL)+AL(IAL+1)*XVD+AL(IAL+2)*YVD 420 CONTINUE C WI = H3((XV-XG(I+1))/DX) FV = FC(1)*WI+(1.-WI)*FC(2) GO TO 620 C C THIS IS FOR (XO(IO),YO(JO)) POINTS WHICH ARE IN TWO RECTANGLES, C (I,J) AND (I,J+1). C 440 DXA = XG(I+2)-XG(I) XVD = (XV-XG(I))/DXA C DO 500 JP=1,2 FC(JP) = 0. JS = J+JP-1 IJ = (JS-1)*NXG+I IAL = 3*IJ-2 DYA = YG(JS+2)-YG(JS) YVD = (YV-YG(JS))/DYA LMAX = NP(IJ+1)-NP(IJ) C DO 460 L=1,LMAX MPS = NP(IJ)+L-1 KJ = MP(MPS) XKJ = (XI(KJ)-XG(I))/DXA YKJ = (YI(KJ)-YG(JS))/DYA 460 FC(JP) = FC(JP)+AB(MPS)*PHI(XKJ,YKJ,XVD,YVD) C 480 FC(JP)=FC(JP)+AL(IAL)+AL(IAL+1)*XVD+AL(IAL+2)*YVD 500 CONTINUE C UJ = H3((YV-YG(J+1))/DY) FV = FC(1)*UJ+(1.-UJ)*FC(2) GO TO 620 C C THIS IS FOR (XO(IO),YO(JO)) POINTS WHICH ARE IN FOUR RECTANGLES, C (I,J), (I+1,J), (I,J+1), AND (I+1,J+1). C 520 KFC = 0 C DO 600 JP=1,2 JS = J+JP-1 DYA = YG(JS+2)-YG(JS) YVD = (YV-YG(JS))/DYA C DO 580 IP=1,2 IS = I+IP-1 IJ = (JS-1)*NXG+IS IAL = 3*IJ-2 KFC = KFC+1 FC(KFC) = 0. DXA = XG(IS+2)-XG(IS) XVD = (XV-XG(IS))/DXA LMAX = NP(IJ+1)-NP(IJ) C DO 540 L=1,LMAX MPS = NP(IJ)+L-1 KI = MP(MPS) XKI = (XI(KI)-XG(IS))/DXA YKI = (YI(KI)-YG(JS))/DYA 540 FC(KFC) = FC(KFC)+AB(MPS)*PHI(XKI,YKI,XVD,YVD) C 560 FC(KFC)=FC(KFC)+AL(IAL)+AL(IAL+1)*XVD+AL(IAL+2)*YVD 580 CONTINUE C 600 CONTINUE C WI = H3((XV-XG(I+1))/DX) UJ = H3((YV-YG(J+1))/DY) FV = WI*(UJ*FC(1)+(1.-UJ)*FC(3))+(1.-WI)*(UJ*FC(2)+(1.-UJ)*FC(4)) 620 FO(IO,JO) = FV C 640 CONTINUE C RETURN END SUBROUTINE LOGARI(Y1,Y2,N1,IACASE,IWRITE, 1Y3,N3,SCAL3,ITYP3,IBUGA3,ISUBRO,IERROR) C C PURPOSE--CARRY OUT LOGICAL ARITHMETIC OPERATIONS C OF THE REAL DATA IN Y1 AND Y2. C C OPERATIONS--AND (OR CONJUNCTION OR MULTIPLICATION) C OR (OR DISJUNCTION OR ADDITION) C NAND C NOR (OR EXCLUSIVE DISJUNCTION) C IFTHEN (OR IMPLICATION) C IFF (OR EQUIVALENCE) C NOT (OR NEGATION OR NOT OR COMPLEMENT) C XOR (OR EXCLUSIVE OR OR EXCL. DISJUNCTION) C C INPUT ARGUMENTS--Y1 (REAL) C --Y2 (REAL) C OUTPUT ARGUMENTS--Y3 (REAL) C SCAL3 C ITYP3 C C NOTE--IT IS NOT PERMISSIBLE TO HAVE THE OUTPUT LOGICALY3(.) C BEING IDENTICAL TO THE INPUT LOGICALY1(.) OR Y2(.). C REFERENCE--HANDBOOK OF MATHEMATICAL TABLES AND FORMULAS, C BURINGTON, EDITION 5, PAGES 130-135. C --INTRODUCTION TO COMPUTER SCIENCE, C SCHEID, SCHAUM OUTLINE SERIES, PP. 3, 4, 6, 7, 43, 224. 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--87/9 C ORIGINAL VERSION--AUGUST 1987. 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--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION Y1(*) DIMENSION Y2(*) DIMENSION Y3(*) 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='LOGA' ISUBN2='RI ' C IERROR='NO' C SCAL3=(-999.0) ITYP3='VECT' C TOL=0.00001 ONE=1.0 ONEMIN=ONE-TOL ONEMAX=ONE+TOL ZERO=0.0 ZERMIN=ZERO-TOL ZERMAX=ZERO+TOL C IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'GARI')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF LOGARI--') 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 53 FORMAT('N1 = ',I8) 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 90 CONTINUE C C ************************************************** C ** CARRY OUT LOGICAL ARITHMETIC OPERATIONS ** C ************************************************** C C ******************************************** C ** STEP 11-- ** C ** CHECK NUMBER OF INPUT OBSERVATIONS. ** C ******************************************** C IF(N1.LT.1)GOTO1100 GOTO1190 C 1100 CONTINUE IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1151) 1151 FORMAT('***** ERROR IN LOGARI--') 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.'LOAN')WRITE(ICOUT,1161) 1161 FORMAT(' THE LOGICAL AND IS TO BE ', 1'COMPUTED') IF(IACASE.EQ.'LOAN')CALL DPWRST('XXX','BUG ') IF(IACASE.EQ.'LOOR')WRITE(ICOUT,1162) 1162 FORMAT(' THE LOGICAL OR IS TO BE ', 1'COMPUTED') IF(IACASE.EQ.'LOOR')CALL DPWRST('XXX','BUG ') IF(IACASE.EQ.'LONA')WRITE(ICOUT,1163) 1163 FORMAT(' THE LOGICAL NAND IS TO BE ', 1'COMPUTED') IF(IACASE.EQ.'LONA')CALL DPWRST('XXX','BUG ') IF(IACASE.EQ.'LONO')WRITE(ICOUT,1164) 1164 FORMAT(' THE LOGICAL NOR IS TO BE ', 1'COMPUTED') IF(IACASE.EQ.'LONO')CALL DPWRST('XXX','BUG ') IF(IACASE.EQ.'LOIM')WRITE(ICOUT,1165) 1165 FORMAT(' THE LOGICAL IMPLICATION IS TO BE ', 1'COMPUTED') IF(IACASE.EQ.'LOIM')CALL DPWRST('XXX','BUG ') IF(IACASE.EQ.'LOEQ')WRITE(ICOUT,1166) 1166 FORMAT(' THE LOGICAL EQUIVALENCE IS TO BE ', 1'COMPUTED') IF(IACASE.EQ.'LOEQ')CALL DPWRST('XXX','BUG ') IF(IACASE.EQ.'LONT')WRITE(ICOUT,1167) 1167 FORMAT(' THE LOGICAL NOT IS TO BE ', 1'COMPUTED') IF(IACASE.EQ.'LONT')CALL DPWRST('XXX','BUG ') IF(IACASE.EQ.'LOXO')WRITE(ICOUT,1168) 1168 FORMAT(' THE LOGICAL XOR IS TO BE ', 1'COMPUTED') IF(IACASE.EQ.'LOXO')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 1183 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 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.'LOAN')GOTO2100 IF(IACASE.EQ.'LOOR')GOTO2200 IF(IACASE.EQ.'LONA')GOTO2300 IF(IACASE.EQ.'LONO')GOTO2400 IF(IACASE.EQ.'LOIM')GOTO2500 IF(IACASE.EQ.'LOEQ')GOTO2600 IF(IACASE.EQ.'LONT')GOTO2700 IF(IACASE.EQ.'LOXO')GOTO2800 C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1211) 1211 FORMAT('***** INTERNAL ERROR IN LOGARI--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1212) 1212 FORMAT(' IACASE NOT EQUAL TO') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1213) 1213 FORMAT(' LOAN, LOOR, LONA, LONO, ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1214) 1214 FORMAT(' LOIM, LOEQ, LONT, OR LOXO') 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 LOGICAL AND CASE ** C ** 0 0 1 1 & 0 1 0 1 YIELDS 0 0 0 1 ** C ********************************************* C 2100 CONTINUE DO2110I=1,N1 Y3(I)=ZERO IF(ONEMIN.LE.Y1(I).AND.Y1(I).LE.ONEMAX.AND. 1 ONEMIN.LE.Y2(I).AND.Y2(I).LE.ONEMAX)Y3(I)=ONE 2110 CONTINUE C ITYP3='VECT' N3=N1 GOTO9000 C C ********************************************* C ** STEP 22-- ** C ** TREAT THE LOGICAL OR CASE ** C ** 0 0 1 1 & 0 1 0 1 YIELDS 0 1 1 1 ** C ********************************************* C 2200 CONTINUE DO2210I=1,N1 Y3(I)=ONE IF(ZERMIN.LE.Y1(I).AND.Y1(I).LE.ZERMAX.AND. 1 ZERMIN.LE.Y2(I).AND.Y2(I).LE.ZERMAX)Y3(I)=ZERO 2210 CONTINUE C ITYP3='VECT' N3=N1 GOTO9000 C C ************************************************ C ** STEP 23-- ** C ** TREAT THE LOGICAL NAND CASE ** C ** 0 0 1 1 & 0 1 0 1 YIELDS 1 1 1 0 ** C ************************************************ C 2300 CONTINUE DO2310I=1,N1 Y3(I)=ONE IF(ONEMIN.LE.Y1(I).AND.Y1(I).LE.ONEMAX.AND. 1 ONEMIN.LE.Y2(I).AND.Y2(I).LE.ONEMAX)Y3(I)=ZERO 2310 CONTINUE C ITYP3='VECT' N3=N1 GOTO9000 C C ************************************************ C ** STEP 24-- ** C ** TREAT THE LOGICAL NOR CASE ** C ** 0 0 1 1 & 0 1 0 1 YIELDS 1 0 0 0 ** C ************************************************ C 2400 CONTINUE DO2410I=1,N1 Y3(I)=ZERO IF(ZERMIN.LE.Y1(I).AND.Y1(I).LE.ZERMAX.AND. 1 ZERMIN.LE.Y2(I).AND.Y2(I).LE.ZERMAX)Y3(I)=ONE 2410 CONTINUE C ITYP3='VECT' N3=N1 GOTO9000 C C *************************************************** C ** STEP 25-- ** C ** TREAT THE LOGICAL IMPLICATION CASE ** C ** 0 0 1 1 & 0 1 0 1 YIELDS 1 1 0 1 ** C *************************************************** C 2500 CONTINUE DO2510I=1,N1 Y3(I)=ONE IF(ONEMIN.LE.Y1(I).AND.Y1(I).LE.ONEMAX.AND. 1 ZERMIN.LE.Y2(I).AND.Y2(I).LE.ZERMAX)Y3(I)=ZERO 2510 CONTINUE C ITYP3='VECT' N3=N1 GOTO9000 C C ************************************************ C ** STEP 26-- ** C ** TREAT THE LOGICAL EQUIVALENCE CASE ** C ** 0 0 1 1 & 0 1 0 1 YIELDS 1 0 0 1 ** C ************************************************ C 2600 CONTINUE DO2610I=1,N1 Y3(I)=ZERO IF(ONEMIN.LE.Y1(I).AND.Y1(I).LE.ONEMAX.AND. 1 ONEMIN.LE.Y2(I).AND.Y2(I).LE.ONEMAX)Y3(I)=ONE IF(ZERMIN.LE.Y1(I).AND.Y1(I).LE.ZERMAX.AND. 1 ZERMIN.LE.Y2(I).AND.Y2(I).LE.ZERMAX)Y3(I)=ONE 2610 CONTINUE C ITYP3='VECT' N3=N1 GOTO9000 C C ********************************************* C ** STEP 27-- ** C ** TREAT THE LOGICAL NOT CASE ** C ** 0 1 YIELDS 1 0 ** C ********************************************* C 2700 CONTINUE DO2710I=1,N1 Y3(I)=ZERO IF(ZERMIN.LE.Y1(I).AND.Y1(I).LE.ZERMAX)Y3(I)=ONE 2710 CONTINUE C ITYP3='VECT' N3=N1 GOTO9000 C C ************************************************ C ** STEP 28-- ** C ** TREAT THE LOGICAL XOR CASE ** C ** 0 0 1 1 & 0 1 0 1 YIELDS 0 1 1 0 ** C ************************************************ C 2800 CONTINUE DO2810I=1,N1 Y3(I)=ONE IF(ONEMIN.LE.Y1(I).AND.Y1(I).LE.ONEMAX.AND. 1 ONEMIN.LE.Y2(I).AND.Y2(I).LE.ONEMAX)Y3(I)=ZERO IF(ZERMIN.LE.Y1(I).AND.Y1(I).LE.ZERMAX.AND. 1 ZERMIN.LE.Y2(I).AND.Y2(I).LE.ZERMAX)Y3(I)=ZERO 2810 CONTINUE C ITYP3='VECT' N3=N1 GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE C IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'GARI')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF LOGARI--') 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 9017 FORMAT('N1,N3 = ',2I8) 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) 9032 FORMAT('I,Y3(I) = ',I8,E13.5) CALL DPWRST('XXX','BUG ') 9031 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE LOGGAM(X,ALG) C C THIS PROGRAM CALCULATES THE LOG(TO BASE E) OF THE GAMMA FUNCTION C THE INPUT IS SINGLE PRECISION X C THE OUTPUT IS SINGLE PRECISION ALG C ALL INTERNAL OPERATIONS ARE DONE IN SINGLE PRECISION C THE ALGORITHM IS TO USE THE RECURSION FORMULA G(X)=G(X+1)/X C UNTIL X IS LARGE ENOUGH TO USE AN ASYMPTOTIC FORMULA FOR G(X)--THE CUT-OFF C POINT USED WAS X = 10 C THE ASYMPTOTIC FORMULA USED IS IN AMS 55, PAGE 257, 6.1.41 (THE FIRST 9 C TERMS OF THE SERIES WERE USED--I.E., OUT TO X**-17) C ALTHOUGH THE DATA STATEMENT DEFINES 10 COEFFICIENTS, THE PROGRAM MAKES USE C OF ONLY 9 COEFFICIENTS (THE ERROR BEING BOUNDED BY THE TENTH COEFFICIENT C DIVIDED BY X**19 C SUBROUTINES NEEDED--NONE C PRINTING--NONE UNLESS AN ERROR CONDITION EXISTS C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-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--82.6 C ORIGINAL VERSION--JUNE 1972. C UPDATED --FEBRUARY 1981. C UPDATED --FEBRUARY 1982. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION Y,Y2,Y3,Y4,Y5,DEN,A,B,C,D C DIMENSION D(10) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C DATA C/ .918938533204672741D0/ DATA D(1),D(2),D(3),D(4),D(5) 1 /+.833333333333333333D-1,-.277777777777777778D-2, 1+.793650793650793651D-3,-.595238095238095238D-3,+.8417508417508417 151D-3/ DATA D(6),D(7),D(8),D(9),D(10) 1 /-.191752691752691753D-2,+.641025641025641025D-2,-.2955065359 147712418D-1,+.179644372368830573D0,-.139243221690590111D1/ C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(X.LE.0.0D0)GOTO50 GOTO90 50 WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,45)X CALL DPWRST('XXX','BUG ') RETURN 90 CONTINUE 5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ', 1'LOGGAM SUBROUTINE IS NON-POSITIVE *****') 45 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',D22.15,' *****') C Y=X DEN=1.0D0 100 IF(Y.GE.10.0D0)GOTO200 DEN=DEN*Y Y=Y+1 GOTO100 200 Y2=Y*Y Y3=Y*Y2 Y4=Y2*Y2 Y5=Y2*Y3 A=(Y-0.5D0)*DLOG(Y)-Y+C B=D(1)/Y+D(2)/Y3+D(3)/Y5+D(4)/(Y2*Y5)+D(5)/(Y4*Y5)+ 1D(6)/(Y*Y5*Y5)+D(7)/(Y3*Y5*Y5)+D(8)/(Y5*Y5*Y5)+D(9)/(Y2*Y5*Y5*Y5) ALG=(A+B)-DLOG(DEN) C RETURN END SUBROUTINE LOGIST(N,X,X0,AK,IERROR) C C PURPOSE--THIS SUBROUTINE GENERATES N LOGISTIC NUMBERS C (A CLASSIC CHAOS THEORY SEQUENCE) C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF LOGISTIC 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 LOGISTIC NUMBERS C WILL BE PLACED. C --X0 = THE STARTING VALUE C (THIS WILL BE THE FIRST VALUE C OF THE OUTPUT SEQUENCE) C --AK = THE INDEX FOR THE SYSTEM C OUTPUT--N LOGISTIC-SEQUENCE 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 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--89.6 C ORIGINAL VERSION--APRIL 1989. 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 CPUMA3=CPUMAX/3.0 C C ****************************************** C ** TREAT THE LOGISTIC SEQUENCE 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 LOGIST--') 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 LOGISTIC 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)=X0 IF(N.LT.2)GOTO1190 DO1100I=2,N I2=I IM1=I-1 X(I)=AK*X(IM1)*(1.0-X(IM1)) IF(X(I).GE.CPUMA3)GOTO1150 1100 CONTINUE GOTO1190 C 1150 CONTINUE I2P1=I2+1 WRITE(ICOUT,1151) 1151 FORMAT('***** ERROR IN LOGIST--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1152) 1152 FORMAT(' A NUMBER IN THE LOGISTIC SEQUENCE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1153) 1153 FORMAT(' HAS JUST EXCEEDED THE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1154) 1154 FORMAT(' LARGEST FLOATING POINT NUMBER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1155) 1155 FORMAT(' ALLOWABLE FOR THIS COMPUTER (',E15.7,').') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1156) 1156 FORMAT(' THE VALUE CAUSING THE OVERFLOW WAS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1157)I2P1 1157 FORMAT(' THE ',I8,'-TH NUMBER IN THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1158) 1158 FORMAT(' LOGISTIC SEQUENCE.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 1190 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE RETURN END SUBROUTINE LOGCDF(X,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE LOGISTIC DISTRIBUTION C WITH MEAN = 0 AND STANDARD DEVIATION = PI/SQRT(3). C THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS C THE PROBABILITY DENSITY FUNCTION C F(X) = EXP(X)/(1+EXP(X)). 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. C REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--2, 1970, PAGES 1-21. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-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 C CHECK THE INPUT ARGUMENTS FOR ERRORS. C NO INPUT ARGUMENT ERRORS POSSIBLE C FOR THIS DISTRIBUTION. C C-----START POINT----------------------------------------------------- C IF(X.GE.0.0)GOTO150 CDF=EXP(X)/(1.0+EXP(X)) RETURN 150 CDF=1.0/(1.0+EXP(-X)) RETURN C END SUBROUTINE LOGCHA(X,CHAZ) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE HAZARD C FUNCTION VALUE FOR THE LOGISTIC DISTRIBUTION C WITH MEAN = 0 AND STANDARD DEVIATION = PI/SQRT(3). C THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS C THE CUMULATIVE HAZARD FUNCTION C F(X) = 1/(1+EXP(-X)). 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. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--LOG, EXP. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN. C REFERENCES--EVANS, HASTINGS, AND PEACOCK, "STATISITCAL C DISTRIBUTIONS", THIRD EDITION, 2000, PAGES 124-128. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-975-2899 C ORIGINAL VERSION--OCTOBER 2003. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C--------------------------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS. C NO INPUT ARGUMENT ERRORS POSSIBLE C FOR THIS DISTRIBUTION. C C-----START POINT----------------------------------------------------- C CHAZ=LOG(1.0+EXP(-X)) C RETURN END SUBROUTINE LOGHAZ(X,HAZ) C C PURPOSE--THIS SUBROUTINE COMPUTES THE HAZARD C FUNCTION VALUE FOR THE LOGISTIC DISTRIBUTION C WITH MEAN = 0 AND STANDARD DEVIATION = PI/SQRT(3). C THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS C THE HAZARD FUNCTION C F(X) = 1/(1+EXP(-X)). 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 HAZARD C FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION HAZARD C FUNCTION VALUE HAZ. 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. C REFERENCES--EVANS, HASTINGS, AND PEACOCK, "STATISITCAL C DISTRIBUTIONS", THIRD EDITION, 2000, PAGES 124-128. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-975-2899 C ORIGINAL VERSION--OCTOBER 2003. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C--------------------------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS. C NO INPUT ARGUMENT ERRORS POSSIBLE C FOR THIS DISTRIBUTION. C C-----START POINT----------------------------------------------------- C HAZ=1.0/(1.0+EXP(-X)) C RETURN END SUBROUTINE LOGPDF(X,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE LOGISTIC DISTRIBUTION C WITH MEAN = 0 AND STANDARD DEVIATION = PI/SQRT(3). C THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS C THE PROBABILITY DENSITY FUNCTION C F(X) = EXP(X)/(1+EXP(X)). 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. C REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--2, 1970, PAGES 1-21. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-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 C CHECK THE INPUT ARGUMENTS FOR ERRORS. C NO INPUT ARGUMENT ERRORS POSSIBLE C FOR THIS DISTRIBUTION. C C-----START POINT----------------------------------------------------- C PDF=EXP(X)/((1.0+EXP(X))**2) C RETURN END SUBROUTINE LOGPPF(P,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE LOGISTIC DISTRIBUTION C WITH MEAN = 0 AND STANDARD DEVIATION = PI/SQRT(3). C THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS C THE PROBABILITY DENSITY FUNCTION C F(X) = EXP(X)/(1+EXP(X)). 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--EXP. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--FILLIBEN, SIMPLE AND ROBUST LINEAR ESTIMATION C OF THE LOCATION PARAMETER OF A SYMMETRIC C DISTRIBUTION (UNPUBLISHED PH.D. DISSERTATION, C PRINCETON UNIVERSITY), 1969, PAGES 21-44, 229-231. C --FILLIBEN, 'THE PERCENT POINT FUNCTION', C (UNPUBLISHED MANUSCRIPT), 1970, PAGES 28-31. C --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--2, 1970, PAGES 1-21. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--82.6 C ORIGINAL VERSION--JUNE 1972. C UPDATED --SEPTEMBER 1975. C UPDATED --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.LE.0.0.OR.P.GE.1.0)GOTO50 GOTO90 50 WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') RETURN 90 CONTINUE 1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ', 1'LOGPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C CCCCC CALL QCORR(P,Q) CCCCC PPF=ALOG(P/Q) PPF=ALOG(P/(1.0-P)) C RETURN END SUBROUTINE LOGRAN(N,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE LOGISTIC DISTRIBUTION C WITH MEAN = 0 AND STANDARD DEVIATION = PI/SQRT(3). C THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS C THE PROBABILITY DENSITY FUNCTION C F(X) = EXP(X)/(1+EXP(X)). 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 LOGISTIC DISTRIBUTION C WITH MEAN = 0 AND STANDARD DEVIATION = PI/SQRT(3). C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN. C FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--TOCHER, THE ART OF SIMULATION, C 1963, PAGES 14-15. C --HAMMERSLEY AND HANDSCOMB, MONTE CARLO METHODS, C 1964, PAGE 36. C --FILLIBEN, SIMPLE AND ROBUST LINEAR ESTIMATION C OF THE LOCATION PARAMETER OF A SYMMETRIC C DISTRIBUTION (UNPUBLISHED PH.D. DISSERTATION, C PRINCETON UNIVERSITY), 1969, PAGE 230. C --FILLIBEN, 'THE PERCENT POINT FUNCTION', C (UNPUBLISHED MANUSCRIPT), 1970, PAGES 28-31. C --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--2, 1970, PAGES 1-21. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--82.6 C ORIGINAL VERSION--JUNE 1972. C UPDATED --SEPTEMBER 1975. C UPDATED --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)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'LOGRAN 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 LOGISTIC RANDOM NUMBERS C USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD. C DO100I=1,N X(I)=ALOG(X(I)/(1.0-X(I))) 100 CONTINUE C RETURN END SUBROUTINE LOGRD(X,N,NX,XG,T) C THIS SUBROUTINE PLACES A SET OF INTERVALS OVER THE SET OF POINTS C (X(I), I=1,...,N). THIS IS DONE BY PLACING APPROXIMATELY EQUAL C NUMBERS OF THEM WITHIN EACH INTERVAL. C C THE ARGUMENTS ARE AS FOLLOWS. C C N - INPUT. THE NUMBER OF POINTS IN THE ARRAY X. C X - INPUT. THE ARRAY OF X POINTS. C NX - INPUT. THE DESIRED NUMBER OF INTERVALS. C XG - OUTPUT. THE COORDINATES OF THE INTERVAL ENDPOINTS. C T - WORK ARRAY OF DIMENSION AT LEAST N. C C SUBROUTINES USED C SLATEC: SSORT C DIMENSION X(*),XG(*),T(*) C DO 100 I=1,N 100 T(I) = X(I) C CCCCC CALL SSORT(T,T,N,1) CALL SORT(T,N,T) C FINC = REAL(N-1)/REAL(NX+1) 120 DO 140 J=1,NX FK = J*FINC + 1. K = FK WK1 = FK - K 140 XG(J+1) = (1. - WK1)*T(K) + WK1*T(K+1) C XG(1) = T(1) XG(NX+2) = T(N) C RETURN END SUBROUTINE LOGSF(P,SF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE SPARSITY C FUNCTION VALUE FOR THE LOGISTIC DISTRIBUTION C WITH MEAN = 0 AND STANDARD DEVIATION = PI/SQRT(3). C THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS C THE PROBABILITY DENSITY FUNCTION C F(X) = EXP(X)/(1+EXP(X)). 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--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. 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--2, 1970, PAGES 1-21. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY (205.03) C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-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 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 LOGSF') 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 SF=1.0/(P-P*P) C RETURN END SUBROUTINE LOSCDF(X,P,IR,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE AT THE SINGLE PRECISION VALUE X C FOR THE LOST GAMES DISTRIBUTION C WITH SINGLE PRECISION SHAPE PARAMETERS P AND C IR. THIS DISTRIBUTION IS DEFINED FOR ALL C NON-NEGATIVE INTEGER X >= IR. C THIS DISTRIBUTION HAS THE PROBABILITY MASS FUNCTION C p(X;P,IR) = (2*X-IR X)*(1-P)**(X-IR)*(P)**X C *(IR/(2*X-IR)) X = IR, IR+ 1, ... C (X*(X-K)!) C THIS DISTRIBUTION IS USED TO MODEL THE "GAMBLER'S C RUIN" PROBLEM. IT CAN ALSO BE USED TO MODEL A C QUEUE WHERE THE QUEUE FOLLOWS A HOMOGENEOUS POISSON C PROCESS WITH PARAMETER LAMBDA, THE SERVICE TIME IS C EXPONENTIAL WITH PARAMETER MU < LAMBDA, AND THERE C ARE R INITIAL CUSTOMERS. THE LOST GAMES DISTRIBUTION C IS THEN THE DISTRIBUTION OF THE NUMBER OF CUSTOMERS C SERVED UNTIL THE QUEUE FIRST VANISHES WITH C P = LAMBDA/(LAMBDA+MU). C C NOTE THAT WE ARE USING DEVROYE'S FORMULATION OF C THE PDF. HOWEVER, WE USE P > 0.5 (I.E., THE C PROBABILITY THAT THE GAMBLER LOSES ON A GIVEN C HAND) WHEREAS DEVROYE USES P < 0.5 = PROBABILITY C GAMBLER WINS ON A GIVEN HAND. C C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE C AT WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C X SHOULD BE AN INTEGR >= IR. C --P = THE SINGLE PRECISION VALUE C OF THE FIRST SHAPE PARAMETER. C --IR = THE SINGLE PRECISION VALUE C OF THE SECOND SHAPE PARAMETER. C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE C OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION C FUNCTION VALUE CDF FOR THE LOST GAMES DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE AN INTEGER >= IR C --0.5 < P < 1, AND IR >= 1 C OTHER DATAPAC SUBROUTINES NEEDED--DLNGAM. 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. 445-447. C --LUC DEVROYE (1986), "NON-UNIFORM RANDOM VARIATE C GENERATION", SPRINGER-VERLANG, PP. 758-759. C --KEMP AND KEMP (1968), "ON A DISTRIBUTION ASSOCIATED C WITH CERTAIN STOCHASTIC PROCESSES", JOURNAL OF C THE ROYAL STATISTICAL SOCIETY, SERIES B, 30, C PP. 401-410. C --HAIGHT (1961), "A DISTRIBUTION ANALOGOUS TO THE C BOREL-TANNER", BIOMETRIKA, 48, PP. 167-173. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/6 C ORIGINAL VERSION--JUNE 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DP DOUBLE PRECISION DR DOUBLE PRECISION DPDF DOUBLE PRECISION DPDFSV DOUBLE PRECISION DCDF DOUBLE PRECISION DC1 DOUBLE PRECISION DC2 DOUBLE PRECISION DC3 CCCCC DOUBLE PRECISION DTERM1 CCCCC DOUBLE PRECISION DTERM2 CCCCC DOUBLE PRECISION DTERM3 CCCCC 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 CDF=0.0 C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(P.LE.0.5 .OR. P.GE.1.0)THEN WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ENDIF 11 FORMAT('***** ERROR--THE SECOND ARGUMENT TO LOSCDF ', 1' IS OUTSIDE THE ALLOWABLE (0.5,1) INTERVAL') C IF(IR.LT.0)THEN WRITE(ICOUT,12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)IR CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ENDIF 12 FORMAT('***** ERROR--THE THIRD ARGUMENT TO LOSCDF IS ', 1' NEGATIVE') INTX=INT(X+0.5) IF(INTX.LT.IR)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)INTX CALL DPWRST('XXX','BUG ') WRITE(ICOUT,48)INTX CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ENDIF 5 FORMAT('***** ERROR--THE FIRST ARGUMENT TO LOSCDF IS LESS ', 1'THAN THE THIRD ARUGMENT') C 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) 48 FORMAT('***** THE VALUE OF THE THIRD ARGUMENT IS ',I8) C DP=DBLE(P) DR=DBLE(IR) DCDF=0.0D0 C CCCCC DO100I=INTX,IR,-1 CCCCC DX=DBLE(I) CCCCC DTERM1=DLNGAM(2.0D0*DX-DR+1) - DLNGAM(DX+1.0D0) - CCCCC1 DLNGAM(DX-DR+1.0D0) CCCCC DTERM2=(DX-DR)*DLOG(1.0D0-DP) + DX*DLOG(DP) CCCCC DTERM3=DLOG(DR) - DLOG(2.0D0*DX - DR) CCCCC DPDF=DEXP(DTERM1 + DTERM2 + DTERM3) CCCCC DCDF=DCDF+DPDF CC100 CONTINUE C CCCCC CDF=REAL(DCDF) C C USE THE RECURRENCE RELATION (FROM KEMP AND KEMP): C C P(X;P,R) = C*P(X-1;P,R) C C WHERE C C C = (2*X-R-1)*(2*X-R-2)*P*(1-P)/[X*(X-R)] C DC1=DLOG(DP) + DLOG(1.0D0 - DP) DPDF=DR*DLOG(DP) DPDFSV=DPDF DCDF=DEXP(DPDF) C IF(INTX.GT.IR)THEN DO200I=IR+1,INTX DX=DBLE(I) DC2=DLOG(2.0D0*DX-DR-1.0D0) + DLOG(2.0D0*DX-DR-2.0D0) DC3=DLOG(DX) + DLOG(DX-DR) DPDF=DC2 - DC3 + DC1 + DPDFSV DCDF=DCDF + DEXP(DPDF) DPDFSV=DPDF 200 CONTINUE ENDIF C CDF=REAL(DCDF) C 9999 CONTINUE RETURN END SUBROUTINE LOSPDF(X,P,IR,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY MASS C FUNCTION VALUE AT THE SINGLE PRECISION VALUE X C FOR THE LOST GAMES DISTRIBUTION C WITH SINGLE PRECISION SHAPE PARAMETERS P AND C IR. THIS DISTRIBUTION IS DEFINED FOR ALL C NON-NEGATIVE INTEGER X >= IR. C THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION C p(X;P,IR) = (2*X-IR X)*(1-P)**(X-IR)*(P)**X C *(IR/(2*X-IR)) X = IR, IR+ 1, ... C (X*(X-K)!) C THIS DISTRIBUTION IS USED TO MODEL THE "GAMBLER'S C RUIN" PROBLEM. IT CAN ALSO BE USED TO MODEL A C QUEUE WHERE THE QUEUE FOLLOWS A HOMOGENEOUS POISSON C PROCESS WITH PARAMETER LAMBDA, THE SERVICE TIME IS C EXPONENTIAL WITH PARAMETER MU < LAMBDA, AND THERE C ARE R INITIAL CUSTOMERS. THE LOST GAMES DISTRIBUTION C IS THEN THE DISTRIBUTION OF THE NUMBER OF CUSTOMERS C SERVED UNTIL THE QUEUE FIRST VANISHES WITH C P = LAMBDA/(LAMBDA+MU). C C NOTE THAT WE ARE USING DEVROYE'S FORMULATION OF C THE PDF. HOWEVER, WE USE P > 0.5 (I.E., THE C PROBABILITY THAT THE GAMBLER LOSES ON A GIVEN C HAND) WHEREAS DEVROYE USES P < 0.5 = PROBABILITY C GAMBLER WINS ON A GIVEN HAND. 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 AN INTEGR >= IR. C --P = THE SINGLE PRECISION VALUE C OF THE FIRST SHAPE PARAMETER. C --IR = THE SINGLE PRECISION VALUE C OF THE SECOND SHAPE PARAMETER. C OUTPUT ARGUMENTS--PDF = THE SINGLE PRECISION PROBABILITY C MASS FUNCTION VALUE C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY C FUNCTION VALUE PDF C FOR THE LOST GAMES DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE A POSITIVE INTEGER C --0.5 < P < 1, AND IR >= 1 C OTHER DATAPAC SUBROUTINES NEEDED--DLNGAM. 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. 445-447. C --LUC DEVROYE (1986), "NON-UNIFORM RANDOM VARIATE C GENERATION", SPRINGER-VERLANG, PP. 758-759. C --KEMP AND KEMP (1968), "ON A DISTRIBUTION ASSOCIATED C WITH CERTAIN STOCHASTIC PROCESSES", JOURNAL OF C THE ROYAL STATISTICAL SOCIETY, SERIES B, 30, C PP. 401-410. C --HAIGHT (1961), "A DISTRIBUTION ANALOGOUS TO THE C BOREL-TANNER", BIOMETRIKA, 48, PP. 167-173. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/6 C ORIGINAL VERSION--JUNE 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DP DOUBLE PRECISION DR DOUBLE PRECISION DPDF DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 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 IF(P.LE.0.5 .OR. P.GE.1.0)THEN WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF 11 FORMAT('***** ERROR--THE SECOND ARGUMENT TO LOSPDF ', 1' IS OUTSIDE THE ALLOWABLE (0.5,1) INTERVAL') C IF(IR.LT.0)THEN WRITE(ICOUT,12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)IR CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF 12 FORMAT('***** ERROR--THE THIRD ARGUMENT TO LOSPDF IS ', 1' NON-POSITIVE') INTX=INT(X+0.5) IF(INTX.LT.IR)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)INTX CALL DPWRST('XXX','BUG ') WRITE(ICOUT,48)INTX CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF 5 FORMAT('***** ERROR--THE FIRST ARGUMENT TO LOSPDF IS LESS ', 1'THAN THE THIRD ARUGMENT') C 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) 48 FORMAT('***** THE VALUE OF THE THIRD ARGUMENT IS ',I8) C DX=DBLE(INTX) DP=DBLE(P) DR=DBLE(IR) C DTERM1=DLNGAM(2.0D0*DX-DR+1) - DLNGAM(DX+1.0D0) - 1 DLNGAM(DX-DR+1.0D0) DTERM2=(DX-DR)*DLOG(1.0D0-DP) + DX*DLOG(DP) DTERM3=DLOG(DR) - DLOG(2.0D0*DX - DR) DPDF=DEXP(DTERM1 + DTERM2 + DTERM3) C PDF=REAL(DPDF) C 9999 CONTINUE RETURN END SUBROUTINE LOSPPF(P,PPAR,IR,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE AT THE SINGLE PRECISION VALUE P C FOR THE LOST GAMES DISTRIBUTION C WITH SINGLE PRECISION SHAPE PARAMETERS PPAR AND C IR. THIS DISTRIBUTION IS DEFINED FOR ALL C NON-NEGATIVE INTEGER X >= IR. C THIS DISTRIBUTION HAS THE PROBABILITY MASS FUNCTION C p(X;P,IR) = (2*X-IR X)*(1-P)**(X-IR)*(P)**X C *(IR/(2*X-IR)) X = IR, IR+ 1, ... C (X*(X-K)!) C THIS DISTRIBUTION IS USED TO MODEL THE "GAMBLER'S C RUIN" PROBLEM. IT CAN ALSO BE USED TO MODEL A C QUEUE WHERE THE QUEUE FOLLOWS A HOMOGENEOUS POISSON C PROCESS WITH PARAMETER LAMBDA, THE SERVICE TIME IS C EXPONENTIAL WITH PARAMETER MU < LAMBDA, AND THERE C ARE R INITIAL CUSTOMERS. THE LOST GAMES DISTRIBUTION C IS THEN THE DISTRIBUTION OF THE NUMBER OF CUSTOMERS C SERVED UNTIL THE QUEUE FIRST VANISHES WITH C P = LAMBDA/(LAMBDA+MU). C C NOTE THAT WE ARE USING DEVROYE'S FORMULATION OF C THE PDF. HOWEVER, WE USE P > 0.5 (I.E., THE C PROBABILITY THAT THE GAMBLER LOSES ON A GIVEN C HAND) WHEREAS DEVROYE USES P < 0.5 = PROBABILITY C GAMBLER WINS ON A GIVEN HAND. C C INPUT ARGUMENTS--P = THE SINGLE PRECISION VALUE C AT WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. C 0 <= P <= 1. C --PPAR = THE SINGLE PRECISION VALUE C OF THE FIRST SHAPE PARAMETER. C --IR = THE SINGLE PRECISION VALUE C OF THE SECOND SHAPE PARAMETER. C OUTPUT ARGUMENTS--PPF = THE SINGLE PRECISION PERCENT POINT C FUNCTION VALUE C OUTPUT--THE SINGLE PRECISION PERCENT POINT C FUNCTION VALUE PPF FOR THE LOST GAMES DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--0 <= P <= 1 C --0.5 < P < 1, AND IR >= 0 C OTHER DATAPAC SUBROUTINES NEEDED--DLNGAM. 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. 445-447. C --LUC DEVROYE (1986), "NON-UNIFORM RANDOM VARIATE C GENERATION", SPRINGER-VERLANG, PP. 758-759. C --KEMP AND KEMP (1968), "ON A DISTRIBUTION ASSOCIATED C WITH CERTAIN STOCHASTIC PROCESSES", JOURNAL OF C THE ROYAL STATISTICAL SOCIETY, SERIES B, 30, C PP. 401-410. C --HAIGHT (1961), "A DISTRIBUTION ANALOGOUS TO THE C BOREL-TANNER", BIOMETRIKA, 48, PP. 167-173. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006/6 C ORIGINAL VERSION--JUNE 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DP DOUBLE PRECISION DPPAR DOUBLE PRECISION DR DOUBLE PRECISION DPDF DOUBLE PRECISION DPDFSV DOUBLE PRECISION DCDF CCCCC DOUBLE PRECISION DTERM1 CCCCC DOUBLE PRECISION DTERM2 CCCCC DOUBLE PRECISION DTERM3 CCCCC DOUBLE PRECISION DLNGAM DOUBLE PRECISION DC1 DOUBLE PRECISION DC2 DOUBLE PRECISION DC3 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 PPF=0.0 C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(PPAR.LE.0.5 .OR. PPAR.GE.1.0)THEN WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF 11 FORMAT('***** ERROR--THE SECOND ARGUMENT TO LOSPPF ', 1' IS OUTSIDE THE ALLOWABLE (0.5,1) INTERVAL') C IF(IR.LT.0)THEN WRITE(ICOUT,12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)IR CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF 12 FORMAT('***** ERROR--THE THIRD ARGUMENT TO LOSPPF IS ', 1' NEGATIVE') C IF(P.LT.0.0 .OR. P.GE.1.0)THEN WRITE(ICOUT,13) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF 13 FORMAT('***** ERROR--THE FIRST ARGUMENT TO LOSPPF ', 1' IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') C 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) C C USE THE RECURRENCE RELATION (FROM KEMP AND KEMP): C C P(X;P,R) = C*P(X-1;P,R) C C WHERE C C C = (2*X-R-1)*(2*X-R-2)*P*(1-P)/[X*(X-R)] C DPPAR=DBLE(PPAR) DP=DBLE(P) DR=DBLE(IR) I=IR DPDFSV=DR*DLOG(DPPAR) DCDF=DEXP(DPDFSV) IF(DCDF.GE.DP)THEN PPF=REAL(IR) GOTO9999 ENDIF C DC1=DLOG(DPPAR) + DLOG(1.0D0 - DPPAR) 100 CONTINUE I=I+1 IF(DBLE(I).GE.DBLE(I1MACH(9)))THEN WRITE(ICOUT,55) 55 FORMAT('***** ERROR--THE COMPUTED PERCENT POINT VALUE ', 1 'EXCEEDS THE LARGEST MACHINE INTEGER.') CALL DPWRST('XXX','BUG ') PPF=REAL(I) GOTO9999 ENDIF DX=DBLE(I) CCCCC DTERM1=DLNGAM(2.0D0*DX-DR+1) - DLNGAM(DX+1.0D0) - CCCCC1 DLNGAM(DX-DR+1.0D0) CCCCC DTERM2=(DX-DR)*DLOG(1.0D0-DPPAR) + DX*DLOG(DPPAR) CCCCC DTERM3=DLOG(DR) - DLOG(2.0D0*DX - DR) CCCCC DPDF=DEXP(DTERM1 + DTERM2 + DTERM3) CCCCC DCDF=DCDF+DPDF DC2=DLOG(2.0D0*DX-DR-1.0D0) + DLOG(2.0D0*DX-DR-2.0D0) DC3=DLOG(DX) + DLOG(DX-DR) DPDF=DC2 - DC3 + DC1 + DPDFSV DCDF=DCDF + DEXP(DPDF) DPDFSV=DPDF IF(DCDF.GE.DP)THEN PPF=REAL(I) GOTO9999 ENDIF GOTO100 C 9999 CONTINUE RETURN END SUBROUTINE LOSRAN(N,P,IR,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE LOST GAMES DISTRIBUTION C WITH SHAPE PARAMETERS P AND IR. C IR. THIS DISTRIBUTION IS DEFINED FOR ALL C NON-NEGATIVE INTEGER X >= IR. C THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION C p(X;P,IR) = (2*X-IR X)*(1-P)**(X-IR)*(P)**X C *(IR/(2*X-IR)) X = IR, IR+ 1, ... C (X*(X-K)!) C THIS DISTRIBUTION IS USED TO MODEL THE "GAMBLER'S C RUIN" PROBLEM. IT CAN ALSO BE USED TO MODEL A C QUEUE WHERE THE QUEUE FOLLOWS A HOMOGENEOUS POISSON C PROCESS WITH PARAMETER LAMBDA, THE SERVICE TIME IS C EXPONENTIAL WITH PARAMETER MU < LAMBDA, AND THERE C ARE R INITIAL CUSTOMERS. THE LOST GAMES DISTRIBUTION C IS THEN THE DISTRIBUTION OF THE NUMBER OF CUSTOMERS C SERVED UNTIL THE QUEUE FIRST VANISHES WITH C P = LAMBDA/(LAMBDA+MU). C C NOTE THAT WE ARE USING DEVROYE'S FORMULATION OF C THE PDF. HOWEVER, WE USE P > 0.5 (I.E., THE C PROBABILITY THAT THE GAMBLER LOSES ON A GIVEN C HAND) WHEREAS DEVROYE USES P < 0.5 = PROBABILITY C GAMBLER WINS ON A GIVEN HAND. 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 --IR = 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 FROM THE LOST GAMES C DISTRIBUTION WITH SHAPE PARAMETERS P AND IR. 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, IR A NON-NEGATIVE INTEGER C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN, LOSPPF C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND KEMP (1992). "UNIVARIATE C DISCRETE DISTRIBUTIONS", SECOND EDITION, C WILEY, PP. 445-447. C --LUC DEVROYE (1986), "NON-UNIFORM RANDOM VARIATE C GENERATION", SPRINGER-VERLANG, PP. 758-759. C --KEMP AND KEMP (1968), "ON A DISTRIBUTION ASSOCIATED C WITH CERTAIN STOCHASTIC PROCESSES", JOURNAL OF C THE ROYAL STATISTICAL SOCIETY, SERIES B, 30, C PP. 401-410. C --HAIGHT (1961), "A DISTRIBUTION ANALOGOUS TO THE C BOREL-TANNER", BIOMETRIKA, 48, PP. 167-173. 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 INTEGER N INTEGER IR DIMENSION X(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)THEN WRITE(ICOUT, 5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF ', 1'LOST GAMES RANDOM NUMBERS IS NON-POSITIVE') C IF(P.LE.0.5 .OR. P.GE.1.0)THEN WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF 11 FORMAT('***** ERROR--THE P PARAMETER FOR THE LOST GAMES') 12 FORMAT(' RANDOM NUMBERS IS OUTSIDE THE ALLOWABLE (0.5,1) ', 1 'INTERVAL') C IF(IR.LT.0)THEN WRITE(ICOUT,21) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)IR CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF 21 FORMAT('***** ERROR--THE R PARAMETER FOR THE LOST GAMES ', 1 'RANDOM NUMBERS IS NON-POSITIVE') C 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) C CALL UNIRAN(N,ISEED,X) DO100I=1,N XTEMP=X(I) CALL LOSPPF(XTEMP,P,IR,PPF) X(I)=PPF 100 CONTINUE C 9999 CONTINUE C RETURN END SUBROUTINE LOLIP (NXG,XG,NYG,YG,NPI,XI,YI,NP,MP,MPM,NMAX,D) C C THIS SUBROUTINE DETERMINES THE LOCAL INTERPOLATION POINTS FOR THE C GRID VERSION OF FRANKE'S METHOD OF SURFACE INTERPOLATION. C MINPTS POINTS ARE REQUIRED FOR EACH REGION. C IF FEWER THAN MINPTS POINTS ARE FOUND IN THE REGION, THE NEXT C CLOSEST POINTS (IN THE SUP NORM AFTER THE CURRENT RECTANGLE IS C TRANSFORMED ONTO (0,1)) ARE USED. MINPTS IS SET TO 3, WHICH IS C THE RECOMMENDED VALUE, ALTHOUGH IT MAY BE ALTERED. C C THE ARGUMENTS ARE AS FOLLOWS. C C NXG - INPUT. NUMBER OF VERTICAL GRID LINES. C XG - INPUT. THE COORDINATES OF THE VERTICAL GRID LINES, IN C INCREASING ORDER C NYG - INPUT. NUMBER OF HORIZONTAL GRID LINES. C YG - INPUT. THE COORDINATES OF THE HORIZONTAL GRID LINES, C IN INCREASING ORDER. C NPI - INPUT. THE NUMBER OF DATA POINTS. C XI - \ C YI - INPUT. THE DATA POINTS (XI,YI), I=1,...,NPI. C FI - / C NP - OUTPUT. AN ARRAY WHICH GIVES THE INITIAL SUBSCRIPT IN C THE ARRAY MP AT WHICH THE SUBSCRIPTS FOR THE C LOCAL INTERPOLATION POINTS ARE STORED. C MP - OUTPUT. AN ARRAY WHICH GIVES THE SUBSCRIPTS FOR THE C LOCAL INTERPOLATION POINTS. C MPM - INPUT. DIMENSION OF THE ARRAY MP IN THE CALLING PROGRAM C NMAX - OUTPUT. THE MAXIMUM NUMBER OF INTERPOLATION POINTS C OVER ALL THE REGIONS. C D - A WORK ARRAY OF DIMENSION AT LEAST NPI. C DIMENSION XG(*), YG(*), XI(*), YI(*), NP(*), MP(*), D(*) DATA MINPTS/3/ IJ = 1 NP(1) = 1 NMAX = 0 L = 0 C DO 200 J=1,NYG YGA = (YG(J+2)+YG(J))/2. DYG = YG(J+2)-YG(J) C DO 180 I=1,NXG XGA = (XG(I+2)+XG(I))/2. DXG = XG(I+2)-XG(I) IJ = IJ+1 C C DETERMINE THE POINTS IN THE (I,J)TH RECTANGLE. C DO 120 NK=1,NPI D(NK) = AMAX1(ABS(XI(NK) - XGA)/DXG,ABS(YI(NK) - YGA)/DYG) IF(D(NK).GT..6125)GO TO 120 D(NK) = 1.E10 L = L + 1 LL = MIN0(L,MPM) MP(LL) = NK 120 CONTINUE C NP(IJ) = L+1 IF (NP(IJ)-NP(IJ-1).GE.MINPTS) GO TO 180 C C ADD THE CLOSEST POINTS IF THERE ARE LESS THAN MINPTS IN THE C RECTANGLE. C LM = MINPTS-(NP(IJ)-NP(IJ-1)) C DO 160 II=1,LM L = L+1 LL = MIN0(L,MPM) MP(LL) = 1 DM = D(1) C DO 140 NK=2,NPI IF (D(NK).GE.DM) GO TO 140 DM = D(NK) MP(LL) = NK 140 CONTINUE C NK = MP(LL) 160 D(NK) = 1.E10 C NP(IJ) = L+1 180 NMAX = MAX0(NMAX,NP(IJ)-NP(IJ-1)) C 200 CONTINUE C RETURN END SUBROUTINE LOTPS (MODE,NPPR,NPI,XI,YI,FI,NXO,XO,NYO,YO,IWK,NIWK, 1 NIWKU,WK,NWK,NWKU,FO,KER) C***START PROLOGUE LOTPS C C THIS VERSION IS DATED 03/04/82. C C RICHARD FRANKE C DEPARTMENT OF MATHEMATICS C NAVAL POSTGRADUATE SCHOOL C MONTEREY, CALIFORNIA 93940 C (408)646-2758 / 2206 C C C C REFERENCE C SMOOTH INTERPOLATION OF SCATTERED DATA BY LOCAL THIN C PLATE SPLINES, COMPUTERS AND MATHEMATICS WITH C APPLICATIONS 8(1982)???-???+8 C OR C NAVAL POSTGRADUATE SCHOOL TR#NPS-53-81-002, 1981 C (AVAILABLE FROM NTIS, AD-A098 232/2) C C ABSTRACT C SUBROUTINE LOTPS SERVES AS THE USER INTERFACE FOR A SET OF C SUBROUTINES WHICH SOLVE THE SCATTERED DATA INTERPOLATION C PROBLEM. A SMOOTH FUNCTION PASSING THROUGH THE GIVEN POINTS C (XI(K),YI(K),FI(K)),K=1,...,NPI IS CONSTRUCTED. C THE RESULT RETURNED IS AN ARRAY OF VALUES, FO(I,J), OF THE INT- C ERPOLATION FUNCTION AT GRID POINTS, (XO(I),YO(J)),I=1,...,NXO, C J=1,...,NYO. C THE METHOD USED INVOLVES CONSTRUCTION OF LOCALLY DEFINED 'THIN C PLATE SPLINES', WHICH ARE THEN BLENDED TOGETHER SMOOTHLY C THROUGH THE USE OF A PARTITION OF UNITY DEFINED ON A C RECTANGULAR GRID ON THE PLANE. THE FUNCTIONS IN THE PARTITION C OF UNITY ARE UNIVARIATE PIECEWISE HERMITE CUBIC POLYNOMIALS. C C CAUTIONS C THE USER SHOULD BE AWARE THAT FOR SOME DATA THE INTERPOLATION C FUNCTION MAY BE ILL-BEHAVED. SOME INVESTIGATION OF ITS C BEHAVIOR FOR THE TYPE OF DATA TO BE INPUT SHOULD BE UNDERTAKEN C BEFORE IMBEDDING ANY SCHEME FOR SCATTERED DATA INTERPOLATION C INTO ANOTHER PROGRAM. C C DESCRIPTION OF ARGUMENTS C C MODE - INPUT. INDICATES THE STATUS OF THE CALCULATION. C = 1, SET UP THE PROBLEM. COMPUTE THE COEFFICIENTS C FOR THE LOCAL APPROXIMATIONS BY THIN PLATE C SPLINES, AND RETURN THE GRID OF INTERPOLATED C FUNCTION VALUES INDICATED BY NXO, XO, NYO, YO C IN THE ARRAY FO. C = 2, THIS MODE VALUE IS A CONVENIENCE FOR USERS WHO C WISH TO CALL THE ROUTINE TO EVALUATE THE C SURFACE REPEATEDLY ON DIFFERENT GRIDS OF C POINTS. A CALL TO LOTPS WITH MODE = 1 HAS C BEEN MADE PREVIOUSLY, NOW CALCULATE C THE GRID OF INTERPOLATED POINTS INDICATED C BY NXO, XO, NYO, YO IN IN THE ARRAY FO. THE C PROGRAM ASSUMES THAT THE ARRAYS XI, YI, IWK, C AND WK ARE UNCHANGED FROM THE PREVIOUS CALL. C NPPR - INPUT. DESIRED AVERAGE NUMBER OF POINTS PER REGION. C THE SUGGESTED VALUE FOR THE NOVICE USER IS TEN, C WHICH USUALLY GIVES GOOD RESULTS. THIS PAR- C AMETER HAS TO DO WITH THE LOCAL PROPERTY OF THE C SURFACE. THE INFLUENCE REGION OF A POINT HAS C AREA WHICH IS ROUGHLY PROPORTIONAL TO NPPR. C UNDER CERTAIN CONDITIONS, SUCH AS TO PRESERVE C ROTATIONAL INVARIANCE, OR TO FORCE CERTAIN C SETS OF POINTS TO BELONG TO THE SAME REGION, C THE USER MAY SPECIFY HIS OWN GRID LINES. C IF THE USER WISHES TO SPECIFY HIS OWN GRID LINES C X TILDA AND Y TILDA, HE MAY DO SO BY SETTING C NPPR = 0 AND SETTING NECESSARY VALUES IN THE C ARRAYS IWK AND WK, AS NOTED BELOW. DATA WHICH C HAS A POOR DISTRIBUTION OVER THE REGION OF INT- C EREST SHOULD PROBABLY HAVE THE GRID SPECIFIED. C THIS IS ALSO ADVISABLE IF THE X-Y POINTS OCCUR C ALONG LINES. SEE THE REFERENCE FOR ADDITIONAL C DETAILS. C NPI - INPUT. NUMBER OF INPUT DATA POINTS. C XI - \ C YI - INPUT ARRAYS. THE DATA POINTS (XI,YI,FI), I=1,...,NPI. C FI - / C NXO - INPUT. THE NUMBER OF XO VALUES AT WHICH THE INTERP- C OLATION FUNCTION IS TO BE CALCULATED. C XO - INPUT ARRAY. THE VALUES OF X AT WHICH THE INTERPOLATION C FUNCTION IS TO BE CALCULATED. THESE SHOULD C BE IN INCREASING ORDER FOR MOST EFFICIENT C EVALUATION, HOWEVER, THEY ONLY NEED TO BE C MONOTONIC. C NYO - INPUT. THE NUMBER OF YO VALUES AT WHICH THE INTERP- C OLATION FUNCTION IS TO BE CALCULATED. C YO - INPUT ARRAY. THE VALUES OF Y AT WHICH THE INTERPOLATION C FUNCTION IS TO BE CALCULATED. THESE SHOULD C BE IN INCREASING ORDER FOR MOST EFFICIENT C EVALUATION, HOWEVER, THEY ONLY NEED TO BE C MONOTONIC. C IWK - INPUT/OUTPUT ARRAY. THIS ARRAY IS OUTPUT WHEN MODE = 1 C AND IS INPUT WHEN MODE = 2. THIS MUST BE C AN ARRAY DIMENSIONED APPROXIMATELY 7*NPI. THE C EXACT DIMENSION IS NOT KNOWN A PRIORI, BUT C WILL BE RETURNED AS THE VALUE OF NIWKU. C WHEN NPPR IS INPUT AS ZERO THE USER MUST C SPECIFY THE NUMBER OF VERTICAL GRID LINES (THE C NUMBER OF X TILDA VALUES) IN IWK(1) AND THE C NUMBER OF HORIZONTAL GRID LINES (THE NUMBER OF C Y TILDA VALUES) IN IWK(2). C NIWK - INPUT. ON ENTRY WITH MODE = 1 THIS MUST BE SET TO THE C DIMENSION OF THE ARRAY IWK IN THE CALLING C PROGRAM. C NIWKU- OUTPUT. THE ACTUAL NUMBER OF LOCATIONS NEEDED IN THE C ARRAY IWK. C WK - INPUT/OUTPUT ARRAY. THIS ARRAY IS OUTPUT WHEN MODE = 1 C AND IS INPUT WHEN MODE = 2. THIS MUST BE AN C ARRAY DIMENSIONED APPROXIMATELY 7*NPI PLUS C THE NUMBER NEEDED TO SET UP AND SOLVE THE SYSTEM C OF EQUATIONS FOR THE LOCAL APPROXIMATIONS. FOR C NPPR NONZERO THIS WILL BE ABOUT 2.5*NPPR*NPPR C PLUS 11*NPPR. THE EXACT DIMENSION IS NOT KNOWN C A PRIORI, BUT WILL BE RETURNED AS THE VALUE OF C NWKU. C WHEN NPPR IS INPUT AS ZERO THE USER MUST SPECIFY C THE VALUES OF X TILDA AND Y TILDA AS FOLLOWS. C WK(2), ... , WK(NXG+1) ARE THE NXG (= IWK(1)) C X GRID VALUES, X(I) TILDA, IN INCREASING ORDER. C TYPICALLY WK(1) = MIN X(I), ALTHOUGH IT NEED C NOT BE. WK(1) MUST BE LESS THAN OR EQUAL TO C WK(2), AND SHOULD BE LESS THAN OR EQUAL TO C MIN X(I). WK(NXG+2) IS USUALLY MAX X(I), AL- C THOUGH IT NEED NOT BE. WK(NXG+2) MUST BE C GREATER THAN WK(NXG+1), AND SHOULD BE GREATER C THAN OR EQUAL TO MAX X(I). C THE VALUES OF WK(NXG+3), ... , WK(NXG+NYG+4) C ARE THE Y GRID VALUES, Y(I) TILDA, AND MUST C SATISFY DUAL CONDITIONS. C NWK - INPUT. ON ENTRY WITH MODE = 1 THIS MUST BE SET TO THE C DIMENSION OF THE ARRAY WK IN THE CALLING C PROGRAM. C NWKU - OUTPUT. THE ACTUAL NUMBER OF LOCATIONS NEEDED IN THE C ARRAY WK. C FO - OUTPUT ARRAY. VALUES OF THE INTERPOLATION FUNCTION AT C THE GRID OF POINTS INDICATED BY NXO, XO, NYO, YO C FO IS ASSUMED TO BE DIMENSIONED (NXO,NYO) IN THE C CALLING PROGRAM. C KER - OUTPUT. RETURN INDICATOR. C = 0, NORMAL RETURN. C = NONZERO, ERROR CONDITION ENCOUNTERED. C C ERROR MESSAGES C NO. 1 FATAL SINGULAR MATRIX IN THE CALCULATION OF C LOCAL THIN PLATE SPLINES. TRY LARGER C VALUE FOR NPPR AND/OR MINPTS. (MINPTS C IS IN SUBROUTINE LOLIP.) C NO. 2 RECOVERABLE FIRST CALL TO LOTPS MUST BE WITH MODE=1 C NO. 3 FATAL PREVIOUS ERROR RETURN FROM SUBROUTINE C LOCAL NOT CORRECTED. C NO. 4 FATAL ARRAY IWK AND/OR WK NOT DIMENSIONED LARGE C ENOUGH. REDIMENSION AS GIVEN BY NIWKU C AND NWKU. C NO. 5 RECOVERABLE MODE IS OUT OF RANGE. C C SUBROUTINES USED C C THIS PACKAGE: LOGRD, LOLIP, LOCAL, LOEVL. C LINPACK: SGECO, SGESL C SLATEC: SSORT, XERROR C C***END PROLOGUE DIMENSION XI(NPI), YI(NPI), FI(NPI), IWK(NIWK), WK(NWK), 1 XO(NXO), YO(NYO), FO(NXO,NYO) DATA KERO/-1/ IF (MODE.LT.1.OR.MODE.GT.2) GO TO 220 KER = 0 C C ON INITIAL ENTRY MODE = 1, THE GRID LINES ARE SET UP, C LOCAL INTERPOLATION POINTS ARE DETERMINED AND LOCAL APPROXIMATIONS C ARE COMPUTED. C IF (MODE.EQ.2) GO TO 140 NXGWK = 1 NPWK = 3 IF (NPPR.LE.0) GO TO 100 NXG = SQRT(4.*REAL(NPI)/REAL(NPPR))-.5 NXG = MAX0(NXG,1) NYG = NXG IWK(1) = NXG IWK(2) = NYG GO TO 120 100 NXG = IWK(1) NYG = IWK(2) 120 IALWK = NXG+NYG+5 IABWK = IALWK + 3*NXG*NYG NYGWK = NXG+3 MPWK = NXG*NYG+4 C IF(NPPR.LE.0)GO TO 130 CALL LOGRD(XI,NPI,NXG,WK(NXGWK),WK(IALWK)) CALL LOGRD(YI,NPI,NYG,WK(NYGWK),WK(IALWK)) 130 CONTINUE C C DETERMINE THE LOCAL INTERPOLATION POINTS FOR THE REGIONS. MWK = NWK - MPWK + 1 CALL LOLIP (NXG,WK(NXGWK),NYG,WK(NYGWK),NPI,XI,YI,IWK(NPWK), 1IWK(MPWK),MWK,NMAX,WK(IALWK)) NCFM = IABWK +IWK(MPWK - 1)-1 NWKU = NCFM + (NMAX+3)*(NMAX+5) - 1 NIPVT = NXG*NYG+3+IWK(MPWK-1) NIWKU = NIPVT + NMAX + 2 IF (NIWKU.GT.NIWK) GO TO 200 IF (NWKU.GT.NWK) GO TO 200 C C COMPUTE THE LOCAL APPROXIMATIONS. CALL LOCAL (XI,YI,FI,NXG,WK(NXGWK),NYG,WK(NYGWK),IWK(NPWK), 1 IWK(MPWK),WK(IALWK),WK(IABWK),WK(NCFM),IWK(NIPVT),IER) KERO = IER IF (IER.NE.0) GO TO 160 140 IF (KERO.NE.0) GO TO 180 C C COMPUTE THE FUNCTION VALUES ON THE DESIRED GRID OF POINTS. C CALL LOEVL (XI,YI,IWK(1),WK(NXGWK),IWK(2),WK(NYGWK),IWK(NPWK), 1 IWK(MPWK),WK(IALWK),WK(IABWK),NXO,XO,NYO,YO,FO) RETURN C C ERROR RETURNS C 160 KER = IER CCCCC IF(IER.NE.0)CALL XERROR('LOTPS-SINGULAR MATRIX IN LOCAL; INCREAS CCCCC1E NPPR OR SPECIFY OWN GRID LINES',71,1,2) RETURN 180 KER = 3 IF (KERO.LT.0) GO TO 190 CCCCC CALL XERROR('LOTPS-PREVIOUS ERROR FROM SUBROUTINE LOCAL HAS NOT CCCCC1BEEN CORRECTED.',65,3,2) RETURN 190 KER = 2 CCCCC CALL XERROR('LOTPS-FIRST CALL TO LOTPS MUST BE WITH MODE = 1', CCCCC1 47,2,1) RETURN 200 KER = 4 CCCCC CALL XERROR('LOTPS-WORK ARRAYS IWK AND/OR WK NOT DIMENSIONED LAR CCCCC1GE ENOUGH',60,4,2) RETURN 220 KER = 5 CCCCC CALL XERROR('LOTPS-MODE IS OUT OF RANGE. MUST BE 1 OR 2',43,5, CCCCC1 1) RETURN END SUBROUTINE LOWESS(Y,X,N,ALOWFR,ALOWDG, CCCCC MARCH 1994. ADD ARGUMENT. CCCCC SUBROUTINE LOWESS(Y,X,N,ALOWFR, 1XTEMP1,XTEMP2,YS,XS,WH,WV,XTEMP7,MAXNXT, 1PRED2,RES2,ISUBRO,IBUGA3,IERROR) C C PURPOSE--THIS ROUTINE PERFORMS A LOWESS FIT/SMOOTH C OF THE DATA IN Y AND X C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--88/2 C ORIGINAL VERSION--FEBRUARY 1988. C UPDATED --MAY 1989. ERROR BRANCHES AFTER CALLS C UPDATED --MARCH 1994. SUPPORT QUADRATIC LOWESS FITS 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 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C DIMENSION Y(*) DIMENSION X(*) DIMENSION XTEMP1(*) DIMENSION XTEMP2(*) DIMENSION YS(*) DIMENSION XS(*) DIMENSION WH(*) DIMENSION WV(*) DIMENSION XTEMP7(*) DIMENSION PRED2(*) DIMENSION RES2(*) 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='LOWE' ISUBN2='SS ' C IERROR='NO' C IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'WESS')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('**** AT THE BEGINNING OF LOWESS--') 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,61)N,ALOWFR 61 FORMAT('N,ALOWFR = ',I8,E15.7) CALL DPWRST('XXX','BUG ') IF(N.LE.0)GOTO64 DO62I=1,N WRITE(ICOUT,63)I,Y(I),X(I) 63 FORMAT('I,Y(I),X(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 62 CONTINUE 64 CONTINUE 90 CONTINUE C C *********************************** C ** STEP 11-- ** C ** SORT THE DATA ** C ** ACCORDING TO THE HORIZONTAL ** C ** AXIS VARIABLE. ** C ** RECORD THE ORDER OF THE ** C ** INCOMING DATA. ** C *********************************** C ISTEPN='11' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CALL SORTC(X,Y,N,XS,YS) C DO1100I=1,N XTEMP1(I)=I 1100 CONTINUE CALL SORTC(X,XTEMP1,N,XS,XTEMP7) C AN=N C C *********************************************** C ** STEP 12-- ** C ** COMPUTE THE TOTAL ** C ** NUMBER OF NEIGHBORS IN A NEIGHBORHOOD ** C *********************************************** C ISTEPN='12' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NN=INT(ALOWFR*AN+0.5) ANN=NN C C *********************************************** C ** STEP 21-- ** C ** SET THE VERTICAL (ROBUSTNESS) WEIGHTS ** C ** EQUAL TO UNITY PRIOR TO COMPUTING ** C ** INITIAL PREDICTED VALUES ** C *********************************************** C ISTEPN='21' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO2100I=1,N WV(I)=1.0 2100 CONTINUE C C ************************************************ C ** STEP 22-- ** C ** LOOP THROUGH EACH OF THE ** C ** N HORIZONTAL DATA POINTS ** C ** FROM SMALLEST TO LARGEST. ** C ** FOR EACH DATA POINT-- ** C ** 1) COMPUTE NEIGHBORHOOD LIMITS ** C ** 2) COMPUTE HORIZONTAL WEIGHTS ** C ** FOR EACH NEIGHBORHOOD POINT ** C ** 3) COMPUTE A INITIAL PREDICTED VALUE ** C ** FOR THAT POINT VIA A ** C ** WEIGHTED LINEAR FIT ** C ** USING HORIZONTAL WEIGHTS ONLY. ** C ************************************************ C ISTEPN='22' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO2200IT=1,N C CALL NEIGH(IT,NN,XS,N,I1,I2,ISUBRO,IBUGA3,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C DEL1=XS(IT)-XS(I1) DEL2=XS(I2)-XS(IT) XMAXHF=DEL1 IF(DEL2.GT.DEL1)XMAXHF=DEL2 CALL WEIGHH(IT,I1,I2,XS,N,XMAXHF, 1WH,ISUBRO,IBUGA3,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C I3=IT I4=IT CCCCC MARCH 1994. ADD CHECK FOR QUADRATIC DEGREE. IF(ALOWDG.GT.1.5)THEN CALL QUAFIT(IT,I1,I2,XS,YS,WH,WV,N,XMAXHF,I3,I4, 1ALPHA,BETA1,BETA2,PRED2,RES2,ISUBRO,IBUGA3,IERROR) ELSE CALL LINEAR(IT,I1,I2,XS,YS,WH,WV,N,XMAXHF,I3,I4, 1ALPHA,BETA,PRED2,RES2,ISUBRO,IBUGA3,IERROR) ENDIF IF(IERROR.EQ.'YES')GOTO9000 C 2200 CONTINUE C C ************************************************* C ** STEP 31-- ** C ** BASED ON THE INITIAL PREDICTED VALUES ** C ** AND THE CONSEQUENTIAL RESIDUALS, ** C ** COMPUTE VERTICAL (ROBUSTNESS) WEIGHTS ** C ** FOR ALL N DATA POINTS ** C ************************************************* C ISTEPN='31' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CALL WEIGHV(RES2,N,XTEMP1,XTEMP2,MAXNXT, 1WV,ISUBRO,IBUGA3,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C C ************************************************ C ** STEP 32-- ** C ** AGAIN LOOP THROUGH EACH OF THE ** C ** N HORIZONTAL DATA POINTS ** C ** FROM SMALLEST TO LARGEST. ** C ** FOR EACH DATA POINT-- ** C ** 1) COMPUTE NEIGHBORHOOD LIMITS ** C ** 2) COMPUTE HORIZONTAL WEIGHTS ** C ** FOR EACH NEIGHBORHOOD POINT ** C ** 3) COMPUTE A FINAL PREDICTED VALUE ** C ** FOR THAT POINT VIA A ** C ** WEIGHTED LINEAR FIT ** C ** USING BOTH THE HORIZONTAL WEIGHTS ** C ** AND THE VERTICAL WEIGHTS ** C ************************************************ C ISTEPN='32' IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C DO3200IT=1,N C CALL NEIGH(IT,NN,XS,N,I1,I2,ISUBRO,IBUGA3,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C DEL1=XS(IT)-XS(I1) DEL2=XS(I2)-XS(IT) XMAXHF=DEL1 IF(DEL2.GT.DEL1)XMAXHF=DEL2 CALL WEIGHH(IT,I1,I2,XS,N,XMAXHF, 1WH,ISUBRO,IBUGA3,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C I3=IT I4=IT CCCCC MARCH 1994. ADD CHECK FOR QUADRATIC DEGREE. IF(ALOWDG.GT.1.5)THEN CALL QUAFIT(IT,I1,I2,XS,YS,WH,WV,N,XMAXHF,I3,I4, 1ALPHA,BETA1,BETA2,PRED2,RES2,ISUBRO,IBUGA3,IERROR) ELSE CALL LINEAR(IT,I1,I2,XS,YS,WH,WV,N,XMAXHF,I3,I4, 1ALPHA,BETA,PRED2,RES2,ISUBRO,IBUGA3,IERROR) ENDIF IF(IERROR.EQ.'YES')GOTO9000 C 3200 CONTINUE C DO3300I=1,N XTEMP1(I)=PRED2(I) XTEMP2(I)=RES2(I) 3300 CONTINUE C DO3400I=1,N J=XTEMP7(I)+0.5 PRED2(J)=XTEMP1(I) RES2(J)=XTEMP2(I) 3400 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'WESS')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('**** AT THE END OF LOWESS--') 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,9021)N,ALOWFR,NN 9021 FORMAT('N,ALOWFR,NN = ',I8,E15.7,I8) CALL DPWRST('XXX','BUG ') IF(N.LE.0)GOTO9024 DO9022I=1,N WRITE(ICOUT,9023)I,Y(I),X(I),PRED2(I),RES2(I) 9023 FORMAT('I,Y(I),X(I),PRED2(I),RES2(I) = ',I8,4E11.3) CALL DPWRST('XXX','BUG ') 9022 CONTINUE 9024 CONTINUE IF(N.LE.0)GOTO9034 DO9032I=1,N WRITE(ICOUT,9033)I,YS(I),XS(I),WH(I),WV(I),PRED2(I),RES2(I) 9033 FORMAT('I,YS(I),XS(I),WH(I),WV(I),PRED2(I),RES2(I) = ', 1I8,6E11.3) CALL DPWRST('XXX','BUG ') 9032 CONTINUE 9034 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE LOWHIN(X,N,IWRITE,XTEMP,MAXNXT,XLOWHI,IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C SAMPLE LOWER HINGE 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--XLOWHI = THE SINGLE PRECISION VALUE OF THE C COMPUTED SAMPLE LOWER HINGE. C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE C SAMPLE LOWER HINGE. 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-- C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--82.6 C ORIGINAL VERSION--JUNE 1981. 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(*) 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='LOWH' ISUBN2='IN ' C IERROR='NO' C IARG1=0 IARG2=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 LOWHIN--') 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 LOWER HINGE ** 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 LOWHIN--') 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 LOWER HINGE 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 LOWHIN--', 1'THE SECOND INPUT ARGUMENT (N) HAS THE VALUE 1') CALL DPWRST('XXX','BUG ') XLOWHI=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 LOWHIN--', 1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','BUG ') XLOWHI=HOLD GOTO9000 139 CONTINUE C 190 CONTINUE C C ******************************** C ** STEP 2-- ** C ** COMPUTE THE LOWER HINGE. ** C ******************************** C CALL SORT(X,N,XTEMP) C N2=(N+1)/2 IARG1=(N2+1)/2 IARG2=(N2+1)-IARG1 XLOWHI=(XTEMP(IARG1)+XTEMP(IARG2))/2.0 C C j****************************** 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,XLOWHI 811 FORMAT('THE LOWER HINGE 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 LOWHIN--') 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)IARG1,IARG2 9014 FORMAT('IARG1,IARG2 = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)XLOWHI 9015 FORMAT('XLOWHI = ',E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE LOWQUA(X,N,IWRITE,XTEMP,MAXNXT,XLOWQU,IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C SAMPLE LOWER QUARTILE 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--XLOWQU = THE SINGLE PRECISION VALUE OF THE C COMPUTED SAMPLE LOWER QUARTILE. C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE C SAMPLE LOWER QUARTILE. 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 INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--82.6 C ORIGINAL VERSION--JUNE 1981. 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(*) 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='LOWQ' ISUBN2='UA ' 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 LOWQUA--') 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 LOWER QUARTILE ** 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 LOWQUA--') 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 LOWER QUARTILE 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 LOWQUA--', 1'THE SECOND INPUT ARGUMENT (N) HAS THE VALUE 1') CALL DPWRST('XXX','BUG ') XLOWQU=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 LOWQUA--', 1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','BUG ') XLOWQU=HOLD GOTO9000 139 CONTINUE C 190 CONTINUE C C *********************************** C ** STEP 2-- ** C ** COMPUTE THE LOWER QUARTILE. ** C *********************************** C CALL SORT(X,N,XTEMP) C P=0.25 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 XLOWQU=REM*XTEMP(NI)+(1.0-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)N,XLOWQU 811 FORMAT('THE LOWER QUARTILE 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 LOWQUA--') 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)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)XLOWQU 9015 FORMAT('XLOWQU = ',E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE LPOCDF(X,LAMBDA,THETA,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE AT THE SINGLE PRECISION VALUE X C FOR THE LAGRANGE-POISSON DISTRIBUTION C WITH SINGLE PRECISION SHAPE PARAMETERS LAMBDA AND C THETA. THIS DISTRIBUTION IS DEFINED FOR ALL C NON-NEGATIVE INTEGER X >= 0. C THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION C p(X;LAMBDA,THETA) = THETA*EXP(-THETA-LAMBDA*X)* C (THETA+LAMBDA*X)**(X-1)/ C (X*(X-K)!) C X >= 0; 0 < LAMBDA < 1; THETA > 0. C NOTE THAT THIS DISTRIBUTION IS A SHIFTED AND C RE-PARAMETERIZED VERSION OF THE BOREL-TANNER C DISTRIBUTION. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE C AT WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C X SHOULD BE A NON-NEGATIVE INTEGR C --LAMBDA = THE SINGLE PRECISION VALUE C OF THE FIRST SHAPE PARAMETER. C --THETA = THE SINGLE PRECISION VALUE C OF THE SECOND SHAPE PARAMETER. C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY C FUNCTION VALUE CDF C FOR THE LAGRANGE-POISSON DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE A POSITIVE INTEGER C --0 < LAMBDA < 1, AND THETA > 0 C OTHER DATAPAC SUBROUTINES NEEDED--LNGAMM. 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. 394-400. 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/5 C ORIGINAL VERSION--MAY 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C REAL THETA REAL LAMBDA C DOUBLE PRECISION DX DOUBLE PRECISION DLAMB DOUBLE PRECISION DTHETA DOUBLE PRECISION DPDF DOUBLE PRECISION DCDF DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 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 CDF=0.0 C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(LAMBDA.LE.0.0 .OR. LAMBDA.GE.1.0)THEN WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)LAMBDA CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ENDIF C IF(THETA.LE.0.0)THEN WRITE(ICOUT,12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)THETA CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9999 ENDIF INTX=X+0.5 IF(INTX.LT.0)THEN CDF=0.0 GOTO9999 ENDIF C 11 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1' LPOCDF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') 12 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE ', 1' LPOCDF SUBROUTINE IS NON-POSITIVE') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) C DLAMB=DBLE(LAMBDA) DTHETA=DBLE(THETA) DCDF=0.0D0 C IF(INTX.EQ.0)THEN DCDF=DEXP(-DTHETA) ELSEIF(INTX.EQ.1)THEN DCDF=DEXP(-DTHETA) + DTHETA*DEXP(-DTHETA-DLAMB) ELSE DO100I=INTX,0,-1 DX=DBLE(I) DTERM1=DLOG(DTHETA) + (-DTHETA-DLAMB*DX) + 1 (DX-1.0D0)*DLOG(DTHETA+DLAMB*DX) DTERM2=DLNGAM(DX+1.0D0) DPDF=DEXP(DTERM1 - DTERM2) DCDF=DCDF + DPDF 100 CONTINUE ENDIF C CDF=REAL(DCDF) C 9999 CONTINUE RETURN END SUBROUTINE LPOFUN(N,XPAR,FVEC,IFLAG,Y,K) C C PURPOSE--THIS ROUTINE COMPUTES THE FUNCTIONS FOR THE C LAGRANGE-POISSON WEIGHTED DISCREPENCIES (A C MODIFICATION OF MAXIMUM LIKELIHOOD) EQUATIONS. C C SUM[i=1 to k][Y(i) - LPOPDF(X)]* C [(X*(THETA+LAMBDA)/(THETA*(THETA+LAMBDA*X)) - 1] = 0 C C SUM[i=1 to k][Y(i) - LPOPDF(X)]* C [(X*(X-1)/(THETA+LAMBDA*X)) - X] = 0 C C WITH THETA AND LAMBDA DENOTING THE SHAPE PARAMETERS. C THIS ROUTINE ASSUMES THE DATA IS IN THE FORM C C X(I) FREQ(I) C C CALLED BY DNSQE ROUTINE FOR SOLVING SIMULTANEOUS C NONLINEAR EQUATIONS. NOTE THAT THE CALLING SEQUENCE C DID NOT ACCOMODATE A DATA ARRAY (AND ASSCIATED NUMBER OF C OBSERVATIONS), SO THESE WERE ADDED TO THE CALL LIST. C SINCE DNSQE ONLY PASSES ONE ARRAY, WE SPLIT INTO C TWO PARTS: 1 - MAXNXT/2 ARE THE FREQUENCIES WHILE C (MAXNXT/2 + 1) - MAXNXT ARE THE CLASS VALUES (I.E., C THE X). C EXAMPLE--LAGRANGE-POISSON MAXIMUM LIKELIHOOD Y C REFERENCE --FELIX FAMOYE AND CARL M. -S. LEE (1992), C "ESTIMATION OF GENERALIZED POISSON DISTRIBUTION", C COMMUNICATIONS IN STATISTICS -- SIMULATION, C 21(1), PP. 173-188. 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 DTHETA DOUBLE PRECISION DLAMB DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DSUM1 DOUBLE PRECISION DSUM2 C DOUBLE PRECISION XBAR COMMON/LPOCOM/XBAR,MAXNXT,NTOT C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C COMPUTE SOME SUMS C DLAMB=XPAR(1) DTHETA=XPAR(2) C IINDX=MAXNXT/2 C DSUM1=0.0D0 DSUM2=0.0D0 C DO200I=1,K C DX=DBLE(Y(IINDX+I)) DFREQ=Y(I) C CALL LPOPDF(REAL(DX),REAL(DLAMB),REAL(DTHETA),PDF) DTERM1=(DFREQ-DBLE(PDF)) C DTERM2=DX*(DTHETA+DLAMB)/(DTHETA*(DTHETA+DLAMB*DX)) DSUM1=DSUM1 + DTERM1*(DTERM2 - 1.0D0) DTERM3=DX*(DX-1.0D0)/(DTHETA+DLAMB*DX) - DX DSUM2=DSUM2 + DTERM1*DTERM3 C 200 CONTINUE C FVEC(1)=DSUM1 FVEC(2)=DSUM2 C RETURN END SUBROUTINE LPOFU2(N,XPAR,FVEC,IFLAG,Y,K) C C PURPOSE--THIS ROUTINE COMPUTES THE FUNCTIONS FOR THE C LAGRANGE POISSON MAXIMUM LIKELIHOOD EQUATION. C C THE MAXIMUM LIKELIHOOD ESTIMATE OF LAMBDA IS C THE SOLUTION OF THE EQUATION: C C SUM[X=0 to K][X*(X-1)*N(X)/(XBAR+(X-XBAR)*LAMBDA)] - C N*XBAR = 0 C C THIS ROUTINE ASSUMES THE DATA IS IN THE FORM C C X(I) FREQ(I) C C CALLED BY DNSQE ROUTINE FOR SOLVING SIMULTANEOUS C NONLINEAR EQUATIONS. NOTE THAT THE CALLING SEQUENCE C DID NOT ACCOMODATE A DATA ARRAY (AND ASSCIATED NUMBER OF C OBSERVATIONS), SO THESE WERE ADDED TO THE CALL LIST. C SINCE DNSQE ONLY PASSES ONE ARRAY, WE SPLIT INTO C TWO PARTS: 1 - MAXNXT/2 ARE THE FREQUENCIES WHILE C (MAXNXT/2 + 1) - MAXNXT ARE THE CLASS VALUES (I.E., C THE X). C EXAMPLE--LAGRANGE POISSON MAXIMUM LIKELIHOOD Y C REFERENCES--CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY C DISTRIBUTIONS", BIRKHAUSER, CHAPTER 9. 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 DLAMBD DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DSUM1 DOUBLE PRECISION DN DOUBLE PRECISION DX DOUBLE PRECISION DFREQ C DOUBLE PRECISION XBAR COMMON/LPOCOM/XBAR,MAXROW,NTOT C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C DLAMBD=XPAR(1) DN=DBLE(NTOT) IINDX=MAXROW/2 C DTERM1=DN*XBAR C DSUM1=0.0D0 DO100I=0,K DX=DBLE(Y(IINDX+I)) DFREQ=Y(I) DSUM1=DSUM1 + DX*(DX-1.0D0)*DFREQ/(XBAR+(DX-XBAR)*DLAMBD) 100 CONTINUE C FVEC(1)=DSUM1 - DTERM1 C RETURN END SUBROUTINE LPOFU3(N,XPAR,FVEC,IFLAG,Y,K) C C PURPOSE--THIS ROUTINE COMPUTES THE FUNCTIONS FOR THE C LAGRANGE-POISSON EWRC METHOD. EWRC IS A C COMBINATION OF THE WEIGHTED DISCREPENCIES AND C MAXIMUM LIKELIHOOD METHODS. THE EWRC ESTIMATES C ARE THE SOLUTIONS OF THE FOLLOWING EQUATIONS: C C SUM[i=1 to k][Y(i)*(Y(i) - LPOPDF(X))]* C [(X*(THETA+LAMBDA)/(THETA*(THETA+LAMBDA*X)) - 1] = 0 C C SUM[i=1 to k][Y(i)*(Y(i) - LPOPDF(X))]* C [(X*(X-1)/(THETA+LAMBDA*X)) - X] = 0 C C WITH THETA AND LAMBDA DENOTING THE SHAPE PARAMETERS. C THIS ROUTINE ASSUMES THE DATA IS IN THE FORM C C X(I) FREQ(I) C C CALLED BY DNSQE ROUTINE FOR SOLVING SIMULTANEOUS C NONLINEAR EQUATIONS. NOTE THAT THE CALLING SEQUENCE C DID NOT ACCOMODATE A DATA ARRAY (AND ASSCIATED NUMBER OF C OBSERVATIONS), SO THESE WERE ADDED TO THE CALL LIST. C SINCE DNSQE ONLY PASSES ONE ARRAY, WE SPLIT INTO C TWO PARTS: 1 - MAXNXT/2 ARE THE FREQUENCIES WHILE C (MAXNXT/2 + 1) - MAXNXT ARE THE CLASS VALUES (I.E., C THE X). C EXAMPLE--LAGRANGE-POISSON MAXIMUM LIKELIHOOD Y C REFERENCE --FELIX FAMOYE AND CARL M. -S. LEE (1992), C "ESTIMATION OF GENERALIZED POISSON DISTRIBUTION", C COMMUNICATIONS IN STATISTICS -- SIMULATION, C 21(1), PP. 173-188. C --CONSUL AND FAMOYE (2006), "LAGRANGIAN PROBABILITY C DISTRIBUTIONS", BIRKHAUSER, CHAPTER 9. 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/8 C ORIGINAL VERSION--AUGUST 2006. C C--------------------------------------------------------------------- C DOUBLE PRECISION XPAR(*) DOUBLE PRECISION FVEC(*) REAL Y(*) C DOUBLE PRECISION DX DOUBLE PRECISION DTHETA DOUBLE PRECISION DLAMB DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DSUM1 DOUBLE PRECISION DSUM2 C DOUBLE PRECISION XBAR COMMON/LPOCOM/XBAR,MAXNXT,NTOT C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C COMPUTE SOME SUMS C DLAMB=XPAR(1) DTHETA=XPAR(2) C IINDX=MAXNXT/2 C DSUM1=0.0D0 DSUM2=0.0D0 C DO200I=1,K C DX=DBLE(Y(IINDX+I)) DFREQ=Y(I) C CALL LPOPDF(REAL(DX),REAL(DLAMB),REAL(DTHETA),PDF) DTERM1=DFREQ*(DFREQ-DBLE(PDF)) C DTERM2=DX*(DTHETA+DLAMB)/(DTHETA*(DTHETA+DLAMB*DX)) DSUM1=DSUM1 + DTERM1*(DTERM2 - 1.0D0) DTERM3=DX*(DX-1.0D0)/(DTHETA+DLAMB*DX) - DX DSUM2=DSUM2 + DTERM1*DTERM3 C 200 CONTINUE C FVEC(1)=DSUM1 FVEC(2)=DSUM2 C RETURN END SUBROUTINE LPOPDF(X,LAMBDA,THETA,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE AT THE SINGLE PRECISION VALUE X C FOR THE LAGRANGE-POISSON DISTRIBUTION C WITH SINGLE PRECISION SHAPE PARAMETERS LAMBDA AND C THETA. THIS DISTRIBUTION IS DEFINED FOR ALL C NON-NEGATIVE INTEGER X >= 0. C THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION C p(X;LAMBDA,THETA) = THETA*EXP(-THETA-LAMBDA*X)* C (THETA+LAMBDA*X)**(X-1)/ C (X*(X-K)!) C X >= 0; 0 < LAMBDA < 1; THETA > 0. C NOTE THAT THIS DISTRIBUTION IS A SHIFTED AND C RE-PARAMETERIZED VERSION OF THE BOREL-TANNER C DISTRIBUTION. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE C AT WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C X SHOULD BE A NON-NEGATIVE INTEGR C --LAMBDA = THE SINGLE PRECISION VALUE C OF THE FIRST SHAPE PARAMETER. C --THETA = THE SINGLE PRECISION VALUE C OF THE SECOND SHAPE PARAMETER. C OUTPUT ARGUMENTS--PDF = THE SINGLE PRECISION PROBABILITY C MASS FUNCTION VALUE C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY C FUNCTION VALUE PDF C FOR THE LAGRANGE-POISSON DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE A POSITIVE INTEGER C --0 < LAMBDA < 1, AND THETA > 0 C OTHER DATAPAC SUBROUTINES NEEDED--LNGAMM. 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. 394-400. 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/5 C ORIGINAL VERSION--MAY 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C REAL THETA REAL LAMBDA C DOUBLE PRECISION DX DOUBLE PRECISION DLAMB DOUBLE PRECISION DTHETA DOUBLE PRECISION DPDF DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 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 IF(LAMBDA.LE.0.0 .OR. LAMBDA.GE.1.0)THEN WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)LAMBDA CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF C IF(THETA.LE.0.0)THEN WRITE(ICOUT,12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)THETA 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 LPOPDF ', 1'SUBROUTINE IS NON-POSITIVE') 11 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1' LPOPDF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') 12 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE ', 1' LPOPDF 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) DLAMB=DBLE(LAMBDA) DTHETA=DBLE(THETA) C IF(INTX.EQ.0)THEN DPDF=DEXP(-DTHETA) ELSEIF(INTX.EQ.1)THEN DPDF=DTHETA*DEXP(-DTHETA-DLAMB) ELSE DTERM1=DLOG(DTHETA) + (-DTHETA-DLAMB*DX) + 1 (DX-1.0D0)*DLOG(DTHETA+DLAMB*DX) DTERM2=DLNGAM(DX+1.0D0) DPDF=DEXP(DTERM1 - DTERM2) ENDIF PDF=REAL(DPDF) C 9999 CONTINUE RETURN END SUBROUTINE LPOPPF(P,LAMBDA,THETA,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE AT THE SINGLE PRECISION VALUE P C FOR THE LAGRANGE-POISSON DISTRIBUTION C WITH SINGLE PRECISION SHAPE PARAMETERS LAMBDA AND C THETA. THIS DISTRIBUTION IS DEFINED FOR ALL C NON-NEGATIVE INTEGER X >= 0. C THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION C p(X;LAMBDA,THETA) = THETA*EXP(-THETA-LAMBDA*X)* C (THETA+LAMBDA*X)**(X-1)/ C (X*(X-K)!) C X >= 0; 0 < LAMBDA < 1; THETA > 0. C NOTE THAT THIS DISTRIBUTION IS A SHIFTED AND C RE-PARAMETERIZED VERSION OF THE BOREL-TANNER C DISTRIBUTION. C INPUT ARGUMENTS--P = THE SINGLE PRECISION VALUE C AT WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. C X SHOULD BE A NON-NEGATIVE INTEGR C --LAMBDA = THE SINGLE PRECISION VALUE C OF THE FIRST SHAPE PARAMETER. C --THETA = THE SINGLE PRECISION VALUE C OF THE SECOND SHAPE PARAMETER. C OUTPUT ARGUMENTS--PPF = THE SINGLE PRECISION PERCENT POINT C FUNCTION VALUE C OUTPUT--THE SINGLE PRECISION PERCENT POINT C FUNCTION VALUE PPF C FOR THE LAGRANGE-POISSON DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--0 <= P < 1 C --0 < LAMBDA < 1, AND THETA > 0 C OTHER DATAPAC SUBROUTINES NEEDED--LNGAMM. 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. 394-400. 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/5 C ORIGINAL VERSION--MAY 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C REAL P REAL THETA REAL LAMBDA C DOUBLE PRECISION DX DOUBLE PRECISION DP DOUBLE PRECISION DLAMB DOUBLE PRECISION DTHETA DOUBLE PRECISION DCDF DOUBLE PRECISION DPDF DOUBLE PRECISION DPPF DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DLNGAM 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 C-----START POINT----------------------------------------------------- C PPF=0.0 C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(P.LT.0.0.OR.P.GE.1.0)THEN WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PPF=0.0 ENDIF C IF(LAMBDA.LE.0.0 .OR. LAMBDA.GE.1.0)THEN WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)LAMBDA CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF C IF(THETA.LE.0.0)THEN WRITE(ICOUT,12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)THETA CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF C 1 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE ', 1' LPOPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1] INTERVAL') 11 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1' LPOPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') 12 FORMAT('***** ERROR--THE THIRD INPUT ARGUMENT TO THE ', 1' LPOPPF SUBROUTINE IS NON-POSITIVE') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) C DP=DBLE(P) DLAMB=DBLE(LAMBDA) DTHETA=DBLE(THETA) C IF(P.LE.0.0)THEN PPF=0.0 GOTO9999 ENDIF C C COMPUTE PDF FOR X = 0 C DCDF=DEXP(-DTHETA) C IF(DCDF.GE.DP)THEN PPF=0.0 GOTO9999 ENDIF I=0 C DCDF=DCDF + DTHETA*DEXP(-DTHETA-DLAMB) IF(DCDF.GE.DP)THEN PPF=1.0 GOTO9999 ENDIF I=1 C 100 CONTINUE I=I+1 IF(DBLE(I).GE.DBLE(I1MACH(9)))THEN WRITE(ICOUT,55) 55 FORMAT('***** ERROR--THE COMPUTED PERCENT POINT VALUE ', 1 'EXCEEDS THE LARGEST MACHINE INTEGER.') CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9999 ENDIF DX=DBLE(I) DTERM1=DLOG(DTHETA) + (-DTHETA-DLAMB*DX) + 1 (DX-1.0D0)*DLOG(DTHETA+DLAMB*DX) DTERM2=DLNGAM(DX+1.0D0) DPDF=DEXP(DTERM1 - DTERM2) DCDF=DCDF + DPDF IF(DCDF.GE.DP)THEN PPF=REAL(I) GOTO9999 ENDIF GOTO100 C 9999 CONTINUE RETURN END SUBROUTINE LPORAN(N,LAMBDA,THETA,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE LAGRANGE-POISSON DISTRIBUTION C WITH SHAPE PARAMETERS LAMBDA AND THETA. C THIS DISTRIBUTION IS DEFINED FOR ALL C NON-NEGATIVE INTEGER X >= 0. C THIS DISTRIBUTION HAS THE PROBABILITY FUNCTION C p(X;LAMBDA,THETA) = THETA*EXP(-THETA-LAMBDA*X)* C (THETA+LAMBDA*X)**(X-1)/ C (X*(X-K)!) C X >= 0; 0 < LAMBDA < 1; THETA > 0. C NOTE THAT THIS DISTRIBUTION IS A SHIFTED AND C RE-PARAMETERIZED VERSION OF THE BOREL-TANNER C DISTRIBUTION. C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --LAMBDA = THE SINGLE PRECISION VALUE C OF THE FIRST SHAPE PARAMETER. C --THETA = 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 LAGRANGE-POISSON DISTRIBUTION C WITH SHAPE PARAMETERS LAMBDA AND THETA. 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 < LAMBDA < 1, THETA > 0 C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN, LPOPPF 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. 394-400. 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 LAMBDA REAL THETA DIMENSION X(*) C CCCCC DIMENSION U(2) C CCCCC DOUBLE PRECISION PI CCCCC DOUBLE PRECISION C CCCCC DOUBLE PRECISION V CCCCC DOUBLE PRECISION Y CCCCC DOUBLE PRECISION DK CCCCC DOUBLE PRECISION DLAMB CCCCC DOUBLE PRECISION U1 CCCCC DOUBLE PRECISION W CCCCC DOUBLE PRECISION WT 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.14159265358979D+00/ C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)THEN WRITE(ICOUT, 5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF IF(LAMBDA.LE.0.0 .OR. LAMBDA.GE.1.0)THEN WRITE(ICOUT,11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)LAMBDA CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF C IF(THETA.LE.0.0)THEN WRITE(ICOUT,12) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)THETA CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF 5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF ', 1'LAGRANGE-POISSON RANDOM NUMBERS IS NON-POSITIVE') 11 FORMAT('***** ERROR--THE LAMBDA PARAMETER FOR THE ', 1'LAGRANGE-POISSON RANDOM NUMBERS IS OUTSIDE THE (0,1) INTERVAL') 12 FORMAT('***** ERROR--THE THETA PARAMETER FOR THE ', 1'LAGRANGE-POISSON RANDOM NUMBERS IS NON-POSITIVE') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) C C GENERATE N LAGRANGE-POISSON DISTRIBUTION RANDOM NUMBERS C USING THE ALGORITHM GIVEN IN THE DEVROYE PAPER. C C I DON'T THINK I HAVE THIS QUITE RIGHT, SO JUST USE C INVERSE PPF METHOD FOR NOW. C CCCCC NTEMP=2 CCCCC C=1.0D0/DSQRT(2.0D0*PI) CCCCC DK=DBLE(IK) CCCCC DLAMB=DBLE(LAMBDA) C CCCCC DO100I=1,N C C110 CONTINUE CCCCC CALL UNIRAN(NTEMP,ISEED,U) CCCCC U1=DBLE(U(1)) C CCCCC V=(1.0D0 + 4.0D0*C*DSQRT(DK))*U1 C CCCCC IF(V.LE.1.0D0)THEN CCCCC X(I)=REAL(IK) CCCCC GOTO100 CCCCC ELSEIF(V.GT.1.0D0 .AND. V.LE.1.0D0+2.0D0*C*DSQRT(DK))THEN CCCCC Y=DK + 1.0D0 + (V - 1.0D0)**2/(4.0D0*C*C) CCCCC T=C/DSQRT(Y-1.0D0-DK) CCCCC ELSE CCCCC Y=DK + 1.0D0 + (2.0D0*DK*C/(1.0D0+4.0D0*C*DSQRT(DK)-V))**2 CCCCC T=DK*C/(Y-1.0D0-DK)**1.5 CCCCC ENDIF C CCCCC W=DBLE(U(2)) CCCCC WT=W*T CCCCC CALL LPOCDF(REAL(Y),LAMBDA,K,CDF) CCCCC CALL LPOPDF(REAL(Y),LAMBDA,K,PDF) CCCCC CALL LPOPDF(REAL(Y),LAMBDA,K,PPF) CCCCC IF(WT.LT.DBLE(PPF))THEN CCCCC IY=INT(Y+0.5) CCCCC X(I)=REAL(IY) CCCCC GOTO100 CCCCC ELSE CCCCC GOTO110 CCCCC ENDIF C C 100 CONTINUE C CALL UNIRAN(N,ISEED,X) DO100I=1,N XTEMP=X(I) CALL LPOPPF(XTEMP,LAMBDA,THETA,PPF) X(I)=PPF 100 CONTINUE C 9999 CONTINUE C RETURN END LOGICAL FUNCTION LSAME( CA, CB ) * * -- LAPACK auxiliary routine (version 1.1) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. CHARACTER CA, CB * .. * * Purpose * ======= * * LSAME returns .TRUE. if CA is the same letter as CB regardless of * case. * * Arguments * ========= * * CA (input) CHARACTER*1 * CB (input) CHARACTER*1 * CA and CB specify the single characters to be compared. * * .. Intrinsic Functions .. INTRINSIC ICHAR * .. * .. Local Scalars .. INTEGER INTA, INTB, ZCODE * .. * .. Executable Statements .. * * Test if the characters are equal * LSAME = CA.EQ.CB IF( LSAME ) $ RETURN * * Now test for equivalence if both characters are alphabetic. * ZCODE = ICHAR( 'Z' ) * * Use 'Z' rather than 'A' so that ASCII can be detected on Prime * machines, on which ICHAR returns a value with bit 8 set. * ICHAR('A') on Prime machines returns 193 which is the same as * ICHAR('A') on an EBCDIC machine. * INTA = ICHAR( CA ) INTB = ICHAR( CB ) * IF( ZCODE.EQ.90 .OR. ZCODE.EQ.122 ) THEN * * ASCII is assumed - ZCODE is the ASCII code of either lower or * upper case 'Z'. * IF( INTA.GE.97 .AND. INTA.LE.122 ) INTA = INTA - 32 IF( INTB.GE.97 .AND. INTB.LE.122 ) INTB = INTB - 32 * ELSE IF( ZCODE.EQ.233 .OR. ZCODE.EQ.169 ) THEN * * EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or * upper case 'Z'. * IF( INTA.GE.129 .AND. INTA.LE.137 .OR. $ INTA.GE.145 .AND. INTA.LE.153 .OR. $ INTA.GE.162 .AND. INTA.LE.169 ) INTA = INTA + 64 IF( INTB.GE.129 .AND. INTB.LE.137 .OR. $ INTB.GE.145 .AND. INTB.LE.153 .OR. $ INTB.GE.162 .AND. INTB.LE.169 ) INTB = INTB + 64 * ELSE IF( ZCODE.EQ.218 .OR. ZCODE.EQ.250 ) THEN * * ASCII is assumed, on Prime machines - ZCODE is the ASCII code * plus 128 of either lower or upper case 'Z'. * IF( INTA.GE.225 .AND. INTA.LE.250 ) INTA = INTA - 32 IF( INTB.GE.225 .AND. INTB.LE.250 ) INTB = INTB - 32 END IF LSAME = INTA.EQ.INTB * * RETURN * * End of LSAME * END SUBROUTINE LSNCDF(X,ALMBDA,SD,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE LOG-SKEW-NORMAL DISTRIBUTION C WITH SHAPE PARAMETERS = LAMBDA AND SD (SD IS THE C SCALE PARAMETER OF THE CORRESPONDING NORMAL C DISTRIBUTION). C THIS DISTRIBUTION IS DEFINED FOR POSITIVE X AND HAS C THE CUMULATIVE DISTRIBUTION FUNCTION C LSNCDF(X,LAMBDA,SD) = SNCDF(LOG(X)/SD,LAMBDA) C WITH SNPDF DENOTING THE SKEW-NORMAL PROBABILITY C DENSITY 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 --ALMBDA = THE FIRST SHAPE PARAMETER C --SD = THE SECOND SHAPE PARAMETER C OUTPUT ARGUMENTS--PDF = THE SINGLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION C FUNCTION VALUE PDF FOR THE LOG-SKEWED-NORMAL DISTRIBUTION C WITH SHAPE PARAMETERS = LAMBDA AND SD. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--SNCDF C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS C UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION, C JOHN WILEY, 1994, PAGE 454. C --"Log-Skew-Normal and Log-Skew-t Distributions as C Models for Family Income Data", Azzalini, Cappello, C and Kotz, paper downloaded from Azzalini's web C site. 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.3 C ORIGINAL VERSION--MARCH 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C C--------------------------------------------------------------------- C CHARACTER*4 ISKNDF C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT 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 ** CHECK INPUT ARGUMENTS FOR ERRORS ** C *************************************** C IF(X.LE.0.0)THEN CDF=0.0 GOTO9000 ENDIF IF(SD.LE.0.0)THEN WRITE(ICOUT,6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,45)SD CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9000 ENDIF 6 FORMAT('**** ERROR: ARGUMENT FOR THE SECOND SHAPE PARAMETER OF ', 1 'THE LOG-SKEW-NORMAL CDF IS NON-POSITIVE.') 45 FORMAT(' VALUE OF THE ARGUMENT IS ',G15.7) C C ************************************ C ** STEP 2-- ** C ** COMPUTE THE DENSITY FUNCTION ** C ************************************ C ISKNDF='DEFA' CALL SNCDF(LOG(X)/SD,ALMBDA,ISKNDF,CDF) C 9000 CONTINUE RETURN END SUBROUTINE LSNPDF(X,ALMBDA,SD,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE LOG-SKEW-NORMAL DISTRIBUTION C WITH SHAPE PARAMETERS = LAMBDA AND SD (SD IS THE C SCALE PARAMETER OF THE CORRESPONDING NORMAL C DISTRIBUTION). C THIS DISTRIBUTION IS DEFINED FOR POSITIVE X AND HAS C THE PROBABILITY DENSITY FUNCTION C LSNPDF(X,LAMBDA,SD) = (1/(SD*X))* C SNPDF(LOG(X)/SD,LAMBDA) C WITH SNPDF DENOTING THE SKEW-NORMAL PROBABILITY C DENSITY FUNCTION. 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 --ALMBDA = THE FIRST SHAPE PARAMETER C --SD = THE SECOND SHAPE PARAMETER C OUTPUT ARGUMENTS--PDF = THE SINGLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY C FUNCTION VALUE PDF FOR THE LOG-SKEWED-NORMAL DISTRIBUTION C WITH SHAPE PARAMETER = LAMBDA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--NODPDF, NODCDF.. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS C UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION, C JOHN WILEY, 1994, PAGE 454. C --"Log-Skew-Normal and Log-Skew-t Distributions as C Models for Family Income Data", Azzalini, Cappello, C and Kotz, paper downloaded from Azzalini's web C site. 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.3 C ORIGINAL VERSION--MARCH 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DLMBDA DOUBLE PRECISION DSD DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 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 C-----START POINT----------------------------------------------------- C C *************************************** C ** STEP 1-- ** C ** CHECK INPUT ARGUMENTS FOR ERRORS ** C *************************************** C IF(X.EQ.0.0)THEN PDF=0.0 GOTO9000 ELSEIF(X.LT.0.0)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,45)X CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9000 ENDIF IF(SD.LE.0.0)THEN WRITE(ICOUT,6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,45)SD CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9000 ENDIF 5 FORMAT('**** ERROR: ARGUMENT FOR LOG-SKEW-NORMAL DISTRIBUTION ', 1 'IS NON-POSITIVE.') 6 FORMAT('**** ERROR: ARGUMENT FOR THE SECOND SHAPE PARAMETER OF ', 1 'THE LOG-SKEW-NORMAL DISTRIBUTION IS NON-POSITIVE.') 45 FORMAT(' VALUE OF THE ARGUMENT IS ',G15.7) C C ************************************ C ** STEP 2-- ** C ** COMPUTE THE DENSITY FUNCTION ** C ************************************ C DX=DBLE(X) DLMBDA=DBLE(ALMBDA) DSD=DBLE(SD) C CALL NODCDF(DLOG(DX)*DLMBDA/DSD,DTERM1) CALL NODPDF(DLOG(DX)/DSD,DTERM2) DPDF=2.0D0*DTERM1*DTERM2 DPDF=(1.0D0/(DSD*DX))*DPDF PDF=REAL(DPDF) GOTO9000 C 9000 CONTINUE RETURN END SUBROUTINE LSNPPF(P,ALMBDA,SD,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE LOG-SKEW-NORMAL DISTRIBUTION C WITH SHAPE PARAMETERS = LAMBDA AND SD. C THIS DISTRIBUTION IS DEFINED FOR ALL X AND THE C PERCENT POINT FUNCTION IS COMPUTED BY C TAKING THE EXPONENT OF THE SKEW-NORMAL PPF FUNCTION. C INPUT ARGUMENTS--P = THE SINGLE PRECISION VALUE AT C WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. C --ALMBDA = THE FIRST SHAPE PARAMETER C --SD = THE SECOND SHAPE PARAMETER C OUTPUT ARGUMENTS--PPF = THE SINGLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PERCENT POINT C FUNCTION VALUE PPF. C PRINTING--NONE. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--SNPPF. C FORTRAN LIBRARY SUBROUTINES NEEDED--EXP. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS C UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION, C JOHN WILEY, 1994, PAGE 454. C --AZZALINI HAS AUTHORED A NUMBER OF PAPERS ON THIS C DISTRIBUTION. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATION INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.3 C ORIGINAL VERSION--MARCH 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C CHARACTER*4 ISKNDF C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT 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 IF(P.LT.0.0.OR.P.GE.1.0)THEN WRITE(ICOUT,61) 61 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT ', 1 'TO THE LSNPPF SUBROUTINE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,62) 62 FORMAT(' IS OUTSIDE THE ALLOWABLE [0,1) INTERVAL ***') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,63)P 63 FORMAT(' VALUE OF ARGUMENT = ',G15.7) CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9000 ENDIF C IF(SD.LE.0.0)THEN WRITE(ICOUT,6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,45)SD CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9000 ENDIF 6 FORMAT('**** ERROR: ARGUMENT FOR THE SECOND SHAPE PARAMETER OF ', 1 'THE LOG-SKEW-NORMAL PPF IS NON-POSITIVE.') 45 FORMAT(' VALUE OF THE ARGUMENT IS ',G15.7) C ISKNDF='DEFA' CALL SNPPF(P,ALMBDA,ISKNDF,PPF2) PPF=EXP(PPF2*SD) C 9000 CONTINUE RETURN END SUBROUTINE LSNRAN(N,ALMBDA,SD,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE LOG-SKEWED-NORMAL DISTRIBUTION C WITH SHAPE PARAMETERS = ALMBDA AND SD. C THIS DISTRIBUTION IS DEFINED FOR POSITIVE X. C LOG-SKEWED-NORMAL RANDOM NUMBERS ARE FOUND BY C EXPONENTIATING SKEW-NORMAL RANDOM NUMBERS. C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --ALMBDA = THE FIRST SHAPE (PARAMETER) FOR THE C LOG-SKEWED-NORMAL DISTRIBUTION. C --SD = THE SECOND SHAPE (PARAMETER) FOR THE C LOG-SKEWED-NORMAL DISTRIBUTION. C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR C (OF DIMENSION AT LEAST N) C INTO WHICH THE GENERATED C RANDOM SAMPLE WILL BE PLACED. C OUTPUT--A RANDOM SAMPLE OF SIZE N C FROM THE LOG-SKEWED-NORMAL DISTRIBUTION C WITH SHAPE PARAMETERS = ALMBDA 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 --ALMBDA CAN BE ANY REAL NUMBER. C OTHER DATAPAC SUBROUTINES NEEDED--NORRAN. 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 I", SECOND EDITION, C JOHN WILEY, 1994, PAGE 454. C --AZZALINI HAS AUTHORED A NUMBER OF PAPERS ON THIS C DISTRIBUTION. ALGORITHM FOR RANDOM NUMBERS C ADAPTED FROM AZZALINI'S R FUNCTIONS FOR SKEW C NORMAL. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATION INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.3 C ORIGINAL VERSION--MARCH 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C 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 5 FORMAT('***** ERROR--FOR THE LOG-SKEWED-NORMAL DISTRIBUTION,') 6 FORMAT(' THE REQUESTED NUMBER OF RANDOM NUMBERS WAS ', 1 'NON-POSITIVE.') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') C C ALGORITM ADAPTED FROM AZZALINI'S R FUNCTION LIBRARY. C DO100I=1,N C CALL NORRAN(2,ISEED,Y) U1=Y(1) U2=Y(2) ATEMP=ALMBDA*U1 IF(U2.GT.ATEMP)U1=-U1 X(I)=EXP(SD*U1) C 100 CONTINUE C 9999 CONTINUE RETURN END SUBROUTINE LSTCDF(X,NU,ALMBDA,SD,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE LOG-SKEW-T DISTRIBUTION C WITH SHAPE PARAMETERS = NU, LAMBDA AND SD (SD IS THE C SCALE PARAMETER OF THE CORRESPONDING T DISTRIBUTION). C THIS DISTRIBUTION IS DEFINED FOR POSITIVE X AND HAS C THE CUMULATIVE DISTRIBUTION FUNCTION C LSTCDF(X,NU,LAMBDA,SD) = STCDF(LOG(X)/SD,NU,LAMBDA) C WITH SNPDF DENOTING THE SKEW-T PROBABILITY C DENSITY 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 --NU = THE FIRST SHAPE PARAMETER C --ALMBDA = THE SECOND SHAPE PARAMETER C --SD = THE THIRD SHAPE PARAMETER C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION C FUNCTION VALUE CDF FOR THE LOG-SKEWED-T DISTRIBUTION C WITH SHAPE PARAMETERS = NU, LAMBDA, AND SD. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--STCDF C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS C UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION, C JOHN WILEY, 1994, PAGE 454. C --"Log-Skew-Normal and Log-Skew-t Distributions as C Models for Family Income Data", Azzalini, Cappello, C and Kotz, paper downloaded from Azzalini's web C site. 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.3 C ORIGINAL VERSION--MARCH 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C 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-----DATA STATEMENTS------------------------------------------------- C C-----START POINT----------------------------------------------------- C C *************************************** C ** STEP 1-- ** C ** CHECK INPUT ARGUMENTS FOR ERRORS ** C *************************************** C IF(X.LE.0.0)THEN CDF=0.0 GOTO9000 ENDIF IF(NU.LE.0)THEN WRITE(ICOUT,7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)NU CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9000 ENDIF IF(SD.LE.0.0)THEN WRITE(ICOUT,6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,45)SD CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9000 ENDIF 6 FORMAT('**** ERROR: ARGUMENT FOR THE THIRD SHAPE PARAMETER OF ', 1 'THE LOG-SKEW-T CDF IS NON-POSITIVE.') 7 FORMAT('**** ERROR: ARGUMENT FOR THE FIRST (DEGREES OF ', 1 'FREEDOM) SHAPE PARAMETER OF') 8 FORMAT(' THE LOG-SKEW-T CDF IS NON-POSITIVE.') 45 FORMAT(' VALUE OF THE ARGUMENT IS ',G15.7) 46 FORMAT(' VALUE OF THE ARGUMENT IS ',I8) C C ************************************ C ** STEP 2-- ** C ** COMPUTE THE DENSITY FUNCTION ** C ************************************ C CALL STCDF(LOG(X)/SD,NU,ALMBDA,CDF) C 9000 CONTINUE RETURN END SUBROUTINE LSTPDF(X,NU,ALMBDA,SD,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE LOG-SKEW-T DISTRIBUTION C WITH SHAPE PARAMETERS = NU, LAMBDA AND SD (SD IS THE C SCALE PARAMETER OF THE CORRESPONDING T DISTRIBUTION). C THIS DISTRIBUTION IS DEFINED FOR POSITIVE X AND HAS C THE PROBABILITY DENSITY FUNCTION C LSTPDF(X,NU,LAMBDA,SD) = (1/(SD*X))* C STPDF(LOG(X)/SD,NU,LAMBDA,SD) C WITH SNPDF DENOTING THE SKEW-T PROBABILITY C DENSITY FUNCTION. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C X SHOULD BE NON-NEGATIVE. C --NU = THE FIRST SHAPE PARAMETER C --ALMBDA = THE SECOND SHAPE PARAMETER C --SD = THE THIRD SHAPE PARAMETER C OUTPUT ARGUMENTS--PDF = THE SINGLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY C FUNCTION VALUE PDF FOR THE LOG-SKEWED-T DISTRIBUTION C WITH SHAPE PARAMETERS = NU, LAMBDA, AND SD. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--STPDF C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS C UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION, C JOHN WILEY, 1994, PAGE 454. C --"Log-Skew-Normal and Log-Skew-t Distributions as C Models for Family Income Data", Azzalini, Cappello, C and Kotz, paper downloaded from Azzalini's web C site. 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.3 C ORIGINAL VERSION--MARCH 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C 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-----DATA STATEMENTS------------------------------------------------- C C-----START POINT----------------------------------------------------- C C *************************************** C ** STEP 1-- ** C ** CHECK INPUT ARGUMENTS FOR ERRORS ** C *************************************** C IF(X.LE.0.0)THEN PDF=0.0 GOTO9000 ENDIF IF(NU.LE.0)THEN WRITE(ICOUT,7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)NU CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9000 ENDIF IF(SD.LE.0.0)THEN WRITE(ICOUT,6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,45)SD CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9000 ENDIF 6 FORMAT('**** ERROR: ARGUMENT FOR THE THIRD SHAPE PARAMETER OF ', 1 'THE LOG-SKEW-T PDF IS NON-POSITIVE.') 7 FORMAT('**** ERROR: ARGUMENT FOR THE FIRST (DEGREES OF ', 1 'FREEDOM) SHAPE PARAMETER OF') 8 FORMAT(' THE LOG-SKEW-T PDF IS NON-POSITIVE.') 45 FORMAT(' VALUE OF THE ARGUMENT IS ',G15.7) 46 FORMAT(' VALUE OF THE ARGUMENT IS ',I8) C C ************************************ C ** STEP 2-- ** C ** COMPUTE THE DENSITY FUNCTION ** C ************************************ C CALL STPDF(LOG(X)/SD,NU,ALMBDA,PDF) PDF=(1.0/(SD*X))*PDF C 9000 CONTINUE RETURN END SUBROUTINE LSTPPF(P,NU,ALMBDA,SD,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE LOG-SKEW-T DISTRIBUTION C WITH SHAPE PARAMETERS = NU, LAMBDA AND SD. C THIS DISTRIBUTION IS DEFINED FOR ALL X AND THE C PERCENT POINT FUNCTION IS COMPUTED BY C TAKING THE EXPONENT OF THE SKEW-T PPF FUNCTION. C INPUT ARGUMENTS--P = THE SINGLE PRECISION VALUE AT C WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. C --NU = THE FIRST SHAPE PARAMETER C --ALMBDA = THE SECOND SHAPE PARAMETER C --SD = THE THIRD SHAPE PARAMETER C OUTPUT ARGUMENTS--PPF = THE SINGLE PRECISION CUMULATIVE C DISTRIBUTION FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PERCENT POINT C FUNCTION VALUE PPF. C PRINTING--NONE. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--STPPF. C FORTRAN LIBRARY SUBROUTINES NEEDED--EXP. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, AND BALAKRISHNAN, "CONTINUOUS C UNIVARIATE DISTRIBUTIONS--VOLUME I", SECOND EDITION, C JOHN WILEY, 1994, PAGE 454. C --"Log-Skew-Normal and Log-Skew-t Distributions as C Models for Family Income Data", Azzalini, Cappello, C and Kotz, paper downloaded from Azzalini's web C site. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATION INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.3 C ORIGINAL VERSION--MARCH 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT 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 IF(P.LT.0.0.OR.P.GE.1.0)THEN WRITE(ICOUT,61) 61 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT ', 1 'TO THE LSTPPF SUBROUTINE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,62) 62 FORMAT(' IS OUTSIDE THE ALLOWABLE [0,1) INTERVAL ***') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,63)P 63 FORMAT(' VALUE OF ARGUMENT = ',G15.7) CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9000 ENDIF C IF(NU.LE.0)THEN WRITE(ICOUT,7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)NU CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9000 ENDIF IF(SD.LE.0.0)THEN WRITE(ICOUT,6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,45)SD CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9000 ENDIF 6 FORMAT('**** ERROR: ARGUMENT FOR THE THIRD SHAPE PARAMETER OF ', 1 'THE LOG-SKEW-T PPF IS NON-POSITIVE.') 7 FORMAT('**** ERROR: ARGUMENT FOR THE FIRST (DEGREES OF ', 1 'FREEDOM) SHAPE PARAMETER OF') 8 FORMAT(' THE LOG-SKEW-T PPF IS NON-POSITIVE.') 45 FORMAT(' VALUE OF THE ARGUMENT IS ',G15.7) 46 FORMAT(' VALUE OF THE ARGUMENT IS ',I8) C CALL STPPF(P,NU,ALMBDA,PPF2) PPF=EXP(PPF2*SD) C 9000 CONTINUE RETURN END SUBROUTINE LSTRAN(N,NU,ALMBDA,SD,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE LOG-SKEWED-T DISTRIBUTION C WITH SHAPE PARAMETERS = NU, ALMBDA AND SD. C THIS DISTRIBUTION IS DEFINED FOR POSITIVE X. C LOG-SKEWED-T RANDOM NUMBERS ARE FOUND BY C EXPONENTIATING SKEW-NORMAL RANDOM NUMBERS. C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --NU = THE FIRST SHAPE (PARAMETER) FOR THE C LOG-SKEWED-T DISTRIBUTION. C --ALMBDA = THE SECOND SHAPE (PARAMETER) FOR THE C LOG-SKEWED-T DISTRIBUTION. C --SD = THE THIRD SHAPE (PARAMETER) FOR THE C LOG-SKEWED-T DISTRIBUTION. C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR C (OF DIMENSION AT LEAST N) C INTO WHICH THE GENERATED C RANDOM SAMPLE WILL BE PLACED. C OUTPUT--A RANDOM SAMPLE OF SIZE N C FROM THE LOG-SKEWED-T DISTRIBUTION C WITH SHAPE PARAMETERS = NU, ALMBDA, 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 --ALMBDA CAN BE ANY REAL NUMBER. C OTHER DATAPAC SUBROUTINES NEEDED--STRAN. 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 I", SECOND EDITION, C JOHN WILEY, 1994, PAGE 454. C --"Log-Skew-Normal and Log-Skew-t Distributions as C Models for Family Income Data", Azzalini, Cappello, C and Kotz, paper downloaded from Azzalini's web C site. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATION INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.3 C ORIGINAL VERSION--MARCH 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C 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 ') GOTO9000 ENDIF IF(NU.LE.0)THEN WRITE(ICOUT,7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)NU CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF IF(SD.LE.0.0)THEN WRITE(ICOUT,9) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,45)SD CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 5 FORMAT('***** ERROR--FOR THE LOG-SKEWED-T DISTRIBUTION,') 6 FORMAT(' THE REQUESTED NUMBER OF RANDOM NUMBERS WAS ', 1 'NON-POSITIVE.') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') 7 FORMAT('**** ERROR: ARGUMENT FOR THE FIRST (DEGREES OF ', 1 'FREEDOM) SHAPE PARAMETER OF') 8 FORMAT(' THE LOG-SKEW-T CDF IS NON-POSITIVE.') 9 FORMAT('**** ERROR: ARGUMENT FOR THE THIRD SHAPE PARAMETER OF ', 1 'THE LOG-SKEW-T CDF IS NON-POSITIVE.') 45 FORMAT(' VALUE OF THE ARGUMENT IS ',G15.7) C C TRANSFORM SKEWED T RANDOM NUMBERS C CALL STRAN(N,NU,ALMBDA,ISEED,X) C DO100I=1,N X(I)=EXP(SD*X(I)) 100 CONTINUE C 9000 CONTINUE RETURN END subroutine ma(x, n, len, ave) c c This routine is part of the Bill Cleveland seasonal loess c program. c integer n, len, i, j, k, m, newn real x(n), ave(n), flen, v newn = n-len+1 flen = real(len) v = 0.0 do 23083 i = 1,len v = v+x(i) 23083 continue ave(1) = v/flen if(.not.(newn .gt. 1))goto 23085 k = len m = 0 do 23087 j = 2, newn k = k+1 m = m+1 v = v-x(m)+x(k) ave(j) = v/flen 23087 continue 23085 continue return end SUBROUTINE MAD(X,N,IWRITE,XTEMP,MAXNXT,XMAD,IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C SAMPLE MEDIAN ABSOLUTE DEVIATION (WITH DENOMINATOR N) C OF THE DATA IN THE INPUT VECTOR X. C THE SAMPLE MEDIAN ABSOLUTE DEVIATION = (THE MEDIAN OF C THE ABSOLUTE DEVIATIONS ABOUT THE SAMPLE MEDIAN) / 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--XMAD = THE SINGLE PRECISION VALUE OF THE C COMPUTED SAMPLE MEDIAN ABSOLUTE DEVIATION. C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE C SAMPLE MEDIAN ABSOLUTE DEVIATION (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--MOSTELLER AND TUKEY, 'DATA ANALYSIS AND REGRESSION' C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--95/3 C ORIGINAL VERSION--MARCH 1995. 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 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='MAD ' 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 MAD--') 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 ABSOLUTE DEVIATION ** C ****************************************** C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C AN=N C IF(N.GE.1)GOTO119 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN MAD--') 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 ABSOLUTE DEVIATION 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 MAD--', 1'THE SECOND INPUT ARGUMENT (N) HAS THE VALUE 1') CALL DPWRST('XXX','BUG ') XMAD=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 MAD--', 1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','BUG ') XMAD=0.0 GOTO9000 139 CONTINUE C 190 CONTINUE C C *********************************************** C ** STEP 2-- ** C ** COMPUTE THE MEDIAN ABSOLUTE DEVIATION. ** C *********************************************** C IWRIT2='OFF' CALL MEDIAN(X,N,IWRIT2,XTEMP,MAXNXT,XMED,IBUGA3,IERROR) C DO300I=1,N X(I)=ABS(X(I)-XMED) 300 CONTINUE IWRIT2='OFF' CALL MEDIAN(X,N,IWRIT2,XTEMP,MAXNXT,XMAD,IBUGA3,IERROR) 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,XMAD 811 FORMAT('THE MEDIAN ABSOLUTE DEVIATION OF THE ',I8, 1' OBSERVATIONS = ',E15.7) CALL DPWRST('XXX','BUG ') 890 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF MAD--') 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 9014 FORMAT('XMED = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)XMAD 9015 FORMAT('XMAD = ',E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE MAHDIS(AMAT1,AMAT2,AMAT3,MAXROM,MAXCOM,NR1,NC1, 1Y1,Y2,INDEX,DMEAN, 1ICASE,IWRITE,IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C MAHALONBIS DISTANCE OF A MATRIX. C INPUT ARGUMENTS--AMAT1 = 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--AMAT3 = THE SINGLE PRECISION VALUE OF THE C COMPUTED MAHALANOBIS DISTANCE MATRIX. C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE C MAHALANOBIS DISTANCE 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 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--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 DIMENSION AMAT1(MAXROM,MAXCOM) DIMENSION AMAT2(MAXROM,MAXCOM) DIMENSION AMAT3(MAXROM,MAXCOM) DIMENSION Y1(*) DIMENSION Y2(*) DIMENSION INDEX(*) DOUBLE PRECISION DMEAN(*) 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='MAHD' ISUBN2='IS ' C IWRITE='NO' 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 MAHDIS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3,ICASE 52 FORMAT('IBUGA3,ICASE = ',2A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)NR1,NC1 53 FORMAT('NR1, NC1 = ',2I8) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ********************************** C ** COMPUTE MAHALNOBIS DISTANCE ** C ********************************** C IF(ICASE.EQ.'COLU')THEN CALL VARCOV(AMAT1,AMAT2,MAXROM,MAXCOM,NR1,NC1,DMEAN, 1 ICASE,IBUGA3,IERROR) CALL SGECO(AMAT2,MAXROM,NC1,INDEX,RCOND,Y1) C IF(1.0+RCOND.EQ.1.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5171) CALL DPWRST('XXX','ERRO ') WRITE(ICOUT,5172) CALL DPWRST('XXX','ERRO ') WRITE(ICOUT,5173) CALL DPWRST('XXX','ERRO ') IERROR='YES' GOTO9000 ENDIF 5171 FORMAT('*** ERROR FROM MAHDIS: UNABLE TO COMPUTE THE INVERSE OF ', 1 'THE COVARIANCE MATRIX.') 5172 FORMAT(' PROBLEM: SOME ROWS ARE LINEARLY DEPDENDENT ON OTHER', 1 ' ROWS.') 5173 FORMAT(' SUGGESTED SOLUTION: WORK WITH A SUBSET OF THE ', 1 'ORIGINAL ROWS.') C IJOB=1 CALL SGEDI(AMAT2,MAXROM,NR1,INDEX,Y1,Y2,IJOB) DO5111I=1,NC1 DO5113J=1,I IF(I.EQ.J)THEN AMAT3(I,I)=0.0 ELSE DO5117K=1,NR1 Y1(K)=AMAT1(K,I)-AMAT1(K,J) 5117 CONTINUE CALL QUAFRM(AMAT2,MAXROM,MAXCOM,NR1,NR1,Y1,IWRITE, 1 XQUAD,IBUGA3,IERROR) AMAT3(I,J)=XQUAD AMAT3(J,I)=XQUAD ENDIF 5113 CONTINUE 5111 CONTINUE ELSE CALL VARCOV(AMAT1,AMAT2,MAXROM,MAXCOM,NR1,NC1,DMEAN, 1 ICASE,IBUGA3,IERROR) CALL SGECO(AMAT2,MAXROM,NR1,INDEX,RCOND,Y1) C IF(1.0+RCOND.EQ.1.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6171) CALL DPWRST('XXX','ERRO ') WRITE(ICOUT,6172) CALL DPWRST('XXX','ERRO ') WRITE(ICOUT,6173) CALL DPWRST('XXX','ERRO ') IERROR='YES' GOTO9000 ENDIF 6171 FORMAT('*** ERROR FROM MAHDIS: UNABLE TO COMPUTE THE INVERSE OF ', 1 'THE COVARIANCE MATRIX.') 6172 FORMAT(' PROBLEM: SOME ROWS ARE LINEARLY DEPDENDENT ON OTHER', 1 ' ROWS.') 6173 FORMAT(' SUGGESTED SOLUTION: WORK WITH A SUBSET OF THE ', 1 'ORIGINAL ROWS.') C IJOB=1 CALL SGEDI(AMAT2,MAXROM,NR1,INDEX,Y1,Y2,IJOB) DO6111I=1,NR1 DO6113J=1,I IF(I.EQ.J)THEN AMAT3(I,I)=0.0 ELSE DO6117K=1,NC1 Y1(K)=AMAT1(I,K)-AMAT1(J,K) 6117 CONTINUE CALL QUAFRM(AMAT2,MAXROM,MAXCOM,NC1,NC1,Y1,IWRITE, 1 XQUAD,IBUGA3,IERROR) AMAT3(I,J)=XQUAD AMAT3(J,I)=XQUAD ENDIF 6113 CONTINUE 6111 CONTINUE ENDIF C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF MAHDIS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)NR1,NC1 9013 FORMAT('NR1,NC1 = ',2I8) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE MAINAN(ICASAN,ISEED,ANOPL1,ANOPL2, 1TEMP,TEMP2,XTEMP1,XTEMP2,MAXNXT, CCCCC1IFTEXP, 1IFTEXP,IFTORD, CCCCC MARCH 1994. ADD ARGUMENT. CCCCC1ALOWFR, 1ALOWFR,ALOWDG, CCCCC JULY 2002: FOLLOWING LINE FOR BOOTSTRAP FIT 1IBOOSS, CCCCC AUGUST 2002: FOLLOWING LINE FOR CROSS TABULATE, TABULATE 1ICAPSW, 1IFORSW, 1IBUGAN,IBUGA2,IBUGA3, 1IBUGCO,IBUGEV,IBUGQ,ISUBRO,IFOUND,IERROR) C C PURPOSE--THIS IS SUBROUTING MAINAN. C (THE AN AT THE END OF MAINAN STANDS FOR ANALYSIS) C THIS SUBROUTINE SEARCHES FOR AND EXECUTES ANALYSIS COMMANDS. C THE ANALYSIS COMMANDS SEARCHED FOR BY MAINAN ARE AS FOLLOWS-- C C CODE AT END: H => HTML OUTPUT IMPLEMENTED C L => LATEX OUTPUT IMPLEMENTED C R => RICH TEXT FORMAT OUTOUT IMPLEMENTED C C ANALYSIS OF VARIANCE (HL) C MEDIAN POLISH C ANALYSIS OF PROPORTIONS (WORKING?) C CONSENSUS MEANS (=MANDEL-PAULE, (HLR) C BOB (BAYESIAN CONCENSUS MEANS), C SCHILLER-EBERHARDT C VANGEL-RUKHIN MAXIMUM LIKELIHOD C E691 INTERLAB (HLR) C YATES ANALYSIS = DEX FIT = 2**K FIT = (HL) C 2**K DEX FIT C (YATES) PHD ANALYSIS C KRUSKAL-WALLIS TEST (HL) C VAN DER WAERDEN TEST (HL) C FRIEDMAN TEST (HL) C DURBIN TEST (HL) C COCHRAN TEST (HL) C C CONFIDENCE LIMITS (HL) C BIWEIGHT CONFIDENCE LIMITS (HL) C TRIMMED MEAN CONFIDENCE LIMITS (HL) C MEDIAN CONFIDENCE LIMITS (HL) C QUANTILE CONFIDENCE LIMITS (HL) C DIFFERENCE OF MEANS CONFIDENCE LIMITS (HL) C TOLERANCE LIMITS Y C PROPORTION CONFIDENCE LIMITS C DIFFERENCE OF PROPORTION CONFIDENCE LIMITS C C EXACT ... RATIONAL FIT C ... FIT (HL) C ... PRE-FIT C ... SMOOTH C ... SPLINE FIT C ORTHOGONAL DISTANCE FIT C BOOTSTRAP FIT C BEST CP Y X1 TO XK C LOWESS C SEASONAL LOWESS C LINEAR CALIBRATION (HL) C QUADRATIC CALIBRATION (HL) C C LET C LET FUNCTION C C RUNS C LUJAN-BOX TEST (FOR RANDOMNESS) C FREQUENCY TEST (FOR RANDOMNESS) (HL) C FREQUENCY WITHIN A BLOCK TEST (FOR RANDOMNESS) (HL) C CUMULATIVE SUM RANDOMNESS TEST (HL) C C T TEST Y1 Y2 or Y MU or MU Y (HL) C SIGN TEST Y1 Y2 or Y MU or MU Y OR Y1 Y2 D0 (HL) C WILCOXON SIGNED RANK TEST Y1 Y2 or Y1 Y2 D0 (HL) C or Y MU C MANN-WHITNEY RANK SUM TEST Y1 Y2 C C CHI-SQUARED TEST Y SIGMA or SIGMA Y (HL) C F TEST Y1 Y2 (HL) C BARTLETT'S TEST Y X1 X2 X3 X4 X5 C F LOCATION TEST Y X C LEVENE TEST Y X (HL) C ANDERSON DARLING K-SAMPLE TEST Y X C C ANDERSON DARLING TEST Y (HL) C WILKS-SHAPIRO NORMALITY TEST Y (HL) C CHI-SQUARED GOODNESS OF FIT TEST Y (HL) C KOLMOGOROV-SMIRNOV GOODNESS OF FIT (HL) C TEST Y C CHI-SQUARED 2 SAMPLE TEST Y1 Y2 C KOMOGOROV-SMIRNOV 2 SAMPLE TEST Y1 Y2 C C GRUBB TEST Y (HL) C C RELIABILITY TREND TESTS Y C C SUMMARY (HL) C CAPABILITY ANALYSIS C C DDS DDS Y 6 5 DELT 3/94 C ARMA ARMA Y 2 1 2 1 1 1 12 C C RECIPE RECIPE Y C SIMCOV SIMCOV Y C BBASIS Y C ABASIS Y C C WEIBULL MAXIMUM LIKELIHOOD Y (HL) C INVERTED WEIBULL MAXIMUM LIKELIHOOD Y (HL) C NORMAL MAXIMUM LIKELIHOOD Y (HL) C NORMAL MIXTURE MAXIMUM LIKELIHOOD Y (HL) C LOGNORMAL MAXIMUM LIKELIHOOD Y (HL) C EXPONENTIAL MAXIMUM LIKELIHOOD Y (HL) C EXPONENTIAL GROUPED MAXIMUM LIKELIHOOD Y X (HL) C PARETO MAXIMUM LIKELIHOOD Y (HL) C GAMMA MAXIMUM LIKELIHOOD Y (HL) C GUMBEL MAXIMUM LIKELIHOOD Y (HL) C FRECHET MAXIMUM LIKELIHOOD Y (HL) C GENERALIZED EXTREME VALUE MAXIMUM LIKELIHOOD Y C POWER MAXIMUM LIKELIHOOD Y (HL) C DOUBLE EXPONENTIAL MAXIMUM LIKELIHOOD Y (HL) C BINOMIAL MAXIMUM LIKELIHOOD Y (HL) C POISSON MAXIMUM LIKELIHOOD Y (HL) C BETA BINOMIAL MAXIMUM LIKELIHOOD Y (HL) C POLYA MAXIMUM LIKELIHOOD Y (HL) C GUMBEL (EV1) MAXIMUM LIKELIHOOD Y (HL) C TWO-SIDED POWER MAXIMUM LIKELIHOOD Y (HL) C LOGISTIC MAXIMUM LIKELIHOOD Y (HL) C CAUCHY MAXIMUM LIKELIHOOD Y (HL) C BETA MAXIMUM LIKELIHOOD Y (HL) C DEHAAN Y (FOR GENERALIZED PARETO) (HL) C CME Y (FOR GENERALIZED PARETO) (HL) C JOHNSON SB MOMENTS Y (HL) C JOHNSON SU MOMENTS Y (HL) C JOHNSON SB PERCENTILE ESTIMATION Y (HL) C JOHNSON SU PERCENTILE ESTIMATION Y (HL) C UNIFORM MOMENTS MLE Y (HL) C LOGARITHMIC SERIES MLE Y (HL) C GEOMETRIC MLE Y (HL) C NEGATIVE BINOMIAL MLE Y (HL) C FATIGUE LIFE MLE Y (HL) C GEOMETRIC EXTREME EXPONENTIAL MLE Y (HL) C FOLDED NORMAL MLE Y (HL) C HYPERGEOMETRIC MLE Y (HL) C HERMITE MLE Y (HL) C YULE MLE Y (HL) C WARING MLE Y (HL) C RAYLEIGH MLE Y (HL) C MAXWELL MLE Y (HL) C GENERALIZED LOGISTIC MLE Y (HL) C BOREL-TANNER MLE Y (HL) C LAGRANGE-POISSON MLE Y (HL) C BETA-GEOMETRIC MLE Y (HL) C ZETA MLE Y (HL) C LOG-BETA MLE Y (HL) C POLYA-AEPPLI MLE Y (HL) C LOST GAMES MLE Y (HL) C GENERALIZED LOGARITHMIC SERIES MLE Y (HL) C GENERALIZED NEGATIVE BINOMIAL MLE Y (HL) C GEETA MLE Y (HL) C QUASI BINOMIAL TYPE I MLE Y (HL) C CONSUL MLE Y (HL) C LAGRANGE KATZ MLE Y (HL) C POWER LAW MLE Y (HL) C GENERALIZED LOST GAMES MLE Y (HL) C C LOW PASS FILTER/SMOOTH Y (NOT WORKING) C HIGH PASS FILTER/SMOOTH Y (NOT WORKING) C C SINGLE SAMPLE ACCEPTANCE PLAN P1 P2 ALPHA BETA C DOUBLE SAMPLE ACCEPTANCE PLAN P1 P2 ALPHA BETA (NOT WORKING) C C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-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--82.6 C ORIGINAL VERSION--JANUARY 1981. C UPDATED --MARCH 1981. C UPDATED --JULY 1981. C UPDATED --AUGUST 1981. C UPDATED --SEPTEMBER 1981. C UPDATED --OCTOBER 1981. C UPDATED --NOVEMBER 1981. C UPDATED --MARCH 1982. C UPDATED --MAY 1982. C UPDATED --JULY 1987. YATES ANALYSIS C UPDATED --FEBRUARY 1988. LOWESS FIT C UPDATED --DECEMBER 1988. LOWESS FRACTION C UPDATED --MAY 1989. EXPERIMENTAL SIMULATION C UPDATED --JUNE 1989. (2**K) DEX FIT = YATES ANALYSIS C UPDATED --NOVEMBER 1989. YATES ... CUTOFF BRANCH C UPDATED --NOVEMBER 1989. YATES OUTPUT BRANCH C UPDATED --NOVEMBER 1989. CROSS-TABULATION C UPDATED --SEPTEMBER 1990. CAPABILITY ANALYSIS C UPDATED --SEPTEMBER 1993. (YATES) PHD ANALYSIS C UPDATED --FEBRUARY 1994. REWRITE T TEST SECTION C UPDATED --FEBRUARY 1994. CHI-SQUARED TEST C UPDATED --FEBRUARY 1994. F TEST C UPDATED --FEBRUARY 1994. BARTLETT'S TEST C UPDATED --FEBRUARY 1994. ADD ARGUMENT TO DPLET C UPDATED --MARCH 1994. DDS C UPDATED --JUNE 1994. ADD ARGUMENT TO DPLET C UPDATED --FEBRUARY 1995. RENAME PHD TO DEX PHD (A MORE C GENERAL PHD COMMAND MAY BE C ADDED LATER) C UPDATED --JULY 1995. RECIPE ANALYSIS (MARK VANGEL) C UPDATED --JULY 1995. MANDEL (2-WAY) ANALYSIS C UPDATED --OCTOBER 1995. IFTORD C UPDATED --APRIL 1996. FLAG FOR PRESERVING THE CASE C ON STRINGS C UPDATED --SEPTEMBER 1997. RECIPE AND SIMCOV C UPDATED --SEPTEMBER 1997. GRUBB TEST C UPDATED --SEPTEMBER 1997. LEVENE TEST C UPDATED --SEPTEMBER 1997. F LOCATION TEST C UPDATED --SEPTEMBER 1997. ANDERSON DARLING 1-SAMPLE TEST C UPDATED --JANUARY 1998. NAME CONFLICT WITH RECIPE AND C RECIPROCAL PROB PLOT AND PPCC PLOT C UPDATED --MARCH 1998. WEIBULL MAXIMUM LIKELIHOOD Y C UPDATED --MARCH 1998. BBASIS WEIBULL/NORMAL/LOGNORMAL Y C UPDATED --MARCH 1998. ABASIS WEIBULL/NORMAL/LOGNORMAL Y C UPDATED --MARCH 1998. K-SAMPLE ANDERSON DARLING C UPDATED --APRIL 1998. OTHER DISTRIBUTIONS FOR MLE C UPDATED --MAY 1998. DEHAAN AND CME C UPDATED --MAY 1998. RELIABILITY TREND TESTS C UPDATED --JUNE 1998. GAMMA, POWER, DOUBLE C EXPONENTIAL MLE C UPDATED --NOVEMBER 1998. TOLERANCE LIMITS C UPDATED --NOVEMBER 1998. CHI-SQUARE GOODNESS OF FIT C UPDATED --NOVEMBER 1998. KOLMOGOROV-SMIRNOV GOODNESS OF FIT C UPDATED --DECEMBER 1998. CHI-SQUARE 2 SAMPLE TEST C UPDATED --FEBRUARY 1999. UPDATE LOWESS TO SUPPORT C SEASONAL LOESS C UPDATED --FEBRUARY 1999. UPDATE SMOOTH TO SUPPORT C LOW PASS AND HIGH PASS FILTER C UPDATED --MARCH 1999. WILKS-SHAPIRO NORMALITY TEST C UPDATED --MARCH 1999. SINGLE SAMPLE ACCEPTANCE PLAN C UPDATED --MARCH 1999. DOUBLE SAMPLE ACCEPTANCE PLAN C UPDATED --MARCH 1999. BETA BINOMIAL MAXIMUM LIKELIHOOD Y C UPDATED --MARCH 1999. GENERALIZED EXTREME VALUE MAXIMUM LIKELIHOOD Y C UPDATED --MARCH 1999. WILKS-SHAPIRO NORMALITY TEST C UPDATED --MARCH 1999. PROPORTIONS CONFIDENCE LIMITS C UPDATED --MARCH 1999. DIFFERENCE OF PROPORTIONS C UPDATED --MARCH 1999. DIFFERENCE OF MEANS C CONFIDENCE LIMITS C UPDATED --MAY 1999. ARMA FIT C UPDATED --JUNE 1999. SIGN TEST C UPDATED --JUNE 1999. KRUSKAL-WALLIS TEST C UPDATED --JUNE 1999. WILCOXON SIGNED RANK TEST C UPDATED --JULY 1999. MANN-WHITNEY TEST C UPDATED --AUGUST 1999. FIX TO LEVENE TEST C UPDATED --AUGUST 1999. FIX TO BARTLETT TEST C UPDATED --OCTOBER 2000. CONSENSUS MEANS C (MANDEL-PAULE) C UPDATED --OCTOBER 2000. BOB (BAYESIAN IMPLEMENTATION C OF CONCENSUS MEANS) C UPDATED --APRIL 2001. ORTHOGONAL DISTANCE FIT C UPDATED --JULY 2001. EV1 SYNONYMS FOR ANDERSON C DARLING TEST C UPDATED --NOVEMBER 2001. BIWEIGHT CONFIDENCE INTEVAL C UPDATED --MAY 2002. TWO-SIDED POWER MAXI LIKE C UPDATED --JUNE 2002. BEST CP C UPDATED --JULY 2002. BOOTSTRAP FIT C UPDATED --AUGUST 2002. CALL LIST TO CROSS TABULAE, C TABULATE C UPDATED --OCTOBER 2002. CALL LIST TO SUMMARY C UPDATED --OCTOBER 2002. CALL LIST TO CONSENSUS MEAN C UPDATED --FEBRUARY 2003. TRIMMED MEAN CONFIDENCE INTERVAL C UPDATED --FEBRUARY 2003. MEDIAN CONFIDENCE INTERVAL C UPDATED --FEBRUARY 2003. QUANTILE CONFIDENCE INTERVAL C UPDATED --FEBRUARY 2003. LUJAN-BOX TEST FOR RANDOMNESS C UPDATED --JULY 2003. JOHNSON SB MOMEMTS C UPDATED --JULY 2003. JOHNSON SU MOMEMTS C UPDATED --JULY 2003. LINEAR CALIBRATION C UPDATED --JULY 2003. QUADRATIC CALIBRATION C UPDATED --OCTOBER 2003. FRIEDMAN TEST C UPDATED --OCTOBER 2003. LOGISTIC MAXIMUM LIKELIHOOD C UPDATED --OCTOBER 2003. CAUCHY MAXIMUM LIKELIHOOD C UPDATED --OCTOBER 2003. BETA MAXIMUM LIKELIHOOD C UPDATED --OCTOBER 2003. UNIFORM MAXIMUM LIKELIHOOD C UPDATED --OCTOBER 2003. ANDERSON-DARLING LOGISTIC C UPDATED --NOVEMBER 2003. ANDERSON-DARLING UNIFORM C UPDATED --NOVEMBER 2003. ANDERSON-DARLING DOUBLE C EXPONENTIAL C UPDATED --NOVEMBER 2003. FREQUENCY TEST C UPDATED --NOVEMBER 2003. FREQUENCY WITHIN A BLOCK TEST C UPDATED --DECEMBER 2003. CUSUM BLOCK TEST C UPDATED --MARCH 2004. LOGARITHMIC SERIES MAXIMUM C LIKELIHOOD C UPDATED --MARCH 2004. NEGATIVE BINOMIAL MAXIMUM C LIKELIHOOD C UPDATED --MARCH 2004. GEOMETRIC MAXIMUM LIKELIHOOD C UPDATED --MARCH 2004. HYPERGEOMETRIC MAXIMUM C LIKELIHOOD C UPDATED --MARCH 2004. POLYA MAXIMUM LIKELIHOOD C UPDATED --APRIL 2004. JOHNSON PERCENTILE C UPDATED --OCTOBER 2004. COCHRAN TEST C UPDATED --OCTOBER 2004. VAN DER WAERDEN TEST C UPDATED --DECEMBER 2004. ANDERSON-DARLING GAMMA C UPDATED --FEBRUARY 2005. E691 INTERLAB C UPDATED --MAY 2005. FRECHET MAXIMUM LIKELIHOOD C UPDATED --MAY 2005. ANDERSON DARLING FRECHET C UPDATED --MAY 2005. ANDERSON DARLING CAUCHY C UPDATED --AUGUST 2005. INVERTED WEIBULL MAXI LIKE C UPDATED --DECEMBER 2005. ALLOW "NORMAL" AND C "NONPARAMETRIC" FOR TOLERANCE C LIMITS COMMAND C UPDATED --JANUARY 2006. DURBIN TEST C UPDATED --FEBRUARY 2006. ALLOW "GRUBB MINIMUM" AND C "GRUB MAXIMUM" C UPDATED --MAY 2006. BOREL-TANNER MAXIMUM LIKELIHOOD C UPDATED --MAY 2006. ZETA MAXIMUM LIKELIHOOD C UPDATED --MAY 2006. BETA-GEOMETRIC MAXIMUM LIKELIHOOD C UPDATED --JUNE 2006. LAGRANGE-POISSON MAXIMUM C LIKELIHOOD C UPDATED --JUNE 2006. LOG-BETA MAXIMUM LIKELIHOOD C UPDATED --JUNE 2006. POLYA-AEPPLI MAXIMUM LIKELIHOOD C UPDATED --JULY 2006. GENERALIZED LOGARITHMIC SERIES C MAXIMUM LIKELIHOOD C UPDATED --JULY 2006. GEETA MLE C UPDATED --JULY 2006. QUASI BINOMIAL TYPE I MLE C UPDATED --AUGUST 2006. CONSUL MLE C UPDATED --AUGUST 2006. LAGRANGE KATZ MLE C UPDATED --OCTOBER 2006. POWER LAW MLE C UPDATED --DECEMBER 2006. GENERALIZED LOST GAMES MLE C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASAN CHARACTER*4 IFORSW CHARACTER*4 IBUGAN CHARACTER*4 IBUGA2 CHARACTER*4 IBUGA3 CHARACTER*4 IBUGCO CHARACTER*4 IBUGEV CHARACTER*4 IBUGQ CHARACTER*4 ISUBRO CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 ICASML C CHARACTER*4 IFTEXP CCCCC AUGUST 1995. ADD FOLLOWING LINE CHARACTER*4 IFTORD CCCCC APRIL 1996. ADD FOLLOWING LINE CHARACTER*10 ISFLAG CCCCC SEPTEMBER 1997. ADD FOLLOWING LINE CHARACTER*4 ICASDI CHARACTER*4 ICAPSW C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C DIMENSION TEMP(*) DIMENSION TEMP2(*) DIMENSION XTEMP1(*) DIMENSION XTEMP2(*) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCOMC.INC' INCLUDE 'DPCOHK.INC' INCLUDE 'DPCOSU.INC' INCLUDE 'DPCOS2.INC' INCLUDE 'DPCODA.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='MAIN' ISUBN2='AN ' C IFOUND='NO' IERROR='NO' C ICASAN='UNKN' C IF(IBUGAN.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF MAINAN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IBUGAN,IBUGA2,IBUGA3 53 FORMAT('IBUGAN,IBUGA2,IBUGA3 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)IBUGCO,IBUGEV,IBUGQ 55 FORMAT('IBUGCO,IBUGEV,IBUGQ = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,56)IFTEXP 56 FORMAT('IFTEXP = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,57)IANGLU 57 FORMAT('IANGLU = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,58)ICASAN,ISEED,ANOPL1,ANOPL2 58 FORMAT('ICASAN,ISEED,ANOPL1,ANOPL2 = ',A4,I8,E15.7,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,60)IFOUND,IERROR 60 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,61)MAXNXT 61 FORMAT('MAXNXT = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,67)ICOM,ICOM2 67 FORMAT('ICOM,ICOM2 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,68)NUMARG 68 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') DO70I=1,NUMARG WRITE(ICOUT,71)I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I) 71 FORMAT('I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I) = ', 1I8,2X,A4,2X,A4,2X,A4,2X,I8,E15.7) CALL DPWRST('XXX','BUG ') 70 CONTINUE WRITE(ICOUT,81)ALOWFR 81 FORMAT('ALOWFR = ',E15.7) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ************************* C ** SEARCH FOR ** C ** ANALYSIS COMMANDS ** C ************************* C CCCCC THE FOLLOWING SECTION WAS MOVED HERE TO BE FIRST MAY 1992 (JJF) CCCCC TO AVOID MISPROCESSING OF LET FUNCTION A = FIT MAY 1992 (JJF) C *********************************** C ** TREAT THE LET FUNCTION CASE ** C *********************************** C CCCCC APRIL 1996. IF ENTERED AS LET STRING, PRESERVE CASE. IF CCCCC ENTERED AS LET FUNCTION, CONVERT TO UPPER CASE IF(NUMARG.GE.1.AND.ICOM.EQ.'LET'.AND. 1IHARG(1).EQ.'FUNC'.AND.IHARG2(1).EQ.'TION')ISFLAG='FUNCTION' IF(NUMARG.GE.1.AND.ICOM.EQ.'LET'.AND. 1IHARG(1).EQ.'FUNC'.AND.IHARG2(1).EQ.'TION')GOTO1800 IF(NUMARG.GE.1.AND.ICOM.EQ.'LET'.AND. 1IHARG(1).EQ.'STRI'.AND.IHARG2(1).EQ.'NG')ISFLAG='STRING' IF(NUMARG.GE.1.AND.ICOM.EQ.'LET'.AND. 1IHARG(1).EQ.'STRI'.AND.IHARG2(1).EQ.'NG')GOTO1800 GOTO1899 C 1800 CONTINUE ICASAN='LETF' CALL DPLETF(IANGLU,IBUGA2,IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO, CCCCC APRIL 1996. ADD FOLLOWING LINE. 1ISFLAG, 1IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 1899 CONTINUE C C ********************************************** C ** TREAT THE ANALYSIS OF PROPORTIONS CASE ** C ********************************************** C CCCCC IF(ICOM.EQ.'ANOP'.AND.IHARG(1).NE.'LIMI'.AND. CCCCC1IHARG2(1).NE.'TS '.AND.IHARG(1).NE.'PLOT'.AND. CCCCC1IHARG2(1).NE.' ')GOTO100 CCCCC GOTO199 C CC100 CONTINUE CCCCC ICASAN='ANOP' CCCCC CALL DPANOP(ANOPL1,ANOPL2,IBUGA2,IBUGA3,IBUGQ, CCCCC1IFOUND,IERROR) CCCCC IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C CC199 CONTINUE C C ******************************************* C ** TREAT THE ANALYSIS OF VARIANCE CASE ** C ******************************************* C IF(ICOM.EQ.'ANAL')GOTO200 IF(ICOM.EQ.'ANOV')GOTO200 GOTO299 C 200 CONTINUE ICASAN='ANOV' CALL DPANOV(ICAPSW,IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 GOTO9000 C 299 CONTINUE C C ********************************************* C ** TREAT THE EXACT ... RATIONAL FIT CASE ** C ********************************************* C IF(ICOM.EQ.'EXAC')GOTO300 GOTO399 C 300 CONTINUE ICASAN='EXAC' CALL DPEXAC(IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 399 CONTINUE C C ************************************* C ** TREAT THE LOWESS FIT CASE ** C ************************************* C IF(ICOM.EQ.'LOWE')GOTO1100 IF(ICOM.EQ.'LOES')GOTO1100 IF(ICOM.EQ.'SEAS')GOTO1100 GOTO1199 C 1100 CONTINUE ICASAN='LOWF' CCCCC MARCH 1994. ADD ARGUMENT. CCCCC CALL DPLOW(ALOWFR, CALL DPLOW(ALOWFR,ALOWDG, 1TEMP,TEMP2,XTEMP1,XTEMP2,MAXNXT, 1IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 GOTO9000 C 1199 CONTINUE C C ************************************************ C ** TREAT THE ORTHOGONAL DISTANCE FIT CASE ** C ************************************************ C IF(ICOM.EQ.'ORTH'.AND.NUMARG.GE.2.AND.IHARG(1).EQ.'DIST'.AND. 1IHARG(2).EQ.'FIT')GOTO1200 IF(ICOM.EQ.'ORTH'.AND.NUMARG.GE.2.AND.IHARG(1).EQ.'DIST'.AND. 1IHARG(2).EQ.'REGR')GOTO1200 GOTO1299 C 1200 CONTINUE ICASAN='ORTF' CALL DPORTH(IBUGA2,IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO, 1IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 GOTO9000 C 1299 CONTINUE C C ****************************** C ** TREAT THE ... FIT CASE ** C ****************************** C CCCCC THE FOLLOWING 8 LINES WERE ADDED JUNE 1989 IF(ICOM.EQ.'BOOT')GOTO1799 IF(ICOM.EQ.'2**K'.AND.NUMARG.GE.1.AND. 1IHARG(1).EQ.'FIT')GOTO1799 IF(ICOM.EQ.'2**K'.AND.NUMARG.GE.2.AND. 1IHARG(2).EQ.'FIT')GOTO1799 IF(ICOM.EQ.'DEX'.AND.NUMARG.GE.1.AND. 1IHARG(1).EQ.'FIT')GOTO1799 IF(ICOM.EQ.'DEX'.AND.NUMARG.GE.2.AND. 1IHARG(2).EQ.'FIT')GOTO1799 C IF(ICOM.EQ.'FIT ')GOTO1700 CCCCC CHECK FOR "RECIPE FIT" AND "SIMCOV FIT" CASES. SEPTEMBER 1997 IF(NUMARG.GE.1.AND.ICOM.NE.'SPLI'.AND.ICOM.NE.'PRE '.AND. CCCCC1ICOM.NE.'LOWE'.AND. 1ICOM.NE.'LOWE'.AND.ICOM.NE.'RECI'.AND.ICOM.NE.'SIMC'.AND. 1IHARG(1).EQ.'FIT ')GOTO1700 DO1710I=2,5 IM1=I-1 IF(NUMARG.GE.I.AND.IHARG(IM1).NE.'SPLI'.AND.IHARG(1).NE.'PRE ' 1.AND.IHARG(IM1).NE.'OF' 1.AND.IHARG(I).EQ.'FIT ')GOTO1700 1710 CONTINUE GOTO1799 C 1700 CONTINUE ICASAN='FIT' CALL DPFIT(ICAPSW,IBUGA2,IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO, 1IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 GOTO9000 C 1799 CONTINUE C C ****************************** C ** TREAT THE BEST CP CASE ** C ****************************** C IF(ICOM.EQ.'BEST'.AND.NUMARG.GE.1.AND. 1IHARG(1).EQ.'CP ')THEN ICASAN='CP' CALL DPBECP(IBUGA2,IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO, 1 IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C C ****************************** C ** TREAT THE BOOTSTRAP FIT ** C ****************************** C IF(ICOM.EQ.'BOOT'.AND.NUMARG.GE.1.AND. 1IHARG(1).EQ.'FIT ')THEN ICASAN='BFIT' CALL DPBOFI(IBUGA2,IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO, 1 ISEED,IBOOSS, 1 IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C C CCCCC THE FOLLOWING SECTION WAS COMMENTED OUT HERE MAY 1992 (JJF) CCCCC AND MOVED UP TO THE TOP OF THIS SUBROUTINE MAY 1992 (JJF) CCCCC TO FIX MISPROCESSING OF LET STRING A = FIT MAY 1992 (JJF) CCCCC *********************************** CCCCC ** TREAT THE LET FUNCTION CASE ** CCCCC *********************************** CCCCC CCCCC IF(NUMARG.GE.1.AND.ICOM.EQ.'LET'.AND. CCCCC1IHARG(1).EQ.'FUNC'.AND.IHARG2(1).EQ.'TION')GOTO1800 CCCCC IF(NUMARG.GE.1.AND.ICOM.EQ.'LET'.AND. CCCCC1IHARG(1).EQ.'STRI'.AND.IHARG2(1).EQ.'NG')GOTO1800 CCCCC GOTO1899 CCCCC C1800 CONTINUE CCCCC ICASAN='LETF' CCCCC CALL DPLETF(IANGLU,IBUGA2,IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO, CCCCC1IFOUND,IERROR) CCCCC IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 CCCCC C1899 CONTINUE C C ************************** C ** TREAT THE LET CASE ** C ************************** C IF(NUMARG.GE.1.AND.ICOM.EQ.'LET')GOTO1900 GOTO1999 C 1900 CONTINUE ICASAN='LET' CALL DPLET(IANGLU,ISEED,IBUGA2,IBUGA3,IBUGCO,IBUGEV,IBUGQ, 1TEMP,TEMP2,XTEMP1,XTEMP2,MAXNXT, CCCCC AUGUST 1995. ADD IFTORD CCCCC1IFTEXP, 1IFTEXP,IFTORD, CCCCC ADD FOLLOWING LINE. FEBRUARY 1994. CCCCC ADD OPTACC ARGUMENT JUNE 1994 CCCCC ADD IOTME, IOPTHE ARGUMENTS FEBRUARY 1995 1ROOTAC,OPTACC,IOPTME,IOPTHE, 1ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 1999 CONTINUE CCCCC THE FOLLOWING SECTION WAS REWRITTEN JULY 1995 C ************************************ C ** TREAT THE MEDIAN POLISH CASE ** C ************************************ C IF(ICOM.EQ.'MEDI'.AND. 1 NUMARG.GE.1.AND.IHARG(1).EQ.'POLI'.AND. 1 IHARG2(1).EQ.'SH ')THEN ICASAN='MEPO' CALL DPMEPO(IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED JULY 1995 C ********************************************** C ** TREAT THE MANDEL (2-WAY) ANALYSIS CASE ** C ********************************************** C CCCCC APRIL 1996. FOLLOWING CODE IS NOT WORKING YET CCCCC OCTOBER 2000. UPDATE (CALL IT CONCENSUS MEANS OR CCCCC MANDEL-PAULE, IT IMPLEMENTS BOTH MANDEL-PAULE AND CCCCC MARK VANGEL'S MAXIMUM LIKELIHOOD APPROACH). C IF(ICOM.EQ.'MAND'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'PAUL')THEN ICASAN='MAND' CALL DPMAND(ICAPSW,IFORSW,ISUBRO,IBUGA2,IBUGA3,IBUGQ, 1 IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF IF(ICOM.EQ.'CONS'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'MEAN')THEN ICASAN='MAND' CALL DPMAND(ICAPSW,IFORSW,ISUBRO,IBUGA2,IBUGA3,IBUGQ, 1 IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C 2199 CONTINUE C CCCCC THE FOLLOWING SECTION WAS ADDED FEBRUARY 2005 C ********************************************** C ** TREAT THE E691 INTERLAB CASE ** C ********************************************** C IF(ICOM.EQ.'E691'.AND.NUMARG.GE.2.AND.IHARG(1).EQ.'INTE'.AND. 1 IHARG(2).EQ.'ANAL')THEN ICASAN='E691' CALL DPEINL(ICAPSW,IFORSW,ISUBRO, 1 IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ELSEIF(ICOM.EQ.'E691'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'INTE')THEN ICASAN='E691' CALL DPEINL(ICAPSW,IFORSW,ISUBRO, 1 IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED JULY 2003 C ********************************************** C ** TREAT THE LINEAR CALIBRATION CASE ** C ********************************************** C IF(ICOM.EQ.'LINE'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'CALI')THEN ICASAN='LICA' CALL DPLICA(ICAPSW,ISEED,ISUBRO,IBUGA2,IBUGA3,IBUGQ, 1 IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED JULY 2003 C ********************************************** C ** TREAT THE QUADRATIC CALIBRATION CASE ** C ********************************************** C IF(ICOM.EQ.'QUAD'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'CALI')THEN ICASAN='QUCA' CALL DPLICA(ICAPSW,ISEED,ISUBRO,IBUGA2,IBUGA3,IBUGQ, 1 IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C C C ********************************** C ** TREAT THE ... PRE-FIT CASE ** C ********************************** C IF(NUMARG.GE.1.AND.ICOM.EQ.'PRE '.AND.IHARG(1).EQ.'FIT ') 1GOTO2200 DO2210I=2,5 IM1=I-1 IF(NUMARG.GE.I.AND.IHARG(IM1).EQ.'PRE '.AND.IHARG(I).EQ.'FIT ') 1GOTO2200 2210 CONTINUE IF(ICOM.EQ.'PREF')GOTO2200 DO2220I=1,4 IF(NUMARG.GE.I.AND.IHARG(I).EQ.'PREF'.AND. 1IHARG2(I).EQ.'IT ')GOTO2200 2220 CONTINUE GOTO2299 C 2200 CONTINUE ICASAN='PREF' CALL DPPREF(IBUGA2,IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO, 1IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 2299 CONTINUE C C ********************************* C ** TREAT THE ... SMOOTH CASE ** C ********************************* C IF(ICOM.EQ.'SMOO')GOTO2300 IF(ICOM.EQ.'LOW'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'PASS')GOTO2300 IF(ICOM.EQ.'HIGH'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'PASS')GOTO2300 DO2310I=1,3 IF(NUMARG.GE.I.AND.IHARG(I).EQ.'SMOO'.AND. 1IHARG2(I).EQ.'TH ')GOTO2300 IF(NUMARG.GE.I.AND.IHARG(I).EQ.'SMOO'.AND. 1IHARG2(I).EQ.'THIN')GOTO2300 2310 CONTINUE GOTO2399 C 2300 CONTINUE ICASAN='SMOO' CALL DPSMOO(IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 2399 CONTINUE C C ************************************* C ** TREAT THE ... SPLINE FIT CASE ** C ************************************* C IF(NUMARG.GE.1.AND.ICOM.EQ.'SPLI'.AND.IHARG(1).EQ.'FIT ') 1GOTO2400 DO2410I=2,5 IM1=I-1 IF(NUMARG.GE.I.AND.IHARG(IM1).EQ.'SPLI'.AND.IHARG(I).EQ.'FIT ') 1GOTO2400 2410 CONTINUE GOTO2499 C 2400 CONTINUE ICASAN='SPLI' CALL DPSPL(IBUGA2,IBUGA3,IBUGQ,ISUBRO, 1IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 GOTO9000 C 2499 CONTINUE C C ****************************** C ** TREAT THE SUMMARY CASE ** C ****************************** C IF(ICOM.EQ.'SUMM')GOTO2500 GOTO2599 C 2500 CONTINUE ICASAN='SUMM' CALL DPSUMM(XTEMP1,XTEMP2,MAXNXT, 1ICAPSW, 1IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 2599 CONTINUE C C **************************************** C ** TREAT THE CONFIDENCE LIMITS CASE ** C **************************************** C IF(ICOM.EQ.'CONF')GOTO3100 GOTO3199 C 3100 CONTINUE IF(NUMARG.GE.3.AND. 1(IHARG(1).EQ.'LIMI'.OR.IHARG(1).EQ.'INTE').AND. 1IHARG(2).EQ.'FOR '.AND.IHARG(3).EQ.'MEAN')GOTO3130 IF(NUMARG.GE.2.AND. 1(IHARG(1).EQ.'LIMI'.OR.IHARG(1).EQ.'INTE').AND. 1IHARG(2).EQ.'MEAN')GOTO3120 IF(NUMARG.GE.1.AND. 1(IHARG(1).EQ.'LIMI'.OR.IHARG(1).EQ.'INTE')) 1GOTO3110 GOTO3180 3110 CONTINUE ISHIFT=1 GOTO3150 3120 CONTINUE ISHIFT=2 GOTO3150 3130 CONTINUE ISHIFT=3 GOTO3150 3150 CONTINUE CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1IBUGA2,IERROR) GOTO3180 3180 CONTINUE ICASAN='ONEV' CALL DPCONF(XTEMP1,XTEMP2,MAXNXT,ICASAN, 1ICAPSW, 1IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 3199 CONTINUE C C ************************************************* C ** TREAT THE BIWEIGHT CONFIDENCE LIMITS CASE ** C ************************************************* C IF(ICOM.EQ.'BIWE')THEN C IF(NUMARG.GE.2.AND.IHARG(1).EQ.'CONF'.AND. 1 (IHARG(2).EQ.'LIMI'.OR.IHARG(2).EQ.'INTE'))THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='ONEV' CALL DPBWCO(XTEMP1,XTEMP2,MAXNXT,ICASAN, 1 ICAPSW, 1 IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C ENDIF ENDIF C C ***************************************************** C ** TREAT THE TRIMMED MEAN CONFIDENCE LIMITS CASE ** C ***************************************************** C IF(ICOM.EQ.'TRIM'.AND.IHARG(1).EQ.'MEAN')THEN C IF(NUMARG.GE.3.AND.IHARG(2).EQ.'CONF'.AND. 1 (IHARG(3).EQ.'LIMI'.OR.IHARG(3).EQ.'INTE'))THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='TMCI' CALL DPTMCO(XTEMP1,XTEMP2,MAXNXT,ICASAN, 1 ICAPSW, 1 IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C ENDIF ENDIF C C ***************************************************** C ** TREAT THE MEDIAN CONFIDENCE LIMITS CASE ** C ** TREAT THE QUANTILE CONFIDENCE LIMITS CASE ** C ***************************************************** C IF(ICOM.EQ.'MEDI')THEN C IF(NUMARG.GE.2.AND.IHARG(1).EQ.'CONF'.AND. 1 (IHARG(2).EQ.'LIMI'.OR.IHARG(2).EQ.'INTE'))THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='MECI' CALL DPQUCO(XTEMP1,XTEMP2,MAXNXT,ICASAN, 1 ICAPSW, 1 IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C ENDIF ENDIF C IF(ICOM.EQ.'QUAN')THEN C IF(NUMARG.GE.2.AND.IHARG(1).EQ.'CONF'.AND. 1 (IHARG(2).EQ.'LIMI'.OR.IHARG(2).EQ.'INTE'))THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='QUCI' CALL DPQUCO(XTEMP1,XTEMP2,MAXNXT,ICASAN, 1 ICAPSW, 1 IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C ENDIF ENDIF C C **************************************** C ** TREAT THE DIFFERENCE OF MEANS ** C ** CONFIDENCE LIMITS CASE ** C **************************************** C IF(ICOM.EQ.'DIFF')THEN IF(NUMARG.GE.4.AND.IHARG(1).EQ.'OF '.AND. 1 IHARG(2).EQ.'MEAN'.AND. 1 IHARG(3).EQ.'CONF'.AND. 1 (IHARG(4).EQ.'LIMI'.OR.IHARG(4).EQ.'INTE'))THEN ISHIFT=4 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='TWOV' CALL DPCONF(XTEMP1,XTEMP2,MAXNXT,ICASAN, 1 ICAPSW, 1 IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MEAN'.AND. 1 IHARG(2).EQ.'CONF'.AND. 1 (IHARG(3).EQ.'LIMI'.OR.IHARG(3).EQ.'INTE'))THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='TWOV' CALL DPCONF(XTEMP1,XTEMP2,MAXNXT,ICASAN, 1 ICAPSW, 1 IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF ENDIF C C *************************************************** C ** TREAT THE PROPORTION CONFIDENCE LIMITS CASE ** C ** AND DIFFERENCE OF PROPORTION CONFIDENCE ** C ** LIMITS CASE ** C *************************************************** C IF(ICOM.EQ.'PROP')THEN IF(NUMARG.GE.2.AND.IHARG(1).EQ.'CONF'.AND. 1 (IHARG(2).EQ.'LIMI'.OR.IHARG(2).EQ.'INTE'))THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='PROP' CALL DPPRCL(XTEMP1,XTEMP2,MAXNXT,ICASAN,ANOPL1,ANOPL2, 1 IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF ENDIF C IF(ICOM.EQ.'DIFF')THEN IF(NUMARG.GE.4.AND.IHARG(1).EQ.'OF '.AND. 1 IHARG(2).EQ.'PROP'.AND.IHARG(3).EQ.'CONF'.AND. 1 (IHARG(4).EQ.'LIMI'.OR.IHARG(4).EQ.'INTE'))THEN ISHIFT=4 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='DPRO' CALL DPPRCL(XTEMP1,XTEMP2,MAXNXT,ICASAN,ANOPL1,ANOPL2, 1 IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF IF(NUMARG.GE.3.AND.IHARG(1).EQ.'PROP'.AND. 1 IHARG(2).EQ.'CONF'.AND. 1 (IHARG(3).EQ.'LIMI'.OR.IHARG(3).EQ.'INTE'))THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='DPRO' CALL DPPRCL(XTEMP1,XTEMP2,MAXNXT,ICASAN,ANOPL1,ANOPL2, 1 IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF ENDIF C C **************************************** C ** TREAT THE TOLERANCE LIMITS CASE ** C **************************************** C IF(ICOM.EQ.'TOLE')THEN IF(NUMARG.GE.1.AND. 1 (IHARG(1).EQ.'LIMI'.OR.IHARG(1).EQ.'INTE'))THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF ICASAN='TOLE' CALL DPTOLI(XTEMP1,XTEMP2,MAXNXT, 1 ICASAN, 1 IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C ELSE IF(ICOM.EQ.'NORM')THEN IF(NUMARG.GE.2.AND. 1 IHARG(1).EQ.'TOLE'.AND. 1 (IHARG(2).EQ.'LIMI'.OR.IHARG(2).EQ.'INTE'))THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='NTOL' CALL DPTOLI(XTEMP1,XTEMP2,MAXNXT, 1 ICASAN, 1 IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C ELSE IF(ICOM.EQ.'NONP')THEN IF(NUMARG.GE.2.AND. 1 IHARG(1).EQ.'TOLE'.AND. 1 (IHARG(2).EQ.'LIMI'.OR.IHARG(2).EQ.'INTE'))THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='NPTO' CALL DPTOLI(XTEMP1,XTEMP2,MAXNXT, 1 ICASAN, 1 IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C ENDIF C C ****************************** C ** TREAT THE RUNS CASE ** C ****************************** C IF(ICOM.EQ.'RUNS')GOTO3200 GOTO3299 C 3200 CONTINUE ICASAN='RUNS' CALL DPRUN(XTEMP1,XTEMP2,MAXNXT, 1IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 3299 CONTINUE C C ********************************************* C ** TREAT THE RELIABILTY TREND TESTS CASE ** C ********************************************* C IF(ICOM.EQ.'RELI')THEN IF(NUMARG.GE.2.AND.IHARG(1).EQ.'TREN'.AND. 1 IHARG(2).EQ.'TEST')THEN ICASAN='TREN' ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) CALL DPTREN(XTEMP1,XTEMP2,MAXNXT, 1 ICAPSW,ISUBRO, 1 IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF ENDIF C C CCCCC THE FOLLOWING SECTION WAS REWRITTEN FEBRUARY 1994 C ****************************** C ** TREAT THE T TEST CASE ** C ****************************** C IF(ICOM.EQ.'T ')THEN IF(NUMARG.GE.1.AND.IHARG(1).EQ.'TEST')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='TTES' CALL DPTTES(XTEMP1,XTEMP2,MAXNXT, 1 ICAPSW, 1 IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED JUNE 1999 C ********************************* C ** TREAT THE SIGN TEST CASE ** C ********************************* C IF(ICOM.EQ.'SIGN')THEN IF(NUMARG.GE.1.AND.IHARG(1).EQ.'TEST')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF ICASAN='STES' IF(NUMARG.GE.1.AND.IHARG(1).EQ.'RANK')THEN CONTINUE ELSE CALL DPSIGN(XTEMP1,XTEMP2,MAXNXT, 1 ICAPSW, 1 IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED JUNE 1999 C ************************************************* C ** TREAT THE WILCOXON SIGNED RANK TEST CASE ** C ************************************************* C IF(ICOM.EQ.'WILC')THEN IF(NUMARG.GE.3.AND.IHARG(1).EQ.'SIGN'.AND. 1 IHARG(2).EQ.'RANK'.AND.IHARG(3).EQ.'TEST')THEN ISHIFT=3 ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'SIGN'.AND. 1 IHARG(2).EQ.'RANK')THEN ISHIFT=2 ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'SIGN'.AND. 1 IHARG(2).EQ.'TEST')THEN ISHIFT=2 ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'TEST')THEN ISHIFT=1 ELSE GOTO3039 ENDIF CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='WTES' CALL DPWILC(XTEMP1,XTEMP2,MAXNXT, 1 ICAPSW, 1 IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF IF(ICOM.EQ.'SIGN')THEN IF(NUMARG.GE.2.AND.IHARG(1).EQ.'RANK'.AND. 1 IHARG(2).EQ.'TEST')THEN ISHIFT=2 ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'RANK')THEN ISHIFT=1 ELSE GOTO3039 ENDIF CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='WTES' CALL DPWILC(XTEMP1,XTEMP2,MAXNXT, 1 ICAPSW, 1 IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C 3039 CONTINUE C CCCCC THE FOLLOWING SECTION WAS ADDED JULY 1999 C ************************************************* C ** TREAT THE MANN-WHITNEY RANK SUM TEST CASE ** C ************************************************* C IF(ICOM.EQ.'MANN')THEN IF(NUMARG.GE.4.AND.IHARG(1).EQ.'WHIT'.AND. 1 IHARG(2).EQ.'RANK'.AND.IHARG(3).EQ.'SUM '.AND. 1 IHARG(4).EQ.'TEST')THEN ISHIFT=4 ELSEIF(NUMARG.GE.3.AND.IHARG(1).EQ.'WHIT'.AND. 1 IHARG(2).EQ.'RANK'.AND.IHARG(3).EQ.'SUM ')THEN ISHIFT=3 ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'WHIT'.AND. 1 IHARG(2).EQ.'TEST')THEN ISHIFT=2 ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'WHIT')THEN ISHIFT=1 ELSE GOTO3049 ENDIF CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='MTES' CALL DPMANN(XTEMP1,XTEMP2,MAXNXT, 1 IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF IF(ICOM.EQ.'RANK')THEN IF(NUMARG.GE.2.AND.IHARG(1).EQ.'SUM '.AND. 1 IHARG(2).EQ.'TEST')THEN ISHIFT=2 ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'SUM ')THEN ISHIFT=1 ELSE GOTO3049 ENDIF CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='MTES' CALL DPMANN(XTEMP1,XTEMP2,MAXNXT, 1 IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C 3049 CONTINUE C CCCCC THE FOLLOWING SECTION WAS ADDED FEBRUARY 1994 C **************************************** C ** TREAT THE CHI-SQUARED TEST CASE ** C **************************************** C IF(ICOM.EQ.'CHI ')THEN IF(NUMARG.GE.1.AND.IHARG(1).EQ.'SQUA')THEN IF(NUMARG.GE.2.AND.IHARG(2).EQ.'TEST')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='CSTE' CALL DPCSTE(XTEMP1,XTEMP2,MAXNXT, 1 ICAPSW, 1 IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF ENDIF ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED DECEMBER 1998 C ************************************************* C ** TREAT THE CHI-SQUARED 2 SAMPLE TEST CASE ** C ************************************************* C IF(ICOM.EQ.'CHI '.OR.ICOM.EQ.'CHIS'.OR.ICOM.EQ.'2'.OR. 1 ICOM.EQ.'TWO')THEN CALL DP2CHS(TEMP,TEMP2,XTEMP1,XTEMP2,MAXNXT, 1 IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED DECEMBER 1998 C ******************************************************* C ** TREAT THE KOLMOGOROV-SMIRNOV 2 SAMPLE TEST CASE ** C ******************************************************* C IF(ICOM.EQ.'KOLM'.OR.ICOM.EQ.'2'.OR. 1 ICOM.EQ.'TWO')THEN CALL DP2KST(TEMP,TEMP2,MAXNXT, 1 IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED NOVEMBER 1998 C *************************************************** C ** TREAT THE CHI-SQUARED GOODNESS OF FIT CASE ** C *************************************************** C IF(NUMARG.GE.3)THEN DO7010I=1,NUMARG-2 IF(IHARG(I).EQ.'GOOD'.AND.IHARG(I+1).EQ.'OF'.AND. 1 IHARG(I+2).EQ.'FIT')THEN CALL DPCHSQ(XTEMP1,XTEMP2,TEMP,MAXNXT, 1 ICAPSW, 1 IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF 7010 CONTINUE ENDIF IF(NUMARG.GE.2)THEN DO7020I=1,NUMARG-1 IF(IHARG(I).EQ.'CHI '.AND.IHARG(I+1).EQ.'SQUA')THEN CALL DPCHSQ(XTEMP1,XTEMP2,TEMP,MAXNXT, 1 ICAPSW, 1 IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF 7020 CONTINUE ENDIF IF(NUMARG.GE.1)THEN DO7030I=1,NUMARG IF(IHARG(I).EQ.'CHIS')THEN CALL DPCHSQ(XTEMP1,XTEMP2,TEMP,MAXNXT, 1 ICAPSW, 1 IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF 7030 CONTINUE ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED NOVEMBER 1998 C *************************************************** C ** TREAT THE KOLMOGOROV-SMIRNOV GOODNESS OF FIT CASE C *************************************************** C IF(NUMARG.GE.3)THEN DO7060I=1,NUMARG-2 IF(IHARG(I).EQ.'GOOD'.AND.IHARG(I+1).EQ.'OF'.AND. 1 IHARG(I+2).EQ.'FIT')THEN CALL DP1KST(XTEMP1,XTEMP2,TEMP,MAXNXT, 1 ICAPSW, 1 IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF 7060 CONTINUE ENDIF IF(NUMARG.GE.2)THEN DO7070I=1,NUMARG-1 IF(IHARG(I).EQ.'KOLM'.AND.IHARG(I+1).EQ.'SMIR')THEN CALL DP1KST(XTEMP1,XTEMP2,TEMP,MAXNXT, 1 ICAPSW, 1 IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF 7070 CONTINUE ENDIF IF(NUMARG.GE.2)THEN DO7080I=1,NUMARG-1 IF(IHARG(I).EQ.'KOLM'.AND.IHARG(I+1).EQ.'SMIR')THEN CALL DP1KST(XTEMP1,XTEMP2,TEMP,MAXNXT, 1 ICAPSW, 1 IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF 7080 CONTINUE ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1997 C *************************************** C ** TREAT THE F LOCATION TEST CASE ** C *************************************** C IF(ICOM.EQ.'F '.AND.(NUMARG.GE.1.AND.IHARG(1).EQ.'LOCA'))THEN IF(NUMARG.GE.1.AND.IHARG(1).EQ.'LOCA')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='FLTE' IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF IF(NUMARG.GE.1.AND.IHARG(1).EQ.'TEST')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF CALL DPFLTE(XTEMP1,XTEMP2,MAXNXT, 1 IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR) ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED FEBRUARY 1994 C ****************************** C ** TREAT THE F TEST CASE ** C ****************************** C IF(ICOM.EQ.'F ')THEN IF(NUMARG.GE.1.AND.IHARG(1).EQ.'TEST')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='FTES' CALL DPFTES(XTEMP1,XTEMP2,MAXNXT, 1 ICAPSW, 1 IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED FEBRUARY 1994 C *************************************** C ** TREAT THE BARTLETT'S TEST CASE ** C *************************************** C CCCCC ADD: DIXON BARTLETT TEST AUGUST 1999 CCCCC ADD: DIXON MASSEY BARTLETT TEST AUGUST 1999 CCCCC ADD: DM BARTLETT TEST AUGUST 1999 C IF(ICOM.EQ.'BART')THEN IF(NUMARG.GE.1.AND.IHARG(1).EQ.'TEST')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='BTES' CALL DPBTES(XTEMP1,XTEMP2,MAXNXT,ICASAN, 1 IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF ENDIF C IF(ICOM.EQ.'DIXO')THEN IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MASS'.AND. 1 IHARG(2).EQ.'BART'.AND.IHARG(3).EQ.'TEST')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='DMBT' CALL DPBTES(XTEMP1,XTEMP2,MAXNXT,ICASAN, 1 IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'BART'.AND. 1 IHARG(2).EQ.'TEST')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='DMBT' CALL DPBTES(XTEMP1,XTEMP2,MAXNXT,ICASAN, 1 IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF ENDIF C IF(ICOM.EQ.'DM ')THEN IF(NUMARG.GE.2.AND.IHARG(1).EQ.'BART'.AND. 1 IHARG(2).EQ.'TEST')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='DMBT' CALL DPBTES(XTEMP1,XTEMP2,MAXNXT,ICASAN, 1 IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1997 C ******************************************** C ** TREAT THE KRUSKALL-WALLIS TEST CASE ** C ******************************************** C IF(ICOM.EQ.'KRUS')THEN IF(NUMARG.GE.2.AND.IHARG(1).EQ.'WALL'.AND. 1 IHARG(2).EQ.'TEST')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'TEST')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'WALL')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF ICASAN='KTES' CALL DPKRUS(XTEMP1,XTEMP2,MAXNXT, 1 ICAPSW, 1 IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1997 C *************************************************** C ** TREAT THE VAN DER WAERDEN TEST CASE ** C ** ONE WAY NORMAL SCORES TEST CASE ** C *************************************************** C IF(ICOM.EQ.'VAN ')THEN IF(NUMARG.GE.3.AND.IHARG(1).EQ.'DER '.AND. 1 IHARG(2).EQ.'WAER'.AND.IHARG(3).EQ.'TEST')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'DER '.AND. 1 IHARG(2).EQ.'WAER')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF ICASAN='VDWA' CALL DPVWAE(XTEMP1,XTEMP2,MAXNXT, 1 ICAPSW, 1 IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C IF(ICOM.EQ.'ONE ')THEN IF(NUMARG.GE.4.AND.IHARG(1).EQ.'WAY '.AND. 1 IHARG(2).EQ.'NORM'.AND.IHARG(3).EQ.'SCOR'.AND. 1 IHARG(4).EQ.'TEST')THEN ISHIFT=4 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.3.AND.IHARG(1).EQ.'WAY '.AND. 1 IHARG(2).EQ.'NORM'.AND.IHARG(3).EQ.'SCOR')THEN ISHIFT=4 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF ICASAN='VDWA' CALL DPVWAE(XTEMP1,XTEMP2,MAXNXT, 1 ICAPSW, 1 IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED OCTOBER 2003 C ******************************************** C ** TREAT THE FRIEDMAN CASE ** C ******************************************** C IF(ICOM.EQ.'FRIE')THEN IF(NUMARG.GE.2.AND.IHARG(1).EQ.'RANK'.AND. 1 IHARG(2).EQ.'TEST')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'TEST')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF ICASAN='FRIE' CALL DPFRIE(XTEMP1,XTEMP2,MAXNXT, 1 ICAPSW, 1 IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED JANUARY 2006 C ******************************************** C ** TREAT THE DURBIN CASE ** C ******************************************** C IF(ICOM.EQ.'DURB')THEN IF(NUMARG.GE.2.AND.IHARG(1).EQ.'RANK'.AND. 1 IHARG(2).EQ.'TEST')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'TEST')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF ICASAN='DURB' CALL DPDURB(XTEMP1,XTEMP2,MAXNXT, 1 ICAPSW, 1 IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED OCTOBER 2004 C ******************************************** C ** TREAT THE COCHRAN CASE ** C ******************************************** C IF(ICOM.EQ.'COCH')THEN IF(NUMARG.GE.1.AND.IHARG(1).EQ.'TEST')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF ICASAN='COCH' CALL DPCOCH(XTEMP1,XTEMP2,MAXNXT, 1 ICAPSW, 1 IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED JUNE 1999 C *************************************** C ** TREAT THE LEVENE'S TEST CASE ** C *************************************** C CCCCC ADD: MEAN LEVENE TEST AND TRIMMED MEAN LEVENE TEST. CCCCC APRIL 1999 C IF(ICOM.EQ.'LEVE')THEN IF(NUMARG.GE.1.AND.IHARG(1).EQ.'TEST')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='LMED' CALL DPLTES(XTEMP1,XTEMP2,MAXNXT,ICASAN, 1 ICAPSW, 1 IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF ENDIF C IF(ICOM.EQ.'MEAN')THEN IF(NUMARG.GE.2.AND.IHARG(1).EQ.'LEVE'.AND. 1 IHARG(2).EQ.'TEST')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='LMEA' CALL DPLTES(XTEMP1,XTEMP2,MAXNXT,ICASAN, 1 ICAPSW, 1 IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ELSE IF(NUMARG.GE.1.AND.IHARG(1).EQ.'LEVE')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='LMEA' CALL DPLTES(XTEMP1,XTEMP2,MAXNXT,ICASAN, 1 ICAPSW, 1 IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF ENDIF C IF(ICOM.EQ.'MEDI')THEN IF(NUMARG.GE.2.AND.IHARG(1).EQ.'LEVE'.AND. 1 IHARG(2).EQ.'TEST')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='LMED' CALL DPLTES(XTEMP1,XTEMP2,MAXNXT,ICASAN, 1 ICAPSW, 1 IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ELSE IF(NUMARG.GE.1.AND.IHARG(1).EQ.'LEVE')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='LMED' CALL DPLTES(XTEMP1,XTEMP2,MAXNXT,ICASAN, 1 ICAPSW, 1 IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF ENDIF C IF(ICOM.EQ.'TRIM')THEN IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MEAN'.AND. 1 IHARG(2).EQ.'LEVE'.AND.IHARG(3).EQ.'TEST')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='LTRI' CALL DPLTES(XTEMP1,XTEMP2,MAXNXT,ICASAN, 1 ICAPSW, 1 IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ELSE IF(NUMARG.GE.2.AND.IHARG(2).EQ.'MEAN'.AND. 1 IHARG(2).EQ.'LEVE')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='LTRI' CALL DPLTES(XTEMP1,XTEMP2,MAXNXT,ICASAN, 1 ICAPSW, 1 IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1997 CCCCC ADD THE ANDERSON-DARLING K-SAMPLE TEST APRIL 1998. CCCCC ADD THE ANDERSON-DARLING LOGISTIC TEST OCTOBER 2003. CCCCC ADD THE ANDERSON-DARLING UNIFORM TEST NOVEMBER 2003. CCCCC ADD THE ANDERSON-DARLING DOUBLE EXPONENTIAL TEST NOVEMBER 2003. C ********************************************* C ** TREAT THE ANDERSON DARLING TEST CASE ** C ********************************************* C IF(ICOM.EQ.'ANDE')THEN IF(NUMARG.GE.1.AND.IHARG(1).EQ.'DARL')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASDI='NORM' IF(NUMARG.GE.1.AND.(IHARG(1).EQ.'NORM'))THEN ICASDI='NORM' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.1.AND.(IHARG(1).EQ.'LOGN'))THEN ICASDI='LOGN' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.1.AND.(IHARG(1).EQ.'LOGI'))THEN ICASDI='LOGI' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.1.AND.(IHARG(1).EQ.'UNIF'))THEN ICASDI='UNIF' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'LAPL')THEN ICASDI='DEXP' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'DOUB'.AND. 1 IHARG(2).EQ.'EXPO')THEN ICASDI='DEXP' ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'GENE'.AND. 1 IHARG(2).EQ.'PARE')THEN ICASDI='GPAR' ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.1.AND.(IHARG(1).EQ.'EXPO'))THEN ICASDI='EXPO' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.1.AND.(IHARG(1).EQ.'WEIB'))THEN ICASDI='WEIB' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.4.AND.(IHARG(1).EQ.'EXTR'.AND. 1 IHARG(2).EQ.'VALU'.AND.IHARG(3).EQ.'TYPE'.AND. 1 IHARG(4).EQ.'1 '))THEN ICASDI='EXTV' ISHIFT=4 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) CCCCC JULY 2001. ADD "EV1" AND "EXTREME VALUE TYPE I" AS SYNONYMS ELSEIF(NUMARG.GE.4.AND.(IHARG(1).EQ.'EXTR'.AND. 1 IHARG(2).EQ.'VALU'.AND.IHARG(3).EQ.'TYPE'.AND. 1 IHARG(4).EQ.'1 '))THEN ICASDI='EXTV' ISHIFT=4 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.4.AND.(IHARG(1).EQ.'EXTR'.AND. 1 IHARG(2).EQ.'VALU'.AND.IHARG(3).EQ.'TYPE'.AND. 1 IHARG(4).EQ.'I '))THEN ICASDI='EXTV' ISHIFT=4 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.2.AND.(IHARG(1).EQ.'EXTR'.AND. 1 IHARG(2).EQ.'VALU'))THEN ICASDI='EXTV' ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'EV1 ')THEN ICASDI='EXTV' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.1.AND.(IHARG(1).EQ.'K-SA'))THEN ICASDI='K-SA' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.2.AND.(IHARG(1).EQ.'K '.AND.IHARG(2).EQ. 1 'SAMP'))THEN ICASDI='K-SA' ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C IF(NUMARG.GE.1.AND.IHARG(1).EQ.'TEST')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C IF(NUMARG.GE.1.AND.(IHARG(1).EQ.'NORM'))THEN ICASDI='NORM' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.1.AND.(IHARG(1).EQ.'LOGN'))THEN ICASDI='LOGN' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.1.AND.(IHARG(1).EQ.'LOGI'))THEN ICASDI='LOGI' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'UNIF')THEN ICASDI='UNIF' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'LAPL')THEN ICASDI='DEXP' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'DOUB'.AND. 1 IHARG(2).EQ.'EXPO')THEN ICASDI='DEXP' ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'GENE'.AND. 1 IHARG(2).EQ.'PARE')THEN ICASDI='GPAR' ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.1.AND.(IHARG(1).EQ.'EXPO'))THEN ICASDI='EXPO' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.1.AND.(IHARG(1).EQ.'WEIB'))THEN ICASDI='WEIB' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.4.AND.(IHARG(1).EQ.'EXTR'.AND. 1 IHARG(2).EQ.'VALU'.AND.IHARG(3).EQ.'TYPE'.AND. 1 IHARG(4).EQ.'1 '))THEN ICASDI='EXTV' ISHIFT=4 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.4.AND.(IHARG(1).EQ.'EXTR'.AND. 1 IHARG(2).EQ.'VALU'.AND.IHARG(3).EQ.'TYPE'.AND. 1 IHARG(4).EQ.'I '))THEN ICASDI='EXTV' ISHIFT=4 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.2.AND.(IHARG(1).EQ.'EXTR'.AND. 1 IHARG(2).EQ.'VALU'))THEN ICASDI='EXTV' ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'GUMB')THEN ICASDI='EXTV' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'EV1 ')THEN ICASDI='EXTV' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.1.AND.(IHARG(1).EQ.'GAMM'))THEN ICASDI='GAMM' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.1.AND.(IHARG(1).EQ.'CAUC'))THEN ICASDI='CAUC' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.1.AND.(IHARG(1).EQ.'FREC'))THEN ICASDI='FREC' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.4.AND.(IHARG(1).EQ.'EXTR'.AND. 1 IHARG(2).EQ.'VALU'.AND.IHARG(3).EQ.'TYPE'.AND. 1 IHARG(4).EQ.'2'))THEN ICASDI='FREC' ISHIFT=4 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.4.AND.(IHARG(1).EQ.'EXTR'.AND. 1 IHARG(2).EQ.'VALU'.AND.IHARG(3).EQ.'TYPE'.AND. 1 IHARG(4).EQ.'II'))THEN ICASDI='FREC' ISHIFT=4 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C IF(ICASDI.EQ.'K-SA')THEN ICASAN='ADKS' CALL DPADKS(XTEMP1,XTEMP2,MAXNXT, 1 IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ELSE ICASAN='ATES' CALL DPADAR(XTEMP1,MAXNXT,ICASDI, 1 ICAPSW, 1 IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED MARCH 1999 C ********************************************* C ** TREAT THE WILKS-SHAPIRO TEST CASE ** C ********************************************* C IF(ICOM.EQ.'WILK'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'SHAP')THEN IFOUND='YES' IF(NUMARG.GE.3.AND.IHARG(2).EQ.'NORM'.AND.IHARG(3).EQ.'TEST') 1 THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.2.AND.IHARG(2).EQ.'TEST')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSE ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='WSTE' CALL DPWSHA(XTEMP1,MAXNXT,ICASDI, 1 ICAPSW, 1 IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1997 C ********************************************* C ** TREAT THE GRUBB TEST CASE ** C ********************************************* C IF(ICOM.EQ.'GRUB')THEN ICASAN='GTES' IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MINI'.AND. 1 IHARG(2).EQ.'TEST')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='GTMI' ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'MAXI'.AND. 1 IHARG(2).EQ.'TEST')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='GTMA' ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'TEST')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'MINI')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='GTMI' ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'MAXI')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='GTMA' ENDIF C CALL DPGRUB(XTEMP1,MAXNXT, 1 ICAPSW,ICASAN, 1 IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED FEBRUARY 2003 C ********************************************* C ** TREAT THE LUJAN-BOX TEST CASE ** C ********************************************* C IF(ICOM.EQ.'LJUN')THEN IF(NUMARG.GE.1.AND.IHARG(1).EQ.'TEST')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'BOX '.AND. 1 IHARG(2).EQ.'TEST')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'BOX ')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='LUJA' CALL DPLUJA(XTEMP1,MAXNXT, 1 IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED NOVEMBER 2003 C ****************************************************** C ** TREAT THE FREQUENCY TEST CASE ** C ** TREAT THE FREQUENCY WITHIN A BLOCK TEST CASE ** C ****************************************************** C IF(ICOM.EQ.'FREQ')THEN IFOUND='NO' IF(NUMARG.GE.4.AND.IHARG(1).EQ.'WITH'.AND.IHARG(2).EQ.'A'.AND. 1 IHARG(3).EQ.'BLOC'.AND.IHARG(4).EQ.'TEST')THEN ISHIFT=4 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='FBTE' IFOUND='YES' ELSEIF(NUMARG.GE.3.AND.IHARG(1).EQ.'WITH'.AND. 1 IHARG(2).EQ.'BLOC'.AND.IHARG(3).EQ.'TEST')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='FBTE' IFOUND='YES' ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'BLOC'.AND. 1 IHARG(2).EQ.'TEST')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='FBTE' IFOUND='YES' ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'TEST')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='FRTE' IFOUND='YES' ENDIF C IF(IFOUND.EQ.'YES')THEN IFOUND='NO' CALL DPFRTE(XTEMP1,MAXNXT, 1 ICASAN,ICAPSW, 1 IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED DECEMBER 2003 C ****************************************************** C ** TREAT THE CUMULATIVE SUM TEST CASE ** C ****************************************************** C IF(ICOM.EQ.'CUMU')THEN IFOUND='NO' IF(NUMARG.GE.3.AND.IHARG(1).EQ.'SUM '.AND. 1 IHARG(2).EQ.'RAND'.AND.IHARG(3).EQ.'TEST')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='CUSU' IFOUND='YES' ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'SUM '.AND. 1 IHARG(2).EQ.'TEST')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='FBTE' IFOUND='YES' ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'SUM '.AND. 1 IHARG(2).EQ.'RAND')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='FBTE' IFOUND='YES' ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'SUM ')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='FRTE' IFOUND='YES' ENDIF C IF(IFOUND.EQ.'YES')THEN IFOUND='NO' CALL DPCUSU(XTEMP1,MAXNXT, 1 ICASAN,ICAPSW, 1 IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF ENDIF C IF(ICOM.EQ.'CUSU')THEN IFOUND='NO' IF(NUMARG.GE.2.AND.IHARG(1).EQ.'RAND'.AND. 1 IHARG(2).EQ.'TEST')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='FBTE' IFOUND='YES' ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'RAND')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='FRTE' IFOUND='YES' ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'TEST')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='FRTE' IFOUND='YES' ENDIF C IF(IFOUND.EQ.'YES')THEN IFOUND='NO' CALL DPCUSU(XTEMP1,MAXNXT, 1 ICASAN,ICAPSW, 1 IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED MARCH 1998 C ************************************************ C ** TREAT THE WEIBULL MAXIMUM LIKELIHOOD CASE ** C ************************************************ C IF(ICOM.EQ.'WEIB')THEN IF(IHARG(1).EQ.'HAZA')GOTO9000 IF(IHARG(1).EQ.'CHI ')GOTO9000 IF(IHARG(1).EQ.'CHIS')GOTO9000 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MAXI'.AND. 1 IHARG(2).EQ.'LIKE'.AND.IHARG(3).EQ.'ESTI')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MAXI'.AND. 1 IHARG(2).EQ.'LIKE')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MLE ')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='WEML' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED AUGUST 2005 C *************************************************** C ** TREAT THE INVERTED WEIBULL MAXIMUM LIKE CASE ** C *************************************************** C IF(ICOM.EQ.'INVE' .AND. IHARG(1).EQ.'WEIB')THEN IF(IHARG(2).EQ.'HAZA')GOTO9000 IF(IHARG(2).EQ.'CHI ')GOTO9000 IF(IHARG(2).EQ.'CHIS')GOTO9000 IF(NUMARG.GE.4.AND.IHARG(2).EQ.'MAXI'.AND. 1 IHARG(3).EQ.'LIKE'.AND.IHARG(4).EQ.'ESTI')THEN ISHIFT=4 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.3.AND.IHARG(2).EQ.'MAXI'.AND. 1 IHARG(3).EQ.'LIKE')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.2.AND.IHARG(2).EQ.'MLE ')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='IWML' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED MARCH 1999 C ******************************************************* C ** TREAT THE NORMAL MIXTURE MAXIMUM LIKELIHOOD CASE** C ******************************************************* C IF(ICOM.EQ.'NORM'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'MIXT')THEN IF(IHARG(2).EQ.'HAZA')GOTO9000 IF(IHARG(2).EQ.'CHI ')GOTO9000 IF(IHARG(2).EQ.'CHIS')GOTO9000 IF(NUMARG.GE.4.AND.IHARG(2).EQ.'MAXI'.AND. 1 IHARG(3).EQ.'LIKE'.AND.IHARG(4).EQ.'ESTI')THEN ISHIFT=4 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.3.AND.IHARG(2).EQ.'MAXI'.AND. 1 IHARG(3).EQ.'LIKE')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.2.AND.IHARG(2).EQ.'MLE ')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='NMML' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED APRIL 1998 C ************************************************ C ** TREAT THE NORMAL MAXIMUM LIKELIHOOD CASE ** C ************************************************ C IF(ICOM.EQ.'NORM')THEN IF(IHARG(1).EQ.'HAZA')GOTO9000 IF(IHARG(1).EQ.'CHI ')GOTO9000 IF(IHARG(1).EQ.'CHIS')GOTO9000 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MAXI'.AND. 1 IHARG(2).EQ.'LIKE'.AND.IHARG(3).EQ.'ESTI')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MAXI'.AND. 1 IHARG(2).EQ.'LIKE')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MLE ')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='NOML' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED APRIL 1998 C ************************************************ C ** TREAT THE LOGNORMAL MAXIMUM LIKELIHOOD CASE ** C ************************************************ C IF(ICOM.EQ.'LOGN'.OR.ICOM.EQ.'LOG-')THEN IF(IHARG(1).EQ.'HAZA')GOTO9000 IF(IHARG(1).EQ.'CHI ')GOTO9000 IF(IHARG(1).EQ.'CHIS')GOTO9000 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MAXI'.AND. 1 IHARG(2).EQ.'LIKE'.AND.IHARG(3).EQ.'ESTI')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MAXI'.AND. 1 IHARG(2).EQ.'LIKE')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MLE ')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='LGML' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED APRIL 1998 C ************************************************ C ** TREAT THE EXPONENTIAL MAXIMUM LIKELIHOOD CASE ** C ************************************************ C C OCTOBER 2004: SUPPORT FOR EXPONENTIAL GROUPED MAXIMUM LIKELIHOOD C IF(ICOM.EQ.'EXPO')THEN IF(IHARG(1).EQ.'HAZA')GOTO9000 IF(IHARG(1).EQ.'CHI ')GOTO9000 IF(IHARG(1).EQ.'CHIS')GOTO9000 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MAXI'.AND. 1 IHARG(2).EQ.'LIKE'.AND.IHARG(3).EQ.'ESTI')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MAXI'.AND. 1 IHARG(2).EQ.'LIKE')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='EXML' ENDIF IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MLE ')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='EXML' ENDIF C IF(NUMARG.GE.4.AND.IHARG(1).EQ.'GROU'.AND. 1 IHARG(2).EQ.'MAXI'.AND. 1 IHARG(3).EQ.'LIKE'.AND.IHARG(4).EQ.'ESTI')THEN ISHIFT=4 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='EXMG' ENDIF IF(NUMARG.GE.3.AND.IHARG(1).EQ.'GROU'.AND. 1 IHARG(2).EQ.'MAXI'.AND. 1 IHARG(3).EQ.'LIKE')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='EXMG' ENDIF IF(NUMARG.GE.2.AND.IHARG(1).EQ.'GROU'.AND. 1 IHARG(2).EQ.'MLE ')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='EXMG' ENDIF C CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED JUNE 1998 C ************************************************ C ** TREAT THE DOUBLE EXPONENTIAL MAXIMUM ** C ** LIKELIHOOD CASE ** C ************************************************ C IF(ICOM.EQ.'DOUB')THEN IF(IHARG(2).EQ.'CHI ')GOTO9000 IF(IHARG(2).EQ.'CHIS')GOTO9000 IF(NUMARG.GE.4.AND.IHARG(1).EQ.'EXPO'.AND. 1 IHARG(2).EQ.'MAXI'.AND. 1 IHARG(3).EQ.'LIKE'.AND.IHARG(4).EQ.'ESTI')THEN ISHIFT=4 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.3.AND.IHARG(1).EQ.'EXPO'.AND. 1 IHARG(2).EQ.'MAXI'.AND. 1 IHARG(3).EQ.'LIKE')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.2.AND.IHARG(1).EQ.'EXPO'.AND. 1 IHARG(2).EQ.'MLE ')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='DEML' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED AUGUST 2004 C ****************************************************** C ** TREAT THE ASYMMETRIC DOUBLE EXPONENTIAL MAXIMUM ** C ** LIKELIHOOD CASE ** C ****************************************************** C IF(ICOM.EQ.'ASYM')THEN IF(IHARG(2).EQ.'CHI ')GOTO9000 IF(IHARG(2).EQ.'CHIS')GOTO9000 IF(NUMARG.GE.5.AND.IHARG(1).EQ.'DOUB'.AND. 1 IHARG(2).EQ.'EXPO'.AND.IHARG(3).EQ.'MAXI'.AND. 1 IHARG(4).EQ.'LIKE'.AND.IHARG(5).EQ.'ESTI')THEN ISHIFT=5 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.4.AND.IHARG(1).EQ.'DOUB'.AND. 1 IHARG(2).EQ.'EXPO'.AND.IHARG(3).EQ.'MAXI'.AND. 1 IHARG(4).EQ.'LIKE')THEN ISHIFT=4 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.3.AND.IHARG(1).EQ.'DOUB'.AND. 1 IHARG(2).EQ.'EXPO'.AND.IHARG(3).EQ.'MLE ')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.4.AND.IHARG(1).EQ.'LAPL'.AND. 1 IHARG(2).EQ.'MAXI'.AND. 1 IHARG(3).EQ.'LIKE'.AND.IHARG(4).EQ.'ESTI')THEN ISHIFT=4 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.3.AND.IHARG(1).EQ.'LAPL'.AND. 1 IHARG(2).EQ.'MAXI'.AND. 1 IHARG(3).EQ.'LIKE')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'LAPL'.AND. 1 IHARG(2).EQ.'MLE ')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='ADML' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C C CCCCC THE FOLLOWING SECTION WAS ADDED MAY 1998 C ************************************************ C ** TREAT THE INVERSE GAUSSIAN MAXIMUM LIKELIHOOD CASE C ************************************************ C IF(ICOM.EQ.'INVE'.AND.IHARG(1).EQ.'GAUS')THEN IF(IHARG(2).EQ.'CHI ')GOTO9000 IF(IHARG(2).EQ.'CHIS')GOTO9000 IF(NUMARG.GE.4.AND.IHARG(2).EQ.'MAXI'.AND. 1 IHARG(3).EQ.'LIKE'.AND.IHARG(4).EQ.'ESTI')THEN ISHIFT=4 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.3.AND.IHARG(2).EQ.'MAXI'.AND. 1 IHARG(3).EQ.'LIKE')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.2.AND.IHARG(2).EQ.'MLE ')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='IGML' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED APRIL 1998 C ************************************************ C ** TREAT THE PARETO MAXIMUM LIKELIHOOD CASE ** C ************************************************ C IF(ICOM.EQ.'PARE')THEN IF(IHARG(1).EQ.'CHI ')GOTO9000 IF(IHARG(1).EQ.'CHIS')GOTO9000 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MAXI'.AND. 1 IHARG(2).EQ.'LIKE'.AND.IHARG(3).EQ.'ESTI')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MAXI'.AND. 1 IHARG(2).EQ.'LIKE')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MLE ')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='PAML' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED OCTOBER 2006 C *************************************************** C ** TREAT THE POWER LAW MAXIMUM LIKE CASE ** C *************************************************** C IF(ICOM.EQ.'POWE' .AND. IHARG(1).EQ.'LAW ')THEN IF(IHARG(2).EQ.'CHI ')GOTO9000 IF(IHARG(2).EQ.'CHIS')GOTO9000 IF(NUMARG.GE.4.AND.IHARG(2).EQ.'MAXI'.AND. 1 IHARG(3).EQ.'LIKE'.AND.IHARG(4).EQ.'ESTI')THEN ISHIFT=4 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.3.AND.IHARG(2).EQ.'MAXI'.AND. 1 IHARG(3).EQ.'LIKE')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.2.AND.IHARG(2).EQ.'MLE ')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='PLML' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED JUNE 1998 C ************************************************ C ** TREAT THE POWER MAXIMUM LIKELIHOOD CASE ** C ************************************************ C IF(ICOM.EQ.'POWE')THEN IF(IHARG(1).EQ.'CHI ')GOTO9000 IF(IHARG(1).EQ.'CHIS')GOTO9000 IF(IHARG(1).EQ.'EXPO')GOTO9000 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MAXI'.AND. 1 IHARG(2).EQ.'LIKE'.AND.IHARG(3).EQ.'ESTI')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MAXI'.AND. 1 IHARG(2).EQ.'LIKE')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MLE ')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='PWML' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED MAY 2002 C ************************************************ C ** TREAT THE TWO-SIDED POWER MAXIMUM ** C ** LIKELIHOOD CASE ** C ************************************************ C IF(ICOM.EQ.'TWO'.AND.IHARG(1).EQ.'SIDE'.AND. 1 IHARG(2).EQ.'POWE')THEN IF(IHARG(3).EQ.'CHI ')GOTO9000 IF(IHARG(3).EQ.'CHIS')GOTO9000 IF(NUMARG.GE.5.AND.IHARG(3).EQ.'MAXI'.AND. 1 IHARG(4).EQ.'LIKE'.AND.IHARG(5).EQ.'ESTI')THEN ISHIFT=5 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.4.AND.IHARG(3).EQ.'MAXI'.AND. 1 IHARG(4).EQ.'LIKE')THEN ISHIFT=4 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.3.AND.IHARG(3).EQ.'MLE ')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='TSML' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED JUNE 1998 C ************************************************ C ** TREAT THE GUMBEL MAXIMUM LIKELIHOOD CASE ** C ************************************************ C IF(ICOM.EQ.'GUMB'.OR.ICOM.EQ.'EV1 ')THEN IF(IHARG(1).EQ.'CHI ')GOTO9000 IF(IHARG(1).EQ.'CHIS')GOTO9000 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MAXI'.AND. 1 IHARG(2).EQ.'LIKE'.AND.IHARG(3).EQ.'ESTI')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MAXI'.AND. 1 IHARG(2).EQ.'LIKE')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MLE ')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='GUML' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED MAY 2005 C ************************************************ C ** TREAT THE FRECHET MAXIMUM LIKELIHOOD CASE ** C ************************************************ C IF(ICOM.EQ.'FREC'.OR.ICOM.EQ.'EV2 ')THEN IF(IHARG(1).EQ.'CHI ')GOTO9000 IF(IHARG(1).EQ.'CHIS')GOTO9000 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MAXI'.AND. 1 IHARG(2).EQ.'LIKE'.AND.IHARG(3).EQ.'ESTI')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MAXI'.AND. 1 IHARG(2).EQ.'LIKE')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MLE ')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='FRML' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED MARCH 2004. C ****************************************************** C ** TREAT THE GEOMETRIC EXTREME EXPONENTIAL MAXIMUM ** C ** LIEKLIHOOD CASE ** C ****************************************************** C IF(ICOM.EQ.'GEOM'.AND.IHARG(1).EQ.'EXTR'.AND. 1 IHARG(2).EQ.'EXPO')THEN IF(IHARG(3).EQ.'CHI ')GOTO9000 IF(IHARG(3).EQ.'CHIS')GOTO9000 IF(NUMARG.GE.5.AND.IHARG(3).EQ.'MAXI'.AND. 1 IHARG(4).EQ.'LIKE'.AND.IHARG(5).EQ.'ESTI')THEN ISHIFT=5 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.4.AND.IHARG(3).EQ.'MAXI'.AND. 1 IHARG(4).EQ.'LIKE')THEN ISHIFT=4 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.3.AND.IHARG(3).EQ.'MLE ')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='GXML' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED JULY 2006. C ****************************************************** C ** TREAT THE GENERALIZED LOGARITHMIC SERIES ** C ** MAXIMUM LIKELIHOOD CASE ** C ****************************************************** C IF(ICOM.EQ.'GENE'.AND.IHARG(1).EQ.'LOGA'.AND. 1 IHARG(2).EQ.'SERI')THEN IF(IHARG(3).EQ.'CHI ')GOTO9000 IF(IHARG(3).EQ.'CHIS')GOTO9000 IF(NUMARG.GE.5.AND.IHARG(3).EQ.'MAXI'.AND. 1 IHARG(4).EQ.'LIKE'.AND.IHARG(5).EQ.'ESTI')THEN ISHIFT=5 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.4.AND.IHARG(3).EQ.'MAXI'.AND. 1 IHARG(4).EQ.'LIKE')THEN ISHIFT=4 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.3.AND.IHARG(3).EQ.'MLE ')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='GSML' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED JULY 2006. C ****************************************************** C ** TREAT THE GENERALIZED NEGATIVE BINOMIAL ** C ** MAXIMUM LIKELIHOOD CASE ** C ****************************************************** C IF(ICOM.EQ.'GENE'.AND.IHARG(1).EQ.'NEGA'.AND. 1 IHARG(2).EQ.'BINO')THEN IF(IHARG(3).EQ.'CHI ')GOTO9000 IF(IHARG(3).EQ.'CHIS')GOTO9000 IF(NUMARG.GE.5.AND.IHARG(3).EQ.'MAXI'.AND. 1 IHARG(4).EQ.'LIKE'.AND.IHARG(5).EQ.'ESTI')THEN ISHIFT=5 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.4.AND.IHARG(3).EQ.'MAXI'.AND. 1 IHARG(4).EQ.'LIKE')THEN ISHIFT=4 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.3.AND.IHARG(3).EQ.'MLE ')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='GNBM' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED JULY 2006. C ****************************************************** C ** TREAT THE GEETA ** C ** MAXIMUM LIKELIHOOD CASE ** C ****************************************************** C IF(ICOM.EQ.'GEET')THEN IF(IHARG(1).EQ.'CHI ')GOTO9000 IF(IHARG(1).EQ.'CHIS')GOTO9000 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MAXI'.AND. 1 IHARG(2).EQ.'LIKE'.AND.IHARG(3).EQ.'ESTI')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MAXI'.AND. 1 IHARG(2).EQ.'LIKE')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MLE ')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='GTML' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED JULY 2006. C ****************************************************** C ** TREAT THE QUASI BINOMIAL TYPE I ** C ** MAXIMUM LIKELIHOOD CASE ** C ****************************************************** C IF(ICOM.EQ.'QUAS'.AND.IHARG(1).EQ.'BINO'.AND. 1 IHARG(2).EQ.'TYPE'.AND. 1 (IHARG(3).EQ.'I '.OR.IHARG(3).EQ.'1 '))THEN IF(IHARG(4).EQ.'CHI ')GOTO9000 IF(IHARG(4).EQ.'CHIS')GOTO9000 IF(NUMARG.GE.6.AND.IHARG(4).EQ.'MAXI'.AND. 1 IHARG(5).EQ.'LIKE'.AND.IHARG(6).EQ.'ESTI')THEN ISHIFT=6 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.5.AND.IHARG(4).EQ.'MAXI'.AND. 1 IHARG(5).EQ.'LIKE')THEN ISHIFT=5 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.4.AND.IHARG(4).EQ.'MLE ')THEN ISHIFT=4 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='QBML' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF IF(ICOM.EQ.'QUAS'.AND.IHARG(1).EQ.'BINO'.AND. 1 (IHARG(2).EQ.'I '.OR.IHARG(3).EQ.'2 '))THEN IF(IHARG(3).EQ.'CHI ')GOTO9000 IF(IHARG(3).EQ.'CHIS')GOTO9000 IF(NUMARG.GE.5.AND.IHARG(3).EQ.'MAXI'.AND. 1 IHARG(4).EQ.'LIKE'.AND.IHARG(5).EQ.'ESTI')THEN ISHIFT=5 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.4.AND.IHARG(3).EQ.'MAXI'.AND. 1 IHARG(4).EQ.'LIKE')THEN ISHIFT=4 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.3.AND.IHARG(3).EQ.'MLE ')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='QBML' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED AUGUST 2006. C ****************************************************** C ** TREAT THE CONSUL ** C ** MAXIMUM LIKELIHOOD CASE ** C ****************************************************** C IF(ICOM.EQ.'CONS')THEN IF(IHARG(1).EQ.'CHI ')GOTO9000 IF(IHARG(1).EQ.'CHIS')GOTO9000 IF(IHARG(1).EQ.'MEAN')GOTO9000 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MAXI'.AND. 1 IHARG(2).EQ.'LIKE'.AND.IHARG(3).EQ.'ESTI')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MAXI'.AND. 1 IHARG(2).EQ.'LIKE')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MLE ')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='CNML' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED MARCH 1999 C ************************************************ C ** TREAT THE GENERALIZED EXTREME VALUE ** C ** MAXIMUM LIKELIHOOD CASE ** C ************************************************ C IF(ICOM.EQ.'GENE'.AND.NUMARG.GE.2.AND.IHARG(1).EQ.'EXTR'.AND. 1 IHARG(2).EQ.'VALU')THEN IF(IHARG(3).EQ.'CHI ')GOTO9000 IF(IHARG(3).EQ.'CHIS')GOTO9000 IF(NUMARG.GE.5.AND.IHARG(3).EQ.'MAXI'.AND. 1 IHARG(4).EQ.'LIKE'.AND.IHARG(5).EQ.'ESTI')THEN ISHIFT=5 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.4.AND.IHARG(3).EQ.'MAXI'.AND. 1 IHARG(4).EQ.'LIKE')THEN ISHIFT=4 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.3.AND.IHARG(3).EQ.'MLE ')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='GEML' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF IF(ICOM.EQ.'GEV ')THEN IF(IHARG(1).EQ.'CHI ')GOTO9000 IF(IHARG(1).EQ.'CHIS')GOTO9000 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MAXI'.AND. 1 IHARG(2).EQ.'LIKE'.AND.IHARG(3).EQ.'ESTI')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MAXI'.AND. 1 IHARG(2).EQ.'LIKE')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MLE ')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='GEML' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED JUNE 1998 C ************************************************ C ** TREAT THE GAMMA MAXIMUM LIKELIHOOD CASE ** C ************************************************ C IF(ICOM.EQ.'GAMM')THEN IF(IHARG(1).EQ.'CHI ')GOTO9000 IF(IHARG(1).EQ.'CHIS')GOTO9000 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MAXI'.AND. 1 IHARG(2).EQ.'LIKE'.AND.IHARG(3).EQ.'ESTI')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MAXI'.AND. 1 IHARG(2).EQ.'LIKE')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MLE ')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='GAML' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 2001 C ************************************************ C ** TREAT THE BETA MAXIMUM LIKELIHOOD CASE ** C ************************************************ C IF(ICOM.EQ.'BETA' .AND. IHARG(1).NE.'BINO' .AND. 1 IHARG(1).NE.'GEOM')THEN IF(IHARG(1).EQ.'CHI ')GOTO9000 IF(IHARG(1).EQ.'CHIS')GOTO9000 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MAXI'.AND. 1 IHARG(2).EQ.'LIKE'.AND.IHARG(3).EQ.'ESTI')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MAXI'.AND. 1 IHARG(2).EQ.'LIKE')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MLE ')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='BEML' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED OCTOBER 2003 C ************************************************* C ** TREAT THE LOGISTIC MAXIMUM LIKELIHOOD CASE ** C ************************************************* C IF(ICOM.EQ.'LOGI')THEN IF(IHARG(1).EQ.'CHI ')GOTO9000 IF(IHARG(1).EQ.'CHIS')GOTO9000 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MAXI'.AND. 1 IHARG(2).EQ.'LIKE'.AND.IHARG(3).EQ.'ESTI')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MAXI'.AND. 1 IHARG(2).EQ.'LIKE')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MLE ')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='LOML' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED OCTOBER 2003 C ************************************************* C ** TREAT THE CAUCHY MAXIMUM LIKELIHOOD CASE ** C ************************************************* C IF(ICOM.EQ.'CAUC')THEN IF(IHARG(1).EQ.'CHI ')GOTO9000 IF(IHARG(1).EQ.'CHIS')GOTO9000 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MAXI'.AND. 1 IHARG(2).EQ.'LIKE'.AND.IHARG(3).EQ.'ESTI')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MAXI'.AND. 1 IHARG(2).EQ.'LIKE')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MLE ')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='CAML' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED APRIL 1998 C ************************************************ C ** TREAT THE BINOMIAL MAXIMUM LIKELIHOOD CASE ** C ************************************************ C IF(ICOM.EQ.'BINO')THEN IF(IHARG(1).EQ.'CHI ')GOTO9000 IF(IHARG(1).EQ.'CHIS')GOTO9000 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MAXI'.AND. 1 IHARG(2).EQ.'LIKE'.AND.IHARG(3).EQ.'ESTI')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MAXI'.AND. 1 IHARG(2).EQ.'LIKE')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MLE ')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='BIML' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED APRIL 1998 C ************************************************ C ** TREAT THE POISSON MAXIMUM LIKELIHOOD CASE ** C ************************************************ C IF(ICOM.EQ.'POIS')THEN IF(IHARG(1).EQ.'CHI ')GOTO9000 IF(IHARG(1).EQ.'CHIS')GOTO9000 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MAXI'.AND. 1 IHARG(2).EQ.'LIKE'.AND.IHARG(3).EQ.'ESTI')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MAXI'.AND. 1 IHARG(2).EQ.'LIKE')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MLE ')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='POML' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED MARCH 1999 C ****************************************************** C ** TREAT THE BETA BINOMIAL MAXIMUM LIKELIHOOD CASE ** C ****************************************************** C IF(ICOM.EQ.'BETA'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'BINO')THEN IF(IHARG(2).EQ.'CHI ')GOTO9000 IF(IHARG(2).EQ.'CHIS')GOTO9000 IF(NUMARG.GE.4.AND.IHARG(2).EQ.'MAXI'.AND. 1 IHARG(3).EQ.'LIKE'.AND.IHARG(4).EQ.'ESTI')THEN ISHIFT=4 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.3.AND.IHARG(2).EQ.'MAXI'.AND. 1 IHARG(3).EQ.'LIKE')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.2.AND.IHARG(2).EQ.'MLE ')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='BBML' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED MARCH 1999 C ************************************************ C ** TREAT THE POLYA MAXIMUM LIKELIHOOD CASE ** C ************************************************ C IF(ICOM.EQ.'POLY' .AND. IHARG(1).NE.'AEPP')THEN IF(IHARG(1).EQ.'CHI ')GOTO9000 IF(IHARG(1).EQ.'CHIS')GOTO9000 IF(IHARG(1).EQ.'KS ')GOTO9000 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MAXI'.AND. 1 IHARG(2).EQ.'LIKE'.AND.IHARG(3).EQ.'ESTI')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MAXI'.AND. 1 IHARG(2).EQ.'LIKE')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MLE ')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='PZML' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED MARCH 2004 C ****************************************************** C ** TREAT THE HYPERGEOMETRIC MAXIMUM LIKELIHOOD CASE** C ****************************************************** C IF(ICOM.EQ.'HYPE')THEN IF(IHARG(1).EQ.'CHI ')GOTO9000 IF(IHARG(1).EQ.'CHIS')GOTO9000 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MAXI'.AND. 1 IHARG(2).EQ.'LIKE'.AND.IHARG(3).EQ.'ESTI')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MAXI'.AND. 1 IHARG(2).EQ.'LIKE')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MLE ')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='HYML' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED APRIL 2004 C ****************************************************** C ** TREAT THE HERMITE MAXIMUM LIKELIHOOD CASE ** C ****************************************************** C IF(ICOM.EQ.'HERM')THEN IF(IHARG(1).EQ.'CHI ')GOTO9000 IF(IHARG(1).EQ.'CHIS')GOTO9000 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MAXI'.AND. 1 IHARG(2).EQ.'LIKE'.AND.IHARG(3).EQ.'ESTI')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MAXI'.AND. 1 IHARG(2).EQ.'LIKE')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MLE ')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='HEML' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED APRIL 2004 C ****************************************************** C ** TREAT THE YULE MAXIMUM LIKELIHOOD CASE ** C ****************************************************** C IF(ICOM.EQ.'YULE')THEN IF(IHARG(1).EQ.'CHI ')GOTO9000 IF(IHARG(1).EQ.'CHIS')GOTO9000 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MAXI'.AND. 1 IHARG(2).EQ.'LIKE'.AND.IHARG(3).EQ.'ESTI')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MAXI'.AND. 1 IHARG(2).EQ.'LIKE')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MLE ')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='YUML' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED MAY 2006 C ****************************************************** C ** TREAT THE ZETA MAXIMUM LIKELIHOOD CASE ** C ****************************************************** C IF(ICOM.EQ.'ZETA')THEN IF(IHARG(1).EQ.'CHI ')GOTO9000 IF(IHARG(1).EQ.'CHIS')GOTO9000 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MAXI'.AND. 1 IHARG(2).EQ.'LIKE'.AND.IHARG(3).EQ.'ESTI')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MAXI'.AND. 1 IHARG(2).EQ.'LIKE')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MLE ')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='ZEML' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED APRIL 2004 C ****************************************************** C ** TREAT THE WARING MAXIMUM LIKELIHOOD CASE ** C ****************************************************** C IF(ICOM.EQ.'WARI')THEN IF(IHARG(1).EQ.'CHI ')GOTO9000 IF(IHARG(1).EQ.'CHIS')GOTO9000 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MAXI'.AND. 1 IHARG(2).EQ.'LIKE'.AND.IHARG(3).EQ.'ESTI')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MAXI'.AND. 1 IHARG(2).EQ.'LIKE')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MLE ')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='WAML' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED MAY 2006 C ******************************************************* C ** TREAT THE BETA GEOMETRIC MAXIMUM LIKELIHOOD CASE ** C ******************************************************* C IF(ICOM.EQ.'BETA'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'GEOM')THEN IF(IHARG(2).EQ.'CHI ')GOTO9000 IF(IHARG(2).EQ.'CHIS')GOTO9000 IF(NUMARG.GE.4.AND.IHARG(2).EQ.'MAXI'.AND. 1 IHARG(3).EQ.'LIKE'.AND.IHARG(4).EQ.'ESTI')THEN ISHIFT=4 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.3.AND.IHARG(2).EQ.'MAXI'.AND. 1 IHARG(3).EQ.'LIKE')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.2.AND.IHARG(2).EQ.'MLE ')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='BGML' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED MAY 2006 C ****************************************************** C ** TREAT THE BOREL-TANNER MAXIMUM LIKELIHOOD CASE ** C ****************************************************** C IF(ICOM.EQ.'BORE'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'TANN')THEN IF(IHARG(2).EQ.'CHI ')GOTO9000 IF(IHARG(2).EQ.'CHIS')GOTO9000 IF(NUMARG.GE.4.AND.IHARG(2).EQ.'MAXI'.AND. 1 IHARG(3).EQ.'LIKE'.AND.IHARG(4).EQ.'ESTI')THEN ISHIFT=4 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.3.AND.IHARG(2).EQ.'MAXI'.AND. 1 IHARG(3).EQ.'LIKE')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.2.AND.IHARG(2).EQ.'MLE ')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='BTML' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED JUNE 2006 C ********************************************************** C ** TREAT THE LAGRANGE-POISSON MAXIMUM LIKELIHOOD CASE ** C ********************************************************** C IF(ICOM.EQ.'LAGR'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'POIS')THEN IF(IHARG(2).EQ.'CHI ')GOTO9000 IF(IHARG(2).EQ.'CHIS')GOTO9000 IF(NUMARG.GE.4.AND.IHARG(2).EQ.'MAXI'.AND. 1 IHARG(3).EQ.'LIKE'.AND.IHARG(4).EQ.'ESTI')THEN ISHIFT=4 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.3.AND.IHARG(2).EQ.'MAXI'.AND. 1 IHARG(3).EQ.'LIKE')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.2.AND.IHARG(2).EQ.'MLE ')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='LPML' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C IF(ICOM.EQ.'CONS'.AND.NUMARG.GE.2.AND.IHARG(1).EQ.'GENE'.AND. 1 IHARG(2).EQ.'POIS')THEN IF(IHARG(3).EQ.'CHI ')GOTO9000 IF(IHARG(3).EQ.'CHIS')GOTO9000 IF(NUMARG.GE.5.AND.IHARG(3).EQ.'MAXI'.AND. 1 IHARG(4).EQ.'LIKE'.AND.IHARG(5).EQ.'ESTI')THEN ISHIFT=5 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.4.AND.IHARG(3).EQ.'MAXI'.AND. 1 IHARG(4).EQ.'LIKE')THEN ISHIFT=4 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.3.AND.IHARG(3).EQ.'MLE ')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='LPML' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED KATZ 2006 C ********************************************************** C ** TREAT THE LAGRANGE KATZ MAXIMUM LIKELIHOOD CASE ** C ********************************************************** C IF(ICOM.EQ.'LAGR'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'KATZ')THEN IF(IHARG(2).EQ.'CHI ')GOTO9000 IF(IHARG(2).EQ.'CHIS')GOTO9000 IF(NUMARG.GE.4.AND.IHARG(2).EQ.'MAXI'.AND. 1 IHARG(3).EQ.'LIKE'.AND.IHARG(4).EQ.'ESTI')THEN ISHIFT=4 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.3.AND.IHARG(2).EQ.'MAXI'.AND. 1 IHARG(3).EQ.'LIKE')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.2.AND.IHARG(2).EQ.'MLE ')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='LKML' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED JUNE 2006 C ****************************************************** C ** TREAT THE LOST GAMES MAXIMUM LIKELIHOOD CASE ** C ****************************************************** C IF(ICOM.EQ.'LOST'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'GAME')THEN IF(IHARG(2).EQ.'CHI ')GOTO9000 IF(IHARG(2).EQ.'CHIS')GOTO9000 IF(NUMARG.GE.4.AND.IHARG(2).EQ.'MAXI'.AND. 1 IHARG(3).EQ.'LIKE'.AND.IHARG(4).EQ.'ESTI')THEN ISHIFT=4 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.3.AND.IHARG(2).EQ.'MAXI'.AND. 1 IHARG(3).EQ.'LIKE')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.2.AND.IHARG(2).EQ.'MLE ')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='LSML' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED DECEMBER 2006 C *************************************************************** C ** TREAT THE GENERALIZED LOST GAMES MAXIMUM LIKELIHOOD CASE ** C *************************************************************** C IF(ICOM.EQ.'GENE'.AND.NUMARG.GE.2.AND.IHARG(1).EQ.'LOST'.AND. 1 IHARG(2).EQ.'GAME')THEN IF(IHARG(3).EQ.'CHI ')GOTO9000 IF(IHARG(3).EQ.'CHIS')GOTO9000 IF(NUMARG.GE.5.AND.IHARG(3).EQ.'MAXI'.AND. 1 IHARG(4).EQ.'LIKE'.AND.IHARG(5).EQ.'ESTI')THEN ISHIFT=5 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.4.AND.IHARG(3).EQ.'MAXI'.AND. 1 IHARG(4).EQ.'LIKE')THEN ISHIFT=4 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.3.AND.IHARG(3).EQ.'MLE ')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='GGML' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED JUNE 2006 C ********************************************************** C ** TREAT THE POLYA-AEPPLI MAXIMUM LIKELIHOOD CASE ** C ********************************************************** C IF(ICOM.EQ.'POLY'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'AEPP')THEN IF(IHARG(2).EQ.'CHI ')GOTO9000 IF(IHARG(2).EQ.'CHIS')GOTO9000 IF(IHARG(2).EQ.'KS ')GOTO9000 IF(IHARG(2).EQ.'PPCC')GOTO9000 IF(NUMARG.GE.4.AND.IHARG(2).EQ.'MAXI'.AND. 1 IHARG(3).EQ.'LIKE'.AND.IHARG(4).EQ.'ESTI')THEN ISHIFT=4 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.3.AND.IHARG(2).EQ.'MAXI'.AND. 1 IHARG(3).EQ.'LIKE')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.2.AND.IHARG(2).EQ.'MLE ')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='AEML' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED JUNE 2006 C ********************************************************** C ** TREAT THE LOG-BETA MAXIMUM LIKELIHOOD CASE ** C ********************************************************** C IF(ICOM.EQ.'LOG '.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'BETA')THEN IF(IHARG(2).EQ.'CHI ')GOTO9000 IF(IHARG(2).EQ.'CHIS')GOTO9000 IF(IHARG(2).EQ.'KOLM')GOTO9000 IF(NUMARG.GE.4.AND.IHARG(2).EQ.'MAXI'.AND. 1 IHARG(3).EQ.'LIKE'.AND.IHARG(4).EQ.'ESTI')THEN ISHIFT=4 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.3.AND.IHARG(2).EQ.'MAXI'.AND. 1 IHARG(3).EQ.'LIKE')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.2.AND.IHARG(2).EQ.'MLE ')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='LBML' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C C CCCCC THE FOLLOWING SECTION WAS ADDED JUNE 2004 C ****************************************************** C ** TREAT THE RAYLEIGH MAXIMUM LIKELIHOOD CASE ** C ****************************************************** C IF(ICOM.EQ.'RAYL')THEN IF(IHARG(1).EQ.'CHI ')GOTO9000 IF(IHARG(1).EQ.'CHIS')GOTO9000 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MAXI'.AND. 1 IHARG(2).EQ.'LIKE'.AND.IHARG(3).EQ.'ESTI')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MAXI'.AND. 1 IHARG(2).EQ.'LIKE')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MLE ')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='RAYL' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED JUNE 2004 C ****************************************************** C ** TREAT THE MAXWELL MAXIMUM LIKELIHOOD CASE ** C ****************************************************** C IF(ICOM.EQ.'MAXW')THEN IF(IHARG(1).EQ.'CHI ')GOTO9000 IF(IHARG(1).EQ.'CHIS')GOTO9000 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MAXI'.AND. 1 IHARG(2).EQ.'LIKE'.AND.IHARG(3).EQ.'ESTI')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MAXI'.AND. 1 IHARG(2).EQ.'LIKE')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MLE ')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='MAXW' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED NOVEMBER 2003. C ****************************************************** C ** TREAT THE GENERALIZED PARETO MAXIMUM LIKELIHOOD ** C ** CASE ** C ****************************************************** C IF(ICOM.EQ.'GENE'.AND.IHARG(1).EQ.'PARE')THEN IF(IHARG(2).EQ.'CHI ')GOTO9000 IF(IHARG(2).EQ.'CHIS')GOTO9000 IF(NUMARG.GE.4.AND.IHARG(2).EQ.'MAXI'.AND. 1 IHARG(3).EQ.'LIKE'.AND.IHARG(4).EQ.'ESTI')THEN ISHIFT=4 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.3.AND.IHARG(2).EQ.'MAXI'.AND. 1 IHARG(3).EQ.'LIKE')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.2.AND.IHARG(2).EQ.'MLE ')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='GPML' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED FEBRUARY 2006. C ****************************************************** C ** TREAT THE GENERALIZED LOGISTIC MAXIMUM ** C ** LIKELIHOOD CASE ** C ****************************************************** C IF(ICOM.EQ.'GENE'.AND.IHARG(1).EQ.'LOGI')THEN IF(IHARG(2).EQ.'CHI ')GOTO9000 IF(IHARG(2).EQ.'CHIS')GOTO9000 IF(NUMARG.GE.4.AND.IHARG(2).EQ.'MAXI'.AND. 1 IHARG(3).EQ.'LIKE'.AND.IHARG(4).EQ.'ESTI')THEN ISHIFT=4 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.3.AND.IHARG(2).EQ.'MAXI'.AND. 1 IHARG(3).EQ.'LIKE')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.2.AND.IHARG(2).EQ.'MLE ')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='GLML' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED MAY 1998 C ************************************************ C ** TREAT THE DEHAAN CASE (GENERALIZED PARETO ** C ************************************************ C IF(ICOM.EQ.'DEHA')THEN IF(NUMARG.GE.3.AND.IHARG(1).EQ.'GENE'.AND. 1 IHARG(2).EQ.'PARE'.AND.IHARG(3).EQ.'ESTI')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.2.AND.IHARG(1).EQ.'GENE'.AND. 1 IHARG(2).EQ.'PARE')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.1.AND.IHARG(1).EQ.'ESTI')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='GPDE' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED MAY 1998 C ************************************************ C ** TREAT THE CME CASE (GENERALIZED PARETO ** C ************************************************ C IF(ICOM.EQ.'CME ')THEN IF(NUMARG.GE.3.AND.IHARG(1).EQ.'GENE'.AND. 1 IHARG(2).EQ.'PARE'.AND.IHARG(3).EQ.'ESTI')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.2.AND.IHARG(1).EQ.'GENE'.AND. 1 IHARG(2).EQ.'PARE')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.1.AND.IHARG(1).EQ.'ESTI')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C C CHECK FOR NAME CONFLICT WITH CME PLOT C IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PLOT')GOTO9000 C ICASAN='GPCM' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED JULY 2003 C ************************************************ C ** TREAT THE JOHNSON SB MOMENTS CASE ** C ** TREAT THE JOHNSON SU MOMENTS CASE ** C ** TREAT THE JOHNSON SB PERCENTILE CASE ** C ** TREAT THE JOHNSON SU PERCENTILE CASE ** C ************************************************ C IF(ICOM.EQ.'JOHN')THEN IF(NUMARG.GE.2.AND.IHARG(1).EQ.'SB '.AND. 1 IHARG(2).EQ.'MOME')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='JOSB' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'SU '.AND. 1 IHARG(2).EQ.'MOME')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='JOSU' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ELSEIF(NUMARG.GE.3.AND.IHARG(1).EQ.'SB '.AND. 1 IHARG(2).EQ.'PERC'.AND.IHARG(3).EQ.'ESTI')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='JOHN' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'SB '.AND. 1 IHARG(2).EQ.'PERC')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='JOHN' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ELSEIF(NUMARG.GE.3.AND.IHARG(1).EQ.'SU '.AND. 1 IHARG(2).EQ.'PERC'.AND.IHARG(3).EQ.'ESTI')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='JOHN' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'SU '.AND. 1 IHARG(2).EQ.'PERC')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='JOHN' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'PERC'.AND. 1 IHARG(2).EQ.'ESTI')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='JOHN' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'PERC')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='JOHN' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED OCTOBER 2003 C ************************************************ C ** TREAT THE UNIFORM MOMENTS CASE ** C ************************************************ C IF(ICOM.EQ.'UNIF')THEN IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MOME')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='UNIF' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'MLE ')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='UNIF' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ELSEIF(NUMARG.GE.2.AND.IHARG(1).EQ.'MAXI'.AND. 1 IHARG(2).EQ.'LIKE')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='UNIF' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED MARCH 2004 C ****************************************************** C ** TREAT THE FATIGUE LIFE MAXIMUM LIKELIHOOD ** C ** CASE ** C ****************************************************** C IF(ICOM.EQ.'FATI'.AND.IHARG(1).EQ.'LIFE')THEN IF(IHARG(2).EQ.'CHI ')GOTO9000 IF(IHARG(2).EQ.'CHIS')GOTO9000 IF(NUMARG.GE.4.AND.IHARG(2).EQ.'MAXI'.AND. 1 IHARG(3).EQ.'LIKE'.AND.IHARG(4).EQ.'ESTI')THEN ISHIFT=4 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.3.AND.IHARG(2).EQ.'MAXI'.AND. 1 IHARG(3).EQ.'LIKE')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.2.AND.IHARG(2).EQ.'MLE ')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='FLML' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED MARCH 2004 C ****************************************************** C ** TREAT THE FOLDED NORMAL MAXIMUM LIKELIHOOD ** C ** CASE ** C ****************************************************** C IF(ICOM.EQ.'FOLD'.AND.IHARG(1).EQ.'NORM')THEN IF(IHARG(2).EQ.'CHI ')GOTO9000 IF(IHARG(2).EQ.'CHIS')GOTO9000 IF(NUMARG.GE.4.AND.IHARG(2).EQ.'MAXI'.AND. 1 IHARG(3).EQ.'LIKE'.AND.IHARG(4).EQ.'ESTI')THEN ISHIFT=4 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.3.AND.IHARG(2).EQ.'MAXI'.AND. 1 IHARG(3).EQ.'LIKE')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.2.AND.IHARG(2).EQ.'MLE ')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='FNML' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED MARCH 2004 C ****************************************************** C ** TREAT THE LOGARITHMIC SERIES MAXIMUM LIKELIHOOD ** C ** CASE ** C ****************************************************** C IF(ICOM.EQ.'LOGA'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'SERI')THEN IF(IHARG(1).EQ.'CHI ')GOTO9000 IF(IHARG(1).EQ.'CHIS')GOTO9000 IF(NUMARG.GE.4.AND.IHARG(2).EQ.'MAXI'.AND. 1 IHARG(3).EQ.'LIKE'.AND.IHARG(4).EQ.'ESTI')THEN ISHIFT=4 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.3.AND.IHARG(2).EQ.'MAXI'.AND. 1 IHARG(3).EQ.'LIKE')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.2.AND.IHARG(2).EQ.'MLE ')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='DLML' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED MARCH 2004 C ****************************************************** C ** TREAT THE NEGATIVE BINOMIAL MAXIMUM LIKELIHOOD ** C ** CASE ** C ****************************************************** C IF(ICOM.EQ.'NEGA'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'BINO')THEN IF(IHARG(1).EQ.'CHI ')GOTO9000 IF(IHARG(1).EQ.'CHIS')GOTO9000 IF(NUMARG.GE.4.AND.IHARG(2).EQ.'MAXI'.AND. 1 IHARG(3).EQ.'LIKE'.AND.IHARG(4).EQ.'ESTI')THEN ISHIFT=4 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.3.AND.IHARG(2).EQ.'MAXI'.AND. 1 IHARG(3).EQ.'LIKE')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.2.AND.IHARG(2).EQ.'MLE ')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='NBML' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED MARCH 2004 C ************************************************** C ** TREAT THE GEOMETRIC MAXIMUM LIKELIHOOD CASE ** C ************************************************** C IF(ICOM.EQ.'GEOM')THEN IF(IHARG(1).EQ.'CHI ')GOTO9000 IF(IHARG(1).EQ.'CHIS')GOTO9000 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'MAXI'.AND. 1 IHARG(2).EQ.'LIKE'.AND.IHARG(3).EQ.'ESTI')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MAXI'.AND. 1 IHARG(2).EQ.'LIKE')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MLE ')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='GMML' CALL DPMLWE(XTEMP1,MAXNXT, 1 ICAPSW, 1 MINMAX,ISEED, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED APRIL 1998 C ************************************************ C ** TREAT THE A BASIS TOLERANCE LIMIT CASE ** C ************************************************ C IF(ICOM.EQ.'A ')THEN ICASDI='NORM' IF(NUMARG.GE.1.AND.IHARG(1).EQ.'BASI')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.1.AND.IHARG(1).EQ.'NORM')THEN ICASDI='NORM' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'WEIB')THEN ICASDI='WEIB' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'LOGN')THEN ICASDI='LOGN' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'NONP')THEN ICASDI='NONP' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.2.AND.IHARG(1).EQ.'TOLE'.AND. 1 IHARG(2).EQ.'LIMI')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'TOLE')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='ABAS' CALL DPABAS(XTEMP1,MAXNXT, 1 ICASAN,ICASDI, 1 IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF IF(ICOM.EQ.'A-BA'.OR.ICOM.EQ.'ABAS')THEN ICASDI='NORM' IF(NUMARG.GE.1.AND.IHARG(1).EQ.'NORM')THEN ICASDI='NORM' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'WEIB')THEN ICASDI='WEIB' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'LOGN')THEN ICASDI='LOGN' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'NONP')THEN ICASDI='NONP' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.2.AND.IHARG(1).EQ.'TOLE'.AND. 1 IHARG(2).EQ.'LIMI')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'TOLE')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='ABAS' CALL DPABAS(XTEMP1,MAXNXT, 1 ICASAN,ICASDI, 1 IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED APRIL 1998 C ************************************************ C ** TREAT THE B BASIS TOLERANCE LIMIT CASE ** C ************************************************ C IF(ICOM.EQ.'B ')THEN ICASDI='NORM' IF(NUMARG.GE.1.AND.IHARG(1).EQ.'BASI')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.1.AND.IHARG(1).EQ.'NORM')THEN ICASDI='NORM' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'WEIB')THEN ICASDI='WEIB' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'LOGN')THEN ICASDI='LOGN' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'NONP')THEN ICASDI='NONP' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.2.AND.IHARG(1).EQ.'TOLE'.AND. 1 IHARG(2).EQ.'LIMI')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'TOLE')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='BBAS' CALL DPABAS(XTEMP1,MAXNXT, 1 ICASAN,ICASDI, 1 IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF IF(ICOM.EQ.'B-BA'.OR.ICOM.EQ.'BBAS')THEN ICASDI='NORM' IF(NUMARG.GE.1.AND.IHARG(1).EQ.'NORM')THEN ICASDI='NORM' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'WEIB')THEN ICASDI='WEIB' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'LOGN')THEN ICASDI='LOGN' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'NONP')THEN ICASDI='NONP' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.2.AND.IHARG(1).EQ.'TOLE'.AND. 1 IHARG(2).EQ.'LIMI')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'TOLE')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF C ICASAN='BBAS' CALL DPABAS(XTEMP1,MAXNXT, 1 ICASAN,ICASDI, 1 IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C C ******************************************* C ** TREAT THE (2**K) DEX FIT CASE ** C ** TREAT THE YATES ANALYSIS CASE ** C ******************************************* C IF(ICOM.EQ.'2**K')GOTO3400 IF(ICOM.EQ.'DEX'.AND.NUMARG.GE.1.AND. 1IHARG(1).EQ.'FIT')GOTO3400 IF(ICOM.EQ.'YATE')GOTO3400 GOTO3499 C 3400 CONTINUE CCCCC THE FOLLOWING 4 LINES WERE INSERTED NOVEMBER 1989 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'CUTO'.AND. 1IHARG2(2).EQ.'FF')GOTO3499 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'OUTP'.AND. 1IHARG2(1).EQ.'UT')GOTO3499 CCCCC THE FOLLOWING 2 LINES WERE INSERTED FEBRUARY 1995 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PHD ')GOTO3499 ICASAN='DEXF' CALL DPYATE(ICASAN, 1ICAPSW, 1IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 3499 CONTINUE C C ******************************************************** C ** TREAT THE ... MAXIMUM LIKELIHOOD ESTIMATION CASE ** C ******************************************************** C IF(NUMARG.GE.2.AND.ICOM.EQ.'MAXI'.AND. 1IHARG(1).EQ.'LIKE'.AND.IHARG(2).EQ.'ESTI')GOTO4100 DO4110I=3,6 IM1=I-1 IM2=I-2 IF(NUMARG.GE.2.AND.IHARG(IM2).EQ.'MAXI'.AND. 1IHARG(IM1).EQ.'LIKE'.AND.IHARG(I).EQ.'ESTI')GOTO4100 4110 CONTINUE GOTO4199 C 4100 CONTINUE ICASAN='MLE' CALL DPMLE(ICASML,ISEED,ILOCES, 1IBUGA3,IBUGQ,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 GOTO9000 C 4199 CONTINUE C C ******************************* C ** TREAT THE TABULATE CASE ** C ******************************* C IF(ICOM.EQ.'TABU')GOTO4200 IF(ICOM.EQ.'TAB')GOTO4200 GOTO4299 C 4200 CONTINUE ICASAN='TABU' CALL DPTABU(XTEMP1,XTEMP2,MAXNXT, 1ISEED,ICAPSW, 1IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 4299 CONTINUE C CCCCC THE FOLLOWING SECTION WAS ADDED NOVEMBER 1989 C ************************************* C ** TREAT THE CROSS-TABULATE CASE ** C ************************************* C IF(ICOM.EQ.'CROS')GOTO4300 GOTO4399 C 4300 CONTINUE IF(NUMARG.GE.1.AND.IHARG(1).EQ.'TABU')GOTO4310 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'TAB')GOTO4310 GOTO4399 4310 CONTINUE ICASAN='CRTA' CCCCC ISHIFT=1 CCCCC CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, CCCCC1IBUGA2,IERROR) CALL DPCRTA(TEMP,XTEMP1,XTEMP2,MAXNXT, 1ISEED, 1ICAPSW, 1IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 4399 CONTINUE C CCCCC THE FOLLOWING SECTION WAS ADDED MAY 1988 C ********************************************** C ** TREAT THE EXPERIMENTAL SIMULATION CASE ** C ** (SYNONYM = RUN) ** C ********************************************** C IF(ICOM.EQ.'EXPE')GOTO4400 IF(ICOM.EQ.'RUN')GOTO4400 GOTO4499 C 4400 CONTINUE ICASAN='EXSI' CALL DPEXSI(ISEED,XTEMP1,XTEMP2,MAXNXT,ICASAN, 1IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 4499 CONTINUE C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1990 C ****************************************** C ** TREAT THE CAPABILITY ANALYSIS CASE ** C ****************************************** C IF(ICOM.EQ.'CAPA')GOTO4500 IF(ICOM.EQ.'CAPA'.AND.ICOM2.EQ.'BILI')GOTO4500 IF(ICOM.EQ.'CP ')GOTO4500 IF(ICOM.EQ.'CPK ')GOTO4500 GOTO4599 C 4500 CONTINUE ICASAN='CAPA' IF(NUMARG.GE.1.AND.IHARG(1).EQ.'ANAL')GOTO4510 GOTO4519 4510 CONTINUE ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1IBUGA2,IERROR) 4519 CONTINUE CALL DPCAAN(XTEMP1,XTEMP2,MAXNXT, 1IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 4599 CONTINUE C C ******************************************* C ** TREAT THE (YATES) PHD ANALYSIS CASE ** C ******************************************* C CCCCC FEBRUARY 1995. RENAME PHD TO DEX PHD IN ORDER TO ALLOW CCCCC FUTURE ADDITION OF A MORE GENERAL PHD COMMAND. CCCCC IF(ICOM.EQ.'PHD ')GOTO4600 IF(ICOM.EQ.'DEX ')THEN IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PHD ')GOTO4600 GOTO4699 ENDIF IF(ICOM.EQ.'PHD ')THEN IF(NUMARG.GE.1.AND.IHARG(1).EQ.'DEX ')GOTO4600 GOTO4699 ENDIF GOTO4699 C 4600 CONTINUE ICASAN='PHD ' CALL DPPHD(ICASAN, 1IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 4699 CONTINUE C CCCCC THE FOLLOWING SECTION WAS ADDED MARCH 1994 C ****************************** C ** TREAT THE DDS CASE ** C ****************************** C IF(ICOM.EQ.'DDS ')THEN ICASAN='DDS ' CALL DPDDS(XTEMP1,XTEMP2,MAXNXT, 1 IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED MAY 1999 C ****************************** C ** TREAT THE ARMA CASE ** C ****************************** C IF(ICOM.EQ.'ARMA'.OR.ICOM.EQ.'ARIM')THEN ICASAN='ARMA' IF(NUMARG.GE.1.AND.IHARG(1).EQ.'FIT ')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.1.AND.IHARG(1).EQ.'MODE')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ENDIF IF(NUMARG.GE.1.AND.IHARG(1).EQ.'FORE')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='ARFC' ENDIF CALL DPARMA(XTEMP1,XTEMP2,MAXNXT, 1 ISUBRO,IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED JULY 1995 CCCCC THE FOLLOWING SECTION WAS ACTIVATED SEPTEMBER 1997 C ************************************************ C ** TREAT THE ... RECIPE ANALYSIS CASE ** C ** RECIPE = REGRESSION CONFIDENCE INTERVALS ** C ** ON PERCENTILES ** C ************************************************ C CCCCC ACTIVATE COMMAND AUGUST 1997 IF(NUMARG.GE.1.AND.ICOM.EQ.'RECI'.AND.IHARG(1).NE.'SIMC')THEN IF(NUMARG.GE.2.AND.IHARG(1).EQ.'PROB'.AND.IHARG(2).EQ.'PLOT') 1 GOTO4799 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'PPCC'.AND.IHARG(2).EQ.'PLOT') 1 GOTO4799 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'KOLM'.AND.IHARG(2).EQ.'SMIR') 1 GOTO4799 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'CHI '.AND.IHARG(2).EQ.'SQUA') 1 GOTO4799 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'CHI ') 1 GOTO4799 ICASAN='RECI' CALL DPRECI(ISEED,IBUGA2,IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO, 1 IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C 4799 CONTINUE C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 1997 C ************************************************ C ** TREAT THE ... SIMCOV ANALYSIS CASE ** C ** USED PRIOR TO A RECIPE ANALYIS TO ** C ** DETERMINE IF SATTERTHWAITE APPROXIMATION ** C ** WILL BE ADEQUATE ** C ************************************************ C IF(NUMARG.GE.1.AND.ICOM.EQ.'RECI'.AND.IHARG(1).EQ.'SIMC')THEN ICOM='SIMC' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) ICASAN='SIMC' CALL SIMCOV(ISEED,IBUGA2,IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO, 1 IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ELSEIF(NUMARG.GE.1.AND.ICOM.EQ.'SIMC')THEN ICASAN='SIMC' CALL SIMCOV(ISEED,IBUGA2,IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO, 1 IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF C CCCCC THE FOLLOWING SECTION WAS ADDED MARCH 1999 C *************************************************** C ** TREAT THE SINGLE SAMPLE ACCEPTANCE PLAN CASE ** C *************************************************** C IF(ICOM.EQ.'SING')THEN IF(NUMARG.GE.3.AND.IHARG(1).EQ.'SAMP'.AND. 1 IHARG(2).EQ.'ACCE'.AND.IHARG(3).EQ.'PLAN')THEN ISHIFT=3 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) IFOUND='YES' ENDIF IF(NUMARG.GE.2.AND.IHARG(1).EQ.'SAMP'.AND. 1 IHARG(2).EQ.'ACCE')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) IFOUND='YES' ENDIF IF(NUMARG.GE.2.AND.IHARG(1).EQ.'SAMP'.AND. 1 IHARG(2).EQ.'PLAN')THEN ISHIFT=2 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) IFOUND='YES' ENDIF IF(NUMARG.GE.1.AND.IHARG(1).EQ.'SAMP')THEN ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGA2,IERROR) IFOUND='YES' ENDIF C ICASAN='SSNC' IF(IFOUND.EQ.'YES')THEN CALL DPACSA(XTEMP1,MAXNXT, 1 ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 ENDIF ENDIF C C C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGAN.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF MAINAN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IBUGAN,IBUGA2,IBUGA3 9013 FORMAT('IBUGAN,IBUGA2,IBUGA3 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)IBUGCO,IBUGEV,IBUGQ 9015 FORMAT('IBUGCO,IBUGEV,IBUGQ = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)IFTEXP 9016 FORMAT('IFTEXP = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9017)IANGLU 9017 FORMAT('IANGLU = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9018)ICASAN,ISEED,ANOPL1,ANOPL2 9018 FORMAT('ICASAN,ISEED,ANOPL1,ANOPL2 = ',A4,I8,E15.7,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9020)IFOUND,IERROR 9020 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9027)ICOM,ICOM2 9027 FORMAT('ICOM,ICOM2 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9028)NUMARG 9028 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') DO9030I=1,NUMARG WRITE(ICOUT,9031)I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I) 9031 FORMAT('I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I) = ', 1I8,2X,A4,2X,A4,2X,A4,2X,I8,E15.7) CALL DPWRST('XXX','BUG ') 9030 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE MAINDG(IBUGDG,IBUGD2,IBUGU2,ISUBRO, 1DEFANG,ANGLE,IDEANU,IANGLU,IREPCH, CCCCC ADD FOLLOWING LINE SEPTEMBER 1998. 1IMPSW, 1ICAPSW, 1IFOUND,IERROR) C C PURPOSE--THIS IS SUBROUTING MAINDG. C (THE TD AT THE END OF MAINDG STANDS FOR DIAGRAMMATIC C THIS SUBROUTINE SEARCHES FOR AND EXECUTES DIAGRAMMATIC GRAPHICS C C THE DIAGRAMMATIC GRAPHICS COMMANDS SEARCHED FOR BY MAINDG ARE AS C C COPY A NUMBER C ERASE NO ENTRY C RING BELL A NUMBER C C TEXT A STRING OF TEXT C FONT A FONT NAME C CASE UPPER OR LOWER C HEIGHT A NUMBER C WIDTH A NUMBER C HW 2 NUMBERS C JUSTIFICATION LEFT, CENTER, OR RIGHT C ANGLE A NUMBER C ANGLE UNITS RADIANS, DEGREES, OR GR C CRLF (CARRIAGE RETURN/LINE FEED) ON OR OFF C ... MARGIN A NUMBER C CROSS-HAIR 0 OR 2 PARAMTER NAMES C C MOVE 2, 4, 6, 8, ... NUMBERS C MOVEDATA 2, 4, 6, 8, ... NUMBERS C DRAW 2, 4, 6, 8, ... NUMBERS C DRAWDATA 2, 4, 6, 8, ... NUMBERS C C POINT 0, 2, 4, 6, ... NUMBERS C ARROW 2, 4, 6, 8, ... NUMBERS C BOX 2, 4, 6, 8, ... NUMBERS C TRIANGLE 4, 6, 8, ... NUMBERS C HEXAGON 2, 4, 6, 8, ... NUMBERS C CIRCLE 2, 4, 6, 8, ... NUMBERS C SEMI-CIRCLE 2, 4, 6, 8, ... NUMBERS C ELLIPSE 4, 6, 8, ... NUMBERS C AMPLIFIER 2, 4, 6, 8, ... NUMBE C DIAMOND 4, 6, 8, ... NUMBERS C OVAL 4, 6, 8, ... NUMBERS C ARC 4, 6, 8, ... NUMBERS C C RESISTOR 2, 4, ... NUMBERS C CAPACITOR 2, 4, 6, 8, ... NUMBERS C GROUND 2, 4, 6, 8, ... NUMBERS C INDUCTOR 2, 4, 6, 8, ... NUMBERS C C AND 2, 4, 6, 8, ... NUMBERS C OR 2, 4, 6, 8, ... NUMBERS C NAND 2, 4, 6, 8, ... NUMBERS C NOR 2, 4, 6, 8, ... NUMBERS C C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-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--82.6 C ORIGINAL VERSION--APRIL 1981. C UPDATED --MAY 1981. C UPDATED --AUGUST 1981. C UPDATED --SEPTEMBER 1981. C UPDATED --MAY 1982. C UPDATED --NOVEMBER 1982. C UPDATED --DECEMBER 1988. AVOID POINT & POINCARE PLOT CONFLICT C UPDATED --AUGUST 1992. AVOID SYMBOL & SYMBOL PLOT CONFLICT C UPDATED --AUGUST 1992. AVOID NAME CONFLICTS WITH BOX C UPDATED --OCTOBER 1992. BOX BORDER SETTINGS C UPDATED --NOVEMBER 1992. MOVEDATA COMMAND C UPDATED --MARCH 1993. ARGUMENTS TO DPBX C UPDATED --SEPTEMBER 1993. ALLOW LOWER CASE TEXT C UPDATED --FEBRUARY 1994. FIX CAPABILITY CONFLICT C UPDATED --MAY 1994. DISCONNECT (TEKT. HARD-) COPY COMMAND C UPDATED --SEPTEMBER 1994. DRAWDATA COMMAND C UPDATED --OCTOBER 1995. NAME CONFLICT WITH ANGLIT PROB C PLOT AND ANGLE COMMANDS C UPDATED --MARCH 1997. SUPPORT FOR DEVICE FONT (ALAN) C AUGMENT ARGUMENT LIST FOR C MOST COMMANDS C UPDATED --JULY 1997. ELLIPSE DATA COMMAND (ALAN) C UPDATED --JULY 1997. DATA COMMAND (ALAN) C FOR DIAGRAMMATIC GRAPHICS C COMMANDS THAT DRAW FIGURES C UPDATED --JULY 1997. POLGON COMMAND (ALAN) C UPDATED --JANUARY 1998. NAME CONFLICT WITH SEMI- C CIRCLE AND SEMICIRCULAR C PROB PLOT AND PPCC PLOT C UPDATED --AUGUST 1998. DRAW C UPDATED --AUGUST 1998. MOVE C UPDATED --SEPTEMBER 1998. ADD IMPSW TO ARGUMENT LIST C (USED TO SET IMPSW2) C UPDATED --SEPTEMBER 1999. ARGUMENT LIST TO DPTEXT C UPDATED --SEPTEMBER 2002. ICAPSW C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IMPSW CHARACTER*4 ICAPSW CHARACTER*4 IDEANU CHARACTER*4 IANGLU C CHARACTER*1 IREPCH C CHARACTER*4 IBUGDG CHARACTER*4 IBUGD2 CHARACTER*4 IBUGU2 CHARACTER*4 ISUBRO CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHOLD C CHARACTER*4 ITEXCV C CCCCC THE FOLLOWING LINE WAS ADDED NOVEMBER 1992 CCCCC AND THEN MODIFIED AUGUST 1998. CHARACTER*4 UNITSW CHARACTER*4 X1UNIT CHARACTER*4 X2UNIT CHARACTER*4 Y1UNIT CHARACTER*4 Y2UNIT C DIMENSION PRV(6) DIMENSION PDIARV(4) DIMENSION ITEXCV(10) DIMENSION PTEXRV(5) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCOHK.INC' INCLUDE 'DPCOPC.INC' INCLUDE 'DPCODA.INC' INCLUDE 'DPCOBE.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IBUGG4=IBUGU2 ISUBG4=ISUBRO C PXSTAR=PXEND PYSTAR=PYEND C CCCCC ADD FOLLOWING LINE SEPTEMBER 1998. IMPSW2=IMPSW C IF(IBUGDG.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('AT THE BEGINNING OF MAINDG--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IBUGDG,IBUGD2,ISUBRO 53 FORMAT('IBUGDG,IBUGD2,ISUBRO = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)IDEFAU,ITEXAU 54 FORMAT('IDEFAU,ITEXAU = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,59)PXSTAR,PYSTAR,PXEND,PYEND 59 FORMAT('PXSTAR,PYSTAR,PXEND,PYEND = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,60)DEFANG,ANGLE,IDEANU,IANGLU 60 FORMAT('DEFANG,ANGLE,IDEANU,IANGLU = ',2E15.7,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,61)IREPCH 61 FORMAT('IREPCH = ',A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,65)IFOUND,IERROR 65 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,67)ICOM,ICOM2 67 FORMAT('ICOM,ICOM2 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,68)NUMARG 68 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') DO70I=1,NUMARG WRITE(ICOUT,71)I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I) 71 FORMAT('I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I) = ', 1I8,2X,A4,2X,A4,2X,A4,2X,I8,E15.7) CALL DPWRST('XXX','BUG ') 70 CONTINUE WRITE(ICOUT,72)IDMANU(1) 72 FORMAT('IDMANU(1) = ',A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C IFOUND='NO' IERROR='NO' C C *************************** C ** TREAT THE COPY CASE ** C *************************** C CCCCC THE FOLLOWING SECTION WAS COMMENTED OUT MAY 1994. CCCCC IN DEFERENCE TO THE COPY FILE COMMAND MAY 1994 CCCCC IF(ICOM.EQ.'COPY')GOTO100 CCCCC IF(ICOM.EQ.'MAKE')GOTO100 CCCCC GOTO199 C CC100 CONTINUE CCCCC CALL DPCOPY(IHARG,IARGT,IARG,NUMARG, CCCCC1NUMDEV, CCCCC1IDMANU,IDMODE,IDMOD2,IDMOD3, CCCCC1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, CCCCC ADD FOLLOWING LINE MARCH 1997. CCCCC1IDFONT, CCCCC1IBUGD2,ISUBRO,IFOUND,IERROR) CCCCC IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C CC199 CONTINUE C C ******************************* C ** TREAT THE ERASE CASE ** C ** TREAT THE PAGE CASE ** C ** TREAT THE NEW PAGE CASE ** C ******************************* C IF(ICOM.EQ.'ERAS')GOTO200 IF(ICOM.EQ.'PAGE')GOTO200 IF(ICOM.EQ.'NEW')GOTO200 GOTO299 C 200 CONTINUE CALL DPERAS(IHARG,IARGT,IARG,NUMARG, 1IBACCO, 1IGRASW,IDIASW, 1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 1PDIAHE,PDIAWI,PDIAVG,PDIAHG, 1NUMDEV, 1IDMANU,IDMODE,IDMOD2,IDMOD3, 1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 1IDNVOF,IDNHOF, CCCCC ADD FOLLOWING LINE MARCH 1997. 1IDFONT, 1ICAPSW, 1IBUGD2,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 299 CONTINUE C C ******************************** C ** TREAT THE RING BELL CASE ** C ******************************** C IF(ICOM.EQ.'RING')GOTO300 GOTO399 C 300 CONTINUE CALL DPRING(IHARG,IARGT,IARG,NUMARG, 1NUMDEV, 1IDMANU,IDMODE,IDMOD2,IDMOD3, 1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, CCCCC ADD FOLLOWING LINE MARCH 1997. 1IDFONT, 1IBUGD2,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 399 CONTINUE C C *************************** C ** TREAT THE TEXT CASE ** C *************************** C CCCCC MODIFIED TO SUPPORT "ELLIPSE DATA" OPTION. JULY 1997. IF(ICOM.EQ.'TEXT')GOTO1100 GOTO1199 C 1100 CONTINUE PRV(1)=PGRAXF PRV(2)=PGRAYF PRV(3)=PDIAXC PRV(4)=PDIAYC PRV(5)=PDIAX2 PRV(6)=PDIAY2 C PDIARV(1)=PDIAHE PDIARV(2)=PDIAWI PDIARV(3)=PDIAVG PDIARV(4)=PDIAHG C ITEXCV(1)=ITEXFO ITEXCV(2)=ITEXCA ITEXCV(3)=ITEXJU ITEXCV(4)=ITEXDI ITEXCV(5)=ITEXCR ITEXCV(6)=ITEXLF ITEXCV(7)=ITEXSY ITEXCV(8)=ITEXSP ITEXCV(9)=ITEXFI ITEXCV(10)=ITEXCO C PTEXRV(1)=PTEXHE PTEXRV(2)=PTEXWI PTEXRV(3)=PTEXVG PTEXRV(4)=PTEXHG PTEXRV(5)=PTEXTH C CCCCC THE FOLLOWING LINE WAS CHANGED SEPTEBMER 1993 CCCCC TO ALLOW FOR LOWER CASE SEPTEMBER 1993 CCCCC CALL DPTEXT(IANS,IWIDTH, CALL DPTEXT(IANS,IANSLC,IWIDTH, 1ITEXTE,NCTEX, 1PXSTAR,PYSTAR,PXEND,PYEND, 1IGRASW,IDIASW,PRV,PDIARV, 1ILINPA,ILINCO,PLINTH, 1ATEXBA, 1ITEBLI,ITEBCO,PTEBTH, 1ITEFSW,ITEFCO, 1ITEPTY,ITEPLI,ITEPCO,PTEPTH,PTEPSP, 1PTEXMR,ITEXCV,ATEXAN,PTEXRV, 1IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM, 1IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH, 1NUMDEV,IDMANU,IDMODE,IDMOD2,IDMOD3, 1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 1IDNVOF,IDNHOF, CCCCC ADD FOLLOWING LINE MARCH 1997. 1IDFONT, 1IMPSW2,AMPSCH,AMPSCW, 1IBUGD2,IFOUND,IERROR) IF(ITEXCR.EQ.'ON')PXSTOP=PTEXMR IF(ITEXLF.EQ.'ON')PYSTOP=PYSTAR-PTEXHE-PTEXVG IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 1199 CONTINUE C C *************************** C ** TREAT THE FONT CASE ** C *************************** C IF(ICOM.EQ.'FONT')GOTO1200 GOTO1299 C 1200 CONTINUE CALL DPFONT(IHARG,NUMARG, 1IDEFFO, 1ITEXFO, 1IBUGD2,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.AND.IERROR.EQ.'NO')GOTO1250 GOTO1259 1250 CONTINUE IX1ZFO=ITEXFO IX2ZFO=ITEXFO IY1ZFO=ITEXFO IY2ZFO=ITEXFO ITITFO=ITEXFO IX1LFO=ITEXFO IX2LFO=ITEXFO IX3LFO=ITEXFO IY1LFO=ITEXFO IY2LFO=ITEXFO DO1251I=1,MAXLEG ILEGFO(I)=ITEXFO 1251 CONTINUE DO1252I=1,MAXCHA ICHAFO(I)=ITEXFO 1252 CONTINUE 1259 CONTINUE IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 1299 CONTINUE C C ************************************************ C ** TREAT THE CASE (UPPER VERSUS LOWER) CASE ** C ************************************************ C IF(ICOM.EQ.'CASE')GOTO1300 GOTO1399 C 1300 CONTINUE CALL DPCASE(ICOM,IHARG,NUMARG, 1IDEFCA, 1ITEXCA, 1IBUGD2,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.AND.IERROR.EQ.'NO')GOTO1350 GOTO1359 1350 CONTINUE DO1351I=1,MAXLEG ILEGCA(I)=ITEXCA 1351 CONTINUE DO1352I=1,MAXCHA ICHACA(I)=ITEXCA 1352 CONTINUE 1359 CONTINUE IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 1399 CONTINUE C C ***************************** C ** TREAT THE HEIGHT CASE ** C ***************************** C IF(ICOM.EQ.'HEIG')GOTO1400 GOTO1499 C 1400 CONTINUE CALL DPHEIG(IHARG,IARGT,ARG,NUMARG, 1PDEFHE, 1PTEXHE, 1IBUGD2,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 1499 CONTINUE C C **************************** C ** TREAT THE WIDTH CASE ** C **************************** C IF(ICOM.EQ.'WIDT')GOTO1500 GOTO1599 C 1500 CONTINUE CALL DPWIDT(IHARG,IARGT,ARG,NUMARG, 1PDEFWI, 1PTEXWI, 1IBUGD2,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 1599 CONTINUE C C ***************************************************** C ** TREAT THE HW (THAT IS, HEIGHT AND WIDTH) CASE ** C ***************************************************** C IF(ICOM.EQ.'HW')GOTO1600 IF(ICOM.EQ.'WH')GOTO1600 GOTO1699 C 1600 CONTINUE CALL DPHW(ICOM,IHARG,IARGT,ARG,NUMARG, 1PDEFHE,PDEFWI, 1PTEXHE,PTEXWI, 1IBUGD2,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 1699 CONTINUE C C ************************************ C ** TREAT THE JUSTIFICATION CASE ** C ************************************ C IF(ICOM.EQ.'JUST')GOTO1700 GOTO1799 1700 CONTINUE CALL DPJUST(ICOM,IHARG,NUMARG, 1IDEFJU, 1ITEXJU, 1IBUGD2,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 1799 CONTINUE C C ***************************** C ** TREAT THE MARGIN CASE ** C ***************************** C IF(ICOM.EQ.'MARG'.AND.IHARG(1).EQ.'COLO')GOTO9000 IF(ICOM.EQ.'MARG'.AND.IHARG(1).EQ.'COOR')GOTO1800 IF(ICOM.EQ.'MARG')GOTO1800 GOTO1899 C 1800 CONTINUE CALL DPMARG(IHARG,IARGT,ARG,NUMARG, 1PDEFMR, 1PTEXMR, 1IBUGD2,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 1899 CONTINUE C C ************************************************ C ** TREAT THE CARRIAGE RETURN/LINE FEED CASE ** C ************************************************ C IF(ICOM.EQ.'CRLF')GOTO 1900 IF(ICOM.EQ.'LFCR')GOTO 1900 GOTO1999 C 1900 CONTINUE CALL DPCRLF(IHARG,NUMARG, 1IDEFCR,IDEFLF, 1ITEXCR,ITEXLF, 1IBUGD2,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 1999 CONTINUE C C *************************** C ** TREAT THE MOVE CASE ** C *************************** C CCCCC MODIFIED TO SUPPORT "MOVE DATA" OPTION. JULY 1997. IF(ICOM.EQ.'MOVE')GOTO2000 GOTO2099 C 2000 CONTINUE CCCCC THE FOLLOWING 2 LINES WERE ADDED NOVEMBER 1992 CCCCC UNITSW='SCRE' X1UNIT='SCRE' Y1UNIT='SCRE' IF(ICOM2(1:1).EQ.'D')X1UNIT='DATA' IF(ICOM2(2:2).EQ.'D')Y1UNIT='DATA' IF(ICOM2.EQ.'DATA')THEN CCCCC UNITSW='DATA' X1UNIT='DATA' Y1UNIT='DATA' ENDIF IF(IHARG(1).EQ.'DATA')THEN CCCCC UNITSW='DATA' X1UNIT='DATA' Y1UNIT='DATA' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGD2,IERROR) ENDIF CALL DPMOVE(IHARG,IARGT,ARG,NUMARG, 1PXSTAR,PYSTAR, 1PXEND,PYEND, 1ILINPA,ILINCO,PLINTH, 1AREGBA, 1IREBLI,IREBCO,PREBTH, 1IREFSW,IREFCO, 1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 1PTEXHE,PTEXWI,PTEXVG,PTEXHG, 1IGRASW,IDIASW, 1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 1PDIAHE,PDIAWI,PDIAVG,PDIAHG, 1NUMDEV, 1IDMANU,IDMODE,IDMOD2,IDMOD3, 1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 1IDNVOF,IDNHOF, CCCCC ADD FOLLOWING LINE MARCH 1997. 1IDFONT, CCCCC THE FOLLOWING LINE WAS ADDED NOVEMBER 1992 CCCCC AND THEN MODIFIED AUGUST 1998 CCCCC1UNITSW, 1X1UNIT,Y1UNIT, 1IBUGD2,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 2099 CONTINUE C C *************************** C ** TREAT THE DRAW CASE ** C *************************** C CCCCC MODIFIED TO SUPPORT "DRAW DATA" OPTION. JULY 1997. CCCCC MODIFIED TO SUPPORT "DRAWDDDD, DRAWDDDS, ETC. OPTIONS. JULY 1998 IF(ICOM.EQ.'DRAW')GOTO2100 GOTO2199 C 2100 CONTINUE CCCCC THE FOLLOWING 2 LINES WERE ADDED SEPTEMBER 1994 CCCCC UNITSW='SCRE' X1UNIT='SCRE' X2UNIT='SCRE' Y1UNIT='SCRE' Y2UNIT='SCRE' IF(ICOM2(1:1).EQ.'D')X1UNIT='DATA' IF(ICOM2(2:2).EQ.'D')Y1UNIT='DATA' IF(ICOM2(3:3).EQ.'D')X2UNIT='DATA' IF(ICOM2(4:4).EQ.'D')Y2UNIT='DATA' IF(ICOM2.EQ.'DATA')THEN CCCCC UNITSW='DATA' X1UNIT='DATA' X2UNIT='DATA' Y1UNIT='DATA' Y2UNIT='DATA' ENDIF IF(IHARG(1).EQ.'DATA')THEN CCCCC UNITSW='DATA' X1UNIT='DATA' X2UNIT='DATA' Y1UNIT='DATA' Y2UNIT='DATA' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGD2,IERROR) ENDIF CALL DPDRAW(IHARG,IARGT,ARG,NUMARG, 1PXSTAR,PYSTAR, 1PXEND,PYEND, 1ILINPA,ILINCO,PLINTH, 1AREGBA, 1IREBLI,IREBCO,PREBTH, 1IREFSW,IREFCO, 1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 1PTEXHE,PTEXWI,PTEXVG,PTEXHG, 1IGRASW,IDIASW, 1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 1PDIAHE,PDIAWI,PDIAVG,PDIAHG, 1NUMDEV, 1IDMANU,IDMODE,IDMOD2,IDMOD3, 1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 1IDNVOF,IDNHOF, CCCCC ADD FOLLOWING LINE MARCH 1997. 1IDFONT, CCCCC THE FOLLOWING LINE WAS ADDED NOVEMBER 1992 CCCCC AND THEN MODIFIED AUGUST 1998 CCCCC1UNITSW, 1X1UNIT,Y1UNIT,X2UNIT,Y2UNIT, 1IBUGD2,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 2199 CONTINUE C C **************************** C ** TREAT THE POINT CASE ** C **************************** C CCCCC THE FOLLOWING LINE WAS COMMENTED OUT (DECEMBER 1988) CCCCC AND REPLACED BY THE SUCCEEDING 2 LINES (DECEMBER 1988) CCCCC TO AVOID CONFLICT BETWEEN POINT COMMAND (DECEMBER 1988) CCCCC AND POINCARE PLOT COMMAND (DECEMBER 1988) CCCCC MODIFIED TO SUPPORT "POINT DATA" OPTION. JULY 1997. CCCCC IF(ICOM.EQ.'POIN')GOTO2200 DECEMBER 1988 IF(ICOM.EQ.'POIN'.AND.NUMARG.GE.1.AND. 1IHARG(1).NE.'PLOT')GOTO2200 GOTO2299 C 2200 CONTINUE UNITSW='SCRE' IF(IHARG(1).EQ.'DATA')THEN UNITSW='DATA' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGD2,IERROR) ENDIF CALL DPPOIN(IHARG,IARGT,ARG,NUMARG, 1PXSTAR,PYSTAR, 1PXEND,PYEND, 1ILINPA,ILINCO,PLINTH, 1AREGBA, 1IREBLI,IREBCO,PREBTH, 1IREFSW,IREFCO, 1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 1PTEXHE,PTEXWI,PTEXVG,PTEXHG, 1IGRASW,IDIASW, 1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 1PDIAHE,PDIAWI,PDIAVG,PDIAHG, 1NUMDEV, 1IDMANU,IDMODE,IDMOD2,IDMOD3, 1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 1IDNVOF,IDNHOF, CCCCC ADD FOLLOWING LINE MARCH 1997. 1IDFONT, CCCCC ADD FOLLOWING LINE JULY 1997. 1UNITSW, 1IBUGD2,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 2299 CONTINUE C C **************************** C ** TREAT THE ARROW CASE ** C **************************** C CCCCC MODIFIED TO SUPPORT "ARROW DATA" OPTION. JULY 1997. IF(ICOM.EQ.'ARRO')GOTO2300 GOTO2399 C 2300 CONTINUE UNITSW='SCRE' IF(IHARG(1).EQ.'DATA')THEN UNITSW='DATA' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGD2,IERROR) ENDIF CALL DPARRO(IHARG,IARGT,ARG,NUMARG, 1PXSTAR,PYSTAR, 1PXEND,PYEND, C 1ILINPA,ILINCO,PLINTH, C AUGUST, 1987: USE VALUES FROM ARROW COMMON BLOCK 1IARRPA,IARRCO,PARRTH, C END CHANGE 1AREGBA, 1IREBLI,IREBCO,PREBTH, 1IREFSW,IREFCO, 1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 1PTEXHE,PTEXWI,PTEXVG,PTEXHG, 1IGRASW,IDIASW, 1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 1PDIAHE,PDIAWI,PDIAVG,PDIAHG, 1NUMDEV, 1IDMANU,IDMODE,IDMOD2,IDMOD3, 1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 1IDNVOF,IDNHOF, CCCCC ADD FOLLOWING LINE MARCH 1997. 1IDFONT, CCCCC ADD FOLLOWING LINE JULY 1997. 1UNITSW, 1IBUGD2,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 2399 CONTINUE C C ************************** C ** TREAT THE BOX CASE ** C ************************** C CCCCC AUGUST 1992. CHECK FOR NAME CONFLICTS CCCCC MODIFIED TO SUPPORT "BOX DATA" OPTION. JULY 1997. CCCCC IF(ICOM.EQ.'BOX'.AND.NUMARG.GE.1.AND. CCCCC1IHARG(1).NE.'PLOT'.AND.IHARG(1).NE.'COX')GOTO2500 IF(NUMARG.GE.1.AND. 1IHARG(1).EQ.'PLOT'.OR.IHARG(1).EQ.'COX'.OR. 1IHARG(1).EQ.'PATT'.OR.IHARG(1).EQ.'THIC'.OR. 1IHARG(1).EQ.'SHAD'.OR. 1IHARG(1).EQ.'COLO'.OR.IHARG(1).EQ.'FILL') 1GOTO2599 IF(NUMARG.GE.2.AND. 1IHARG(2).EQ.'PATT'.OR.IHARG(2).EQ.'THIC'.OR. 1IHARG(2).EQ.'SHAD'.OR. 1IHARG(2).EQ.'COLO'.OR.IHARG(2).EQ.'FILL') 1GOTO2599 IF(ICOM.EQ.'BOX')GOTO2500 GOTO2599 C 2500 CONTINUE UNITSW='SCRE' IF(IHARG(1).EQ.'DATA')THEN UNITSW='DATA' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGD2,IERROR) ENDIF CALL DPBX(IHARG,IARGT,ARG,NUMARG, 1PXSTAR,PYSTAR, 1PXEND,PYEND, C 1ILINPA,ILINCO,PLINTH, C USE PARAMETERS FOR BOX FRAME C AUGUST, 1987 CCCCC1IBOFPA,IBOFCO,PBOFTH, CCCCC CHANGE BOX BORDER SETTINGS OCTOBER 1992 1IBOBPA,IBOBCO,PBOPTH, C END 1AREGBA, 1IREBLI,IREBCO,PREBTH, C MARCH 1993. USE PARAMETERS FOR BOX INTERIOR CCCCC1IREFSW,IREFCO, CCCCC1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 1IBOFPA,IBOFCO, 1IBOFPA,IBOPPA,IBOFCO,PBOFTH,PBOPGA, CCCCC MARCH 1993. ADD BOX SHADOW PARAMETERS. 1PBOSHE,PBOSWI, 1PTEXHE,PTEXWI,PTEXVG,PTEXHG, 1IGRASW,IDIASW, 1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 1PDIAHE,PDIAWI,PDIAVG,PDIAHG, 1NUMDEV, 1IDMANU,IDMODE,IDMOD2,IDMOD3, 1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 1IDNVOF,IDNHOF, CCCCC ADD FOLLOWING LINE MARCH 1997. 1IDFONT, CCCCC ADD FOLLOWING LINE JULY 1997. 1UNITSW, 1IBUGD2,IFOUND,IERROR) 2599 CONTINUE C C C ****************************** C ** TREAT THE HEXAGON CASE ** C ****************************** C CCCCC MODIFIED TO SUPPORT "HEXAGON DATA" OPTION. JULY 1997. IF(ICOM.EQ.'HEXA')GOTO2600 GOTO2699 C 2600 CONTINUE UNITSW='SCRE' IF(IHARG(1).EQ.'DATA')THEN UNITSW='DATA' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGD2,IERROR) ENDIF CALL DPHEXA(IHARG,IARGT,ARG,NUMARG, 1PXSTAR,PYSTAR, 1PXEND,PYEND, 1ILINPA,ILINCO,PLINTH, 1AREGBA, 1IREBLI,IREBCO,PREBTH, 1IREFSW,IREFCO, 1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 1PTEXHE,PTEXWI,PTEXVG,PTEXHG, 1IGRASW,IDIASW, 1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 1PDIAHE,PDIAWI,PDIAVG,PDIAHG, 1NUMDEV, 1IDMANU,IDMODE,IDMOD2,IDMOD3, 1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 1IDNVOF,IDNHOF, CCCCC ADD FOLLOWING LINE MARCH 1997. 1IDFONT, CCCCC ADD FOLLOWING LINE JULY 1997. 1UNITSW, 1IBUGD2,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 2699 CONTINUE C C ***************************** C ** TREAT THE CIRCLE CASE ** C ***************************** C CCCCC MODIFIED TO SUPPORT "ELLIPSE DATA" OPTION. JULY 1997. IF(ICOM.EQ.'CIRC')GOTO2700 GOTO2799 C 2700 CONTINUE UNITSW='SCRE' IF(IHARG(1).EQ.'DATA')THEN UNITSW='DATA' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGD2,IERROR) ENDIF CALL DPCIRC(IHARG,IARGT,ARG,NUMARG, 1PXSTAR,PYSTAR, 1PXEND,PYEND, 1ILINPA,ILINCO,PLINTH, 1AREGBA, 1IREBLI,IREBCO,PREBTH, 1IREFSW,IREFCO, 1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 1PTEXHE,PTEXWI,PTEXVG,PTEXHG, 1IGRASW,IDIASW, 1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 1PDIAHE,PDIAWI,PDIAVG,PDIAHG, 1NUMDEV, 1IDMANU,IDMODE,IDMOD2,IDMOD3, 1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 1IDNVOF,IDNHOF, CCCCC ADD FOLLOWING LINE MARCH 1997. 1IDFONT, CCCCC ADD FOLLOWING LINE JULY 1997. 1UNITSW, 1IBUGD2,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 2799 CONTINUE C C ********************************** C ** TREAT THE SEMI-CIRCLE CASE ** C ********************************** C CCCCC MODIFIED TO SUPPORT "SEMI-CIRCLE DATA" OPTION. JULY 1997. IF(ICOM.EQ.'SEMI')GOTO2800 GOTO2899 C 2800 CONTINUE IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PROB')GOTO2899 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PPCC')GOTO2899 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'PROB')GOTO2899 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'PPCC')GOTO2899 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'KOLM')GOTO2899 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'KOLM')GOTO2899 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'CHI ')GOTO2899 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'CHI ')GOTO2899 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'CHIS')GOTO2899 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'CHIS')GOTO2899 UNITSW='SCRE' IF(IHARG(1).EQ.'DATA')THEN UNITSW='DATA' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGD2,IERROR) ENDIF CALL DPSCIR(IHARG,IARGT,ARG,NUMARG, 1PXSTAR,PYSTAR, 1PXEND,PYEND, 1ILINPA,ILINCO,PLINTH, 1AREGBA, 1IREBLI,IREBCO,PREBTH, 1IREFSW,IREFCO, 1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 1PTEXHE,PTEXWI,PTEXVG,PTEXHG, 1IGRASW,IDIASW, 1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 1PDIAHE,PDIAWI,PDIAVG,PDIAHG, 1NUMDEV, 1IDMANU,IDMODE,IDMOD2,IDMOD3, 1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 1IDNVOF,IDNHOF, CCCCC ADD FOLLOWING LINE MARCH 1997. 1IDFONT, CCCCC ADD FOLLOWING LINE JULY 1997. 1UNITSW, 1IBUGD2,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 2899 CONTINUE C C ****************************** C ** TREAT THE ELLIPSE CASE ** C ****************************** C CCCCC MODIFIED TO SUPPORT "ELLIPSE DATA" OPTION. JULY 1997. C IF(ICOM.EQ.'ELLI')GOTO2900 GOTO2999 C 2900 CONTINUE UNITSW='SCRE' IF(IHARG(1).EQ.'DATA')THEN UNITSW='DATA' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGD2,IERROR) ENDIF CALL DPELLI(IHARG,IARGT,ARG,NUMARG, 1PXSTAR,PYSTAR, 1PXEND,PYEND, 1ILINPA,ILINCO,PLINTH, 1AREGBA, 1IREBLI,IREBCO,PREBTH, 1IREFSW,IREFCO, 1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 1PTEXHE,PTEXWI,PTEXVG,PTEXHG, 1IGRASW,IDIASW, 1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 1PDIAHE,PDIAWI,PDIAVG,PDIAHG, 1NUMDEV, 1IDMANU,IDMODE,IDMOD2,IDMOD3, 1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 1IDNVOF,IDNHOF, CCCCC ADD FOLLOWING LINE MARCH 1997. 1IDFONT, CCCCC ADD FOLLOWING LINE JULY 1997. 1UNITSW, 1IBUGD2,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 2999 CONTINUE C C ******************************* C ** TREAT THE RESISTOR CASE ** C ******************************* C CCCCC MODIFIED TO SUPPORT "RESISTOR DATA" OPTION. JULY 1997. IF(ICOM.EQ.'RESI')GOTO3000 GOTO3099 C 3000 CONTINUE UNITSW='SCRE' IF(IHARG(1).EQ.'DATA')THEN UNITSW='DATA' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGD2,IERROR) ENDIF CALL DPRESI(IHARG,IARGT,ARG,NUMARG, 1PXSTAR,PYSTAR, 1PXEND,PYEND, 1ILINPA,ILINCO,PLINTH, 1AREGBA, 1IREBLI,IREBCO,PREBTH, 1IREFSW,IREFCO, 1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 1PTEXHE,PTEXWI,PTEXVG,PTEXHG, 1IGRASW,IDIASW, 1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 1PDIAHE,PDIAWI,PDIAVG,PDIAHG, 1NUMDEV, 1IDMANU,IDMODE,IDMOD2,IDMOD3, 1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 1IDNVOF,IDNHOF, CCCCC ADD FOLLOWING LINE MARCH 1997. 1IDFONT, CCCCC ADD FOLLOWING LINE JULY 1997. 1UNITSW, 1IBUGD2,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 3099 CONTINUE C C ******************************* C ** TREAT THE INDUCTOR CASE ** C ******************************* C CCCCC MODIFIED TO SUPPORT "INDUCTOR DATA" OPTION. JULY 1997. IF(ICOM.EQ.'INDU')GOTO3100 GOTO3199 C 3100 CONTINUE UNITSW='SCRE' IF(IHARG(1).EQ.'DATA')THEN UNITSW='DATA' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGD2,IERROR) ENDIF CALL DPINDU(IHARG,IARGT,ARG,NUMARG, 1PXSTAR,PYSTAR, 1PXEND,PYEND, 1ILINPA,ILINCO,PLINTH, 1AREGBA, 1IREBLI,IREBCO,PREBTH, 1IREFSW,IREFCO, 1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 1PTEXHE,PTEXWI,PTEXVG,PTEXHG, 1IGRASW,IDIASW, 1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 1PDIAHE,PDIAWI,PDIAVG,PDIAHG, 1NUMDEV, 1IDMANU,IDMODE,IDMOD2,IDMOD3, 1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 1IDNVOF,IDNHOF, CCCCC ADD FOLLOWING LINE MARCH 1997. 1IDFONT, CCCCC ADD FOLLOWING LINE JULY 1997. 1UNITSW, 1IBUGD2,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 3199 CONTINUE C ******************************** C ** TREAT THE CAPACITOR CASE ** C ******************************** C CCCCC THE FOLLOWING LINE WAS FIXED FEBRUARY 1994 CCCCC TO AVOID CONFLICT WITH CAPABILITY COMMAND FEBRUARY 1994 CCCCC MODIFIED TO SUPPORT "CAPACITOR DATA" OPTION. JULY 1997. CCCCC IF(ICOM.EQ.'CAPA')GOTO3200 IF(ICOM.EQ.'CAPA'.AND.ICOM2.EQ.'CITO')GOTO3200 GOTO3299 C 3200 CONTINUE UNITSW='SCRE' IF(IHARG(1).EQ.'DATA')THEN UNITSW='DATA' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGD2,IERROR) ENDIF IF(ICOM2.EQ.'BILI')GOTO3299 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'ANAL')GOTO3299 CALL DPCAPA(IHARG,IARGT,ARG,NUMARG, 1PXSTAR,PYSTAR, 1PXEND,PYEND, 1ILINPA,ILINCO,PLINTH, 1AREGBA, 1IREBLI,IREBCO,PREBTH, 1IREFSW,IREFCO, 1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 1PTEXHE,PTEXWI,PTEXVG,PTEXHG, 1IGRASW,IDIASW, 1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 1PDIAHE,PDIAWI,PDIAVG,PDIAHG, 1NUMDEV, 1IDMANU,IDMODE,IDMOD2,IDMOD3, 1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 1IDNVOF,IDNHOF, CCCCC ADD FOLLOWING LINE MARCH 1997. 1IDFONT, CCCCC ADD FOLLOWING LINE JULY 1997. 1UNITSW, 1IBUGD2,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 3299 CONTINUE C C ***************************** C ** TREAT THE GROUND CASE ** C ***************************** C CCCCC MODIFIED TO SUPPORT "ELLIPSE DATA" OPTION. JULY 1997. IF(ICOM.EQ.'GROU' .AND. IHARG(1).NE.'PARA'.AND. 1 IHARG(2).NE.'COOR')GOTO3300 GOTO3399 C 3300 CONTINUE UNITSW='SCRE' IF(IHARG(1).EQ.'DATA')THEN UNITSW='DATA' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGD2,IERROR) ENDIF CALL DPGROU(IHARG,IARGT,ARG,NUMARG, 1PXSTAR,PYSTAR, 1PXEND,PYEND, 1ILINPA,ILINCO,PLINTH, 1AREGBA, 1IREBLI,IREBCO,PREBTH, 1IREFSW,IREFCO, 1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 1PTEXHE,PTEXWI,PTEXVG,PTEXHG, 1IGRASW,IDIASW, 1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 1PDIAHE,PDIAWI,PDIAVG,PDIAHG, 1NUMDEV, 1IDMANU,IDMODE,IDMOD2,IDMOD3, 1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 1IDNVOF,IDNHOF, CCCCC ADD FOLLOWING LINE MARCH 1997. 1IDFONT, CCCCC ADD FOLLOWING LINE JULY 1997. 1UNITSW, 1IBUGD2,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 3399 CONTINUE C ************************** C ** TREAT THE AND CASE ** C ************************** C CCCCC MODIFIED TO SUPPORT "ELLIPSE DATA" OPTION. JULY 1997. IF(ICOM.EQ.'AND')GOTO3400 GOTO3499 C 3400 CONTINUE UNITSW='SCRE' IF(IHARG(1).EQ.'DATA')THEN UNITSW='DATA' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGD2,IERROR) ENDIF CALL DPAND(IHARG,IARGT,ARG,NUMARG, 1PXSTAR,PYSTAR, 1PXEND,PYEND, 1ILINPA,ILINCO,PLINTH, 1AREGBA, 1IREBLI,IREBCO,PREBTH, 1IREFSW,IREFCO, 1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 1PTEXHE,PTEXWI,PTEXVG,PTEXHG, 1IGRASW,IDIASW, 1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 1PDIAHE,PDIAWI,PDIAVG,PDIAHG, 1NUMDEV, 1IDMANU,IDMODE,IDMOD2,IDMOD3, 1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 1IDNVOF,IDNHOF, CCCCC ADD FOLLOWING LINE MARCH 1997. 1IDFONT, CCCCC ADD FOLLOWING LINE JULY 1997. 1UNITSW, 1IBUGD2,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 3499 CONTINUE C C ************************* C ** TREAT THE OR CASE ** C ************************* C CCCCC MODIFIED TO SUPPORT "ELLIPSE DATA" OPTION. JULY 1997. IF(ICOM.EQ.'OR')GOTO3500 GOTO3599 C 3500 CONTINUE UNITSW='SCRE' IF(IHARG(1).EQ.'DATA')THEN UNITSW='DATA' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGD2,IERROR) ENDIF CALL DPOR(IHARG,IARGT,ARG,NUMARG, 1PXSTAR,PYSTAR, 1PXEND,PYEND, 1ILINPA,ILINCO,PLINTH, 1AREGBA, 1IREBLI,IREBCO,PREBTH, 1IREFSW,IREFCO, 1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 1PTEXHE,PTEXWI,PTEXVG,PTEXHG, 1IGRASW,IDIASW, 1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 1PDIAHE,PDIAWI,PDIAVG,PDIAHG, 1NUMDEV, 1IDMANU,IDMODE,IDMOD2,IDMOD3, 1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 1IDNVOF,IDNHOF, CCCCC ADD FOLLOWING LINE MARCH 1997. 1IDFONT, CCCCC ADD FOLLOWING LINE JULY 1997. 1UNITSW, 1IBUGD2,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 3599 CONTINUE C C *************************** C ** TREAT THE NAND CASE ** C *************************** C CCCCC MODIFIED TO SUPPORT "ELLIPSE DATA" OPTION. JULY 1997. IF(ICOM.EQ.'NAND')GOTO3600 GOTO3699 C 3600 CONTINUE UNITSW='SCRE' IF(IHARG(1).EQ.'DATA')THEN UNITSW='DATA' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGD2,IERROR) ENDIF CALL DPNAND(IHARG,IARGT,ARG,NUMARG, 1PXSTAR,PYSTAR, 1PXEND,PYEND, 1ILINPA,ILINCO,PLINTH, 1AREGBA, 1IREBLI,IREBCO,PREBTH, 1IREFSW,IREFCO, 1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 1PTEXHE,PTEXWI,PTEXVG,PTEXHG, 1IGRASW,IDIASW, 1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 1PDIAHE,PDIAWI,PDIAVG,PDIAHG, 1NUMDEV, 1IDMANU,IDMODE,IDMOD2,IDMOD3, 1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 1IDNVOF,IDNHOF, CCCCC ADD FOLLOWING LINE MARCH 1997. 1IDFONT, CCCCC ADD FOLLOWING LINE JULY 1997. 1UNITSW, 1IBUGD2,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 3699 CONTINUE C C ************************** C ** TREAT THE NOR CASE ** C ************************** C CCCCC MODIFIED TO SUPPORT "ELLIPSE DATA" OPTION. JULY 1997. IF(ICOM.EQ.'NOR')GOTO3700 GOTO3799 C 3700 CONTINUE UNITSW='SCRE' IF(IHARG(1).EQ.'DATA')THEN UNITSW='DATA' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGD2,IERROR) ENDIF CALL DPNOR(IHARG,IARGT,ARG,NUMARG, 1PXSTAR,PYSTAR, 1PXEND,PYEND, 1ILINPA,ILINCO,PLINTH, 1AREGBA, 1IREBLI,IREBCO,PREBTH, 1IREFSW,IREFCO, 1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 1PTEXHE,PTEXWI,PTEXVG,PTEXHG, 1IGRASW,IDIASW, 1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 1PDIAHE,PDIAWI,PDIAVG,PDIAHG, 1NUMDEV, 1IDMANU,IDMODE,IDMOD2,IDMOD3, 1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 1IDNVOF,IDNHOF, CCCCC ADD FOLLOWING LINE MARCH 1997. 1IDFONT, CCCCC ADD FOLLOWING LINE JULY 1997. 1UNITSW, 1IBUGD2,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 3799 CONTINUE C C ************************************** C ** TREAT THE CROSS-HAIR CASE ** C ** TREAT THE READ CROSS-HAIR CASE ** C ************************************** C IF(ICOM.EQ.'CROS')GOTO3800 IF(ICOM.EQ.'CH')GOTO3800 IF(ICOM.EQ.'READ'.AND.IHARG(1).EQ.'CROS')GOTO3800 IF(ICOM.EQ.'READ'.AND.IHARG(1).EQ.'CH')GOTO3800 GOTO3899 C 3800 CONTINUE CALL DPCROS(ICOM,IHARG,IHARG2,IARGT,ARG,NUMARG, 1IANS,IWIDTH, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1IGRASW,IDIASW, 1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 1PDIAHE,PDIAWI,PDIAVG,PDIAHG, 1NUMDEV, 1IDMANU,IDMODE,IDMOD2,IDMOD3, 1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 1IDNVOF,IDNHOF, CCCCC ADD FOLLOWING LINE MARCH 1997. 1IDFONT, 1PXMIN,PXMAX,PYMIN,PYMAX, 1FX1MIN,FX1MAX,FY1MIN,FY1MAX, 1IBUGD2,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 3899 CONTINUE C C ****************************** C ** TREAT THE TRIANGLE CASE ** C ****************************** C CCCCC MODIFIED TO SUPPORT "TRIANGLE DATA" OPTION. JULY 1997. IF(ICOM.EQ.'TRIA')GOTO3900 GOTO3999 C 3900 CONTINUE CCCCC ADD FOLLOWING CHECK SEPTEMBER 1994. IF(IHARG(1).EQ.'PROB')GOTO3999 CCCCC ADD FOLLOWING CHECK SEPTEMBER 2001. IF(IHARG(1).EQ.'PPCC')GOTO3999 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'KOLM')GOTO2899 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'CHI ')GOTO2899 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'CHIS')GOTO2899 C UNITSW='SCRE' IF(IHARG(1).EQ.'DATA')THEN UNITSW='DATA' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGD2,IERROR) ENDIF CALL DPTRIA(IHARG,IARGT,ARG,NUMARG, 1PXSTAR,PYSTAR, 1PXEND,PYEND, 1ILINPA,ILINCO,PLINTH, 1AREGBA, 1IREBLI,IREBCO,PREBTH, 1IREFSW,IREFCO, 1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 1PTEXHE,PTEXWI,PTEXVG,PTEXHG, 1IGRASW,IDIASW, 1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 1PDIAHE,PDIAWI,PDIAVG,PDIAHG, 1NUMDEV, 1IDMANU,IDMODE,IDMOD2,IDMOD3, 1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 1IDNVOF,IDNHOF, CCCCC ADD FOLLOWING LINE MARCH 1997. 1IDFONT, CCCCC ADD FOLLOWING LINE JULY 1997. 1UNITSW, 1IBUGD2,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 3999 CONTINUE C C ****************************** C ** TREAT THE AMPLIFIER CASE** C ****************************** C CCCCC MODIFIED TO SUPPORT "AMPLIFIER DATA" OPTION. JULY 1997. IF(ICOM.EQ.'AMPL'.AND.ICOM2.EQ.'IFIE')GOTO4000 IF(ICOM.EQ.'AMP ')GOTO4000 GOTO4099 C 4000 CONTINUE UNITSW='SCRE' IF(IHARG(1).EQ.'DATA')THEN UNITSW='DATA' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGD2,IERROR) ENDIF CALL DPAMPL(IHARG,IARGT,ARG,NUMARG, 1PXSTAR,PYSTAR, 1PXEND,PYEND, 1ILINPA,ILINCO,PLINTH, 1AREGBA, 1IREBLI,IREBCO,PREBTH, 1IREFSW,IREFCO, 1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 1PTEXHE,PTEXWI,PTEXVG,PTEXHG, 1IGRASW,IDIASW, 1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 1PDIAHE,PDIAWI,PDIAVG,PDIAHG, 1NUMDEV, 1IDMANU,IDMODE,IDMOD2,IDMOD3, 1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 1IDNVOF,IDNHOF, CCCCC ADD FOLLOWING LINE MARCH 1997. 1IDFONT, CCCCC ADD FOLLOWING LINE JULY 1997. 1UNITSW, 1IBUGD2,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 4099 CONTINUE C C ****************************** C ** TREAT THE DIAMOND CASE ** C ****************************** C CCCCC MODIFIED TO SUPPORT "DIAMOND DATA" OPTION. JULY 1997. IF(ICOM.EQ.'DIAM')GOTO4100 GOTO4199 C 4100 CONTINUE UNITSW='SCRE' IF(IHARG(1).EQ.'DATA')THEN UNITSW='DATA' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGD2,IERROR) ENDIF CALL DPDIAM(IHARG,IARGT,ARG,NUMARG, 1PXSTAR,PYSTAR, 1PXEND,PYEND, 1ILINPA,ILINCO,PLINTH, 1AREGBA, 1IREBLI,IREBCO,PREBTH, 1IREFSW,IREFCO, 1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 1PTEXHE,PTEXWI,PTEXVG,PTEXHG, 1IGRASW,IDIASW, 1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 1PDIAHE,PDIAWI,PDIAVG,PDIAHG, 1NUMDEV, 1IDMANU,IDMODE,IDMOD2,IDMOD3, 1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 1IDNVOF,IDNHOF, CCCCC ADD FOLLOWING LINE MARCH 1997. 1IDFONT, CCCCC ADD FOLLOWING LINE JULY 1997. 1UNITSW, 1IBUGD2,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 4199 CONTINUE C C ****************************** C ** TREAT THE OVAL CASE ** C ****************************** C CCCCC MODIFIED TO SUPPORT "OVAL DATA" OPTION. JULY 1997. IF(ICOM.EQ.'OVAL')GOTO4200 GOTO4299 C 4200 CONTINUE UNITSW='SCRE' IF(IHARG(1).EQ.'DATA')THEN UNITSW='DATA' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGD2,IERROR) ENDIF CALL DPOVAL(IHARG,IARGT,ARG,NUMARG, 1PXSTAR,PYSTAR, 1PXEND,PYEND, 1ILINPA,ILINCO,PLINTH, 1AREGBA, 1IREBLI,IREBCO,PREBTH, 1IREFSW,IREFCO, 1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 1PTEXHE,PTEXWI,PTEXVG,PTEXHG, 1IGRASW,IDIASW, 1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 1PDIAHE,PDIAWI,PDIAVG,PDIAHG, 1NUMDEV, 1IDMANU,IDMODE,IDMOD2,IDMOD3, 1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 1IDNVOF,IDNHOF, CCCCC ADD FOLLOWING LINE MARCH 1997. 1IDFONT, CCCCC ADD FOLLOWING LINE JULY 1997. 1UNITSW, 1IBUGD2,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 4299 CONTINUE C C ****************************** C ** TREAT THE ARC CASE ** C ****************************** C CCCCC MODIFIED TO SUPPORT "ARC DATA" OPTION. JULY 1997. IF(ICOM.EQ.'ARC ')GOTO4300 GOTO4399 C 4300 CONTINUE UNITSW='SCRE' IF(IHARG(1).EQ.'DATA')THEN UNITSW='DATA' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGD2,IERROR) ENDIF CALL DPARC(IHARG,IARGT,ARG,NUMARG, 1PXSTAR,PYSTAR, 1PXEND,PYEND, 1ILINPA,ILINCO,PLINTH, 1AREGBA, 1IREBLI,IREBCO,PREBTH, 1IREFSW,IREFCO, 1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 1PTEXHE,PTEXWI,PTEXVG,PTEXHG, 1IGRASW,IDIASW, 1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 1PDIAHE,PDIAWI,PDIAVG,PDIAHG, 1NUMDEV, 1IDMANU,IDMODE,IDMOD2,IDMOD3, 1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 1IDNVOF,IDNHOF, CCCCC ADD FOLLOWING LINE MARCH 1997. 1IDFONT, CCCCC ADD FOLLOWING LINE JULY 1997. 1UNITSW, 1IBUGD2,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 4399 CONTINUE C C ************************************ C ** TREAT THE FILL CASE ** C ************************************ C IF(ICOM.EQ.'FILL')GOTO7100 GOTO7199 7100 CONTINUE CALL DPFILL(IHARG,NUMARG, 1IDEFFI, 1ITEXFI, 1IBUGD2,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 7199 CONTINUE C C ************************************ C ** TREAT THE ANGLE CASE ** C ************************************ C CCCCC OCTOBER 1995. NAME CONFLICT WITH ANGLIT PROBABILITY PLOT C IF(ICOM.EQ.'ANGL')GOTO7200 GOTO7299 7200 CONTINUE CCCCC OCTOBER 1995. ADD FOLLOWING 2 LINES. IF(ICOM2.EQ.'IT '.OR.(NUMARG.GE.2.AND.IHARG(1).EQ.'PROB'.AND. 1IHARG(2).EQ.'PLOT'))GOTO7299 CALL DPANGL(IHARG,IARGT,ARG,NUMARG, 1ITEXAU, 1ADEFAN,IDEFDI, 1ATEXAN,ITEXDI, 1IBUGD2,ISUBRO,IFOUND,IERROR) ANGLE=ATEXAN DEFANG=ADEFAN IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 7299 CONTINUE C C ************************************ C ** TREAT THE ANGLE UNITS CASE ** C ** TREAT THE RADIANS CASE ** C ** TREAT THE DEGREES CASE ** C ** TREAT THE GRADS CASE ** C ************************************ C IF(ICOM.EQ.'ANGL')GOTO7300 IF(ICOM.EQ.'RADI')GOTO7300 IF(ICOM.EQ.'DEGR')GOTO7300 IF(ICOM.EQ.'GRAD')GOTO7300 GOTO7399 7300 CONTINUE IF(ICOM.EQ.'ANGL')GOTO7310 ISHIFT=2 CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1IBUGD2,IERROR) IHARG(1)='UNIT' IHOLD=ICOM IF(NUMARG.GE.3.AND.IHARG(3).EQ.'OFF')IHOLD=IDEFAU IF(NUMARG.GE.3.AND.IHARG(3).EQ.'OFF'.AND.ICOM.EQ.IDEFAU) 1IHOLD='DEGR' IHARG(2)=IHOLD NUMARG=2 7310 CONTINUE CALL DPANGU(IHARG,NUMARG, 1IDEFAU, 1ITEXAU, 1IBUGD2,ISUBRO,IFOUND,IERROR) IANGLU=ITEXAU IDEANU=IDEFAU IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 7399 CONTINUE C C ************************************ C ** TREAT THE PATTERN CASE ** C ************************************ C IF(ICOM.EQ.'PATT')GOTO7400 GOTO7499 7400 CONTINUE CALL DPPATT(IHARG,NUMARG, 1IDEFPA, 1ITEXPA, 1IBUGD2,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 7499 CONTINUE C C ************************************ C ** TREAT THE COLOR CASE ** C ************************************ C IF(ICOM.EQ.'COLO')GOTO7500 IF(ICOM.EQ.'PEN')GOTO7500 GOTO7599 7500 CONTINUE CALL DPCOLO(IHARG,NUMARG, 1IDEFCO, 1ITEXCO, 1IBUGD2,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 7599 CONTINUE C C *************************************** C ** TREAT THE VERTICAL SPACING CASE ** C *************************************** C IF(ICOM.EQ.'VERT')GOTO7600 GOTO7699 C 7600 CONTINUE CALL DPVERT(IHARG,IARGT,ARG,NUMARG, 1PDEFVG, 1PTEXVG, 1IBUGD2,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 7699 CONTINUE C C ***************************************** C ** TREAT THE HORIZONTAL SPACING CASE ** C ***************************************** C IF(ICOM.EQ.'HORI'.AND.IHARG(1).NE.'SWIT')GOTO7700 GOTO7799 C 7700 CONTINUE CALL DPHORI(IHARG,IARGT,ARG,NUMARG, 1PDEFHG, 1PTEXHG, 1IBUGD2,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 7799 CONTINUE C C *************************************** C ** TREAT THE CARRAIAGE RETURN CASE ** C *************************************** C IF(ICOM.EQ.'CARR')GOTO7800 IF(ICOM.EQ.'CR')GOTO7800 GOTO7899 C 7800 CONTINUE CALL DPCR(IHARG,NUMARG, 1IDEFCR, 1ITEXCR, 1IBUGD2,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 7899 CONTINUE C C ******************************** C ** TREAT THE LINE FEED CASE ** C ******************************** C IF(ICOM.EQ.'LINE'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'FEED')GOTO7900 IF(ICOM.EQ.'LF')GOTO7900 GOTO7999 C 7900 CONTINUE CALL DPLF(IHARG,NUMARG, 1IDEFLF, 1ITEXLF, 1IBUGD2,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 7999 CONTINUE C C *************************************** C ** TREAT THE SYMBOL CHARACTER CASE ** C *************************************** C CCCCC AUGUST 1992. CHECK FOR CONFLICT WITH "SYMBOL PLOT" COMMAND. CCCCC IF(ICOM.EQ.'SYMB')GOTO8000 IF(ICOM.EQ.'SYMB'.AND.IHARG(1).NE.'PLOT')GOTO8000 GOTO8099 C 8000 CONTINUE CALL DPSYMB(IHARG,NUMARG, 1IDEFSY, 1ITEXSY, 1IBUGD2,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 8099 CONTINUE C C ******************************************************* C ** TREAT THE SPACING (EQUAL VS. PROPORTIONAL) CASE ** C ******************************************************* C IF(ICOM.EQ.'SPAC')GOTO8100 GOTO8199 C 8100 CONTINUE CALL DPSPAC(IHARG,NUMARG, 1IDEFSP, 1ITEXSP, 1IBUGD2,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 8199 CONTINUE C C ***************************** C ** TREAT THE THICKNESS CASE ** C ***************************** C IF(ICOM.EQ.'THIC')GOTO8200 GOTO8299 C 8200 CONTINUE CALL DPTHIC(IHARG,IARGT,ARG,NUMARG, 1PDEFTH, 1PTEXTH, C DECEMBER 1987: SET ALL THICKNESS (CAN THEN C OVERRIDE ANY INDIVIDUALLY) 1PFRATH,PTICTH,PTIZTH,PVGRTH,PHGRTH,PTITTH,PX1LTH,PX2LTH,PY1LTH, 1PY2LTH,PLEGTH,MAXLG,PBOPTH,PBOFTH,MAXBX,PARRTH,MAXAR, 1PSEGTH,MAXSG,PLINTH,MAXLN,PCHATH,MAXCH2,PFILTH,MAXFL, 1PPATTH,MAXPT,PSPITH,MAXSP,PBABTH,PBAPTH,MAXBA,PREPTH,MAXRG, 1PMABTH,PMAPTH,MAXMR,PTEBTH,PTEPTH,MAXTX, C END CHANGE 1IBUGD2,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 8299 CONTINUE C C ******************************* C ** TREAT THE DIALOGUE CASE ** C ******************************* C CCCCC IF(ICOM.EQ.'DIAL')GOTO8300 CCCCC IF(ICOM.EQ.'D')GOTO8300 CCCCC GOTO8399 CCCCC C8300 CONTINUE CCCCC CALL DPDIAL(IHARG,IARGT,IARG,NUMARG, CCCCC1IGRASW,PDIAXC,PDIAYC, CCCCC1NUMDEV, CCCCC1IDMANU,IDMODE,IDMOD2,IDMOD3, CCCCC1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, CCCCC1IDNVOF,IDNHOF, CCCCC ADD FOLLOWING LINE MARCH 1997. CCCCC1IDFONT, CCCCC1IBUGD2,ISUBRO,IFOUND,IERROR) CCCCC IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 CCCCC C8399 CONTINUE C C ************************** C ** TREAT THE CUBE CASE ** C ************************** C CCCCC MODIFIED TO SUPPORT "CUBE DATA" OPTION. JULY 1997. IF(ICOM.EQ.'CUBE')GOTO8400 GOTO8499 C 8400 CONTINUE UNITSW='SCRE' IF(IHARG(1).EQ.'DATA')THEN UNITSW='DATA' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGD2,IERROR) ENDIF CALL DPCUBE(IHARG,IARGT,ARG,NUMARG, 1PXSTAR,PYSTAR, 1PXEND,PYEND, 1ILINPA,ILINCO,PLINTH, 1AREGBA, 1IREBLI,IREBCO,PREBTH, 1IREFSW,IREFCO, 1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 1PTEXHE,PTEXWI,PTEXVG,PTEXHG, 1IGRASW,IDIASW, 1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 1PDIAHE,PDIAWI,PDIAVG,PDIAHG, 1NUMDEV, 1IDMANU,IDMODE,IDMOD2,IDMOD3, 1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 1IDNVOF,IDNHOF, 1IDFONT, CCCCC ADD FOLLOWING LINE JULY 1997. 1UNITSW, 1IBUGD2,IFOUND,IERROR) 8499 CONTINUE C C ****************************** C ** TREAT THE PYRAMID CASE ** C ****************************** C CCCCC MODIFIED TO SUPPORT "PYRAMID DATA" OPTION. JULY 1997. IF(ICOM.EQ.'PYRA')GOTO8500 GOTO8599 C 8500 CONTINUE UNITSW='SCRE' IF(IHARG(1).EQ.'DATA')THEN UNITSW='DATA' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGD2,IERROR) ENDIF CALL DPPYRA(IHARG,IARGT,ARG,NUMARG, 1PXSTAR,PYSTAR, 1PXEND,PYEND, 1ILINPA,ILINCO,PLINTH, 1AREGBA, 1IREBLI,IREBCO,PREBTH, 1IREFSW,IREFCO, 1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 1PTEXHE,PTEXWI,PTEXVG,PTEXHG, 1IGRASW,IDIASW, 1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 1PDIAHE,PDIAWI,PDIAVG,PDIAHG, 1NUMDEV, 1IDMANU,IDMODE,IDMOD2,IDMOD3, 1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 1IDNVOF,IDNHOF, 1IDFONT, CCCCC ADD FOLLOWING LINE JULY 1997. 1UNITSW, 1IBUGD2,IFOUND,IERROR) 8599 CONTINUE C C ****************************** C ** TREAT THE LATTICE CASE ** C ****************************** C CCCCC MODIFIED TO SUPPORT "LATTICE DATA" OPTION. JULY 1997. IF(ICOM.EQ.'LATT')GOTO8600 GOTO8699 C 8600 CONTINUE UNITSW='SCRE' IF(IHARG(1).EQ.'DATA')THEN UNITSW='DATA' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGD2,IERROR) ENDIF CALL DPLATT(IHARG,IARGT,ARG,NUMARG, 1PXSTAR,PYSTAR, 1PXEND,PYEND, 1ILINPA,ILINCO,PLINTH, 1AREGBA, 1IREBLI,IREBCO,PREBTH, 1IREFSW,IREFCO, 1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 1PTEXHE,PTEXWI,PTEXVG,PTEXHG, 1IGRASW,IDIASW, 1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 1PDIAHE,PDIAWI,PDIAVG,PDIAHG, 1NUMDEV, 1IDMANU,IDMODE,IDMOD2,IDMOD3, 1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 1IDNVOF,IDNHOF, 1IDFONT, CCCCC ADD FOLLOWING LINE JULY 1997. 1UNITSW, 1IBUGD2,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 8699 CONTINUE C C ****************************** C ** TREAT THE POLYGON CASE ** C ****************************** C IF(ICOM.EQ.'POLY'.AND.ICOM2.EQ.'GON ')GOTO8700 GOTO8799 C 8700 CONTINUE UNITSW='SCRE' IF(IHARG(1).EQ.'DATA')THEN UNITSW='DATA' ISHIFT=1 CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1 IBUGD2,IERROR) ENDIF CALL DPPOLY( 1PXSTAR,PYSTAR, 1PXEND,PYEND, 1ILINPA,ILINCO,PLINTH, 1AREGBA, 1IREBLI,IREBCO,PREBTH, 1IREFSW,IREFCO, 1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 1PTEXHE,PTEXWI,PTEXVG,PTEXHG, 1IGRASW,IDIASW, 1PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 1PDIAHE,PDIAWI,PDIAVG,PDIAHG, 1NUMDEV, 1IDMANU,IDMODE,IDMOD2,IDMOD3, 1IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT, 1IDNVOF,IDNHOF, 1IDFONT, 1UNITSW, 1IBUGD2,IFOUND,IERROR) IF(IFOUND.EQ.'YES'.OR.IERROR.EQ.'YES')GOTO9000 C 8799 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGDG.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('AT THE END OF MAINDG--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IBUGDG,IBUGD2,ISUBRO 9013 FORMAT('IBUGDG,IBUGD2,ISUBRO = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)IFOUND,IERROR 9014 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9019)PXSTAR,PYSTAR,PXEND,PYEND 9019 FORMAT('PXSTAR,PYSTAR,PXEND,PYEND = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9020)DEFANG,ANGLE,IDEANU,IANGLU 9020 FORMAT('DEFANG,ANGLE,IDEANU,IANGLU = ',2E15.7,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9029)IFOUND,IERROR 9029 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9027)ICOM,ICOM2 9027 FORMAT('ICOM,ICOM2 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9028)NUMARG 9028 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') DO9030I=1,NUMARG WRITE(ICOUT,9031)I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I) 9031 FORMAT('I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I) = ', 1I8,2X,A4,2X,A4,2X,A4,2X,I8,E15.7) CALL DPWRST('XXX','BUG ') 9030 CONTINUE WRITE(ICOUT,9041)IREPCH 9041 FORMAT('IREPCH = ',A1) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END