real function ran183(ix,iy,iz) c c Algorithm AS 183 Appl. Statist. (1982) vol.31, no.2 c c Returns a pseudo-random number rectangularly distributed c between 0 and 1. The cycle length is 6.95E+12 (See page 123 c of Applied Statistics (1984) vol.33), not as claimed in the c original article. c c IX, IY and IZ should be set to integer values between 1 and c 30000 before the first entry. c c Integer arithmetic up to 30323 is required. c integer ix, iy, iz c ix = 171 * mod(ix, 177) - 2 * (ix / 177) iy = 172 * mod(iy, 176) - 35 * (iy / 176) iz = 170 * mod(iz, 178) - 63 * (iz / 178) c if (ix .lt. 0) ix = ix + 30269 if (iy .lt. 0) iy = iy + 30307 if (iz .lt. 0) iz = iz + 30323 c c If integer arithmetic up to 5212632 is available, the preceding c 6 statements may be replaced by: c c ix = mod(171 * ix, 30269) c iy = mod(172 * iy, 30307) c iz = mod(170 * iz, 30323) c ran183 = mod(float(ix) / 30269. + float(iy) / 30307. + + float(iz) / 30323., 1.0) return end FUNCTION RAND(R) C***BEGIN PROLOGUE RAND C***DATE WRITTEN 770401 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. L6A21 C***KEYWORDS RANDOM NUMBER,SPECIAL FUNCTION,UNIFORM C***AUTHOR FULLERTON, W., (LANL) C***PURPOSE Generates a uniformly distributed random number. C***DESCRIPTION C C This pseudo-random number generator is portable among a wide C variety of computers. RAND(R) undoubtedly is not as good as many C readily available installation dependent versions, and so this C routine is not recommended for widespread usage. Its redeeming C feature is that the exact same random numbers (to within final round- C off error) can be generated from machine to machine. Thus, programs C that make use of random numbers can be easily transported to and C checked in a new environment. C The random numbers are generated by the linear congruential C method described, e.g., by Knuth in Seminumerical Methods (p.9), C Addison-Wesley, 1969. Given the I-th number of a pseudo-random C sequence, the I+1 -st number is generated from C X(I+1) = (A*X(I) + C) MOD M, C where here M = 2**22 = 4194304, C = 1731 and several suitable values C of the multiplier A are discussed below. Both the multiplier A and C random number X are represented in double precision as two 11-bit C words. The constants are chosen so that the period is the maximum C possible, 4194304. C In order that the same numbers be generated from machine to C machine, it is necessary that 23-bit integers be reducible modulo C 2**11 exactly, that 23-bit integers be added exactly, and that 11-bit C integers be multiplied exactly. Furthermore, if the restart option C is used (where R is between 0 and 1), then the product R*2**22 = C R*4194304 must be correct to the nearest integer. C The first four random numbers should be .0004127026, C .6750836372, .1614754200, and .9086198807. The tenth random number C is .5527787209, and the hundredth is .3600893021 . The thousandth C number should be .2176990509 . C In order to generate several effectively independent sequences C with the same generator, it is necessary to know the random number C for several widely spaced calls. The I-th random number times 2**22, C where I=K*P/8 and P is the period of the sequence (P = 2**22), is C still of the form L*P/8. In particular we find the I-th random C number multiplied by 2**22 is given by C I = 0 1*P/8 2*P/8 3*P/8 4*P/8 5*P/8 6*P/8 7*P/8 8*P/8 C RAND= 0 5*P/8 2*P/8 7*P/8 4*P/8 1*P/8 6*P/8 3*P/8 0 C Thus the 4*P/8 = 2097152 random number is 2097152/2**22. C Several multipliers have been subjected to the spectral test C (see Knuth, p. 82). Four suitable multipliers roughly in order of C goodness according to the spectral test are C 3146757 = 1536*2048 + 1029 = 2**21 + 2**20 + 2**10 + 5 C 2098181 = 1024*2048 + 1029 = 2**21 + 2**10 + 5 C 3146245 = 1536*2048 + 517 = 2**21 + 2**20 + 2**9 + 5 C 2776669 = 1355*2048 + 1629 = 5**9 + 7**7 + 1 C C In the table below LOG10(NU(I)) gives roughly the number of C random decimal digits in the random numbers considered I at a time. C C is the primary measure of goodness. In both cases bigger is better. C C LOG10 NU(I) C(I) C A I=2 I=3 I=4 I=5 I=2 I=3 I=4 I=5 C C 3146757 3.3 2.0 1.6 1.3 3.1 1.3 4.6 2.6 C 2098181 3.3 2.0 1.6 1.2 3.2 1.3 4.6 1.7 C 3146245 3.3 2.2 1.5 1.1 3.2 4.2 1.1 0.4 C 2776669 3.3 2.1 1.6 1.3 2.5 2.0 1.9 2.6 C Best C Possible 3.3 2.3 1.7 1.4 3.6 5.9 9.7 14.9 C C Input Argument -- C R If R=0., the next random number of the sequence is generated. C If R .LT. 0., the last generated number will be returned for C possible use in a restart procedure. C If R .GT. 0., the sequence of random numbers will start with C the seed R mod 1. This seed is also returned as the value of C RAND provided the arithmetic is done exactly. C C Output Value -- C RAND a pseudo-random number between 0. and 1. C***REFERENCES (NONE) C***ROUTINES CALLED (NONE) C***END PROLOGUE RAND DATA IA1, IA0, IA1MA0 /1536, 1029, 507/ DATA IC /1731/ DATA IX1, IX0 /0, 0/ C***FIRST EXECUTABLE STATEMENT RAND IF (R.LT.0.) GO TO 10 IF (R.GT.0.) GO TO 20 C C A*X = 2**22*IA1*IX1 + 2**11*(IA1*IX1 + (IA1-IA0)*(IX0-IX1) C + IA0*IX0) + IA0*IX0 C IY0 = IA0*IX0 IY1 = IA1*IX1 + IA1MA0*(IX0-IX1) + IY0 IY0 = IY0 + IC IX0 = MOD (IY0, 2048) IY1 = IY1 + (IY0-IX0)/2048 IX1 = MOD (IY1, 2048) C 10 RAND = IX1*2048 + IX0 RAND = RAND / 4194304. RETURN C 20 IX1 = AMOD(R,1.)*4194304. + 0.5 IX0 = MOD (IX1, 2048) IX1 = (IX1-IX0)/2048 GO TO 10 C END SUBROUTINE RANGE(X,N,IWRITE,XRANGE,IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C SAMPLE RANGE C OF THE DATA IN THE INPUT VECTOR X. C THE SAMPLE RANGE = SAMPLE MAX - SAMPLE MIN. 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--XRANGE = THE SINGLE PRECISION VALUE OF THE C COMPUTED SAMPLE RANGE. C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE C SAMPLE RANGE. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--KENDALL AND STUART, THE ADVANCED THEORY OF C STATISTICS, VOLUME 1, EDITION 2, 1963, PAGE 338. C --DAVID, ORDER STATISTICS, 1970, PAGE 10-11. C --SNEDECOR AND COCHRAN, STATISTICAL METHODS, C EDITION 6, 1967, PAGE 39. C --DIXON AND MASSEY, INTRODUCTION TO STATISTICAL C ANALYSIS, EDITION 2, 1957, PAGE 21. 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 (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 --JUNE 1974. C UPDATED --APRIL 1975. C UPDATED --SEPTEMBER 1975. C UPDATED --NOVEMBER 1975. C UPDATED --JUNE 1979. C UPDATED --AUGUST 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DIMENSION X(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='RANG' ISUBN2='E ' C IERROR='NO' C XMIN=0.0 XMAX=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 RANGE--') 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 RANGE ** 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 RANGE--') 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 RANGE IS TO BE COMPUTED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,115) 115 FORMAT(' MUST BE 1 OR LARGER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,116) 116 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,117)N 117 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 1'.') CALL DPWRST('XXX','BUG ') GOTO9000 119 CONTINUE C IF(N.EQ.1)GOTO120 GOTO129 120 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,121) 121 FORMAT('***** NON-FATAL DIAGNOSTIC IN RANGE--', 1'THE 2ND INPUT ARGUMENT (N) HAS THE VALUE 1') CALL DPWRST('XXX','BUG ') XRANGE=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 RANGE--', 1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','BUG ') XRANGE=0.0 GOTO9000 139 CONTINUE C 190 CONTINUE C C ************************** C ** STEP 2-- ** C ** COMPUTE THE RANGE. ** C ************************** C XMIN=X(1) XMAX=X(1) DO200I=2,N IF(X(I).LT.XMIN)XMIN=X(I) IF(X(I).GT.XMAX)XMAX=X(I) 200 CONTINUE XRANGE=XMAX-XMIN 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,XRANGE 811 FORMAT('THE RANGE 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 RANGE--') 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)XMIN,XMAX 9014 FORMAT('XMIN,XMAX = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)XRANGE 9015 FORMAT('XRANGE = ',E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE RANK(X,N,IWRITE,XR,IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE RANKS (IN ASCENDING ORDER) C THE N ELEMENTS OF THE SINGLE PRECISION VECTOR X, C AND PUTS THE RESULTING N RANKS INTO THE C SINGLE PRECISION VECTOR XR. C NOTE--THIS ROUTINE IN JJF8 HAS BEEN MODIFIED C FOR DATAPLOT C FROM THE SAME-NAME SUBROUTINE IN JJF6 IN 3 IMPORTANT WAYS-- C 1) THE UPPER LIMIT (IUPPER) HAS BEEN C REDUCED FROM 7500 TO 1000 C 2) THE VECTOR XS HAS HAD ITS DIMENSION C CHANGED FROM 7500 TO 1000. C 3) THE VECTOR XS HAS BEEN TAKEN OUT OF COMMON. C THIS SUBROUTINE GIVES THE DATA ANALYST C THE ABILITY TO (FOR EXAMPLE) RANK THE DATA C PRELIMINARY TO CERTAIN DISTRIBUTION-FREE C ANALYSES. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF C OBSERVATIONS TO BE RANKED. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X. C OUTPUT ARGUMENTS--XR = THE SINGLE PRECISION VECTOR C INTO WHICH THE RANKS C FROM X WILL BE PLACED. C OUTPUT--THE SINGLE PRECISION VECTOR XR C CONTAINING THE RANKS C (IN ASCENDING ORDER) C OF THE VALUES C IN THE SINGLE PRECISION VECTOR X. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THE MAXIMUM ALLOWABLE VALUE OF N C FOR THIS SUBROUTINE IS 7500. 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 COMMENT--THE RANK OF THE FIRST ELEMENT C OF THE VECTOR X C WILL BE PLACED IN THE FIRST POSITION C OF THE VECTOR XR, C THE RANK OF THE SECOND ELEMENT C OF THE VECTOR X C WILL BE PLACED IN THE SECOND POSITION C OF THE VECTOR XR, C ETC. C COMMENT--THE SMALLEST ELEMENT IN THE VECTOR X C WILL HAVE A RANK OF 1 (UNLESS TIES EXIST). C THE LARGEST ELEMENT IN THE VECTOR X C WILL HAVE A RANK OF N (UNLESS TIES EXIST). C COMMENT--ALTHOUGH RANKS ARE USUALLY (UNLESS TIES EXIST) C INTEGRAL VALUES FROM 1 TO N, IT IS TO BE C NOTED THAT THEY ARE OUTPUTED AS SINGLE C PRECISION INTEGERS IN THE SINGLE PRECISION C VECTOR XR. C XR IS SINGLE PRECISION SO AS TO BE C CONSISTENT WITH THE FACT THAT ALL C VECTOR ARGUMENTS IN ALL OTHER C DATAPAC SUBROUTINES ARE SINGLE PRECISION; C BUT MORE IMPORTANTLY, BECAUSE TIES FREQUENTLY C DO EXIST IN DATA SETS AND SO SOME OF THE C RESULTING RANKS WILL BE NON-INTEGRAL C AND SO THE OUTPUT VECTOR OF RANKS MUST NECESSARILY C BE SINGLE PRECISION AND NOT INTEGER. C COMMENT--THE INPUT VECTOR X REMAINS UNALTERED. C COMMENT--THE FIRST AND THIRD ARGUMENTS IN THE C CALLING SEQUENCE MAY C BE IDENTICAL; THAT IS, AN 'IN PLACE' C RANKING IS PERMITTED. C THE CALLING SEQUENCE C CALL RANK(X,N,X) IS VALID, IF DESIRED. C COMMENT--THE SORTING ALGORTHM USED HEREIN C IS THE QUICKSORT. C THIS ALGORTHIM IS EXTREMELY FAST AS THE C FOLLOWING TIME TRIALS INDICATE. C THESE TIME TRIALS WERE CARRIED OUT ON THE C UNIVAC 1108 EXEC 8 SYSTEM AT NBS C IN AUGUST OF 1974. C BY WAY OF COMPARISON, THE TIME TRIAL VALUES C FOR THE EASY-TO-PROGRAM BUT EXTREMELY C INEFFICIENT BUBBLE SORT ALGORITHM HAVE C ALSO BEEN INCLUDED-- C NUMBER OF RANDOM QUICKSORT BUBBLE SORT C NUMBERS SORTED C N = 10 .002 SEC .002 SEC C N = 100 .011 SEC .045 SEC C N = 1000 .141 SEC 4.332 SEC C N = 3000 .476 SEC 37.683 SEC C N = 10000 1.887 SEC NOT COMPUTED C REFERENCES--CACM MARCH 1969, PAGE 186 (QUICKSORT ALGORITHM C BY RICHARD C. SINGLETON). C --CACM JANUARY 1970, PAGE 54. C --CACM OCTOBER 1970, PAGE 624. C --JACM JANUARY 1961, PAGE 41. 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 (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--82.6 C ORIGINAL VERSION--JUNE 1972. C UPDATED --JANUARY 1975. C UPDATED --NOVEMBER 1975. C UPDATED --JANUARY 1977. C UPDATED --MARCH 1979. C UPDATED --AUGUST 1981. C UPDATED --MARCH 1982. C UPDATED --MAY 1982. C UPDATED --JUNE 1990. TEMPORARY ARRAYS TO GARBAGE COMMON C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION X(*) DIMENSION XR(*) DIMENSION XS(MAXOBV) CCCCC FOLLOWING LINES ADDED JUNE, 1990 INCLUDE 'DPCOZ2.INC' EQUIVALENCE (G2RBAG(IGAR45),XS(1)) CCCCC END CHANGE C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='RANK' ISUBN2=' ' C IERROR='NO' IUPPER=MAXOBV C K=0 C RPREV=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 RANK--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N,IUPPER 53 FORMAT('N,IUPPER = ',2I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,X(I) 56 FORMAT('I,X(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ********************************** C ** COMPUTE THE RANKED VALUES. ** 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)IUPPER 111 FORMAT('***** ERROR IN RANK--', 1'THE 2ND INPUT ARGUMENT (N) IS SMALLER THAN 1', 1'OR LARGER THAN ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,118)N 118 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) 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 RANK--', 1'THE 2ND INPUT ARGUMENT (N) HAS THE VALUE 1') CALL DPWRST('XXX','BUG ') XR(1)=1.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 RANK--', 1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','BUG ') AVRANK=(AN+1.0)/2.0 DO137I=1,N XR(I)=AVRANK 137 CONTINUE GOTO9000 139 CONTINUE C 190 CONTINUE C C *************************************************** C ** STEP 2-- ** C ** FIRST SORT THE DATA FROM THE INPUT VECTOR X ** C ** INTO THE INTERMEDIATE STORAGE VECTOR XS. ** C *************************************************** C CALL SORT(X,N,XS) C C **************************************************************** C ** STEP 3-- C ** NOW DETERMINE THE RANKS. C ** THE BASIC ALGORITHM IS TO TAKE A GIVEN ELEMENT C ** IN THE ORIGINAL INPUT VECTOR X, C ** AND SCAN THE SORTED VALUES IN THE XS VECTOR C ** UNTIL A MATCH IS FOUND; C ** WHEN A MATCH IS FOUND, THEN THE RANK FOR THAT C ** VALUE IN THE XS VECTOR IS DETERMINED. C ** THAT RANK IS THEN WRITTEN INTO THAT POSITION C ** IN THE OUTPUT Y VECTOR WHICH CORRESPONDS TO THE POSITION OF C ** GIVEN ELEMENT OF INTEREST IN THE ORIGINAL X VECTOR. C ** THE CODE IS LENGTHENED FROM THIS BASIC ALGORITHM C ** BY A SECTION WHICH CUTS DOWN THE SEARCH IN THE XS VECTOR, C ** AND BY A SECTION WHICH OBVIATES (UNDER CERTAIN CIRCUMSTANCES C ** THE NEED FOR RECALCULATING THE RANK OF AN ELEMENT IN XS. C **************************************************************** C NM1=N-1 XPREV=X(1) DO700I=1,N JMIN=1 IF(X(I).GT.XPREV)GOTO770 IF(I.EQ.1)GOTO790 IF(X(I).EQ.XPREV)GOTO750 GOTO790 750 CONTINUE XPREV=X(I) XR(I)=RPREV GOTO880 770 CONTINUE JMIN=K IF(JMIN.LT.N)GOTO790 IF(JMIN.EQ.N)GOTO820 C IERROR='YES' IBRAN=1 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,781)IBRAN 781 FORMAT('***** INTERNAL ERROR IN RANK--', 1'IMPOSSIBLE BRANCH CONDITION AT BRANCH POINT = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,782)JMIN 782 FORMAT('JMIN = ',I8) CALL DPWRST('XXX','BUG ') GOTO9000 C 790 CONTINUE DO800J=JMIN,NM1 IF(X(I).NE.XS(J))GOTO800 JP1=J+1 DO900K=JP1,N IF(XS(K).NE.XS(J))GOTO950 900 CONTINUE K=N+1 950 CONTINUE AVRANK=J+K-1 AVRANK=AVRANK/2.0 XPREV=X(I) XR(I)=AVRANK GOTO880 800 CONTINUE 820 CONTINUE J=N K=N+1 IF(X(I).EQ.XS(J))GOTO850 C IERROR='YES' IBRAN=2 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,881)IBRAN 881 FORMAT('***** INTERNAL ERROR IN RANK--', 1'IMPOSSIBLE BRANCH CONDITION AT BRANCH POINT = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,882)X(I),XS(I) 882 FORMAT('X(I) = ',E15.7,' XS(J) = ',E15.7) CALL DPWRST('XXX','BUG ') GOTO9000 C 850 CONTINUE XPREV=X(I) XR(I)=N 880 CONTINUE RPREV=XR(I) 700 CONTINUE C XMIN=XS(1) XMAX=XS(N) CCCCC RKXMIN=XR(1) CCCCC RKXMAX=XR(1) CCCCC DO910I=1,N CCCCC IF(XR(I).LT.RKXMIN)RKXMIN=XR(I) CCCCC IF(XR(I).GT.RKXMAX)RKXMAX=XR(I) CC910 CONTINUE C C ****************************** C ** STEP 4-- ** C ** WRITE OUT A FEW LINES ** C ** OF SUMMARY INFORMATION ** C ** ABOUT THE CODING. ** C ****************************** C IF(IFEEDB.EQ.'OFF')GOTO990 IF(IWRITE.EQ.'OFF')GOTO990 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') AI=1 WRITE(ICOUT,912)XS(1),AI 912 FORMAT('THE MINIMUM (= ',E15.7,' ) HAS RANK ',F10.0) CALL DPWRST('XXX','BUG ') AI=N WRITE(ICOUT,913)XS(N),AI 913 FORMAT('THE MAXIMUM (= ',E15.7,' ) HAS RANK ',F10.0) CALL DPWRST('XXX','BUG ') 990 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 RANK--') 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 ') DO9015I=1,N WRITE(ICOUT,9016)I,X(I),XR(I),XS(I) 9016 FORMAT('I,X(I),XR(I),XS(I) = ',I8,3E15.7) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE RANK2(X,N,IWRITE,XR,IBUGA3,IERROR) C C NOTE--THIS SUBROUTINE IS IDENTICAL TO SUBROUTINE RANK(.) C AND HAS BEEN DUPLICATED ONLY FOR MAPPING/STORAGE ECONOMY. C C PURPOSE--THIS SUBROUTINE RANKS (IN ASCENDING ORDER) C THE N ELEMENTS OF THE SINGLE PRECISION VECTOR X, C AND PUTS THE RESULTING N RANKS INTO THE C SINGLE PRECISION VECTOR XR. C NOTE--THIS ROUTINE IN JJF8 HAS BEEN MODIFIED C FOR DATAPLOT C FROM THE SAME-NAME SUBROUTINE IN JJF6 IN 3 IMPORTANT WAYS-- C 1) THE UPPER LIMIT (IUPPER) HAS BEEN C REDUCED FROM 7500 TO 1000 C 2) THE VECTOR XS HAS HAD ITS DIMENSION C CHANGED FROM 7500 TO 1000. C 3) THE VECTOR XS HAS BEEN TAKEN OUT OF COMMON. C THIS SUBROUTINE GIVES THE DATA ANALYST C THE ABILITY TO (FOR EXAMPLE) RANK THE DATA C PRELIMINARY TO CERTAIN DISTRIBUTION-FREE C ANALYSES. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF C OBSERVATIONS TO BE RANKED. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X. C OUTPUT ARGUMENTS--XR = THE SINGLE PRECISION VECTOR C INTO WHICH THE RANKS C FROM X WILL BE PLACED. C OUTPUT--THE SINGLE PRECISION VECTOR XR C CONTAINING THE RANKS C (IN ASCENDING ORDER) C OF THE VALUES C IN THE SINGLE PRECISION VECTOR X. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THE MAXIMUM ALLOWABLE VALUE OF N C FOR THIS SUBROUTINE IS 7500. 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 COMMENT--THE RANK OF THE FIRST ELEMENT C OF THE VECTOR X C WILL BE PLACED IN THE FIRST POSITION C OF THE VECTOR XR, C THE RANK OF THE SECOND ELEMENT C OF THE VECTOR X C WILL BE PLACED IN THE SECOND POSITION C OF THE VECTOR XR, C ETC. C COMMENT--THE SMALLEST ELEMENT IN THE VECTOR X C WILL HAVE A RANK OF 1 (UNLESS TIES EXIST). C THE LARGEST ELEMENT IN THE VECTOR X C WILL HAVE A RANK OF N (UNLESS TIES EXIST). C COMMENT--ALTHOUGH RANKS ARE USUALLY (UNLESS TIES EXIST) C INTEGRAL VALUES FROM 1 TO N, IT IS TO BE C NOTED THAT THEY ARE OUTPUTED AS SINGLE C PRECISION INTEGERS IN THE SINGLE PRECISION C VECTOR XR. C XR IS SINGLE PRECISION SO AS TO BE C CONSISTENT WITH THE FACT THAT ALL C VECTOR ARGUMENTS IN ALL OTHER C DATAPAC SUBROUTINES ARE SINGLE PRECISION; C BUT MORE IMPORTANTLY, BECAUSE TIES FREQUENTLY C DO EXIST IN DATA SETS AND SO SOME OF THE C RESULTING RANKS WILL BE NON-INTEGRAL C AND SO THE OUTPUT VECTOR OF RANKS MUST NECESSARILY C BE SINGLE PRECISION AND NOT INTEGER. C COMMENT--THE INPUT VECTOR X REMAINS UNALTERED. C COMMENT--THE FIRST AND THIRD ARGUMENTS IN THE C CALLING SEQUENCE MAY C BE IDENTICAL; THAT IS, AN 'IN PLACE' C RANKING IS PERMITTED. C THE CALLING SEQUENCE C CALL RANK(X,N,X) IS VALID, IF DESIRED. C COMMENT--THE SORTING ALGORTHM USED HEREIN C IS THE QUICKSORT. C THIS ALGORTHIM IS EXTREMELY FAST AS THE C FOLLOWING TIME TRIALS INDICATE. C THESE TIME TRIALS WERE CARRIED OUT ON THE C UNIVAC 1108 EXEC 8 SYSTEM AT NBS C IN AUGUST OF 1974. C BY WAY OF COMPARISON, THE TIME TRIAL VALUES C FOR THE EASY-TO-PROGRAM BUT EXTREMELY C INEFFICIENT BUBBLE SORT ALGORITHM HAVE C ALSO BEEN INCLUDED-- C NUMBER OF RANDOM QUICKSORT BUBBLE SORT C NUMBERS SORTED C N = 10 .002 SEC .002 SEC C N = 100 .011 SEC .045 SEC C N = 1000 .141 SEC 4.332 SEC C N = 3000 .476 SEC 37.683 SEC C N = 10000 1.887 SEC NOT COMPUTED C REFERENCES--CACM MARCH 1969, PAGE 186 (QUICKSORT ALGORITHM C BY RICHARD C. SINGLETON). C --CACM JANUARY 1970, PAGE 54. C --CACM OCTOBER 1970, PAGE 624. C --JACM JANUARY 1961, PAGE 41. 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 (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--82.6 C ORIGINAL VERSION--JUNE 1972. C UPDATED --JANUARY 1975. C UPDATED --NOVEMBER 1975. C UPDATED --JANUARY 1977. C UPDATED --MARCH 1979. C UPDATED --AUGUST 1981. C UPDATED --MARCH 1982. C UPDATED --MAY 1982. C UPDATED --JUNE 1990. TEMPORARY ARRAYS TO GARBAGE COMMON C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION X(*) DIMENSION XR(*) DIMENSION XS(MAXOBV) CCCCC FOLLOWING LINES ADDED JUNE, 1990 INCLUDE 'DPCOZ2.INC' EQUIVALENCE (G2RBAG(IGAR45),XS(1)) CCCCC END CHANGE C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='RANK' ISUBN2='2 ' C IERROR='NO' IUPPER=MAXOBV C K=0 C RPREV=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 RANK2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N,IUPPER 53 FORMAT('N,IUPPER = ',2I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,X(I) 56 FORMAT('I,X(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ********************************** C ** COMPUTE THE RANKED VALUES. ** 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)IUPPER 111 FORMAT('***** ERROR IN RANK2--', 1'THE 2ND INPUT ARGUMENT (N) IS SMALLER THAN 1', 1'OR LARGER THAN ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,118)N 118 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) 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 RANK2--', 1'THE 2ND INPUT ARGUMENT (N) HAS THE VALUE 1') CALL DPWRST('XXX','BUG ') XR(1)=1.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 RANK2--', 1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','BUG ') AVRANK=(AN+1.0)/2.0 DO137I=1,N XR(I)=AVRANK 137 CONTINUE GOTO9000 139 CONTINUE C 190 CONTINUE C C *************************************************** C ** STEP 2-- ** C ** FIRST SORT THE DATA FROM THE INPUT VECTOR X ** C ** INTO THE INTERMEDIATE STORAGE VECTOR XS. ** C *************************************************** C CALL SORT(X,N,XS) C C **************************************************************** C ** STEP 3-- C ** NOW DETERMINE THE RANKS. C ** THE BASIC ALGORITHM IS TO TAKE A GIVEN ELEMENT C ** IN THE ORIGINAL INPUT VECTOR X, C ** AND SCAN THE SORTED VALUES IN THE XS VECTOR C ** UNTIL A MATCH IS FOUND; C ** WHEN A MATCH IS FOUND, THEN THE RANK FOR THAT C ** VALUE IN THE XS VECTOR IS DETERMINED. C ** THAT RANK IS THEN WRITTEN INTO THAT POSITION C ** IN THE OUTPUT Y VECTOR WHICH CORRESPONDS TO THE POSITION OF C ** GIVEN ELEMENT OF INTEREST IN THE ORIGINAL X VECTOR. C ** THE CODE IS LENGTHENED FROM THIS BASIC ALGORITHM C ** BY A SECTION WHICH CUTS DOWN THE SEARCH IN THE XS VECTOR, C ** AND BY A SECTION WHICH OBVIATES (UNDER CERTAIN CIRCUMSTANCES C ** THE NEED FOR RECALCULATING THE RANK OF AN ELEMENT IN XS. C **************************************************************** C NM1=N-1 XPREV=X(1) DO700I=1,N JMIN=1 IF(X(I).GT.XPREV)GOTO770 IF(I.EQ.1)GOTO790 IF(X(I).EQ.XPREV)GOTO750 GOTO790 750 CONTINUE XPREV=X(I) XR(I)=RPREV GOTO880 770 CONTINUE JMIN=K IF(JMIN.LT.N)GOTO790 IF(JMIN.EQ.N)GOTO820 C IERROR='YES' IBRAN=1 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,781)IBRAN 781 FORMAT('***** INTERNAL ERROR IN RANK2--', 1'IMPOSSIBLE BRANCH CONDITION AT BRANCH POINT = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,782)JMIN 782 FORMAT('JMIN = ',I8) CALL DPWRST('XXX','BUG ') GOTO9000 C 790 CONTINUE DO800J=JMIN,NM1 IF(X(I).NE.XS(J))GOTO800 JP1=J+1 DO900K=JP1,N IF(XS(K).NE.XS(J))GOTO950 900 CONTINUE K=N+1 950 CONTINUE AVRANK=J+K-1 AVRANK=AVRANK/2.0 XPREV=X(I) XR(I)=AVRANK GOTO880 800 CONTINUE 820 CONTINUE J=N K=N+1 IF(X(I).EQ.XS(J))GOTO850 C IERROR='YES' IBRAN=2 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,881)IBRAN 881 FORMAT('***** INTERNAL ERROR IN RANK2--', 1'IMPOSSIBLE BRANCH CONDITION AT BRANCH POINT = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,882)X(I),XS(I) 882 FORMAT('X(I) = ',E15.7,' XS(J) = ',E15.7) CALL DPWRST('XXX','BUG ') GOTO9000 C 850 CONTINUE XPREV=X(I) XR(I)=N 880 CONTINUE RPREV=XR(I) 700 CONTINUE C XMIN=XS(1) XMAX=XS(N) CCCCC RKXMIN=XR(1) CCCCC RKXMAX=XR(1) CCCCC DO910I=1,N CCCCC IF(XR(I).LT.RKXMIN)RKXMIN=XR(I) CCCCC IF(XR(I).GT.RKXMAX)RKXMAX=XR(I) CC910 CONTINUE C C ****************************** C ** STEP 4-- ** C ** WRITE OUT A FEW LINES ** C ** OF SUMMARY INFORMATION ** C ** ABOUT THE CODING. ** C ****************************** C IF(IFEEDB.EQ.'OFF')GOTO990 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') AI=1 WRITE(ICOUT,912)XS(1),AI 912 FORMAT('THE MINIMUM (= ',E15.7,' ) HAS RANK ',F10.0) CALL DPWRST('XXX','BUG ') AI=N WRITE(ICOUT,913)XS(N),AI 913 FORMAT('THE MAXIMUM (= ',E15.7,' ) HAS RANK ',F10.0) CALL DPWRST('XXX','BUG ') 990 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 RANK2--') 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 ') DO9015I=1,N WRITE(ICOUT,9016)I,X(I),XR(I),XS(I) 9016 FORMAT('I,X(I),XR(I),XS(I) = ',I8,3E15.7) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE RANKCM(X,Y,N,IWRITE,XTEMP,YTEMP,MAXNXT,XYRACM, 1IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C RANK COMOVEMENT 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--XYRACM = THE SINGLE PRECISION VALUE OF THE C COMPUTED RANK COMOVEMENT C COEFFICIENT BETWEEN THE 2 SETS OF DATA C 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 RANK COMOVEMENT COEFFICIENT BETWEEN THE 2 SETS C OF DATA IN THE INPUT VECTORS X AND Y. C OTHER DATAPAC SUBROUTINES NEEDED--RANK AND SORT. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--AN INDEX FOR COMOVEMENT OF TIME SEQUENCES C WITH GEOPHYSICAL APPLICATIONS: A WORKING PAPER C (PENN STATE INTERFACE CONFERANCE ON ASTRONOMY C AUGUST 11-14, 1991) 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 (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--91.8 C ORIGINAL VERSION--AUGUST 1991. 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 DOUBLE PRECISION DN DOUBLE PRECISION DXI DOUBLE PRECISION DXIM1 DOUBLE PRECISION DYI DOUBLE PRECISION DYIM1 DOUBLE PRECISION DDELX DOUBLE PRECISION DDELY DOUBLE PRECISION DSUMX DOUBLE PRECISION DSUMY DOUBLE PRECISION DSUMXY DOUBLE PRECISION DSQRTX DOUBLE PRECISION DSQRTY 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='RANK' ISUBN2='CM ' C IERROR='NO' C DN=0.0D0 DSUMX=0.0D0 DSUMY=0.0D0 DSUMXY=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 RANKCM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N 53 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,X(I),Y(I) 56 FORMAT('I,X(I),Y(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ******************************************** C ** COMPUTE RANK COMOVEMENT COEFFICIENT ** C ******************************************** C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C AN=N C IF(2.LE.N.AND.N.LE.MAXNXT)GOTO119 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN RANKCM--') 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 RANK COMOVEMENT COEFFICIENT IS TO BE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,115)MAXNXT 115 FORMAT(' MUST BE BETWEEN 2 AND ',I8,' (INCLUSIVELY).') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,116) 116 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,117)N 117 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 1'.') CALL DPWRST('XXX','BUG ') GOTO9000 119 CONTINUE C IF(N.EQ.2)GOTO120 GOTO129 120 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,121) 121 FORMAT('***** NON-FATAL DIAGNOSTIC IN RANKCM--', 1'THE THIRD INPUT ARGUMENT (N) HAS THE VALUE 2') CALL DPWRST('XXX','BUG ') XYRACM=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 RANKCM--', 1'THE 1ST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','BUG ') XYRACM=0.0 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 RANKCM--', 1'THE 2ND INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','BUG ') XYRACM=0.0 GOTO9000 149 CONTINUE C 190 CONTINUE C C ************************************************* C ** STEP 2-- ** C ** COMPUTE THE RANK COMOVEMENT COEFFICIENT. ** C ************************************************* C IWRIT2=IBUGA3 CALL RANK(X,N,IWRIT2,XTEMP,IBUGA3,IERROR) CALL RANK(Y,N,IWRIT2,YTEMP,IBUGA3,IERROR) C DN=N DSUMX=0.0D0 DSUMY=0.0D0 DSUMXY=0.0D0 DO300I=2,N IM1=I-1 DXI=XTEMP(I) DXIM1=XTEMP(IM1) DDELX=DXI-DXIM1 DYI=YTEMP(I) DYIM1=YTEMP(IM1) DDELY=DYI-DYIM1 DSUMX=DSUMX+DDELX**2 DSUMY=DSUMY+DDELY**2 DSUMXY=DSUMXY+DDELX*DDELY 300 CONTINUE DSQRTX=0.0 IF(DSUMX.GT.0.0D0)DSQRTX=DSQRT(DSUMX) DSQRTY=0.0 IF(DSUMY.GT.0.0D0)DSQRTY=DSQRT(DSUMY) XYRACM=DSUMXY/(DSQRTX*DSQRTY) 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,XYRACM 811 FORMAT('THE RANK COMOVEMENT 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.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF RANKCM--') 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)DN,DSUMX,DSUMY,DSUMXY 9014 FORMAT('DN,DSUMX,DSUMY,DSUMXY = ',4D15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)XYRACM 9015 FORMAT('XYRACM = ',E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE RANKCR(X,Y,N,IWRITE,XTEMP,YTEMP,MAXNXT,XYRACR, 1IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C SPEARMAN RANK CORRELATION 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--XYRACR = THE SINGLE PRECISION VALUE OF THE C COMPUTED SPEARMAN RANK CORRELATION C COEFFICIENT BETWEEN THE 2 SETS OF DATA C 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 SPEARMAN RANK CORRELATION COEFFICIENT BETWEEN THE 2 SETS C OF DATA IN THE INPUT VECTORS X AND Y. C OTHER DATAPAC SUBROUTINES NEEDED--RANK AND SORT. C FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--KENDALL AND STUART, THE ADVANCED THEORY OF C STATISTICS, VOLUME 2, EDITION 1, 1961, PAGES 476-477. C --SNEDECOR AND COCHRAN, STATISTICAL METHODS, C EDITION 6, 1967, PAGES 193-195. C --DIXON AND MASSEY, INTRODUCTION TO STATISTICAL C ANALYSIS, EDITION 2, 1957, PAGES 294-295. C --MOOD AND GRABLE, 'INTRODUCTION TO THE THEORY C OF STATISTICS, EDITION 2, 1963, PAGE 424. 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 (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 --OCTOBER 1974. C UPDATED --JANUARY 1975. C UPDATED --SEPTEMBER 1975. C UPDATED --NOVEMBER 1975. C UPDATED --FEBRUARY 1976. C UPDATED --JUNE 1979. C UPDATED --JULY 1979. C UPDATED --JULY 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 IWRIT2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DOUBLE PRECISION DN DOUBLE PRECISION DX1 DOUBLE PRECISION DX2 DOUBLE PRECISION DSUM1 DOUBLE PRECISION DSUM2 DOUBLE PRECISION DSUM12 DOUBLE PRECISION DMEAN1 DOUBLE PRECISION DMEAN2 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='RANK' ISUBN2='CR ' C IERROR='NO' C DN=0.0D0 DMEAN1=0.0D0 DMEAN2=0.0D0 DSUM12=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 RANKCR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N 53 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,X(I),Y(I) 56 FORMAT('I,X(I),Y(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ******************************************** C ** COMPUTE RANK 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.MAXNXT)GOTO119 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN RANKCR--') 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 RANK CORRELATION COEFFICIENT IS TO BE') 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 RANKCR--', 1'THE THIRD INPUT ARGUMENT (N) HAS THE VALUE 1') CALL DPWRST('XXX','BUG ') XYRACR=1.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 RANKCR--', 1'THE 1ST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','BUG ') XYRACR=1.0 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 RANKCR--', 1'THE 2ND INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','BUG ') XYRACR=1.0 GOTO9000 149 CONTINUE C 190 CONTINUE C C ************************************************* C ** STEP 2-- ** C ** COMPUTE THE RANK CORRELATION COEFFICIENT. ** C ************************************************* C IWRIT2=IBUGA3 CALL RANK(X,N,IWRIT2,XTEMP,IBUGA3,IERROR) CALL RANK(Y,N,IWRIT2,YTEMP,IBUGA3,IERROR) C DN=N DSUM1=0.0D0 DSUM2=0.0D0 DO200I=1,N DX1=XTEMP(I) DX2=YTEMP(I) DSUM1=DSUM1+DX1 DSUM2=DSUM2+DX2 200 CONTINUE DMEAN1=DSUM1/DN DMEAN2=DSUM2/DN C DSUM1=0.0D0 DSUM2=0.0D0 DSUM12=0.0D0 DO300I=1,N DX1=XTEMP(I) DX2=YTEMP(I) DSUM1=DSUM1+(DX1-DMEAN1)*(DX1-DMEAN1) DSUM2=DSUM2+(DX2-DMEAN2)*(DX2-DMEAN2) DSUM12=DSUM12+(DX1-DMEAN1)*(DX2-DMEAN2) 300 CONTINUE DSQRT1=0.0 IF(DSUM1.GT.0.0D0)DSQRT1=DSQRT(DSUM1) DSQRT2=0.0 IF(DSUM2.GT.0.0D0)DSQRT2=DSQRT(DSUM2) XYRACR=DSUM12/(DSQRT1*DSQRT2) 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,XYRACR 811 FORMAT('THE RANK CORRELATION 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.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF RANKCR--') 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)DN,DMEAN1,DMEAN2,DSUM12 9014 FORMAT('DN,DMEAN1,DMEAN2,DSUM12 = ',4D15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)XYRACR 9015 FORMAT('XYRACR = ',E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE RANKCV(X,Y,N,IWRITE,XTEMP,YTEMP,MAXNXT,XYRACV, 1IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C SPEARMAN RANK COVARIANCE 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--XYRACV = THE SINGLE PRECISION VALUE OF THE C COMPUTED SPEARMAN RANK COVARIANCE C COEFFICIENT BETWEEN THE 2 SETS OF DATA C 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 SPEARMAN RANK COVARIANCE COEFFICIENT BETWEEN THE 2 SETS C OF DATA IN THE INPUT VECTORS X AND Y. C OTHER DATAPAC SUBROUTINES NEEDED--RANK AND SORT. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--KENDALL AND STUART, THE ADVANCED THEORY OF C STATISTICS, VOLUME 2, EDITION 1, 1961, PAGES 476-477. C --SNEDECOR AND COCHRAN, STATISTICAL METHODS, C EDITION 6, 1967, PAGES 193-195. C --DIXON AND MASSEY, INTRODUCTION TO STATISTICAL C ANALYSIS, EDITION 2, 1957, PAGES 294-295. C --MOOD AND GRABLE, 'INTRODUCTION TO THE THEORY C OF STATISTICS, EDITION 2, 1963, PAGE 424. 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 (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 --OCTOBER 1974. C UPDATED --JANUARY 1975. C UPDATED --SEPTEMBER 1975. C UPDATED --NOVEMBER 1975. C UPDATED --FEBRUARY 1976. C UPDATED --JUNE 1979. C UPDATED --JULY 1979. C UPDATED --JULY 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 IWRIT2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DOUBLE PRECISION DN DOUBLE PRECISION DX1 DOUBLE PRECISION DX2 DOUBLE PRECISION DSUM1 DOUBLE PRECISION DSUM2 DOUBLE PRECISION DSUM12 DOUBLE PRECISION DMEAN1 DOUBLE PRECISION DMEAN2 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='RANK' ISUBN2='CV ' C IERROR='NO' C DN=0.0D0 DMEAN1=0.0D0 DMEAN2=0.0D0 DSUM12=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 RANKCV--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N 53 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,X(I),Y(I) 56 FORMAT('I,X(I),Y(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ******************************************** C ** COMPUTE RANK COVARIANCE 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.MAXNXT)GOTO119 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN RANKCV--') 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 RANK COVARIANCE COEFFICIENT IS TO BE') 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 RANKCV--', 1'THE THIRD INPUT ARGUMENT (N) HAS THE VALUE 1') CALL DPWRST('XXX','BUG ') XYRACV=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 RANKCV--', 1'THE 1ST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','BUG ') XYRACV=0.0 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 RANKCV--', 1'THE 2ND INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','BUG ') XYRACV=0.0 GOTO9000 149 CONTINUE C 190 CONTINUE C C ************************************************* C ** STEP 2-- ** C ** COMPUTE THE RANK COVARIANCE COEFFICIENT. ** C ************************************************* C IWRIT2=IBUGA3 CALL RANK(X,N,IWRIT2,XTEMP,IBUGA3,IERROR) CALL RANK(Y,N,IWRIT2,YTEMP,IBUGA3,IERROR) C DN=N DSUM1=0.0D0 DSUM2=0.0D0 DO200I=1,N DX1=XTEMP(I) DX2=YTEMP(I) DSUM1=DSUM1+DX1 DSUM2=DSUM2+DX2 200 CONTINUE DMEAN1=DSUM1/DN DMEAN2=DSUM2/DN C DSUM12=0.0D0 DO300I=1,N DX1=XTEMP(I) DX2=YTEMP(I) DSUM12=DSUM12+(DX1-DMEAN1)*(DX2-DMEAN2) 300 CONTINUE XYRACV=DSUM12/DN C C ******************************* C ** STEP 3-- ** C ** WRITE OUT A LINE ** C ** OF SUMMARY INFORMATION. ** C ******************************* C IF(IFEEDB.EQ.'OFF')GOTO890 IF(IWRITE.EQ.'OFF')GOTO890 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,811)N,XYRACV 811 FORMAT('THE RANK COVARIANCE 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.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF RANKCV--') 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)DN,DMEAN1,DMEAN2,DSUM12 9014 FORMAT('DN,DMEAN1,DMEAN2,DSUM12 = ',4D15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)XYRACV 9015 FORMAT('XYRACV = ',E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE RANLUX(RVEC,LENV) C Subtract-and-borrow random number generator proposed by C Marsaglia and Zaman, implemented by F. James with the name C RCARRY in 1991, and later improved by Martin Luescher C in 1993 to produce "Luxury Pseudorandom Numbers". C Fortran 77 coded by F. James, 1993 C C references: C M. Luscher, Computer Physics Communications 79 (1994) 100 C F. James, Computer Physics Communications 79 (1994) 111 C C LUXURY LEVELS. C ------ ------ The available luxury levels are: C C level 0 (p=24): equivalent to the original RCARRY of Marsaglia C and Zaman, very long period, but fails many tests. C level 1 (p=48): considerable improvement in quality over level 0, C now passes the gap test, but still fails spectral test. C level 2 (p=97): passes all known tests, but theoretically still C defective. C level 3 (p=223): DEFAULT VALUE. Any theoretically possible C correlations have very small chance of being observed. C level 4 (p=389): highest possible luxury, all 24 bits chaotic. C C!!! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C!!! Calling sequences for RANLUX: ++ C!!! CALL RANLUX (RVEC, LEN) returns a vector RVEC of LEN ++ C!!! 32-bit random floating point numbers between ++ C!!! zero (not included) and one (also not incl.). ++ C!!! CALL RLUXGO(LUX,INT,K1,K2) initializes the generator from ++ C!!! one 32-bit integer INT and sets Luxury Level LUX ++ C!!! which is integer between zero and MAXLEV, or if ++ C!!! LUX .GT. 24, it sets p=LUX directly. K1 and K2 ++ C!!! should be set to zero unless restarting at a break++ C!!! point given by output of RLUXAT (see RLUXAT). ++ C!!! CALL RLUXAT(LUX,INT,K1,K2) gets the values of four integers++ C!!! which can be used to restart the RANLUX generator ++ C!!! at the current point by calling RLUXGO. K1 and K2++ C!!! specify how many numbers were generated since the ++ C!!! initialization with LUX and INT. The restarting ++ C!!! skips over K1+K2*E9 numbers, so it can be long.++ C!!! A more efficient but less convenient way of restarting is by: ++ C!!! CALL RLUXIN(ISVEC) restarts the generator from vector ++ C!!! ISVEC of 25 32-bit integers (see RLUXUT) ++ C!!! CALL RLUXUT(ISVEC) outputs the current values of the 25 ++ C!!! 32-bit integer seeds, to be used for restarting ++ C!!! ISVEC must be dimensioned 25 in the calling program ++ C!!! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C MAY 2003: MODIFIED SLIGHTLY FOR INCORPORATION INTO DATAPLOT. C MOSTLY JUST THE I/O. C DIMENSION RVEC(LENV) DIMENSION SEEDS(24), ISEEDS(24), ISDEXT(25) PARAMETER (MAXLEV=4, LXDFLT=3) DIMENSION NDSKIP(0:MAXLEV) DIMENSION NEXT(24) PARAMETER (TWOP12=4096., IGIGA=1000000000,JSDFLT=314159265) PARAMETER (ITWO24=2**24, ICONS=2147483563) SAVE NOTYET, I24, J24, CARRY, SEEDS, TWOM24, TWOM12, LUXLEV SAVE NSKIP, NDSKIP, IN24, NEXT, KOUNT, MKOUNT, INSEED INTEGER LUXLEV LOGICAL NOTYET C CHARACTER*4 IFEEDB CHARACTER*4 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 NOTYET, LUXLEV, IN24, KOUNT, MKOUNT /.TRUE., LXDFLT, 0,0,0/ DATA I24,J24,CARRY/24,10,0./ C default C Luxury Level 0 1 2 *3* 4 DATA NDSKIP/0, 24, 73, 199, 365 / Corresponds to p=24 48 97 223 389 C time factor 1 2 3 6 10 on slow workstation C 1 1.5 2 3 5 on fast mainframe C C NOTYET is .TRUE. if no initialization has been performed yet. C Default Initialization by Multiplicative Congruential IF (NOTYET) THEN NOTYET = .FALSE. JSEED = JSDFLT INSEED = JSEED CCCCC WRITE(6,'(A,I12)') ' RANLUX DEFAULT INITIALIZATION: ',JSEED LUXLEV = LXDFLT NSKIP = NDSKIP(LUXLEV) LP = NSKIP + 24 IN24 = 0 KOUNT = 0 MKOUNT = 0 CCCCC WRITE(6,'(A,I2,A,I4)') ' RANLUX DEFAULT LUXURY LEVEL = ', CCCCC+ LUXLEV,' p =',LP TWOM24 = 1. DO 25 I= 1, 24 TWOM24 = TWOM24 * 0.5 K = JSEED/53668 JSEED = 40014*(JSEED-K*53668) -K*12211 IF (JSEED .LT. 0) JSEED = JSEED+ICONS ISEEDS(I) = MOD(JSEED,ITWO24) 25 CONTINUE TWOM12 = TWOM24 * 4096. DO 50 I= 1,24 SEEDS(I) = REAL(ISEEDS(I))*TWOM24 NEXT(I) = I-1 50 CONTINUE NEXT(1) = 24 I24 = 24 J24 = 10 CARRY = 0. IF (SEEDS(24) .EQ. 0.) CARRY = TWOM24 ENDIF C C The Generator proper: "Subtract-with-borrow", C as proposed by Marsaglia and Zaman, C Florida State University, March, 1989 C DO 100 IVEC= 1, LENV UNI = SEEDS(J24) - SEEDS(I24) - CARRY IF (UNI .LT. 0.) THEN UNI = UNI + 1.0 CARRY = TWOM24 ELSE CARRY = 0. ENDIF SEEDS(I24) = UNI I24 = NEXT(I24) J24 = NEXT(J24) RVEC(IVEC) = UNI C small numbers (with less than 12 "significant" bits) are "padded". IF (UNI .LT. TWOM12) THEN RVEC(IVEC) = RVEC(IVEC) + TWOM24*SEEDS(J24) C and zero is forbidden in case someone takes a logarithm IF (RVEC(IVEC) .EQ. 0.) RVEC(IVEC) = TWOM24*TWOM24 ENDIF C Skipping to luxury. As proposed by Martin Luscher. IN24 = IN24 + 1 IF (IN24 .EQ. 24) THEN IN24 = 0 KOUNT = KOUNT + NSKIP DO 90 ISK= 1, NSKIP UNI = SEEDS(J24) - SEEDS(I24) - CARRY IF (UNI .LT. 0.) THEN UNI = UNI + 1.0 CARRY = TWOM24 ELSE CARRY = 0. ENDIF SEEDS(I24) = UNI I24 = NEXT(I24) J24 = NEXT(J24) 90 CONTINUE ENDIF 100 CONTINUE KOUNT = KOUNT + LENV IF (KOUNT .GE. IGIGA) THEN MKOUNT = MKOUNT + 1 KOUNT = KOUNT - IGIGA ENDIF RETURN C C Entry to input and float integer seeds from previous run ENTRY RLUXIN(ISDEXT) TWOM24 = 1. DO 195 I= 1, 24 NEXT(I) = I-1 195 TWOM24 = TWOM24 * 0.5 NEXT(1) = 24 TWOM12 = TWOM24 * 4096. CCCCC WRITE(6,'(A)') ' FULL INITIALIZATION OF RANLUX WITH 25 INTEGERS:' CCCCC WRITE(6,'(5X,5I12)') ISDEXT DO 200 I= 1, 24 SEEDS(I) = REAL(ISDEXT(I))*TWOM24 200 CONTINUE CARRY = 0. IF (ISDEXT(25) .LT. 0) CARRY = TWOM24 ISD = IABS(ISDEXT(25)) I24 = MOD(ISD,100) ISD = ISD/100 J24 = MOD(ISD,100) ISD = ISD/100 IN24 = MOD(ISD,100) ISD = ISD/100 LUXLEV = ISD IF (LUXLEV .LE. MAXLEV) THEN NSKIP = NDSKIP(LUXLEV) CCCCC WRITE (6,'(A,I2)') ' RANLUX LUXURY LEVEL SET BY RLUXIN TO: ', CCCCC+ LUXLEV ELSE IF (LUXLEV .GE. 24) THEN NSKIP = LUXLEV - 24 CCCCC WRITE (6,'(A,I5)') ' RANLUX P-VALUE SET BY RLUXIN TO:',LUXLEV ELSE NSKIP = NDSKIP(MAXLEV) WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,201) 201 FORMAT('***** ERROR FROM LUXURY RANDOM NUMBER GENERATOR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,202)LUXLEV 202 FORMAT(' ILLEGAL LUXURY LEVEL: ',I5) CALL DPWRST('XXX','BUG ') CCCCC WRITE (6,'(A,I5)') ' RANLUX ILLEGAL LUXURY RLUXIN: ',LUXLEV LUXLEV = MAXLEV ENDIF INSEED = -1 RETURN C C Entry to ouput seeds as integers ENTRY RLUXUT(ISDEXT) DO 300 I= 1, 24 ISDEXT(I) = INT(SEEDS(I)*TWOP12*TWOP12) 300 CONTINUE ISDEXT(25) = I24 + 100*J24 + 10000*IN24 + 1000000*LUXLEV IF (CARRY .GT. 0.) ISDEXT(25) = -ISDEXT(25) RETURN C C Entry to output the "convenient" restart point ENTRY RLUXAT(LOUT,INOUT,K1,K2) LOUT = LUXLEV INOUT = INSEED K1 = KOUNT K2 = MKOUNT RETURN C C Entry to initialize from one or three integers ENTRY RLUXGO(LUX,INS,K1,K2) IF (LUX .LT. 0) THEN LUXLEV = LXDFLT ELSE IF (LUX .LE. MAXLEV) THEN LUXLEV = LUX ELSE IF (LUX .LT. 24 .OR. LUX .GT. 2000) THEN LUXLEV = MAXLEV CCCCC WRITE (6,'(A,I7)') ' RANLUX ILLEGAL LUXURY RLUXGO: ',LUX WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,301) 301 FORMAT('***** ERROR FROM LUXURY RANDOM NUMBER GENERATOR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,302)LUX 302 FORMAT(' ILLEGAL LUXURY LEVEL: ',I7) CALL DPWRST('XXX','BUG ') ELSE LUXLEV = LUX DO 310 ILX= 0, MAXLEV IF (LUX .EQ. NDSKIP(ILX)+24) LUXLEV = ILX 310 CONTINUE ENDIF IF (LUXLEV .LE. MAXLEV) THEN NSKIP = NDSKIP(LUXLEV) CCCCC WRITE(6,'(A,I2,A,I4)') ' RANLUX LUXURY LEVEL SET BY RLUXGO :', CCCCC+ LUXLEV,' P=', NSKIP+24 ELSE NSKIP = LUXLEV - 24 CCCCC WRITE (6,'(A,I5)') ' RANLUX P-VALUE SET BY RLUXGO TO:',LUXLEV ENDIF IN24 = 0 IF (INS .LT. 0) THEN CCCCC WRITE (6,'(A)') CCCCC+ ' Illegal initialization by RLUXGO, negative input seed' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,401) 401 FORMAT('***** ERROR FROM LUXURY RANDOM NUMBER GENERATOR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,402) 402 FORMAT(' NEGATIVE INPUT SEED: ') CALL DPWRST('XXX','BUG ') ENDIF IF (INS .GT. 0) THEN JSEED = INS CCCCC WRITE(6,'(A,3I12)') ' RANLUX INITIALIZED BY RLUXGO FROM SEEDS', CCCCC+ JSEED, K1,K2 ELSE JSEED = JSDFLT CCCCC WRITE(6,'(A)')' RANLUX INITIALIZED BY RLUXGO FROM DEFAULT SEED' ENDIF INSEED = JSEED NOTYET = .FALSE. TWOM24 = 1. DO 325 I= 1, 24 TWOM24 = TWOM24 * 0.5 K = JSEED/53668 JSEED = 40014*(JSEED-K*53668) -K*12211 IF (JSEED .LT. 0) JSEED = JSEED+ICONS ISEEDS(I) = MOD(JSEED,ITWO24) 325 CONTINUE TWOM12 = TWOM24 * 4096. DO 350 I= 1,24 SEEDS(I) = REAL(ISEEDS(I))*TWOM24 NEXT(I) = I-1 350 CONTINUE NEXT(1) = 24 I24 = 24 J24 = 10 CARRY = 0. IF (SEEDS(24) .EQ. 0.) CARRY = TWOM24 C If restarting at a break point, skip K1 + IGIGA*K2 C Note that this is the number of numbers delivered to C the user PLUS the number skipped (if luxury .GT. 0). KOUNT = K1 MKOUNT = K2 IF (K1+K2 .NE. 0) THEN DO 500 IOUTER= 1, K2+1 INNER = IGIGA IF (IOUTER .EQ. K2+1) INNER = K1 DO 450 ISK= 1, INNER UNI = SEEDS(J24) - SEEDS(I24) - CARRY IF (UNI .LT. 0.) THEN UNI = UNI + 1.0 CARRY = TWOM24 ELSE CARRY = 0. ENDIF SEEDS(I24) = UNI I24 = NEXT(I24) J24 = NEXT(J24) 450 CONTINUE 500 CONTINUE C Get the right value of IN24 by direct calculation IN24 = MOD(KOUNT, NSKIP+24) IF (MKOUNT .GT. 0) THEN IZIP = MOD(IGIGA, NSKIP+24) IZIP2 = MKOUNT*IZIP + IN24 IN24 = MOD(IZIP2, NSKIP+24) ENDIF C Now IN24 had better be between zero and 23 inclusive IF (IN24 .GT. 23) THEN CCCCC WRITE (6,'(A/A,3I11,A,I5)') CCCCC+ ' Error in RESTARTING with RLUXGO:',' The values', INS, CCCCC+ K1, K2, ' cannot occur at luxury level', LUXLEV IN24 = 0 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,501) 501 FORMAT('***** ERROR FROM LUXURY RANDOM NUMBER GENERATOR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,502) 502 FORMAT(' ERROR IN RESTARTING WITH RLUXG0:') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,503)INS,K1,K2 503 FORMAT(' THE VALUES ',3I11) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,504)LUXLEV 504 FORMAT(' CANNOT OCCUR AT LUXURY LEVEL ',I5) CALL DPWRST('XXX','BUG ') ENDIF ENDIF C RETURN END SUBROUTINE RANMVN( N, LOWER, UPPER, INFIN, CORREL, MAXPTS, & ABSEPS, RELEPS, ERROR, VALUE, INFORM ) * * A subroutine for computing multivariate normal probabilities. * This subroutine uses the Monte-Carlo 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 taken. 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, MPT, INFORM, INFIS, IVLS DOUBLE PRECISION & CORREL(*), LOWER(*), UPPER(*), MVNFNC, & ABSEPS, RELEPS, ERROR, VALUE, D, E, EPS, MVNNIT IF ( N .GT. 100 .OR. N .LT. 1 ) THEN INFORM = 2 VALUE = 0 ERROR = 1 RETURN ENDIF 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 then Monte-Carlo integration subroutine * MPT = 25 + 10*N CALL RCRUDE(N-INFIS-1, MPT, MVNFNC, ERROR, VALUE, 0) IVLS = MPT 10 EPS = MAX( ABSEPS, RELEPS*ABS(VALUE) ) IF ( ERROR .GT. EPS .AND. IVLS .LT. MAXPTS ) THEN MPT = MAX( MIN( INT(MPT*(ERROR/(EPS))**2), & MAXPTS-IVLS ), 10 ) CALL RCRUDE(N-INFIS-1, MPT, MVNFNC, ERROR, VALUE, 1) IVLS = IVLS + MPT GO TO 10 ENDIF IF ( ERROR. GT. EPS .AND. IVLS .GE. MAXPTS ) INFORM = 1 ENDIF C RETURN END SUBROUTINE RANMVT(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 taken. 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, MPT, IVLS DOUBLE PRECISION CORREL(*), LOWER(*), UPPER(*), * ABSEPS, RELEPS, EPS, 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.0D0 ELSE IF ( N-INFIS .EQ. 1 ) THEN VALUE = E - D ERROR = 2E-16 ELSE * * Call the Monte-Carlo integration subroutine * MPT = 25 + 10*N*N CALL RCRUDE(N-INFIS-1, MPT, FNCMVT, ERROR, VALUE, 0) IVLS = MPT 10 EPS = MAX( ABSEPS, RELEPS*ABS(VALUE) ) IF ( ERROR .GT. EPS .AND. IVLS .LT. MAXPTS ) THEN MPT = MAX(MIN( INT(MPT*(ERROR/(EPS))**2), MAXPTS-IVLS ), 10) CALL RCRUDE(N-INFIS-1, MPT, FNCMVT, ERROR, VALUE, 1) IVLS = IVLS + MPT GO TO 10 ENDIF IF ( ERROR. GT. EPS .AND. IVLS .GE. MAXPTS ) INFORM = 1 ENDIF C RETURN END SUBROUTINE RANPER(N,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM PERMUTATION OF SIZE N C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF ITEMS IN THE PERMUTATION. C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR C (OF DIMENSION AT LEAST N) C INTO WHICH THE GENERATED C RANDOM PERMUTATION WILL BE PLACED. C OUTPUT--A RANDOM PERMUTATION OF SIZE N C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C NOTE--THE BASIC ALGORITHM WAS ORIGINALLY SUGGESTED C BY DAN LOZIER OF THE NAT. BUR. OF STANDARDS. 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--89/1 C ORIGINAL VERSION--DECEMBER 1988. C UPDATED --DECEMBER 1989. OUTER LOOP+ FOR MORE RANDOMNESS C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*) C CCCCC THE FOLLOWING DIMENSION WAS CHANGED DECEMBER 1989 CCCCC DIMENSION U(2) DIMENSION U(10) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C AN=N 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'RANPER SUBROUTINE IS NON-POSITIVE *****') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') C C GENERATE A RANDOM PERMUTATION OF THE INTEGERS 1 TO N C C START OFF WITH A RANDOM CYCLIC PERMUTATION C CALL UNIRAN(10,ISEED,U) IFUDGE=AN*U(10) IFUDGE=IFUDGE+1 IF(IFUDGE.LE.1)IFUDGE=1 IF(IFUDGE.GE.N)IFUDGE=N DO1100I=1,N IP=I+IFUDGE IF(IP.LE.N)X(I)=IP IF(IP.GT.N)X(I)=IP-N 1100 CONTINUE C CCCCC THE FOLLOWING RANDOM NUMBER OF LOOPS WAS ADDED DECEMBER 1989 CCCCC BECAUSE OF 9 STRINGS OF 1,2 AND OTHER CCCCC CORRELATED PATTERNS THAT DID NOT LOOK "RANDOM ENOUGH" C NREP=2 AREP=NREP CALL UNIRAN(NREP,ISEED,U) NLOOP=AREP*U(NREP) NLOOP=NLOOP+1 IF(NLOOP.LE.1)NLOOP=1 IF(NLOOP.GE.NREP)NLOOP=NREP C CCCCC THE FOLLOWING "TRASHING" OF RANDOM NUMBERS WAS ADDED DECEMBER 1989 CCCCC BECAUSE OF 9 STRINGS OF 1,2 AND OTHER CCCCC CORRELATED PATTERNS THAT DID NOT LOOK "RANDOM ENOUGH" C DO1150ILOOP=1,NLOOP CALL UNIRAN(10,ISEED,U) 1150 CONTINUE C CCCCC THE FOLLOWING OUTER LOOP WAS ADDED DECEMBER 1989 CCCCC BECAUSE OF 9 STRINGS OF 1,2 AND OTHER CCCCC CORRELATED PATTERNS THAT DID NOT LOOK "RANDOM ENOUGH" C DO1200ILOOP=1,NLOOP DO1300I=1,N CCCCC THE FOLLOWING CALL WAS CHANGED DECEMBER 1989 CCCCC CALL UNIRAN(1,ISEED,U) CALL UNIRAN(NREP,ISEED,U) CCCCC THE FOLLOWING LINE WAS CHANGED DECEMBER 1989 CCCCC U1=U(1) U1=U(ILOOP) PROD=AN*U1 IPROD=PROD INDEX=IPROD+1 IF(INDEX.LT.1)INDEX=1 IF(INDEX.GT.N)INDEX=N HOLD1=X(I) HOLD2=X(INDEX) X(I)=HOLD2 X(INDEX)=HOLD1 CCCCC WRITE(6,777)ISEED,U1 CC777 FORMAT('ISEED,U1 = ',I8,F10.4) 1300 CONTINUE 1200 CONTINUE C 8000 CONTINUE CALL UNIRAN(5,ISEED,U) IFUDGE=AN*U(5) IFUDGE=IFUDGE+1 IF(IFUDGE.LE.1)IFUDGE=1 IF(IFUDGE.GE.N)IFUDGE=N DO1400I=1,N IXI=X(I)+0.5 IXIP=IXI+IFUDGE IF(IXIP.LE.N)X(I)=IXIP IF(IXIP.GT.N)X(I)=IXIP-N 1400 CONTINUE C 9000 CONTINUE RETURN END SUBROUTINE RAYCDF(X,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE RAYLEIGH DISTRIBUTION. C THIS DISTRIBUTION IS DEFINED FOR NON-NEGATIVE X AND C HAS THE CUMULATIVE DISTRIBUTION FUNCTION C F(X) = 1 - EXP(-0.5*X**2) X > 0 C NOTE THAT THE RAYLEIGH IS A SPECIAL CASE OF THE C FOLLOWING: C 1) A CHI DISTRIBUTION WITH NU = 2 C 2) A WEIBULL DISTRIBUTION WITH GAMMA = 2 AND SCALE C PARAMETER SQRT(2) 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 OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION FUNCTION C VALUE CDF FOR THE RAYLEIGH DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--EXP. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C REFERENCE--JOHNSON, KOTZ, AND BALAKRISHNAN (1994). C "CONTINUOUS UNIVARIATE DISTRIBUTIONS--VOLUME 1", C SECOND EDITION, WILEY, PP. 453, 686. C LANGUAGE--ANSI FORTRAN (1977) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.6 C ORIGINAL VERSION--JUNE 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DCDF 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 C ************************************ C ** STEP 1-- ** C ** COMPUTE THE DENSITY FUNCTION ** C ************************************ C IF(X.LE.0.0)THEN CDF=0.0 ELSE DX=DBLE(X) IF(DX.GE.DSQRT(D1MACH(2)))THEN CDF=1.0 GOTO9000 ENDIF C DCDF=1.0D0 - DEXP(-0.5D0*(DBLE(X)**2)) CDF=REAL(DCDF) ENDIF C 9000 CONTINUE RETURN END SUBROUTINE RAYPDF(X,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE RAYLEIGH DISTRIBUTION. C THIS DISTRIBUTION IS DEFINED FOR NON-NEGATIVE X AND C HAS THE PROBABILITY DENSITY FUNCTION C F(X) = X*EXP(-X**2/2) X > 0 C NOTE THAT THE RAYLEIGH IS A SPECIAL CASE OF THE C FOLLOWING: C 1) A CHI DISTRIBUTION WITH NU = 2 C 2) A WEIBULL DISTRIBUTION WITH GAMMA = 2 AND SCALE C PARAMETER = SQRT(2) C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C X SHOULD BE NON-NEGATIVE. C OUTPUT ARGUMENTS--PDF = THE SINGLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY FUNCTION C VALUE PDF FOR THE RAYLEIGH DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--EXP, LOG. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C REFERENCE--JOHNSON, KOTZ, AND BALAKRISHNAN (1994). C "CONTINUOUS UNIVARIATE DISTRIBUTIONS--VOLUME 1", C SECOND EDITION, WILEY, PP. 453, 686. C LANGUAGE--ANSI FORTRAN (1977) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.6 C ORIGINAL VERSION--JUNE 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DPDF DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 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 C ************************************ C ** STEP 1-- ** C ** COMPUTE THE DENSITY FUNCTION ** C ************************************ C IF(X.LT.0.0)THEN WRITE(ICOUT,8) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)X CALL DPWRST('XXX','WRIT') PDF=0.0 GOTO9000 ENDIF 8 FORMAT('***** ERROR: VALUE OF THE FIRST ARGUMENT TO RAYPDF ', 1 'IS NEGATIVE.') 48 FORMAT(' VALUE OF ARGUMENT IS: ',G15.7) C IF(X.EQ.0.0)THEN PDF=0.0 ELSE DX=DBLE(X) IF(DX.GE.DSQRT(D1MACH(2)))THEN PDF=0.0 GOTO9000 ENDIF C DTERM1=DLOG(DX) DTERM2=-DX*DX/2.0D0 DPDF=DTERM1 + DTERM2 DPDF=DEXP(DPDF) PDF=REAL(DPDF) ENDIF C 9000 CONTINUE RETURN END SUBROUTINE RAYPPF(P,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE RAYLEIGH DISTRIBUTION. C THIS DISTRIBUTION IS DEFINED FOR NON-NEGATIVE X AND C HAS THE PERCENT POINT FUNCTION C G(P) = SQRT(2*LOG(1/(1-P))) 0 <= P < 1 C NOTE THAT THE RAYLEIGH IS A SPECIAL CASE OF THE C FOLLOWING: C 1) A CHI DISTRIBUTION WITH NU = 2 C 2) A WEIBULL DISTRIBUTION WITH GAMMA = 2 AND SCALE C PARAMETER = SQRT(2) C INPUT ARGUMENTS--P = THE SINGLE PRECISION VALUE AT C WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. C 0 <= P < 1. C OUTPUT ARGUMENTS--PPF = THE SINGLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION C VALUE FOR THE RAYLEIGH DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--LOG. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C REFERENCE--JOHNSON, KOTZ, AND BALAKRISHNAN (1994). C "CONTINUOUS UNIVARIATE DISTRIBUTIONS--VOLUME 1", C SECOND EDITION, WILEY, PP. 453, 686. C LANGUAGE--ANSI FORTRAN (1977) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.6 C ORIGINAL VERSION--JUNE 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DP 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 ************************************ C ** STEP 1-- ** C ** COMPUTE THE DENSITY FUNCTION ** C ************************************ C IF(P.LT.0.0 .OR. P.GE.1.0)THEN WRITE(ICOUT,8) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)P CALL DPWRST('XXX','WRIT') PPF=0.0 GOTO9000 ENDIF 8 FORMAT('***** ERROR: VALUE OF THE FIRST ARGUMENT TO RAYPPF ', 1 'IS OUTSIDE THE [0,1) INTERVAL.') 48 FORMAT(' VALUE OF ARGUMENT IS: ',G15.7) IF(P.EQ.0.0)THEN PPF=0.0 ELSE DP=DBLE(P) DPPF=DSQRT(2.0D0*DLOG(1.0D0/(1.0D0-DP))) PPF=REAL(DPPF) ENDIF C 9000 CONTINUE RETURN END SUBROUTINE RAYRAN(N,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE RAYLEIGH DISTRIBUTION. C THIS DISTRIBUTION IS DEFINED FOR NON-NEGATIVE X AND HAS C THE PROBABILITY DENSITY FUNCTION C F(X) = X*EXP(-X**2/2) C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR C (OF DIMENSION AT LEAST N) C INTO WHICH THE GENERATED C RANDOM SAMPLE WILL BE PLACED. C OUTPUT--A RANDOM SAMPLE OF SIZE N C FROM THE RAYLEIGH DISTRIBUTION C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCE--JOHNSON, KOTZ, AND BALAKRISHNAN (1994). C "CONTINUOUS UNIVARIATE DISTRIBUTIONS--VOLUME 1", C SECOND EDITION, WILEY, P. 453. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATION INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRMAXMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.6 C ORIGINAL VERSION--JUNE 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*) C DOUBLE PRECISION DP DOUBLE PRECISION DPPF C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF C 5 FORMAT('***** ERROR--FOR THE RAYLEIGH DISTRIBUTION, THE') 6 FORMAT(' REQUESTED NUMBER OF RANDOM NUMBERS WAS ', 1 'NON-POSITIVE.') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,'.') 48 FORMAT(' VALUE OF ARGUMENT IS: ',G15.7) C C USE PERCENT POINT TRANSFORMATION METHOD. C CALL UNIRAN(N,ISEED,X) DO100I=1,N DP=DBLE(X(I)) DPPF=DSQRT(2.0D0*DLOG(1.0D0/(1.0D0-DP))) X(I)=REAL(DPPF) 100 CONTINUE C 9999 CONTINUE RETURN END REAL FUNCTION RC (X, Y, IER) C***BEGIN PROLOGUE RC C***PURPOSE Calculate an approximation to C RC(X,Y) = Integral from zero to infinity of C -1/2 -1 C (1/2)(t+X) (t+Y) dt, C where X is nonnegative and Y is positive. C***LIBRARY SLATEC C***CATEGORY C14 C***TYPE SINGLE PRECISION (RC-S, DRC-D) C***KEYWORDS DUPLICATION THEOREM, ELEMENTARY FUNCTIONS, C ELLIPTIC INTEGRAL, TAYLOR SERIES C***AUTHOR Carlson, B. C. C Ames Laboratory-DOE C Iowa State University C Ames, IA 50011 C Notis, E. M. C Ames Laboratory-DOE C Iowa State University C Ames, IA 50011 C Pexton, R. L. C Lawrence Livermore National Laboratory C Livermore, CA 94550 C***DESCRIPTION C C 1. RC C Standard FORTRAN function routine C Single precision version C The routine calculates an approximation to C RC(X,Y) = Integral from zero to infinity of C C -1/2 -1 C (1/2)(t+X) (t+Y) dt, C C where X is nonnegative and Y is positive. The duplication C theorem is iterated until the variables are nearly equal, C and the function is then expanded in Taylor series to fifth C order. Logarithmic, inverse circular, and inverse hyper- C bolic functions can be expressed in terms of RC. C C C 2. Calling Sequence C RC( X, Y, IER ) C C Parameters on Entry C Values assigned by the calling routine C C X - Single precision, nonnegative variable C C Y - Single precision, positive variable C C C C On Return (values assigned by the RC routine) C C RC - Single precision approximation to the integral C C IER - Integer to indicate normal or abnormal termination. C C IER = 0 Normal and reliable termination of the C routine. It is assumed that the requested C accuracy has been achieved. C C IER > 0 Abnormal termination of the routine C C X and Y are unaltered. C C C 3. Error Messages C C Value of IER assigned by the RC routine C C Value Assigned Error Message Printed C IER = 1 X.LT.0.0E0.OR.Y.LE.0.0E0 C = 2 X+Y.LT.LOLIM C = 3 MAX(X,Y) .GT. UPLIM C C C 4. Control Parameters C C Values of LOLIM, UPLIM, and ERRTOL are set by the C routine. C C LOLIM and UPLIM determine the valid range of X and Y C C LOLIM - Lower limit of valid arguments C C Not less than 5 * (machine minimum) . C C UPLIM - Upper limit of valid arguments C C Not greater than (machine maximum) / 5 . C C C Acceptable values for: LOLIM UPLIM C IBM 360/370 SERIES : 3.0E-78 1.0E+75 C CDC 6000/7000 SERIES : 1.0E-292 1.0E+321 C UNIVAC 1100 SERIES : 1.0E-37 1.0E+37 C CRAY : 2.3E-2466 1.09E+2465 C VAX 11 SERIES : 1.5E-38 3.0E+37 C C ERRTOL determines the accuracy of the answer C C The value assigned by the routine will result C in solution precision within 1-2 decimals of C "machine precision". C C C ERRTOL - Relative error due to truncation is less than C 16 * ERRTOL ** 6 / (1 - 2 * ERRTOL). C C C The accuracy of the computed approximation to the inte- C gral can be controlled by choosing the value of ERRTOL. C Truncation of a Taylor series after terms of fifth order C introduces an error less than the amount shown in the C second column of the following table for each value of C ERRTOL in the first column. In addition to the trunca- C tion error there will be round-off error, but in prac- C tice the total error from both sources is usually less C than the amount given in the table. C C C C Sample Choices: ERRTOL Relative Truncation C error less than C 1.0E-3 2.0E-17 C 3.0E-3 2.0E-14 C 1.0E-2 2.0E-11 C 3.0E-2 2.0E-8 C 1.0E-1 2.0E-5 C C C Decreasing ERRTOL by a factor of 10 yields six more C decimal digits of accuracy at the expense of one or C two more iterations of the duplication theorem. C C *Long Description: C C RC Special Comments C C C C C Check: RC(X,X+Z) + RC(Y,Y+Z) = RC(0,Z) C C where X, Y, and Z are positive and X * Y = Z * Z C C C On Input: C C X and Y are the variables in the integral RC(X,Y). C C On Output: C C X and Y are unaltered. C C C C RC(0,1/4)=RC(1/16,1/8)=PI=3.14159... C C RC(9/4,2)=LN(2) C C C C ******************************************************** C C Warning: Changes in the program may improve speed at the C expense of robustness. C C C -------------------------------------------------------------------- C C Special Functions via RC C C C C LN X X .GT. 0 C C 2 C LN(X) = (X-1) RC(((1+X)/2) , X ) C C C -------------------------------------------------------------------- C C ARCSIN X -1 .LE. X .LE. 1 C C 2 C ARCSIN X = X RC (1-X ,1 ) C C -------------------------------------------------------------------- C C ARCCOS X 0 .LE. X .LE. 1 C C C 2 2 C ARCCOS X = SQRT(1-X ) RC(X ,1 ) C C -------------------------------------------------------------------- C C ARCTAN X -INF .LT. X .LT. +INF C C 2 C ARCTAN X = X RC(1,1+X ) C C -------------------------------------------------------------------- C C ARCCOT X 0 .LE. X .LT. INF C C 2 2 C ARCCOT X = RC(X ,X +1 ) C C -------------------------------------------------------------------- C C ARCSINH X -INF .LT. X .LT. +INF C C 2 C ARCSINH X = X RC(1+X ,1 ) C C -------------------------------------------------------------------- C C ARCCOSH X X .GE. 1 C C 2 2 C ARCCOSH X = SQRT(X -1) RC(X ,1 ) C C -------------------------------------------------------------------- C C ARCTANH X -1 .LT. X .LT. 1 C C 2 C ARCTANH X = X RC(1,1-X ) C C -------------------------------------------------------------------- C C ARCCOTH X X .GT. 1 C C 2 2 C ARCCOTH X = RC(X ,X -1 ) C C -------------------------------------------------------------------- C C***REFERENCES B. C. Carlson and E. M. Notis, Algorithms for incomplete C elliptic integrals, ACM Transactions on Mathematical C Software 7, 3 (September 1981), pp. 398-403. C B. C. Carlson, Computing elliptic integrals by C duplication, Numerische Mathematik 33, (1979), C pp. 1-16. C B. C. Carlson, Elliptic integrals of the first kind, C SIAM Journal of Mathematical Analysis 8, (1977), C pp. 231-242. C***ROUTINES CALLED R1MACH, XERMSG C***REVISION HISTORY (YYMMDD) C 790801 DATE WRITTEN C 890531 Changed all specific intrinsics to generic. (WRB) C 891009 Removed unreferenced statement labels. (WRB) C 891009 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 900326 Removed duplicate information from DESCRIPTION section. C (WRB) C 900510 Changed calls to XERMSG to standard form, and some C editorial changes. (RWC)) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE RC 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*16 XERN3, XERN4, XERN5 INTEGER IER REAL C1, C2, ERRTOL, LAMDA, LOLIM REAL MU, S, SN, UPLIM, X, XN, Y, YN LOGICAL FIRST SAVE ERRTOL,LOLIM,UPLIM,C1,C2,FIRST DATA FIRST /.TRUE./ C C***FIRST EXECUTABLE STATEMENT RC IF (FIRST) THEN ERRTOL = (R1MACH(3)/16.0E0)**(1.0E0/6.0E0) LOLIM = 5.0E0 * R1MACH(1) UPLIM = R1MACH(2) / 5.0E0 C C1 = 1.0E0/7.0E0 C2 = 9.0E0/22.0E0 ENDIF FIRST = .FALSE. C C CALL ERROR HANDLER IF NECESSARY. C RC = 0.0E0 IF (X.LT.0.0E0.OR.Y.LE.0.0E0) THEN IER = 1 CCCCC WRITE (XERN3, '(1PE15.6)') X CCCCC WRITE (XERN4, '(1PE15.6)') Y WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9)X CALL DPWRST('XXX','BUG ') WRITE(ICOUT,19)Y CALL DPWRST('XXX','BUG ') RETURN ENDIF 1 FORMAT('***** ERORR FROM RC, EITHER THE FIRST ARGUMENT IS ', * 'NEGATIVE OR THE SECOND ARGUMENT IS NON-POSITIVE ***') 9 FORMAT('***** THE VALUE OF THE FIRST ARGUMENT IS ',E15.8,' *****') 19 FORMAT('***** THE VALUE OF THE SECOND ARGUMENT IS ',E15.8,' ***') C CCCCC IF (MAX(X,Y).GT.UPLIM) THEN IF (X.GT.UPLIM) THEN IER = 3 CCCCC WRITE (XERN3, '(1PE15.6)') X CCCCC WRITE (XERN4, '(1PE15.6)') Y CCCCC WRITE (XERN5, '(1PE15.6)') UPLIM WRITE(ICOUT,2) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9)X CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8)UPLIM CALL DPWRST('XXX','BUG ') RETURN ENDIF 2 FORMAT('***** ERORR FROM RC, THE FIRST INPUT ARGUMENT IS LARGER', * 'THAN THE UPPER LIMIT. *****') IF (Y.GT.UPLIM) THEN IER = 3 WRITE(ICOUT,3) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,19)Y CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8)UPLIM CALL DPWRST('XXX','BUG ') RETURN ENDIF 3 FORMAT('***** ERORR FROM RC, THE SECOND INPUT ARGUMENT IS ', * 'LARGER THAN THE UPPER LIMIT. *****') 8 FORMAT('***** THE VALUE OF THE UPPER LIMIT IS ',E15.8,' *****') C IF (X+Y.LT.LOLIM) THEN IER = 2 CCCCC WRITE (XERN3, '(1PE15.6)') X CCCCC WRITE (XERN4, '(1PE15.6)') Y CCCCC WRITE (XERN5, '(1PE15.6)') LOLIM WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9)X CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9)Y CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7)UPLIM CALL DPWRST('XXX','BUG ') RETURN ENDIF 4 FORMAT('***** ERORR FROM RC, THE SUM OF THE TWO ARGUMENTS IS ', * 'LESS THAN THE LOWER LIMIT. *****') 7 FORMAT('***** THE VALUE OF THE LOWER LIMIT IS ',E15.8,' *****') C IER = 0 XN = X YN = Y C 30 MU = (XN+YN+YN)/3.0E0 SN = (YN+MU)/MU - 2.0E0 IF (ABS(SN).LT.ERRTOL) GO TO 40 LAMDA = 2.0E0*SQRT(XN)*SQRT(YN) + YN XN = (XN+LAMDA)*0.250E0 YN = (YN+LAMDA)*0.250E0 GO TO 30 C 40 S = SN*SN*(0.30E0+SN*(C1+SN*(0.3750E0+SN*C2))) RC = (1.0E0+S)/SQRT(MU) RETURN END SUBROUTINE RCRUDE(NDIM, MAXPTS, FUNCTN, ABSEST, FINEST, IR) * * Crude Monte-Carlo Algorithm with simple antithetic variates * and weighted results on restart * EXTERNAL FUNCTN INTEGER NDIM, MAXPTS, M, K, IR, NPTS DOUBLE PRECISION FINEST, ABSEST, X(100), FUN, FUNCTN, UNI, & VARSQR, VAREST, VARPRD, FINDIF, FINVAL SAVE VAREST IF ( IR .LE. 0 ) THEN VAREST = 0.0D0 FINEST = 0.0D0 ENDIF FINVAL = 0.0D0 VARSQR = 0.0D0 NPTS = MAXPTS/2 DO 100 M = 1,NPTS DO 200 K = 1,NDIM X(K) = UNI() 200 CONTINUE FUN = FUNCTN(NDIM, X) DO 300 K = 1,NDIM X(K) = 1.0D0 - X(K) 300 CONTINUE FUN = ( FUNCTN(NDIM, X) + FUN )/2.0D0 FINDIF = ( FUN - FINVAL )/DBLE(M) VARSQR = DBLE( M - 2 )*VARSQR/DBLE(M) + FINDIF**2 FINVAL = FINVAL + FINDIF 100 CONTINUE VARPRD = VAREST*VARSQR FINEST = FINEST + ( FINVAL - FINEST )/(1.0D0 + VARPRD) IF ( VARSQR .GT. 0.0D0 ) VAREST = (1.0D0 + VARPRD)/VARSQR ABSEST = 3.0D0*SQRT( VARSQR/( 1.0D0 + VARPRD ) ) C RETURN END SUBROUTINE RCSWAP(P, Q, A, B, INFIN, N, C) * * Swaps rows and columns P and Q in situ. * DOUBLE PRECISION A(*), B(*), C(*), T INTEGER INFIN(*), P, Q, N, I, J, II, JJ T = A(P) A(P) = A(Q) A(Q) = T T = B(P) B(P) = B(Q) B(Q) = T J = INFIN(P) INFIN(P) = INFIN(Q) INFIN(Q) = J JJ = (P*(P-1))/2 II = (Q*(Q-1))/2 T = C(JJ+P) C(JJ+P) = C(II+Q) C(II+Q) = T DO 100 J = 1, P-1 T = C(JJ+J) C(JJ+J) = C(II+J) C(II+J) = T 100 CONTINUE JJ = JJ + P DO 200 I = P+1, Q-1 T = C(JJ+P) C(JJ+P) = C(II+I) C(II+I) = T JJ = JJ + I 200 CONTINUE II = II + Q DO 300 I = Q+1, N T = C(II+P) C(II+P) = C(II+Q) C(II+Q) = T II = II + I 300 CONTINUE C RETURN END REAL FUNCTION RD (X, Y, Z, IER) C***BEGIN PROLOGUE RD C***PURPOSE Compute the incomplete or complete elliptic integral of the C 2nd kind. For X and Y nonnegative, X+Y and Z positive, C RD(X,Y,Z) = Integral from zero to infinity of C -1/2 -1/2 -3/2 C (3/2)(t+X) (t+Y) (t+Z) dt. C If X or Y is zero, the integral is complete. C***LIBRARY SLATEC C***CATEGORY C14 C***TYPE SINGLE PRECISION (RD-S, DRD-D) C***KEYWORDS COMPLETE ELLIPTIC INTEGRAL, DUPLICATION THEOREM, C INCOMPLETE ELLIPTIC INTEGRAL, INTEGRAL OF THE SECOND KIND, C TAYLOR SERIES C***AUTHOR Carlson, B. C. C Ames Laboratory-DOE C Iowa State University C Ames, IA 50011 C Notis, E. M. C Ames Laboratory-DOE C Iowa State University C Ames, IA 50011 C Pexton, R. L. C Lawrence Livermore National Laboratory C Livermore, CA 94550 C***DESCRIPTION C C 1. RD C Evaluate an INCOMPLETE (or COMPLETE) ELLIPTIC INTEGRAL C of the second kind C Standard FORTRAN function routine C Single precision version C The routine calculates an approximation result to C RD(X,Y,Z) = Integral from zero to infinity of C -1/2 -1/2 -3/2 C (3/2)(t+X) (t+Y) (t+Z) dt, C where X and Y are nonnegative, X + Y is positive, and Z is C positive. If X or Y is zero, the integral is COMPLETE. C The duplication theorem is iterated until the variables are C nearly equal, and the function is then expanded in Taylor C series to fifth order. C C 2. Calling Sequence C C RD( X, Y, Z, IER ) C C Parameters on Entry C Values assigned by the calling routine C C X - Single precision, nonnegative variable C C Y - Single precision, nonnegative variable C C X + Y is positive C C Z - Real, positive variable C C C C On Return (values assigned by the RD routine) C C RD - Real approximation to the integral C C C IER - Integer C C IER = 0 Normal and reliable termination of the C routine. It is assumed that the requested C accuracy has been achieved. C C IER > 0 Abnormal termination of the routine C C C X, Y, Z are unaltered. C C 3. Error Messages C C Value of IER assigned by the RD routine C C Value Assigned Error Message Printed C IER = 1 MIN(X,Y) .LT. 0.0E0 C = 2 MIN(X + Y, Z ) .LT. LOLIM C = 3 MAX(X,Y,Z) .GT. UPLIM C C C 4. Control Parameters C C Values of LOLIM, UPLIM, and ERRTOL are set by the C routine. C C LOLIM and UPLIM determine the valid range of X, Y, and Z C C LOLIM - Lower limit of valid arguments C C Not less than 2 / (machine maximum) ** (2/3). C C UPLIM - Upper limit of valid arguments C C Not greater than (0.1E0 * ERRTOL / machine C minimum) ** (2/3), where ERRTOL is described below. C In the following table it is assumed that ERRTOL C will never be chosen smaller than 1.0E-5. C C C Acceptable Values For: LOLIM UPLIM C IBM 360/370 SERIES : 6.0E-51 1.0E+48 C CDC 6000/7000 SERIES : 5.0E-215 2.0E+191 C UNIVAC 1100 SERIES : 1.0E-25 2.0E+21 C CRAY : 3.0E-1644 1.69E+1640 C VAX 11 SERIES : 1.0E-25 4.5E+21 C C C ERRTOL determines the accuracy of the answer C C The value assigned by the routine will result C in solution precision within 1-2 decimals of C "machine precision". C C ERRTOL Relative error due to truncation is less than C 3 * ERRTOL ** 6 / (1-ERRTOL) ** 3/2. C C C C The accuracy of the computed approximation to the inte- C gral can be controlled by choosing the value of ERRTOL. C Truncation of a Taylor series after terms of fifth order C introduces an error less than the amount shown in the C second column of the following table for each value of C ERRTOL in the first column. In addition to the trunca- C tion error there will be round-off error, but in prac- C tice the total error from both sources is usually less C than the amount given in the table. C C C C C Sample Choices: ERRTOL Relative Truncation C error less than C 1.0E-3 4.0E-18 C 3.0E-3 3.0E-15 C 1.0E-2 4.0E-12 C 3.0E-2 3.0E-9 C 1.0E-1 4.0E-6 C C C Decreasing ERRTOL by a factor of 10 yields six more C decimal digits of accuracy at the expense of one or C two more iterations of the duplication theorem. C C *Long Description: C C RD Special Comments C C C C Check: RD(X,Y,Z) + RD(Y,Z,X) + RD(Z,X,Y) C = 3 / SQRT(X * Y * Z), where X, Y, and Z are positive. C C C On Input: C C X, Y, and Z are the variables in the integral RD(X,Y,Z). C C C On Output: C C C X, Y, and Z are unaltered. C C C C ******************************************************** C C WARNING: Changes in the program may improve speed at the C expense of robustness. C C C C ------------------------------------------------------------------- C C C Special Functions via RD and RF C C C Legendre form of ELLIPTIC INTEGRAL of 2nd kind C ---------------------------------------------- C C C 2 2 2 C E(PHI,K) = SIN(PHI) RF(COS (PHI),1-K SIN (PHI),1) - C C 2 3 2 2 2 C -(K/3) SIN (PHI) RD(COS (PHI),1-K SIN (PHI),1) C C C 2 2 2 C E(K) = RF(0,1-K ,1) - (K/3) RD(3,1-K ,1) C C C PI/2 2 2 1/2 C = INT (1-K SIN (PHI) ) D PHI C 0 C C C C Bulirsch form of ELLIPTIC INTEGRAL of 2nd kind C ---------------------------------------------- C C 2 2 2 C EL2(X,KC,A,B) = AX RF(1,1+KC X ,1+X ) + C C 3 2 2 2 C +(1/3)(B-A) X RD(1,1+KC X ,1+X ) C C C C Legendre form of alternative ELLIPTIC INTEGRAL of 2nd C ----------------------------------------------------- C kind C ---- C C Q 2 2 2 -1/2 C D(Q,K) = INT SIN P (1-K SIN P) DP C 0 C C C C 3 2 2 2 C D(Q,K) =(1/3)(SIN Q) RD(COS Q,1-K SIN Q,1) C C C C C C Lemniscate constant B C --------------------- C C C C 1 2 4 -1/2 C B = INT S (1-S ) DS C 0 C C C B =(1/3)RD (0,2,1) C C C C C Heuman's LAMBDA function C ------------------------ C C C C (PI/2) LAMBDA0(A,B) = C C 2 2 C = SIN(B) (RF(0,COS (A),1)-(1/3) SIN (A) * C C 2 2 2 2 C *RD(0,COS (A),1)) RF(COS (B),1-COS (A) SIN (B),1) C C 2 3 2 C -(1/3) COS (A) SIN (B) RF(0,COS (A),1) * C C 2 2 2 C *RD(COS (B),1-COS (A) SIN (B),1) C C C C Jacobi ZETA function C -------------------- C C C 2 2 2 2 C Z(B,K) = (K/3) SIN(B) RF(COS (B),1-K SIN (B),1) C C C 2 2 C *RD(0,1-K ,1)/RF(0,1-K ,1) C C 2 3 2 2 2 C -(K /3) SIN (B) RD(COS (B),1-K SIN (B),1) C C C ------------------------------------------------------------------- C C***REFERENCES B. C. Carlson and E. M. Notis, Algorithms for incomplete C elliptic integrals, ACM Transactions on Mathematical C Software 7, 3 (September 1981), pp. 398-403. C B. C. Carlson, Computing elliptic integrals by C duplication, Numerische Mathematik 33, (1979), C pp. 1-16. C B. C. Carlson, Elliptic integrals of the first kind, C SIAM Journal of Mathematical Analysis 8, (1977), C pp. 231-242. C***ROUTINES CALLED R1MACH, XERMSG C***REVISION HISTORY (YYMMDD) C 790801 DATE WRITTEN C 890531 Changed all specific intrinsics to generic. (WRB) C 890531 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 900326 Removed duplicate information from DESCRIPTION section. C (WRB) C 900510 Modify calls to XERMSG to put in standard form. (RWC) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE RD 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*16 XERN3, XERN4, XERN5, XERN6 INTEGER IER REAL LOLIM, UPLIM, EPSLON, ERRTOL REAL C1, C2, C3, C4, EA, EB, EC, ED, EF, LAMDA REAL MU, POWER4, SIGMA, S1, S2, X, XN, XNDEV REAL XNROOT, Y, YN, YNDEV, YNROOT, Z, ZN, ZNDEV, ZNROOT LOGICAL FIRST SAVE ERRTOL, LOLIM, UPLIM, C1, C2, C3, C4, FIRST DATA FIRST /.TRUE./ C C***FIRST EXECUTABLE STATEMENT RD IF (FIRST) THEN ERRTOL = (R1MACH(3)/3.0E0)**(1.0E0/6.0E0) LOLIM = 2.0E0/(R1MACH(2))**(2.0E0/3.0E0) TUPLIM = R1MACH(1)**(1.0E0/3.0E0) TUPLIM = (0.10E0*ERRTOL)**(1.0E0/3.0E0)/TUPLIM UPLIM = TUPLIM**2.0E0 C C1 = 3.0E0/14.0E0 C2 = 1.0E0/6.0E0 C3 = 9.0E0/22.0E0 C4 = 3.0E0/26.0E0 ENDIF FIRST = .FALSE. C C CALL ERROR HANDLER IF NECESSARY. C RD = 0.0E0 IF( MIN(X,Y).LT.0.0E0) THEN IER = 1 CCCCC WRITE (XERN3, '(1PE15.6)') X CCCCC WRITE (XERN4, '(1PE15.6)') Y WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9)X CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8)Y CALL DPWRST('XXX','BUG ') RETURN ENDIF 1 FORMAT('***** ERORR FROM RD, THE MINIMUM OF THE FIRST TWO ', * 'AGRUMENTS IS NEGATIVE. ***') 9 FORMAT('***** THE VALUE OF THE FIRST ARGUMENT IS ',E15.8,' ***') 8 FORMAT('***** THE VALUE OF THE SECOND ARGUMENT IS ',E15.8,' ***') 7 FORMAT('***** THE VALUE OF THE THIRD ARGUMENT IS ',E15.8,' ***') C IF (MAX(X,Y,Z).GT.UPLIM) THEN IER = 3 CCCCC WRITE (XERN3, '(1PE15.6)') X CCCCC WRITE (XERN4, '(1PE15.6)') Y CCCCC WRITE (XERN5, '(1PE15.6)') Z CCCCC WRITE (XERN6, '(1PE15.6)') UPLIM WRITE(ICOUT,2) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9)X CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8)Y CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7)Z CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6)UPLIM CALL DPWRST('XXX','BUG ') RETURN ENDIF 2 FORMAT('***** ERORR FROM RD, ONE OF THE THREE ARGUMENTS EXCEEDS', * ' THE LARGEST ALLOWABLE VALUE. ****') 6 FORMAT('***** THE VALUE OF THE UPPER LIMIT IS ',E15.8,' *****') C IF (MIN(X+Y,Z).LT.LOLIM) THEN IER = 2 CCCCC WRITE (XERN3, '(1PE15.6)') X CCCCC WRITE (XERN4, '(1PE15.6)') Y CCCCC WRITE (XERN5, '(1PE15.6)') Z CCCCC WRITE (XERN6, '(1PE15.6)') LOLIM WRITE(ICOUT,3) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9)X CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8)Y CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7)Z CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5)LOLIM CALL DPWRST('XXX','BUG ') RETURN ENDIF 3 FORMAT('***** ERORR FROM RC, THE MINIMUM OF THE SUM OF THE ', * 'FIRST TWO ARGUMENTS ') 4 FORMAT('AND THE THIRD ARGUMENT IS LESS THAN THE LOWER LIMIT. ') 5 FORMAT('***** THE VALUE OF THE LOWER LIMIT IS ',E15.8,' *****') C IER = 0 XN = X YN = Y ZN = Z SIGMA = 0.0E0 POWER4 = 1.0E0 C 30 MU = (XN+YN+3.0E0*ZN)*0.20E0 XNDEV = (MU-XN)/MU YNDEV = (MU-YN)/MU ZNDEV = (MU-ZN)/MU EPSLON = MAX(ABS(XNDEV), ABS(YNDEV), ABS(ZNDEV)) IF (EPSLON.LT.ERRTOL) GO TO 40 XNROOT = SQRT(XN) YNROOT = SQRT(YN) ZNROOT = SQRT(ZN) LAMDA = XNROOT*(YNROOT+ZNROOT) + YNROOT*ZNROOT SIGMA = SIGMA + POWER4/(ZNROOT*(ZN+LAMDA)) POWER4 = POWER4*0.250E0 XN = (XN+LAMDA)*0.250E0 YN = (YN+LAMDA)*0.250E0 ZN = (ZN+LAMDA)*0.250E0 GO TO 30 C 40 EA = XNDEV*YNDEV EB = ZNDEV*ZNDEV EC = EA - EB ED = EA - 6.0E0*EB EF = ED + EC + EC S1 = ED*(-C1+0.250E0*C3*ED-1.50E0*C4*ZNDEV*EF) S2 = ZNDEV*(C2*EF+ZNDEV*(-C3*EC+ZNDEV*C4*EA)) RD = 3.0E0*SIGMA + POWER4*(1.0E0+S1+S2)/(MU* SQRT(MU)) C RETURN END REAL FUNCTION RF (X, Y, Z, IER) C***BEGIN PROLOGUE RF C***PURPOSE Compute the incomplete or complete elliptic integral of the C 1st kind. For X, Y, and Z non-negative and at most one of C them zero, RF(X,Y,Z) = Integral from zero to infinity of C -1/2 -1/2 -1/2 C (1/2)(t+X) (t+Y) (t+Z) dt. C If X, Y or Z is zero, the integral is complete. C***LIBRARY SLATEC C***CATEGORY C14 C***TYPE SINGLE PRECISION (RF-S, DRF-D) C***KEYWORDS COMPLETE ELLIPTIC INTEGRAL, DUPLICATION THEOREM, C INCOMPLETE ELLIPTIC INTEGRAL, INTEGRAL OF THE FIRST KIND, C TAYLOR SERIES C***AUTHOR Carlson, B. C. C Ames Laboratory-DOE C Iowa State University C Ames, IA 50011 C Notis, E. M. C Ames Laboratory-DOE C Iowa State University C Ames, IA 50011 C Pexton, R. L. C Lawrence Livermore National Laboratory C Livermore, CA 94550 C***DESCRIPTION C C 1. RF C Evaluate an INCOMPLETE (or COMPLETE) ELLIPTIC INTEGRAL C of the first kind C Standard FORTRAN function routine C Single precision version C The routine calculates an approximation result to C RF(X,Y,Z) = Integral from zero to infinity of C C -1/2 -1/2 -1/2 C (1/2)(t+X) (t+Y) (t+Z) dt, C C where X, Y, and Z are nonnegative and at most one of them C is zero. If one of them is zero, the integral is COMPLETE. C The duplication theorem is iterated until the variables are C nearly equal, and the function is then expanded in Taylor C series to fifth order. C C 2. Calling Sequence C RF( X, Y, Z, IER ) C C Parameters on Entry C Values assigned by the calling routine C C X - Single precision, nonnegative variable C C Y - Single precision, nonnegative variable C C Z - Single precision, nonnegative variable C C C C On Return (values assigned by the RF routine) C C RF - Single precision approximation to the integral C C IER - Integer C C IER = 0 Normal and reliable termination of the C routine. It is assumed that the requested C accuracy has been achieved. C C IER > 0 Abnormal termination of the routine C C X, Y, Z are unaltered. C C C 3. Error Messages C C Value of IER assigned by the RF routine C C Value assigned Error Message Printed C IER = 1 MIN(X,Y,Z) .LT. 0.0E0 C = 2 MIN(X+Y,X+Z,Y+Z) .LT. LOLIM C = 3 MAX(X,Y,Z) .GT. UPLIM C C C C 4. Control Parameters C C Values of LOLIM, UPLIM, and ERRTOL are set by the C routine. C C LOLIM and UPLIM determine the valid range of X, Y and Z C C LOLIM - Lower limit of valid arguments C C Not less than 5 * (machine minimum). C C UPLIM - Upper limit of valid arguments C C Not greater than (machine maximum) / 5. C C C Acceptable Values For: LOLIM UPLIM C IBM 360/370 SERIES : 3.0E-78 1.0E+75 C CDC 6000/7000 SERIES : 1.0E-292 1.0E+321 C UNIVAC 1100 SERIES : 1.0E-37 1.0E+37 C CRAY : 2.3E-2466 1.09E+2465 C VAX 11 SERIES : 1.5E-38 3.0E+37 C C C C ERRTOL determines the accuracy of the answer C C The value assigned by the routine will result C in solution precision within 1-2 decimals of C "machine precision". C C C C ERRTOL - Relative error due to truncation is less than C ERRTOL ** 6 / (4 * (1-ERRTOL) . C C C C The accuracy of the computed approximation to the inte- C gral can be controlled by choosing the value of ERRTOL. C Truncation of a Taylor series after terms of fifth order C introduces an error less than the amount shown in the C second column of the following table for each value of C ERRTOL in the first column. In addition to the trunca- C tion error there will be round-off error, but in prac- C tice the total error from both sources is usually less C than the amount given in the table. C C C C C C Sample Choices: ERRTOL Relative Truncation C error less than C 1.0E-3 3.0E-19 C 3.0E-3 2.0E-16 C 1.0E-2 3.0E-13 C 3.0E-2 2.0E-10 C 1.0E-1 3.0E-7 C C C Decreasing ERRTOL by a factor of 10 yields six more C decimal digits of accuracy at the expense of one or C two more iterations of the duplication theorem. C C *Long Description: C C RF Special Comments C C C C Check by addition theorem: RF(X,X+Z,X+W) + RF(Y,Y+Z,Y+W) C = RF(0,Z,W), where X,Y,Z,W are positive and X * Y = Z * W. C C C On Input: C C X, Y, and Z are the variables in the integral RF(X,Y,Z). C C C On Output: C C C X, Y, and Z are unaltered. C C C C ******************************************************** C C Warning: Changes in the program may improve speed at the C expense of robustness. C C C C Special Functions via RF C C C Legendre form of ELLIPTIC INTEGRAL of 1st kind C ---------------------------------------------- C C C 2 2 2 C F(PHI,K) = SIN(PHI) RF(COS (PHI),1-K SIN (PHI),1) C C C 2 C K(K) = RF(0,1-K ,1) C C PI/2 2 2 -1/2 C = INT (1-K SIN (PHI) ) D PHI C 0 C C C C C C Bulirsch form of ELLIPTIC INTEGRAL of 1st kind C ---------------------------------------------- C C C 2 2 2 C EL1(X,KC) = X RF(1,1+KC X ,1+X ) C C C C C Lemniscate constant A C --------------------- C C C 1 4 -1/2 C A = INT (1-S ) DS = RF(0,1,2) = RF(0,2,1) C 0 C C C ------------------------------------------------------------------- C C***REFERENCES B. C. Carlson and E. M. Notis, Algorithms for incomplete C elliptic integrals, ACM Transactions on Mathematical C Software 7, 3 (September 1981), pp. 398-403. C B. C. Carlson, Computing elliptic integrals by C duplication, Numerische Mathematik 33, (1979), C pp. 1-16. C B. C. Carlson, Elliptic integrals of the first kind, C SIAM Journal of Mathematical Analysis 8, (1977), C pp. 231-242. C***ROUTINES CALLED R1MACH, XERMSG C***REVISION HISTORY (YYMMDD) C 790801 DATE WRITTEN C 890531 Changed all specific intrinsics to generic. (WRB) C 891009 Removed unreferenced statement labels. (WRB) C 891009 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 900326 Removed duplicate information from DESCRIPTION section. C (WRB) C 900510 Changed calls to XERMSG to standard form, and some C editorial changes. (RWC)) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE RF 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*16 XERN3, XERN4, XERN5, XERN6 INTEGER IER REAL LOLIM, UPLIM, EPSLON, ERRTOL REAL C1, C2, C3, E2, E3, LAMDA REAL MU, S, X, XN, XNDEV REAL XNROOT, Y, YN, YNDEV, YNROOT, Z, ZN, ZNDEV, * ZNROOT LOGICAL FIRST SAVE ERRTOL,LOLIM,UPLIM,C1,C2,C3,FIRST DATA FIRST /.TRUE./ C C***FIRST EXECUTABLE STATEMENT RF C IF (FIRST) THEN ERRTOL = (4.0E0*R1MACH(3))**(1.0E0/6.0E0) LOLIM = 5.0E0 * R1MACH(1) UPLIM = R1MACH(2)/5.0E0 C C1 = 1.0E0/24.0E0 C2 = 3.0E0/44.0E0 C3 = 1.0E0/14.0E0 ENDIF FIRST = .FALSE. C C CALL ERROR HANDLER IF NECESSARY. C RF = 0.0E0 IF (MIN(X,Y,Z).LT.0.0E0) THEN IER = 1 CCCCC WRITE (XERN3, '(1PE15.6)') X CCCCC WRITE (XERN4, '(1PE15.6)') Y CCCCC WRITE (XERN5, '(1PE15.6)') Z WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9)X CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8)Y CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7)Z CALL DPWRST('XXX','BUG ') RETURN ENDIF 1 FORMAT('***** ERORR FROM RF, ONE OF THE THREE ARGUMENTS IS', * ' NEGATIVE. ***') 9 FORMAT('***** THE VALUE OF THE FIRST ARGUMENT IS ',E15.8,' ***') 8 FORMAT('***** THE VALUE OF THE SECOND ARGUMENT IS ',E15.8,' ***') 7 FORMAT('***** THE VALUE OF THE THIRD ARGUMENT IS ',E15.8,' ***') C IF (MAX(X,Y,Z).GT.UPLIM) THEN IER = 3 CCCCC WRITE (XERN3, '(1PE15.6)') X CCCCC WRITE (XERN4, '(1PE15.6)') Y CCCCC WRITE (XERN5, '(1PE15.6)') Z CCCCC WRITE (XERN6, '(1PE15.6)') UPLIM WRITE(ICOUT,2) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9)X CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8)Y CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7)Z CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6)UPLIM CALL DPWRST('XXX','BUG ') RETURN ENDIF 2 FORMAT('***** ERORR FROM RF, ONE OF THE THREE ARGUMENTS EXCEEDS', * ' THE LARGEST ALLOWABLE VALUE') 6 FORMAT('***** THE VALUE OF THE UPPER LIMIT IS ',E15.8,' *****') C IF (MIN(X+Y,X+Z,Y+Z).LT.LOLIM) THEN IER = 2 CCCCC WRITE (XERN3, '(1PE15.6)') X CCCCC WRITE (XERN4, '(1PE15.6)') Y CCCCC WRITE (XERN5, '(1PE15.6)') Z CCCCC WRITE (XERN6, '(1PE15.6)') LOLIM WRITE(ICOUT,3) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9)X CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8)Y CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7)Z CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5)LOLIM CALL DPWRST('XXX','BUG ') RETURN ENDIF 3 FORMAT('***** ERORR FROM RF, THE MINIMUM OF THE PAIRWISE SUMS ', * 'OF THE ARGUMENTS IS LESS THAN THE LOWER LIMIT.') 5 FORMAT('***** THE VALUE OF THE LOWER LIMIT IS ',E15.8,' *****') C IER = 0 XN = X YN = Y ZN = Z C 30 MU = (XN+YN+ZN)/3.0E0 XNDEV = 2.0E0 - (MU+XN)/MU YNDEV = 2.0E0 - (MU+YN)/MU ZNDEV = 2.0E0 - (MU+ZN)/MU EPSLON = MAX(ABS(XNDEV), ABS(YNDEV), ABS(ZNDEV)) IF (EPSLON.LT.ERRTOL) GO TO 40 XNROOT = SQRT(XN) YNROOT = SQRT(YN) ZNROOT = SQRT(ZN) LAMDA = XNROOT*(YNROOT+ZNROOT) + YNROOT*ZNROOT XN = (XN+LAMDA)*0.250E0 YN = (YN+LAMDA)*0.250E0 ZN = (ZN+LAMDA)*0.250E0 GO TO 30 C 40 E2 = XNDEV*YNDEV - ZNDEV*ZNDEV E3 = XNDEV*YNDEV*ZNDEV S = 1.0E0 + (C1*E2-0.10E0-C2*E3)*E2 + C3*E3 RF = S/SQRT(MU) C RETURN END REAL FUNCTION RJ (X, Y, Z, P, IER) C***BEGIN PROLOGUE RJ C***PURPOSE Compute the incomplete or complete (X or Y or Z is zero) C elliptic integral of the 3rd kind. For X, Y, and Z non- C negative, at most one of them zero, and P positive, C RJ(X,Y,Z,P) = Integral from zero to infinity of C -1/2 -1/2 -1/2 -1 C (3/2)(t+X) (t+Y) (t+Z) (t+P) dt. C***LIBRARY SLATEC C***CATEGORY C14 C***TYPE SINGLE PRECISION (RJ-S, DRJ-D) C***KEYWORDS COMPLETE ELLIPTIC INTEGRAL, DUPLICATION THEOREM, C INCOMPLETE ELLIPTIC INTEGRAL, INTEGRAL OF THE THIRD KIND, C TAYLOR SERIES C***AUTHOR Carlson, B. C. C Ames Laboratory-DOE C Iowa State University C Ames, IA 50011 C Notis, E. M. C Ames Laboratory-DOE C Iowa State University C Ames, IA 50011 C Pexton, R. L. C Lawrence Livermore National Laboratory C Livermore, CA 94550 C***DESCRIPTION C C 1. RJ C Standard FORTRAN function routine C Single precision version C The routine calculates an approximation result to C RJ(X,Y,Z,P) = Integral from zero to infinity of C C -1/2 -1/2 -1/2 -1 C (3/2)(t+X) (t+Y) (t+Z) (t+P) dt, C C where X, Y, and Z are nonnegative, at most one of them is C zero, and P is positive. If X or Y or Z is zero, the C integral is COMPLETE. The duplication theorem is iterated C until the variables are nearly equal, and the function is C then expanded in Taylor series to fifth order. C C C 2. Calling Sequence C RJ( X, Y, Z, P, IER ) C C Parameters On Entry C Values assigned by the calling routine C C X - Single precision, nonnegative variable C C Y - Single precision, nonnegative variable C C Z - Single precision, nonnegative variable C C P - Single precision, positive variable C C C On Return (values assigned by the RJ routine) C C RJ - Single precision approximation to the integral C C IER - Integer C C IER = 0 Normal and reliable termination of the C routine. It is assumed that the requested C accuracy has been achieved. C C IER > 0 Abnormal termination of the routine C C C X, Y, Z, P are unaltered. C C C 3. Error Messages C C Value of IER assigned by the RJ routine C C Value Assigned Error Message Printed C IER = 1 MIN(X,Y,Z) .LT. 0.0E0 C = 2 MIN(X+Y,X+Z,Y+Z,P) .LT. LOLIM C = 3 MAX(X,Y,Z,P) .GT. UPLIM C C C C 4. Control Parameters C C Values of LOLIM, UPLIM, and ERRTOL are set by the C routine. C C C LOLIM and UPLIM determine the valid range of X Y, Z, and P C C LOLIM is not less than the cube root of the value C of LOLIM used in the routine for RC. C C UPLIM is not greater than 0.3 times the cube root of C the value of UPLIM used in the routine for RC. C C C Acceptable Values For: LOLIM UPLIM C IBM 360/370 SERIES : 2.0E-26 3.0E+24 C CDC 6000/7000 SERIES : 5.0E-98 3.0E+106 C UNIVAC 1100 SERIES : 5.0E-13 6.0E+11 C CRAY : 1.32E-822 1.4E+821 C VAX 11 SERIES : 2.5E-13 9.0E+11 C C C C ERRTOL determines the accuracy of the answer C C The value assigned by the routine will result C in solution precision within 1-2 decimals of C "machine precision". C C C C C Relative error due to truncation of the series for RJ C is less than 3 * ERRTOL ** 6 / (1 - ERRTOL) ** 3/2. C C C C The accuracy of the computed approximation to the inte- C gral can be controlled by choosing the value of ERRTOL. C Truncation of a Taylor series after terms of fifth order C Introduces an error less than the amount shown in the C second column of the following table for each value of C ERRTOL in the first column. In addition to the trunca- C tion error there will be round-off error, but in prac- C tice the total error from both sources is usually less C than the amount given in the table. C C C C Sample choices: ERRTOL Relative Truncation C error less than C 1.0E-3 4.0E-18 C 3.0E-3 3.0E-15 C 1.0E-2 4.0E-12 C 3.0E-2 3.0E-9 C 1.0E-1 4.0E-6 C C Decreasing ERRTOL by a factor of 10 yields six more C decimal digits of accuracy at the expense of one or C two more iterations of the duplication theorem. C C *Long Description: C C RJ Special Comments C C C Check by addition theorem: RJ(X,X+Z,X+W,X+P) C + RJ(Y,Y+Z,Y+W,Y+P) + (A-B) * RJ(A,B,B,A) + 3 / SQRT(A) C = RJ(0,Z,W,P), where X,Y,Z,W,P are positive and X * Y C = Z * W, A = P * P * (X+Y+Z+W), B = P * (P+X) * (P+Y), C and B - A = P * (P-Z) * (P-W). The sum of the third and C fourth terms on the left side is 3 * RC(A,B). C C C On Input: C C X, Y, Z, and P are the variables in the integral RJ(X,Y,Z,P). C C C On Output: C C C X, Y, Z, and P are unaltered. C C ******************************************************** C C Warning: Changes in the program may improve speed at the C expense of robustness. C C ------------------------------------------------------------ C C C Special Functions via RJ and RF C C C Legendre form of ELLIPTIC INTEGRAL of 3rd kind C ---------------------------------------------- C C C PHI 2 -1 C P(PHI,K,N) = INT (1+N SIN (THETA) ) * C 0 C C 2 2 -1/2 C *(1-K SIN (THETA) ) D THETA C C C 2 2 2 C = SIN (PHI) RF(COS (PHI), 1-K SIN (PHI),1) C C 3 2 2 2 C -(N/3) SIN (PHI) RJ(COS (PHI),1-K SIN (PHI), C C 2 C 1,1+N SIN (PHI)) C C C C Bulirsch form of ELLIPTIC INTEGRAL of 3rd kind C ---------------------------------------------- C C C 2 2 2 C EL3(X,KC,P) = X RF(1,1+KC X ,1+X ) + C C 3 2 2 2 2 C +(1/3)(1-P) X RJ(1,1+KC X ,1+X ,1+PX ) C C C 2 C CEL(KC,P,A,B) = A RF(0,KC ,1) + C C 2 C +(1/3)(B-PA) RJ(0,KC ,1,P) C C C C C Heuman's LAMBDA function C ------------------------ C C C 2 2 2 1/2 C L(A,B,P) = (COS(A)SIN(B)COS(B)/(1-COS (A)SIN (B)) ) C C 2 2 2 C *(SIN(P) RF(COS (P),1-SIN (A) SIN (P),1) C C 2 3 2 2 C +(SIN (A) SIN (P)/(3(1-COS (A) SIN (B)))) C C 2 2 2 C *RJ(COS (P),1-SIN (A) SIN (P),1,1- C C 2 2 2 2 C -SIN (A) SIN (P)/(1-COS (A) SIN (B)))) C C C C C (PI/2) LAMBDA0(A,B) =L(A,B,PI/2) = C C C 2 2 2 -1/2 C = COS (A) SIN(B) COS(B) (1-COS (A) SIN (B)) C C 2 2 2 C *RF(0,COS (A),1) + (1/3) SIN (A) COS (A) C C 2 2 -3/2 C *SIN(B) COS(B) (1-COS (A) SIN (B)) C C 2 2 2 2 2 C *RJ(0,COS (A),1,COS (A) COS (B)/(1-COS (A) SIN (B))) C C C C Jacobi ZETA function C -------------------- C C C 2 2 2 1/2 C Z(B,K) = (K/3) SIN(B) COS(B) (1-K SIN (B)) C C C 2 2 2 2 C *RJ(0,1-K ,1,1-K SIN (B)) / RF (0,1-K ,1) C C C ------------------------------------------------------------------- C C***REFERENCES B. C. Carlson and E. M. Notis, Algorithms for incomplete C elliptic integrals, ACM Transactions on Mathematical C Software 7, 3 (September 1981), pp. 398-403. C B. C. Carlson, Computing elliptic integrals by C duplication, Numerische Mathematik 33, (1979), C pp. 1-16. C B. C. Carlson, Elliptic integrals of the first kind, C SIAM Journal of Mathematical Analysis 8, (1977), C pp. 231-242. C***ROUTINES CALLED R1MACH, RC, XERMSG C***REVISION HISTORY (YYMMDD) C 790801 DATE WRITTEN C 890531 Changed all specific intrinsics to generic. (WRB) C 891009 Removed unreferenced statement labels. (WRB) C 891009 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 900326 Removed duplicate information from DESCRIPTION section. C (WRB) C 900510 Changed calls to XERMSG to standard form, and some C editorial changes. (RWC)). C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE RJ 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*16 XERN3, XERN4, XERN5, XERN6, XERN7 INTEGER IER REAL ALFA, BETA, C1, C2, C3, C4, EA, EB, EC, E2, E3 REAL LOLIM, UPLIM, EPSLON, ERRTOL REAL LAMDA, MU, P, PN, PNDEV REAL POWER4, RC, SIGMA, S1, S2, S3, X, XN, XNDEV REAL XNROOT, Y, YN, YNDEV, YNROOT, Z, ZN, ZNDEV, * ZNROOT LOGICAL FIRST SAVE ERRTOL,LOLIM,UPLIM,C1,C2,C3,C4,FIRST DATA FIRST /.TRUE./ C C***FIRST EXECUTABLE STATEMENT RJ IF (FIRST) THEN ERRTOL = (R1MACH(3)/3.0E0)**(1.0E0/6.0E0) LOLIM = (5.0E0 * R1MACH(1))**(1.0E0/3.0E0) UPLIM = 0.30E0*( R1MACH(2) / 5.0E0)**(1.0E0/3.0E0) C C1 = 3.0E0/14.0E0 C2 = 1.0E0/3.0E0 C3 = 3.0E0/22.0E0 C4 = 3.0E0/26.0E0 ENDIF FIRST = .FALSE. C C CALL ERROR HANDLER IF NECESSARY. C RJ = 0.0E0 IF (MIN(X,Y,Z).LT.0.0E0) THEN IER = 1 CCCCC WRITE (XERN3, '(1PE15.6)') X CCCCC WRITE (XERN4, '(1PE15.6)') Y CCCCC WRITE (XERN5, '(1PE15.6)') Z WRITE(ICOUT,1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9)X CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8)Y CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7)Z CALL DPWRST('XXX','BUG ') RETURN ENDIF 1 FORMAT('***** ERORR FROM RJ, ONE OF THE THREE ARGUMENTS IS', * ' NEGATIVE. ***') 9 FORMAT('***** THE VALUE OF THE FIRST ARGUMENT IS ',E15.8,' ***') 8 FORMAT('***** THE VALUE OF THE SECOND ARGUMENT IS ',E15.8,' ***') 7 FORMAT('***** THE VALUE OF THE THIRD ARGUMENT IS ',E15.8,' ***') 11 FORMAT('***** THE VALUE OF THE FOURTH ARGUMENT IS ',E15.8,' ***') C IF (MAX(X,Y,Z,P).GT.UPLIM) THEN IER = 3 CCCCC WRITE (XERN3, '(1PE15.6)') X CCCCC WRITE (XERN4, '(1PE15.6)') Y CCCCC WRITE (XERN5, '(1PE15.6)') Z CCCCC WRITE (XERN6, '(1PE15.6)') P CCCCC WRITE (XERN7, '(1PE15.6)') UPLIM WRITE(ICOUT,2) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9)X CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8)Y CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7)Z CALL DPWRST('XXX','BUG ') WRITE(ICOUT,11)P CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6)UPLIM CALL DPWRST('XXX','BUG ') RETURN ENDIF 2 FORMAT('***** ERORR FROM RJ, ONE OF THE FOUR ARGUMENTS EXCEEDS', * 'THE LARGEST ALLOWABLE VALUE') 6 FORMAT('***** THE VALUE OF THE UPPER LIMIT IS ',E15.8,' *****') C IF (MIN(X+Y,X+Z,Y+Z,P).LT.LOLIM) THEN IER = 2 CCCCC WRITE (XERN3, '(1PE15.6)') X CCCCC WRITE (XERN4, '(1PE15.6)') Y CCCCC WRITE (XERN5, '(1PE15.6)') Z CCCCC WRITE (XERN6, '(1PE15.6)') P CCCCC WRITE (XERN7, '(1PE15.6)') LOLIM WRITE(ICOUT,3) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9)X CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8)Y CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7)Z CALL DPWRST('XXX','BUG ') WRITE(ICOUT,11)P CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5)LOLIM CALL DPWRST('XXX','BUG ') RETURN ENDIF 3 FORMAT('***** ERORR FROM RJ, THE MINIMUM OF THE PAIRWISE SUMS ', * 'OF THE FIRST THREE ARGUMENTS ') 4 FORMAT(' OR THE FOURTH ARGUMENT IS LESS THAN THE LOWER ', * 'LIMIT.') 5 FORMAT('***** THE VALUE OF THE LOWER LIMIT IS ',E15.8,' *****') C IER = 0 XN = X YN = Y ZN = Z PN = P SIGMA = 0.0E0 POWER4 = 1.0E0 C 30 MU = (XN+YN+ZN+PN+PN)*0.20E0 XNDEV = (MU-XN)/MU YNDEV = (MU-YN)/MU ZNDEV = (MU-ZN)/MU PNDEV = (MU-PN)/MU EPSLON = MAX(ABS(XNDEV), ABS(YNDEV), ABS(ZNDEV), ABS(PNDEV)) IF (EPSLON.LT.ERRTOL) GO TO 40 XNROOT = SQRT(XN) YNROOT = SQRT(YN) ZNROOT = SQRT(ZN) LAMDA = XNROOT*(YNROOT+ZNROOT) + YNROOT*ZNROOT ALFA = PN*(XNROOT+YNROOT+ZNROOT) + XNROOT*YNROOT*ZNROOT ALFA = ALFA*ALFA BETA = PN*(PN+LAMDA)*(PN+LAMDA) SIGMA = SIGMA + POWER4*RC(ALFA,BETA,IER) POWER4 = POWER4*0.250E0 XN = (XN+LAMDA)*0.250E0 YN = (YN+LAMDA)*0.250E0 ZN = (ZN+LAMDA)*0.250E0 PN = (PN+LAMDA)*0.250E0 GO TO 30 C 40 EA = XNDEV*(YNDEV+ZNDEV) + YNDEV*ZNDEV EB = XNDEV*YNDEV*ZNDEV EC = PNDEV*PNDEV E2 = EA - 3.0E0*EC E3 = EB + 2.0E0*PNDEV*(EA-EC) S1 = 1.0E0 + E2*(-C1+0.750E0*C3*E2-1.50E0*C4*E3) S2 = EB*(0.50E0*C2+PNDEV*(-C3-C3+PNDEV*C4)) S3 = PNDEV*EA*(C2-PNDEV*C3) - C2*PNDEV*EC RJ = 3.0E0*SIGMA + POWER4*(S1+S2+S3)/(MU* SQRT(MU)) RETURN END SUBROUTINE RDMNOR(AMU,SIG,LDSIG,N,LTF,ZM,IFLAG,ISEED) C C----------------------------------------------------------------------- C RDMNOR WRITTEN BY CHARLES P. REEVE, STATISTICAL ENGINEERING C DIVISION, NATION INSTITUTE OF STANDARDS AND TECHNOLOGY, GAITHERSBURG, C MARYLAND 20899 C C FOR: COMPUTING A VECTOR OF PSEUDO-RANDOM MULTIVARIATE NORMAL C DEVIATES WITH MEAN AMU AND VARIANCE SIG. BEFORE THE FIRST C CALL WITH A GIVEN SIG, THE LOGICAL VARIABLE LTF MUST BE C ASSIGNED THE VALUE .TRUE. SO THAT A CHOLESKY FACTORIZATION C OF SIG IS PERFORMED AS IN THE REFERENCE. THE RESULT IS A C LOWER TRIANGULAR MATRIX L, STORED IN THE LOWER TRIANGLE OF C SIG, SUCH THAT SIG=LL'. FURTHER CALL TO RDMNOR USE ONLY THE C LOWER TRIANGLE OF SIG (L) IN COMPUTING THE DEVIATES UNTIL THE C VALUE OF LTF IS RESET TO .TRUE., EVEN IS SIG IS REDEFINED. C C NOTE: BEFORE THE FIRST CALL TO THIS ROUTINE THE CALL C C Z = RDNOR(ISEED) C C FOR DATAPLOT, PASS SEED AS AGRUMENT C C SHOULD BE MADE IN ORDER TO INITIALIZE THE NORMAL RANDOM C NUMBER GENERATOR WHERE ISEED IS A POSITIVE INTEGER. THIS C ALLOWS THE USER TO ESTABLISH A REPEATABLE SEQUENCE OF C DEVIATES. C C SUBPROGRAMS CALLED: RDNOR (PSEUDO-RANDOM NORMAL GENERATOR) C C FOR DATAPLOT, REPLACE WITH NORRAN C C CURRENT VERSION COMPLETED MAY 15, 1987 C C REFERENCE: STEWART, G.W., 'INTRODUCTION TO MATRIX COMPUTATIONS', C ACADEMIC PRESS, ALGORITHM 3.9, P 142. C----------------------------------------------------------------------- C DEFINITION OF PASSED PARAMETERS: C C * AMU = MEAN VECTOR (LENGTH N) OF THE MULTIVARIATE NORMAL C DEVIATES ZM (REAL) C C * SIG = COVARIANCE MATRIX (SIZE NXN) OF THE MULTIVARIATE NORMAL C DEVIATES ZM (REAL) C C * LDSIG = THE LEADING DIMENSION OF MATRIX SIG (>=N) (INTEGER) C C * N = THE LENGTH OF THE VECTOR OF DEVIATES ZM (INTEGER) C C * LTF = AN INDICATOR VARIABLE FOR PERFORMING A CHOLESKY C FACTORIZATION OF A NEW COVARIANCE MATRIX SIG (LOGICAL) C C ZM = A PSEUDO-RANDOM MULTIVARIATE NORMAL VECTOR (LENGTH N) C WITH MEAN AMU AND VARIANCE SIG (REAL) C C IFLAG = AN ERROR INDICATOR ON OUTPUT (INTEGER) INTERPRETATION: C 0 -> NO ERRORS DETECTED C 1 -> THE MATRIX SIG IS NOT POSITIVE SEMIDEFINITE, THUS C CANNOT BE A COVARIANCE MATRIX - NO DEVIATE GENERATED C C ISEED = AN INTEGER THAT SPECIFIES THE SEED FOR THE DATAPLOT C RANDOM NUMBER GENERATOR. C C * INDICATES VARIABLES REQUIRING INPUT VALUES C----------------------------------------------------------------------- DIMENSION AMU(*),SIG(LDSIG,*),ZM(*) LOGICAL LTF C C--- IF NEW MATRIX SIG, PERFORM CHOLESKY FACTORIZATION. SET ERROR C--- FLAG IF SIG IS NOT POSITIVE DEFINITE C IF (LTF) THEN DO 40 K = 1, N DO 20 I = 1, K-1 S = 0.0 DO 10 J = 1, I-1 S = S+SIG(I,J)*SIG(K,J) 10 CONTINUE SIG(K,I) = (SIG(K,I)-S)/SIG(I,I) 20 CONTINUE S = 0.0 DO 30 J = 1, K-1 S = S+SIG(K,J)**2 30 CONTINUE Q = SIG(K,K)-S IF (Q.LT.0.0) THEN IFLAG = 1 RETURN ELSE IF(Q.GT.0.0)THEN SIG(K,K) = SQRT(Q) ELSE SIG(K,K)=0.0 ENDIF ENDIF 40 CONTINUE LTF = .FALSE. ENDIF IFLAG = 0 C C--- COMPUTE N INDEPENDENT N(0,1) PSEUDO-RANDOM DEVIATES IN ZM C CCCCC DO 50 I = 1, N CCCCC ZM(I) = RDNOR(0) CCC50 CONTINUE CALL NORRAN(N,ISEED,ZM) C C--- COMPUTE THE PSEUDO-RANDOM MULTIVARIATE NORMAL DEVIATES IN ZM C DO 70 I = N, 1, -1 S = 0.0 DO 60 J = 1, I S = S+SIG(I,J)*ZM(J) 60 CONTINUE ZM(I) = AMU(I)+S 70 CONTINUE RETURN END FUNCTION RDT (DF,ISEED) C C----------------------------------------------------------------------- C RDT WRITTEN BY CHARLES P. REEVE, STATISTICAL ENGINEERING C DIVISION, NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, C C FOR: GENERATING A RANDOM DEVIATE FROM THE T(DF) DISTRIBUTION. C ONE OF THREE METHODS IS USED DEPENDING ON THE VALUE OF THE C PARAMETER DF (WHICH DOES NOT HAVE TO BE AN INTEGER): C C VALUE OF DF METHOD USED C ------------- ------------------ C 0 < DF < 1 NORMAL/SQRT(CHI-SQUARED/DF) C DF = 1 TANGENT TRANSFORMATION (CST) C DF > 1 KINDERMAN-MONAHAN-RAMAGE (TIR) C C IF DF <= 0 AN ERROR MESSAGE IS PRINTED AND EXECUTION IS C TERMINATED. C C DESCRIPTIONS OF EACH OF THESE ALGORITHMS CAN BE FOUND IN C THE REFERENCE GIVEN BELOW. C C SUBPROGRAMS CALLED: RDUNI (STSPAC) - UNIFORM(0,1) GENERATOR C RDNOR (STSPAC) - NORMAL(0,1) GENERATOR C RDCHI2 (STSPAC) - CHI-SQUARED GENERATOR C C CURRENT VERSION COMPLETED FEBRUARY 28, 1986 C C REFERENCE: KINDERMAN, A.J., MONAHAN, J.F., AND RAMAGE, J.G., C "COMPUTER METHODS FOR SAMPLING FROM STUDENT'S T C DISTRIBUTION", MATHEMATICS OF COMPUTATION, VOLUME 31, C NUMBER 140, OCTOBER 1977, PP. 1009-1018 C C ADAPTED FOR DATAPLOT. USE THIS ALGORITHM FOR THE CASE OF C NON-INTEGER DEGREES OF FREEDOM. CHANGE TO USE DATAPLOT UNIFORM C RANDOM NUMBER GENERATOR. C REAL XTEMP(1) C C----------------------------------------------------------------------- C F(X,A) = (1.0+X*X/A)**(-(A+1.0)/2.0) IF (DF.GT.1.0) THEN C C C KINDERMAN-MONAHAN-RAMAGE ALGORITHM (TIR) C C--- STEP 1 C 10 CONTINUE CCCCC U = RDUNI(0) CALL UNIRAN(1,ISEED,XTEMP) U=XTEMP(1) IF (U.GE.0.23079283) GO TO 20 RDT = 4.0*U-0.46158566 C C--- STEP 2 C CCCCC V = RDUNI(0) CALL UNIRAN(1,ISEED,XTEMP) V=XTEMP(1) IF (V.LE.1.0-0.5*ABS(RDT)) RETURN IF (V.LE.F(RDT,DF)) RETURN GO TO 10 C C--- STEP 3 C 20 IF (U.GE.0.5) GO TO 40 S = 4.0*U-1.46158566 RDT = SIGN(ABS(S)+0.46158566,S) CCCCC V = RDUNI(0) CALL UNIRAN(1,ISEED,XTEMP) V=XTEMP(1) C C--- STEP 4 C 30 IF (V.LE.1.0-0.5*ABS(RDT)) RETURN IF (V.GE.1.2130613/(1.0+RDT*RDT)) GO TO 10 IF (V.LE.F(RDT,DF)) RETURN GO TO 10 C C--- STEP 5 C 40 IF (U.GE.0.75) GO TO 50 S = 8.0*U-5.0 RDT = 2.0/SIGN(ABS(S)+1.0,S) CCCCC V = RDUNI(0)/(RDT*RDT) CALL UNIRAN(1,ISEED,XTEMP) V=XTEMP(1) GO TO 30 C C--- STEP 6 C 50 RDT = 2.0/(8.0*U-7.0) CCCCC V = RDUNI(0) CALL UNIRAN(1,ISEED,XTEMP) V=XTEMP(1) IF (V.LT.RDT*RDT*F(RDT,DF)) RETURN GO TO 10 C ELSEIF (DF.EQ.1.0) THEN C C C SYNTHETIC TANGENT ALGORITHM (CST) C C--- STEP 1 C 60 CONTINUE CCCCC U = RDUNI(0) CALL UNIRAN(1,ISEED,XTEMP) U=XTEMP(1) CCCCC V = 2.0*RDUNI(0)-1.0 CALL UNIRAN(1,ISEED,XTEMP) V=2.0*XTEMP(1)-1.0 C C--- STEP 2 C IF (U*U+V*V.GT.1.0) GO TO 60 RDT = V/U RETURN C ELSEIF (DF.GT.0.0) THEN C C C RATIO OF STANDARD NORMAL AND SQUARE ROOT OF C CHI-SQUARED DIVIDED BY ITS DEGREES OF FREEDOM C C CCCCC D = SQRT(RDCHI2(DF)/DF) CALL CHSRAN(1,DF,ISEED,XTEMP) D = SQRT(XTEMP(1)/DF) CCCCC RDT = RDNOR(0)/D CALL NORRAN(1,ISEED,XTEMP) RDT = XTEMP(1)/D ELSE CCCCC PRINT *,' *** DEGREES OF FREEDOM MUST BE > 0' CCCCC PRINT *,' *** EXECUTION STOPPED IN FUNCTION RDT' CCCCC STOP C ENDIF RETURN END SUBROUTINE RECCDF(X,B,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE RECIPROCAL C DISTRIBUTION WITH SINGLE PRECISION C TAIL LENGTH PARAMETER = B. C THE RECIPROCAL DISTRIBUTION USED C HEREIN IS DEFINED FOR 1/B <= x < 1. C AND HAS THE PROBABILITY DENSITY FUNCTION C F(X) = 1/(X*LOG(B)) C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE C AT WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C X SHOULD BE GREATER THAN C OR EQUAL TO 1. C --B = THE SINGLE PRECISION VALUE C OF THE TAIL LENGTH PARAMETER. C B SHOULD BE > 1. 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 RECIPROCAL C DISTRIBUTION WITH TAIL LENGTH PARAMETER VALUE = B. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--B SHOULD BE > 1. C --X SHOULD BE POSITIVE AND LESS THAN 1. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN. C REFERENCES--R. W. HAMMING, NUMERICAL METHODS FOR SCIENTISTS C AND ENGINEERS, 2ND. ED., 1973, PAGE 34. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY C NATION INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-975-2855 C ORIGINAL VERSION--MAY 1996. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DB 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--------------------------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(B.LE.1.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)B CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF 15 FORMAT('***** FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT ', 1'TO RECPDF IS LESS THAN OR EQUAL TO 1') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') IF(X.LT.(1./B))THEN CDF=0.0 GOTO9999 ENDIF IF(X.GE.1.0)THEN CDF=1.0 GOTO9999 ENDIF C C-----START POINT----------------------------------------------------- C DX=DBLE(X) DB=DBLE(B) DCDF=(DLOG(DX)+DLOG(DB))/DLOG(DB) CDF=SNGL(DCDF) C 9999 CONTINUE RETURN END SUBROUTINE RECIPG(X,ODD,EVEN,RG) C THIS ROUTINE IS A TRANSLATION INTO FORTRAN OF THE ALGOL PROCEDURE C RECIPGAMMA GIVEN IN N. M. TEMME, ON THE NUMERICAL EVALUATION OF THE C MODIFIED BESSEL FUNCTION OF THE THIRD KIND, J. COMP. PHYSICS, VOLUME C 19, PAGE 324 (1975). DIMENSION B(12) C----------------------------------------------------------------------- C C MACHINE DEPENDENT CONSTANTS. C --------------------------- C DATA B(1), B(2), B(3), B(4), B(5), B(6), B(7), B(8), B(9), B(10), * B(11), B(12) * /-.28387 65422 7602,-.07685 28408 44786,.00170 63050 71096, 1 .00127 19271 36655,.00007 63095 97586,-.4971736704E-5,-.865920800 2 E-6,-.33126120E-7,.1745136E-8,.242310E-9,.9161E-11,-.170E-12/ C C----------------------------------------------------------------------- X2=8.*X*X ALFA=-1.E-15 BETA=0. DO 1 N=1,11,2 BETA=-(BETA+2.*ALFA) ITEMP = 13 - N 1 ALFA = - X2 * BETA - ALFA + B(ITEMP) EVEN=(ALFA+.5*BETA)*X2-ALFA+.92187 02936 5045 ALFA=-.34E-13 BETA=0. DO 2 N=2,12,2 BETA=-(BETA+2.*ALFA) ITEMP = 13 - N 2 ALFA = - X2 * BETA - ALFA + B(ITEMP) ODD=2.*(ALFA+BETA) RG=ODD*X+EVEN RETURN END SUBROUTINE RECPDF(X,B,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE RECIPROCAL C DISTRIBUTION WITH SINGLE PRECISION C TAIL LENGTH PARAMETER = B. C THE RECIPROCAL DISTRIBUTION USED C HEREIN IS DEFINED FOR 1/B <= x < 1. C AND HAS THE PROBABILITY DENSITY FUNCTION C F(X) = 1/(X*LOG(B)) C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE C AT WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C X SHOULD BE GREATER THAN C OR EQUAL TO 1. C --B = THE SINGLE PRECISION VALUE C OF THE TAIL LENGTH PARAMETER. C B SHOULD BE > 1. 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 RECIPROCAL C DISTRIBUTION WITH TAIL LENGTH PARAMETER VALUE = B. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--B SHOULD BE POSITIVE. C --X SHOULD BE POSITIVE AND LESS THAN 1. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN. C REFERENCES--R. W. HAMMING, NUMERICAL METHODS FOR SCIENTISTS C AND ENGINEERS, 2ND. ED., 1973, PAGE 34. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY C NATION INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-975-2855 C ORIGINAL VERSION--MAY 1996. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DB DOUBLE PRECISION DPDF C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C--------------------------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(B.LE.1.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)B CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF 15 FORMAT('***** FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT ', 1'TO RECPDF IS LESS THAN OR EQUAL TO 1') IF(X.LT.(1./B).OR.X.GE.1.0)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF 4 FORMAT('***** FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT ', 1'TO RECPDF IS OUTSIDE THE (1/B,1) INTERVAL') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') C C-----START POINT----------------------------------------------------- C DX=DBLE(X) DB=DBLE(B) DPDF=1.0D0/(DX*DLOG(DB)) PDF=SNGL(DPDF) C 9999 CONTINUE RETURN END SUBROUTINE RECPPF(P,B,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE RECIPROCAL C DISTRIBUTION WITH SINGLE PRECISION C TAIL LENGTH PARAMETER = B. C THE RECIPROCAL DISTRIBUTION USED C HEREIN IS DEFINED FOR 1/B <= X < 1. C AND HAS THE PROBABILITY DENSITY FUNCTION C F(X) = 1/(X*LOG(B)) C INPUT ARGUMENTS--P = THE SINGLE PRECISION VALUE C SPECIFYING THE PROBABILITY VALUE. C P SHOULD BE GREATER THAN OR EQUAL TO 0 C AND LESS THAN OR EQUAL TO 1. C --B = THE SINGLE PRECISION VALUE C OF THE TAIL LENGTH PARAMETER. C B SHOULD BE > 1. 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 RECIPROCAL C DISTRIBUTION WITH TAIL LENGTH PARAMETER VALUE = B. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--B SHOULD BE > 1. C --P SHOULD BE >= 0 AND <= 1 C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN. C REFERENCES--R. W. HAMMING, NUMERICAL METHODS FOR SCIENTISTS C AND ENGINEERS, 2ND. ED., 1973, PAGE 34. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING LABORATORY C NATION INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE: 301-975-2855 C ORIGINAL VERSION--MAY 1996. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DP DOUBLE PRECISION DB 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--------------------------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(P.LT.0.0.OR.P.GT.1.0)THEN WRITE(ICOUT,4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)P CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF 4 FORMAT('***** FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT ', 1'TO RECPPF IS OUTSIDE THE (0,1) INTERVAL') IF(B.LE.1.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)B CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9999 ENDIF 15 FORMAT('***** FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT ', 1'TO RECPDF IS LESS THAN OR EQUAL TO 0') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') IF(P.EQ.0.0)THEN PPF=1.0/B GOTO9999 ENDIF IF(P.EQ.1.0)THEN PPF=1.0 GOTO9999 ENDIF C C-----START POINT----------------------------------------------------- C DP=DBLE(P) DB=DBLE(B) DPPF=DEXP(DLOG(DB)*(DP-1.0D0)) PPF=SNGL(DPPF) C 9999 CONTINUE RETURN END SUBROUTINE RECRAN(N,B,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE RECIROCAL DISTRIBUTION C WITH SHAPE PARAMETER VALUE = B. C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --B = THE SINGLE PRECISION VALUE OF THE C SHAPE PARAMETER. C B SHOULD BE POSITIVE. C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR C (OF DIMENSION AT LEAST N) C INTO WHICH THE GENERATED C RANDOM SAMPLE WILL BE PLACED. C OUTPUT--A RANDOM SAMPLE OF SIZE N C FROM THE RECIROCAL DISTRIBUTION C WITH SHAPE PARAMETER VALUE = B. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C --B 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 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--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(B.LE.1.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)B CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 5 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE ', 1'RECRAN SUBROUTINE IS NON-POSITIVE *****') 15 FORMAT('***** ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1'RECRAN SUBROUTINE IS <= 1 *****') 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 RECIROCAL DISTRIBUTION RANDOM NUMBERS C USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD. C DO100I=1,N CALL RECPPF(X(I),B,XTEMP) X(I)=XTEMP 100 CONTINUE C 9000 CONTINUE RETURN END SUBROUTINE REGDAT (NPAR, NTOT, NBCH, NPTS, XPTS, Y, COEF, CCCCC CALL LIST CHANGED TO REFLECT SWAPPING TO USE LESS MEMORY. CCCCC$ U1, S1, V1, U2, TLM0, TLM1, ETA0, ETA1, $ SCRTCH, S1, V1, TLM0, TLM1, ETA0, ETA1, $ WK1, XM, T, X, NLVL, $ ICASRE, IFLAG, ISUBRO, IBUGA2, IERROR) C C SUBROUTINE REGDAT PERFORMS ALL OF THE REGRESSION TOLERANCE LIMIT C CALCULATIONS WHICH INVOLVE THE RESPONSE (Y) DATA. REGINI MUST BE C CALLED BEFORE REGDAT, BUT IF MULTIPLE SETS OF Y DATA ARE TO BE C ANALYZED (E.G., IN A SIMULATION), THEN REGINI NEED ONLY BE CALLED C ONCE. C IMPLICIT DOUBLE PRECISION (A-H, O-Z) LOGICAL CONFND CHARACTER*4 ICASRE C CHARACTER*4 ISUBRO CHARACTER*4 IERROR CHARACTER*4 IBUGA2 CHARACTER*4 IBUGA3 CHARACTER*4 IOP CHARACTER*4 IFLAG CHARACTER*80 IFILE C CCCCC DIMENSION U1(*), S1(*), V1(*), U2(*), Y(*), COEF(*), DIMENSION SCRTCH(*), S1(*), V1(*), Y(*), COEF(*), $ XPTS(*), ETA0(*), ETA1(*), TLM0(*), TLM1(*), XM(*), $ T(*), WK1(*), X(*) C COMMON /RECIPA/ IRANK1, IRANK2, TR1, TR2, GNU0, GNU1, CONFND COMMON /RECIPB/ NUMXX, NUMU1, NUMU2, NUMH COMMON /RECSIM/ RSSA C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C REAL CPUMIN REAL CPUMAX COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C DATA ZERO /0.D0/ DATA ONE/1.D0/ C IBUGA3='OFF' C -- OLS COEFFICIENTS IERROR='NO' CALL DSET (NTOT*NPAR, WK1, ZERO) C C -- FOR DATAPLOT, READ U1 ARRAY BACK IN IOP='READ' IFILE='DPRE2F.DAT' CALL DPSWA2(IOP,IFILE,SCRTCH,NUMU1,IBUGA3,ISUBRO,IERROR) IF(IERROR.EQ.'YES')RETURN C DO 60 I=1, IRANK1 CALL DGER (NPAR, NTOT, ONE/S1(I), V1((I-1)*NPAR+1), 1, CCCCC$ U1((I-1)*NTOT+1), 1, WK1, NPAR, IERROR) $ SCRTCH((I-1)*NTOT+1), 1, WK1, NPAR, IERROR) IF(IERROR.EQ.'YES')RETURN 60 CONTINUE CALL DGEMV ('N', NPAR, NTOT, ONE, WK1, NPAR, $ Y, 1, ZERO, COEF, 1, IERROR) IF(IERROR.EQ.'YES')RETURN C C -- CALCULATE RESIDUAL SUMS OF SQUARES FOR BOTH MODELS SY = DDOT (NTOT, Y, 1, Y, 1) CCCCC CALL DGEMV ('T', NTOT, IRANK1, ONE, U1, NTOT, Y, 1, ZERO, WK1, 1, CALL DGEMV ('T', NTOT, IRANK1, ONE, SCRTCH, NTOT, Y, 1, ZERO, 1 WK1, 1, IERROR) IF(IERROR.EQ.'YES')RETURN RSSA = SY -DDOT (IRANK1, WK1, 1, WK1, 1) C -- FOR DATAPLOT, READ U2 ARRAY BACK IN IOP='READ' IFILE='DPRE3F.DAT' CALL DPSWA2(IOP,IFILE,SCRTCH,NUMU2,IBUGA3,ISUBRO,IERROR) IF(IERROR.EQ.'YES')RETURN C CCCCC CALL DGEMV ('T', NTOT, IRANK2, ONE, U2, NTOT, Y, 1, ZERO, WK1, 1, CALL DGEMV ('T', NTOT, IRANK2, ONE, SCRTCH, NTOT, Y, 1, ZERO, 1 WK1, 1, IERROR) IF(IERROR.EQ.'YES')RETURN RSSB = SY - DDOT (IRANK2, WK1, 1, WK1, 1) C C -- VARIANCE COMPONENT ESTIMATES RMSA = RSSA /(NTOT -IRANK1) RMSB = RSSB /(NTOT -IRANK2) TMSA = RMSA IF (RMSA .LT. RMSB) TMSA = RMSB IF (CONFND) THEN S2B = ZERO ELSE S2B = GNU0 /TR1 *(RMSA -RMSB) END IF IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GDAT')THEN WRITE(ICOUT,2001)TR1 CALL DPWRST('XXX','BUG') WRITE(ICOUT,2002)TR2 CALL DPWRST('XXX','BUG') WRITE(ICOUT,2003)S2B CALL DPWRST('XXX','BUG') END IF 2001 FORMAT('TR1 = ',E15.7) 2002 FORMAT('TR2 = ',E15.7) 2003 FORMAT('S2B = ',E15.7) IF (S2B .LT. ZERO) S2B = ZERO S2W = RMSB IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GDAT')THEN WRITE(ICOUT,2004)S2W,NPTS CALL DPWRST('XXX','BUG') END IF 2004 FORMAT('S2W, NPTS = ',E15.7,I8) S = SQRT(S2B +S2W) C C -- TOLERANCE LIMIT FACTORS AND TOLERANCE LIMITS DO 10 I=1, NPTS SMEAN = SQRT(S2B/ETA1(I) +S2W/ETA0(I)) TFCT = (SQRT(ETA0(I)*ETA1(I)) *(TLM1(I) -TLM0(I))*SMEAN + $ (TLM0(I)*SQRT(ETA0(I)) -TLM1(I)*SQRT(ETA1(I)))*S)/ $ (SQRT(TMSA) *(SQRT(ETA0(I)) -SQRT(ETA1(I)))) XM(I) = DDOT (NPAR, XPTS(I), NPTS, COEF, 1) IF(IBUGA2.EQ.'ON')THEN WRITE(ICOUT,119)I,XM(I) CALL DPWRST('XXX','BUG') ENDIF T (I) = XM(I) -TFCT*SQRT(RMSA) 10 CONTINUE C C -- FOR FIT CASE, CALCULATE PREDICTED VALUES AT C -- DESIGN POINTS IF(IBUGA2.EQ.'ON')THEN WRITE(ICOUT,118)ICASRE,NLVL,NPAR 118 FORMAT('ICASRE,NLVL,NPAR=',A4,1X,2I8) CALL DPWRST('XXX','BUG') DO116I=1,NPAR*NLVL WRITE(ICOUT,117)I,X(I) 117 FORMAT('I,X(I)=',I8,E15.7) CALL DPWRST('XXX','BUG') 116 CONTINUE DO115I=1,NPAR*NPTS WRITE(ICOUT,114)I,XPTS(I) 114 FORMAT('I,XPTS(I)=',I8,E15.7) CALL DPWRST('XXX','BUG') 115 CONTINUE ENDIF IF(ICASRE.EQ.'FREC')THEN DO 19 I=1, NLVL XM(I) = DDOT (NPAR, X(I), NLVL, COEF, 1) IF(IBUGA2.EQ.'ON')THEN WRITE(ICOUT,119)I,XM(I) 119 FORMAT('I,XM(I)=',I8,E15.7) CALL DPWRST('XXX','BUG') ENDIF 19 CONTINUE ENDIF C -- FOR DATAPLOT, READ XX ARRAY BACK IN C -- FOR RECIPE, READ THIS MATRIX BACK IN, FOR SIMCOV DO NOT C -- (SIMCOV MAKES MULTIPLE CALLS TO REGDAT, WANT TO LEAVE C -- WK1 MATRIX AS THE SVDC MATRIX) IF(IFLAG.EQ.'RECI')THEN IOP='READ' IFILE='DPRE1F.DAT' NUMXX=NTOT*NPAR CALL DPSWA2(IOP,IFILE,WK1,NUMXX,IBUGA3,ISUBRO,IERROR) IF(IERROR.EQ.'YES')RETURN ENDIF C RETURN END SUBROUTINE REGINI ( CCCCC CALL LIST CHANGED TO REFLECT SWAPPING TO USE LESS MEMORY. & NLVL, NPAR, NTOT, NBCH, NPTS, X, XPTS, IP, CCCCC$ IQ, CONT, CONF, XX, XTX, XTXI, XN, H, $ IQ, CONT, CONF, XX, XTX, XTXI, XN, SCRTCH, CCCCC$ U1, S1, V1, U2, S2, V2, TLM0, TLM1, ETA0, ETA1, $ S1, V1, S2, V2, TLM0, TLM1, ETA0, ETA1, CCCCC$ SATT, IN2, WK1, WK2, WK3, $ SATT, IN2, WK2, WK3, $ CRT,ISEED, MAXREP,MAXLVL, $ ICASRE,ISUBRO,IBUGA2, IERROR) C C SUBROUTINE REGINI PERFORMS ALL OF THE CALCULATIONS FOR REGRESSION C TOLERANCE LIMITS WHICH DO NOT INVOLVE THE RESPONSE (Y) DATA. C C IMPLICIT DOUBLE PRECISION (A-H, O-Z) REAL AJUNK REAL XTMP(1) LOGICAL CONFND, SATT CCCCC CHARACTER*10 DUMCHR DIMENSION X(*), XPTS(*), IP(*), IQ(*), XX(*), XTX(*), CCCCC$ XTXI(*), XN(*), H(*), U1(*), S1(*), V1(*), CCCCC$ U2(*), S2(*), V2(*), TLM0(*), TLM1(*), CCCCC$ ETA0(*), ETA1(*), WK1(*), WK2(*), WK3(*) $ XTXI(*), XN(*), SCRTCH(*), S1(*), V1(*), $ S2(*), V2(*), TLM0(*), TLM1(*), $ ETA0(*), ETA1(*), WK2(*), WK3(*), CRT(*) C COMMON /RECIPA/ IRANK1, IRANK2, TR1, TR2, GNU0, GNU1, CONFND COMMON /RECIPB/ NUMXX, NUMU1, NUMU2, NUMH C CHARACTER*4 IOP CHARACTER*4 IMATCH CHARACTER*80 IFILE C CHARACTER*4 ICASRE C CHARACTER*4 IERROR CHARACTER*4 IBUGA2 CHARACTER*4 IBUGA3 CHARACTER*4 ISUBRO 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 ONE /1.D0/ DATA ZERO/0.D0/ DATA EPS /1.D-7/ C IBUGA3='OFF' IERROR='NO' C -- BUILD FULL DATA MATRIX FROM UNIQUE ROWS C -- NOTE: DATAPLOT PASSES IN FULL DESIGN MATRIX (MINUS C THE BATCH VARIABLE). NEED TO RECONSTRUCT THE C X ARRAY. C -- NOTE: FOR EXAMPLE, THE 2-D ARRAY C 1 -3 -2 C 1 -3 0 C 1 1 -2 C 1 1 0 C IS STORED AS C 1 1 1 1 -3 -3 1 1 -2 0 -2 0 C IN THE 1-D ARRAY C C -- A DATAPLOT COMPLICATION IS THAT WE START WITH C THE FULL DESIGN MATRIX, BUT WE DON'T KNOW WHAT C NLVL IS IN ADVANCE (THAT IS BEING CACLUCATED C HERE). THEREFORE, IN CREATING THE REDUCED DESIGN C MATRIX, X, WE NEED TO MAKE AN INITIAL PASS TO C DETERMINE THE VALUE OF "NLVL". DO THIS BY LOOPING C THROUGH AND COMPARING EACH ROW OF XX WITH ALL PREVIOUS C ROWS OF XX. INCREMENT NLVL IF NO MATCH FOUND. C CCCCC DO 10 I=1, NTOT CCCCC DO 20 J=1, NPAR CCCCC XX((J-1)*NTOT+I) = X((J-1)*NLVL+IP(I)) C20 CONTINUE C10 CONTINUE C NLVL=1 DEPS=1.0D-10 DO110I=2,NTOT IMATCH='NO' DO120J=1,I-1 DO125KK=1,NPAR DTERM1=XX((KK-1)*NTOT+I) DTERM2=XX((KK-1)*NTOT+J) CCCCC IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GINI')THEN CCCCC WRITE(ICOUT,126)I,J,KK,DTERM1,DTERM2 CCCCC CALL DPWRST('XXX','BUG') CCCCC ENDIF IF(DABS(DTERM1-DTERM2).GT.DEPS)THEN GOTO120 ENDIF 125 CONTINUE IMATCH='YES' GOTO110 120 CONTINUE IF(IMATCH.EQ.'NO')NLVL=NLVL+1 110 CONTINUE 126 FORMAT('I,J,KK=',3I8,2D15.7) C IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GINI')THEN WRITE(ICOUT,132)NLVL CALL DPWRST('XXX','BUG') ENDIF 132 FORMAT('NLVL=',I8) C DO5J=1,NPAR X((J-1)*NLVL+1)=XX((J-1)*NTOT+1) 5 CONTINUE ITEST=1 IP(1)=ITEST C DO10I=2,NTOT IMATCH='NO' DO20J=1,ITEST DO25K=1,NPAR DTERM1=XX((K-1)*NTOT+I) DTERM2=X((K-1)*NLVL+J) CCCCC IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GINI')THEN CCCCC WRITE(ICOUT,136)I,J,K,DTERM1,DTERM2 CCCCC CALL DPWRST('XXX','BUG') CCCCC ENDIF IF(DABS(DTERM1-DTERM2).GT.DEPS)THEN GOTO20 ENDIF 25 CONTINUE IP(I)=J GOTO10 20 CONTINUE ITEST=ITEST+1 DO35KK=1,NPAR X((KK-1)*NLVL+ITEST)=XX((KK-1)*NTOT+I) 35 CONTINUE IP(I)=ITEST 10 CONTINUE 136 FORMAT('I,J,KK=',3I8,2D15.7) C IF(ITEST.NE.NLVL)THEN WRITE(ICOUT,142)NLVL,ITEST CALL DPWRST('XXX','BUG') IERROR='YES' RETURN ENDIF 142 FORMAT('***** INTERNAL ERROR FROM REGINI--NUMBER OF LEVELS ', 1'PASS 1 = ',I8,' NUMBER OF LEVELS PASS 2 = ',I8) IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GINI')THEN DO1001I=1,NLVL*NPAR WRITE(ICOUT,1002)I,X(I) CALL DPWRST('XXX','BUG') 1001 CONTINUE DO1006I=1,NTOT WRITE(ICOUT,1007)I,IP(I) CALL DPWRST('XXX','BUG') 1006 CONTINUE ENDIF 1002 FORMAT('I,X(I)=',I8,D15.7) 1007 FORMAT('I,IP(I)=',2I8) C IF(NLVL.GT.MAXLVL)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG') WRITE(ICOUT,101)NLVL CALL DPWRST('XXX','BUG') WRITE(ICOUT,102)MAXLVL CALL DPWRST('XXX','BUG') IERROR='YES' RETURN ENDIF 101 FORMAT('**** ERROR FROM REGINI: THE NUMBER OF LEVELS IN THE ', 1'DESIGN MATRIX ',I8) 102 FORMAT(' EXCEEDS THE MAXIMUM ALLOWABLE ',I8) C C --FOR RECIPE FIT CASE, XPTS IS CREATED FROM USER SUPPLIED DATA. C --FOR RECIPE ANOVA CASE, XPTS IS EQUAL TO X MATRIX (THAT IS, C --WE WILL COMPUTE A TOLERANCE VALUE AT ALL UNIQUE DESIGN C --POINTS. C --FOR ANOVA CASE, XPTS SHOULD BE ALL ZERO'S. FOR FIT CASE C --FIRST NTOT ROWS SHOULD BE 1 (CORRESPONDING TO THE CONSTANT). C IF(ICASRE.EQ.'AREC'.OR.(ICASRE.EQ.'FREC'.AND.NPTS.EQ.0))THEN NPTS=NLVL DO42I=1,NPAR*NLVL XPTS(I)=X(I) 42 CONTINUE ENDIF C C -- NEED COPY OF XX, BECAUSE DSVDC DESTROYS INPUT MATRIX C -- FOR DATAPLOT, COPY XX FILE TO A SWAP FILE, USE XX IN SUBSEQUENT C CALCULATIONS. IOP='WRIT' IFILE='DPRE1F.DAT' NUMXX=NTOT*NPAR CALL DPSWA2(IOP,IFILE,XX,NUMXX,IBUGA3,ISUBRO,IERROR) IF(IERROR.EQ.'YES')RETURN C CCCCC CALL DCOPY (NTOT*NPAR, XX, 1, WK1, 1) C C -- XX^T *XX CALL DGEMM ('T', 'N', NPAR, NPAR, NTOT, ONE, XX, NTOT, $ XX, NTOT, ZERO, XTX, NPAR,IERROR) IF(IERROR.EQ.'YES')RETURN C C -- SVD OF DESIGN MATRIX XX (COPY IN WK1) IJOB = 21 LDU = NTOT LDV = NPAR TOL = 1.D-7 CCCCC CALL DSVDC (WK1 , NTOT, NTOT, NPAR, S1, WK2, U1, LDU, V1, LDV, CALL DSVDC (XX , NTOT, NTOT, NPAR, S1, WK2, SCRTCH, LDU, V1, LDV, $ WK3, IJOB, INFO) C -- FOR DATAPLOT, COPY U1 (=SCRTCH) FILE TO A SWAP FILE IOP='WRIT' IFILE='DPRE2F.DAT' NUMU1=NTOT*NPAR CALL DPSWA2(IOP,IFILE,SCRTCH,NUMU1,IBUGA3,ISUBRO,IERROR) IF(IERROR.EQ.'YES')RETURN C C -- RANK (XX) IRANK1 = 0 DO 30 I=1, NPAR IF (ABS(S1(I)) .LT. TOL) GO TO 40 IRANK1 = IRANK1 +1 30 CONTINUE 40 CONTINUE C C -- DO "SIMRAT" CODE HERE IF(.NOT.SATT)THEN IOP='WRIT' IFILE='DPRE3F.DAT' NUMXX=NTOT*NPAR CALL DPSWA2(IOP,IFILE,XX,NUMXX,IBUGA3,ISUBRO,IERROR) IF(IERROR.EQ.'YES')RETURN C IOP='WRIT' IFILE='DPRE4F.DAT' NUMXPT=NPTS*NPAR CALL DPSWA2(IOP,IFILE,XPTS,NUMXPT,IBUGA3,ISUBRO,IERROR) IF(IERROR.EQ.'YES')RETURN C CALL NODPPF(CONT,ZCONT) NREP=MAXREP NRAN=1 DO 900 I=1, NPTS CCCCC Z = RNOR(ISEED) CALL NORRAN(NRAN,ISEED,XTMP) Z=DBLE(XTMP(1)) CCCCC CALL DCOPY(NPAR, XPTS(I), NPTS, W, 1) CALL SIMRAT CCCCC$ (U1,S1,V1,IQ,W,NBCH,NTOT,NPAR,NREP,IRK,ZCONT,CONF, CCCCC$ WK1,WK2,VALS,QUANT) $ (SCRTCH,S1,V1,IQ,XPTS,NBCH,NTOT,NPAR,NREP,IRK,ZCONT,CONF, $ WK2,WK3,XX,QUANT, IERROR) IF(IERROR.EQ.'YES')RETURN CRT(I)=QUANT 900 CONTINUE C IOP='READ' IFILE='DPRE2F.DAT' CALL DPSWA2(IOP,IFILE,SCRTCH,NUMU1,IBUGA3,ISUBRO,IERROR) IF(IERROR.EQ.'YES')RETURN C IOP='READ' IFILE='DPRE3F.DAT' NUMXX=NTOT*NPAR CALL DPSWA2(IOP,IFILE,XX,NUMXX,IBUGA3,ISUBRO,IERROR) IF(IERROR.EQ.'YES')RETURN C IOP='READ' IFILE='DPRE4F.DAT' NUMXPT=NPTS*NPAR CALL DPSWA2(IOP,IFILE,XPTS,NUMXPT,IBUGA3,ISUBRO,IERROR) IF(IERROR.EQ.'YES')RETURN ENDIF C C -- INVERSE (XX^T XX) CALL DSET (NPAR*NPAR, XTXI, ZERO) DO 50 I=1, IRANK1 CALL DGER (NPAR, NPAR, ONE/S1(I)**2, V1((I-1)*NPAR+1), 1, $ V1((I-1)*NPAR+1), 1, XTXI, NPAR,IERROR) IF(IERROR.EQ.'YES')RETURN 50 CONTINUE C C -- H = X *INVERSE(XX^T XX) *X^T CALL DGEMM ('N', 'N', NLVL, NPAR, NPAR, ONE, X, NLVL, CCCCC$ XTXI, NPAR, ZERO, WK1, NLVL,IERROR) $ XTXI, NPAR, ZERO, XX, NLVL,IERROR) IF(IERROR.EQ.'YES')RETURN CCCCC CALL DGEMM ('N', 'T', NLVL, NLVL, NPAR, ONE, WK1, NLVL, CCCCC$ X, NLVL, ZERO, H, NLVL,IERROR) CALL DGEMM ('N', 'T', NLVL, NLVL, NPAR, ONE, XX, NLVL, $ X, NLVL, ZERO, SCRTCH, NLVL,IERROR) C -- FOR DATAPLOT, COPY H (=SCRTCH) FILE TO A SWAP FILE IOP='WRIT' IFILE='DPRE4F.DAT' NUMH=NLVL*NLVL CALL DPSWA2(IOP,IFILE,SCRTCH,NUMH,IBUGA3,ISUBRO,IERROR) IF(IERROR.EQ.'YES')RETURN C IF(IERROR.EQ.'YES')RETURN C C -- AUGMENT THE XX MATRIX WITH BATCH INDICATORS C -- FOR DATAPLOT, READ ORIGINAL XX MATRIX BACK IN IOP='READ' IFILE='DPRE1F.DAT' NUMXX=NTOT*NPAR CALL DPSWA2(IOP,IFILE,XX,NUMXX,IBUGA3,ISUBRO,IERROR) IF(IERROR.EQ.'YES')RETURN C CALL DSET (NTOT*NBCH, XX(NTOT*NPAR+1), ZERO) DO 70 I=1, NTOT XX((IQ(I)+NPAR-1)*NTOT +I) = ONE 70 CONTINUE C C -- DO AN SVD ON THE AUGMENTED MATRIX IJOB = 21 LDU = NTOT NCOL = NPAR+NBCH LDV = NCOL TOL = 1.D-7 CCCCC CALL DCOPY (NTOT*NCOL, XX, 1, WK1, 1) CCCCC CALL DSVDC (WK1, NTOT, NTOT, NCOL, S2, WK2, U2, CCCCC$ LDU, V2, LDV, WK3, IJOB, INFO) CALL DSVDC (XX, NTOT, NTOT, NCOL, S2, WK2, SCRTCH, $ LDU, V2, LDV, WK3, IJOB, INFO) C -- FOR DATAPLOT, COPY U2 (=SCRTCH) FILE TO A SWAP FILE IOP='WRIT' IFILE='DPRE3F.DAT' CCCCC NUMU2=NTOT*(NPAR+NUMBCH) NUMU2=NTOT*(NPAR+NBCH) CALL DPSWA2(IOP,IFILE,SCRTCH,NUMU2,IBUGA3,ISUBRO,IERROR) IF(IERROR.EQ.'YES')RETURN C C -- GET RANK OF AUGMENTED DESIGN MATRIX IRANK2 = 0 DO 80 I=1, NPAR+NBCH IF (ABS(S2(I)) .LT. TOL) GO TO 90 IRANK2 = IRANK2 +1 80 CONTINUE 90 CONTINUE C IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GINI')THEN WRITE(ICOUT,91)IRANK2 CALL DPWRST('XXX','BUG') ENDIF 91 FORMAT('FROM REGINI--IRANK2=',I8) C C -- CALCULATE N, M, B =M-N^T*H*N, TR(B), AND TR(B^2) CALL DSET (NBCH*NLVL, XN, ZERO) DO 100 I=1, NTOT IDX = (IQ(I)-1)*NLVL +IP(I) XN(IDX) = XN(IDX) +1 100 CONTINUE CCCCC CALL DGEMM ('T', 'N', NBCH, NLVL, NLVL, ONE, XN, NLVL, CCCCC$ H, NLVL, ZERO, WK1, NBCH,IERROR) C -- FOR DATAPLOT, READ H (=SCRTCH) FROM SWAP FILE IOP='READ' IFILE='DPRE4F.DAT' NUMH=NLVL*NLVL CALL DPSWA2(IOP,IFILE,SCRTCH,NUMH,IBUGA3,ISUBRO,IERROR) IF(IERROR.EQ.'YES')RETURN C CALL DGEMM ('T', 'N', NBCH, NLVL, NLVL, ONE, XN, NLVL, 1 SCRTCH, NLVL, ZERO, XX, NBCH,IERROR) IF(IERROR.EQ.'YES')RETURN CCCCC CALL DGEMM ('N', 'N', NBCH , NBCH, NLVL, ONE, WK1, NBCH, CALL DGEMM ('N', 'N', NBCH , NBCH, NLVL, ONE, XX, NBCH, $ XN, NLVL, ZERO, WK2, NBCH,IERROR) IF(IERROR.EQ.'YES')RETURN CCCCC CALL DSET (NLVL, WK1, ONE) CALL DSET (NLVL, XX, ONE) CCCCC CALL DGEMV ('T', NLVL, NBCH, ONE, XN, NLVL, WK1, 1,ZERO,WK3,1, CALL DGEMV ('T', NLVL, NBCH, ONE, XN, NLVL, XX, 1,ZERO,WK3,1, $ IERROR) IF(IERROR.EQ.'YES')RETURN CALL DSCAL (NBCH*NBCH, -ONE, WK2, 1) CALL DAXPY (NBCH, ONE, WK3, 1, WK2, NBCH+1) TR1 = DSUM (NBCH, WK2, NBCH+1) TR2 = DDOT (NBCH*NBCH, WK2, 1, WK2, 1) C C -- CHECK TO SEE IF BETWEEN-BATCH VARIANCE IS CONFOUNDED WITH FIXED PART C IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GINI')THEN WRITE(ICOUT,191)TR1,TR2,EPS CALL DPWRST('XXX','BUG') ENDIF 191 FORMAT('FROM REGINI--TR1,TR2,EPS=',3D15.7) IF (TR2 .LE. EPS) THEN IF(ICASRE.NE.'UREC')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG') WRITE(ICOUT,2001) CALL DPWRST('XXX','BUG') WRITE(ICOUT,2002) CALL DPWRST('XXX','BUG') WRITE(ICOUT,2003) CALL DPWRST('XXX','BUG') WRITE(ICOUT,2004) CALL DPWRST('XXX','BUG') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG') ENDIF CONFND = .TRUE. ELSE CONFND = .FALSE. END IF 999 FORMAT(' ') 2001 FORMAT(' REGINI : WARNING: BETWEEN-BATCH VARIANCE CANNOT') 2002 FORMAT(' BE ESTIMATED FROM THESE DATA. RESULTS') 2003 FORMAT(' WILL BE BASED ON THE ASSUMPTION THAT THE') 2004 FORMAT(' BETWEEN-BATCH VARIABILITY IS NEGLIGIBLE.') C C -- VARIANCE OF MEAN WHEN S2W = 0 CALL DGEMM ('T', 'N', NBCH, NPAR, NLVL, ONE, XN, NLVL, X, CCCCC$ NLVL, ZERO, WK1, NBCH, IERROR) $ NLVL, ZERO, XX, NBCH, IERROR) IF(IERROR.EQ.'YES')RETURN CCCCC CALL DGEMM ('T', 'N', NPAR, NPAR, NBCH, ONE, WK1, NBCH, WK1, CALL DGEMM ('T', 'N', NPAR, NPAR, NBCH, ONE, XX, NBCH, XX, $ NBCH, ZERO, WK2, NPAR, IERROR) IF(IERROR.EQ.'YES')RETURN CALL DGEMM ('N', 'N', NPAR, NPAR, NPAR, ONE, XTXI, NPAR, WK2, CCCCC$ NPAR, ZERO, WK1, NPAR, IERROR) $ NPAR, ZERO, XX, NPAR, IERROR) IF(IERROR.EQ.'YES')RETURN CCCCC CALL DGEMM ('N', 'N', NPAR, NPAR, NPAR, ONE, WK1, NPAR, XTXI, CALL DGEMM ('N', 'N', NPAR, NPAR, NPAR, ONE, XX, NPAR, XTXI, $ NPAR, ZERO, WK2, NPAR, IERROR) IF(IERROR.EQ.'YES')RETURN C C -- TOLERANCE LIMIT FACTORS C 8/97. REPLACE WITH DATAPLOT NODPPF ROUTINE. CCCCC ZCONT = PPND16 (CONT, IFAULT) CALL NODPPF (CONT, ZCONT) IF (.NOT. CONFND) GNU1 = TR1**2 /TR2 GNU0 = NTOT -IRANK1 NDF = IRANK2 -IRANK1 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GINI')THEN WRITE(ICOUT,2011)CONT,ZCONT,GNU0, NDF CALL DPWRST('XXX','BUG') ENDIF 2011 FORMAT('CONT,ZCONT, GNU0, NDF = ',3D15.7,I8) C C -- IF SIMULATED CRITICAL VALUES ARE TO BE USED, SKIP C THE HEADER LINE IN THE CRITICAL VALUE FILE CCCCC NOTE: FOR DATAPLOT, NOT ACTUALLY READING FILE, SO SKIP CCCCC THIS STEP. CCCCC IF (.NOT. SATT) THEN CCCCC READ (IN2,'(A)') DUMCHR CCCCC END IF DO 130 I=1, NPTS CALL DGEMV ('N', NPAR, NPAR, ONE, XTXI, NPAR, XPTS(I), NPTS, CCCCC$ ZERO, WK1, 1, IERROR) $ ZERO, XX, 1, IERROR) IF(IERROR.EQ.'YES')RETURN CCCCC ETA0(I) = ONE /DDOT (NPAR, WK1, 1, XPTS(I), NPTS) ETA0(I) = ONE /DDOT (NPAR, XX, 1, XPTS(I), NPTS) CALL DGEMV ('N', NPAR, NPAR, ONE, WK2, NPAR, XPTS(I), CCCCC$ NPTS, ZERO, WK1, 1, IERROR) $ NPTS, ZERO, XX, 1, IERROR) IF(IERROR.EQ.'YES')RETURN CCCCC ETA1(I) = ONE /DDOT (NPAR, WK1, 1, XPTS(I), NPTS) ETA1(I) = ONE /DDOT (NPAR, XX, 1, XPTS(I), NPTS) XNCP0 = ZCONT *SQRT(ETA0(I)) XNCP1 = ZCONT *SQRT(ETA1(I)) IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GINI')THEN WRITE(ICOUT,2021)I,XNCP0,XNCP1 CALL DPWRST('XXX','BUG') ENDIF 2021 FORMAT('I,XNCP0, XNCP1 = ',I8,D15.7,D15.7) C CCCCC 8/97. REPLACE FOLLOWING NON-CENTRAL T PPF WITH DATAPLOT CCCCC VERSION NCTPPF. CCCCC CALL INVNCT (CONF, GNU0, XNCP0, TLM0(I)) CALL NCTPPF (SNGL(CONF), SNGL(GNU0), SNGL(XNCP0), AJUNK) TLM0(I)=DBLE(AJUNK) IF (CONFND) THEN TLM1(I) = TLM0(I) ELSE CCCCC 8/97. REPLACE FOLLOWING NON-CENTRAL T PPF WITH DATAPLOT CCCCC VERSION DNTPPF. CCCCC CALL INVNCT (CONF, GNU1, XNCP1, TLM1(I)) CALL NCTPPF (SNGL(CONF), SNGL(GNU1), SNGL(XNCP1), AJUNK) TLM1(I)=DBLE(AJUNK) IF (.NOT. SATT) THEN CCCCC READ (IN2,*) CRT TLM1(I) = CRT(I) *SQRT(TR1 *ETA1(I)/GNU0) END IF END IF TLM0(I) = TLM0(I)/SQRT(ETA0(I)) TLM1(I) = TLM1(I)/SQRT(ETA1(I)) IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'GINI')THEN WRITE(ICOUT,2031)I,TLM0(I),TLM1(I),ETA0(I),ETA1(I) CALL DPWRST('XXX','BUG') ENDIF 2031 FORMAT('I,TLM0(I),TLM1(I),ETA0(I),ETA1(I) = ',I8,4D15.7) 130 CONTINUE RETURN END SUBROUTINE RELSD(X,N,IWRITE,XRELSD,IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C SAMPLE RELATIVE STANDARD DEVIATION C OF THE DATA IN THE INPUT VECTOR X. C THE SAMPLE RELATIVE STANDARD DEVIATION = 100 * (THE SAMPLE C STANDARD DEVIATION)/(THE SAMPLE MEAN). C THE DENOMINATOR N-1 IS USED IN COMPUTING THE C SAMPLE STANDARD DEVIATION. C THE SAMPLE RELATIVE STANDARD DEVIATION IS ALTERNATIVELY C REFERRED TO AS THE SAMPLE COEFFICIENT OF VARIATION. C THE SAMPLE STANDARD DEVIATION = SQRT((THE SUM OF THE C SQUARED DEVIATIONS ABOUT THE SAMPLE MEAN)/(N-1)). C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF C (UNSORTED OR SORTED) OBSERVATIONS. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X. C OUTPUT ARGUMENTS--XRELSD = THE SINGLE PRECISION VALUE OF THE C COMPUTED SAMPLE RELATIVE STANDARD DEVIATION. C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE C SAMPLE RELATIVE STANDARD DEVIATION. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--KENDALL AND STUART, THE ADVANCED THEORY OF C STATISTICS, VOLUME 1, EDITION 2, 1963, PAGES 47, 233. C --SNEDECOR AND COCHRAN, STATISTICAL METHODS, C EDITION 6, 1967, PAGES 62-65. 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 (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 --AUGUST 1981. C UPDATED --MAY 1982. C UPDATED --FEBRUARY 1994. USE ABS OF MEAN 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 DOUBLE PRECISION DMEAN DOUBLE PRECISION DVAR DOUBLE PRECISION DSD C DIMENSION X(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='RELS' ISUBN2='D ' C IERROR='NO' C DMEAN=0.0D0 DSD=0.0D0 C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF RELSD--') 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 RELATIVE STANDARD DEVIATION ** C ******************************************* C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C AN=N C IF(N.GE.1)GOTO119 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN RELSD--') 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 RELATIVE STANDARD DEVIATION IS TO BE ', 1'COMPUTED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,115) 115 FORMAT(' MUST BE 1 OR LARGER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,116) 116 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,117)N 117 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 1'.') CALL DPWRST('XXX','BUG ') GOTO9000 119 CONTINUE C IF(N.EQ.1)GOTO120 GOTO129 120 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,121) 121 FORMAT('***** NON-FATAL DIAGNOSTIC IN RELSD--', 1'THE 2ND INPUT ARGUMENT (N) HAS THE VALUE 1') CALL DPWRST('XXX','BUG ') XRELSD=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 RELSD--', 1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','BUG ') XRELSD=0.0 GOTO9000 139 CONTINUE C 190 CONTINUE C C ************************************************ C ** STEP 2-- ** C ** COMPUTE THE RELATIVE STANDARD DEVIATION. ** C ************************************************ C DN=N DSUM=0.0D0 DO200I=1,N DX=X(I) DSUM=DSUM+DX 200 CONTINUE DMEAN=DSUM/DN XMEAN=DMEAN C DSUM=0.0D0 DO300I=1,N DX=X(I) DSUM=DSUM+(DX-DMEAN)**2 300 CONTINUE DVAR=DSUM/(DN-1.0D0) DSD=0.0D0 IF(DVAR.GT.0.0D0)DSD=DSQRT(DVAR) CCCCC MODIFY FOLLOWING LINE. FEBRUARY 1994. CCCCC XRELSD=100.0D0*DSD/DMEAN XRELSD=100.0D0*DSD/ABS(DMEAN) 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,XRELSD 811 FORMAT('THE RELATIVE STANDARD DEVIATION OF THE ',I8, 1' OBSERVATIONS = ',E15.7,' PERCENT') 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 RELSD--') 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)DMEAN,DSD 9014 FORMAT('DMEAN,DSD = ',2D15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)XRELSD 9015 FORMAT('XRELSD = ',E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE REPEAT(Y,X,XIDTEM,TEMP,N,IWRITE,XREP, 1ISUBRO,IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE SAMPLE REPEATABILITY C STANDARD DEVIATION OF THE DATA IN THE INPUT VECTOR Y C WITH LAB ID VECTOR X. 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--XREP = THE SINGLE PRECISION VALUE OF THE C COMPUTED SAMPLE REPEATABILITY SD. C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE C SAMPLE REPEATABILITY SD. 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 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='REPE' ISUBN2='AT ' C IERROR='NO' C IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PEAT')THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF REPEAT--') 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 ** COMPUTE REPEAT ** C ******************** 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 REPEATABILITY SD--') 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 REPEATABILITY SD IS ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,115) 115 FORMAT(' 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 REPEATABILTY STANDARD DEVIATION. ** 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 AN=N ANUMSE=NUMSET 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 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PEAT')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))) C C ******************************* C ** STEP 3-- ** C ** WRITE OUT A LINE ** C ** OF SUMMARY INFORMATION. ** C ******************************* C IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,811)XREP 811 FORMAT('THE REPEATABILITY STANDARD DEVIATION = ',E15.7) CALL DPWRST('XXX','BUG ') ENDIF C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PEAT')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF REPEAT--') 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 ') ENDIF C RETURN END SUBROUTINE REPLAC(X,Z,NX,VAL,NVAL,IWRITE,Y,ICASE, 1 ISUBRO,IBUGA3,IERROR) C C PURPOSE--THIS COMMAND IS A VARIANT OF THE MATCH COMMAND. C THE SYNTAX C LET Y2 = REPLACE GROUPID GROUP2 Y1 C DOES THE FOLLOWING: C 1) IT MATCHES THE VALUES IN GROUP2 AGAINST C GROUPID AND RETURNS THE INDICES OF THE C MATCHING ROWS FOR THE GROUPID ARRAY. C 2) THE INDEX IS USED TO ACCESS THE CORRESPONDING C VALUE IN THE Y1 ARRAY. C 3) THE CORRESPONDING ROW OF Y2 IS REPLACED WITH C THE Y1 VALUE. C NOTE THAT Y2, GROUPID, AND Y1 SHOULD HAVE THE C SAME LENGTH. ALSO, IT IS ASSUMED THAT Y1 C ALREADY EXISTS. THIS SHOULD BE CHECKED FOR BEFORE C CALLING THIS ROUTINE. C C THE SHORTHAND SYNTAX C LET Y2 = REPLACE GROUPID GROUP C SIMPLY ASSIGNS A VALUE OF 1 IN THE CORRESPONDING C ROW OF Y2 (THIS IS A CONVENIENT SYNTAX FOR C CREATING A TAG VARIABLE). THIS CASE IS IDENTIFIED C WITH THE "ICASE=INDE" OPTION. 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*4 ICASE CHARACTER*4 IWRITE CHARACTER*4 ISUBRO CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C C------------------------------------------------------------------ C DIMENSION X(*) DIMENSION Y(*) DIMENSION Z(*) DIMENSION VAL(*) C C--------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT 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='MATC' ISUBN2='H ' C IERROR='NO' C IF(ISUBRO.EQ.'PLAC' .OR. IBUGA3.EQ.'ON')THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF REPLAC--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)NX,NVAL 53 FORMAT('NX,NVAL = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,NX WRITE(ICOUT,56)I,X(I),Z(I),Y(I) 56 FORMAT('I,X(I),Z(I),Y(I) = ',I8,3G15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE DO65I=1,NVAL WRITE(ICOUT,66)I,VAL(I) 66 FORMAT('I,VAL(I) = ',I8,G15.7) CALL DPWRST('XXX','BUG ') 65 CONTINUE ENDIF C C **************************************** C ** COMPUTE INDICES OF MATCHING VALUES * C **************************************** C DO100I=1,NVAL VALTMP=VAL(I) INDTMP=1 YDIFF=CPUMAX DO200J=1,NX APROD=X(J)*VALTMP TERM1=MAX(X(J),VALTMP) TERM2=MIN(X(J),VALTMP) IF(APROD.GT.0.0)THEN ADIFF=ABS(ABS(TERM1) - ABS(TERM2)) ELSEIF(APROD.LT.0.0)THEN ADIFF=TERM1+ABS(TERM2) ELSE ADIFF=ABS(TERM1-TERM2) ENDIF IF(ADIFF.LT.YDIFF)THEN INDTMP=J YDIFF=ADIFF ENDIF 200 CONTINUE IF(ICASE.EQ.'INDE')THEN Y(INDTMP)=1.0 ELSE Y(INDTMP)=Z(INDTMP) ENDIF 100 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE C IF(ISUBRO.EQ.'PLAC' .OR. IBUGA3.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF REPLAC--') 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 = ',2I8) CALL DPWRST('XXX','BUG ') DO9015I=1,NX WRITE(ICOUT,9016)I,X(I),Z(I),Y(I) 9016 FORMAT('I,X(I),Z(I),Y(I) = ',I8,3G15.7) CALL DPWRST('XXX','BUG ') 9015 CONTINUE ENDIF C RETURN END SUBROUTINE REPROD(Y,X,XIDTEM,TEMP,TEMP2,N,IWRITE,XREP, 1ISUBRO,IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE SAMPLE REPRODUCABILITY C STANDARD DEVIATION OF THE DATA IN THE INPUT VECTOR Y C WITH LAB ID VECTOR X. THE REPRODUCABILITY STANDARD C DEVIATION IS DEFINED AS: C C SR = MAX(SR*,Sr) C C WITH C C SR* = SQRT(s(x)**2 + (Sr**2*(n-1)/n) C C s(xbar) = STANDARD DEVIATION OF THE CELL C AVERAGES C n = CELL SAMPLE SIZE (CURRENTLY, EQUAL C CELL SIZES EXPECTED) C C AND Sr DENOTING THE REPEATABILITY STANDARD DEVIATION 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--XREP = THE SINGLE PRECISION VALUE OF THE C COMPUTED SAMPLE REPRODUCABILITY SD. C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE C SAMPLE REPRODUCABILITY SD. 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 DOUBLE PRECISION DXREP DOUBLE PRECISION XREPRD C DIMENSION Y(*) DIMENSION X(*) 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='REPE' ISUBN2='AT ' C IERROR='NO' C IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PROD')THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF REPROD--') 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 ** COMPUTE REPROD ** C ********************** 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 REPRODUCABILITY SD--') 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 REPRODUCABILITY SD IS ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,115) 115 FORMAT(' 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 REPRODABILTY STANDARD DEVIATION. ** 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 AN=N ANUMSE=NUMSET 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 C IF(ISET1.EQ.1)THEN NHOLD=NTEMP ELSE IF(NTEMP.NE.NHOLD)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1131)ISET1,NHOLD,NTEMP 1131 FORMAT(' FOR GROUP ',I8,', ',I8, 1 'ELEMENTS EXPECTED BUT ',I8,' ELEMENTS FOUND.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF ENDIF C CALL MEAN(TEMP,NTEMP,IWRITE,XMEAN,IBUGA3,IERROR) CALL SD(TEMP,NTEMP,IWRITE,XSD,IBUGA3,IERROR) DSUM=DSUM + DBLE(XSD)**2 TEMP2(ISET1)=XMEAN IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PROD')THEN WRITE(ICOUT,1151)NUMSET,XSD 1151 FORMAT('***** GROUP ',I8,': MEAN, SD = ',2G15.7) CALL DPWRST('XXX','BUG ') ENDIF 1110 CONTINUE C DXREP=DSUM/DBLE(NUMSET) CALL SD(TEMP2,NUMSET,IWRITE,SXBAR,IBUGA3,IERROR) XREPRD=DSQRT(DBLE(SXBAR**2) + DXREP*DBLE(NHOLD-1)/DBLE(NHOLD)) XREP=REAL(MAX(DSQRT(DXREP),XREPRD)) C C ******************************* C ** STEP 3-- ** C ** WRITE OUT A LINE ** C ** OF SUMMARY INFORMATION. ** C ******************************* C IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,811)XREP 811 FORMAT('THE REPRODUCABILITY STANDARD DEVIATION = ',E15.7) CALL DPWRST('XXX','BUG ') ENDIF C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PROD')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF REPROD--') 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,DXREP,XREPRD 9015 FORMAT('XREP,DXREP,XREPRD = ',3G15.7) CALL DPWRST('XXX','BUG ') ENDIF C RETURN END SUBROUTINE RESULT(NR,N,X,F,G,A,P,ITNCNT,IFLG,IPRTMP) IMPLICIT DOUBLE PRECISION (A-H,O-Z) C C PURPOSE C ------- C PRINT INFORMATION (FOR OPTIMIZE COMMAND) C C PARAMETERS C ---------- C NR --> ROW DIMENSION OF MATRIX C N --> DIMENSION OF PROBLEM C X(N) --> ITERATE X[K] C F --> FUNCTION VALUE AT X[K] C G(N) --> GRADIENT AT X[K] C A(N,N) --> HESSIAN AT X[K] C P(N) --> STEP TAKEN C ITNCNT --> ITERATION NUMBER K C IFLG --> FLAG CONTROLLING INFO TO PRINT C IPR --> DEVICE TO WHICH TO SEND OUTPUT C DIMENSION X(N),G(N),P(N),A(NR,1) C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C REAL CPUMIN, CPUMAX COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C PRINT ITERATION NUMBER WRITE(ICOUT,903) ITNCNT CALL DPWRST('XXX','BUG ') IF(IFLG.EQ.0) GO TO 120 C C PRINT STEP WRITE(ICOUT,907) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,905) (P(I),I=1,N) CALL DPWRST('XXX','BUG ') C C PRINT CURRENT ITERATE 120 CONTINUE WRITE(ICOUT,904) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,905) (X(I),I=1,N) CALL DPWRST('XXX','BUG ') C C PRINT FUNCTION VALUE WRITE(ICOUT,906) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,905) F CALL DPWRST('XXX','BUG ') C C PRINT GRADIENT WRITE(ICOUT,908) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,905) (G(I),I=1,N) CALL DPWRST('XXX','BUG ') C C PRINT HESSIAN FROM ITERATION K IF(IFLG.EQ.0) GO TO 140 WRITE(ICOUT,901) CALL DPWRST('XXX','BUG ') DO 130 I=1,N WRITE(ICOUT,900) I CALL DPWRST('XXX','BUG ') WRITE(ICOUT,902) (A(I,J),J=1,I) CALL DPWRST('XXX','BUG ') 130 CONTINUE C 140 RETURN 900 FORMAT('****** FROM RESULT ROW',I5) 901 FORMAT('****** FROM RESULT HESSIAN AT X(K)') 902 FORMAT('****** FROM RESULT ',5(2X,E20.13)) 903 FORMAT('****** FROM RESULT ITERATE K=',I5) 904 FORMAT('****** FROM RESULT X(K)') 905 FORMAT('****** FROM RESULT ',5(2X,E20.13)) 906 FORMAT('****** FROM RESULT FUNCTION AT X(K)') 907 FORMAT('****** FROM RESULT STEP') 908 FORMAT('****** FROM RESULT GRADIENT AT X(K)') END SUBROUTINE REVERS(X,NX,IWRITE,Y,YTEMP,IBUGA3,IERROR) C C PURPOSE--REVERSE THE ORDER OF AN ARRAY. THAT IS, C Y(1)=X(N), ..., Y(N)=X(1). 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 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--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 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='REVE' ISUBN2='RS ' 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 REVERS--') 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 ** FLIP ORDER OF ARRAY ** C ************************************** C DO100I=1,NX IREV=NX-I+1 YTEMP(I)=X(IREV) 100 CONTINUE DO200I=1,NX Y(I)=YTEMP(I) 200 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 REVERS--') 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 REVRT(X, M) C C ALGORITHM AS 97.1 APPL. STATIST. (1976) VOL.25, NO. 2 C C Inverse discrete Fourier transform in one dimension of real C data using complex transform subroutine FASTG. C C X = array of Fourier components as output from subroutine FORRT, C type real, dimension M. C M = length of the inverse transform, must be a power of 2. C The minimum length is 8, maximum 2**21. C C Auxiliary routines required: SCRAG & FASTG from AS 83, but C with SCRAG modified as described on page 168 of the paper for C this algorithm. C IMPLICIT DOUBLE PRECISION (A-H, O-Z) DOUBLE PRECISION X(M) DATA ZERO/0.0D0/, HALF/0.5D0/, ONE/1.0D0/, ONE5/1.5D0/, * TWO/2.0D0/, FOUR/4.0D0/ C C Check for valid transform size. C II = 8 DO 2 K = 3, 21 IPOW = K IF (II .EQ. M) GO TO 3 II = II * 2 2 CONTINUE C C If this point is reached, an illegal size was specified. C RETURN 3 PIE = FOUR * ATAN(ONE) N = M / 2 NN = N / 2 C C Undo the spectrum into that of two interleaved series. C First, the special cases. C Z = X(1) + X(N+1) X(N+1) = X(1) - X(N+1) X(1) = Z NN1 = NN + 1 NN2 = NN1 + N X(NN1) = TWO * X(NN1) X(NN2) = -TWO * X(NN2) Z = PIE / N BCOS = -TWO * (SIN(Z / TWO) **2) BSIN = SIN(Z) UN = ONE VN = ZERO DO 4 K = 2, NN Z = UN * BCOS + VN * BSIN + UN VN = VN * BCOS - UN * BSIN + VN SAVE1 = ONE5 - HALF * (Z * Z + VN * VN) UN = Z * SAVE1 VN = VN * SAVE1 KI = N + K L = N + 2 - K LI = N + L AN = X(K) + X(L) BN = X(KI) - X(LI) PN = X(K) - X(L) QN = X(KI) + X(LI) CN = UN * PN + VN * QN DN = UN * QN - VN * PN X(K) = AN - DN X(KI) = BN + CN X(L) = AN + DN X(LI) = CN - BN 4 CONTINUE C C Now do the inverse transform C CALL FASTG(X, X(N+1), N, -1) C C Now undo the order - the half arrays are already bit reversed; C bit reverse the whole array. C CALL SCRAG(X, M, IPOW) RETURN END SUBROUTINE RIGCDF(X,GAMMA,AMU,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE RECIPROCAL INVERSE GAUSSIAN C DISTRIBUTION WITH SHAPE PARAMETERS GAMMA AND MU. C THE RECIPROCAL INVERSE GAUSSIAN DISTRIBUTION IS C THE DISTRIBUTION OF Y = 1/X WHEN X HAS AN INVERSE C GAUSSIAN DISTRIBUTION. C THE FORMULA FOR THE CDF OF THE RECIROCAL INVERSE C GAUSIAN DISTRIBUTION IS: C F(X,GAMMA,MU) = NORCDF{-[1/(MU*X) - 1]*SQRT(GAMMA*X)} - C EXP[2*GAMMA/MU]*NORCDF{-[1/(MU*X) - 1]*SQRT(GAMMA*X)} - C X, GAMMA, MU > 0 C NOTE--THE RECIPROCAL INVERSE GAUSSIA DISTRIBUTION CAN BE C COMPUTED IN TERMS OF THE INVERSE GAUSSIAN CDF: C RIGCDF(X,GAMMA,MU) = 1 - IGCDF(1/X,GAMMA,MU) 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 --GAMMA = THE SHAPE PARAMETER C GAMMA SHOULD BE POSITIVE. C --AMU = 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 RECIPROCAL INVERSE C GAUSSIAN DISTRIBUTION C WITH SHAPE PARAMETERS GAMMA AND MU C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--X SHOULD BE POSITIVE. C --GAMMA SHOULD BE POSITIVE. C OTHER DATAPAC SUBROUTINES NEEDED--IGCDF. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--SAM SAUNDERS TALK, MAY 1990 C REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--1, 1970, PAGES 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--90.6 C ORIGINAL VERSION--MAY 1990. C UPDATED --DECEMBER 2003. SUPPORT FOR GENERAL MU C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT 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 'RIGCDF 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 FOR THE ', 1 'RIGPDF SUBROUTINE IS NON-POSITIVE *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)AMU CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9000 ENDIF C IF(X.LT.0.0)THEN WRITE(ICOUT,61) 61 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO THE ', 1 'RIGPDF SUBROUTINE IS NON-POSITIVE *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)X CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9000 ENDIF C IF(X.EQ.0.0)THEN PDF=0.0 GOTO9000 ENDIF C X2=1.0/X CALL IGCDF(X2,GAMMA,AMU,CDF) CDF=1.0-CDF C 9000 CONTINUE RETURN END SUBROUTINE RIGCHA(X,GAMMA,AMU,HAZ) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE HAZARD C FUNCTION VALUE FOR THE RECIPROCAL INVERSE GAUSSIAN C DISTRIBUTION WITH SHAPE PARAMETERS GAMMA AND MU. C THE RECIPROCAL INVERSE GAUSSIAN DISTRIBUTION IS C THE DISTRIBUTION OF Y = 1/X WHEN X HAS AN INVERSE C GAUSSIAN DISTRIBUTION. 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 --AMU = THE SHAPE PARAMETER C MU SHOULD BE POSITIVE. C OUTPUT ARGUMENTS--HAZ = THE SINGLE PRECISION CUMULATIVE HAZARD C FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION CUMULATIVE HAZARD C FUNCTION VALUE PDF FOR THE RECIPROCAL INVERSE GAUSSIAN C DISTRIBUTION WITH SHAPE PARAMETERS GAMMA AND 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--RIGDF. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--SAM SAUNDERS TALK, MAY 1990 C REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--1, 1970, PAGES 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--98.6 C ORIGINAL VERSION--APRIL 1998. C UPDATED --DECEMBER 2003. SUPPORT FOR GENERAL MU C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT 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 'RIGCHA 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 'RIGPDF 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 ARGUMENT TO THE ', 1 'RIGPDF 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 ELSEIF(X.GT.0.0)THEN CALL RIGCDF(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 SUBROUTINE RIGHAZ(X,GAMMA,AMU,HAZ) C C PURPOSE--THIS SUBROUTINE COMPUTES THE HAZARD C FUNCTION VALUE FOR THE RECIPROCAL INVERSE GAUSSIAN C DISTRIBUTION WITH SHAPE PARAMETERS GAMMA AND MU. C THE RECIPROCAL INVERSE GAUSSIAN DISTRIBUTION IS C THE DISTRIBUTION OF Y = 1/X WHEN X HAS AN INVERSE C GAUSSIAN DISTRIBUTION. 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 --AMU = 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 HAZARD FOR THE RECIPROCAL INVERSE C GAUSSIAN DISTRIBUTION C WITH SHAPE PARAMETERS GAMMA AND 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--RIGCDF, RIGPDF. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--SAM SAUNDERS TALK, MAY 1990 C REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--1, 1970, PAGES 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--98.6 C ORIGINAL VERSION--APRIL 1998. 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 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 'RIGPDF 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 'RIGPDF 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 ARGUMENT TO THE ', 1 'RIGPDF 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 ELSEIF(X.GT.0.0)THEN CALL RIGCDF(X,GAMMA,AMU,CDF) CDF=1.0-CDF IF(CDF.GT.0.0)THEN CALL RIGPDF(X,GAMMA,AMU,PDF) 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 RIGPDF(X,GAMMA,AMU,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE RECIPROCAL INVERSE GAUSSIAN C DISTRIBUTION WITH SHAPE PARAMETERS GAMMA AND MU. C THE RECIPROCAL INVERSE GAUSSIAN DISTRIBUTION IS C THE DISTRIBUTION OF Y = 1/X WHEN X HAS AN INVERSE C GAUSSIAN DISTRIBUTION. C THE FORMULA FOR THE RECIPROCAL INVERSE GAUSSIAN C PROBABILITY DENSITY FUNCTION IS: C f(X,GAMMA,MU)=SQRT(GAMMA/(2*PI*X)]* C EXP[-GAMMA*(1-MU*X)**2/(2*MU**2*X)] C X, GAMMA, MU > 0 C NOTE--THE RECIPROCAL INVERSE GAUSSIA DISTRIBUTION CAN BE C COMPUTED IN TERMS OF THE INVERSE GAUSSIAN PDF: C RIGPDF(X,GAMMA,MU)=IGPDF(1/X,GAMMA,MU)/(X**2) C NOTE--THE RECIPROCAL INVERSE GAUSSIAN DISTRIBUTION-- C GOES FROM 0 TO INFINITY C HAS MEAN = (GAMMA + MU)/(GAMMA*MU) C HAS STANDARD DEVIATION=SQRT((GAMMA+2*MU)/(GAMMA**2*MU)) C IS NEAR-SYMMETRIC AND MODERATE-TAILED FOR SMALL GAMMA C IS HIGHLY-SKEWED AND LONG-TAILED FOR LARGE GAMMA C APPROACHES NORMALITY AS GAMMA APPROACHES 0 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 --AMU = THE SHAPE PARAMETER C MU 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 RECIPROCAL INVERSE GAUSSIAN C DISTRIBUTION WITH SHAPE PARAMETERS GAMMA AND 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--IGPDF. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--SAM SAUNDERS TALK, MAY 1990 C REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--1, 1970, PAGES 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--90.6 C ORIGINAL VERSION--MAY 1990. 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 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 'RIGPDF 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 'RIGPDF 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 'RIGPDF 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 X2=1.0/X CALL IGPDF(X2,GAMMA,AMU,PDF) PDF=PDF/(X**2) C 9000 CONTINUE RETURN END SUBROUTINE RIGPPF(P,GAMMA,AMU,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE RECIPROCAL INVERSE GAUSSIAN C DISTRIBUTION WITH SHAPE PARAMETERS GAMMA AND MU. C THE RECIPROCAL INVERSE GAUSSIAN DISTRIBUTION IS C THE DISTRIBUTION OF Y = 1/X WHEN X HAS AN INVERSE C GAUSSIAN DISTRIBUTION. C NOTE--THE RECIPROCAL INVERSE GAUSSIAN PPF CAN BE C COMPUTED IN TERMS OF THE INVERSE GAUSSIAN PPF: C RIGPPF(P,GAMMA,MU) = 1/IGPPF(1-P,GAMMA,MU) 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 MU 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 PARAMETERS GAMMA AND 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 AND MU SHOULD BE POSITIVE C OTHER DATAPAC SUBROUTINES NEEDED--IGPPF C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--SAM SAUNDERS TALK, MAY 1990 C REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--1, 1970, PAGES 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--90.6 C ORIGINAL VERSION--MAY 1990. 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 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 'RIGPPF 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 FOR THE ', 1 'RIGPPF 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 FOR THE ', 1 'RIGPPF 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 P2=1.0-P CALL IGPPF(P2,GAMMA,AMU,PPF) PPF=1.0/PPF C 9000 CONTINUE RETURN END SUBROUTINE RIGRAN(N,GAMMA,AMU,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE RECIPROCAL INVERSE GAUSSIAN DISTRIBUTION C WITH SHAPE PARAMETERS GAMMA AND MU. 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 --AMU = THE SHAPE PARAMETER C MU 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 RECIPROCAL INVERSE GAUSSIAN DISTRIBUTION C WITH TAIL LENGTH PARAMETERS GAMMA AND MU. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C --GAMMA AND MU SHOULD BE POSITIVE. C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN, RIGPPF. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON AND KOTZ C --SAM SAUNDERS 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 (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 --DECEMBER 2003. USE GENERAL VALUE OF MU C INSTEAD OF ASSUMING MU=1 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 ', 1 'RECIPROCAL INVERSE GAUSSIAN RANDOM NUMBERS IS *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)N 52 FORMAT('***** NON-POSITIVE. THE VALUE OF THE ARGUMENT IS ', 1 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 ' RECIPROCAL 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 ' RECIPROCAL 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 CALL UNIRAN(N,ISEED,X) C C GENERATE N RECIP. INV. GAUS. DISTRIBUTION RANDOM NUMBERS C USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD. C DO100I=1,N XTEMP=X(I) CALL RIGPPF(XTEMP,GAMMA,AMU,X(I)) 100 CONTINUE C 9000 CONTINUE RETURN END DOUBLE PRECISION FUNCTION RNOR() * * RNOR generates normal random numbers with zero mean and unit * standard deviation, often denoted N(0,1),adapted from G. Marsaglia * and W. W. Tsang: "A Fast, Easily Implemented Method for Sampling * from Decreasing or Symmetric Unimodal Density Functions" * SIAM J. Sci. Stat. Comput. 5(1984), pp. 349-359. * INTEGER J, N, TN DOUBLE PRECISION TWOPIS, AA, B, C, XDN PARAMETER ( N = 64, TN = 2*N, TWOPIS = TN/2.506628274631000D0 ) PARAMETER ( XDN = 0.3601015713011893D0, B = 0.4878991777603940D0 ) PARAMETER ( AA = 12.37586029917064D0, C = 12.67705807886560D0 ) DOUBLE PRECISION XT, XX, Y, UNI DOUBLE PRECISION X(0:N) SAVE X DATA ( X(J), J = 0, 31 ) / & 0.3409450287039653D+00, 0.4573145918669259D+00, & 0.5397792816116612D+00, 0.6062426796530441D+00, & 0.6631690627645207D+00, 0.7136974590560222D+00, & 0.7596124749339174D+00, 0.8020356003555283D+00, & 0.8417226679789527D+00, 0.8792102232083114D+00, & 0.9148948043867484D+00, 0.9490791137530882D+00, & 0.9820004812398864D+00, 0.1013849238029940D+01, & 0.1044781036740172D+01, 0.1074925382028552D+01, & 0.1104391702268125D+01, 0.1133273776243940D+01, & 0.1161653030133931D+01, 0.1189601040838737D+01, & 0.1217181470700870D+01, 0.1244451587898246D+01, & 0.1271463480572119D+01, 0.1298265041883197D+01, & 0.1324900782180860D+01, 0.1351412509933371D+01, & 0.1377839912870011D+01, 0.1404221063559975D+01, & 0.1430592868502691D+01, 0.1456991476137671D+01, & 0.1483452656603219D+01, 0.1510012164318519D+01 / DATA ( X(J), J = 32, 64 ) / & 0.1536706093359520D+01, 0.1563571235037691D+01, & 0.1590645447014253D+01, 0.1617968043674446D+01, & 0.1645580218369081D+01, 0.1673525509567038D+01, & 0.1701850325062740D+01, 0.1730604541317782D+01, & 0.1759842199038300D+01, 0.1789622321566574D+01, & 0.1820009890130691D+01, 0.1851077020230275D+01, & 0.1882904397592872D+01, 0.1915583051943031D+01, & 0.1949216574916360D+01, 0.1983923928905685D+01, & 0.2019843052906235D+01, 0.2057135559990095D+01, & 0.2095992956249391D+01, 0.2136645022544389D+01, & 0.2179371340398135D+01, 0.2224517507216017D+01, & 0.2272518554850147D+01, 0.2323933820094302D+01, & 0.2379500774082828D+01, 0.2440221797979943D+01, & 0.2507511701865317D+01, 0.2583465835225429D+01, & 0.2671391590320836D+01,4*0.2776994269662875D+01 / Y = UNI() J = MOD( INT( TN*UNI() ), N ) XT = X(J+1) RNOR = ( Y + Y - 1 )*XT IF ( ABS(RNOR) .GT. X(J) ) THEN XX = B*( XT - ABS(RNOR) )/( XT - X(J) ) Y = UNI() IF ( Y .GT. C - AA*EXP( -XX**2/2 ) ) THEN RNOR = SIGN( XX, RNOR ) ELSE IF ( EXP(-XT**2/2)+Y/(TWOPIS*XT).GT.EXP(-RNOR**2/2) ) THEN 10 XX = XDN*LOG( UNI() ) IF ( -2*LOG( UNI() ) .LE. XX**2 ) GO TO 10 RNOR = SIGN( X(N) - XX, RNOR ) END IF END IF END IF C RETURN END SUBROUTINE RNORM(U1, U2, ISEED) C C ALGORITHM AS 53.1 APPL. STATIST. (1972) VOL.21, NO.3 C C Sets U1 and U2 to two independent standardized random normal C deviates. This is a Fortran version of the method given in C Knuth(1969). C C Function RAND must give a result randomly and rectangularly C distributed between the limits 0 and 1 exclusive. C REAL U1, U2 REAL XTEMP(1) C C Local variables C REAL X, Y, S, ONE, TWO DATA ONE /1.0/, TWO /2.0/ C 1 CONTINUE N1 = 1 CALL UNIRAN(N1,ISEED,XTEMP) X = XTEMP(1) CALL UNIRAN(N1,ISEED,XTEMP) Y = XTEMP(1) C X = TWO * X - ONE Y = TWO * Y - ONE S = X * X + Y * Y IF (S .GT. ONE) GO TO 1 S = SQRT(- TWO * LOG(S) / S) U1 = X * S U2 = Y * S RETURN END SUBROUTINE RSURF(X,Y,NP,KOLR,FRM, 1XTEMP,YTEMP,TATEMP,NTEMP,NTRACE, 1IBUGG3,ISUBRO,IERROR) C C PURPOSE--PAINT IN THE ENCLOSED REGION C DEFINED BY THE NP COORDINATES C IN X(.) AND Y(.). C USE FILL COLOR AS SPECIFIED BY THE INTEGER KOLR C (WHERE KOLR = 0 IMPLIES NO FILL). C C WRITTEN BY--DAVID W. BEHRINGER NOAA/AOML (MIAMI). C AS PART OF NOAA'S CONCX V.3 MARCH 1988. C ORIGINAL VERSION (IN DATAPLOT)--AUGUST 1988. C C--------------------------------------------------------------------- C CHARACTER*4 IBUGG3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C DIMENSION X(*) DIMENSION Y(*) C DIMENSION XTEMP(*) DIMENSION YTEMP(*) DIMENSION TATEMP(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'SURF')GOTO1010 GOTO1019 1010 CONTINUE WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1011)NP,KOLR,FRM 1011 FORMAT('FROM RSURF--NP,KOLR,FRM = ',2I8,F10.5) CALL DPWRST('XXX','BUG ') DO1015I=1,NP WRITE(ICOUT,1016)I,X(I),Y(I) 1016 FORMAT(' I,X(I),Y(I) = ',I8,2F10.5) CALL DPWRST('XXX','BUG ') 1015 CONTINUE 1019 CONTINUE C CCCCC NTRACE=NTRACE+1 CCCCC DO1100I=1,NP CCCCC NTEMP=NTEMP+1 CCCCC XTEMP(NTEMP)=X(I) CCCCC YTEMP(NTEMP)=Y(I) CCCCC TATEMP(NTEMP)=NTRACE C1100 CONTINUE C RETURN END SUBROUTINE RULNRM( LENRUL, NUMNUL, RULPTS, W, RULCON ) INTEGER LENRUL, NUMNUL, I, J, K, RULPTS(*) DOUBLE PRECISION ALPHA, NORMCF, NORMNL, W(LENRUL, *), RULCON * * Compute orthonormalized null rules. * NORMCF = 0 DO 100 I = 1,LENRUL NORMCF = NORMCF + RULPTS(I)*W(I,1)*W(I,1) 100 CONTINUE DO 200 K = 2,NUMNUL DO 300 I = 1,LENRUL W(I,K) = W(I,K) - W(I,1) 300 CONTINUE DO 400 J = 2,K-1 ALPHA = 0 DO 500 I = 1,LENRUL ALPHA = ALPHA + RULPTS(I)*W(I,J)*W(I,K) 500 CONTINUE ALPHA = -ALPHA/NORMCF DO 600 I = 1,LENRUL W(I,K) = W(I,K) + ALPHA*W(I,J) 600 CONTINUE 400 CONTINUE NORMNL = 0 DO 700 I = 1,LENRUL NORMNL = NORMNL + RULPTS(I)*W(I,K)*W(I,K) 700 CONTINUE ALPHA = SQRT(NORMCF/NORMNL) DO 800 I = 1,LENRUL W(I,K) = ALPHA*W(I,K) 800 CONTINUE 200 CONTINUE DO 900 J = 2, NUMNUL DO 950 I = 1,LENRUL W(I,J) = W(I,J)/RULCON 950 CONTINUE 900 CONTINUE C RETURN END FUNCTION RUNIF(T,N) C***BEGIN PROLOGUE RUNIF C***DATE WRITTEN 770401 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***REVISION HISTORY (YYMMDD) C 000330 Modified array declarations. (JEC) C***CATEGORY NO. L6A21 C***KEYWORDS RANDOM NUMBER,SPECIAL FUNCTION,UNIFORM C***AUTHOR FULLERTON, W., (LANL) C***PURPOSE A portable random number genaerator. C***DESCRIPTION C C This random number generator is portable among a wide variety of C computers. It generates a random number between 0.0 and 1.0 accord- C ing to the algorithm presented by Bays and Durham (TOMS, 2, 59, C 1976). The motivation for using this scheme, which resembles the C Maclaren-Marsaglia method, is to greatly increase the period of the C random sequence. If the period of the basic generator (RAND) is P, C then the expected mean period of the sequence generated by RUNIF is C given by new mean P = SQRT (PI*FACTORIAL(N)/(8*P)), C where FACTORIAL(N) must be much greater than P in this asymptotic C formula. Generally, N should be around 32 if P=4.E6 as for RAND. C C Input Argument -- C N IABS(N) is the number of random numbers in an auxiliary table. C Note though that IABS(N)+1 is the number of items in array T. C If N is positive and differs from its value in the previous C invocation, then the table is initialized for the new value of C N. If N is negative, IABS(N) is the number of items in an C auxiliary table, but the tables are now assumed already to C be initialized. This option enables the user to save the C table T at the end of a long computer run and to restart with C the same sequence. Normally, RUNIF would be called at most C once with negative N. Subsequent invocations would have N C positive and of the correct magnitude. C C Input and Output Argument -- C T an array of IABS(N)+1 random numbers from a previous invocation C of RUNIF. Whenever N is positive and differs from the old C N, the table is initialized. The first IABS(N) numbers are the C table discussed in the reference, and the N+1 -st value is Y. C This array may be saved in order to restart a sequence. C C Output Value -- C RUNIF a random number between 0.0 and 1.0. C***REFERENCES (NONE) C***ROUTINES CALLED RAND C***END PROLOGUE RUNIF DIMENSION T(*) EXTERNAL RAND DATA NOLD /-1/ C***FIRST EXECUTABLE STATEMENT RUNIF IF (N.EQ.NOLD) GO TO 20 C NOLD = IABS(N) FLOATN = NOLD IF (N.LT.0) DUMMY = RAND (T(NOLD+1)) IF (N.LT.0) GO TO 20 C DO 10 I=1,NOLD T(I) = RAND (0.) 10 CONTINUE T(NOLD+1) = RAND (0.) C 20 J = T(NOLD+1)*FLOATN + 1. T(NOLD+1) = T(J) RUNIF = T(J) T(J) = RAND (0.) C RETURN END subroutine rwts(y,n,fit,rw) c c This routine is part of the Bill Cleveland seasonal loess c program. c integer mid(2), n real y(n), fit(n), rw(n), cmad, c9, c1, r do 23097 i = 1,n rw(i) = abs(y(i)-fit(i)) 23097 continue mid(1) = n/2+1 mid(2) = n-mid(1)+1 call psort(rw,n,mid,2) cmad = 3.0*(rw(mid(1))+rw(mid(2))) c9 = .999*cmad c1 = .001*cmad do 23099 i = 1,n r = abs(y(i)-fit(i)) if(.not.(r .le. c1))goto 23101 rw(i) = 1. goto 23102 23101 continue if(.not.(r .le. c9))goto 23103 rw(i) = (1.0-(r/cmad)**2)**2 goto 23104 23103 continue rw(i) = 0. 23104 continue 23102 continue 23099 continue return end SUBROUTINE R9AIMP (X, AMPL, THETA) C***BEGIN PROLOGUE R9AIMP C***SUBSIDIARY C***PURPOSE Evaluate the Airy modulus and phase. C***LIBRARY SLATEC (FNLIB) C***CATEGORY C10D C***TYPE SINGLE PRECISION (R9AIMP-S, D9AIMP-D) C***KEYWORDS AIRY FUNCTION, FNLIB, MODULUS, PHASE, SPECIAL FUNCTIONS C***AUTHOR Fullerton, W., (LANL) C***DESCRIPTION C C Evaluate the Airy modulus and phase for X .LE. -1.0 C C Series for AM21 on the interval -1.25000D-01 to 0. C with weighted error 2.89E-17 C log weighted error 16.54 C significant figures required 14.15 C decimal places required 17.34 C C Series for ATH1 on the interval -1.25000D-01 to 0. C with weighted error 2.53E-17 C log weighted error 16.60 C significant figures required 15.15 C decimal places required 17.38 C C Series for AM22 on the interval -1.00000D+00 to -1.25000D-01 C with weighted error 2.99E-17 C log weighted error 16.52 C significant figures required 14.57 C decimal places required 17.28 C C Series for ATH2 on the interval -1.00000D+00 to -1.25000D-01 C with weighted error 2.57E-17 C log weighted error 16.59 C significant figures required 15.07 C decimal places required 17.34 C C***REFERENCES (NONE) C***ROUTINES CALLED CSEVL, INITS, R1MACH, XERMSG C***REVISION HISTORY (YYMMDD) C 770701 DATE WRITTEN C 890206 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 900720 Routine changed from user-callable to subsidiary. (WRB) C***END PROLOGUE R9AIMP 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 DIMENSION AM21CS(40), ATH1CS(36), AM22CS(33), ATH2CS(32) LOGICAL FIRST SAVE AM21CS, ATH1CS, AM22CS, ATH2CS, PI4, NAM21, 1 NATH1, NAM22, NATH2, XSML, FIRST DATA AM21CS( 1) / .0065809191 761485E0 / DATA AM21CS( 2) / .0023675984 685722E0 / DATA AM21CS( 3) / .0001324741 670371E0 / DATA AM21CS( 4) / .0000157600 904043E0 / DATA AM21CS( 5) / .0000027529 702663E0 / DATA AM21CS( 6) / .0000006102 679017E0 / DATA AM21CS( 7) / .0000001595 088468E0 / DATA AM21CS( 8) / .0000000471 033947E0 / DATA AM21CS( 9) / .0000000152 933871E0 / DATA AM21CS(10) / .0000000053 590722E0 / DATA AM21CS(11) / .0000000020 000910E0 / DATA AM21CS(12) / .0000000007 872292E0 / DATA AM21CS(13) / .0000000003 243103E0 / DATA AM21CS(14) / .0000000001 390106E0 / DATA AM21CS(15) / .0000000000 617011E0 / DATA AM21CS(16) / .0000000000 282491E0 / DATA AM21CS(17) / .0000000000 132979E0 / DATA AM21CS(18) / .0000000000 064188E0 / DATA AM21CS(19) / .0000000000 031697E0 / DATA AM21CS(20) / .0000000000 015981E0 / DATA AM21CS(21) / .0000000000 008213E0 / DATA AM21CS(22) / .0000000000 004296E0 / DATA AM21CS(23) / .0000000000 002284E0 / DATA AM21CS(24) / .0000000000 001232E0 / DATA AM21CS(25) / .0000000000 000675E0 / DATA AM21CS(26) / .0000000000 000374E0 / DATA AM21CS(27) / .0000000000 000210E0 / DATA AM21CS(28) / .0000000000 000119E0 / DATA AM21CS(29) / .0000000000 000068E0 / DATA AM21CS(30) / .0000000000 000039E0 / DATA AM21CS(31) / .0000000000 000023E0 / DATA AM21CS(32) / .0000000000 000013E0 / DATA AM21CS(33) / .0000000000 000008E0 / DATA AM21CS(34) / .0000000000 000005E0 / DATA AM21CS(35) / .0000000000 000003E0 / DATA AM21CS(36) / .0000000000 000001E0 / DATA AM21CS(37) / .0000000000 000001E0 / DATA AM21CS(38) / .0000000000 000000E0 / DATA AM21CS(39) / .0000000000 000000E0 / DATA AM21CS(40) / .0000000000 000000E0 / DATA ATH1CS( 1) / -.0712583781 5669365E0 / DATA ATH1CS( 2) / -.0059047197 9831451E0 / DATA ATH1CS( 3) / -.0001211454 4069499E0 / DATA ATH1CS( 4) / -.0000098860 8542270E0 / DATA ATH1CS( 5) / -.0000013808 4097352E0 / DATA ATH1CS( 6) / -.0000002614 2640172E0 / DATA ATH1CS( 7) / -.0000000605 0432589E0 / DATA ATH1CS( 8) / -.0000000161 8436223E0 / DATA ATH1CS( 9) / -.0000000048 3464911E0 / DATA ATH1CS(10) / -.0000000015 7655272E0 / DATA ATH1CS(11) / -.0000000005 5231518E0 / DATA ATH1CS(12) / -.0000000002 0545441E0 / DATA ATH1CS(13) / -.0000000000 8043412E0 / DATA ATH1CS(14) / -.0000000000 3291252E0 / DATA ATH1CS(15) / -.0000000000 1399875E0 / DATA ATH1CS(16) / -.0000000000 0616151E0 / DATA ATH1CS(17) / -.0000000000 0279614E0 / DATA ATH1CS(18) / -.0000000000 0130428E0 / DATA ATH1CS(19) / -.0000000000 0062373E0 / DATA ATH1CS(20) / -.0000000000 0030512E0 / DATA ATH1CS(21) / -.0000000000 0015239E0 / DATA ATH1CS(22) / -.0000000000 0007758E0 / DATA ATH1CS(23) / -.0000000000 0004020E0 / DATA ATH1CS(24) / -.0000000000 0002117E0 / DATA ATH1CS(25) / -.0000000000 0001132E0 / DATA ATH1CS(26) / -.0000000000 0000614E0 / DATA ATH1CS(27) / -.0000000000 0000337E0 / DATA ATH1CS(28) / -.0000000000 0000188E0 / DATA ATH1CS(29) / -.0000000000 0000105E0 / DATA ATH1CS(30) / -.0000000000 0000060E0 / DATA ATH1CS(31) / -.0000000000 0000034E0 / DATA ATH1CS(32) / -.0000000000 0000020E0 / DATA ATH1CS(33) / -.0000000000 0000011E0 / DATA ATH1CS(34) / -.0000000000 0000007E0 / DATA ATH1CS(35) / -.0000000000 0000004E0 / DATA ATH1CS(36) / -.0000000000 0000002E0 / DATA AM22CS( 1) / -.0156284448 0625341E0 / DATA AM22CS( 2) / .0077833644 5239681E0 / DATA AM22CS( 3) / .0008670577 7047718E0 / DATA AM22CS( 4) / .0001569662 7315611E0 / DATA AM22CS( 5) / .0000356396 2571432E0 / DATA AM22CS( 6) / .0000092459 8335425E0 / DATA AM22CS( 7) / .0000026211 0161850E0 / DATA AM22CS( 8) / .0000007918 8221651E0 / DATA AM22CS( 9) / .0000002510 4152792E0 / DATA AM22CS(10) / .0000000826 5223206E0 / DATA AM22CS(11) / .0000000280 5711662E0 / DATA AM22CS(12) / .0000000097 6821090E0 / DATA AM22CS(13) / .0000000034 7407923E0 / DATA AM22CS(14) / .0000000012 5828132E0 / DATA AM22CS(15) / .0000000004 6298826E0 / DATA AM22CS(16) / .0000000001 7272825E0 / DATA AM22CS(17) / .0000000000 6523192E0 / DATA AM22CS(18) / .0000000000 2490471E0 / DATA AM22CS(19) / .0000000000 0960156E0 / DATA AM22CS(20) / .0000000000 0373448E0 / DATA AM22CS(21) / .0000000000 0146417E0 / DATA AM22CS(22) / .0000000000 0057826E0 / DATA AM22CS(23) / .0000000000 0022991E0 / DATA AM22CS(24) / .0000000000 0009197E0 / DATA AM22CS(25) / .0000000000 0003700E0 / DATA AM22CS(26) / .0000000000 0001496E0 / DATA AM22CS(27) / .0000000000 0000608E0 / DATA AM22CS(28) / .0000000000 0000248E0 / DATA AM22CS(29) / .0000000000 0000101E0 / DATA AM22CS(30) / .0000000000 0000041E0 / DATA AM22CS(31) / .0000000000 0000017E0 / DATA AM22CS(32) / .0000000000 0000007E0 / DATA AM22CS(33) / .0000000000 0000002E0 / DATA ATH2CS( 1) / .0044052734 5871877E0 / DATA ATH2CS( 2) / -.0304291945 2318455E0 / DATA ATH2CS( 3) / -.0013856532 8377179E0 / DATA ATH2CS( 4) / -.0001804443 9089549E0 / DATA ATH2CS( 5) / -.0000338084 7108327E0 / DATA ATH2CS( 6) / -.0000076781 8353522E0 / DATA ATH2CS( 7) / -.0000019678 3944371E0 / DATA ATH2CS( 8) / -.0000005483 7271158E0 / DATA ATH2CS( 9) / -.0000001625 4615505E0 / DATA ATH2CS(10) / -.0000000505 3049981E0 / DATA ATH2CS(11) / -.0000000163 1580701E0 / DATA ATH2CS(12) / -.0000000054 3420411E0 / DATA ATH2CS(13) / -.0000000018 5739855E0 / DATA ATH2CS(14) / -.0000000006 4895120E0 / DATA ATH2CS(15) / -.0000000002 3105948E0 / DATA ATH2CS(16) / -.0000000000 8363282E0 / DATA ATH2CS(17) / -.0000000000 3071196E0 / DATA ATH2CS(18) / -.0000000000 1142367E0 / DATA ATH2CS(19) / -.0000000000 0429811E0 / DATA ATH2CS(20) / -.0000000000 0163389E0 / DATA ATH2CS(21) / -.0000000000 0062693E0 / DATA ATH2CS(22) / -.0000000000 0024260E0 / DATA ATH2CS(23) / -.0000000000 0009461E0 / DATA ATH2CS(24) / -.0000000000 0003716E0 / DATA ATH2CS(25) / -.0000000000 0001469E0 / DATA ATH2CS(26) / -.0000000000 0000584E0 / DATA ATH2CS(27) / -.0000000000 0000233E0 / DATA ATH2CS(28) / -.0000000000 0000093E0 / DATA ATH2CS(29) / -.0000000000 0000037E0 / DATA ATH2CS(30) / -.0000000000 0000015E0 / DATA ATH2CS(31) / -.0000000000 0000006E0 / DATA ATH2CS(32) / -.0000000000 0000002E0 / DATA PI4 / 0.7853981633 9744831 E0 / DATA FIRST /.TRUE./ C***FIRST EXECUTABLE STATEMENT R9AIMP IF (FIRST) THEN ETA = 0.1*R1MACH(3) NAM21 = INITS (AM21CS, 40, ETA) NATH1 = INITS (ATH1CS, 36, ETA) NAM22 = INITS (AM22CS, 33, ETA) NATH2 = INITS (ATH2CS, 32, ETA) C XSML = -1.0/R1MACH(3)**0.3333 ENDIF FIRST = .FALSE. C IF (X.GE.(-2.0)) GO TO 20 Z = 1.0 IF (X.GT.XSML) Z = 16.0/X**3 + 1.0 AMPL = 0.3125 + CSEVL(Z, AM21CS, NAM21) THETA = -0.625 + CSEVL (Z, ATH1CS, NATH1) GO TO 30 C 20 IF (X .GT. (-1.0)) THEN WRITE(ICOUT,1) 1 FORMAT('***** ERORR FROM R9AIMP, X MUST BE LESS THAN OR EQUAL', 1 ' TO -1. *******') CALL DPWRST('XXX','BUG ') RETURN ENDIF C Z = (16.0/X**3 + 9.0)/7.0 AMPL = 0.3125 + CSEVL (Z, AM22CS, NAM22) THETA = -0.625 + CSEVL (Z, ATH2CS, NATH2) C 30 SQRTX = SQRT(-X) AMPL = SQRT (AMPL/SQRTX) THETA = PI4 - X*SQRTX * THETA C RETURN END SUBROUTINE SAMLMR(X,N,XMOM,NMOM,A,B) C===================================================== SAMLMR.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 SAMPLE L-MOMENTS OF A DATA ARRAY C C PARAMETERS OF ROUTINE: C X * INPUT* ARRAY OF LENGTH N. CONTAINS THE DATA, IN ASCENDING C ORDER. C N * INPUT* NUMBER OF DATA VALUES C XMOM *OUTPUT* ARRAY OF LENGTH NMOM. ON EXIT, CONTAINS THE SAMPLE C L-MOMENTS L-1, L-2, T-3, T-4, ... . C NMOM * INPUT* NUMBER OF L-MOMENTS TO BE FOUND. AT MOST MAX(N,20). C A * INPUT* ) PARAMETERS OF PLOTTING C B * INPUT* ) POSITION (SEE BELOW) C C FOR UNBIASED ESTIMATES (OF THE LAMBDA'S) SET A=B=ZERO. OTHERWISE, C PLOTTING-POSITION ESTIMATORS ARE USED, BASED ON THE PLOTTING POSITION C (J+A)/(N+B) FOR THE J'TH SMALLEST OF N OBSERVATIONS. FOR EXAMPLE, C A=-0.35D0 AND B=0.0D0 YIELDS THE ESTIMATORS RECOMMENDED BY C HOSKING ET AL. (1985, TECHNOMETRICS) FOR THE GEV DISTRIBUTION. C C MODIFIED 6/2005 FOR INCLUSION INTO DATAPLOT BY ALAN HECKERT. C NOTE THAT THE CHANGES WERE ONLY FOR THE I/O, NO CHANGE IN C COMPUTATIONAL ASPECTS. C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DOUBLE PRECISION X(N),XMOM(NMOM),SUM(20) C REAL CPUMIN REAL CPUMAX CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DATA ZERO/0D0/,ONE/1D0/ C IF(NMOM.GT.20.OR.NMOM.GT.N)THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7000) 7000 FORMAT('****** ERROR IN ROUTINE SAMLMR: PARAMETER NMOM ', 1 '(NUMBER OF MOMENTS) INVALID') CALL DPWRST('XXX','BUG ') ENDIF C DO 10 J=1,NMOM SUM(J)=ZERO 10 CONTINUE IF(A.EQ.ZERO.AND.B.EQ.ZERO)THEN C C UNBIASED ESTIMATES OF PWM'S C DO 70 I=1,N Z=I TERM=X(I) SUM(1)=SUM(1)+TERM DO 60 J=2,NMOM Z=Z-ONE TERM=TERM*Z SUM(J)=SUM(J)+TERM 60 CONTINUE 70 CONTINUE Y=N Z=N SUM(1)=SUM(1)/Z DO 80 J=2,NMOM Y=Y-ONE Z=Z*Y SUM(J)=SUM(J)/Z 80 CONTINUE ELSE IF(A.LE.-ONE.OR.A.GE.B)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7010) 7010 FORMAT('****** ERROR IN ROUTINE SAMLMR :') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7011) 7011 FORMAT(' PLOTTING-POSITION PARAMETERS INVALID') CALL DPWRST('XXX','BUG ') RETURN ENDIF C C PLOTTING-POSITION ESTIMATES OF PWM'S C DO 30 I=1,N PPOS=(I+A)/(N+B) TERM=X(I) SUM(1)=SUM(1)+TERM DO 20 J=2,NMOM TERM=TERM*PPOS SUM(J)=SUM(J)+TERM 20 CONTINUE 30 CONTINUE DO 40 J=1,NMOM SUM(J)=SUM(J)/N 40 CONTINUE ENDIF C C L-MOMENTS C K=NMOM P0=ONE IF(NMOM-NMOM/2*2.EQ.1)P0=-ONE DO 120 KK=2,NMOM AK=K P0=-P0 P=P0 TEMP=P*SUM(1) DO 110 I=1,K-1 AI=I P=-P*(AK+AI-ONE)*(AK-AI)/(AI*AI) TEMP=TEMP+P*SUM(I+1) 110 CONTINUE SUM(K)=TEMP K=K-1 120 CONTINUE XMOM(1)=SUM(1) IF(NMOM.EQ.1)RETURN XMOM(2)=SUM(2) IF(SUM(2).EQ.ZERO)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7020) 7020 FORMAT('****** ERROR IN ROUTINE SAMLMR: ALL DATA VALUES ', 1 'EQUAL.') CALL DPWRST('XXX','BUG ') RETURN ENDIF IF(NMOM.EQ.2)RETURN DO 130 K=3,NMOM XMOM(K)=SUM(K)/SUM(2) 130 CONTINUE C RETURN END SUBROUTINE SAMLMU(X,N,XMOM,NMOM) C===================================================== SAMLMU.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 SAMPLE L-MOMENTS OF A DATA ARRAY C C PARAMETERS OF ROUTINE: C X * INPUT* ARRAY OF LENGTH N. CONTAINS THE DATA, IN ASCENDING C ORDER. C N * INPUT* NUMBER OF DATA VALUES C XMOM *OUTPUT* ARRAY OF LENGTH NMOM. CONTAINS THE SAMPLE L-MOMENTS, C STORED AS DESCRIBED BELOW. C NMOM * INPUT* NUMBER OF L-MOMENTS TO BE FOUND. AT MOST 100. C C MODIFIED 6/2005 FOR INCLUSION INTO DATAPLOT BY ALAN HECKERT. C NOTE THAT THE CHANGES WERE ONLY FOR THE I/O, NO CHANGE IN C COMPUTATIONAL ASPECTS. C IMPLICIT DOUBLE PRECISION (A-H,O-Z) PARAMETER (MAXMOM=100) DOUBLE PRECISION X(N),XMOM(NMOM),COEF(2,MAXMOM) C REAL CPUMIN REAL CPUMAX CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DATA ZERO/0.0D0/,ONE/1.0D0/,TWO/2.0D0/ C IF(NMOM.GT.MAXMOM)THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7000) 7000 FORMAT('****** ERROR IN ROUTINE SAMLMU: PARAMETER NMOM ', 1 '(NUMBER OF MOMENTS) INVALID') CALL DPWRST('XXX','BUG ') ENDIF C DN=N DO 10 J=1,NMOM XMOM(J)=ZERO 10 CONTINUE IF(NMOM.LE.2)THEN C C AT MOST TWO L-MOMENTS C SUM1=ZERO SUM2=ZERO TEMP=-DN+ONE DO 110 I=1,N SUM1=SUM1+X(I) SUM2=SUM2+X(I)*TEMP TEMP=TEMP+TWO 110 CONTINUE XMOM(1)=SUM1/DN IF(NMOM.EQ.1)RETURN XMOM(2)=SUM2/(DN*(DN-ONE)) RETURN ELSE C C UNBIASED ESTIMATES OF L-MOMENTS -- THE 'DO 30' LOOP C RECURSIVELY CALCULATES DISCRETE LEGENDRE POLYNOMIALS, VIA C EQ.(9) OF NEUMAN AND SCHONBACH (1974, INT.J.NUM.METH.ENG.) C DO 20 J=3,NMOM TEMP=ONE/DBLE((J-1)*(N-J+1)) COEF(1,J)=DBLE(J+J-3)*TEMP COEF(2,J)=DBLE((J-2)*(N+J-2))*TEMP 20 CONTINUE TEMP=-DN-ONE CONST=ONE/(DN-ONE) NHALF=N/2 DO 40 I=1,NHALF TEMP=TEMP+TWO XI=X(I) XII=X(N+1-I) TERMP=XI+XII TERMN=XI-XII XMOM(1)=XMOM(1)+TERMP S1=ONE S=TEMP*CONST XMOM(2)=XMOM(2)+S*TERMN DO 30 J=3,NMOM,2 S2=S1 S1=S S=COEF(1,J)*TEMP*S1-COEF(2,J)*S2 XMOM(J)=XMOM(J)+S*TERMP IF(J.EQ.NMOM)GOTO 30 JJ=J+1 S2=S1 S1=S S=COEF(1,JJ)*TEMP*S1-COEF(2,JJ)*S2 XMOM(JJ)=XMOM(JJ)+S*TERMN 30 CONTINUE 40 CONTINUE IF(N.EQ.NHALF+NHALF)GOTO 60 TERM=X(NHALF+1) S=ONE XMOM(1)=XMOM(1)+TERM DO 50 J=3,NMOM,2 S=-COEF(2,J)*S XMOM(J)=XMOM(J)+S*TERM 50 CONTINUE C C L-MOMENT RATIOS C 60 CONTINUE XMOM(1)=XMOM(1)/DN IF(XMOM(2).EQ.ZERO)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7020) 7020 FORMAT('****** ERROR IN ROUTINE SAMLMU: ALL DATA VALUES ', 1 'EQUAL.') CALL DPWRST('XXX','BUG ') DO 1020 J=1,NMOM XMOM(J)=ZERO 1020 CONTINUE RETURN ENDIF DO 70 J=3,NMOM XMOM(J)=XMOM(J)/XMOM(2) 70 CONTINUE XMOM(2)=XMOM(2)/DN RETURN ENDIF C C RETURN END SUBROUTINE SAMPWM(X,N,XMOM,NMOM,A,B,KIND) C===================================================== SAMPWM.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 PROBABILITY WEIGHTED MOMENTS OF A DATA ARRAY C C PARAMETERS OF ROUTINE: C X * INPUT* ARRAY OF LENGTH N. CONTAINS THE DATA, IN ASCENDING C ORDER. C N * INPUT* NUMBER OF DATA VALUES C XMOM *OUTPUT* ARRAY OF LENGTH NMOM. ON EXIT, CONTAINS THE SAMPLE C PROBABILITY WEIGHTED MOMENTS. XMOM(I) CONTAINS C ALPHA-SUB-(I-1) OR BETA-SUB-(I-1). C NMOM * INPUT* NUMBER OF PROBABILITY WEIGHTED MOMENTS TO BE FOUND. C AT MOST MAX(N,20). C A * INPUT* ) PARAMETERS OF PLOTTING C B * INPUT* ) POSITION (SEE BELOW) C KIND * INPUT* SPECIFIES WHICH KIND OF PWM'S ARE TO BE FOUND. C 1 ALPHA-SUB-R = E ( X (1-F(X))**R ) C 2 BETA -SUB-R = E ( X F(X)**R ) C C FOR UNBIASED ESTIMATES SET A AND B EQUAL TO ZERO. OTHERWISE, C PLOTTING-POSITION ESTIMATORS ARE USED, BASED ON THE PLOTTING POSITION C (J+A)/(N+B) FOR THE J'TH SMALLEST OF N OBSERVATIONS. FOR EXAMPLE, C A=-0.35D0 AND B=0.0D0 YIELDS THE ESTIMATORS RECOMMENDED BY C HOSKING ET AL. (1985, TECHNOMETRICS) FOR THE GEV DISTRIBUTION. C C MODIFIED 6/2005 FOR INCLUSION INTO DATAPLOT BY ALAN HECKERT. C NOTE THAT THE CHANGES WERE ONLY FOR THE I/O, NO CHANGE IN C COMPUTATIONAL ASPECTS. C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DOUBLE PRECISION X(N),XMOM(NMOM) C REAL CPUMIN REAL CPUMAX CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C DATA ZERO/0D0/,ONE/1D0/ IF(NMOM.GT.20.OR.NMOM.GT.N)THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7000) 7000 FORMAT('****** ERROR IN ROUTINE SAMPWM: PARAMETER NMOM ', 1 '(NUMBER OF MOMENTS) INVALID') CALL DPWRST('XXX','BUG ') ENDIF C IF(KIND.NE.1.AND.KIND.NE.2)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7010) 7010 FORMAT('****** ERROR IN ROUTINE SAMPWM : PARAMETER KIND ', 1 'INVALID.') CALL DPWRST('XXX','BUG ') RETURN ENDIF DO 10 J=1,NMOM XMOM(J)=ZERO 10 CONTINUE DN=N IF(A.EQ.ZERO.AND.B.EQ.ZERO)THEN C C UNBIASED ESTIMATES OF PWM'S C DO 70 I=1,N DI=I WEIGHT=ONE/DN XMOM(1)=XMOM(1)+WEIGHT*X(I) DO 60 J=2,NMOM DJ=J-ONE IF(KIND.EQ.1)THEN WEIGHT=WEIGHT*(DN-DI-DJ+ONE)/(DN-DJ) ELSEIF(KIND.EQ.2)THEN WEIGHT=WEIGHT*(DI-DJ)/(DN-DJ) ENDIF XMOM(J)=XMOM(J)+WEIGHT*X(I) 60 CONTINUE 70 CONTINUE ELSE IF(A.LE.-ONE.OR.A.GE.B)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,7020) 7020 FORMAT('****** ERROR IN ROUTINE SAMPWM:', * ' PLOTTING-POSITION PARAMETERS INVALID') CALL DPWRST('XXX','BUG ') RETURN ENDIF C C PLOTTING-POSITION ESTIMATES OF PWM'S C DO 30 I=1,N PPOS=(I+A)/(N+B) IF(KIND.EQ.1)PPOS=ONE-PPOS TERM=X(I) XMOM(1)=XMOM(1)+TERM DO 20 J=2,NMOM TERM=TERM*PPOS XMOM(J)=XMOM(J)+TERM 20 CONTINUE 30 CONTINUE DO 40 J=1,NMOM XMOM(J)=XMOM(J)/DN 40 CONTINUE ENDIF C RETURN END REAL FUNCTION SASUM(N,SX,INCX) C***BEGIN PROLOGUE SASUM C***DATE WRITTEN 791001 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D1A3A C***KEYWORDS ADD,BLAS,LINEAR ALGEBRA,MAGNITUDE,SUM,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 Sum of magnitudes of s.p vector components 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 SASUM single precision result (zero if N .LE. 0) C C Returns sum of magnitudes of single precision SX. C SASUM = sum from 0 to N-1 of ABS(SX(1+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 SASUM C REAL SX(*) C***FIRST EXECUTABLE STATEMENT SASUM SASUM = 0.0E0 IF(N.LE.0)RETURN IF(INCX.EQ.1)GOTO 20 C C CODE FOR INCREMENTS NOT EQUAL TO 1. C NS = N*INCX DO 10 I=1,NS,INCX SASUM = SASUM + ABS(SX(I)) 10 CONTINUE RETURN C C CODE FOR INCREMENTS EQUAL TO 1. C C C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 6. C 20 M = MOD(N,6) IF( M .EQ. 0 ) GO TO 40 DO 30 I = 1,M SASUM = SASUM + ABS(SX(I)) 30 CONTINUE IF( N .LT. 6 ) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,6 SASUM = SASUM + ABS(SX(I)) + ABS(SX(I + 1)) + ABS(SX(I + 2)) 1 + ABS(SX(I + 3)) + ABS(SX(I + 4)) + ABS(SX(I + 5)) 50 CONTINUE RETURN END SUBROUTINE SADMVN( 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 taken. 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 MVNFNC INTEGER N, NL, M, INFIN(*), LENWRK, MAXPTS, INFORM, INFIS, & RULCLS, TOTCLS, NEWCLS, MAXCLS DOUBLE PRECISION & CORREL(*), LOWER(*), UPPER(*), ABSEPS, RELEPS, ERROR, VALUE, & OLDVAL, D, E, MVNNIT, MVNFNC PARAMETER ( NL = 20 ) PARAMETER ( LENWRK = 20*NL**2 ) DOUBLE PRECISION WORK(LENWRK) IF ( N .GT. 20 .OR. N .LT. 1 ) THEN INFORM = 2 VALUE = 0 ERROR = 1 RETURN ENDIF INFORM = MVNNIT( N, CORREL, LOWER, UPPER, INFIN, INFIS, D, E ) M = N - INFIS IF ( M .EQ. 0 ) THEN VALUE = 1 ERROR = 0 ELSE IF ( M .EQ. 1 ) THEN VALUE = E - D ERROR = 2E-16 ELSE * * Call the subregion adaptive integration subroutine * M = M - 1 RULCLS = 1 CALL ADAPT( M, RULCLS, 0, MVNFNC, ABSEPS, RELEPS, & LENWRK, WORK, ERROR, VALUE, INFORM ) MAXCLS = MIN( 10*RULCLS, MAXPTS ) TOTCLS = 0 CALL ADAPT(M, TOTCLS, MAXCLS, MVNFNC, ABSEPS, RELEPS, & LENWRK, WORK, ERROR, VALUE, INFORM) IF ( ERROR .GT. MAX( ABSEPS, RELEPS*ABS(VALUE) ) ) THEN 10 OLDVAL = VALUE MAXCLS = MAX( 2*RULCLS, MIN( 3*MAXCLS/2, MAXPTS - TOTCLS ) ) NEWCLS = -1 CALL ADAPT(M, NEWCLS, MAXCLS, MVNFNC, ABSEPS, RELEPS, & LENWRK, WORK, ERROR, VALUE, INFORM) TOTCLS = TOTCLS + NEWCLS ERROR = ABS(VALUE-OLDVAL) + SQRT(RULCLS*ERROR**2/TOTCLS) IF ( ERROR .GT. MAX( ABSEPS, RELEPS*ABS(VALUE) ) ) THEN IF ( MAXPTS - TOTCLS .GT. 2*RULCLS ) GO TO 10 ELSE INFORM = 0 END IF ENDIF ENDIF C RETURN END SUBROUTINE SADMVT(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 taken. 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 NL, N, NU, M, INFIN(*), LENWRK, MAXPTS, INFORM, INFIS, & RULCLS, TOTCLS, NEWCLS, MAXCLS DOUBLE PRECISION CORREL(*), LOWER(*), UPPER(*), ABSEPS, RELEPS, & ERROR, VALUE, OLDVAL, D, E, MVTNIT PARAMETER ( NL = 20 ) PARAMETER ( LENWRK = 20*NL**2 ) DOUBLE PRECISION WORK(LENWRK) IF ( N .GT. 20 .OR. N .LT. 1 ) THEN INFORM = 2 VALUE = 0.0D0 ERROR = 1.0D0 RETURN ENDIF INFORM = MVTNIT( N, NU, CORREL, LOWER, UPPER, INFIN, INFIS, D, E ) M = N - INFIS IF ( M .EQ. 0 ) THEN VALUE = 1.0D0 ERROR = 0.0D0 ELSE IF ( M .EQ. 1 ) THEN VALUE = E - D ERROR = 2E-16 ELSE * * Call the subregion adaptive integration subroutine * M = M - 1 RULCLS = 1.0D0 CALL ADAPT( M, RULCLS, 0, FNCMVT, ABSEPS, RELEPS, * LENWRK, WORK, ERROR, VALUE, INFORM ) MAXCLS = MIN( 10*RULCLS, MAXPTS ) TOTCLS = 0.0D0 CALL ADAPT( M, TOTCLS, MAXCLS, FNCMVT, ABSEPS, RELEPS, * LENWRK, WORK, ERROR, VALUE, INFORM ) IF ( ERROR .GT. MAX( ABSEPS, RELEPS*ABS(VALUE) ) ) THEN 10 OLDVAL = VALUE MAXCLS = MAX( 2*RULCLS, MIN( 3*MAXCLS/2, MAXPTS - TOTCLS ) ) NEWCLS = -1 CALL ADAPT( M, NEWCLS, MAXCLS, FNCMVT, ABSEPS, RELEPS, * LENWRK, WORK, ERROR, VALUE, INFORM ) TOTCLS = TOTCLS + NEWCLS ERROR = ABS(VALUE-OLDVAL) + SQRT(RULCLS*ERROR**2/TOTCLS) IF ( ERROR .GT. MAX( ABSEPS, RELEPS*ABS(VALUE) ) ) THEN IF ( MAXPTS - TOTCLS .GT. 2*RULCLS ) GO TO 10 ELSE INFORM = 0 END IF ENDIF ENDIF C RETURN END SUBROUTINE SAXPY(N,SA,SX,INCX,SY,INCY) C***BEGIN PROLOGUE SAXPY C***DATE WRITTEN 791001 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D1A7 C***KEYWORDS BLAS,LINEAR ALGEBRA,TRIAD,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 S.P. computation y = a*x + y 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 SA single precision scalar multiplier C SX single precision vector with N elements C INCX storage spacing between elements of SX C SY single precision vector with N elements C INCY storage spacing between elements of SY C C --Output-- C SY single precision result (unchanged if N .LE. 0) C C Overwrite single precision SY with single precision SA*SX +SY. C For I = 0 to N-1, replace SY(LY+I*INCY) with SA*SX(LX+I*INCX) + C SY(LY+I*INCY), where LX = 1 if INCX .GE. 0, else LX = (-INCX)*N C and LY is defined in a similar way using INCY. 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 SAXPY C REAL SX(*),SY(*),SA C***FIRST EXECUTABLE STATEMENT SAXPY IF(N.LE.0.OR.SA.EQ.0.E0) RETURN IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60 5 CONTINUE C C CODE FOR NONEQUAL OR NONPOSITIVE INCREMENTS. C IX = 1 IY = 1 IF(INCX.LT.0)IX = (-N+1)*INCX + 1 IF(INCY.LT.0)IY = (-N+1)*INCY + 1 DO 10 I = 1,N SY(IY) = SY(IY) + SA*SX(IX) IX = IX + INCX IY = IY + INCY 10 CONTINUE RETURN C C CODE FOR BOTH INCREMENTS EQUAL TO 1 C C C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 4. C 20 M = MOD(N,4) IF( M .EQ. 0 ) GO TO 40 DO 30 I = 1,M SY(I) = SY(I) + SA*SX(I) 30 CONTINUE IF( N .LT. 4 ) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,4 SY(I) = SY(I) + SA*SX(I) SY(I + 1) = SY(I + 1) + SA*SX(I + 1) SY(I + 2) = SY(I + 2) + SA*SX(I + 2) SY(I + 3) = SY(I + 3) + SA*SX(I + 3) 50 CONTINUE RETURN C C CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS. C 60 CONTINUE NS = N*INCX DO 70 I=1,NS,INCX SY(I) = SA*SX(I) + SY(I) 70 CONTINUE RETURN END SUBROUTINE SBFIT(XBAR, SIGMA, RTB1, B2, GAMMA, DELTA, XLAM, $ XI, FAULT) C C ALGORITHM AS 99.2 APPL. STATIST. (1976) VOL.25, P.180 C C FINDS PARAMETERS OF JOHNSON SB CURVE WITH C GIVEN FIRST FOUR MOMENTS C REAL HMU(6), DERIV(4), DD(4), XBAR, SIGMA, RTB1, B2, GAMMA, $ DELTA, XLAM, XI, TT, TOL, RB1, B1, E, U, X, Y, W, F, D, $ G, S, H2, T, H2A, H2B, H3, H4, RBET, BET2, ZERO, ONE, $ TWO, THREE, FOUR, SIX, HALF, QUART, ONE5, A1, A2, A3, $ A4, A5, A6, A7, A8, A9, A10, A11, A12, A13, A14, A15, $ A16, A17, A18, A19, A20, A21, A22, ZABS, ZLOG, ZSQRT LOGICAL NEG, FAULT C DATA TT, TOL, LIMIT /1.0E-4, 0.01, 50/ DATA ZERO, ONE, TWO, THREE, FOUR, SIX, HALF, QUART, ONE5 $ /0.0, 1.0, 2.0, 3.0, 4.0, 6.0, 0.5, 0.25, 1.5/ DATA A1, A2, A3, A4, A5, A6, $ A7, A8, A9, A10, A11, A12, $ A13, A14, A15, A16, A17, A18, $ A19, A20, A21, A22 $ /0.0124, 0.0623, 0.4043, 0.408, 0.479, 0.485, $ 0.5291, 0.5955, 0.626, 0.64, 0.7077, 0.7466, $ 0.8, 0.9281, 1.0614, 1.25, 1.7973, 1.8, $ 2.163, 2.5, 8.5245, 11.346/ C ZABS(X) = ABS(X) ZLOG(X) = ALOG(X) ZSQRT(X) = SQRT(X) C RB1 = ZABS(RTB1) B1 = RB1 * RB1 NEG = RTB1 .LT. ZERO C C GET D AS FIRST ESTIMATE OF DELTA C E = B1 + ONE X = HALF * B1 + ONE Y = ZABS(RB1) * ZSQRT(QUART * B1 + ONE) U = (X + Y) ** (ONE / THREE) W = U + ONE / U - ONE F = W * W * (THREE + W * (TWO + W)) - THREE E = (B2 - E) / (F - E) IF (ZABS(RB1) .GT. TOL) GOTO 5 F = TWO GOTO 20 5 D = ONE / ZSQRT(ZLOG(W)) IF (D .LT. A10) GOTO 10 F = TWO - A21 / (D * (D * (D - A19) + A22)) GOTO 20 10 F = A16 * D 20 F = E * F + ONE IF (F .LT. A18) GOTO 25 D = (A9 * F - A4) * (THREE - F) ** (-A5) GOTO 30 25 D = A13 * (F - ONE) C C GET G AS FIRST ESTIMATE OF GAMMA C 30 G = ZERO IF (B1 .LT. TT) GOTO 70 IF (D .GT. ONE) GOTO 40 G = (A12 * D ** A17 + A8) * B1 ** A6 GOTO 70 40 IF (D .LE. A20) GOTO 50 U = A1 Y = A7 GOTO 60 50 U = A2 Y = A3 60 G = B1 ** (U * D + Y) * (A14 + D * (A15 * D - A11)) 70 M = 0 C C MAIN ITERATION STARTS HERE C 80 M = M + 1 FAULT = M .GT. LIMIT IF (FAULT) RETURN C C GET FIRST SIX MOMENTS FOR LATEST G AND D VALUES C CALL MOM(G, D, HMU, FAULT) IF (FAULT) RETURN S = HMU(1) * HMU(1) H2 = HMU(2) - S FAULT = H2 .LE. ZERO IF (FAULT) RETURN T = ZSQRT(H2) H2A = T * H2 H2B = H2 * H2 H3 = HMU(3) - HMU(1) * (THREE * HMU(2) - TWO * S) RBET = H3 / H2A H4 = HMU(4) - HMU(1) * (FOUR * HMU(3) - HMU(1) * $ (SIX * HMU(2) - THREE * S)) BET2 = H4 / H2B W = G * D U = D * D C C GET DERIVATIVES C DO 120 J = 1, 2 DO 110 K = 1, 4 T = K IF (J .EQ. 1) GOTO 90 S = ((W - T) * (HMU(K) - HMU(K + 1)) + (T + ONE) * $ (HMU(K + 1) - HMU(K + 2))) / U GOTO 100 90 S = HMU(K + 1) - HMU(K) 100 DD(K) = T * S / D 110 CONTINUE T = TWO * HMU(1) * DD(1) S = HMU(1) * DD(2) Y = DD(2) - T DERIV(J) = (DD(3) - THREE * (S + HMU(2) * DD(1) - T * HMU(1)) $ - ONE5 * H3 * Y / H2) / H2A DERIV(J + 2) = (DD(4) - FOUR * (DD(3) * HMU(1) + DD(1) * HMU(3)) $ + SIX * (HMU(2) * T + HMU(1) * (S - T * HMU(1))) $ - TWO * H4 * Y / H2) / H2B 120 CONTINUE T = ONE / (DERIV(1) * DERIV(4) - DERIV(2) * DERIV(3)) U = (DERIV(4) * (RBET - RB1) - DERIV(2) * (BET2 - B2)) * T Y = (DERIV(1) * (BET2 - B2) - DERIV(3) * (RBET - RB1)) * T C C FORM NEW ESTIMATES OF G AND D C G = G - U IF (B1 .EQ. ZERO .OR. G .LT. ZERO) G = ZERO D = D - Y IF (ZABS(U) .GT. TT .OR. ZABS(Y) .GT. TT) GOTO 80 C C END OF ITERATION C DELTA = D XLAM = SIGMA / ZSQRT(H2) IF (NEG) GOTO 130 GAMMA = G GOTO 140 130 GAMMA = -G HMU(1) = ONE - HMU(1) 140 XI = XBAR - XLAM * HMU(1) RETURN END SUBROUTINE SCAN(IPT, M, LER, N, LE, LS, LV, LLIM, LP, L, IA, * IBATCH) C PART OF ACM 591 FOR ANOVA C ****************************** SCAN ****************************** SCA 10 C SCA 20 C PROCESSES THE MODEL/HYPOTHESIS STATEMENT TO CONSTRUCT/MODIFY THE SCA 30 C E/R LIST (ARRAY LER); TURNS SWITCH ISST ON FOR AN INVALID STATE- SCA 40 C MENT. DETERMINES THE EFFECTIVE NUMBER OF FACTORS (NSUBS); TURNS SCA 50 C SWITCH IXST ON WHEN THE EFFECTIVE X MATRIX IS SQUARE; COMPUTES THE SCA 60 C PARAMETERS NEEDED IN RESTRUCTURING DATA (LPOUT AND NO1). COMPUTES SCA 70 C THE DEGREES OF FREEDOM APPLICABLE TO DATA WITH NO MISSING CELLS SCA 80 C (IDFM AND IDFR). SCA 90 C SCA 100 C IPT = POINTER TO BEGINNING OF MODEL/HYPOTHESIS STATEMENT IN INPUT SCA 110 C BUFFER; IBATCH = 1 (BATCH PROCESSING) OR IBATCH = 0 (INTERACTIVE) SCA 120 C SCA 130 C (SEE MAIN PROGRAM COMMENTS FOR DESCRIPTION OF OTHER ARGUMENTS) SCA 140 C SCA 150 C ****************************************************************** SCA 160 COMMON /C1/ YPY, SSRM, SSEM, IIN, IOUT, IROPT, IVOPT, IGOPT, * IPOPT, IOFLAG, IBST, IHST, IRST, ISST, IXST, ICD, NSUBS, LPOUT, * NO1, IDF, IDFM, IDFR DIMENSION LER(M), LE(N), LS(N), LV(N), LLIM(N), LP(10), IA(L) DOUBLE PRECISION YPY, SSRM, SSEM C CHARACTER*1 ILP, IRP, IM, IH, ISTAR, ISLASH, IBLANK, IC CHARACTER*4 ICD C CNIST CHARACTER*1 FUNCTION IGET C CHARACTER*4 IFEEDB CHARACTER*4 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 ILP /1H(/, IRP /1H)/, IM /1HM/, IH /1HH/, ISTAR /1H*/, * ISLASH /1H// DATA IBLANK /1H / C ISST = 0 IXST = 0 M1 = M - 1 II = IPT IF (II.GT.L) GO TO 350 CNIST IC = IGET(II,IA,L) IF (ICD(1:1).EQ.IH) GO TO 20 IF (IC.EQ.ISTAR) GO TO 270 C INITIALIZE E/R LIST TO ZEROES FOR M AND ABSOLUTE VALUES FOR H DO 10 I=1,M1 LER(I) = 0 10 CONTINUE LER(M) = 1 20 IF (LER(M).EQ.0) GO TO 350 DO 30 I=1,M1 LER(I) = IABS(LER(I)) 30 CONTINUE M2 = 2*M C SCAN TERM TO CONSTRUCT E/R LIST; ENTER NEGATIVES FOR H TERM 40 DO 50 I=1,N LP(I) = M2 50 CONTINUE C SUM VALUES OF FACTOR SYMBOLS FOR E/R ENTRY; ZERO LP POSITIONS NE = 0 NVS = 0 60 IFLAG = 0 DO 70 I=1,N CNIST IF (IC.NE.LE(I)) GO TO 70 LP(I) = 0 IFLAG = 1 NE = NE + 1 NVS = NVS + LV(I) 70 CONTINUE IF (IFLAG.NE.1) GO TO 80 IF (II.GT.L) GO TO 350 CNIST IC = IGET(II,IA,L) GO TO 60 80 IF (NE.EQ.0) GO TO 350 CNIST IF (IC.NE.ILP) GO TO 350 C SCAN SUBSCRIPTS; SET NONZERO LP ENTRIES TO NUMERICAL VALUES NS = 0 NAS = 0 90 IF (II.GT.L) GO TO 350 CNIST IC = IGET(II,IA,L) CNIST SET FOLLOWING LINE JUST TO AVOID COMPILATION WARNING. CNIST REMOVE IF WE ACTIVATE THIS CODE IC=' ' IFLAG = 0 DO 120 I=1,N CNIST IF (IC.NE.LS(I)) GO TO 120 IF (LP(I).NE.0) LP(I) = LV(I) IF (LP(I).EQ.0) NAS = NAS + 1 C CHECK FOR INVALID NESTED TERM DO 100 J=I,N IF (LP(J).EQ.0) GO TO 110 100 CONTINUE GO TO 350 110 IFLAG = 1 NS = NS + 1 120 CONTINUE IF (IFLAG.NE.1) GO TO 130 GO TO 90 130 IF (NAS.NE.NE) GO TO 350 IF (IC.NE.IRP) GO TO 350 IF (NS.NE.NE) GO TO 150 C CHECK FOR INVALID CROSSED TERM DO 140 I=1,N IF (LP(I).EQ.M2) GO TO 140 IF (LP(I).NE.0) GO TO 350 140 CONTINUE I = M - NVS ITEMP = 0 IF (ICD(1:1).EQ.IH) ITEMP = NVS + 1 IF (LER(I).NE.ITEMP) GO TO 350 LER(I) = NVS + 1 IF (ICD(1:1).EQ.IH) LER(I) = -LER(I) GO TO 190 C ENTER SUM FOR NESTED TERM INTO E/R POSITIONS TO POOL 150 DO 180 I=1,M1 NUM = I - NVS DO 160 J=1,N NUM = NUM - LP(J) IF (NUM.GT.0) GO TO 160 IF (NUM.EQ.0) GO TO 170 NUM = NUM + LP(J) 160 CONTINUE GO TO 180 170 K = M - I ITEMP = 0 IF (ICD(1:1).EQ.IH) ITEMP = NVS + 1 IF (LER(K).NE.ITEMP) GO TO 350 LER(K) = NVS + 1 IF (ICD(1:1).EQ.IH) LER(K) = -LER(K) 180 CONTINUE 190 IF (II.GT.L) GO TO 200 CNIST IC = IGET(II,IA,L) IF (IC.EQ.IBLANK .AND. II.GT.L) GO TO 200 IF (IC.NE.ISLASH) GO TO 40 C READ MODEL OR HYPOTHESIS CONTINUATION CARD (SLASH FOLLOWS TERM) READ (IIN,99999) (IA(I),I=1,L) 99999 FORMAT (80A1) IF (IBATCH.EQ.1) THEN WRITE (ICOUT,99998) (IA(I),I=1,L) CALL DPWRST('XXX','BUG ') ENDIF 99998 FORMAT (1H , 80A1) II = 1 CNIST IC = IGET(II,IA,L) GO TO 40 C CHECK FOR INVALID HYPOTHESIS TERM 200 DO 220 I=1,M1 DO 210 J=I,M1 IF (LER(I).EQ.0) GO TO 210 IF (LER(I).EQ.(-LER(J))) GO TO 350 210 CONTINUE 220 CONTINUE C CONSTRUCT LP FROM E/R; DETERMINE EFFECTIVE FACTORS NSUBS = N DO 250 I=1,N LP(I) = 0 INC1 = LV(I) INC2 = LV(1)/INC1 LOC = 1 DO 240 J=1,INC2 DO 230 K=1,INC1 IF (LER(LOC).GT.0) LP(I) = LP(I) + 1 LOC = LOC + 1 230 CONTINUE LOC = LOC + INC1 240 CONTINUE IF (LP(I).EQ.0) NSUBS = NSUBS - 1 250 CONTINUE C DETERMINE IF THE EFFECTIVE X MATRIX IS SQUARE IV = N - NSUBS + 1 DO 260 I=1,N IF (LP(I).EQ.0) GO TO 260 IF (LP(I).NE.LV(IV)) GO TO 310 260 CONTINUE GO TO 300 C CONSTRUCT E/R LIST FOR COMPLETELY CROSSED MODEL 270 DO 280 I=1,M1 LER(I) = M - I + 1 280 CONTINUE NSUBS = N DO 290 I=1,N LP(I) = LV(1) 290 CONTINUE 300 IXST = 1 310 IF (IOFLAG.EQ.1) THEN WRITE (ICOUT,99997) (LER(I),I=1,M) CALL DPWRST('XXX','BUG ') ENDIF 99997 FORMAT (10H E/R LIST-/(1H , 16I5)) C COMPUTE PARAMETERS REQUIRED TO RESTRUCTURE CELL FREQUENCY ARRAY LPOUT = 1 NO1 = 1 DO 320 I=1,N IF (LP(I).EQ.0) LPOUT = LPOUT*LLIM(I) IF (LP(I).NE.0) NO1 = NO1 + LV(I) 320 CONTINUE C COMPUTE DEGREES OF FREEDOM FOR FULL OR REDUCED MODEL IDF = 0 DO 340 I=1,M IF (LER(I).LE.0) GO TO 340 NO2 = M - I + 1 CALL LABEL(NO2, 0, LLIM, IOUT, N, LV, LP) K = 1 DO 330 J=1,N IF (LP(J).NE.0) K = K*(LLIM(J)-1) 330 CONTINUE IDF = IDF + K 340 CONTINUE IDFR = 0 IF (ICD(1:1).EQ.IH) IDFR = IDF IF (ICD(1:1).EQ.IM) IDFM = IDF RETURN 350 ISST = 1 RETURN END SUBROUTINE SCLMUL(N,S,V,Z) IMPLICIT DOUBLE PRECISION (A-H,O-Z) C C PURPOSE C ------- C MULTIPLY VECTOR BY SCALAR C RESULT VECTOR MAY BE OPERAND VECTOR C C PARAMETERS C ---------- C N --> DIMENSION OF VECTORS C S --> SCALAR C V(N) --> OPERAND VECTOR C Z(N) <-- RESULT VECTOR DIMENSION V(N),Z(N) DO 100 I=1,N Z(I)=S*V(I) 100 CONTINUE RETURN END SUBROUTINE SCOPY(N,SX,INCX,SY,INCY) C***BEGIN PROLOGUE SCOPY C***DATE WRITTEN 791001 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D1A5 C***KEYWORDS BLAS,COPY,LINEAR ALGEBRA,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 Copy s.p. vector y = x 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 SY single precision vector with N elements C INCY storage spacing between elements of SY C C --Output-- C SY copy of vector SX (unchanged if N .LE. 0) C C Copy single precision SX to single precision SY. C For I = 0 to N-1, copy SX(LX+I*INCX) to SY(LY+I*INCY), C where LX = 1 if INCX .GE. 0, else LX = (-INCX)*N, and LY is C defined in a similar way using INCY. 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 SCOPY C REAL SX(1),SY(1) C***FIRST EXECUTABLE STATEMENT SCOPY IF(N.LE.0)RETURN IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60 5 CONTINUE C C CODE FOR UNEQUAL OR NONPOSITIVE INCREMENTS. C IX = 1 IY = 1 IF(INCX.LT.0)IX = (-N+1)*INCX + 1 IF(INCY.LT.0)IY = (-N+1)*INCY + 1 DO 10 I = 1,N SY(IY) = SX(IX) IX = IX + INCX IY = IY + INCY 10 CONTINUE RETURN C C CODE FOR BOTH INCREMENTS EQUAL TO 1 C C C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 7. C 20 M = MOD(N,7) IF( M .EQ. 0 ) GO TO 40 DO 30 I = 1,M SY(I) = SX(I) 30 CONTINUE IF( N .LT. 7 ) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,7 SY(I) = SX(I) SY(I + 1) = SX(I + 1) SY(I + 2) = SX(I + 2) SY(I + 3) = SX(I + 3) SY(I + 4) = SX(I + 4) SY(I + 5) = SX(I + 5) SY(I + 6) = SX(I + 6) 50 CONTINUE RETURN C C CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS. C 60 CONTINUE NS = N*INCX DO 70 I=1,NS,INCX SY(I) = SX(I) 70 CONTINUE RETURN END SUBROUTINE SCOPYM(N,SX,INCX,SY,INCY) C***BEGIN PROLOGUE SCOPYM C***DATE WRITTEN 801001 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D1A5 C***KEYWORDS BLAS,COPY,VECTOR C***AUTHOR KAHANER,DAVID(NBS) C***PURPOSE Copy negative of real SX to real SY. C***DESCRIPTION C C Description of Parameters C The * Flags Output Variables C C N Number of elements in vector(s) C SX Real vector with N elements C INCX Storage spacing between elements of SX C SY* Real negative copy of SX C INCY Storage spacing between elements of SY C C *** Note that SY = -SX *** C C Copy negative of real SX to real SY. For I=0 to N-1, C copy -SX(LX+I*INCX) to SY(LY+I*INCY), where LX=1 if C INCX .GE. 0, else LX = (-INCX)*N, and LY is defined C in a similar way using INCY. C***REFERENCES (NONE) C***ROUTINES CALLED (NONE) C***END PROLOGUE SCOPYM REAL SX(1),SY(1) C***FIRST EXECUTABLE STATEMENT SCOPYM IF(N.LE.0) RETURN IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60 5 CONTINUE C C CODE FOR UNEQUAL OR NONPOSITIVE INCREMENTS C IX=1 IY=1 IF(INCX.LT.0)IX = (-N+1)*INCX + 1 IF(INCY.LT.0)IY = (-N+1)*INCY + 1 DO 10 I=1,N SY(IY) = -SX(IX) IX = IX + INCX IY = IY + INCY 10 CONTINUE RETURN C C CODE FOR BOTH INCREMENTS EQUAL TO 1 C C C CLEAN UP LOOP SO REMAINING VECTOR LENGTH IS MULTIPLE OF 7 C 20 M = MOD(N,7) IF( M .EQ. 0 ) GO TO 40 DO 30 I=1,M SY(I) = -SX(I) 30 CONTINUE IF( N .LT. 7 ) RETURN 40 MP1 = M + 1 DO 50 I= MP1,N,7 SY(I) = -SX(I) SY(I + 1) = -SX(I + 1) SY(I + 2) = -SX(I + 2) SY(I + 3) = -SX(I + 3) SY(I + 4) = -SX(I + 4) SY(I + 5) = -SX(I + 5) SY(I + 6) = -SX(I + 6) 50 CONTINUE RETURN C C CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS C 60 CONTINUE NS = N*INCX DO 70 I=1,NS,INCX SY(I) = -SX(I) 70 CONTINUE RETURN END subroutine scrag(xreal, n, ipow) c c Algorithm AS 83.3 Appl. Statist. (1975) vol.24, no.1 c *** MODIFIED FOR USE WITH AS 97 *** c c Subroutine for unscrambling FFT data. c implicit double precision (A-H, O-Z) double precision xreal(n) integer l(19) equivalence (l1,l(1)), (l2,l(2)), (l3,l(3)), (l4,l(4)), + (l5,l(5)), (l6,l(6)), (l7,l(7)), (l8,l(8)), (l9,l(9)), + (l10,l(10)), (l11,l(11)), (l12,l(12)), (l13,l(13)), + (l14,l(14)), (l15,l(15)), (l16,l(16)), (l17,l(17)), + (l18,l(18)), (l19,l(19)) c ii = 1 itop = 2 ** (ipow - 1) i = 20 - ipow do 5 k = 1, i 5 l(k) = ii l0 = ii i = i + 1 do 6 k = i, 19 ii = ii * 2 l(k) = ii 6 continue c ii = 0 do 9 j1 = 1, l1, l0 do 9 j2 = j1, l2, l1 do 9 j3 = j2, l3, l2 do 9 j4 = j3, l4, l3 do 9 j5 = j4, l5, l4 do 9 j6 = j5, l6, l5 do 9 j7 = j6, l7, l6 do 9 j8 = j7, l8, l7 do 9 j9 = j8, l9, l8 do 9 j10 = j9, l10, l9 do 9 j11 = j10, l11, l10 do 9 j12 = j11, l12, l11 do 9 j13 = j12, l13, l12 do 9 j14 = j13, l14, l13 do 9 j15 = j14, l15, l14 do 9 j16 = j15, l16, l15 do 9 j17 = j16, l17, l16 do 9 j18 = j17, l18, l17 do 9 j19 = j18, l19, l18 j20 = j19 do 9 i = 1, 2 ii = ii + 1 if (ii .lt. j20) then c c J20 is the bit-reverse of II pairwise interchange. c tempr = xreal(ii) xreal(ii) = xreal(j20) xreal(j20) = tempr end if j20 = j20 + itop 9 continue c return end SUBROUTINE SCRUDE( NDIM, MAXPTS, ABSEST, FINEST, IR ) * * Crude Monte-Carlo Algorithm for Deak method with * weighted results on restart * CCCCC INTEGER NDIM, MAXPTS, M, K, IR, NPTS INTEGER NDIM, MAXPTS, M, IR DOUBLE PRECISION FINEST, ABSEST, SPNRML, & VARSQR, VAREST, VARPRD, FINDIF, FINVAL SAVE VAREST IF ( IR .LE. 0 ) THEN VAREST = 0 FINEST = 0 ENDIF FINVAL = 0 VARSQR = 0 DO 100 M = 1,MAXPTS FINDIF = ( SPNRML(NDIM) - FINVAL )/DBLE(M) FINVAL = FINVAL + FINDIF VARSQR = DBLE( M - 2 )*VARSQR/DBLE(M) + FINDIF**2 100 CONTINUE VARPRD = VAREST*VARSQR FINEST = FINEST + ( FINVAL - FINEST )/(1.0D0 + VARPRD) IF ( VARSQR .GT. 0.0D0 ) VAREST = (1.0D0 + VARPRD)/VARSQR ABSEST = 3.0D0*SQRT( VARSQR/( 1.0D0 + VARPRD ) ) C RETURN END SUBROUTINE SD(X,N,IWRITE,XSD,IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C SAMPLE STANDARD DEVIATION (WITH DENOMINATOR N-1) C OF THE DATA IN THE INPUT VECTOR X. C THE SAMPLE STANDARD DEVIATION = SQRT((THE SUM OF THE C SQUARED DEVIATIONS ABOUT THE SAMPLE MEAN)/(N-1)). C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF C (UNSORTED OR SORTED) OBSERVATIONS. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X. C OUTPUT ARGUMENTS--XSD = THE SINGLE PRECISION VALUE OF THE C COMPUTED SAMPLE STANDARD DEVIATION. C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE C SAMPLE STANDARD DEVIATION (WITH DENOMINATOR N-1). C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--SNEDECOR AND COCHRAN, STATISTICAL METHODS, C EDITION 6, 1967, PAGE 44. C --DIXON AND MASSEY, INTRODUCTION TO STATISTICAL C ANALYSIS, EDITION 2, 1957, PAGES 19, 76. 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 (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 --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 DN DOUBLE PRECISION DX DOUBLE PRECISION DSUM DOUBLE PRECISION DMEAN DOUBLE PRECISION DVAR DOUBLE PRECISION DSD C DIMENSION X(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='SD ' ISUBN2=' ' C IERROR='NO' C DMEAN=0.0D0 C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF SD--') 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 STANDARD DEVIATION ** C ********************************** C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C AN=N C IF(N.GE.1)GOTO119 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN SD--') 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 STANDARD DEVIATION IS TO BE COMPUTED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,115) 115 FORMAT(' MUST BE 1 OR LARGER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,116) 116 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,117)N 117 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 1'.') CALL DPWRST('XXX','BUG ') GOTO9000 119 CONTINUE C IF(N.EQ.1)GOTO120 GOTO129 120 CONTINUE CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,121) CC121 FORMAT('***** NON-FATAL DIAGNOSTIC IN SD--', CCCCC1'THE 2ND INPUT ARGUMENT (N) HAS THE VALUE 1') CCCCC CALL DPWRST('XXX','BUG ') XSD=0.0 GOTO9000 129 CONTINUE C HOLD=X(1) DO135I=2,N IF(X(I).NE.HOLD)GOTO139 135 CONTINUE CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,136)HOLD CC136 FORMAT('***** NON-FATAL DIAGNOSTIC IN SD--', CCCCC1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) CCCCC CALL DPWRST('XXX','BUG ') XSD=0.0 GOTO9000 139 CONTINUE C 190 CONTINUE C C *************************************** C ** STEP 2-- ** C ** COMPUTE THE STANDARD DEVIATION. ** C *************************************** C DN=N DSUM=0.0D0 DO200I=1,N DX=X(I) DSUM=DSUM+DX 200 CONTINUE DMEAN=DSUM/DN C DSUM=0.0D0 DO300I=1,N DX=X(I) DSUM=DSUM+(DX-DMEAN)**2 300 CONTINUE DVAR=DSUM/(DN-1.0D0) DSD=0.0D0 IF(DVAR.GT.0.0D0)DSD=DSQRT(DVAR) XSD=DSD C C ******************************* C ** STEP 3-- ** C ** 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,XSD 811 FORMAT('THE STANDARD DEVIATION 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 SD--') 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)DMEAN 9014 FORMAT('DMEAN = ',D15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)XSD 9015 FORMAT('XSD = ',E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE SDDP(X,N,IWRITE,XSD,IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C SAMPLE STANDARD DEVIATION (WITH DENOMINATOR N-1) C OF THE DATA IN THE INPUT VECTOR X. C THE SAMPLE STANDARD DEVIATION = SQRT((THE SUM OF THE C SQUARED DEVIATIONS ABOUT THE SAMPLE MEAN)/(N-1)). C --THIS IS A DOUBLE PRECISION VERSION OF C THE SD SUBROUTINE. C INPUT ARGUMENTS--X = THE DOUBLE PRECISION VECTOR OF C (UNSORTED OR SORTED) OBSERVATIONS. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X. C OUTPUT ARGUMENTS--XSD = THE DOUBLE PRECISION VALUE OF THE C COMPUTED SAMPLE STANDARD DEVIATION. C OUTPUT--THE COMPUTED DOUBLE PRECISION VALUE OF THE C SAMPLE STANDARD DEVIATION (WITH DENOMINATOR N-1). C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--SNEDECOR AND COCHRAN, STATISTICAL METHODS, C EDITION 6, 1967, PAGE 44. C --DIXON AND MASSEY, INTRODUCTION TO STATISTICAL C ANALYSIS, EDITION 2, 1957, PAGES 19, 76. 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 LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2006.4 C ORIGINAL VERSION--APRIL 2006. 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 DOUBLE PRECISION DMEAN DOUBLE PRECISION DVAR DOUBLE PRECISION DSD DOUBLE PRECISION XSD DOUBLE PRECISION HOLD C DOUBLE PRECISION 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='SDDP' ISUBN2=' ' C IERROR='NO' C DMEAN=0.0D0 C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF SD--') 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,G15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ********************************** C ** COMPUTE STANDARD DEVIATION ** C ********************************** C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C DN=N C IF(N.GE.1)GOTO119 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN SDDP--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,112) 112 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS IN THE VARIABLE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,114) 114 FORMAT(' FOR WHICH THE STANDARD 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)THEN XSD=0.0D0 GOTO9000 ENDIF C HOLD=X(1) DO135I=2,N IF(X(I).NE.HOLD)GOTO139 135 CONTINUE XSD=0.0D0 GOTO9000 139 CONTINUE C 190 CONTINUE C C *************************************** C ** STEP 2-- ** C ** COMPUTE THE STANDARD DEVIATION. ** C *************************************** C DN=N DSUM=0.0D0 DO200I=1,N DX=X(I) DSUM=DSUM+DX 200 CONTINUE DMEAN=DSUM/DN C DSUM=0.0D0 DO300I=1,N DX=X(I) DSUM=DSUM+(DX-DMEAN)**2 300 CONTINUE DVAR=DSUM/(DN-1.0D0) DSD=0.0D0 IF(DVAR.GT.0.0D0)DSD=DSQRT(DVAR) XSD=DSD C C ******************************* C ** STEP 3-- ** C ** 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,XSD 811 FORMAT('THE STANDARD DEVIATION 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 SDDP--') 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)DMEAN 9014 FORMAT('DMEAN = ',D15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)XSD 9015 FORMAT('XSD = ',E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE SDECDF(X,ALMBDA,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE SKEW-LAPLACE DISTRIBUTION C (OR SKEW-DOUBLE EXPONENTIAL) C WITH SHAPE PARAMETER = LAMBDA. C THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS C THE CUMULATIVE DISTRIBUTION FUNCTION C SDECDF(X,LAMBDA) = 0.5*EXP((1+LAMBDA)*X)/(1+LAMMBDA) C X <= 0 C = 1 + (1)*EXP(-X) - C 0.5/(EXP((1+LAMBDA)*X)*(-1-LAMBDA)) C X > 0 C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C --ALMBDA = THE 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 SKEWED-LAPLACE DISTRIBUTION C WITH SHAPE PARAMETER = LAMBDA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--EXP. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--KOTZ, KOZUBOWSKI, AND PODGORSKI, "THE LAPLACE C DISTRIBUTION AND GENERALIZATIONS: A REVISIT WITH C APPLICATIONS TO COMMUNICATIONS, ECONOMICS, C ENGINEERING, AND FINANCE", BIRKHAUSR, 2001, C PP. 134. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.6 C ORIGINAL VERSION--JUNE 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DLMBDA DOUBLE PRECISION DTERM1 DOUBLE PRECISION 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 ************************************ C ** STEP 1-- ** C ** COMPUTE THE DENSITY FUNCTION ** C ************************************ C IF(ALMBDA.LT.0.0)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)ALMBDA CALL DPWRST('XXX','WRIT') CDF=0.0 GOTO9000 ENDIF 5 FORMAT('***** ERROR: VALUE OF SHAPE PARAMETER IN SDECDF ', 1 'ROUTINE IS NEGATIVE.') 48 FORMAT(' VALUE OF ARGUMENT IS: ',G15.7) C DX=DBLE(X) DLMBDA=DBLE(ALMBDA) C IF(ALMBDA.EQ.0)THEN CALL DEXCDF(X,CDF) GOTO9000 ELSE IF(X.LE.0.0)THEN DCDF=0.5D0*DEXP((1.0D0 + DLMBDA)*DX)/(1.0D0 + DLMBDA) ELSE DCDF=1.0D0 - DEXP(-DX) - 1 0.5D0/(DEXP((1.0D0 + DLMBDA)*DX)*(-1.0D0-DLMBDA)) ENDIF CDF=REAL(DCDF) ENDIF C 9000 CONTINUE RETURN END REAL FUNCTION SDEFUN(X) C C PURPOSE--SDEPPF CALLS FZERO TO FIND A ROOT FOR THE PERCENT C POINT FUNCTION. SDEFUN IS THE FUNCTION FOR WHICH C THE ZERO IS FOUND. IT IS: C P - SDECDF(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 SDEFUN. C PRINTING--NONE. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--SDECDF. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATION INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.6 C ORIGINAL VERSION--JUNE 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C REAL P COMMON/SDECOM/P,ALAMB C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT 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 SDECDF(X,ALAMB,CDF) SDEFUN=P - CDF C 9999 CONTINUE RETURN END SUBROUTINE SDEPDF(X,ALMBDA,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE SKEW-LAPLACE DISTRIBUTION C (OR SKEW-DOUBLE EXPONENTIAL) C WITH SHAPE PARAMETER = LAMBDA. C THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS C THE PROBABILITY DENSITY FUNCTION C SDEPDF(X,LAMBDA) = 0.5*EXP((1+LAMBDA)*X) X <= 0 C = EXP(-X) - 0.5*EXP((1+LAMBDA)*X) C X > 0 C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C --ALMBDA = THE SHAPE PARAMETER C OUTPUT ARGUMENTS--PDF = THE SINGLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY C FUNCTION VALUE PDF FOR THE SKEWED-LAPLACE DISTRIBUTION C WITH SHAPE PARAMETER = LAMBDA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--EXP. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--KOTZ, KOZUBOWSKI, AND PODGORSKI, "THE LAPLACE C DISTRIBUTION AND GENERALIZATIONS: A REVISIT WITH C APPLICATIONS TO COMMUNICATIONS, ECONOMICS, C ENGINEERING, AND FINANCE", BIRKHAUSR, 2001, C PP. 134. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.6 C ORIGINAL VERSION--JUNE 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION DLMBDA 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 ** COMPUTE THE DENSITY FUNCTION ** C ************************************ C IF(ALMBDA.LT.0.0)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)ALMBDA CALL DPWRST('XXX','WRIT') PDF=0.0 GOTO9000 ENDIF 5 FORMAT('***** ERROR: VALUE OF SHAPE PARAMETER IN SDEPDF ', 1 'ROUTINE IS NEGATIVE.') 48 FORMAT(' VALUE OF ARGUMENT IS: ',G15.7) C DX=DBLE(X) DLMBDA=DBLE(ALMBDA) C IF(ALMBDA.EQ.0.0)THEN CALL DEXPDF(X,PDF) GOTO9000 ELSE IF(X.LE.0.0)THEN DPDF=0.5D0*DEXP((1.0D0 + DLMBDA)*DX) ELSE DPDF=DEXP(-DX) - 0.5D0*DEXP(-(1.0D0 + DLMBDA)*DX) ENDIF PDF=REAL(DPDF) ENDIF C 9000 CONTINUE RETURN END SUBROUTINE SDEPPF(P,ALMBDA,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE SKEW DOUBLE EXPONENTIAL C DISTRIBUTION WITH SHAPE PARAMETER = LAMBDA. C THIS DISTRIBUTION IS DEFINED FOR ALL X AND THE C PERCENT POINT FUNCTION IS COMPUTED BY: C 1) COMPUTE PCUT = SDECDF(0,LAMBDA) C 2) IF P <= PCUT, USE CLOSED FORM FORMULA: C PPF = LOG[2*P*(1+LAMBDA)]/(1+LAMBDA) C C 3) IF P > PCUT, NUMERICALLY INVERT THE CDF FUNCTION. C INPUT ARGUMENTS--P = THE SINGLE PRECISION VALUE AT C WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. C --ALMBDA = THE 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--KOTZ, KOZUBOWSKI, AND PODGORSKI, "THE LAPLACE C DISTRIBUTION AND GENERALIZATIONS: A REVISIT WITH C APPLICATIONS TO COMMUNICATIONS, ECONOMICS, C ENGINEERING, AND FINANCE", BIRKHAUSR, 2001, C PP. 134. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATION INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.6 C ORIGINAL VERSION--JUNE 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C REAL PPF DOUBLE PRECISION DP DOUBLE PRECISION DPPF DOUBLE PRECISION DLMBDA C REAL SDEFUN EXTERNAL SDEFUN C REAL P2,ALAMB COMMON/SDECOM/P2,ALAMB C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT 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.LE.0.0.OR.P.GE.1.0)THEN WRITE(ICOUT,61) 61 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT ', 1 'TO THE SDEPPF 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(ALMBDA.LT.0.0)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)ALMBDA CALL DPWRST('XXX','WRIT') PDF=0.0 GOTO9000 ENDIF 5 FORMAT('***** ERROR: VALUE OF SHAPE PARAMETER IN SDEPPF ', 1 'ROUTINE IS NEGATIVE.') 48 FORMAT(' VALUE OF ARGUMENT IS: ',G15.7) C DP=DBLE(P) DLMBDA=DBLE(ALMBDA) C IF(ALMBDA.EQ.0.0)THEN CALL DEXPPF(P,PPF) GOTO9000 ENDIF C C STEP 1: COMPUTE SDECDF(0,LAMBDA). CLOSED FORM FOR P < PCUT. C CALL SDECDF(0.0,ALMBDA,PCUT) IF(P.LE.PCUT)THEN DPPF=DLOG(2.0D0*DP*(1.0D0+DLMBDA))/(1.0D0+DLMBDA) PPF=REAL(DPPF) GOTO9000 ENDIF C C STEP 2: FIND BRACKETING INTERVAL. PCUT IS LOWER BOUND, PPF OF C EXPONENTIAL DISTRIBUTION IS UPPER BOUND. C XLOW=PCUT CALL EXPPPF(P,XUP) XLOW=XLOW - 1.0 XUP=XUP + 10.0 C AE=1.E-6 RE=1.E-6 ALAMB=ALMBDA P2=P CALL FZERO(SDEFUN,XLOW,XUP,XUP,RE,AE,IFLAG) C PPF=XLOW 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 SDEPPF--') 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 SDEPPF--') 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 SDEPPF--') 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 SDEPPF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,143) 143 FORMAT(' MAXIMUM ITERATIONS EXCEEDED.') CALL DPWRST('XXX','BUG ') ENDIF C 9000 CONTINUE RETURN END SUBROUTINE SDERAN(N,ALMBDA,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE SKEWED DOUBLE EXPONENTIAL (LAPLACE) C DISTRIBUTION WITH SHAPE PARAMETER = ALMBDA. C THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS C THE PROBABILITY DENSITY FUNCTION C SDEPDF(X,LAMBDA) = 0.5*EXP((1+LAMBDA)*X) X <= 0 C = EXP(-X) - 0.5*EXP((1+LAMBDA)*X) C X > 0 C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --ALMBDA = THE SHAPE (PARAMETER) FOR THE C SKEWED DOUBLE EXPONENTIAL C DISTRIBUTION. C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR C (OF DIMENSION AT LEAST N) C INTO WHICH THE GENERATED C RANDOM SAMPLE WILL BE PLACED. C OUTPUT--A RANDOM SAMPLE OF SIZE N C FROM THE SKEWED DOUBLE EXPONENTIAL DISTRIBUTION C WITH SHAPE PARAMETER = ALMBDA. 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--SDEPPF. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--KOTZ, KOZUBOWSKI, AND PODGORSKI, "THE LAPLACE C DISTRIBUTION AND GENERALIZATIONS: A REVISIT WITH C APPLICATIONS TO COMMUNICATIONS, ECONOMICS, C ENGINEERING, AND FINANCE", BIRKHAUSR, 2001, C PP. 134. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABORATORY C NATION INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2855 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2004.6 C ORIGINAL VERSION--JUNE 2004. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)THEN WRITE(ICOUT,5) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF IF(ALMBDA.LT.0.0)THEN WRITE(ICOUT,15) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,48)ALMBDA CALL DPWRST('XXX','WRIT') PDF=0.0 GOTO9999 ENDIF 5 FORMAT('***** ERROR--FOR THE SKEWED DOUBLE EXPONENTIAL ', 1 'DISTRIBUTION,') 6 FORMAT(' THE REQUESTED NUMBER OF RANDOM NUMBERS WAS ', 1 'NON-POSITIVE.') 15 FORMAT('***** ERROR: VALUE OF LAMBDA FOR SKEW DOUBLE ', 1 'EXPONENTIAL RANDOM NUMBERS IS NEGATIVE.') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,'.') 48 FORMAT(' VALUE OF ARGUMENT IS: ',G15.7) C C USE PERCENT POINT TRANSFORMATION METHOD. C CALL UNIRAN(N,ISEED,X) C DO100I=1,N ATEMP=X(I) CALL SDEPPF(ATEMP,ALMBDA,APPF) X(I)=APPF 100 CONTINUE C 9999 CONTINUE RETURN END SUBROUTINE SDMEAN(X,N,IWRITE,XSDM,IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C STANDARD DEVIATION OF THE MEAN (AVERAGE). C IT IS HERE COMPUTED AS THE RATIO OF THE C SAMPLE STANDARD DEVIATION (WITH DENOMINATOR N-1) C OF THE DATA IN THE INPUT VECTOR X, C DIVIDED BY THE SQUARE ROOT OF THE C NUMBER N OF OBSERVATIONS IN X. C THE SAMPLE STANDARD DEVIATION = SQRT((THE SUM OF THE C SQUARED DEVIATIONS ABOUT THE SAMPLE MEAN)/(N-1)). C THE STANDARD DEVIATION OF THE MEAN = C THE SAMPLE STANDARD DEVIATION / SQRT(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--XSDM = THE SINGLE PRECISION VALUE OF THE C COMPUTED STANDARD DEVIATION C OF THE SAMPLE MEAN. C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE C STANDARD DEVIATION OF THE SAMPLE MEAN. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--DSQRT. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--SNEDECOR AND COCHRAN, STATISTICAL METHODS, C EDITION 6, 1967, PAGE 44. C --DIXON AND MASSEY, INTRODUCTION TO STATISTICAL C ANALYSIS, EDITION 2, 1957, PAGES 19, 76. 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 (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--82.6 C ORIGINAL VERSION--JANUARY 1978. C UPDATED --JUNE 1979. C UPDATED --JUNE 1979. C UPDATED --AUGUST 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DOUBLE PRECISION DN DOUBLE PRECISION DX DOUBLE PRECISION DSUM DOUBLE PRECISION DMEAN DOUBLE PRECISION DVAR DOUBLE PRECISION DSD C DIMENSION X(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='SDME' ISUBN2='AN ' C IERROR='NO' C DMEAN=0.0D0 DSD=0.0D0 C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF SDMEAN--') 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 STANDARD DEVIATION OF THE 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 SDMEAN--') 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 STANDARD DEVIATION OF THE MEAN 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 SDMEAN--', 1'THE 2ND INPUT ARGUMENT (N) HAS THE VALUE 1') CALL DPWRST('XXX','BUG ') XSDM=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 SDMEAN--', 1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','BUG ') XSDM=0.0 GOTO9000 139 CONTINUE C 190 CONTINUE C C *************************************************** C ** STEP 2-- ** C ** COMPUTE THE STANDARD DEVIATION OF THE MEAN. ** C *************************************************** C DN=N DSUM=0.0D0 DO200I=1,N DX=X(I) DSUM=DSUM+DX 200 CONTINUE DMEAN=DSUM/DN C DSUM=0.0D0 DO300I=1,N DX=X(I) DSUM=DSUM+(DX-DMEAN)**2 300 CONTINUE DVAR=DSUM/(DN-1.0D0) DSD=0.0D0 IF(DVAR.GT.0.0D0)DSD=DSQRT(DVAR) XSDM=DSD/DSQRT(DN) C C ******************************* C ** STEP 3-- ** C ** WRITE OUT A LINE ** C ** OF SUMMARY INFORMATION. ** C ******************************* C IF(IFEEDB.EQ.'OFF')GOTO890 IF(IWRITE.EQ.'OFF')GOTO890 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,811)N,XSDM 811 FORMAT('THE STANDARD DEVIATION OF THE MEAN BASED ON ',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 SDMEAN--') 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)DMEAN,DSD 9014 FORMAT('DMEAN,DSD = ',2D15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)XSDM 9015 FORMAT('XSDM = ',E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END REAL FUNCTION SDOT(N,SX,INCX,SY,INCY) C C***BEGIN PROLOGUE SDOT C***DATE WRITTEN 791001 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D1A4 C***KEYWORDS BLAS,INNER PRODUCT,LINEAR ALGEBRA,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 S.P. inner product of s.p. vectors 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 SY single precision vector with N elements C INCY storage spacing between elements of SY C C --Output-- C SDOT single precision dot product (zero if N .LE. 0) C C where LX = 1 if INCX .GE. 0, else LX = (-INCX)*N, and LY is C defined in a similar way using INCY. 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 SDOT C REAL SX(*),SY(*) C***FIRST EXECUTABLE STATEMENT SDOT SDOT = 0.0E0 IF(N.LE.0)RETURN IF(INCX.EQ.INCY) IF(INCX-1)5,20,60 5 CONTINUE C C CODE FOR UNEQUAL INCREMENTS OR NONPOSITIVE INCREMENTS. C IX = 1 IY = 1 IF(INCX.LT.0)IX = (-N+1)*INCX + 1 IF(INCY.LT.0)IY = (-N+1)*INCY + 1 DO 10 I = 1,N SDOT = SDOT + SX(IX)*SY(IY) IX = IX + INCX IY = IY + INCY 10 CONTINUE RETURN C C CODE FOR BOTH INCREMENTS EQUAL TO 1 C C C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 5. C 20 M = MOD(N,5) IF( M .EQ. 0 ) GO TO 40 DO 30 I = 1,M SDOT = SDOT + SX(I)*SY(I) 30 CONTINUE IF( N .LT. 5 ) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,5 SDOT = SDOT + SX(I)*SY(I) + SX(I + 1)*SY(I + 1) + 1 SX(I + 2)*SY(I + 2) + SX(I + 3)*SY(I + 3) + SX(I + 4)*SY(I + 4) 50 CONTINUE RETURN C C CODE FOR POSITIVE EQUAL INCREMENTS .NE.1. C 60 CONTINUE NS=N*INCX DO 70 I=1,NS,INCX SDOT = SDOT + SX(I)*SY(I) 70 CONTINUE RETURN END REAL FUNCTION SDSDOT(N,X,INCX,Y,INCY,C) CCCCC REAL FUNCTION SDSDOT(N,SB,SX,INCX,SY,INCY) CCCCC OCTOBER 1993. USE VERSION AS CODED IN LINPACK MANUAL C***BEGIN PROLOGUE SDSDOT C***DATE WRITTEN 791001 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D1A4 C***KEYWORDS BLAS,INNER PRODUCT,LINEAR ALGEBRA,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 S.P. result with inner product accumulated in d.p. 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 C single precision scalar to be added to inner product C X single precision vector with N elements C INCX storage spacing between elements of SX C Y single precision vector with N elements C INCY storage spacing between elements of SY C C --Output-- C SDSDOT single precision dot product (zero if N .LE. 0) C C Returns S.P. result with dot product accumulated in D.P. C SDSDOT = SB + sum for I = 0 to N-1 of SX(LX+I*INCX)*SY(LY+I*INCY) C where LX = 1 if INCX .GE. 0, else LX = (-INCX)*N, and LY is C defined in a similar way using INCY. 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 SDSDOT C REAL X(INCX,*),Y(INCY,*),C DOUBLE PRECISION SUM C***FIRST EXECUTABLE STATEMENT SDSDOT SUM = 0.0D0 IF(N .LE. 0) GO TO 20 DO 10 I = 1,N SUM = SUM + DBLE(X(1,I))*DBLE(Y(1,I)) 10 CONTINUE 20 SUM = SUM + DBLE(C) SDSDOT = SNGL(SUM) RETURN END SUBROUTINE SECFAC(NR,N,X,G,A,XPLS,GPLS,EPSM,ITNCNT,RNF, + IAGFLG,NOUPDT,S,Y,U,W) IMPLICIT DOUBLE PRECISION (A-H,O-Z) C C PURPOSE C ------- C UPDATE HESSIAN BY THE BFGS FACTORED 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 G(N) --> GRADIENT OR APPROXIMATE AT OLD ITERATE C A(N,N) <--> ON ENTRY: CHOLESKY DECOMPOSITION OF HESSIAN IN C LOWER PART AND DIAGONAL. C ON EXIT: UPDATED CHOLESKY DECOMPOSITION OF HESSIAN C IN LOWER TRIANGULAR PART AND DIAGONAL C XPLS(N) --> NEW ITERATE, X[K] C GPLS(N) --> GRADIENT OR APPROXIMATE AT NEW ITERATE C EPSM --> MACHINE EPSILON C ITNCNT --> ITERATION COUNT C RNF --> RELATIVE NOISE IN OPTIMIZATION FUNCTION FCN C IAGFLG --> =1 IF ANALYTIC GRADIENT SUPPLIED, =0 ITHERWISE C NOUPDT <--> BOOLEAN: NO UPDATE YET C [RETAIN VALUE BETWEEN SUCCESSIVE CALLS] C S(N) --> WORKSPACE C Y(N) --> WORKSPACE C U(N) --> WORKSPACE C W(N) --> WORKSPACE C DIMENSION X(N),XPLS(N),G(N),GPLS(N) DIMENSION A(NR,1) DIMENSION S(N),Y(N),U(N),W(N) LOGICAL NOUPDT,SKPUPD C IF(ITNCNT.EQ.1) NOUPDT=.TRUE. DO 10 I=1,N S(I)=XPLS(I)-X(I) Y(I)=GPLS(I)-G(I) 10 CONTINUE DEN1=DDOT(N,S,1,Y,1) SNORM2=DNRM2(N,S,1) YNRM2=DNRM2(N,Y,1) IF(DEN1.LT.SQRT(EPSM)*SNORM2*YNRM2) GO TO 110 C IF(DEN1.GE.SQRT(EPSM)*SNORM2*YNRM2) C THEN CALL MVMLTU(NR,N,A,S,U) DEN2=DDOT(N,U,1,U,1) C C L <-- SQRT(DEN1/DEN2)*L C ALP=SQRT(DEN1/DEN2) IF(.NOT.NOUPDT) GO TO 50 C IF(NOUPDT) C THEN DO 30 J=1,N U(J)=ALP*U(J) DO 20 I=J,N A(I,J)=ALP*A(I,J) 20 CONTINUE 30 CONTINUE NOUPDT=.FALSE. DEN2=DEN1 ALP=1.0 C ENDIF 50 SKPUPD=.TRUE. C C W = L(L+)S = HS C CALL MVMLTL(NR,N,A,U,W) I=1 IF(IAGFLG.NE.0) GO TO 55 C IF(IAGFLG.EQ.0) C THEN RELTOL=SQRT(RNF) GO TO 60 C ELSE 55 RELTOL=RNF C ENDIF 60 IF(I.GT.N .OR. .NOT.SKPUPD) GO TO 70 C IF(I.LE.N .AND. SKPUPD) C THEN IF(ABS(Y(I)-W(I)) .LT. RELTOL*MAX(ABS(G(I)),ABS(GPLS(I)))) + GO TO 65 C IF(ABS(Y(I)-W(I)) .GE. RELTOL*AMAX1(ABS(G(I)),ABS(GPLS(I)))) C THEN SKPUPD=.FALSE. GO TO 60 C ELSE 65 I=I+1 GO TO 60 C ENDIF C ENDIF 70 IF(SKPUPD) GO TO 110 C IF(.NOT.SKPUPD) C THEN C C W=Y-ALP*L(L+)S C DO 75 I=1,N W(I)=Y(I)-ALP*W(I) 75 CONTINUE C C ALP=1/SQRT(DEN1*DEN2) C ALP=ALP/DEN1 C C U=(L+)/SQRT(DEN1*DEN2) = (L+)S/SQRT((Y+)S * (S+)L(L+)S) C DO 80 I=1,N U(I)=ALP*U(I) 80 CONTINUE C C COPY L INTO UPPER TRIANGULAR PART. ZERO L. C IF(N.EQ.1) GO TO 93 DO 90 I=2,N IM1=I-1 DO 85 J=1,IM1 A(J,I)=A(I,J) A(I,J)=0. 85 CONTINUE 90 CONTINUE C C FIND Q, (L+) SUCH THAT Q(L+) = (L+) + U(W+) C 93 CALL QRUPDT(NR,N,A,U,W) C C UPPER TRIANGULAR PART AND DIAGONAL OF A NOW CONTAIN UPDATED C CHOLESKY DECOMPOSITION OF HESSIAN. COPY BACK TO LOWER C TRIANGULAR PART. C IF(N.EQ.1) GO TO 110 DO 100 I=2,N IM1=I-1 DO 95 J=1,IM1 A(I,J)=A(J,I) 95 CONTINUE 100 CONTINUE C ENDIF C ENDIF 110 RETURN END SUBROUTINE SECUNF(NR,N,X,G,A,UDIAG,XPLS,GPLS,EPSM,ITNCNT, + RNF,IAGFLG,NOUPDT,S,Y,T) IMPLICIT DOUBLE PRECISION (A-H,O-Z) C C PURPOSE C ------- C UPDATE HESSIAN BY THE BFGS UNFACTORED 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 G(N) --> GRADIENT OR APPROXIMATE AT OLD ITERATE C A(N,N) <--> ON ENTRY: APPROXIMATE HESSIAN AT OLD ITERATE C IN UPPER TRIANGULAR PART (AND UDIAG) C ON EXIT: UPDATED APPROX HESSIAN AT NEW ITERATE C IN LOWER TRIANGULAR PART AND DIAGONAL C [LOWER TRIANGULAR PART OF SYMMETRIC MATRIX] C UDIAG --> ON ENTRY: DIAGONAL OF HESSIAN C XPLS(N) --> NEW ITERATE, X[K] C GPLS(N) --> GRADIENT OR APPROXIMATE AT NEW ITERATE C EPSM --> MACHINE EPSILON C ITNCNT --> ITERATION COUNT C RNF --> RELATIVE NOISE IN OPTIMIZATION FUNCTION FCN C IAGFLG --> =1 IF ANALYTIC GRADIENT SUPPLIED, =0 OTHERWISE C NOUPDT <--> BOOLEAN: NO UPDATE YET C [RETAIN VALUE BETWEEN SUCCESSIVE CALLS] C S(N) --> WORKSPACE C Y(N) --> WORKSPACE C T(N) --> WORKSPACE C DIMENSION X(N),G(N),XPLS(N),GPLS(N) DIMENSION A(NR,1) DIMENSION UDIAG(N) DIMENSION S(N),Y(N),T(N) LOGICAL NOUPDT,SKPUPD C C COPY HESSIAN IN UPPER TRIANGULAR PART AND UDIAG TO C LOWER TRIANGULAR PART AND DIAGONAL C DO 5 J=1,N A(J,J)=UDIAG(J) IF(J.EQ.N) GO TO 5 JP1=J+1 DO 4 I=JP1,N A(I,J)=A(J,I) 4 CONTINUE 5 CONTINUE C IF(ITNCNT.EQ.1) NOUPDT=.TRUE. DO 10 I=1,N S(I)=XPLS(I)-X(I) Y(I)=GPLS(I)-G(I) 10 CONTINUE DEN1=DDOT(N,S,1,Y,1) SNORM2=DNRM2(N,S,1) YNRM2=DNRM2(N,Y,1) IF(DEN1.LT.SQRT(EPSM)*SNORM2*YNRM2) GO TO 100 C IF(DEN1.GE.SQRT(EPSM)*SNORM2*YNRM2) C THEN CALL MVMLTS(NR,N,A,S,T) DEN2=DDOT(N,S,1,T,1) IF(.NOT. NOUPDT) GO TO 50 C IF(NOUPDT) C THEN C C H <-- [(S+)Y/(S+)HS]H C GAM=DEN1/DEN2 DEN2=GAM*DEN2 DO 30 J=1,N T(J)=GAM*T(J) DO 20 I=J,N A(I,J)=GAM*A(I,J) 20 CONTINUE 30 CONTINUE NOUPDT=.FALSE. C ENDIF 50 SKPUPD=.TRUE. C C CHECK UPDATE CONDITION ON ROW I C DO 60 I=1,N TOL=RNF*MAX(ABS(G(I)),ABS(GPLS(I))) IF(IAGFLG.EQ.0) TOL=TOL/SQRT(RNF) IF(ABS(Y(I)-T(I)).LT.TOL) GO TO 60 C IF(ABS(Y(I)-T(I)).GE.TOL) C THEN SKPUPD=.FALSE. GO TO 70 C ENDIF 60 CONTINUE 70 IF(SKPUPD) GO TO 100 C IF(.NOT.SKPUPD) C THEN C C BFGS UPDATE C DO 90 J=1,N DO 80 I=J,N A(I,J)=A(I,J)+Y(I)*Y(J)/DEN1-T(I)*T(J)/DEN2 80 CONTINUE 90 CONTINUE C ENDIF C ENDIF 100 RETURN END SUBROUTINE SEMCDF(X,R,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE SEMI-CIRCULAR C DISTRIBUTION ON THE INTERVAL (-R,R). C THE CUMULATIVE DISTRIBUTION FUNCTION IS C C F(X;R) = 0.5 + X*SQRT(R**2-X**2)/(PI*R**2) + C ARCSIN(X/R)/PI C C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C --R = THE SINGLE PRECISION VALUE OF C THE SHAPE PARAMETER (RADIUS) 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 -R AND R, INCLUSIVELY. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT, ATAN. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--XXXXX. 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--82.6 C ORIGINAL VERSION--NOVEMBER 1977. C UPDATED --DECEMBER 1981. C UPDATED --MAY 1982. C UPDATED --OCTOBER 2006. GENERALIZE TO CASE WHERE C RADIUS NOT EQUAL TO 1 C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C DATA PI/3.14159265359/ C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(R.LE.0.0)THEN WRITE(ICOUT,1) 1 FORMAT('***** ERROR--THE SECOD INPUT ARGUMENT ', 1 'TO SEMCDF IS NON-POSITIVE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)R CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9000 ENDIF IF(X.LT.-R .OR. X.GT.R)THEN WRITE(ICOUT,2) 2 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT ', 1 'TO SEMCDF IS OUTSIDE THE (-R,R) INTERVAL') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)R 47 FORMAT('***** THE VALUE OF R IS ',G15.7) CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9000 ENDIF C IF(X.EQ.-R)THEN CDF=0.0 ELSEIF(X.EQ.R)THEN CDF=1.0 ELSE TERM1=0.5 TERM2=X*SQRT(R**2 - X*X)/(PI*R**2) TERM3=ASIN(X/R)/PI CDF=TERM1 + TERM2 + TERM3 ENDIF C 9000 CONTINUE RETURN END SUBROUTINE SEMPDF(X,R,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE SEMI-CIRCULAR C DISTRIBUTION ON THE INTERVAL (-R,R). C THIS DISTRIBUTION HAS MEAN = 0.0 C AND STANDARD DEVIATION = SQRT(R**2/4) C THIS DISTRIBUTION HAS THE PROBABILITY C DENSITY FUNCTION C C F(X;R) = 2*SQRT(R**2-X**2)/(PI*R**2) C C (A SEMI-CIRCLE FOR R=1, AN ELLIPSE OTHERWISE). C THIS DISTRIBUTION IS IMPORTANT IN THAT IT IS C THE DISTRIBUTION ONTO ONE AXIS C OF POINTS WHICH ARE UNIFORMLY C DISTRIBUTED WITHIN A CIRCLE OF UNIT RADIUS. C IT IS USEFUL IN TESTING FOR C 2-DIMENSIONAL UNIFORMITY. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C --R = THE SINGLE PRECISION VALUE THAT C DEFINES THE RADIUS 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 -R AND R, INCLUSIVELY. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--XXXXX. 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--94.4 C ORIGINAL VERSION--APRIL 1994 C UPDATED --OCTOBER 2006. GENERALIZE TO CASES WHERE C R NOT EQUAL TO 1. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----DATA STATEMENTS------------------------------------------------- C DATA PI/3.14159265359/ C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(R.LE.0.0)THEN WRITE(ICOUT,1) 1 FORMAT('***** ERROR--THE SECOD INPUT ARGUMENT ', 1 'TO SEMPDF IS NON-POSITIVE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)R CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9000 ENDIF IF(X.LT.-R .OR. X.GT.R)THEN WRITE(ICOUT,2) 2 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT ', 1 'TO SEMPDF IS OUTSIDE THE (-R,R) INTERVAL') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)X 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)R 47 FORMAT('***** THE VALUE OF R IS ',G15.7) CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9000 ENDIF C IF(X.EQ.-R)THEN PDF=0.0 ELSEIF(X.EQ.R)THEN PDF=0.0 ELSE PDF=2.0*SQRT(R**2 - X*X)/(R**2*PI) ENDIF C 9000 CONTINUE RETURN END SUBROUTINE SEMPPF(P,R,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE SEMI-CIRCULAR C DISTRIBUTION ON THE INTERVAL (-R,R). C THIS DISTRIBUTION HAS MEAN = 0.0 C AND STANDARD DEVIATION = SQRT(R**2/4) C THIS DISTRIBUTION HAS THE PROBABILITY C DENSITY FUNCTION C C F(X;R) = 2*SQRT(R**2-X**2)/(PI*R**2) C C (A SEMI-CIRCLE FOR R=1, AN ELLIPSE OTHERWISE). 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 --R = THE SINGLE PRECISION VALUE THAT C DEFINES THE RADIUS C OUTPUT ARGUMENTS--PPF = THE SINGLE PRECISION PERCENT C POINT FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PERCENT POINT C FUNCTION VALUE PPF. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--P SHOULD BE BETWEEN 0.0 AND 1.0, INCLUSIVELY. C OTHER DATAPAC SUBROUTINES NEEDED--SEMCDF. C FORTRAN LIBRARY SUBROUTINES NEEDED--ABS. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--FILLIBEN, SIMPLE AND ROBUST LINEAR ESTIMATION C OF THE LOCATION PARAMETER OF A SYMMETRIC C DISTRIBUTION (UNPUBLISHED PH.D. DISSERTATION, C PRINCETON UNIVERSITY), 1969, PAGES 21-44, 229-231. C --FILLIBEN, 'THE PERCENT POINT FUNCTION', C (UNPUBLISHED MANUSCRIPT), 1970, PAGES 28-31. C --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--2, 1970, PAGES 57-74. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C 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--82.6 C ORIGINAL VERSION--DECEMBER 1977. C UPDATED --DECEMBER 1981. C UPDATED --MAY 1982. C UPDATED --OCTOBER 2006. GENERALIZE TO THE CASE C WHERE R NOT EQUAL TO 1 C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C 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 ') GOTO9000 ENDIF 1 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT TO ', 1 'SEMPPF IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) IF(R.LE.0.0)THEN WRITE(ICOUT,2) 2 FORMAT('***** ERROR--THE SECOD INPUT ARGUMENT ', 1 'TO SEMPDF IS NON-POSITIVE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)R CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9000 ENDIF C PHOLD=P IF(PHOLD.EQ.0.0)THEN PPF=-R ELSEIF(PHOLD.EQ.1.0)THEN PPF=R ELSE CONTINUE TOL=0.000001 MAXIT=100 C XMIN=-R XMAX=R C XMID=(XMIN+XMAX)/2.0 XLOW=XMIN XUP=XMAX ICOUNT=0 C 210 CONTINUE X=XMID CALL SEMCDF(X,R,PCALC) IF(PCALC.EQ.PHOLD)GOTO240 IF(PCALC.GT.PHOLD)GOTO220 C XLOW=XMID XMID=(XMID+XUP)/2.0 GOTO230 C 220 CONTINUE XUP=XMID XMID=(XMID+XLOW)/2.0 C 230 CONTINUE XDEL=ABS(XMID-XLOW) ICOUNT=ICOUNT+1 IF(XDEL.LT.TOL.OR.ICOUNT.GT.MAXIT)GOTO240 GOTO210 C 240 CONTINUE PPF=XMID ENDIF C 9000 CONTINUE RETURN END SUBROUTINE SEMRAN(N,R,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE SEMI-CIRCULAR DISTRIBUTION. C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --R = THE SINGLE PRECISION VALUE THAT C DEFINES THE RADIUS 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 SEMI-CIRCULAR DISTRIBUTION C WITH MEAN = 0 AND STANDARD DEVIATION = ZZZ C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN, SEMPPF C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--TOCHER, THE ART OF SIMULATION, C 1963, PAGES 14-15. C --HAMMERSLEY AND HANDSCOMB, MONTE CARLO METHODS, C 1964, PAGE 36. C --FILLIBEN, SIMPLE AND ROBUST LINEAR ESTIMATION C OF THE LOCATION PARAMETER OF A SYMMETRIC C DISTRIBUTION (UNPUBLISHED PH.D. DISSERTATION, C PRINCETON UNIVERSITY), 1969, PAGE 230. C --FILLIBEN, 'THE PERCENT POINT FUNCTION', C (UNPUBLISHED MANUSCRIPT), 1970, PAGES 28-31. C --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE C DISTRIBUTIONS--2, 1970, PAGES ZZZ. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C 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--82.6 C ORIGINAL VERSION--JUNE 1978. C UPDATED --DECEMBER 1981. C UPDATED --MAY 1982. C UPDATED --OCTOBER 2006. GENERALIZE TO CASES WHERE C R NOT EQUAL TO 1. 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('***** ERROR--THE REQUESTED NUMBER OF SEMI-CIRCULAR ', 1 'RANDOM NUMBERS IS NON-POSITIVE') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) C IF(R.LE.0.0)THEN WRITE(ICOUT,8) 8 FORMAT('***** ERROR--THE SHAPE PARAMETER, R, FOR THE ', 1 'SEMI-CIRCULAR RANDOM NUMBERS IS NON-POSITIVE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,46)R 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF C C GENERATE N UNIFORM (0,1) RANDOM NUMBERS; C CALL UNIRAN(N,ISEED,X) C C GENERATE N SEMI-CIRCULAR RANDOM NUMBERS C USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD. C DO100I=1,N CALL SEMPPF(X(I),R,ATEMP) X(I)=ATEMP 100 CONTINUE C 9000 CONTINUE RETURN END SUBROUTINE SEQDIF(X,NX,IWRITE,Y,NY,IBUGA3,IERROR) C C PURPOSE--COMPUTE SEQUENTIAL DIFFERENCE OF A VARIABLE-- C Y(1) = 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 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--82.6 C ORIGINAL VERSION--FEBRUARY 1979. C UPDATED --APRIL 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 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='SEQD' ISUBN2='DI ' 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 SEQDIF--') 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 NXM1=NX-1 IF(NXM1.LT.1)GOTO150 DO100I=1,NXM1 IP1=I+1 Y(I)=X(IP1)-X(I) 100 CONTINUE NY=NXM1 GOTO190 C 150 CONTINUE IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,151) 151 FORMAT('***** ERROR IN SEQDIF--') 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 SEQUENTIAL DIFFERENCE IS 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 SEQDIF--') 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 SETARI(Y1,Y2,N1,N2,IACASE,IWRITE, 1Y3,Y4,N3,SCAL3,ITYP3,IBUGA3,ISUBRO,IERROR) C C PURPOSE--CARRY OUT SET ARITHMETIC OPERATIONS C OF THE REAL DATA IN Y1 AND Y2. C C OPERATIONS--UNION C INTERSECTION C COMPLEMENT C CARDINALITY C CARTESIAN PRODUCT C ELEMENTS (DISTINCT) C C INPUT ARGUMENTS--Y1 (REAL) C --Y2 (REAL) C OUTPUT ARGUMENTS--Y3 (REAL) C SCAL3 C ITYP3 C --Y4 (REAL) C C NOTE--IT IS NOT PERMISSIBLE TO HAVE THE OUTPUT SETS Y3(.) & Y4(.) C BEING IDENTICAL TO THE INPUT SETS Y1(.) OR Y2(.). 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--87/9 C ORIGINAL VERSION--AUGUST 1987. C UPDATED --JUNE 1990. TEMPORARY ARRAYS TO GARBAGE COMMON C UPDATED --SEPTEMBER 1993. FIX CARTESIAN PRODUCT (ALAN) 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(*) DIMENSION Y4(*) C DIMENSION Y1HOLD(MAXOBV) DIMENSION Y2HOLD(MAXOBV) CCCCC FOLLOWING LINES ADDED JUNE, 1990 INCLUDE 'DPCOZ2.INC' EQUIVALENCE (G2RBAG(IGAR11),Y1HOLD(1)) EQUIVALENCE (G2RBAG(IGAR12),Y2HOLD(1)) CCCCC END CHANGE C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='SETA' ISUBN2='RI ' C IERROR='NO' C SCAL3=(-999.0) ITYP3='VECT' C TOL=0.00001 C IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'TARI')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF SETARI--') 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 SET ARITHMETIC OPERATIONS ** C ************************************************** C C ******************************************** C ** STEP 11-- ** C ** CHECK NUMBER OF INPUT OBSERVATIONS. ** C ******************************************** C IF(N1.LT.1)GOTO1100 IF(IACASE.EQ.'SECA')GOTO1190 IF(IACASE.EQ.'SEEL')GOTO1190 IF(N2.LT.1)GOTO1100 GOTO1190 C 1100 CONTINUE IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1151) 1151 FORMAT('***** ERROR IN SETARI--') 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.'SEUN')WRITE(ICOUT,1161) 1161 FORMAT(' THE SET UNION IS TO BE ', 1'COMPUTED') IF(IACASE.EQ.'SEUN')CALL DPWRST('XXX','BUG ') IF(IACASE.EQ.'SEIN')WRITE(ICOUT,1162) 1162 FORMAT(' THE SET INTERSECTION IS TO BE ', 1'COMPUTED') IF(IACASE.EQ.'SEIN')CALL DPWRST('XXX','BUG ') IF(IACASE.EQ.'SECO')WRITE(ICOUT,1163) 1163 FORMAT(' THE SET COMPLEMENT IS TO BE ', 1'COMPUTED') IF(IACASE.EQ.'SECO')CALL DPWRST('XXX','BUG ') IF(IACASE.EQ.'SECA')WRITE(ICOUT,1164) 1164 FORMAT(' THE SET CARDINALITY IS TO BE ', 1'COMPUTED') IF(IACASE.EQ.'SECA')CALL DPWRST('XXX','BUG ') IF(IACASE.EQ.'SECP')WRITE(ICOUT,1165) 1165 FORMAT(' THE SET CARTESIAN PRODUCT IS TO BE ', 1'COMPUTED') IF(IACASE.EQ.'SECP')CALL DPWRST('XXX','BUG ') IF(IACASE.EQ.'SECA')WRITE(ICOUT,1166) 1166 FORMAT(' THE SET ELEMENTS IS TO BE ', 1'COMPUTED') IF(IACASE.EQ.'SECA')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.'SEUN')GOTO2100 IF(IACASE.EQ.'SEIN')GOTO2200 IF(IACASE.EQ.'SECO')GOTO2300 IF(IACASE.EQ.'SECA')GOTO2400 IF(IACASE.EQ.'SECP')GOTO2500 IF(IACASE.EQ.'SEEL')GOTO2600 C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1211) 1211 FORMAT('***** INTERNAL ERROR IN SETARI--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1212) 1212 FORMAT(' IACASE NOT EQUAL TO') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1213) 1213 FORMAT(' SEUN, SEIN, SECO, SECA, ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1214) 1214 FORMAT(' SECP, OR SEEL') 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 SET UNION CASE ** C ********************************************* C 2100 CONTINUE K=1 Y3(K)=Y1(K) C IF(N1.LE.1)GOTO2119 DO2110I=1,N1 TARGET=Y1(I) DO2120J=1,K Y3JL=Y3(J)-TOL Y3JU=Y3(J)+TOL IF(Y3JL.LE.TARGET.AND.TARGET.LE.Y3JU)GOTO2110 2120 CONTINUE K=K+1 Y3(K)=TARGET 2110 CONTINUE 2119 CONTINUE C DO2130I=1,N2 TARGET=Y2(I) DO2140J=1,K Y3JL=Y3(J)-TOL Y3JU=Y3(J)+TOL IF(Y3JL.LE.TARGET.AND.TARGET.LE.Y3JU)GOTO2130 2140 CONTINUE K=K+1 Y3(K)=TARGET 2130 CONTINUE C ITYP3='VECT' N3=K GOTO9000 C C ********************************************* C ** STEP 22-- ** C ** TREAT THE SET INTERSECTION CASE ** C ********************************************* C 2200 CONTINUE K=0 C DO2210I=1,N1 TARGET=Y1(I) DO2220J=1,N2 Y2JL=Y2(J)-TOL Y2JU=Y2(J)+TOL IF(Y2JL.LE.TARGET.AND.TARGET.LE.Y2JU)GOTO2215 2220 CONTINUE GOTO2210 2215 CONTINUE K=K+1 Y3(K)=TARGET 2210 CONTINUE C ITYP3='VECT' N3=K GOTO9000 C C ************************************************ C ** STEP 23-- ** C ** TREAT THE SET COMPLEMENT CASE ** C ************************************************ C 2300 CONTINUE K=0 C DO2310I=1,N2 TARGET=Y2(I) DO2320J=1,N1 Y1JL=Y1(J)-TOL Y1JU=Y1(J)+TOL IF(Y1JL.LE.TARGET.AND.TARGET.LE.Y1JU)GOTO2310 2320 CONTINUE K=K+1 Y3(K)=TARGET 2310 CONTINUE C ITYP3='VECT' N3=K GOTO9000 C C ************************************************ C ** STEP 24-- ** C ** TREAT THE SET CARDINALITY CASE ** C ************************************************ C 2400 CONTINUE K=1 Y3(K)=Y1(K) C IF(N1.LE.1)GOTO2419 DO2410I=1,N1 TARGET=Y1(I) DO2420J=1,K Y3JL=Y3(J)-TOL Y3JU=Y3(J)+TOL IF(Y3JL.LE.TARGET.AND.TARGET.LE.Y3JU)GOTO2410 2420 CONTINUE K=K+1 2410 CONTINUE 2419 CONTINUE SCAL3=K C ITYP3='SCAL' N3=1 GOTO9000 C C *************************************************** C ** STEP 25-- ** C ** TREAT THE SET CARTESIAN PRODUCT CASE ** C *************************************************** C 2500 CONTINUE K1=1 Y1HOLD(K1)=Y1(K1) IF(N1.LE.1)GOTO2519 DO2510I=1,N1 TARGET=Y1(I) DO2520J=1,K1 Y1JL=Y1HOLD(J)-TOL Y1JU=Y1HOLD(J)+TOL IF(Y1JL.LE.TARGET.AND.TARGET.LE.Y1JU)GOTO2510 2520 CONTINUE K1=K1+1 Y1HOLD(K1)=TARGET 2510 CONTINUE 2519 CONTINUE C CCCCC THE FOLLOWING SECTION WAS CORRECTED (ALAN) SEPTEMBER 1993 K2=1 Y2HOLD(K2)=Y2(K2) IF(N2.LE.1)GOTO2539 DO2530I=1,N2 TARGET=Y2(I) DO2540J=1,K2 Y2JL=Y2HOLD(J)-TOL Y2JU=Y2HOLD(J)+TOL IF(Y2JL.LE.TARGET.AND.TARGET.LE.Y2JU)GOTO2530 2540 CONTINUE K2=K2+1 Y2HOLD(K2)=TARGET 2530 CONTINUE 2539 CONTINUE C CCCCC THE FOLLOWING SECTION WAS CORRECTED (ALAN) SEPTEMBER 1993 K=0 DO2550I=1,K1 DO2560J=1,K2 K=K+1 Y3(K)=Y1HOLD(I) Y4(K)=Y2HOLD(J) 2560 CONTINUE 2550 CONTINUE C ITYP3='VECT' N3=K GOTO9000 C C ******************************************************* C ** STEP 26-- ** C ** TREAT THE SET ELEMENTS (DISTINCT) CASE ** C ******************************************************* C 2600 CONTINUE K=1 Y3(K)=Y1(K) C IF(N1.LE.1)GOTO2619 DO2610I=1,N1 TARGET=Y1(I) DO2620J=1,K Y3JL=Y3(J)-TOL Y3JU=Y3(J)+TOL IF(Y3JL.LE.TARGET.AND.TARGET.LE.Y3JU)GOTO2610 2620 CONTINUE K=K+1 Y3(K)=TARGET 2610 CONTINUE 2619 CONTINUE C ITYP3='VECT' N3=K GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE C IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'TARI')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF SETARI--') 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,N2,N3 9017 FORMAT('N1,N2,N3 = ',3I8) 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) 9022 FORMAT('I,Y1(I) = ',I8,E13.5) CALL DPWRST('XXX','BUG ') 9021 CONTINUE DO9031I=1,N2 WRITE(ICOUT,9032)I,Y2(I) 9032 FORMAT('I,Y2(I) = ',I8,E13.5) CALL DPWRST('XXX','BUG ') 9031 CONTINUE DO9041I=1,N3 WRITE(ICOUT,9042)I,Y3(I),Y4(I) 9042 FORMAT('I,Y3(I),Y4(I) = ',I8,2E13.5) CALL DPWRST('XXX','BUG ') 9041 CONTINUE 9090 CONTINUE C RETURN END REAL FUNCTION SGAMMA(ISEED,A) CCCCC REAL FUNCTION SGAMMA(IR,A) C SGA 10 C**********************************************************************CSGA 20 C**********************************************************************CSGA 30 C CSGA 40 C CSGA 50 C (STANDARD-) G A M M A DISTRIBUTION CSGA 60 C CSGA 70 C CSGA 80 C**********************************************************************CSGA 90 C**********************************************************************CSGA 100 C CSGA 110 C PARAMETER A >= 1.0 ] CSGA 120 C CSGA 130 C**********************************************************************CSGA 140 C CSGA 150 C FOR DETAILS SEE: CSGA 160 C CSGA 170 C AHRENS, J.H. AND DIETER, U. CSGA 180 C GENERATING GAMMA VARIATES BY A CSGA 190 C MODIFIED REJECTION TECHNIQUE. CSGA 200 C COMM. ACM, 25,1 (JAN. 1982), 47 - 54. CSGA 210 C CSGA 220 C STEP NUMBERS CORRESPOND TO ALGORITHM 'GD' IN THE ABOVE PAPER CSGA 230 C (STRAIGHTFORWARD IMPLEMENTATION) CSGA 240 C CSGA 250 C**********************************************************************CSGA 260 C CSGA 270 C PARAMETER 0.0 < A < 1.0 ] CSGA 280 C CSGA 290 C**********************************************************************CSGA 300 C CSGA 310 C FOR DETAILS SEE: CSGA 320 C CSGA 330 C AHRENS, J.H. AND DIETER, U. CSGA 340 C COMPUTER METHODS FOR SAMPLING FROM GAMMA, CSGA 350 C BETA, POISSON AND BINOMIAL DISTRIBUTIONS. CSGA 360 C COMPUTING, 12 (1974), 223 - 246. CSGA 370 C CSGA 380 C (ADAPTED IMPLEMENTATION OF ALGORITHM 'GS' IN THE ABOVE PAPER) CSGA 390 C CSGA 400 C**********************************************************************CSGA 410 C SGA 420 C C INPUT: IR=CURRENT STATE OF BASIC RANDOM NUMBER GENERATOR C A =PARAMETER (MEAN) OF THE STANDARD GAMMA DISTRIBUTION C OUTPUT: SGAMMA = SAMPLE FROM THE GAMMA-(A)-DISTRIBUTION C C COEFFICIENTS Q(K) - FOR Q0 = SUM(Q(K)*A**(-K)) C COEFFICIENTS A(K) - FOR Q = Q0+(T*T/2)*SUM(A(K)*V**K) C COEFFICIENTS E(K) - FOR EXP(Q)-1 = SUM(E(K)*Q**K) C C MAY, 2003: SOME MODIFICATIONS MADE IN ORDER TO INCORPORATE C INTO DATAPLOT. C C 1) REPLACE CALLS TO SUNIF WITH CALLS TO DATAPLOT C UNIFORM RANDOM NUMBER ROUTINE "UNIRAN". C 2) REPLACE IR WITH ISEED C 3) REPLACE CALLS TO "SNORM" WITH "NORRAN" C C JANUARY, 2005: THERE WAS A BUG IF GAMMA RAND NUMBER ROUTINE C CALLED MORE THAN ONCE. NEED TO RESET VALUE OF C AA AND AAA TO 0. DO THIS BY STORING IN COMMON C AND HAVING CALLING ROUTINE RESET. C REAL XTEMP(1) C COMMON/SGAMM/AA,AAA C DATA Q1,Q2,Q3,Q4,Q5,Q6,Q7 /.04166669,.02083148, ,.00801191,.00144121,-.00007388,.00024511,.00024240/ DATA A1,A2,A3,A4,A5,A6,A7 /.3333333,-.2500030, ,.2000062,-.1662921,.1423657,-.1367177,.1233795/ DATA E1,E2,E3,E4,E5 /1.,.4999897,.1668290,.0407753,.0102930/ C C PREVIOUS A PRE-SET TO ZERO - AA IS A', AAA IS A" C SQRT32 IS THE SQUAREROOT OF 32 = 5.656854249492380 C CCCCC DATA AA /0.0/, AAA /0.0/, SQRT32 /5.656854/ DATA SQRT32 /5.656854/ C IF (A .EQ. AA) GO TO 1 IF (A .LT. 1.0) GO TO 12 C C STEP 1: RECALCULATIONS OF S2,S,D IF A HAS CHANGED C AA=A S2=A-0.5 S=SQRT(S2) D=SQRT32-12.0*S C C STEP 2: T=STANDARD NORMAL DEVIATE, C X=(S,1/2)-NORMAL DEVIATE. C IMMEDIATE ACCEPTANCE (I) C CCC1 T=SNORM(IR) 1 CONTINUE NTEMP=1 CALL NORRAN(NTEMP,ISEED,XTEMP) T=XTEMP(1) X=S+0.5*T SGAMMA=X*X IF (T .GE. 0.0) RETURN C C STEP 3: U= 0,1 -UNIFORM SAMPLE. SQUEEZE ACCEPTANCE (S) C CCCCC U=SUNIF(IR) NTEMP=1 CALL UNIRAN(NTEMP,ISEED,XTEMP) U=XTEMP(1) IF (D*U .LE. T*T*T) RETURN C C STEP 4: RECALCULATIONS OF Q0,B,SI,C IF NECESSARY C IF (A .EQ. AAA) GO TO 4 AAA=A R=1.0/A Q0=((((((Q7*R+Q6)*R+Q5)*R+Q4)*R+Q3)*R+Q2)*R+Q1)*R C C APPROXIMATION DEPENDING ON SIZE OF PARAMETER A C THE CONSTANTS IN THE EXPRESSIONS FOR B, SI AND C C WERE ESTABLISHED BY NUMERICAL EXPERIMENTS C IF (A .LE. 3.686) GO TO 3 IF (A .LE. 13.022) GO TO 2 C C CASE 3: A .GT. 13.022 C B=1.77 SI=.75 C=.1515/S GO TO 4 C C CASE 2: 3.686 .LT. A .LE. 13.022 C 2 B=1.654+.0076*S2 SI=1.68/S+.275 C=.062/S+.024 GO TO 4 C C CASE 1: A .LE. 3.686 C 3 B=.463+S-.178*S2 SI=1.235 C=.195/S-.079+.016*S C C STEP 5: NO QUOTIENT TEST IF X NOT POSITIVE C 4 IF (X .LE. 0.0) GO TO 7 C C STEP 6: CALCULATION OF V AND QUOTIENT Q C V=T/(S+S) IF (ABS(V) .LE. 0.25) GO TO 5 Q=Q0-S*T+0.25*T*T+(S2+S2)*ALOG(1.0+V) GO TO 6 5 Q=Q0+0.5*T*T*((((((A7*V+A6)*V+A5)*V+A4)*V+A3)*V+A2)*V+A1)*V C C STEP 7: QUOTIENT ACCEPTANCE (Q) C 6 IF (ALOG(1.0-U) .LE. Q) RETURN C C STEP 8: E=STANDARD EXPONENTIAL DEVIATE C U= 0,1 -UNIFORM DEVIATE C T=(B,SI)-DOUBLE EXPONENTIAL (LAPLACE) SAMPLE C CCC7 E=SEXPO(IR) 7 CONTINUE NTEMP=1 CALL EXPRAN(NTEMP,ISEED,XTEMP) E=XTEMP(1) CALL UNIRAN(NTEMP,ISEED,XTEMP) CCCCC U=SUNIF(IR) U=XTEMP(1) U=U+U-1.0 T=B+SIGN(SI*E,U) C C STEP 9: REJECTION IF T .LT. TAU(1) = -.71874483771719 C IF (T .LT. (-.7187449)) GO TO 7 C C STEP 10: CALCULATION OF V AND QUOTIENT Q C V=T/(S+S) IF (ABS(V) .LE. 0.25) GO TO 8 Q=Q0-S*T+0.25*T*T+(S2+S2)*ALOG(1.0+V) GO TO 9 8 Q=Q0+0.5*T*T*((((((A7*V+A6)*V+A5)*V+A4)*V+A3)*V+A2)*V+A1)*V C C STEP 11: HAT ACCEPTANCE (H) (IF Q NOT POSITIVE GO TO STEP 8) C 9 IF (Q .LE. 0.0) GO TO 7 IF (Q .LE. 0.5) GO TO 10 W=EXP(Q)-1.0 GO TO 11 10 W=((((E5*Q+E4)*Q+E3)*Q+E2)*Q+E1)*Q C C IF T IS REJECTED, SAMPLE AGAIN AT STEP 8 C 11 IF (C*ABS(U) .GT. W*EXP(E-0.5*T*T)) GO TO 7 X=S+0.5*T SGAMMA=X*X RETURN C C ALTERNATE METHOD FOR PARAMETERS A BELOW 1 (.3678794=EXP(-1.)) C 12 AA=0.0 B=1.0+.3678794*A CC13 P=B*SUNIF(IR) 13 CONTINUE NTEMP=1 CALL UNIRAN(NTEMP,ISEED,XTEMP) P=B*XTEMP(1) IF (P .GE. 1.0) GO TO 14 SGAMMA=EXP(ALOG(P)/A) CCCCC IF (SEXPO(IR) .LT. SGAMMA) GO TO 13 NTEMP=1 CALL EXPRAN(NTEMP,ISEED,XTEMP) IF (XTEMP(1) .LT. SGAMMA) GO TO 13 RETURN 14 SGAMMA=-ALOG((B-P)/A) CCCCC IF (SEXPO(IR) .LT. (1.0-A)*ALOG(SGAMMA)) GO TO 13 NTEMP=1 CALL EXPRAN(NTEMP,ISEED,XTEMP) IF (XTEMP(1) .LT. (1.0-A)*ALOG(SGAMMA)) GO TO 13 RETURN END SUBROUTINE SGECO(A,LDA,N,IPVT,RCOND,Z) C***BEGIN PROLOGUE SGECO C***DATE WRITTEN 780814 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D2A1 C***KEYWORDS CONDITION,FACTOR,LINEAR ALGEBRA,LINPACK,MATRIX C***AUTHOR MOLER, C. B., (U. OF NEW MEXICO) C***PURPOSE Factors a real matrix by Gaussian elimination and estimates C the condition number of the matrix. C***DESCRIPTION C C SGECO factors a real matrix by Gaussian elimination C and estimates the condition of the matrix. C C If RCOND is not needed, SGEFA is slightly faster. C To solve A*X = B , follow SGECO by SGESL. C To compute INVERSE(A)*C , follow SGECO by SGESL. C To compute DETERMINANT(A) , follow SGECO by SGEDI. C To compute INVERSE(A) , follow SGECO by SGEDI. C C On Entry C C A REAL(LDA, N) C the matrix to be factored. C C LDA INTEGER C the leading dimension of the array A . C C N INTEGER C the order of the matrix A . C C On Return C C A an upper triangular matrix and the multipliers C which were used to obtain it. C The factorization can be written A = L*U , where C L is a product of permutation and unit lower C triangular matrices and U is upper triangular. C C IPVT INTEGER(N) C an integer vector of pivot indices. C C RCOND REAL C an estimate of the reciprocal condition of A . C For the system A*X = B , relative perturbations C in A and B of size EPSILON may cause C relative perturbations in X of size EPSILON/RCOND . C If RCOND is so small that the logical expression C 1.0 + RCOND .EQ. 1.0 C is true, then A may be singular to working C precision. In particular, RCOND is zero if C exact singularity is detected or the estimate C underflows. C C Z REAL(N) C a work vector whose contents are usually unimportant. C If A is close to a singular matrix, then Z is C an approximate null vector in the sense that C NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . C C LINPACK. This version dated 08/14/78 . C Cleve Moler, University of New Mexico, Argonne National Lab. C C Subroutines and Functions C C LINPACK SGEFA C BLAS SAXPY,SDOT,SSCAL,SASUM C Fortran ABS,AMAX1,SIGN C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., C *LINPACK USERS GUIDE*, SIAM, 1979. C***ROUTINES CALLED SASUM,SAXPY,SDOT,SGEFA,SSCAL C***END PROLOGUE SGECO INTEGER LDA,N,IPVT(*) REAL A(LDA,*),Z(*) REAL RCOND C REAL SDOT,EK,T,WK,WKM REAL ANORM,S,SASUM,SM,YNORM INTEGER INFO,J,K,KB,KP1,L C C COMPUTE 1-NORM OF A C C***FIRST EXECUTABLE STATEMENT SGECO ANORM = 0.0E0 DO 10 J = 1, N ANORM = AMAX1(ANORM,SASUM(N,A(1,J),1)) 10 CONTINUE C C FACTOR C CALL SGEFA(A,LDA,N,IPVT,INFO) C C RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . C ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND TRANS(A)*Y = E . C TRANS(A) IS THE TRANSPOSE OF A . THE COMPONENTS OF E ARE C CHOSEN TO CAUSE MAXIMUM LOCAL GROWTH IN THE ELEMENTS OF W WHERE C TRANS(U)*W = E . THE VECTORS ARE FREQUENTLY RESCALED TO AVOID C OVERFLOW. C C SOLVE TRANS(U)*W = E C EK = 1.0E0 DO 20 J = 1, N Z(J) = 0.0E0 20 CONTINUE DO 100 K = 1, N IF (Z(K) .NE. 0.0E0) EK = SIGN(EK,-Z(K)) IF (ABS(EK-Z(K)) .LE. ABS(A(K,K))) GO TO 30 S = ABS(A(K,K))/ABS(EK-Z(K)) CALL SSCAL(N,S,Z,1) EK = S*EK 30 CONTINUE WK = EK - Z(K) WKM = -EK - Z(K) S = ABS(WK) SM = ABS(WKM) IF (A(K,K) .EQ. 0.0E0) GO TO 40 WK = WK/A(K,K) WKM = WKM/A(K,K) GO TO 50 40 CONTINUE WK = 1.0E0 WKM = 1.0E0 50 CONTINUE KP1 = K + 1 IF (KP1 .GT. N) GO TO 90 DO 60 J = KP1, N SM = SM + ABS(Z(J)+WKM*A(K,J)) Z(J) = Z(J) + WK*A(K,J) S = S + ABS(Z(J)) 60 CONTINUE IF (S .GE. SM) GO TO 80 T = WKM - WK WK = WKM DO 70 J = KP1, N Z(J) = Z(J) + T*A(K,J) 70 CONTINUE 80 CONTINUE 90 CONTINUE Z(K) = WK 100 CONTINUE S = 1.0E0/SASUM(N,Z,1) CALL SSCAL(N,S,Z,1) C C SOLVE TRANS(L)*Y = W C DO 120 KB = 1, N K = N + 1 - KB IF (K .LT. N) Z(K) = Z(K) + SDOT(N-K,A(K+1,K),1,Z(K+1),1) IF (ABS(Z(K)) .LE. 1.0E0) GO TO 110 S = 1.0E0/ABS(Z(K)) CALL SSCAL(N,S,Z,1) 110 CONTINUE L = IPVT(K) T = Z(L) Z(L) = Z(K) Z(K) = T 120 CONTINUE S = 1.0E0/SASUM(N,Z,1) CALL SSCAL(N,S,Z,1) C YNORM = 1.0E0 C C SOLVE L*V = Y C DO 140 K = 1, N L = IPVT(K) T = Z(L) Z(L) = Z(K) Z(K) = T IF (K .LT. N) CALL SAXPY(N-K,T,A(K+1,K),1,Z(K+1),1) IF (ABS(Z(K)) .LE. 1.0E0) GO TO 130 S = 1.0E0/ABS(Z(K)) CALL SSCAL(N,S,Z,1) YNORM = S*YNORM 130 CONTINUE 140 CONTINUE S = 1.0E0/SASUM(N,Z,1) CALL SSCAL(N,S,Z,1) YNORM = S*YNORM C C SOLVE U*Z = V C DO 160 KB = 1, N K = N + 1 - KB IF (ABS(Z(K)) .LE. ABS(A(K,K))) GO TO 150 S = ABS(A(K,K))/ABS(Z(K)) CALL SSCAL(N,S,Z,1) YNORM = S*YNORM 150 CONTINUE IF (A(K,K) .NE. 0.0E0) Z(K) = Z(K)/A(K,K) IF (A(K,K) .EQ. 0.0E0) Z(K) = 1.0E0 T = -Z(K) CALL SAXPY(K-1,T,A(1,K),1,Z(1),1) 160 CONTINUE C MAKE ZNORM = 1.0 S = 1.0E0/SASUM(N,Z,1) CALL SSCAL(N,S,Z,1) YNORM = S*YNORM C IF (ANORM .NE. 0.0E0) RCOND = YNORM/ANORM IF (ANORM .EQ. 0.0E0) RCOND = 0.0E0 RETURN END SUBROUTINE SGEDI(A,LDA,N,IPVT,DET,WORK,JOB) C***BEGIN PROLOGUE SGEDI C***DATE WRITTEN 780814 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D2A1,D3A1 C***KEYWORDS DETERMINANT,FACTOR,INVERSE,LINEAR ALGEBRA,LINPACK,MATRIX C***AUTHOR MOLER, C. B., (U. OF NEW MEXICO) C***PURPOSE Computes the determinant and inverse of a matrix C using the factors computed by SGECO or SGEFA. C***DESCRIPTION C C SGEDI computes the determinant and inverse of a matrix C using the factors computed by SGECO or SGEFA. C C On Entry C C A REAL(LDA, N) C the output from SGECO or SGEFA. C C LDA INTEGER C the leading dimension of the array A . C C N INTEGER C the order of the matrix A . C C IPVT INTEGER(N) C the pivot vector from SGECO or SGEFA. C C WORK REAL(N) C work vector. Contents destroyed. C C JOB INTEGER C = 11 both determinant and inverse. C = 01 inverse only. C = 10 determinant only. C C On Return C C A inverse of original matrix if requested. C Otherwise unchanged. C C DET REAL(2) C determinant of original matrix if requested. C Otherwise not referenced. C Determinant = DET(1) * 10.0**DET(2) C with 1.0 .LE. ABS(DET(1)) .LT. 10.0 C or DET(1) .EQ. 0.0 . C C Error Condition C C A division by zero will occur if the input factor contains C a zero on the diagonal and the inverse is requested. C It will not occur if the subroutines are called correctly C and if SGECO has set RCOND .GT. 0.0 or SGEFA has set C INFO .EQ. 0 . C C LINPACK. This version dated 08/14/78 . C Cleve Moler, University of New Mexico, Argonne National Lab. C C Subroutines and Functions C C BLAS SAXPY,SSCAL,SSWAP C Fortran ABS,MOD C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., C *LINPACK USERS GUIDE*, SIAM, 1979. C***ROUTINES CALLED SAXPY,SSCAL,SSWAP C***END PROLOGUE SGEDI INTEGER LDA,N,IPVT(1),JOB REAL A(LDA,1),DET(2),WORK(1) C REAL T REAL TEN INTEGER I,J,K,KB,KP1,L,NM1 C C COMPUTE DETERMINANT C C***FIRST EXECUTABLE STATEMENT SGEDI IF (JOB/10 .EQ. 0) GO TO 70 DET(1) = 1.0E0 DET(2) = 0.0E0 TEN = 10.0E0 DO 50 I = 1, N IF (IPVT(I) .NE. I) DET(1) = -DET(1) DET(1) = A(I,I)*DET(1) C ...EXIT IF (DET(1) .EQ. 0.0E0) GO TO 60 10 IF (ABS(DET(1)) .GE. 1.0E0) GO TO 20 DET(1) = TEN*DET(1) DET(2) = DET(2) - 1.0E0 GO TO 10 20 CONTINUE 30 IF (ABS(DET(1)) .LT. TEN) GO TO 40 DET(1) = DET(1)/TEN DET(2) = DET(2) + 1.0E0 GO TO 30 40 CONTINUE 50 CONTINUE 60 CONTINUE 70 CONTINUE C C COMPUTE INVERSE(U) C IF (MOD(JOB,10) .EQ. 0) GO TO 150 DO 100 K = 1, N A(K,K) = 1.0E0/A(K,K) T = -A(K,K) CALL SSCAL(K-1,T,A(1,K),1) KP1 = K + 1 IF (N .LT. KP1) GO TO 90 DO 80 J = KP1, N T = A(K,J) A(K,J) = 0.0E0 CALL SAXPY(K,T,A(1,K),1,A(1,J),1) 80 CONTINUE 90 CONTINUE 100 CONTINUE C C FORM INVERSE(U)*INVERSE(L) C NM1 = N - 1 IF (NM1 .LT. 1) GO TO 140 DO 130 KB = 1, NM1 K = N - KB KP1 = K + 1 DO 110 I = KP1, N WORK(I) = A(I,K) A(I,K) = 0.0E0 110 CONTINUE DO 120 J = KP1, N T = WORK(J) CALL SAXPY(N,T,A(1,J),1,A(1,K),1) 120 CONTINUE L = IPVT(K) IF (L .NE. K) CALL SSWAP(N,A(1,K),1,A(1,L),1) 130 CONTINUE 140 CONTINUE 150 CONTINUE RETURN END SUBROUTINE SGEEV(A,LDA,N,E,V,LDV,WORK,JOB,INFO) C***BEGIN PROLOGUE SGEEV C***DATE WRITTEN 800808 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D4A2 C***KEYWORDS EIGENVALUE,EIGENVECTOR,GENERAL MATRIX,REAL C***AUTHOR KAHANER, D. K., (NBS) C MOLER, C. B., (U. OF NEW MEXICO) C STEWART, G. W., (U. OF MARYLAND) C***PURPOSE To compute the eigenvalues and, optionally, the eigen- C vectors of a GENERAL real matrix. C***DESCRIPTION C C LICEPACK. This version dated 08/08/80. C David Kahaner, Cleve Moler, G. W. Stewart, C N.B.S. U.N.M. N.B.S./U.MD. C C Abstract C SGEEV computes the eigenvalues and, optionally, C the eigenvectors of a general real matrix. C C Call Sequence Parameters- C (The values of parameters marked with * (star) will be changed C by SGEEV.) C C A* REAL(LDA,N) C real nonsymmetric input matrix. C C LDA INTEGER C set by the user to C the leading dimension of the real array A. C C N INTEGER C set by the user to C the order of the matrices A and V, and C the number of elements in E. C C E* COMPLEX(N) C on return from SGEEV, E contains the eigenvalues of A. C See also INFO below. C C V* COMPLEX(LDV,N) C on return from SGEEV, if the user has set JOB C = 0 V is not referenced. C = nonzero the N eigenvectors of A are stored in the C first N columns of V. See also INFO below. C (Note that if the input matrix A is nearly degenerate, C V may be badly conditioned, i.e., may have nearly C dependent columns.) C C LDV INTEGER C set by the user to C the leading dimension of the array V if JOB is also C set nonzero. In that case, N must be .LE. LDV. C If JOB is set to zero, LDV is not referenced. C C WORK* REAL(2N) C temporary storage vector. Contents changed by SGEEV. C C JOB INTEGER C set by the user to C = 0 eigenvalues only to be calculated by SGEEV. C Neither V nor LDV is referenced. C = nonzero eigenvalues and vectors to be calculated. C In this case, A & V must be distinct arrays. C Also, if LDA .GT. LDV, SGEEV changes all the C elements of A thru column N. If LDA < LDV, C SGEEV changes all the elements of V through C column N. If LDA = LDV, only A(I,J) and V(I, C J) for I,J = 1,...,N are changed by SGEEV. C C INFO* INTEGER C on return from SGEEV the value of INFO is C = 0 normal return, calculation successful. C = K if the eigenvalue iteration fails to converge, C eigenvalues K+1 through N are correct, but C no eigenvectors were computed even if they were C requested (JOB nonzero). C C Error Messages C No. 1 recoverable N is greater than LDA C No. 2 recoverable N is less than one. C No. 3 recoverable JOB is nonzero and N is greater than LDV C No. 4 warning LDA > LDV, elements of A other than the C N by N input elements have been changed. C No. 5 warning LDA < LDV, elements of V other than the C N x N output elements have been changed. C C C Subroutines used C C EISPACK- BALANC,BALBAK, ORTHES, ORTRAN, HQR, HQR2 C BLAS- SCOPY, SCOPYM C SLATEC- XERROR C***REFERENCES (NONE) C***ROUTINES CALLED BALANC,BALBAK,HQR,HQR2,ORTHES,ORTRAN,SCOPY,SCOPYM, C XERROR C***END PROLOGUE SGEEV CCCCC INTEGER I,IHI,ILO,INFO,J,JB,JOB,K,KM,KP,L,LDA,LDV, INTEGER IHI,ILO,INFO,J,JOB,K,L,LDA,LDV, 1 MDIM,MIN0,N REAL A(*),E(*),WORK(*),V(*) C***FIRST EXECUTABLE STATEMENT SGEEV IF(N .GT. LDA)THEN CCCCC WRITE(*,*) 'FROM SGEEV: N > LDA' INFO = -1 RETURN ENDIF IF(N .LT. 1) THEN CCCCC WRITE(*,*) 'FROM SGEEV: N < 1' INFO = -1 RETURN END IF IF(N .EQ. 1 .AND. JOB .EQ. 0) GO TO 35 MDIM = LDA IF(JOB .EQ. 0) GO TO 5 IF(N .GT. LDV)THEN CCCCC WRITE(*,*) 'FROM SGEEV: JOB NON-ZERO AND N > LDV' INFO = -1 RETURN ENDIF IF(N .EQ. 1) GO TO 35 C C REARRANGE A IF NECESSARY WHEN LDA.GT.LDV AND JOB .NE.0 C MDIM = MIN0(LDA,LDV) IF(LDA.LT.LDV) THEN CCCCC WRITE(*,*) 'FROM SGEEV: LDA < LDV, ELEMENTS OF V OTHER' CCCCC WRITE(*,*) 'THAN THE N BY N OUTPUT ELEMENTS HAVE BEEN CHANGED.' ENDIF IF(LDA.LE.LDV) GO TO 5 CCCCC WRITE(*,*) 'FROM SGEEV: LDA > LDV, ELEMENTS OF A OTHER THAN THE' CCCCC WRITE(*,*) 'N BY N INPUT ELEMENTS HAVE BEEN CHANGED.' L = N - 1 DO 4 J=1,L M = 1+J*LDV K = 1+J*LDA CALL SCOPY(N,A(K),1,A(M),1) 4 CONTINUE 5 CONTINUE C C SCALE AND ORTHOGONAL REDUCTION TO HESSENBERG. C CALL BALANC(MDIM,N,A,ILO,IHI,WORK(1)) CALL ORTHES(MDIM,N,ILO,IHI,A,WORK(N+1)) IF(JOB .NE. 0) GO TO 10 C C EIGENVALUES ONLY C CALL HQR(LDA,N,ILO,IHI,A,E(1),E(N+1),INFO) GO TO 30 C C EIGENVALUES AND EIGENVECTORS. C 10 CALL ORTRAN(MDIM,N,ILO,IHI,A,WORK(N+1),V) CALL HQR2(MDIM,N,ILO,IHI,A,E(1),E(N+1),V,INFO) IF (INFO .NE. 0) GO TO 30 CALL BALBAK(MDIM,N,ILO,IHI,WORK(1),N,V) C C CONVERT EIGENVECTORS TO COMPLEX STORAGE. C CCCCC JULY 1993. FOR DATAPLOT PURPOSES, DO NOT CONVERT TO COMPLEX CCCCC FORMAT (I.E., ROWS 1 TO N CORRESPOND TO REAL PART, ROWS N+1 CCCCC TO 2*N CORRESPOND TO IMAGINARY PART). CNIST DO 20 JB = 1,N CNIST J=N+1-JB CNIST I=N+J CNIST K=(J-1)*MDIM+1 CNIST KP=K+MDIM CNIST KM=K-MDIM CNIST IF(E(I).GE.0.0E0) CALL SCOPY(N,V(K),1,WORK(1),2) CNIST IF(E(I).LT.0.0E0) CALL SCOPY(N,V(KM),1,WORK(1),2) CNIST IF(E(I).EQ.0.0E0) CALL SCOPY(N,0.0E0,0,WORK(2),2) CNIST IF(E(I).GT.0.0E0) CALL SCOPY(N,V(KP),1,WORK(2),2) CNIST IF(E(I).LT.0.0E0) CALL SCOPYM(N,V(K),1,WORK(2),2) CNIST L=2*(J-1)*LDV+1 CNIST CALL SCOPY(2*N,WORK(1),1,V(L),1) 20 CONTINUE C C CONVERT EIGENVALUES TO COMPLEX STORAGE. C CCCCC JULY 1993. FOR DATAPLOT PURPOSES, DO NOT CONVERT TO COMPLEX CCCCC FORMAT (I.E., ROWS 1 TO N CORRESPOND TO REAL PART, ROWS N+1 CCCCC TO 2*N CORRESPOND TO IMAGINARY PART). 30 CONTINUE CNIST CALL SCOPY(N,E(1),1,WORK(1),1) CNIST CALL SCOPY(N,E(N+1),1,E(2),2) CNIST CALL SCOPY(N,WORK(1),1,E(1),2) RETURN C C TAKE CARE OF N=1 CASE C 35 E(1) = A(1) E(2) = 0.E0 INFO = 0 IF(JOB .EQ. 0) RETURN V(1) = A(1) V(2) = 0.E0 RETURN END SUBROUTINE SGEFA(A,LDA,N,IPVT,INFO) C***BEGIN PROLOGUE SGEFA C***DATE WRITTEN 780814 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D2A1 C***KEYWORDS FACTOR,LINEAR ALGEBRA,LINPACK,MATRIX C***AUTHOR MOLER, C. B., (U. OF NEW MEXICO) C***PURPOSE Factors a real matrix by Gaussian elimination. C***DESCRIPTION C C SGEFA factors a real matrix by Gaussian elimination. C C SGEFA is usually called by SGECO, but it can be called C directly with a saving in time if RCOND is not needed. C (Time for SGECO) = (1 + 9/N)*(Time for SGEFA) . C C On Entry C C A REAL(LDA, N) C the matrix to be factored. C C LDA INTEGER C the leading dimension of the array A . C C N INTEGER C the order of the matrix A . C C On Return C C A an upper triangular matrix and the multipliers C which were used to obtain it. C The factorization can be written A = L*U , where C L is a product of permutation and unit lower C triangular matrices and U is upper triangular. C C IPVT INTEGER(N) C an integer vector of pivot indices. C C INFO INTEGER C = 0 normal value. C = K if U(K,K) .EQ. 0.0 . This is not an error C condition for this subroutine, but it does C indicate that SGESL or SGEDI will divide by zero C if called. Use RCOND in SGECO for a reliable C indication of singularity. C C LINPACK. This version dated 08/14/78 . C Cleve Moler, University of New Mexico, Argonne National Lab. C C Subroutines and Functions C C BLAS SAXPY,SSCAL,ISAMAX C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., C *LINPACK USERS GUIDE*, SIAM, 1979. C***ROUTINES CALLED ISAMAX,SAXPY,SSCAL C***END PROLOGUE SGEFA INTEGER LDA,N,IPVT(*),INFO REAL A(LDA,*) C REAL T INTEGER ISAMAX,J,K,KP1,L,NM1 C C GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING C C***FIRST EXECUTABLE STATEMENT SGEFA INFO = 0 NM1 = N - 1 IF (NM1 .LT. 1) GO TO 70 DO 60 K = 1, NM1 KP1 = K + 1 C C FIND L = PIVOT INDEX C L = ISAMAX(N-K+1,A(K,K),1) + K - 1 IPVT(K) = L C C ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED C IF (A(L,K) .EQ. 0.0E0) GO TO 40 C C INTERCHANGE IF NECESSARY C IF (L .EQ. K) GO TO 10 T = A(L,K) A(L,K) = A(K,K) A(K,K) = T 10 CONTINUE C C COMPUTE MULTIPLIERS C T = -1.0E0/A(K,K) CALL SSCAL(N-K,T,A(K+1,K),1) C C ROW ELIMINATION WITH COLUMN INDEXING C DO 30 J = KP1, N T = A(L,J) IF (L .EQ. K) GO TO 20 A(L,J) = A(K,J) A(K,J) = T 20 CONTINUE CALL SAXPY(N-K,T,A(K+1,K),1,A(K+1,J),1) 30 CONTINUE GO TO 50 40 CONTINUE INFO = K 50 CONTINUE 60 CONTINUE 70 CONTINUE IPVT(N) = N IF (A(N,N) .EQ. 0.0E0) INFO = N RETURN END SUBROUTINE SGESL(A,LDA,N,IPVT,B,JOB) C***BEGIN PROLOGUE SGESL C***DATE WRITTEN 780814 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D2A1 C***KEYWORDS LINEAR ALGEBRA,LINPACK,MATRIX,SOLVE C***AUTHOR MOLER, C. B., (U. OF NEW MEXICO) C***PURPOSE Solves the real system A*X=B or TRANS(A)*X=B C using the factors of SGECO or SGEFA C***DESCRIPTION C C SGESL solves the real system C A * X = B or TRANS(A) * X = B C using the factors computed by SGECO or SGEFA. C C On Entry C C A REAL(LDA, N) C the output from SGECO or SGEFA. C C LDA INTEGER C the leading dimension of the array A . C C N INTEGER C the order of the matrix A . C C IPVT INTEGER(N) C the pivot vector from SGECO or SGEFA. C C B REAL(N) C the right hand side vector. C C JOB INTEGER C = 0 to solve A*X = B , C = nonzero to solve TRANS(A)*X = B where C TRANS(A) is the transpose. C C On Return C C B the solution vector X . C C Error Condition C C A division by zero will occur if the input factor contains a C zero on the diagonal. Technically, this indicates singularity, C but it is often caused by improper arguments or improper C setting of LDA . It will not occur if the subroutines are C called correctly and if SGECO has set RCOND .GT. 0.0 C or SGEFA has set INFO .EQ. 0 . C C To compute INVERSE(A) * C where C is a matrix C with P columns C CALL SGECO(A,LDA,N,IPVT,RCOND,Z) C IF (RCOND is too small) GO TO ... C DO 10 J = 1, P C CALL SGESL(A,LDA,N,IPVT,C(1,J),0) C 10 CONTINUE C C LINPACK. This version dated 08/14/78 . C Cleve Moler, University of New Mexico, Argonne National Lab. C C Subroutines and Functions C C BLAS SAXPY,SDOT C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., C *LINPACK USERS GUIDE*, SIAM, 1979. C***ROUTINES CALLED SAXPY,SDOT C***END PROLOGUE SGESL INTEGER LDA,N,IPVT(*),JOB REAL A(LDA,*),B(*) C REAL SDOT,T INTEGER K,KB,L,NM1 C***FIRST EXECUTABLE STATEMENT SGESL NM1 = N - 1 IF (JOB .NE. 0) GO TO 50 C C JOB = 0 , SOLVE A * X = B C FIRST SOLVE L*Y = B C IF (NM1 .LT. 1) GO TO 30 DO 20 K = 1, NM1 L = IPVT(K) T = B(L) IF (L .EQ. K) GO TO 10 B(L) = B(K) B(K) = T 10 CONTINUE CALL SAXPY(N-K,T,A(K+1,K),1,B(K+1),1) 20 CONTINUE 30 CONTINUE C C NOW SOLVE U*X = Y C DO 40 KB = 1, N K = N + 1 - KB B(K) = B(K)/A(K,K) T = -B(K) CALL SAXPY(K-1,T,A(1,K),1,B(1),1) 40 CONTINUE GO TO 100 50 CONTINUE C C JOB = NONZERO, SOLVE TRANS(A) * X = B C FIRST SOLVE TRANS(U)*Y = B C DO 60 K = 1, N T = SDOT(K-1,A(1,K),1,B(1),1) B(K) = (B(K) - T)/A(K,K) 60 CONTINUE C C NOW SOLVE TRANS(L)*X = Y C IF (NM1 .LT. 1) GO TO 90 DO 80 KB = 1, NM1 K = N - KB B(K) = B(K) + SDOT(N-K,A(K+1,K),1,B(K+1),1) L = IPVT(K) IF (L .EQ. K) GO TO 70 T = B(L) B(L) = B(K) B(K) = T 70 CONTINUE 80 CONTINUE 90 CONTINUE 100 CONTINUE RETURN END SUBROUTINE SGEMM (TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, $ BETA, C, LDC, $ IERROR) *DECK SGEMM C***BEGIN PROLOGUE SGEMM C***PURPOSE Multiply a real general matrix by a real general matrix. C***LIBRARY SLATEC (BLAS) C***CATEGORY D1B6 C***TYPE SINGLE PRECISION (SGEMM-S, DGEMM-D, CGEMM-C) C***KEYWORDS LEVEL 3 BLAS, LINEAR ALGEBRA C***AUTHOR Dongarra, J., (ANL) C Duff, I., (AERE) C Du Croz, J., (NAG) C Hammarling, S. (NAG) C***DESCRIPTION C C SGEMM performs one of the matrix-matrix operations C C C := alpha*op( A )*op( B ) + beta*C, C C where op( X ) is one of C C op( X ) = X or op( X ) = X', C C alpha and beta are scalars, and A, B and C are matrices, with op( A ) C an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. C C Parameters C ========== C C TRANSA - CHARACTER*1. C On entry, TRANSA specifies the form of op( A ) to be used in C the matrix multiplication as follows: C C TRANSA = 'N' or 'n', op( A ) = A. C C TRANSA = 'T' or 't', op( A ) = A'. C C TRANSA = 'C' or 'c', op( A ) = A'. C C Unchanged on exit. C C TRANSB - CHARACTER*1. C On entry, TRANSB specifies the form of op( B ) to be used in C the matrix multiplication as follows: C C TRANSB = 'N' or 'n', op( B ) = B. C C TRANSB = 'T' or 't', op( B ) = B'. C C TRANSB = 'C' or 'c', op( B ) = B'. C C Unchanged on exit. C C M - INTEGER. C On entry, M specifies the number of rows of the matrix C op( A ) and of the matrix C. M must be at least zero. C Unchanged on exit. C C N - INTEGER. C On entry, N specifies the number of columns of the matrix C op( B ) and the number of columns of the matrix C. N must be C at least zero. C Unchanged on exit. C C K - INTEGER. C On entry, K specifies the number of columns of the matrix C op( A ) and the number of rows of the matrix op( B ). K must C be at least zero. C Unchanged on exit. C C ALPHA - REAL . C On entry, ALPHA specifies the scalar alpha. C Unchanged on exit. C C A - REAL array of DIMENSION ( LDA, ka ), where ka is C k when TRANSA = 'N' or 'n', and is m otherwise. C Before entry with TRANSA = 'N' or 'n', the leading m by k C part of the array A must contain the matrix A, otherwise C the leading k by m part of the array A must contain the C matrix A. C Unchanged on exit. C C LDA - INTEGER. C On entry, LDA specifies the first dimension of A as declared C in the calling (sub) program. When TRANSA = 'N' or 'n' then C LDA must be at least max( 1, m ), otherwise LDA must be at C least max( 1, k ). C Unchanged on exit. C C B - REAL array of DIMENSION ( LDB, kb ), where kb is C n when TRANSB = 'N' or 'n', and is k otherwise. C Before entry with TRANSB = 'N' or 'n', the leading k by n C part of the array B must contain the matrix B, otherwise C the leading n by k part of the array B must contain the C matrix B. C Unchanged on exit. C C LDB - INTEGER. C On entry, LDB specifies the first dimension of B as declared C in the calling (sub) program. When TRANSB = 'N' or 'n' then C LDB must be at least max( 1, k ), otherwise LDB must be at C least max( 1, n ). C Unchanged on exit. C C BETA - REAL . C On entry, BETA specifies the scalar beta. When BETA is C supplied as zero then C need not be set on input. C Unchanged on exit. C C C - REAL array of DIMENSION ( LDC, n ). C Before entry, the leading m by n part of the array C must C contain the matrix C, except when beta is zero, in which C case C need not be set on entry. C On exit, the array C is overwritten by the m by n matrix C ( alpha*op( A )*op( B ) + beta*C ). C C LDC - INTEGER. C On entry, LDC specifies the first dimension of C as declared C in the calling (sub) program. LDC must be at least C max( 1, m ). C Unchanged on exit. C C***REFERENCES Dongarra, J., Du Croz, J., Duff, I., and Hammarling, S. C A set of level 3 basic linear algebra subprograms. C ACM TOMS, Vol. 16, No. 1, pp. 1-17, March 1990. C***ROUTINES CALLED LSAME, XERBLA C***REVISION HISTORY (YYMMDD) C 890208 DATE WRITTEN C 910605 Modified to meet SLATEC prologue standards. Only comment C lines were modified. (BKS) C***END PROLOGUE SGEMM C .. Scalar Arguments .. CHARACTER*1 TRANSA, TRANSB INTEGER M, N, K, LDA, LDB, LDC REAL ALPHA, BETA C .. Array Arguments .. REAL A( LDA, * ), B( LDB, * ), C( LDC, * ) C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. CCCCC EXTERNAL XERBLA C .. Intrinsic Functions .. INTRINSIC MAX C .. Local Scalars .. LOGICAL NOTA, NOTB INTEGER I, INFO, J, L, NCOLA, NROWA, NROWB REAL TEMP C .. Parameters .. REAL ONE , ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) C CHARACTER*4 IERROR C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C***FIRST EXECUTABLE STATEMENT SGEMM C C Set NOTA and NOTB as true if A and B respectively are not C transposed and set NROWA, NCOLA and NROWB as the number of rows C and columns of A and the number of rows of B respectively. C IERROR='NO' C NOTA = LSAME( TRANSA, 'N' ) NOTB = LSAME( TRANSB, 'N' ) IF( NOTA )THEN NROWA = M NCOLA = K ELSE NROWA = K NCOLA = M END IF IF( NOTB )THEN NROWB = K ELSE NROWB = N END IF C C Test the input parameters. C INFO = 0 IF( ( .NOT.NOTA ).AND. $ ( .NOT.LSAME( TRANSA, 'C' ) ).AND. $ ( .NOT.LSAME( TRANSA, 'T' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.NOTB ).AND. $ ( .NOT.LSAME( TRANSB, 'C' ) ).AND. $ ( .NOT.LSAME( TRANSB, 'T' ) ) )THEN INFO = 2 ELSE IF( M .LT.0 )THEN INFO = 3 ELSE IF( N .LT.0 )THEN INFO = 4 ELSE IF( K .LT.0 )THEN INFO = 5 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 8 ELSE IF( LDB.LT.MAX( 1, NROWB ) )THEN INFO = 10 ELSE IF( LDC.LT.MAX( 1, M ) )THEN INFO = 13 END IF IF( INFO.NE.0 )THEN CCCCC CALL XERBLA( 'SGEMM ', INFO ) WRITE(ICOUT,1001) CALL DPWRST('XXX','BUG') IERROR='YES' 1001 FORMAT('***** INTERNAL ERROR FROM SGEMM, INVALID', 1' ARGUMENTS.') RETURN END IF C C Quick return if possible. C IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) $ RETURN C C And if alpha.eq.zero. C IF( ALPHA.EQ.ZERO )THEN IF( BETA.EQ.ZERO )THEN DO 20, J = 1, N DO 10, I = 1, M C( I, J ) = ZERO 10 CONTINUE 20 CONTINUE ELSE DO 40, J = 1, N DO 30, I = 1, M C( I, J ) = BETA*C( I, J ) 30 CONTINUE 40 CONTINUE END IF RETURN END IF C C Start the operations. C IF( NOTB )THEN IF( NOTA )THEN C C Form C := alpha*A*B + beta*C. C DO 90, J = 1, N IF( BETA.EQ.ZERO )THEN DO 50, I = 1, M C( I, J ) = ZERO 50 CONTINUE ELSE IF( BETA.NE.ONE )THEN DO 60, I = 1, M C( I, J ) = BETA*C( I, J ) 60 CONTINUE END IF DO 80, L = 1, K IF( B( L, J ).NE.ZERO )THEN TEMP = ALPHA*B( L, J ) DO 70, I = 1, M C( I, J ) = C( I, J ) + TEMP*A( I, L ) 70 CONTINUE END IF 80 CONTINUE 90 CONTINUE ELSE C C Form C := alpha*A'*B + beta*C C DO 120, J = 1, N DO 110, I = 1, M TEMP = ZERO DO 100, L = 1, K TEMP = TEMP + A( L, I )*B( L, J ) 100 CONTINUE IF( BETA.EQ.ZERO )THEN C( I, J ) = ALPHA*TEMP ELSE C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) END IF 110 CONTINUE 120 CONTINUE END IF ELSE IF( NOTA )THEN C C Form C := alpha*A*B' + beta*C C DO 170, J = 1, N IF( BETA.EQ.ZERO )THEN DO 130, I = 1, M C( I, J ) = ZERO 130 CONTINUE ELSE IF( BETA.NE.ONE )THEN DO 140, I = 1, M C( I, J ) = BETA*C( I, J ) 140 CONTINUE END IF DO 160, L = 1, K IF( B( J, L ).NE.ZERO )THEN TEMP = ALPHA*B( J, L ) DO 150, I = 1, M C( I, J ) = C( I, J ) + TEMP*A( I, L ) 150 CONTINUE END IF 160 CONTINUE 170 CONTINUE ELSE C C Form C := alpha*A'*B' + beta*C C DO 200, J = 1, N DO 190, I = 1, M TEMP = ZERO DO 180, L = 1, K TEMP = TEMP + A( L, I )*B( J, L ) 180 CONTINUE IF( BETA.EQ.ZERO )THEN C( I, J ) = ALPHA*TEMP ELSE C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) END IF 190 CONTINUE 200 CONTINUE END IF END IF C RETURN C C End of SGEMM . C END SUBROUTINE SGTSL(N,C,D,E,B,INFO) C***BEGIN PROLOGUE SGTSL C***DATE WRITTEN 780814 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D2A2A C***KEYWORDS LINEAR ALGEBRA,LINPACK,MATRIX,SOLVE,TRIDIAGONAL C***AUTHOR DONGARRA, J., (ANL) C***PURPOSE Solves the system A*X=B where a is TRIDIAGONAL C***DESCRIPTION C C SGTSL given a general tridiagonal matrix and a right hand C side will find the solution. C C On Entry C C N INTEGER C is the order of the tridiagonal matrix. C C C REAL(N) C is the subdiagonal of the tridiagonal matrix. C C(2) through C(N) should contain the subdiagonal. C On output, C is destroyed. C C D REAL(N) C is the diagonal of the tridiagonal matrix. C On output, D is destroyed. C C E REAL(N) C is the superdiagonal of the tridiagonal matrix. C E(1) through E(N-1) should contain the superdiagonal. C On output, E is destroyed. C C B REAL(N) C is the right hand side vector. C C On Return C C B is the solution vector. C C INFO INTEGER C = 0 normal value. C = K if the K-th element of the diagonal becomes C exactly zero. The subroutine returns when C this is detected. C C LINPACK. This version dated 08/14/78 . C Jack Dongarra, Argonne National Laboratory. C C No externals C Fortran ABS C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., C *LINPACK USERS GUIDE*, SIAM, 1979. C***ROUTINES CALLED (NONE) C***END PROLOGUE SGTSL INTEGER N,INFO REAL C(1),D(1),E(1),B(1) C INTEGER K,KB,KP1,NM1,NM2 REAL T C BEGIN BLOCK PERMITTING ...EXITS TO 100 C C***FIRST EXECUTABLE STATEMENT SGTSL INFO = 0 C(1) = D(1) NM1 = N - 1 IF (NM1 .LT. 1) GO TO 40 D(1) = E(1) E(1) = 0.0E0 E(N) = 0.0E0 C DO 30 K = 1, NM1 KP1 = K + 1 C C FIND THE LARGEST OF THE TWO ROWS C IF (ABS(C(KP1)) .LT. ABS(C(K))) GO TO 10 C C INTERCHANGE ROW C T = C(KP1) C(KP1) = C(K) C(K) = T T = D(KP1) D(KP1) = D(K) D(K) = T T = E(KP1) E(KP1) = E(K) E(K) = T T = B(KP1) B(KP1) = B(K) B(K) = T 10 CONTINUE C C ZERO ELEMENTS C IF (C(K) .NE. 0.0E0) GO TO 20 INFO = K C ............EXIT GO TO 100 20 CONTINUE T = -C(KP1)/C(K) C(KP1) = D(KP1) + T*D(K) D(KP1) = E(KP1) + T*E(K) E(KP1) = 0.0E0 B(KP1) = B(KP1) + T*B(K) 30 CONTINUE 40 CONTINUE IF (C(N) .NE. 0.0E0) GO TO 50 INFO = N GO TO 90 50 CONTINUE C C BACK SOLVE C NM2 = N - 2 B(N) = B(N)/C(N) IF (N .EQ. 1) GO TO 80 B(NM1) = (B(NM1) - D(NM1)*B(N))/C(NM1) IF (NM2 .LT. 1) GO TO 70 DO 60 KB = 1, NM2 K = NM2 - KB + 1 B(K) = (B(K) - D(K)*B(K+1) - E(K)*B(K+2))/C(K) 60 CONTINUE 70 CONTINUE 80 CONTINUE 90 CONTINUE 100 CONTINUE C RETURN END SUBROUTINE SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1IBUGO2,IERROR) C C PURPOSE--SHIFT TO THE LEFT (ONLY) C THE IHARG,IHARG2,IARG,ARG, AND IARGT VECTORS C AND ADJUST THE VALUE OF NUMARG ACCORDINGLY. C THE ADJUSTMENT RESULTS IN C ALL ELEMENTS BEING SHIFTED C ISHIFT STEPS TO THE LEFT. 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--82/7 C ORIGINAL VERSION--APRIL 1978. C UPDATED --JUNE 1978. C UPDATED --JANUARY 1981. C UPDATED --JULY 1981. C UPDATED --NOVEMBER 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IHARG2 CHARACTER*4 IARGT C CHARACTER*4 IBUGO2 CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION IHARG(*) DIMENSION IHARG2(*) DIMENSION IARG(*) DIMENSION ARG(*) DIMENSION IARGT(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT 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(IBUGO2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF SHIFTL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ISHIFT,NUMARG 52 FORMAT('ISHIFT,NUMARG = ',2I8) CALL DPWRST('XXX','BUG ') DO55I=1,NUMARG WRITE(ICOUT,56)I,IHARG(I),IHARG2(I),IARG(I),ARG(I),IARGT(I) 56 FORMAT('I,IHARG(I),IHARG2(I),IARG(I),ARG(I),IARGT(I) = ', 1I8,2X,A4,A4,I8,E15.7,2X,A4) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C IMIN=1 IMAX=NUMARG-ISHIFT DO100I=IMIN,IMAX IPSHIF=I+ISHIFT IHARG(I)=IHARG(IPSHIF) IHARG2(I)=IHARG2(IPSHIF) IARG(I)=IARG(IPSHIF) ARG(I)=ARG(IPSHIF) IARGT(I)=IARGT(IPSHIF) 100 CONTINUE NUMARG=IMAX GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGO2.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF SHIFTL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)ISHIFT,NUMARG 9012 FORMAT('ISHIFT,NUMARG = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IMIN,IMAX 9013 FORMAT('IMIN,IMAX = ',2I8) CALL DPWRST('XXX','BUG ') DO9015I=1,NUMARG WRITE(ICOUT,9016)I,IHARG(I),IHARG2(I),IARG(I),ARG(I),IARGT(I) 9016 FORMAT('I,IHARG(I),IHARG2(I),IARG(I),ARG(I),IARGT(I) = ', 1I8,2X,A4,A4,I8,E15.7,2X,A4) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG, 1IBUGO2,IERROR) C C PURPOSE--SHIFT TO THE RIGHT (ONLY) C THE IHARG,IHARG2,IARG,ARG, AND IARGT VECTORS C AND ADJUST THE VALUE OF NUMARG ACCORDINGLY. C THE ADJUSTMENT RESULTS IN C ALL ELEMENTS BEING SHIFTED C ISHIFT STEPS TO THE RIGHT. 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--82/7 C ORIGINAL VERSION--APRIL 1978. C UPDATED --JUNE 1978. C UPDATED --JANUARY 1981. C UPDATED --JULY 1981. C UPDATED --NOVEMBER 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IHARG2 CHARACTER*4 IARGT C CHARACTER*4 IBUGO2 CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION IHARG(*) DIMENSION IHARG2(*) DIMENSION IARG(*) DIMENSION ARG(*) DIMENSION IARGT(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT 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(IBUGO2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF SHIFTR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ISHIFT,NUMARG 52 FORMAT('ISHIFT,NUMARG = ',2I8) CALL DPWRST('XXX','BUG ') DO55I=1,NUMARG WRITE(ICOUT,56)I,IHARG(I),IHARG2(I),IARG(I),ARG(I),IARGT(I) 56 FORMAT('I,IHARG(I),IHARG2(I),IARG(I),ARG(I),IARGT(I) = ', 1I8,2X,A4,A4,I8,E15.7,2X,A4) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C IMIN=1+ISHIFT IMAX=NUMARG+ISHIFT DO100I=IMIN,IMAX IREV=IMAX-I+IMIN IREV2=IREV-ISHIFT IHARG(IREV)=IHARG(IREV2) IHARG2(IREV)=IHARG2(IREV2) IARG(IREV)=IARG(IREV2) ARG(IREV)=ARG(IREV2) IARGT(IREV)=IARGT(IREV2) 100 CONTINUE NUMARG=IMAX GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGO2.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF SHIFTR--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)ISHIFT,NUMARG 9012 FORMAT('ISHIFT,NUMARG = ',2I8) CALL DPWRST('XXX','BUG ') DO9015I=1,NUMARG WRITE(ICOUT,9016)I,IHARG(I),IHARG2(I),IARG(I),ARG(I),IARGT(I) 9016 FORMAT('I,IHARG(I),IHARG2(I),IARG(I),ARG(I),IARGT(I) = ', 1I8,2X,A4,A4,I8,E15.7,2X,A4) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE SICIEI(IC,X,SI,CI,CII,EI,EXNEI,SHI,CHI,CHII,IERR) C C APPENDIX C C IMPLEMENTING PROGRAM C LANGUAGE. AMERICAN NATIONAL STANDARD FORTRAN C DEFINITIONS. X, A REAL VARIABLE C SI(X) =INTEGRAL(SIN T/T)DT FROM 0 TO X C SI(-X)=-SI(X) C CI(X) =GAMMA+LN X+INTEGRAL((COS T-1)/T)DT FROM 0 TO X C CI(-X)=CI(X)-I PI C EI(X) =-P.V.INTEGRAL(EXP(-T)/T)DT FROM -X TO INFINITY C EXNEI(X)=EXP(-X)*EI(X) (X .GT. 0) C INTEGRAL(EXP(-T)/T) DT FROM X TO INFINITY, OFTEN C DENOTED BY -EI(-X)=E1(X). (SEE AUTOMATIC COMPUTING C METHODS FOR SPECIAL FUNCTIONS, PART II. THE EXPO- C NENTIAL INTEGRAL EN(X), J. OF RESEARCH NBS, 78B, C OCTOBER-DECEMBER 1974, PP. 199-216.) C SHI(X) =INTEGRAL(SINH T/T)DT FROM 0 TO X C SHI(-X)=-SHI(X) C CHI(X)=GAMMA+LN X+INTEGRAL((COSH T-1)/T)DT FROM 0 TO X C CHI(-X)=CHI(X)-I PI C GAMMA(EULER'S CONSTANT)=.5772156649... C SPECIAL CASES C X=0 C SI(0)=SHI(0)=0 C CI(0)=EI(0)=EXNEI(0)=CHI(0)=-INFINITY C =-MAX. MACH. VALUE (RINF) C LIMITING VALUES - X APPROACHES INFINITY C SI(X)=PI/2 C CI(X)=0 C EI(X)=SHI(X)=CHI(X)=INFINITY (RINF) C EXNEI(X)=0 C USAGE. CALL SICIEI (IC,X,SI,CI,CII,EI,EXNEI,SHI,CHI,CHII, C IERR) C FORMAL PARAMETERS C IC INTEGER TYPE INPUT C IC FUNCTIONS TO BE COMPUTED C 1 SI,CI C 2 EI,EXNEI C 3 EI,EXNEI,SHI,CHI C 4 SI,CI,EI,EXNEI,SHI,CHI C X REAL OR DOUBLE PRECISION TYPE INPUT C SI=SI(X) (SAME TYPE AS X) OUTPUT C CI+I CII=CI(X) '' OUTPUT C EI=EI(X) '' OUTPUT C EXNEI=EXP(-X)*EI(X) '' OUTPUT C SHI=SHI(X) '' OUTPUT C CHI+I CHII=CHI(X) '' OUTPUT C IERR INTEGER TYPE OUTPUT C IERR=0 X .GE. 0, NORMAL RETURN C IERR=1 X .LT. 0, ERROR RETURN IF C IC=2 C MODIFICATIONS. C THE CODE IS SET UP FOR DOUBLE PRECISION COMPUTATION C WITH DOUBLE PRECISION TYPE STATEMENTS C DOUBLE PRECISION FUNCTION REFERENCES AND,PARTICU- C LARLY,FOR THE UNIVAC 1108 WITH (SEE DEFINITIONS BELOW) C RINF APPROX. 2**1023,ULSC=2**56,NBM=60 AND OTHER C CONSTANTS IN DOUBLE PRECISION FORMAT TO 19 SIGNIFICANT C FIGURES. ALL ABOVE ITEMS MUST BE CHANGED FOR SINGLE C PRECISION COMPUTATIONS WITH DATA ADJUSTMENTS FOR OTHER C COMPUTERS. C AUXILIARY FUNCTIONS C VARIOUS FUNCTIONS ARE AVAILABLE TO GREATER ACCURACY C AT INTERMEDIATE POINTS IN THE SUBROUTINE,NAMELY, C SI-(PI/2)=IMAG. PART OF THE CONTINUED FRACTION C CI(EI AND CHI)-GAMMA-LN X=SUM OF SERIES C CAUTION - THE SUBROUTINE CANNOT READILY BE ADAPTED TO C COMPUTE THE FUNCTIONS FOR COMPLEX ARGUMENTS. C METHOD. T=ABS(X) C POWER SERIES T .LE. PSLSC(=2) FOR SI,CI C T .LE. AELL(=-LN(TOLER)) FOR EI,SHI,CHI C SI=SUMS(SGN(RK)*TM(RK)) IP=-1 RK=1,3,...,RKO C CI=SUMC(SGN(RK)*TM(RK)) IP=+1 RK=2,4,...,RKE C +EULER+XLOG C SHI=SUMOT(TM(RK)) IP=-1 RK=1,3,...,RKO C CHI=SUMET(TM(RK)) IP=+1 RK=2,4,...,RKE C +EULER+XLOG C EI=SUMOT+SUMET+EULER+XLOG (X .GT. 0) C SGN(1)=1 C SGN(RK+1)=-SGN(RK) RK=1,3,... C SGN(RK+1)=+SGN(RK) RK=2,4,... C TM(RK)=((T**RK)/(1*2...RK))/RK C =PTM(RK)/RK C PTM(1)=T C PTM(RK+1)=PTM(RK)*(T/(RK+1)) RK .GE. 1 C IF TM(RK)/SUM .LT. TOLER C RKE=RK WHERE SUM=ABS(SUMC) IC=1 OR 4 C SUM=SUMET IC=2 OR 3 C IC=4,X .GT. PSLSC C RKO=RK WHERE SUM=ABS(SUMS) IC=1 OR 4 C SUM=SUMOT IC=2 OR 3 C IC=4,X .GT. PSLSC C EXNEI= EI/EXP(T/2)/EXP(T/2) C =(EI/EXPHT)/EXPHT C CONTINUED FRACTION T .GT. PSLSC C -CI+I(SI-PI/2)=E1(IT) C =EXP(-IT)*(1 I/I (1+IT)- C 1**2 I/I (3+IT)- C 2**2 I/I (5+IT)-...) C =EXP(-IT)*II(AM(RM) I/I BM(RM)) C RM=1,2,...,RMF C AM(1)=1 C AM(RM)=-(RM-1)**2 RM .GT. 1 C BM(RM)=2*RM-1+IT=BMR+I BMI C =EXP(-IT)*(FM/GM) C =EXP(-IT)*(FMR+I FMI)/(GMR+I GMI) C =EXP(-IT)*F(RM) C =(COST-I SINT)*(FR+I FI) C -CI+I(SI-PI/2)=(FR*COST+FI*SINT)+ C I(FI*COST-FR*SINT) C IF RESQ(RM) .LE. TOLSQ(=TOLER**2) C OR RESQ(RM) .GE. RESQ(RM-1) C (RESQ .GE. RESQP) C RMF=RM WHERE C RESQ=(MOD(1-F(RM-1)/F(RM)))**2 C ASYMPTOTIC EXPANSION T .GT. AELL C EI=(EXNEI*EXPHT)*EXPHT C EXNEI=(1+SUME(TM(RK)))/T RK=1,2,...,RKF C SHI=CHI=EI/2 C TM(RK)=(1*2...RK)/(T**RK) C TM(0)=1 C TM(RK)=(RK/T)*TM(RK-1) RK .GE. 1 C IF TM(RK) .LT. TOLER (CONVERGENCE) RKF=RK OR C TM(RK) .GE. TM(RK-1)(DIVERGENCE) RKF=RK-1 C RANGE. C FOR SI(X),CI(X), ABS(X) .LT. ULSC(UPPER LIMIT FOR C SIN,COS ROUTINE) C X=APPROXIMATELY 2**21, NBM=27 C 2**56, NBM=60 C FOR EXP(-X)*EI(X), X .LE. RINF C FOR EI(X), X .LT. XMAXEI (APPROXIMATELY 92.5, NBC=8, C 715.6, NBC=11) C NBC=NUMBER OF BINARY DIGITS IN THE BIASED C CHARACTERISTIC OF A FLOATING POINT NUMBER C FOR SHI(X),CHI(X), ABS(X) .LT. XMAXHF C X=APPROXIMATELY 93.2, NBC=8 C 716.3, NBC=11 C ACCURACY. THE MAXIMUM RELATIVE ERROR, EXCEPT FOR REGIONS C IN THE IMMEDIATE NEIGHBORHOOD OF ZEROS,ON THE C UNIVAC 1108 IS 4.5(-7) FOR SINGLE PRECISION COM- C PUTATION AND 7.5(-17) FOR DOUBLE PRECISION COM- C PUTATION. C PRECISION. VARIABLE - BY SETTING THE DESIRED VALUE OF NBM C OR A PREDETERMINED VALUE OF TOLER C MAXIMUM UNIVAC 1108 TIME/SHARING EXECUTIVE SYSTEM C TIMING. NBM=27 NBM=60 C (SECONDS) .0093 .070 C STORAGE. 954 WORDS REQUIRED BY THE UNIVAC 1108 COMPILER C C C MACHINE DEPENDENT STATEMENTS C TYPE STATEMENTS C INCLUDE 'DPCOMC.INC' C DOUBLE PRECISION X,SI,CI,CII,EI,EXNEI,SHI,CHI,CHII DOUBLE PRECISION A,AELL,AM,AMIN,ASUMSC, 1 BMI,BMR,COST,EXPL,EXPHT, 2 FI,FIP,FMI,FMM1I,FMM1R,FMM2I,FMM2R,FMR,FR,FRP, 3 GMI,GMM1I,GMM1R,GMM2I,GMM2R,GMR, 4 PSLL,PSLSC,PTM,RE,RESQ,RESQP,RK,RM, 5 SCC,SFMI,SFMR,SGMI,SGMR,SGN, 6 SINT,SUMC,SUME,SUMEO,SUMET,SUMOT,SUMS,SUMSC, 7 T,TEMP,TEMPA,TEMPB,TM,TMAX,TMM1,TOLER,TOLSQ, 8 XLOG,XMAXEI,XMAXHF DOUBLE PRECISION RINF,ULSC,EULER,HALFPI,PI,ALOG2, 1 ZERO,ONE,TWO,FOUR DIMENSION A(4) EQUIVALENCE (FMR,A(1)), (FMI,A(2)), (GMR,A(3)), 1 (GMI,A(4)) C CONSTANTS DATA EULER/.5772156649015328606D0/ DATA HALFPI/1.570796326794896619D0/ DATA PI/3.141592653589793238D0/ DATA ALOG2/.6931471805599453094D0/ DATA ZERO,ONE,TWO,FOUR / 1 0.0D0,1.D0,2.D0,4.D0/ C RINF=MAXIMUM MACHINE VALUE C ULSC=MAXIMUM ARGUMENT FOR SIN,COS ROUTINE C APPROX. 2**(NBM-6) OR 10**(S-2) C (S=SIGNIFICANT FIGURES) C NBM=ACCURACY DESIRED OR THE C MAXIMUM NUMBER OF BINARY DIGITS IN THE C MANTISSA OF A FLOATING POINT NUMBER C TOLER=UPPER LIMIT FOR RELATIVE ERRORS C =2**(-NBM)=APPROX. 10**(-S) C TOLER PRECOMPUTED MAY BE INSERTED IN A DATA STATEMENT AND C THE NBM DATA STATEMENT ELIMINATED CCCCC DATA RINF/.8988465674311579538D308 / CCCCC DATA ULSC/.72057594037927936D17/ CCCCC DATA NBM / 60 / C RINF=D1MACH(2) NBM=I1MACH(14) ULSC=TWO**(NBM-6) TOLER=TWO**(-NBM) C C NOTE - ARGUMENT CHECKS PRECEDING FUNCTION REFERENCES C NECESSITATE ADDITIONAL MACHINE DEPENDENT STATEMENTS 0 C IN THE STATEMENT NUMBER RANGE 140-150 C INITIALIZATION OF OUTPUT FUNCTIONS SI=RINF CI=RINF CII=RINF EI=ZERO EXNEI=RINF SHI=ZERO CHI=ZERO CHII=RINF C VALIDITY CHECK ON INPUT PARAMETERS C INDICATOR CHECK C SET IND=IC C CHANGE IND=4 IF IC .LT. 1 OR .GT. 4 IND=IC IF (IND .LT. 1) GO TO 10 IF (IND .GT. 4) GO TO 10 GO TO 20 10 IND=4 C ARGUMENT CHECK C X .GE. 0 IERR=0 C X .LT. 0 IERR=1 C (ERROR RETURN IF IC=2) 20 IERR=0 T=X 30 IF (T) 40,50,90 40 T=-T IF (IND .EQ. 1) GO TO 30 IERR=1 IF (IND .NE. 2) GO TO 30 IF (X .LT. ZERO) RETURN C SPECIAL CASES C X=0 50 IF (IND-2) 80,70,60 60 SHI=ZERO CHI=-RINF CHII=ZERO 70 EI=-RINF EXNEI=-RINF IF (IND .NE. 4) RETURN 80 SI=ZERO CI=-RINF CII=ZERO RETURN 90 IF (T .LT. ULSC) GO TO 140 C ABS(X) .GE. ULSC IF (IND-2) 130,110,100 100 SHI=RINF CHI=RINF CHII=ZERO IF (IERR .EQ. 1) GO TO 120 110 EI=RINF EXNEI=(ONE+(ONE/T))/T 120 IF (IND .NE. 4) GO TO 1000 130 SI=HALFPI CI=ZERO CII=ZERO GO TO 1000 C EVALUATIONS FOR ABS(X)(=T) .GT. 0 AND .LT. ULSC C ADDITIONAL MACHINE DEPENDENT STATEMENTS C FUNCTION REFERENCES C CONTROL VARIABLES 140 XLOG=DLOG(T) SINT=DSIN(T) COST=DCOS(T) EXPL =DLOG(RINF) XMAXEI=EXPL+DLOG(EXPL+DLOG(EXPL)) -ONE/EXPL XMAXHF=XMAXEI+ALOG2 AELL=-DLOG(TOLER) AMIN=ONE/RINF PSLL=TWO*DSQRT(AMIN) PSLSC=TWO C EXPONENTIAL FUNCTION DETERMINATION IF (T .LE. TOLER) GO TO 150 IF (T .GE. XMAXHF) GO TO 160 EXPHT=DEXP(T/TWO) GO TO 170 150 EXPHT=ONE GO TO 170 160 EXPHT=RINF C METHOD SELECTION 170 IF (T .LE. PSLSC) GO TO 200 IF (IND .EQ. 1) GO TO 500 IF (IND .EQ. 4) GO TO 500 180 IF (T .GT. AELL) GO TO 800 GO TO 230 C INDICATOR TO COMPUTE EI,SHI,CHI 190 IF (IND .EQ. 1) GO TO 1000 IND=3 GO TO 180 C METHOD --- POWER SERIES C SI(X),CI(X), T .LE. PSLSC C EI(X),SHI(X),CHI(X), T .LE. AELL C LIMITING VALUES, T NEAR ZERO 200 IF (T .GT. PSLL) GO TO 210 SUMC=ZERO SUMET=ZERO SUMS=T SUMOT=T GO TO 360 C INITIALIZATION FOR SI,CI 210 IF (IND .NE. 1) GO TO 230 220 SUMS=ZERO SUMC=ZERO SUMSC=ZERO SGN=ONE GO TO 240 C INITIALIZATION FOR SHI,CHI(AND EI) 230 SUMOT=ZERO SUMET=ZERO SUMEO=ZERO IF (IND .EQ. 4) GO TO 220 C IP - INDICATOR FOR ODD OR C EVEN TERMS 240 IP=-1 RK=ONE PTM=T C COMPUTATION OF (T**K)/(1*2...K)/K 250 TM=PTM/RK C SUMMATION FOR SI(CI) IF (IND .NE. 1) GO TO 310 260 SUMSC=SGN*TM+SUMSC C RELATIVE ERROR FOR SI(CI) C PARTIAL SUM OF ALTERNATING ODD(EVEN) TERMS MAY EQUAL ZERO ASUMSC=SUMSC 270 IF (ASUMSC) 280,300,290 280 ASUMSC=-ASUMSC GO TO 270 290 RE=TM/ASUMSC GO TO 320 300 RE=RINF GO TO 320 C SUMMATION FOR SHI(CHI)(AND EI) 310 SUMEO=TM+SUMEO IF (IND .EQ. 4) GO TO 260 C RELATIVE ERROR FOR SHI(CHI) RE=TM/SUMEO C SIGN CHANGE AND SELECTION C OF SUMS OF ODD(EVEN) TERMS 320 IF (IP .EQ. 1) GO TO 330 SGN=-SGN SUMS=SUMSC SUMSC=SUMC SUMOT=SUMEO SUMEO=SUMET GO TO 340 330 SUMC=SUMSC SUMSC=SUMS SUMET=SUMEO SUMEO=SUMOT C RELATIVE ERROR CHECK 340 IF (RE .LT. TOLER) GO TO 360 C ADDITIONAL TERMS RK=RK+ONE C UNDERFLOW TEST C UNDERFLOWS AFFECTING ACCURACY ARE AVOIDED. ALL OTHER C UNDERFLOWS ARE ASSUMED TO BE SET EQUAL TO ZERO IF (T .GT. PSLSC) GO TO 350 IF (PTM .LE. (AMIN*RK*RK)/T ) GO TO 360 350 PTM=(T/RK)*PTM IP=-IP GO TO 250 C SI,CI EVALUATION 360 IF (IND .NE. 1) GO TO 380 370 SI=SUMS CI=(SUMC+XLOG)+EULER CII=ZERO GO TO 1000 C EI EVALUATION 380 IF (X .LE. ZERO) GO TO 390 EI=(SUMET+SUMOT+XLOG)+EULER EXNEI=(EI/EXPHT)/EXPHT IF (IND .EQ. 2) RETURN C SHI,CHI EVALUATION 390 SHI=SUMOT CHI=(EULER+SUMET)+XLOG CHII=ZERO IF (IND .NE. 4) GO TO 1000 GO TO 370 C METHOD --- CONTINUED FRACTION C SI(X),CI(X), T .GT. PSLSC C -CI(T) + I (SI(T)-HALFPI)=E1(IT) C INITIALIZATION 500 SCC=RINF/FOUR TOLSQ=TOLER*TOLER RM=ONE AM=ONE BMR=ONE BMI=T FMM2R=ONE FMM2I=ZERO GMM2R=ZERO GMM2I=ZERO FMM1R=ZERO FMM1I=ZERO GMM1R=ONE GMM1I=ZERO RESQP=RINF FRP=ZERO FIP=ZERO C RECURRENCE RELATION C FM=BM*FMM1 + AM*FMM2 C GM=BM*GMM1 + AM*GMM2 510 FMR=BMR*FMM1R-BMI*FMM1I+AM*FMM2R FMI=BMI*FMM1R+BMR*FMM1I+AM*FMM2I GMR=BMR*GMM1R-BMI*GMM1I+AM*GMM2R GMI=BMI*GMM1R+BMR*GMM1I+AM*GMM2I C CONVERGENT F=FM/GM C TESTS TO AVOID INCORRECT RESULTS C DUE TO OVERFLOWS(UNDERFLOWS) C FINDING MAXIMUM(=TMAX) OF C ABSOLUTE OF FMR,GMR,FMI,GMI C FOR SCALING PURPOSES TMAX=ZERO I=1 520 TEMP=A(I) 530 IF (TEMP) 540,560,550 540 TEMP=-TEMP GO TO 530 550 IF (TEMP .LE. TMAX) GO TO 560 TMAX=TEMP 560 IF (I .GE. 4) GO TO 570 I=I+1 GO TO 520 570 SFMR=FMR/TMAX SFMI=FMI/TMAX SGMR=GMR/TMAX SGMI=GMI/TMAX TEMP=SGMR*SGMR + SGMI*SGMI FR=(SFMR*SGMR+SFMI*SGMI)/TEMP FI=(SFMI*SGMR-SFMR*SGMI)/TEMP C RELATIVE ERROR CHECK TEMP=FR*FR+FI*FI TEMPA=(FRP*FR+FIP*FI)/TEMP TEMPB=(FIP*FR-FRP*FI)/TEMP TEMP=ONE-TEMPA RESQ =TEMP*TEMP+TEMPB*TEMPB IF (RESQ .LE. TOLSQ) GO TO 590 IF (RESQ .GE. RESQP) GO TO 580 C ADDITIONAL CONVERGENTS AM=-RM*RM RM=RM+ONE BMR=BMR+TWO FMM2R=FMM1R FMM2I=FMM1I GMM2R=GMM1R GMM2I=GMM1I FMM1R=FMR FMM1I=FMI GMM1R=GMR GMM1I=GMI FRP=FR FIP=FI RESQP=RESQ C SCALING C SCALING SHOULD NOT BE DELETED AS THE VALUES OF FMR,FMI AND C GMR,GMI MAY OVERFLOW FOR SMALL VALUES OF T IF (TMAX .LT. SCC/(BMR-AM ) ) GO TO 510 FMM2R=FMM2R/TMAX FMM2I=FMM2I/TMAX GMM2R=GMM2R/TMAX GMM2I=GMM2I/TMAX FMM1R=FMM1R/TMAX FMM1I=FMM1I/TMAX GMM1R=GMM1R/TMAX GMM1I=GMM1I/TMAX GO TO 510 C DIVERGENCE OF RELATIVE ERROR C ACCEPT PRIOR CONVERGENT 580 FR=FRP FI=FIP C SI,CI EVALUATION 590 SI=FI*COST-FR*SINT+HALFPI CI=-(FR*COST+FI*SINT) CII=ZERO GO TO 190 C METHOD --- ASYMPTOTIC EXPANSION C EI(X),EXNEI(X) X .GT. AELL C SHI(T)=CHI(T)=EI(T)/2 T .GT. AELL C INITIALIZATION 800 IF (IND .NE. 2) GO TO 880 810 SUME=ZERO RK=ZERO TM=ONE C ADDITIONAL TERMS 820 TMM1=TM RK=RK+ONE TM=(RK/T)*TM C TOLERANCE CHECK IF (TM .LT. TOLER) GO TO 840 IF (TM .GE. TMM1) GO TO 830 SUME=SUME+TM GO TO 820 C DIVERGENT PATH 830 SUME=SUME-TMM1 C EXNEI EVALUATION 840 IF (X .LT. ZERO) GO TO 870 EXNEI=(ONE+SUME)/T C EI EVALUATION - X .LT. XMAXEI IF (T .GE. XMAXEI) GO TO 850 EI=(EXNEI*EXPHT)*EXPHT GO TO 860 C EI - LIMITING VALUE, X .GE. XMAXEI 850 EI=RINF C SHI,CHI EVALUATION - T .LT. XMAXHF 860 IF (IND .EQ. 2) RETURN 870 IF (T .GE. XMAXHF) GO TO 1000 SHI=(((( ONE+SUME)/T)/TWO)*EXPHT)*EXPHT CHI=SHI CHII=ZERO GO TO 1000 C SHI,CHI - LIMITING VALUE C T .GE. XMAXHF 880 IF ( T .LT. XMAXHF) GO TO 810 SHI=RINF CHI=RINF CHII=ZERO IF ( X .GT. ZERO) GO TO 810 GO TO 1010 C ADJUSTMENTS FOR X .LT. 0 1000 IF (X .GT. ZERO) RETURN 1010 IF (IC .EQ. 3) GO TO 1020 SI=-SI CII=-PI IF (IC .EQ. 1) RETURN 1020 SHI=-SHI CHII=-PI RETURN END SUBROUTINE SIDEDI(XC,YC,NS,D,IB,JB,X,Y) C C PURPOSE--XX C C WRITTEN BY--DAVID W. BEHRINGER NOAA/AOML (MIAMI). C AS PART OF NOAA'S CONCX V.3 MARCH 1988. C ORIGINAL VERSION (IN DATAPLOT)--AUGUST 1988. C UPDATED --JANUARY 1989. MORE CHANGES TO STANDARD FORTRAN 77-- C CHANGED DO WHILE/END DO (ALAN HECKERT). C C--------------------------------------------------------------------- C DIMENSION IB(*) DIMENSION JB(*) DIMENSION X(*) DIMENSION Y(*) C C-----START POINT----------------------------------------------------- C EPS=0.001*AMIN1(ABS(X(2)-X(1)),ABS(Y(2)-Y(1))) NS=0 D=0. NB=1 CCCCC DO WHILE (NS.EQ.0) JANUARY 1989 100 CONTINUE IF(NS.NE.0)GOTO199 IF (IB(NB).EQ.IB(NB+1)) THEN I=IB(NB) J1=JB(NB) J2=JB(NB+1) IF (ABS(XC-X(I)).LE.EPS.AND. 1 ABS(YC-Y(J1)).LT.ABS(Y(J2)-Y(J1))) THEN D=D+ABS(YC-Y(J1)) NS=NB ELSE D=D+ABS(Y(J2)-Y(J1)) END IF ELSE J=JB(NB) I1=IB(NB) I2=IB(NB+1) IF (ABS(YC-Y(J)).LE.EPS.AND. 1 ABS(XC-X(I1)).LT.ABS(X(I2)-X(I1))) THEN D=D+ABS(XC-X(I1)) NS=NB ELSE D=D+ABS(X(I2)-X(I1)) END IF END IF NB=NB+1 CCCCC END DO JANUARY 1989 GOTO100 199 CONTINUE RETURN END SUBROUTINE SIMCOV(ISEED,IBUGA2,IBUGA3,IBUGCO,IBUGEV,IBUGQ, 1ISUBRO,IFOUND,IERROR) C C PURPOSE--CARRY OUT MARK VANGEL'S SIMCOV PROGRAM C FOR LINEAR MODELS. 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--97/9 C ORIGINAL VERSION--SEPTEMBER1997. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C 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 ICASRE CHARACTER*4 ICASDG CCCCC CHARACTER*4 IH CCCCC CHARACTER*4 IH2 CHARACTER*4 ICASEQ CHARACTER*4 IKEY CHARACTER*4 IHRIGH CHARACTER*4 IHRIG2 CCCCC CHARACTER*4 ICH CCCCC CHARACTER*4 IOP CHARACTER*4 IFLAG C CCCCC CHARACTER*4 NEWNAM CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 IHLEFT CHARACTER*4 IHLEF2 CCCCC CHARACTER*4 IREP C CHARACTER*4 IVARN1 CHARACTER*4 IVARN2 C CHARACTER*4 IWRITE C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C CCCCC CHARACTER*20 IMODEL C LOGICAL SATT C DOUBLE PRECISION PCT DOUBLE PRECISION ERR DOUBLE PRECISION SDW DOUBLE PRECISION SDB DOUBLE PRECISION RHO C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION ILIS(100) DIMENSION ICOLR(100) C REAL XTMP(1) DOUBLE PRECISION COV(MAXOBV/2) DOUBLE PRECISION XDESGN(MAXOBV/2) DOUBLE PRECISION XPTS(MAXOBV/2) DOUBLE PRECISION V2(MAXOBV/2) DOUBLE PRECISION TLM0(MAXOBV/2) DOUBLE PRECISION TLM1(MAXOBV/2) DOUBLE PRECISION ETA0(MAXOBV/2) DOUBLE PRECISION ETA1(MAXOBV/2) DOUBLE PRECISION XM(MAXOBV/2) DOUBLE PRECISION WK2(MAXOBV/2) DOUBLE PRECISION WK3(MAXOBV/2) DOUBLE PRECISION XN(MAXOBV) DOUBLE PRECISION T(MAXOBV/2) DOUBLE PRECISION CRT(MAXOBV/2) C DIMENSION IP(MAXOBV) DIMENSION IQ(MAXOBV) C DOUBLE PRECISION Y2(MAXOBV/2) DIMENSION PRED2(MAXOBV/2) DIMENSION RES2(MAXOBV/2) C DOUBLE PRECISION XMAT(MAXOBV*10) DOUBLE PRECISION SCRTCH(MAXOBV*20) C DOUBLE PRECISION XTX(100) DOUBLE PRECISION XTXI(100) DOUBLE PRECISION S1(100) DOUBLE PRECISION S2(100) DOUBLE PRECISION V1(100) DOUBLE PRECISION COEF(100) C CCCCC DIMENSION ICH(10) C DIMENSION IVARN1(100) DIMENSION IVARN2(100) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOMC.INC' INCLUDE 'DPCOHK.INC' INCLUDE 'DPCOSU.INC' INCLUDE 'DPCODA.INC' INCLUDE 'DPCOHO.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C EQUIVALENCE (Y2(1),X3D(1)) EQUIVALENCE (PRED2(1),X(1)) EQUIVALENCE (RES2(1),D(1)) EQUIVALENCE (CRT(1),DSIZE(1)) EQUIVALENCE (COV(1),DSYMB(1)) EQUIVALENCE (XTX(1),DCOLOR(1)) EQUIVALENCE (XTXI(1),DCOLOR(1001)) EQUIVALENCE (S1(1),DCOLOR(2001)) EQUIVALENCE (S2(1),DCOLOR(3001)) EQUIVALENCE (V1(1),DCOLOR(4001)) C INCLUDE 'DPCOZZ.INC' INCLUDE 'DPCOZ2.INC' INCLUDE 'DPCOZI.INC' INCLUDE 'DPCOZD.INC' EQUIVALENCE (IGARBG(IIGAR1),IQ(1)) EQUIVALENCE (IGARBG(IIGAR2),IP(1)) EQUIVALENCE (G2RBAG(1),SCRTCH(1)) EQUIVALENCE (G2RBAG(1+40*MAXOBV),XM(1)) EQUIVALENCE (G2RBAG(1+41*MAXOBV),WK2(1)) EQUIVALENCE (G2RBAG(1+42*MAXOBV),WK3(1)) EQUIVALENCE (G2RBAG(1+43*MAXOBV),T(1)) EQUIVALENCE (G2RBAG(1+44*MAXOBV),XN(1)) EQUIVALENCE (GARBAG(1),XMAT(1)) EQUIVALENCE (DGARBG(1),XDESGN(1)) EQUIVALENCE (DGARBG(1+MAXOBV),XPTS(1)) EQUIVALENCE (DGARBG(1+2*MAXOBV),V2(1)) EQUIVALENCE (DGARBG(1+3*MAXOBV),TLM0(1)) EQUIVALENCE (DGARBG(1+4*MAXOBV),TLM1(1)) EQUIVALENCE (DGARBG(1+5*MAXOBV),ETA0(1)) EQUIVALENCE (DGARBG(1+6*MAXOBV),ETA1(1)) C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT 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='SIMC' ISUBN2='OV ' C IERROR='NO' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C CCCCC IPAROC(1)='NONE' C MAXV2=35 MINN2=2 C CPUEPS=R1MACH(3) C MAXN2=MAXCHF MAXN3=MAXCHF MAXN4=MAXCHF C MAXLVL=INT(SQRT(REAL(IGARB0))) MAXPT1=20*MAXOBV MAXPT2=10*MAXOBV C NPAR=0 NTOT=0 NBCH=0 NLEFT=0 C C ***************************** C ** TREAT THE RECIPE CASE ** C ***************************** C IF(IBUGA2.EQ.'OFF'.AND.ISUBRO.NE.'MCOV')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF SIMCOV--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IBUGA2,IBUGA3 53 FORMAT('IBUGA2,IBUGA3 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)IBUGCO,IBUGEV,IBUGQ 54 FORMAT('IBUGCO,IBUGEV,IBUGQ = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,56)NUMNAM 56 FORMAT('NUMNAM = ',I8) CALL DPWRST('XXX','BUG ') DO57I=1,NUMNAM WRITE(ICOUT,58)I,IHNAME(I),IHNAM2(I),IUSE(I),IN(I),IVALUE(I), 1VALUE(I) 58 FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IN(I),IVALUE(I)', 1'VALUE(I) = ',I8,2X,A4,A4,2X,A4,I8,I8,E15.7) CALL DPWRST('XXX','BUG ') 57 CONTINUE WRITE(ICOUT,61)IRECSA,RECIDG,RECIPC,RECICO 61 FORMAT('IRECSA,RECIDG,RECIPC,RECICO=',A4,1X,3(E15.7)) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ********************************** C ** STEP 1-- ** C ** EXTRACT THE COMMAND ** C ** SIMCOV FIT ** C ** SIMCOV ANOVA ** C ** SIMCOV Y , RESPONSE VARIABLE IS FIRST WORD. ** C ** EXTRACT THE RESPONSE VARIABLE AND DETERMINE ** C ** IF IT IS ALREADY IN THE NAME LIST AND IS, IN FACT,* C ** A VARIABLE (AS OPPOSED TO A PARAMETER). ** C ******************************************************* C ISTEPN='4' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'MCOV') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ILOCY=2 IF(ICASRE.EQ.'UREC')ILOCY=1 IHLEFT=IHARG(ILOCY) IHLEF2=IHARG2(ILOCY) DO2350I=1,NUMNAM I2=I IF(IHLEFT.EQ.IHNAME(I2).AND.IHLEF2.EQ.IHNAM2(I2).AND. 1IUSE(I2).EQ.'V')GOTO2379 2350 CONTINUE WRITE(ICOUT,2361) 2361 FORMAT('***** ERROR IN SIMCOV--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2362) 2362 FORMAT(' THE NAME FOLLOWING THE WORD RECIPE FIT ', 1'(OR RECIPE ANOVA') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2363) 2363 FORMAT(' (WHICH SHOULD BE THE RESPONSE VARIABLE)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2364) 2364 FORMAT(' EITHER DOES NOT EXIST,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2365) 2365 FORMAT(' OR IS A PARAMETER (AS OPPOSED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2366) 2366 FORMAT(' TO A VARIABLE) IN THE CURRENT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2367) 2367 FORMAT(' LIST OF AVAILABLE VARIABLE AND PARAMETER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2368) 2368 FORMAT(' NAMES.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2369)IHLEFT,IHLEF2 2369 FORMAT(' NAME AFTER THE WORD RECIPE FIT/ANOVA = ',A4,A4) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,2378)(IANS(J),J=1,MIN(IWIDTH,100)) 2378 FORMAT(' COMMAND LINE--',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 2379 CONTINUE ILOCV=I2 ICOLL=IVALUE(ILOCV) NLEFT=IN(ILOCV) 2390 CONTINUE C C ******************************************************* C ** STEP 5-- ** C ** FOR ALL VARIATIONS OF THE SIMCOV COMMAND, ** C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS (NLEFT) C ** FOR THE RESPONSE VARIABLE IS 2 OR LARGER. ** C ******************************************************* C ISTEPN='5' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'MCOV') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NLEFT.GE.MINN2)GOTO390 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,311) 311 FORMAT('***** ERROR IN SIMCOV--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,312)IHLEFT,IHLEF2 312 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS ', 1'IN VARIABLE ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,313) 313 FORMAT(' (FOR WHICH A RECIPE ANALYSIS ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,314) 314 FORMAT(' WAS TO HAVE BEEN PERFORMED)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,315)MINN2 315 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,316) 316 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,317)NLEFT 317 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS NLEFT = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,318) 318 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,319)(IANS(I),I=1,IWIDTH) 319 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 390 CONTINUE C C ************************************************** C ** STEP 12-- ** C ** EXTRACT THE INDEPENDENT VARIABLES ** C ** FOR SIMCOV FIT: ** C ** Y X ** C ** FOR SIMCOV ANOVA: ** C ** Y X1 ... XK ** C ** FOR SIMCOV : ** C ** Y ** C ** IF THE TO FEATURE IS USED IN THE ** C ** ARGUMENT LIST, TRANSLATE THE TO TO ** C ** EXPLICIT VARIABLE NAMES INTO ** C ************************************************** C ISTEPN='12' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'MCOV') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASRE.EQ.'FREC')THEN MAXREC=3 JMIN=ILOCY+1 JMAX=ILOCQ-1 CALL EXTVAR(IHARG,IHARG2,NUMARG,JMIN,JMAX,MAXREC, 1 IHNAME,IHNAM2,IUSE,NUMNAM, 1 IVARN1,IVARN2,NUMVAR,IBUGA2,ISUBRO,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IF(NUMVAR.EQ.1)THEN ILOCX=ILOCY+1 ILOCB=-1 ILOCXP=-1 ELSEIF(NUMVAR.EQ.2)THEN ILOCX=ILOCY+1 ILOCB=ILOCX+1 ILOCXP=-1 ELSEIF(NUMVAR.EQ.3)THEN ILOCX=ILOCY+1 ILOCB=ILOCX+1 ILOCXP=ILOCB+1 ELSE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,411) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,412) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,413)NUMVAR CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF 411 FORMAT('***** ERROR IN SIMCOV (SIMCOV FIT)--') 412 FORMAT(' BETWEEN 2 AND 4 VARIABLE NAMES CAN BE SPECIFIED ' 1 ,'FOR THIS COMMAND') 413 FORMAT(' ',I8,' VARIABLES WERE GIVEN.') ELSEIF(ICASRE.EQ.'UREC')THEN MAXREC=1 JMIN=ILOCY+1 JMAX=ILOCQ-1 CALL EXTVAR(IHARG,IHARG2,NUMARG,JMIN,JMAX,MAXREC, 1 IHNAME,IHNAM2,IUSE,NUMNAM, 1 IVARN1,IVARN2,NUMVAR,IBUGA2,ISUBRO,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ILOCX=-1 ILOCXP=-1 IF(NUMVAR.EQ.1)THEN ILOCB=ILOCX+1 ELSEIF(NUMVAR.EQ.0)THEN ILOCB=-1 ELSE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,421) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,422) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,423)NUMVAR CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF 421 FORMAT('***** ERROR IN SIMCOV (SIMCOV)--') 422 FORMAT(' BETWEEN 0 AND 1 VARIABLE NAMES CAN BE SPECIFIED ' 1 ,'FOR THIS COMMAND') 423 FORMAT(' ',I8,' VARIABLES WERE GIVEN.') ELSEIF(ICASRE.EQ.'AREC')THEN NUMFAC=INT(RECIFA+0.5) CCCCC IF(NUMFAC.GT.MAXPAR)THEN CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,511) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,512)NUMFAC,MAXPAR CCCCC CALL DPWRST('XXX','BUG ') CCCCC IERROR='YES' CCCCC GOTO9000 CCCCC ENDIF 511 FORMAT('***** ERROR IN SIMCOV (RECIPE ANOVA)--') 512 FORMAT(' THE REQUESTED NUMBER OF FACTORS ',I8, 1 ' IS GREATER THAN THE ALLOWED MAXIMUM OF ',I8) MAXREC=NUMFAC+1 JMIN=ILOCY+1 JMAX=ILOCQ-1 CALL EXTVAR(IHARG,IHARG2,NUMARG,JMIN,JMAX,MAXREC, 1 IHNAME,IHNAM2,IUSE,NUMNAM, 1 IVARN1,IVARN2,NUMVAR,IBUGA2,ISUBRO,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IF(NUMVAR.EQ.NUMFAC)THEN ILOCX=ILOCY+1 ILOCB=-1 ILOCXP=-1 ELSEIF(NUMVAR.EQ.NUMFAC+1)THEN ILOCX=ILOCY+1 ILOCB=ILOCX+NUMFAC ILOCXP=-1 ELSE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,611) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,612)NUMFAC,NUMVAR CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF 611 FORMAT('***** ERROR IN SIMCOV (SIMCOV ANOVA)--') 612 FORMAT(' ',I8,' FACTORS WERE SPECIFIED, BUT ONLY ',I8, 1 ' VARIABLES WERE GIVEN ON THE COMMAND LINE.') ENDIF C IF(IBUGA2.EQ.'ON')THEN WRITE(ICOUT,71)NUMVAR,NUMFAC CALL DPWRST('XXX','BUG') ENDIF 71 FORMAT('NUMVAR,NUMFAC=',2I8) 1290 CONTINUE C C *************************************** C ** STEP 13-- ** C ** CHECK THE VALIDITY OF EACH ** C ** OF THE VARIABLES. ** C ** THE DESIGN MATRIX (X) AND BATCH ** C ** IDENTIFIER VARIABLE MUST HAVE THE** C ** SAME NUMER OF OBSERVATIONS AS THE** C ** Y VARIABLE. THE XPRED VARIABLE ** C ** MUST HAVE AT LEAST 2 OBSERVATIONS** C *************************************** C ISTEPN='13' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'MCOV') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASRE.EQ.'UREC'.AND.NUMVAR.EQ.0)GOTO1399 DO1300I=1,NUMVAR C IHRIGH=IVARN1(I) IHRIG2=IVARN2(I) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHRIGH,IHRIG2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 C NRIGHT=IN(ILOCV) ILIS(I)=ILOCV ICOLR(I)=IVALUE(ILOCV) C IF(ILOCXP.GT.0 .AND. I.EQ.NUMVAR)NPRED=NRIGHT IF(NRIGHT.EQ.NLEFT)GOTO1390 IF(ILOCXP.GT.0 .AND. I.EQ.NUMVAR .AND. NRIGHT.GT.2)GOTO1390 C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1311) 1311 FORMAT('***** ERROR IN SIMCOV--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1312) 1312 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1321) 1321 FORMAT(' FOR THE INDEPENDENT VARIABLES') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1322) 1322 FORMAT(' MUST BE THE SAME AS THE DEPENDENT VARIABLE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1323) 1323 FORMAT(' IN ADDITION, THE VARIABLE CONTAINING THE X ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1324) 1324 FORMAT(' VALUES FOR THE TOLERANCE LIMITS MUST HAVE AT ', 1'LEAST 2 ELEMENTS.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1327) 1327 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1328) 1328 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,1329)(IANS(J),J=1,MIN(80,IWIDTH)) 1329 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1390 CONTINUE C 1300 CONTINUE 1399 CONTINUE C C ********************************************** C ** STEP 6.3-- ** C ** FOR ALL VARIATIONS OF THE SIMCOV COMMAND,* C ** CHECK TO SEE THE TYPE CASE-- ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET/EXCEPT; OR ** C ** 3) FOR. ** C ********************************************** C ISTEPN='6.3' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'MCOV') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO490 DO400J=1,NUMARG J1=J IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET ')GOTO410 IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT ')GOTO410 IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.' ')GOTO420 400 CONTINUE GOTO490 410 CONTINUE ICASEQ='SUBS' IKEY='SUBS' IF(IHARG(J1).EQ.'EXCE')IKEY='EXCE' ILOCQ=J1 GOTO490 420 CONTINUE ICASEQ='FOR' ILOCQ=J1 GOTO490 490 CONTINUE IF(IBUGA2.EQ.'OFF'.AND.ISUBRO.NE.'MCOV')GOTO495 WRITE(ICOUT,491)NUMARG,ILOCQ 491 FORMAT('NUMARG,ILOCQ = ',2I8) CALL DPWRST('XXX','BUG ') 495 CONTINUE C C ******************************************************* C ** STEP 12-- ** C ** BRANCH TO THE APPROPRIATE SUBCASE; THEN ** C ** COPY OVER THE RESPONSE VECTOR TO BE USED IN THE ** C ** MODEL INTO THE VECTOR Y2; AND ** C ** COPY OVER THE VECTORS THAT WERE USED IN THE MODEL** C ** INTO THE FULL DESIGN MATRIX ** C ******************************************************* C ISTEPN='12' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'MCOV') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'MCOV')WRITE(ICOUT,601)NLEFT,NUMVAR 601 FORMAT('NLEFT,NUMVAR = ',2I8) IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'MCOV')CALL DPWRST('XXX','BUG ') C IF(ICASEQ.EQ.'FULL')GOTO610 IF(ICASEQ.EQ.'SUBS')GOTO620 IF(ICASEQ.EQ.'FOR')GOTO630 C 610 CONTINUE DO615I=1,NLEFT ISUB(I)=1 615 CONTINUE NQ=NLEFT GOTO650 C 620 CONTINUE NIOLD=NLEFT CALL DPSUB2(NIOLD,ILOCS,NS,IBUGQ,IERROR) NQ=NIOLD GOTO650 C 630 CONTINUE NIOLD=NLEFT CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1NLOCAL,ILOCS,NS,IBUGQ,IERROR) NQ=NFOR GOTO650 C 650 CONTINUE NTOT=NQ K=ICOLL J=0 DO4500I=1,NLEFT IF(ISUB(I).EQ.0)GOTO4500 J=J+1 IJ=MAXN*(K-1)+I IF(K.LE.MAXCOL)Y2(J)=DBLE(V(IJ)) IF(K.EQ.MAXCP1)Y2(J)=DBLE(PRED(I)) IF(K.EQ.MAXCP2)Y2(J)=DBLE(RES(I)) IF(K.EQ.MAXCP3)Y2(J)=DBLE(YPLOT(I)) IF(K.EQ.MAXCP4)Y2(J)=DBLE(XPLOT(I)) IF(K.EQ.MAXCP5)Y2(J)=DBLE(X2PLOT(I)) IF(K.EQ.MAXCP6)Y2(J)=DBLE(TAGPLO(I)) 4500 CONTINUE IF(IBUGA2.EQ.'ON')THEN DO4503I=1,NTOT WRITE(ICOUT,4504)I,Y2(I) 4504 FORMAT('I,Y2(I)=',I8,2X,D15.7) CALL DPWRST('XXX','BUG') 4503 CONTINUE ENDIF C C ******************************************************** C ** DEFINE A VECTOR OF ALL 1'S (FOR THE CONSTANT TERM) ** C ** IN THE DESIGN MATRIX. ** C ******************************************************** C J=0 DO380I=1,NLEFT IF(ISUB(I).EQ.0)GOTO380 J=J+1 XMAT(J)=1.0D0 380 CONTINUE C C ******************************************************** C ** DETERMINE IF THERE IS A BATCH VARIABLE. IF NOT, ** C ** CREATE ONE EQUAL TO ALL 1'S. IF YES, DETERMINE ** C ** HOW MANY UNIQUE VALUES. ** C ******************************************************** C IF(ILOCB.LE.0)THEN J=0 DO4610I=1,NLEFT IF(ISUB(I).EQ.0)GOTO4610 J=J+1 IQ(J)=1 4610 CONTINUE NBCH=1 GOTO4699 ENDIF C IF(ICASRE.EQ.'FREC')THEN K=ICOLR(NUMVAR) IF(ILOCXP.GT.0)K=ICOLR(NUMVAR-1) ELSE K=ICOLR(NUMVAR) ENDIF C J=0 DO4600I=1,NLEFT IF(ISUB(I).EQ.0)GOTO4600 J=J+1 IJ=MAXN*(K-1)+I IF(K.LE.MAXCOL)RES2(J)=V(IJ) IF(K.EQ.MAXCP1)RES2(J)=PRED(I) IF(K.EQ.MAXCP2)RES2(J)=RES(I) IF(K.EQ.MAXCP3)RES2(J)=YPLOT(I) IF(K.EQ.MAXCP4)RES2(J)=XPLOT(I) IF(K.EQ.MAXCP5)RES2(J)=X2PLOT(I) IF(K.EQ.MAXCP6)RES2(J)=TAGPLO(I) 4600 CONTINUE C CALL SORT(RES2,NQ,PRED2) IWRITE='NO' CALL DISTIN(PRED2,NQ,IWRITE,PRED2,NBCH,IBUGA3,IERROR) IF(IERROR.EQ.'YES')GOTO9000 DO4650I=1,NQ IQ(I)=0 DO4660J=1,NBCH IF(RES2(I).EQ.PRED2(J))THEN IQ(I)=J GOTO4650 ENDIF 4660 CONTINUE 4650 CONTINUE C 4699 CONTINUE C IF(IBUGA2.EQ.'ON')THEN DO4603I=1,NTOT WRITE(ICOUT,4604)I,IQ(I) 4604 FORMAT('I,IQ(I)=',I8,2X,I8) CALL DPWRST('XXX','BUG') 4603 CONTINUE ENDIF C C ******************************************************** C ** DETERMINE IF THERE IS A PREDICTED VARIABLE (FIT ** C ** CASE ONLY). IF SO, EXTRACT AND PUT IN XPTS. ** C ******************************************************** C IF(ICASRE.EQ.'UREC')THEN XPTS(1)=1.D0 NPRED=1 NPAR=1 GOTO4799 ELSEIF(ILOCXP.LT.0.OR.ICASRE.EQ.'AREC')THEN DO4701I=1,MAXOBV XPTS(I)=0.D0 4701 CONTINUE NPRED=0 GOTO4799 ENDIF C K=ICOLR(NUMVAR) DO4703I=1,NPRED XPTS(I)=1.D0 4703 CONTINUE J=NPRED DO4700I=1,NPRED IF(ISUB(I).EQ.0)GOTO4700 J=J+1 IJ=MAXN*(K-1)+I IF(K.LE.MAXCOL)XPTS(J)=DBLE(V(IJ)) IF(K.EQ.MAXCP1)XPTS(J)=DBLE(PRED(I)) IF(K.EQ.MAXCP2)XPTS(J)=DBLE(RES(I)) IF(K.EQ.MAXCP3)XPTS(J)=DBLE(YPLOT(I)) IF(K.EQ.MAXCP4)XPTS(J)=DBLE(XPLOT(I)) IF(K.EQ.MAXCP5)XPTS(J)=DBLE(X2PLOT(I)) IF(K.EQ.MAXCP6)XPTS(J)=DBLE(TAGPLO(I)) 4700 CONTINUE C 4799 CONTINUE C IF(IBUGA2.EQ.'ON')THEN DO4713I=1,2*NPRED WRITE(ICOUT,4714)I,XPTS(I) 4714 FORMAT('I,XPTS(I)=',I8,2X,D15.7) CALL DPWRST('XXX','BUG') 4713 CONTINUE ENDIF C C ******************************************************** C ** COPY OVER THE FULL DESIGN MATRIX. ** C ******************************************************** C IF(ICASRE.EQ.'FREC')THEN NPAR=1 IF(ICASDG.EQ.'0')GOTO379 IF(ICASDG.EQ.'1')NLOOP=1 IF(ICASDG.EQ.'2')NLOOP=2 IF(ICASDG.EQ.'3')NLOOP=3 IF(ICASDG.EQ.'4')NLOOP=4 IF(ICASDG.EQ.'5')NLOOP=5 IF(ICASDG.EQ.'6')NLOOP=6 IF(ICASDG.EQ.'7')NLOOP=7 IF(ICASDG.EQ.'8')NLOOP=8 IF(ICASDG.EQ.'9')NLOOP=9 IF(ICASDG.EQ.'10')NLOOP=10 K=ICOLR(1) DO376IVAR=1,NLOOP J=IVAR*NTOT DO371I=1,NLEFT IF(ISUB(I).EQ.0)GOTO371 J=J+1 IJ=MAXN*(K-1)+I IF(K.LE.MAXCOL)XMAT(J)=DBLE(V(IJ)**NLOOP) IF(K.EQ.MAXCP1)XMAT(J)=DBLE(PRED(I)**NLOOP) IF(K.EQ.MAXCP2)XMAT(J)=DBLE(RES(I)**NLOOP) IF(K.EQ.MAXCP3)XMAT(J)=DBLE(YPLOT(I)**NLOOP) IF(K.EQ.MAXCP4)XMAT(J)=DBLE(XPLOT(I)**NLOOP) IF(K.EQ.MAXCP5)XMAT(J)=DBLE(X2PLOT(I)**NLOOP) IF(K.EQ.MAXCP6)XMAT(J)=DBLE(TAGPLO(I)**NLOOP) 371 CONTINUE 376 CONTINUE NPAR=NLOOP+1 379 CONTINUE C ELSEIF(ICASRE.EQ.'UREC')THEN NPAR=1 J=NTOT CCCCC DO372I=1,NLEFT CCCCC IF(ISUB(I).EQ.0)GOTO372 CCCCC J=J+1 CCCCC XMAT(J)=1.D0 C372 CONTINUE ELSEIF(ICASRE.EQ.'AREC')THEN NLOOP=NUMVAR IF(ILOCB.GT.0)NLOOP=NUMVAR-1 DO389IVAR=1,NLOOP K=ICOLR(IVAR) J=IVAR*NTOT DO381I=1,NLEFT IF(ISUB(I).EQ.0)GOTO381 J=J+1 IJ=MAXN*(K-1)+I IF(K.LE.MAXCOL)XMAT(J)=DBLE(V(IJ)) IF(K.EQ.MAXCP1)XMAT(J)=DBLE(PRED(I)) IF(K.EQ.MAXCP2)XMAT(J)=DBLE(RES(I)) IF(K.EQ.MAXCP3)XMAT(J)=DBLE(YPLOT(I)) IF(K.EQ.MAXCP4)XMAT(J)=DBLE(XPLOT(I)) IF(K.EQ.MAXCP5)XMAT(J)=DBLE(X2PLOT(I)) IF(K.EQ.MAXCP6)XMAT(J)=DBLE(TAGPLO(I)) 381 CONTINUE 389 CONTINUE NPAR=NLOOP+1 ENDIF C IF(IBUGA2.EQ.'ON')THEN DO4803I=1,NTOT*NPAR WRITE(ICOUT,4804)I,XMAT(I) 4804 FORMAT('I,XMAT(I)=',I8,2X,D15.7) CALL DPWRST('XXX','BUG') 4803 CONTINUE ENDIF C C ****************************************************** C ** STEP 14-- ** C ** CARRY OUT THE ACTUAL FIT ** C ** VIA CALLING ** C ** REGINI AND REGDAT ** C ****************************************************** C NSTOR=NTOT*(NPAR+NBCH) IF(NSTOR.GT.MAXPT1)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6071) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6072)NSTOR CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6073)MAXPT1 CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF 6071 FORMAT('***** ERROR FROM SIMCOV--THE AMOUNT OF SCRATCH STORAGE ', 1'REQUIRED') 6072 FORMAT(' NUMBER OF POINTS*(NUMBER OF PARAMETERS + NUMBER OF', 1' BATCHES) = ',I8) 6073 FORMAT(' EXCEEDS THE MAXIMIM ALLOWABLE OF ',I8) ISTEPN='14' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'MCOV') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IBUGA2.EQ.'OFF'.AND.ISUBRO.NE.'MCOV')GOTO6099 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6081) 6081 FORMAT('***** FROM SIMCOV, AS ABOUT TO CALL REGINI--') CALL DPWRST('XXX','BUG ') 6099 CONTINUE C 6530 CONTINUE SATT=.FALSE. IF(IRECSA.EQ.'YES'.OR.IRECSA.EQ.'TRUE'.OR.IRECSA.EQ.'ON') 1SATT=.TRUE. NREPS=IRECR2 MAXREP=10*MAXOBV IF(NREPS.GT.MAXREP)THEN NREPS=MAXREP WRITE(ICOUT,998) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,6531)NREPS,MAXREP CALL DPWRST('XXX','WRIT') WRITE(ICOUT,6532) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,998) CALL DPWRST('XXX','WRIT') ENDIF 998 FORMAT(1X) 6531 FORMAT('THE REQUESTED NUMBER OF SIMULATION REPLICATIONS ',I8, 1' IS GREATER THAN THE ALLOWED MAXIMUM OF ',I8) 6532 FORMAT('THE MAXIMUM ALLOWED NUMBER OF REPLICATIONS WILL BE ', 1'USED.') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1032) 1032 FORMAT(20X,'RECIPE SIMCOV ANALYSIS') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1132) 1132 FORMAT(22X,'(MARK VANGEL, NIST)') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,998) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1033)NTOT 1033 FORMAT('NUMBER OF OBSERVATIONS = ',I8) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1035)NBCH 1035 FORMAT('NUMBER OF BATCHES = ',I8) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1036)IRECR1 1036 FORMAT('NUMBER OF SIMCOV SIMULATIONS = ',I8) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1037)RECIPC 1037 FORMAT('PROBABILITY CONTENT = ',G15.7) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1039) 1039 FORMAT('NOTE: PLEASE BE PATIENT. THE SIMULATION CAN TAKE ', 1'SOME TIME.') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,998) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,1041) 1041 FORMAT(' CORRELATION PROBABILITY') CALL DPWRST('XXX','WRIT') C CALL REGINI(NLVL,NPAR,NTOT,NBCH,NPRED,XDESGN,XPTS,IP,IQ, 1 DBLE(RECIPC),DBLE(RECICO),XMAT,XTX,XTXI,XN,SCRTCH, 1 S1,V1,S2,V2,TLM0,TLM1,ETA0,ETA1, 1 SATT,IN2,WK2,WK3, 1 CRT,ISEED,MAXREP,MAXLVL, 1 ICASRE,ISUBRO,IBUGA2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IF(IBUGA2.EQ.'OFF'.AND.ISUBRO.NE.'MCOV')GOTO6199 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,6181) 6181 FORMAT('***** FROM SIMCOV, AS ABOUT TO PERFORM SIMULATION--') CALL DPWRST('XXX','BUG ') 6199 CONTINUE C NSIM=IRECR1 NRHO=IRECC1 NRAN=1 C IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'MCOV')THEN WRITE(ICOUT,6185)NSIM,NRHO,NRAN,NPRED 6185 FORMAT('NSIM,NRHO,NRAN,NPRED=',4I8) CALL DPWRST('XXX','BUG ') ENDIF C C LOOP OVER INTRACLASS CORRELATION VALUES C DO7000 IRHO=1,NRHO RHO=DBLE(IRHO-1)/DBLE(NRHO-1) IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'MCOV')THEN WRITE(ICOUT,7005)IRHO,RHO 7005 FORMAT('IRHO,RHO=',I8,E15.7) CALL DPWRST('XXX','BUG ') ENDIF CALL NODPPF(DBLE(RECIPC),PCT) PCT=-PCT SDB=DSQRT(RHO) SDW=DSQRT(1.0D0-RHO) IF(NBCH.EQ.1)THEN SDB=0.0D0 SDW=1.0D0 ENDIF DO7049 IDX=1,NPRED COV(IDX)=0.D0 CCCCC XMU(IDX)=0.D0 7049 CONTINUE DO5000 IDX=1,NSIM CALL NORRAN(NBCH,ISEED,RES2) DO5021I=1,NTOT CALL NORRAN(NRAN,ISEED,XTMP) ERR=DBLE(XTMP(1)) Y2(I)=DBLE(RES2(IQ(I)))*SDB + ERR*SDW 5021 CONTINUE C IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'MCOV')THEN WRITE(ICOUT,7009) 7009 FORMAT('BEFORE CALL TO REGDAT') CALL DPWRST('XXX','BUG ') ENDIF IFLAG='SIMC' CALL REGDAT(NPAR,NTOT,NBCH,NPRED,XPTS,Y2,COEF, 1 SCRTCH,S1,V1,TLM0,TLM1,ETA0,ETA1, 1 XMAT,XM,T,XDESGN,NLVL, 1 ICASRE,IFLAG,ISUBRO,IBUGA2,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'MCOV')THEN WRITE(ICOUT,7019) 7019 FORMAT('NPRED = ',I8) CALL DPWRST('XXX','BUG ') ENDIF DO4000I=1,NPRED IF(T(I).LT.PCT) COV(I) = COV(I)+1.0D0 4000 CONTINUE 5000 CONTINUE C WRITE(ICOUT,998) CALL DPWRST('XXX','WRIT') DO6000I=1,NPRED WRITE(ICOUT,2000)RHO,COV(I)/DBLE(NSIM) 2000 FORMAT(2F12.4) CALL DPWRST('XXX','WRIT') 6000 CONTINUE C 7000 CONTINUE C C *************************************** C ** STEP 16-- ** C ** STORE THE TOLERANCE VALUES ** C *************************************** C7640 CONTINUE CCCCC IH=IRECTN(1:4) CCCCC IH2=IRECTN(5:8) C CCCCC NEWNAM='NO' CCCCC DO7650I=1,NUMNAM CCCCC I2=I CCCCC IF(IH.EQ.IHNAME(I).AND.IH2.EQ.IHNAM2(I).AND. CCCCC1IUSE(I).EQ.'V')THEN CCCCC ICOLL1=IVALUE(I2) CCCCC GOTO7680 CCCCC ENDIF CCCCC IF(IH.EQ.IHNAME(I).AND.IH2.EQ.IHNAM2(I).AND. CCCCC1IUSE(I).NE.'V')THEN CCCCC WRITE(ICOUT,7646) C7646 FORMAT('***** ERROR IN SIMCOV--') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,7647)IRECTN C7647 FORMAT(' THE REQUESTED NAME FOR THE TOLERANCE ', CCCCC1 'VARIABLE, ',A8,', WAS FOUND IN THE') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,7648) C7648 FORMAT(' CURRENT NAME LIST, BUT NOT AS A VARIABLE.') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,7649) C7649 FORMAT(' THEREFORE THE TOLERANCE VARIABLE WAS NOT ', CCCCC1 'UPDATED.') CCCCC CALL DPWRST('XXX','BUG ') CCCCC GOTO7699 CCCCC ENDIF C7650 CONTINUE CCCCC NEWNAM='YES' C C NEW VARIABLE, CHECK TO ENSURE MAXIMUM NAMES AND MAXIMUM C COLUMNS NOT EXCEEDED. C CCCCC IF(NUMNAM.GE.MAXNAM)THEN CCCCC WRITE(ICOUT,7651) C7651 FORMAT('***** ERROR IN SIMCOV--') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,7652) C7652 FORMAT(' THE TOTAL NUMBER OF (VARIABLE + PARAMETER)') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,7653)MAXNAM C7653 FORMAT(' NAMES MUST BE AT MOST ',I8) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,7654) C7654 FORMAT(' SUCH WAS NOT THE CASE HERE--') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,7655) C7655 FORMAT(' THE MAXIMUM ALLOWABLE NUMBER OF NAMES') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,7656) C7656 FORMAT(' WAS JUST EXCEEDED.') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,7657) C7657 FORMAT(' SUGGESTED ACTION--ENTER STAT') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,7658) C7658 FORMAT(' TO DETERMINE THE IMPORTANT') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,7659) C7659 FORMAT(' (VERSUS UNIMPORTANT) VARIABLES') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,7660) C7660 FORMAT(' AND PARAMETERS, AND THEN REUSE SOME') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,7661) C7661 FORMAT(' OF THE NAMES.') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,7662) C7662 FORMAT(' THE TOLERANCE VARIABLE WAS NOT UPDATED--') CCCCC CALL DPWRST('XXX','BUG ') CCCCC GOTO7699 CCCCC ENDIF C CCCCC IF(NUMCOL.GE.MAXCOL)THEN CCCCC WRITE(ICOUT,7665) C7665 FORMAT('***** ERROR IN SIMCOV--') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,7666) C7666 FORMAT(' THE NUMBER OF DATA COLUMNS') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,7667)MAXCOL C7667 FORMAT(' HAS JUST EXCEEDED THE MAX ALLOWABLE ',I8,' .') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,7668) C7668 FORMAT(' SUGGESTED ACTION--') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,7669) C7669 FORMAT(' ENTER STATUS VARIABLES') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,7670) C7670 FORMAT(' TO FIND OUT THE FULL LIST OF USED COLUMNS') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,7671) C7671 FORMAT(' AND THEN DELETE SOME COLUMNS.') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,7672) C7672 FORMAT(' THE TOLERANCE VARIABLE WAS NOT UPDATED--') CCCCC CALL DPWRST('XXX','BUG ') CCCCC GOTO7699 CCCCC ENDIF C C7680 CONTINUE CCCCC IF(NEWNAM.EQ.'YES')THEN CCCCC NUMCOL=NUMCOL+1 CCCCC ICOLL1=NUMCOL CCCCC NUMNAM=NUMNAM+1 CCCCC IHNAME(NUMNAM)=IH CCCCC IHNAM2(NUMNAM)=IH2 CCCCC IUSE(NUMNAM)='V' CCCCC VALUE(NUMNAM)=ICOLL1 CCCCC IVALUE(NUMNAM)=ICOLL1 CCCCC NTEMP=NTOT CCCCC IF(ICASRE.EQ.'FREC'.AND.ILOCXP.GT.0)NTEMP=NPRED CCCCC IN(NUMNAM)=NTEMP CCCCC IF(IBUGA2.EQ.'ON')THEN CCCCC WRITE(ICOUT,7683)IN(NUMNAM) C7683 FORMAT('IN(NUMNAM)=',I8) CCCCC CALL DPWRST('XXX','BUG') CCCCC ENDIF CCCCC ELSE CCCCC NTEMP=NTOT CCCCC IF(ICASRE.EQ.'FREC'.AND.ILOCXP.GT.0)NTEMP=NPRED CCCCC IF(ICASRE.EQ.'UREC')NTEMP=1 CCCCC IN(ICOLL1)=NTEMP CCCCC IF(IBUGA2.EQ.'ON')THEN CCCCC WRITE(ICOUT,7686)IN(ICOLL1) C7686 FORMAT('IN(ICOLL1)=',I8) CCCCC CALL DPWRST('XXX','BUG') CCCCC ENDIF CCCCC ENDIF CCCCC IF(IBUGA2.EQ.'ON')THEN CCCCC WRITE(ICOUT,7681)NEWNAM,ICOLL1,NUMCOL,NUMNAM,NPRED,NTEMP CCCCC CALL DPWRST('XXX','BUG') C7681 FORMAT('NEWNAM,ICOLL1,NUMCOL,NUMNAM,NPRED,NTEMP =', CCCCC1 A4,1X,5I8) CCCCC ENDIF CCCCC K=ICOLL1 CCCCC DO7682I=1,NTEMP CCCCC IJ=MAXN*(K-1)+I CCCCC IF(K.LE.MAXCOL)V(IJ)=T(I) CCCCC IF(K.EQ.MAXCP1)PRED(I)=T(I) CCCCC IF(K.EQ.MAXCP1)RES(I)=T(I) CCCCC IF(K.EQ.MAXCP1)YPLOT(I)=T(I) CCCCC IF(K.EQ.MAXCP1)XPLOT(I)=T(I) CCCCC IF(K.EQ.MAXCP1)X2PLOT(I)=T(I) CCCCC IF(K.EQ.MAXCP1)TAGPLO(I)=T(I) C7682 CONTINUE C C7699 CONTINUE C C8000 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGA2.EQ.'OFF'.AND.ISUBRO.NE.'MCOV')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF SIMCOV--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA2,IBUGA3 9012 FORMAT('IBUGA2,IBUGA3 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IBUGCO,IBUGEV,IBUGQ 9013 FORMAT('IBUGCO,IBUGEV,IBUGQ = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)NPAR,NTOT,NBCH,NLVL,ICASRE 9015 FORMAT('NPAR,NTOT,NBCH,NLEVL,ICASRE = ',4(I8,1X),2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9052)ICASEQ 9052 FORMAT('ICASEQ = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9061)IWIDTH 9061 FORMAT('IWIDTH = ',I8) CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,9062)(IANS(I),I=1,MIN(100,IWIDTH)) 9062 FORMAT('(IANS(I),I=1,IWIDTH) = ',100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9069)IFOUND,IERROR 9069 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE SIMPLX(A,M,N,MP,NP,M1,M2,M3, 1ICASE,IZROV,IPOSV,IBUGA3,ISUBRO,IERROR) C C PURPOSE--CARRY OUT SIMPLEX LINEAR PROGRAMMING SOLUTION C C INPUT ARGUMENTS-- C C SOURCE--NUMERICAL RECIPES, C PRESS, FLANNERY, TEUKOLSKY, AND VETTERLING, C CAMBRIDGE UNIVERSITY PRESS, 1986. C C--------------------------------------------------------------------- C CCCCC PARAMETER(MMAX=100,EPS=1.E-6) CCCCC PARAMETER(MMAX=100,EPS=1.E-3) PARAMETER(MMAX=100) C CHARACTER*4 IBUGA3 CHARACTER*4 ISUBRO CHARACTER*4 IERROR C DIMENSION A(MP,NP),IZROV(N),IPOSV(M),L1(MMAX),L2(MMAX),L3(MMAX) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT 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 MP1=M+1 NP1=N+1 C MP2=M+2 C IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'MPLX')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF SIMPLX--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3,ISUBRO 52 FORMAT('IBUGA3,ISUBRO = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,61)M,N,MP,NP,M1,M2,M3 61 FORMAT('M,N,MP,NP,M1,M2,M3 = ',7I8) CALL DPWRST('XXX','BUG ') IF(M.LE.0)GOTO69 IF(N.LE.0)GOTO69 JMAX=NP1 IF(JMAX.GT.10)JMAX=10 DO62I=1,MP2 WRITE(ICOUT,63)I,(A(I,J),J=1,JMAX) 63 FORMAT('I,A(I,.) = ',I8,10F10.2) CALL DPWRST('XXX','BUG ') 62 CONTINUE 69 CONTINUE 90 CONTINUE C C MAKE A CORRECTION (THANKS TO CHRIS WITZGEL, NBS) C ON THE VALUE OF EPSILON C TO CIRCUMVENT A BUG ARISING FROM C A TEST PROBLEM DRAWN FROM C BRONSON/SCHAUM OP. RES. (PROBLEM 1.7). C (SEPT, 1987) C AM=M SUM=0.0 DO1000I=1,M MP1=M+1 SUM=SUM+A(MP1,1) 1000 CONTINUE XBAR=SUM/AM EPSEXP=6.0 IF(XBAR.GT.0.0)EPSEXP=6.0-AINT(ALOG10(XBAR)+0.5) IF(EPSEXP.LT.1.0)EPSEXP=1.0 EPS=10.0**(-EPSEXP) C CCCCC IF(M.NE.M1+M2+M3)PAUSE 'Bad input constraint counts.' IF(M.NE.M1+M2+M3)GOTO110 GOTO119 110 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN SIMPLX--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,112) 112 FORMAT(' BAD INPUT CONSTRAINT COUNTS.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,113)M 113 FORMAT(' M = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,114)M1,M2,M3 114 FORMAT(' M1,M2,M3 = ',3I8) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 119 CONTINUE C NL1=N DO 11 K=1,N L1(K)=K IZROV(K)=K 11 CONTINUE NL2=M DO 12 I=1,M C CCCCC IF(A(I+1,1).LT.0.)PAUSE 'Bad input tableau.' IF(A(I+1,1).LT.0.)GOTO120 GOTO129 120 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,121) 121 FORMAT('***** ERROR IN SIMPLX--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,122) 122 FORMAT(' BAD INPUT TABLEAU.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,123) 123 FORMAT(' POSSIBLE CAUSE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,124) 124 FORMAT(' SOME CONSTRAINT LIMIT IS NEGATIVE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,125) 125 FORMAT(' (FORBIDDEN IN SIMPLEX METHOD)') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 129 CONTINUE C L2(I)=I IPOSV(I)=N+I 12 CONTINUE C DO 13 I=1,M2 L3(I)=1 13 CONTINUE C IR=0 IF(M2+M3.EQ.0)GO TO 30 IR=1 C DO 15 K=1,N+1 Q1=0. DO 14 I=M1+1,M Q1=Q1+A(I+1,K) 14 CONTINUE A(M+2,K)=-Q1 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'MPLX') 1WRITE(ICOUT,777)K,A(M+2,K) 777 FORMAT('K,A(M+2,K) = ',I8,F10.2) IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'MPLX') 1CALL DPWRST('XXX','BUG ') 15 CONTINUE C 10 CONTINUE CALL SIMP1(A,MP,NP,M+1,L1,NL1,0,KP,BMAX) IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'MPLX')GOTO790 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') DO782I=1,MP2 WRITE(ICOUT,783)I,(A(I,J),J=1,JMAX) 783 FORMAT('I,A(I,.) = ',I8,10F10.2) CALL DPWRST('XXX','BUG ') 782 CONTINUE WRITE(ICOUT,784)IR,BMAX,A(M+2,1),EPS,XBAR 784 FORMAT('IR,BMAX,A(M+2,1),EPS,XBAR = ',I8,4E15.7) CALL DPWRST('XXX','BUG ') 790 CONTINUE C IF(BMAX.LE.EPS.AND.A(M+2,1).LT.-EPS)THEN ICASE=-1 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,211) 211 FORMAT('***** ERROR IN SIMPLX (FROM CODE POINT 211)--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,212) 212 FORMAT(' NO SOLUTION SATISFIES ALL CONSTRAINTS.') CALL DPWRST('XXX','BUG ') IERROR='YES' CCCCC RETURN GOTO9000 C ELSE IF(BMAX.LE.EPS.AND.A(M+2,1).LE.EPS)THEN M12=M1+M2+1 IF(M12.LE.M)THEN DO 16 IP=M12,M IF(IPOSV(IP).EQ.IP+N)THEN CALL SIMP1(A,MP,NP,IP,L1,NL1,1,KP,BMAX) IF(BMAX.GT.0.)GO TO 1 ENDIF 16 CONTINUE ENDIF IR=0 M12=M12-1 IF(M1+1.GT.M12)GO TO 30 C DO 18 I=M1+1,M12 IF(L3(I-M1).EQ.1)THEN DO 17 K=1,N+1 A(I+1,K)=-A(I+1,K) 17 CONTINUE ENDIF 18 CONTINUE C GO TO 30 ENDIF CALL SIMP2(A,M,N,MP,NP,L2,NL2,IP,KP,Q1) IF(IP.EQ.0)THEN ICASE=-1 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,221) 221 FORMAT('***** ERROR IN SIMPLX (FROM CODE POINT 221)--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,222) 222 FORMAT(' NO SOLUTION SATISFIES ALL CONSTRAINTS.') CALL DPWRST('XXX','BUG ') IERROR='YES' CCCCC RETURN GOTO9000 ENDIF C 1 CONTINUE CALL SIMP3(A,MP,NP,M+1,N,IP,KP) IF(IPOSV(IP).GE.N+M1+M2+1)THEN DO 19 K=1,NL1 IF(L1(K).EQ.KP)GO TO 2 19 CONTINUE 2 CONTINUE NL1=NL1-1 DO 21 IS=K,NL1 L1(IS)=L1(IS+1) 21 CONTINUE ELSE IF(IPOSV(IP).LT.N+M1+1)GO TO 20 KH=IPOSV(IP)-M1-N IF(L3(KH).EQ.0)GO TO 20 L3(KH)=0 ENDIF A(M+2,KP+1)=A(M+2,KP+1)+1. DO 22 I=1,M+2 A(I,KP+1)=-A(I,KP+1) 22 CONTINUE 20 CONTINUE IS=IZROV(KP) IZROV(KP)=IPOSV(IP) IPOSV(IP)=IS IF(IR.NE.0)GO TO 10 30 CONTINUE CALL SIMP1(A,MP,NP,0,L1,NL1,0,KP,BMAX) IF(BMAX.LE.0.)THEN ICASE=0 CCCCC RETURN GOTO9000 ENDIF CALL SIMP2(A,M,N,MP,NP,L2,NL2,IP,KP,Q1) IF(IP.EQ.0)THEN ICASE=1 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,231) 231 FORMAT('***** ERROR IN SIMPLX--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,232) 232 FORMAT(' OBJECTIVE FUNCTION UNBOUNDED IN THIS REGION.') CALL DPWRST('XXX','BUG ') IERROR='YES' CCCCC RETURN GOTO9000 ENDIF CALL SIMP3(A,MP,NP,M,N,IP,KP) GO TO 20 C 9000 CONTINUE IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'MPLX')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF SIMPLX--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,ISUBRO 9012 FORMAT('IBUGA3,ISUBRO = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9021)M,N,MP,NP,M1,M2,M3,MP1,NP1 9021 FORMAT('M,N,MP,NP,M1,M2,M3,MP1,NP1 = ',9I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9022)ICASE 9022 FORMAT('ICASE = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9023)XBAR,EPS 9023 FORMAT('XBAR,EPS = ',2E15.7) CALL DPWRST('XXX','BUG ') IF(M.LE.0)GOTO9039 IF(N.LE.0)GOTO9039 JMAX=NP1 IF(JMAX.GT.10)JMAX=10 DO9032I=1,MP1 WRITE(ICOUT,9033)I,(A(I,J),J=1,JMAX) 9033 FORMAT('I,A(I,.) = ',I8,10F10.2) CALL DPWRST('XXX','BUG ') 9032 CONTINUE 9039 CONTINUE DO9041I=1,M WRITE(ICOUT,9042)I,IPOSV(I) 9042 FORMAT('I,IPOSV(I) = ',2I8) CALL DPWRST('XXX','BUG ') 9041 CONTINUE DO9051I=1,N WRITE(ICOUT,9052)I,IZROV(I) 9052 FORMAT('I,IZROV(I) = ',2I8) CALL DPWRST('XXX','BUG ') 9051 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE SIMP1(A,MP,NP,MM,LL,NLL,IABF,KP,BMAX) C C PURPOSE-- C C SOURCE--NUMERICAL RECIPES, C PRESS, FLANNERY, TEUKOLSKY, AND VETTERLING, C CAMBRIDGE UNIVERSITY PRESS, 1986. C C C--------------------------------------------------------------------- C DIMENSION A(MP,NP),LL(NP) C C-----START POINT----------------------------------------------------- C KP=LL(1) BMAX=A(MM+1,KP+1) IF(NLL.LT.2)RETURN DO 11 K=2,NLL IF(IABF.EQ.0)THEN TEST=A(MM+1,LL(K)+1)-BMAX ELSE TEST=ABS(A(MM+1,LL(K)+1))-ABS(BMAX) ENDIF IF(TEST.GT.0.)THEN BMAX=A(MM+1,LL(K)+1) KP=LL(K) ENDIF 11 CONTINUE C RETURN END SUBROUTINE SIMP2(A,M,N,MP,NP,L2,NL2,IP,KP,Q1) C C PURPOSE-- C C SOURCE--NUMERICAL RECIPES, C PRESS, FLANNERY, TEUKOLSKY, AND VETTERLING, C CAMBRIDGE UNIVERSITY PRESS, 1986. C C--------------------------------------------------------------------- C PARAMETER (EPS=1.E-6) DIMENSION A(MP,NP),L2(MP) C C-----START POINT----------------------------------------------------- C IP=0 IF(NL2.LT.1)RETURN DO 11 I=1,NL2 IF(A(L2(I)+1,KP+1).LT.-EPS)GO TO 2 11 CONTINUE RETURN 2 Q1=-A(L2(I)+1,1)/A(L2(I)+1,KP+1) IP=L2(I) IF(I+1.GT.NL2)RETURN DO 13 I=I+1,NL2 II=L2(I) IF(A(II+1,KP+1).LT.-EPS)THEN Q=-A(II+1,1)/A(II+1,KP+1) IF(Q.LT.Q1)THEN IP=II Q1=Q ELSE IF (Q.EQ.Q1) THEN DO 12 K=1,N QP=-A(IP+1,K+1)/A(IP+1,KP+1) Q0=-A(II+1,K+1)/A(II+1,KP+1) IF(Q0.NE.QP)GO TO 6 12 CONTINUE 6 IF(Q0.LT.QP)IP=II ENDIF ENDIF 13 CONTINUE C RETURN END SUBROUTINE SIMP3(A,MP,NP,I1,K1,IP,KP) C C PURPOSE-- C C SOURCE--NUMERICAL RECIPES, C PRESS, FLANNERY, TEUKOLSKY, AND VETTERLING, C CAMBRIDGE UNIVERSITY PRESS, 1986. C C--------------------------------------------------------------------- C DIMENSION A(MP,NP) C C-----START POINT----------------------------------------------------- C PIV=1./A(IP+1,KP+1) IF(I1.GE.0)THEN DO 12 II=1,I1+1 IF(II-1.NE.IP)THEN A(II,KP+1)=A(II,KP+1)*PIV DO 11 KK=1,K1+1 IF(KK-1.NE.KP)THEN A(II,KK)=A(II,KK)-A(IP+1,KK)*A(II,KP+1) ENDIF 11 CONTINUE ENDIF 12 CONTINUE ENDIF DO 13 KK=1,K1+1 IF(KK-1.NE.KP)A(IP+1,KK)=-A(IP+1,KK)*PIV 13 CONTINUE A(IP+1,KP+1)=PIV C RETURN END SUBROUTINE SIMRAT $ (U1, S1, V1, IQ, W, NBCH, NTOT, NPAR, NREP, IRK, $ XNCP, CONF, WK1, WK2, VALS, QUANT,IERROR) C C MARK VANGEL, APRIL 1995 C C SIMULATE THE PIVOTAL RATIO IN THE LIMIT OF ZERO C WITHIN-GROUP VARIANCE. C C SINGULAR VALUE DECOMPOSITION OF THE DEISGN MATRIX: C U1, S1, V1 --- (INPUT, D.P.) C IQ --- BATCH INDICATOR (INPUT, INT., LENGTH `NBCH') C W --- VECTOR OF COEFFICIENTS OF POINT AT WHICH TOL. C LIM. IS TO BE CALCULATED (INPUT, D.P., LENGTH `NREP') C NBCH --- NUMBER OF BATCHES (INPUT, INT.) C NTOT --- TOTAL NUMBER OF DATA VALUES (INPUT, INT.) C NPAR --- NUMBER OF REGRESSION COEFFICIENTS (INPUT, INT.) C NREP --- NUMBER OF SIMULATION REPLICATES (INPUT, INT.) C IRK --- RANK OF DESIGN MATRIX (INPUT, INT.) C XNCP --- NONCENTRALITY PARAMETER (Z_{\BETA}) (INPUT,D.P.) C CONF --- CONFIDENCE LEVEL (INPUT, D.P.) C WK1 --- WORK ARRAY (OUTPUT, D.P., LENGTH MAX(NBCH, IRK)) C WK2 --- WORK ARRAY (OUTPUT, D.P., LENGTH NTOT) C VALS --- ARRAY OF SIM. VALUES (OUTPUT, D.P., LENGTH NREP) C QUANT --- ESTIMATED QUANTILE (OUPUT, D.P.) C IMPLICIT DOUBLE PRECISION (A-H, O-Z) CCCCC REAL RNOR REAL XTMP(1) CHARACTER*4 IERROR DIMENSION U1(1), S1(1), V1(1), IQ(1), W(1), WK1(1), $ WK2(1), VALS(1) DATA ZERO, ONE /0.D0, 1.D0/ C C -- LOOP OVER `NREP' REPLICATES NRAN=1 DO 100 ISIM=1, NREP C C -- GENERATE ONE N(0,1) R.V. FOR EACH LEVEL OF RANDOM C EFFECT. DO 10 I=1, NBCH CCCCC WK1(I) = RNOR(0) CALL NORRAN(NRAN,ISEED,XTMP) WK1(I)=DBLE(XTMP(1)) 10 CONTINUE C C -- CREATE PSEUDO-RANDOM DATA FOR \SIGMA_{E}^2 = 0 CASE DO 20 I=1, NTOT WK2(I) = WK1(IQ(I)) 20 CONTINUE Y2 = DDOT (NTOT, WK2, 1, WK2, 1) C C -- FORM VECTOR Q = (U^T)Y CALL DGEMV ('T', NTOT, IRK, ONE, U1, NTOT, $ WK2, 1, ZERO, WK1, 1, IERROR) IF(IERROR.EQ.'YES')RETURN Q2 = DDOT (IRK, WK1, 1, WK1, 1) C C -- FORM VECTOR W = (V^T)W CALL DGEMV ('T', NPAR, NTOT, ONE, V1, NPAR, $ W, 1, ZERO, WK2, 1, IERROR) IF(IERROR.EQ.'YES')RETURN C C -- CALCULATE W^T(L^(-))Q, WHERE L IS MATRIX OF SVS XNUM = 0 DO 30 I=1, IRK XNUM = XNUM +WK2(I) *WK1(I) /S1(I) 30 CONTINUE C C -- CALCULATE RESIDUAL SUM OF SQUARES RSS = Y2 -Q2 C C -- FINALLY, FORM RATIO AND RETURN VALS (ISIM) = (XNUM+XNCP) /SQRT(RSS/(NTOT -IRK)) 100 CONTINUE C C -- SORT THE SIMULATED PIVOT VALUES CALL DSORT (VALS, DUM, NREP, 1, IERROR) C C -- RETURN THE DESIRED QUANTILE IDX = CONF*NREP QUANT = VALS(IDX) RETURN END SUBROUTINE SINFIT(X,TEMP,N,IWRITE,XSINFR,XSINAM,XRESSD, 1ISUBRO,IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C SINUSOIDAL FREQUENCY ESTIMATE C AND THE SINUSOIDAL AMPLITUDE ESTIMATE C OF THE DATA IN THE INPUT VECTOR X. C THE FREQUENCY AND AMPLITUDE ESTIMATE = C THAT APPROXIMATE LEAST SQUARES FIT FREQUENCY AND AMP. C WHICH BEST FITS THE DATA IN A 1-FREQUENCY SIN MODEL. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF C (UNSORTED) OBSERVATIONS. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X. C OUTPUT ARGUMENTS--XSINFR = THE SINGLE PRECISION VALUE OF THE C COMPUTED SAMPLE AUTOCOVARIANCE C COEFFICIENT. C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE C SINUSOIDAL FREQUENCY ESTIMATE AND AMPLITUDE ESTIMATE. 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 REFERENCE--BLOOMFIELD, PETER, FOURIER ANALYSIS OF TIME SERIES: C AN INTRODUCTION, WILEY, 1976, PAGES 14 AND 18. 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 (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--88/1 C ORIGINAL VERSION--JANUARY 1988. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 ISUBRO CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DOUBLE PRECISION DN DOUBLE PRECISION DX CCCCC DOUBLE PRECISION DX1 CCCCC DOUBLE PRECISION DX2 DOUBLE PRECISION DSUM DOUBLE PRECISION DMEAN C DIMENSION X(*) 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='SINF' ISUBN2='IT ' C IERROR='NO' C PI=3.1415926 C DN=0.0D0 DMEAN=0.0D0 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 SINFIT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)ISUBRO,IBUGA3 52 FORMAT('ISUBRO,IBUGA3 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N 53 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,X(I) 56 FORMAT('I,X(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ******************************************* C ** COMPUTE APPROX. LEAST SQUARES FIT C ** ESTIMATE OF UENCY C ** IN A 1-TERM SINUSOIDAL MODEL. 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 SINFIT--') 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 FREQUENCY 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 SINFIT--', 1'THE SECOND INPUT ARGUMENT (N) HAS THE VALUE 1') CALL DPWRST('XXX','BUG ') XSINFR=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 SINFIT--', 1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','BUG ') XSINFR=0.0 GOTO9000 139 CONTINUE C 190 CONTINUE C C ************************************************ C ** STEP 2-- ** C ** COMPUTE THE APPROXIMATE LEAST SQUARES C ** SINUSOIDAL FREQUENCY ESTIMATE C ************************************************ C DN=N DSUM=0.0D0 DO200I=1,N DX=X(I) DSUM=DSUM+DX 200 CONTINUE DMEAN=DSUM/DN XMEAN=DMEAN C DO300I=1,N TEMP(I)=X(I)-XMEAN 300 CONTINUE C SSQHOL=CPUMAX NLOOP=100 ANLOOP=NLOOP DO500IANGLE=1,NLOOP AANGLE=IANGLE THETA=AANGLE/(2.0*ANLOOP) OMEGA=2.0*PI*THETA C SUM1=0.0 SUM2=0.0 DO550I=1,N AI=I SUM1=SUM1+X(I)*COS(OMEGA*AI) SUM2=SUM2+X(I)*SIN(OMEGA*AI) 550 CONTINUE A=(2.0/AN)*SUM1 B=(2.0/AN)*SUM2 AMP=A*A+B*B IF(AMP.GT.0.0)AMP=SQRT(AMP) C SSQ=0.0 DO560I=1,N AI=I PREDI=A*COS(OMEGA*AI)+B*SIN(OMEGA*AI) RESI=TEMP(I)-PREDI SSQ=SSQ+RESI**2 560 CONTINUE C IF(IANGLE.LE.1)GOTO561 GOTO562 561 CONTINUE FREHOL=THETA AMPHOL=AMP SSQHOL=SSQ GOTO569 562 CONTINUE IF(SSQ.LT.SSQHOL)FREHOL=THETA IF(SSQ.LT.SSQHOL)AMPHOL=AMP IF(SSQ.LT.SSQHOL)SSQHOL=SSQ GOTO569 569 CONTINUE IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NFIT') 1WRITE(ICOUT,563)AANGLE,THETA,SSQ,SSQHOL,A,B,AMP 563 FORMAT('AANGLE,THETA,SSQ,SSQHOL,A,B,AMP = ',7E12.4) IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NFIT') 1CALL DPWRST('XXX','BUG ') C 500 CONTINUE XSINFR=FREHOL XSINAM=AMPHOL RESSD=SSQHOL/(AN-2.0) IF(RESSD.GT.0.0)RESSD=SQRT(RESSD) C IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NFIT') 1WRITE(ICOUT,591)XSINFR,XSINAM,XRESSD 591 FORMAT('XSINFR,XSINAM,XRESSD = ',3E15.7) IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'NFIT') 1CALL DPWRST('XXX','BUG ') 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,XSINFR 811 FORMAT('THE SINUSOIDAL FREQUENCY ESTIMATE FOR THE ',I8, 1' OBSERVATIONS = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,812)N,XSINAM 812 FORMAT('THE SINUSOIDAL AMPLITUDE ESTIMATE FOR THE ',I8, 1' OBSERVATIONS = ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,813)XRESSD 813 FORMAT('THE RESIDUAL STANDARD DEVIATION = ',E15.7) CALL DPWRST('XXX','BUG ') 890 CONTINUE 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 SINFIT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)ISUBRO,IBUGA3,IERROR 9012 FORMAT('ISUBRO,IBUGA3,IERROR = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N 9013 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)DN,DMEAN 9014 FORMAT('DN,DMEAN = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)XSINFR,XSINAM,XRESSD 9015 FORMAT('XSINFR,XSINAM,XRESSD = ',3E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE SINTRA(Y1,N1,IWRITE,Y2,N2,IBUGA3,IERROR) C C PURPOSE--COMPUTE SINE TRANSFORM OF A VARIABLE-- C = THE COEFFICIENTS OF THE SINE TERM C IN THE FINITE FOURIER RESPRESENTATION OF THE DATA IN Y1. C Y2(1) = B0 = 0 C Y2(2) = B1 C Y2(3) = B2 C ETC. C NOTE--IT IS NOT PERMISSIBLE TO HAVE THE OUTPUT VECTOR Y2(.) C BEING IDENTICAL TO THE INPUT VECTOR Y1(.). 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--85/1 C ORIGINAL VERSION--DECEMBER 1984. 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-----DOUBLE PRECISION STATEMENTS FOR NON-COMMON VARIABLES------------------- C DOUBLE PRECISION DPI DOUBLE PRECISION DN1 DOUBLE PRECISION DDEL DOUBLE PRECISION DI DOUBLE PRECISION DSUM DOUBLE PRECISION DK DOUBLE PRECISION DOMEGA DOUBLE PRECISION DY1K C C--------------------------------------------------------------------- C DIMENSION Y1(*) DIMENSION Y2(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT 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='SINT' ISUBN2='RA ' C IERROR='NO' C N1HALF=(-999) IMAX=(-999) IEVODD=(-999) DDEL=(-999.0D0) C DN1=N1 C DPI=3.14159265358979D0 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 SINTRA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',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) 56 FORMAT('I,Y1(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C *********************************** C ** COMPUTE SINE TRANSFORM. ** 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 SINTRA--') 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 ') WRITE(ICOUT,1154) 1154 FORMAT(' THE SINE TRANSFORM IS TO BE COMPUTED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1155) 1155 FORMAT(' MUST BE 1 OR LARGER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1156) 1156 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1157)N1 1157 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 1'.') CALL DPWRST('XXX','BUG ') GOTO9000 C 1190 CONTINUE C N1HALF=N1/2 N1HALP=N1HALF+1 IMAX=N1HALP IEVODD=N1-2*(N1/2) DDEL=(DN1+1.0D0)/2.0D0 IF(IEVODD.EQ.0)DDEL=(DN1+2.0D0)/2.0D0 C J=0 J=J+1 Y2(J)=0.0 C DO1210IP1=2,IMAX J=J+1 I=IP1-1 DI=I CCCCC FREQI=DI/DN1 DSUM=0.0D0 C DO1220K=1,N1 DK=K DOMEGA=2.0*DPI*(DI/DN1) DY1K=Y1(K) DSUM=DSUM+DY1K*DSIN(DOMEGA*(DK-DDEL)) 1220 CONTINUE COEF=DSUM/DN1 IF(IBUGA3.EQ.'ON')WRITE(ICOUT,1221)J,I,DN1,DI,COEF 1221 FORMAT('J,I,DN1,DI,COEF = ',I8,I8,2D15.7,E15.7) IF(IBUGA3.EQ.'ON')CALL DPWRST('XXX','BUG ') C Y2(J)=COEF C 1210 CONTINUE C N2=J 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 SINTRA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA3,IERROR 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)N1,N2,N1HALF,IMAX,IEVODD,DDEL 9013 FORMAT('N1,N2,N1HALF,IMAX,IEVODD,DDEL = ',5I8,D15.7) CALL DPWRST('XXX','BUG ') DO9015I=1,N1 WRITE(ICOUT,9016)I,Y1(I),Y2(I) 9016 FORMAT('I,Y1(I),Y2(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE SIZE(X,N,IWRITE,XSIZE,IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C SAMPLE SIZE C OF THE DATA IN THE INPUT VECTOR X. C THE SAMPLE SIZE IS IDENTICALLY = THE INPUT ARGUMENT N C EXCEPT N IS AN INTEGER VARIABLE C WHEREAS THE OUTPUTTED XSIZE IS A SINGLE PRECISION VARIABLE. 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--XSIZE = THE SINGLE PRECISION VALUE OF THE C COMPUTED SAMPLE SIZE. C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE C SAMPLE SIZE; THAT IS, A SINGLE PRECISION REPRESENTATION C OF THE INTEGER INPUT VARIABLE N. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--NONE. C NOTE--ALTHOUGH THIS SUBROUTINE DOES NOTHING C EXCEPT FORM THE SINGLE PRECISION VARIABLE XSIZE C WHICH IS EQUAL TO THE INTEGER INPUT VARIABLE N, C IT EXISTS AND HAS THE ARGUMENT STRUCTURE C THAT IT DOES SO AS TO HAVE AN IDENTICAL C CALLING SEQUENCE WITH MOST OF THE OTHER C SUBROUTINES IN THE INDIVIDUAL STATISTICS C CATEGORY OF THE DATAPAC LIBRARY. C THIS IS DESIRABLE FOR THE USE OF THE C SUBSET STATISTICS SUBROUTINES SSTAT1, SSTAT2, SSTAT3, ... C WHICH CARRY AN INDIVIDUAL STATISTICS CATEGORY SUBROUTINE C NAME (E. G., MEAN, MEDIAN, SD, RANGE, SIZE, ETC.) C AS ITS FIRST INPUT ARGUMENT SO AS TO SPECIFY C WHAT STATISTIC IS TO BE COMPUTED FOR THE SUBSETS OF 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 (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--82.6 C ORIGINAL VERSION--JUNE 1977. C UPDATED --JUNE 1979. C UPDATED --AUGUST 1981. C UPDATED --MARCH 1982. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C 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='SIZE' 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 SIZE--') 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 SIZE ** C ******************** C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C CCCCC AN=N C CCCCC IF(N.GE.1)GOTO119 CCCCC IERROR='YES' CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,111) CC111 FORMAT('***** ERROR IN SIZE--') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,112) CC112 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,113) CC113 FORMAT(' IN THE VARIABLE FOR WHICH') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,114) CC114 FORMAT(' THE SAMPLE SIZE IS TO BE COMPUTED') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,115) CC115 FORMAT(' MUST BE 1 OR LARGER.') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,116) CC116 FORMAT(' SUCH WAS NOT THE CASE HERE.') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,117)N CC117 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, CCCCC1'.') CCCCC CALL DPWRST('XXX','BUG ') CCCCC GOTO9000 CC119 CONTINUE C CCCCC IF(N.LE.1)GOTO120 CCCCC GOTO129 CC120 CONTINUE CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,121)N CC121 FORMAT('***** NON-FATAL DIAGNOSTIC IN SIZE--', CCCCC1'THE SECOND INPUT ARGUMENT (N) HAS THE VALUE ',I8) CCCCC CALL DPWRST('XXX','BUG ') CCCCC XSIZE=N CCCCC GOTO9000 CC129 CONTINUE C CCCCC HOLD=X(1) CCCCC DO135I=2,N CCCCC IF(X(I).NE.HOLD)GOTO139 CC135 CONTINUE CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,136)HOLD CC136 FORMAT('***** NON-FATAL DIAGNOSTIC IN SIZE--', CCCCC1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) CCCCC CALL DPWRST('XXX','BUG ') CCCCC XSIZE=N CCCCC GOTO9000 CC139 CONTINUE C CC190 CONTINUE C C ******************************** C ** STEP 2-- ** C ** COMPUTE THE SAMPLE SIZE. ** C ******************************** C XSIZE=N 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,XSIZE 811 FORMAT('THE SAMPLE SIZE 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 SIZE--') 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)XSIZE 9015 FORMAT('XSIZE = ',E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE SLACDF(X,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION FROM THE THE SLASH DISTIBUTION WITH C LOCATION = 0 AND SCALE = 1. THIS DISTRIBUTION IS C DEFINED FOR ALL X AND HAS THE PROBABILITY DENSITY C FUNCTION C F(X) = NORPDF(0) - NORPDF(X))/[X**2] X <> 0 C 0.5*NORPDF(0) X = 0 C WHERE NORPDF IS THE PDF OF THE STANDARD NORMAL C DISTRIBUTION. THE CUMULATIVE DISTRIBUTION IS C COMPUTED BY CALLING THE QAGI (FROM QUADPACK) C INTEGRATION ROUTINE. 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--DQAGI. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, BALKRISHNAN, "CONTINUOUS UNIVARIATE C DISTRIBUTIONS, VOLUME 1", WILEY, 1994 (PAGE 63). 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 INTEGER LIMIT INTEGER LENW PARAMETER(LIMIT=100) PARAMETER(LENW=4*LIMIT) INTEGER INF INTEGER NEVAL INTEGER IER INTEGER LAST INTEGER IWORK(LIMIT) REAL X REAL CDF DOUBLE PRECISION EPSABS DOUBLE PRECISION EPSREL DOUBLE PRECISION RESULT DOUBLE PRECISION DCDF DOUBLE PRECISION DX DOUBLE PRECISION ABSERR DOUBLE PRECISION WORK(LENW) C DOUBLE PRECISION SLAFUN EXTERNAL SLAFUN C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT 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 INF=-1 EPSABS=0.0D0 EPSREL=1.0D-7 IER=0 DCDF=0.0D0 C C NOTE: FOR X > 0, COMPUTE 1 - SLACDF(-X) FOR EFFICIENCY (INTEGRATING C OVER A SMALLER RANGE) AND GREATER ACCURACY. C IFLAG=0 DX=DBLE(X) IF(DX.GT.0.0D0)THEN IFLAG=1 DX=-DX ENDIF C CALL DQAGI(SLAFUN,DX,INF,EPSABS,EPSREL,DCDF,ABSERR,NEVAL, 1 IER,LIMIT,LENW,LAST,IWORK,WORK) C IF(IFLAG.EQ.0)THEN CDF=REAL(DCDF) ELSE DCDF=1.0D0 - DCDF CDF=REAL(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 SLACDF--') 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 SLACDF--') 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 SLACDF--') 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 SLACDF--') 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 SLACDF--') 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 SLACDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,163) 163 FORMAT(' INVALID INPUT TO THE INTEGRATION ROUTINE.') CALL DPWRST('XXX','BUG ') ENDIF C 9999 CONTINUE RETURN END DOUBLE PRECISION FUNCTION SLAFUN(DX) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION FROM THE THE SLASH DISTIBUTION WITH C LOCATION = 0 AND SCALE = 1. IDENTICAL TO SLAPDF, C BUT DEFINE AS FUNCTION TO BE USED FOR INTEGRATION C CODE CALLED BY SLACDF. C INPUT ARGUMENTS--DX = THE DOUBLE PRECISION VALUE AT C WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY C FUNCTION VALUE SLAFUN. C PRINTING--NONE. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--NODPDF. C FORTRAN LIBRARY SUBROUTINES NEEDED--EXP. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, BALKRISHNAN, "CONTINUOUS UNIVARIATE C DISTRIBUTIONS, VOLUME 1", WILEY, 1994 (PAGE 63). 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 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DX DOUBLE PRECISION DPDF C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C C TRANSFORM THE NORMAL PDF C CALL NODPDF(DX,DTERM3) C IF(DX.EQ.0.0D0)THEN DPDF=0.5D0*DTERM3 ELSE CALL NODPDF(0.0D0,DTERM2) DPDF=(DTERM2 - DTERM3)/(DX*DX) ENDIF C SLAFUN=DPDF C 9999 CONTINUE RETURN END REAL FUNCTION SLAFU2(X) C C PURPOSE--SLAPPF CALLS FZERO TO FIND A ROOT FOR THE PERCENT C POINT FUNCTION. SLAFU2 IS THE FUNCTION FOR WHICH C THE ZERO IS FOUND. IT IS: C P - SLACDF(X) 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 SLAFU2. C PRINTING--NONE. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--SLACDF. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, BALKRISHNAN, "CONTINUOUS UNIVARIATE C DISTRIBUTIONS, VOLUME 1", WILEY, 1994 (PAGE 63). 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/SLACOM/P C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT 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 SLACDF(X,CDF) SLAFU2=P - CDF C 9999 CONTINUE RETURN END SUBROUTINE SLAPDF(X,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION FROM THE THE SLASH DISTIBUTION WITH C LOCATION = 0 AND SCALE = 1. THIS DISTRIBUTION IS C DEFINED FOR ALL X AND HAS THE PROBABILITY DENSITY C FUNCTION C F(X) = NORPDF(0) - NORPDF(X))/[X**2] X <> 0 C 0.5*NORPDF(0) X = 0 C WHERE NORPDF IS THE PDF OF THE STANDARD NORMAL C DISTRIBUTION. 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--NODPDF. C FORTRAN LIBRARY SUBROUTINES NEEDED--EXP. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--JOHNSON, KOTZ, BALKRISHNAN, "CONTINUOUS UNIVARIATE C DISTRIBUTIONS, VOLUME 1", WILEY, 1994 (PAGE 63). 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.1 C ORIGINAL VERSION--JANUARY 2003. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DX DOUBLE PRECISION DPDF C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C C TRANSFORM THE NORMAL PDF C DX=DBLE(X) CALL NODPDF(DX,DTERM3) C IF(X.EQ.0.0)THEN DPDF=0.5D0*DTERM3 PDF=REAL(DPDF) ELSE CALL NODPDF(0.0D0,DTERM2) DPDF=(DTERM2 - DTERM3)/(DX*DX) PDF=REAL(DPDF) ENDIF C C 9999 CONTINUE RETURN END SUBROUTINE SLAPPF(P,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION OF THE THE SLASH DISTIBUTION WITH C LOCATION = 0 AND SCALE = 1. THIS DISTRIBUTION IS C DEFINED FOR ALL X AND HAS THE PROBABILITY DENSITY C FUNCTION C F(X) = NORPDF(0) - NORPDF(X))/[X**2] X <> 0 C 0.5*NORPDF(0) X = 0 C WHERE NORPDF IS THE PDF OF THE STANDARD NORMAL C DISTRIBUTION. THE PERCENT POINT FUNCTION IS C COMPUTED BY CALLING THE FZERO ROUTINE TO FIND THE C ROOT OF P - SLACDF(X) WHERE SLACDF IS THE CUMULATIVE C DISTRIBUTION FUNCTION OF THE SLASH DISTRIBUTION. C INPUT ARGUMENTS--P = THE SINGLE PRECISION VALUE AT C WHICH THE PERCENT POINT C FUNCTION IS TO BE EVALUATED. 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, BALKRISHNAN, "CONTINUOUS UNIVARIATE C DISTRIBUTIONS, VOLUME 1", WILEY, 1994 (PAGE 63). 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 PPF C REAL SLAFU2 EXTERNAL SLAFU2 C REAL P2 COMMON/SLACOM/P2 C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT 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.LE.0.0.OR.P.GE.1.0)THEN WRITE(ICOUT,61) 61 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT ', 1 'TO THE SLAPPF 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 ELSE XTEMP=675000. CALL SLACDF(-XTEMP,PLOW) CALL SLACDF(XTEMP,PUPP) IF(P.LT.PLOW .OR. P.GT.PUPP)THEN WRITE(ICOUT,71) 71 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT ', 1 'TO THE SLAPPF SUBROUTINE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,72) 72 FORMAT(' IS OUTSIDE THE INTERVAL (',G15.7,',',G15.7, 1 ') INTERVAL, UNABLE TO COMPUTE PPF') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,63)P CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9000 ENDIF ENDIF C C STEP 1: FIND BRACKETING INTERVAL. START WITH FACT THAT SLASH C DISTRIBUTION IS SYMMETRIC ABOUT X = 0. C IF(P.EQ.0.5)THEN PPF=0.0 GOTO9000 ELSEIF(P.GT.0.5)THEN XLOW=0.0 IF(P.LE.0.95)THEN XUP=9.0 ELSEIF(P.LT.0.995)THEN XUP=100. ELSEIF(P.LT.0.9995)THEN XUP=1000. ELSEIF(P.LT.0.99995)THEN XUP=10000. ELSE XUP=675000. ENDIF ELSE XUP=0.0 IF(P.GT.0.05)THEN XLOW=-9.0 ELSEIF(P.GT.0.005)THEN XLOW=-100.0 ELSEIF(P.GT.0.0005)THEN XLOW=-1000. ELSEIF(P.GT.0.00005)THEN XLOW=-10000. ELSE XLOW=-675000. ENDIF ENDIF C P2=P AE=1.E-6 RE=1.E-6 IFLAG=0 CALL FZERO(SLAFU2,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 SLAPPF--') 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 SLAPPF--') 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 SLAPPF--') 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 SLAPPF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,143) 143 FORMAT(' MAXIMUM ITERATIONS EXCEEDED.') CALL DPWRST('XXX','BUG ') ENDIF C 9000 CONTINUE RETURN END SUBROUTINE SLARAN(N,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE THE SLASH DISTIBUTION WITH LOCATION = 0 C AND SCALE = 1. THIS DISTRIBUTION IS DEFINED FOR ALL C X AND HAS THE PROBABILITY DENSITY FUNCTION C F(X) = NORPDF(0) - NORPDF(X))/[X**2] X <> 0 C 0.5*NORPDF(0) X = 0 C WHERE NORPDF IS THE PDF OF THE STANDARD NORMAL C DISTRIBUTION. NOTE THAT THE SLASH DISTRIBUTION IS C THE RATIO OF AN INDEPENDENT STANDARD NORMAL AND C UNIFORM DISTRIBUTIONS. 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 FROM THE SLASH DISTRIBUTION C WITH LOCATION = 0 AND SCALE = 1. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN. C FORTRAN LIBRARY SUBROUTINES NEEDED--ALOG, SQRT, SIN, COS. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C METHOD--TRANSFORM NORMAL RANDOM NUMBERS C REFERENCES--JOHNSON, KOTZ, BALKRISHNAN, "CONTINUOUS UNIVARIATE C DISTRIBUTIONS, VOLUME 1", WILEY, 1994 (PAGE 63). 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.1 C ORIGINAL VERSION--JANUARY 2003. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*) DIMENSION Y(1) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C C GENERATE N NORMAL (0,1) RANDOM NUMBERS; C C C TRANSFORM THE NORMAL RANDOM NUMBERS C NTEMP=1 DO300I=1,N CALL NORRAN(NTEMP,ISEED,Y) TERM1=Y(1) CALL UNIRAN(NTEMP,ISEED,Y) TERM2=Y(1) IF(TERM2.EQ.0.0)THEN CALL UNIRAN(NTEMP,ISEED,Y) TERM2=Y(1) ENDIF X(I)=TERM1/TERM2 300 CONTINUE C 9999 CONTINUE RETURN END function Sn(x,n,y,a2,scrtch) C cc##################################################################### cc###################### file Sn.for : ############################## cc##################################################################### cc cc This file contains a Fortran function for a new robust estimator cc of scale denoted as Sn, proposed in Rousseeuw and Croux (1993). cc The estimator has a high breakdown point and a bounded influence cc function. The algorithm given here is very fast (running in cc O(nlogn) time) and needs only O(n) storage space. cc cc Rousseeuw, P.J. and Croux, C. (1993), "Alternatives to the cc Median Absolute Deviation," Journal of the American cc Statistical Association, Vol. 88, 1273-1283. cc cc A Fortran function for the estimator Qn, described in the same cc paper, is attached below. For both estimators, implementations cc in the Pascal language can be obtained from the authors. cc cc This software may be used and copied freely, provided cc reference is made to the abovementioned paper. cc cc For questions, problems or comments contact: cc cc Peter Rousseeuw (rousse@wins.uia.ac.be) cc Christophe Croux (croux@wins.uia.ac.be) cc Department of Mathematics and Computing cc Universitaire Instelling Antwerpen cc Universiteitsplein 1 cc B-2610 Wilrijk (Antwerp) cc Belgium cc cc-------------------------------------------------------------------- cc cc Efficient algorithm for the scale estimator: cc cc Sn = cn * 1.1926 * LOMED_{i} HIMED_{i} |x_i-x_j| cc cc which can equivalently be written as cc cc Sn = cn * 1.1926 * LOMED_{i} LOMED_{j<>i} |x_i-x_j| cc cc Parameters of the function Sn : cc x : real array containing the observations cc n : number of observations (n>=2) cc cc The function Sn uses the procedures: cc sort(x,n,y) : sorts an array x of length n, and stores the cc result in an array y (of size at least n) cc pull(a,n,k) : finds the k-th order statistic of an cc array a of length n cc cc The function Sn also creates an auxiliary array a2 cc (of size at least n) in which it stores the values cc LOMED_{j<>i} |x_i-x_j| for i=1,...,n cc ccccc dimension x(n),y(1000),a2(1000) dimension x(*),y(*),a2(*),scrtch(*) integer rightA,rightB,tryA,tryB,diff,Amin,Amax,even,half real medA, medB call sort(x,n,y) a2(1)=y(n/2+1)-y(1) do 10 i=2,(n+1)/2 nA=i-1 nB=n-i diff=nB-nA leftA=1 leftB=1 rightA=nB rightB=nB Amin=diff/2+1 Amax=diff/2+nA 15 continue if (leftA.lt.rightA) then length=rightA-leftA+1 even=1-mod(length,2) half=(length-1)/2 tryA=leftA+half tryB=leftB+half if (tryA.lt.Amin) then rightB=tryB leftA=tryA+even else if (tryA.gt.Amax) then rightA=tryA leftB=tryB+even else medA=y(i)-y(i-tryA+Amin-1) medB=y(tryB+i)-y(i) if (medA.ge.medB) then rightA=tryA leftB=tryB+even else rightB=tryB leftA=tryA+even endif endif endif go to 15 endif if (leftA.gt.Amax) then a2(i)=y(leftB+i)-y(i) else medA=y(i)-y(i-leftA+Amin-1) medB=y(leftB+i)-y(i) a2(i)=min(medA,medB) endif 10 continue do 20 i=(n+1)/2+1,n-1 nA=n-i nB=i-1 diff=nB-nA leftA=1 leftB=1 rightA=nB rightB=nB Amin=diff/2+1 Amax=diff/2+nA 25 continue if (leftA.lt.rightA) then length=rightA-leftA+1 even=1-mod(length,2) half=(length-1)/2 tryA=leftA+half tryB=leftB+half if (tryA.lt.Amin) then rightB=tryB leftA=tryA+even else if (tryA.gt.Amax) then rightA=tryA leftB=tryB+even else medA=y(i+tryA-Amin+1)-y(i) medB=y(i)-y(i-tryB) if (medA.ge.medB) then rightA=tryA leftB=tryB+even else rightB=tryB leftA=tryA+even endif endif endif go to 25 endif if (leftA.gt.Amax) then a2(i)=y(i)-y(i-leftB) else medA=y(i+leftA-Amin+1)-y(i) medB=y(i)-y(i-leftB) a2(i)=min(medA,medB) endif 20 continue a2(n)=y(n)-y((n+1)/2) cn=1 if (n.le.9) then if (n.eq.2) cn=0.743 if (n.eq.3) cn=1.851 if (n.eq.4) cn=0.954 if (n.eq.5) cn=1.351 if (n.eq.6) cn=0.993 if (n.eq.7) cn=1.198 if (n.eq.8) cn=1.005 if (n.eq.9) cn=1.131 else if (mod(n,2).eq.1) cn=n/(n-0.9) endif Sn=cn*1.1926*pull(a2,n,(n+1)/2,scrtch) return end SUBROUTINE SNCDF(X,ALMBDA,ISKNDF,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE SKEW-NORMAL DISTRIBUTION C WITH SHAPE PARAMETER = LAMBDA. C THIS DISTRIBUTION IS DEFINED FOR ALL X AND C THE CUMULATIVE DISTRIBUTION IS COMPUTED BY C NUMERICALLY INTEGRATING THE PDF FUNCTION. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C --ALMBDA = THE 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 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--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 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--2003.11 C ORIGINAL VERSION--NOVEMBER 2003. 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 ISKNDF C INTEGER LIMIT INTEGER LENW PARAMETER(LIMIT=100) PARAMETER(LENW=4*LIMIT) INTEGER INF INTEGER NEVAL INTEGER IER INTEGER LAST INTEGER IWORK(LIMIT) REAL X REAL CDF DOUBLE PRECISION EPSABS DOUBLE PRECISION EPSREL DOUBLE PRECISION RESULT DOUBLE PRECISION DCDF DOUBLE PRECISION DX DOUBLE PRECISION ABSERR DOUBLE PRECISION WORK(LENW) C DOUBLE PRECISION SNFUN EXTERNAL SNFUN C DOUBLE PRECISION DLMBDA COMMON/SNCOM/DLMBDA C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT 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 IF(ISKNDF.EQ.'DEFA')THEN INF=-1 EPSABS=0.0D0 EPSREL=1.0D-7 IER=0 CDF=0.0D0 C DX=DBLE(X) DLMBDA=DBLE(ALMBDA) C CALL DQAGI(SNFUN,DX,INF,EPSABS,EPSREL,DCDF,ABSERR,NEVAL, 1 IER,LIMIT,LENW,LAST,IWORK,WORK) C 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 SNCDF--') 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 SNCDF--') 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 SNCDF--') 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 SNCDF--') 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 SNCDF--') 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 SNCDF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,163) 163 FORMAT(' INVALID INPUT TO THE INTEGRATION ROUTINE.') CALL DPWRST('XXX','BUG ') ENDIF C ELSE ENDIF C 9000 CONTINUE RETURN END DOUBLE PRECISION FUNCTION SNFUN(DX) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE SKEW-NORMAL DISTRIBUTION C WITH SHAPE PARAMETER = LAMBDA. C THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS C THE PROBABILITY DENSITY FUNCTION. IDENTICAL TO SLAPDF, C BUT DEFINE AS FUNCTION TO BE USED FOR INTEGRATION C CODE CALLED BY SLACDF. ALSO, THIS ROUTINE USES C DOUBLE PRECISION ARITHMETIC. C SNPDF(X,LAMBDA) = 2*NORCDF(LAMDDA*X)*NORPDF(X) C INPUT ARGUMENTS--DX = THE DOUBLE PRECISION VALUE AT C WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C OUTPUT ARGUMENTS--SNFUN = THE DOUBLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE DOUBLE PRECISION PROBABILITY DENSITY C FUNCTION VALUE PDF FOR THE 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 --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 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 DOUBLE PRECISION DX DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DPDF C DOUBLE PRECISION DLMBDA COMMON/SNCOM/DLMBDA C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT 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 NODCDF(DX*DLMBDA,DTERM1) CALL NODPDF(DX,DTERM2) DPDF=2.0D0*DTERM1*DTERM2 SNFUN=DPDF C 9000 CONTINUE RETURN END REAL FUNCTION SNFU2(X) C C PURPOSE--SNPPF CALLS FZERO TO FIND A ROOT FOR THE PERCENT C POINT FUNCTION. SNFU2 IS THE FUNCTION FOR WHICH C THE ZERO IS FOUND. IT IS: C P - SNCDF(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 SNFU2. C PRINTING--NONE. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--SNCDF. 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 CHARACTER*4 ISKNDF COMMON/SN2COM/P,ISKNDF C DOUBLE PRECISION DLMBDA COMMON/SNCOM/DLMBDA C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT 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 SNCDF(X,REAL(DLMBDA),ISKNDF,CDF) SNFU2=P - CDF C 9999 CONTINUE RETURN END SUBROUTINE SNPDF(X,ALMBDA,ISKNDF,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE SKEW-NORMAL DISTRIBUTION C WITH SHAPE PARAMETER = LAMBDA. C THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS C THE PROBABILITY DENSITY FUNCTION C SNPDF(X,LAMBDA) = 2*NORCDF(LAMDDA*X)*NORPDF(X) 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 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 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--2003.11 C ORIGINAL VERSION--NOVEMBER 2003. 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 ISKNDF C DOUBLE PRECISION DX,DLMBDA 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 ** COMPUTE THE DENSITY FUNCTION ** C ************************************ C DX=DBLE(X) DLMBDA=DBLE(ALMBDA) IF(ISKNDF.EQ.'DEFA')THEN CALL NODCDF(DX*DLMBDA,DTERM1) CALL NODPDF(DX,DTERM2) DPDF=2.0D0*DTERM1*DTERM2 PDF=REAL(DPDF) GOTO9000 ELSE ENDIF C 9000 CONTINUE RETURN END SUBROUTINE SNPPF(P,ALMBDA,ISKNDF,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE SKEW-NORMAL DISTRIBUTION C WITH SHAPE PARAMETER = LAMBDA. C THIS DISTRIBUTION IS DEFINED FOR ALL 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 --ALMBDA = THE 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 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--2003.12 C ORIGINAL VERSION--DECEMBER 2003. 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 ISKNDF C REAL PPF C REAL SNFU2 EXTERNAL SNFU2 C REAL P2 CHARACTER*4 ISNDF2 COMMON/SN2COM/P2,ISNDF2 C DOUBLE PRECISION DLMBDA COMMON/SNCOM/DLMBDA C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT 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.LE.0.0.OR.P.GE.1.0)THEN WRITE(ICOUT,61) 61 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT ', 1 'TO THE SNPPF 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 C STEP 1: FIND BRACKETING INTERVAL. START WITH FACT THAT LAMBDA = 0 C IS THE NORMAL DISTRIBUTION AND THE HALF-NORMAL IS THE C LIMITING DISTRIBUTION AS LAMBDA GOES TO INFINITY. C IF(ALMBDA.EQ.0.0)THEN CALL NORPPF(P,PPF) GOTO9000 ELSE IFLAG2=0 IF(ALMBDA.LT.0.0)IFLAG2=1 P2=P IF(IFLAG2.EQ.1)P2=1.0 - P CALL NORPPF(P2,XLOW) CALL HFNPPF(P2,XUP) ENDIF XLOW=XLOW - 0.2 XUP=XUP + 0.2 C ISNDF2=ISKNDF AE=1.E-6 RE=1.E-6 DLMBDA=DBLE(ALMBDA) IF(IFLAG2.EQ.1)DLMBDA=-DLMBDA IFLAG=0 CALL FZERO(SNFU2,XLOW,XUP,XUP,RE,AE,IFLAG) C PPF=XLOW IF(IFLAG2.EQ.1)PPF=-PPF 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 SNPPF--') 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 SNPPF--') 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 SNPPF--') 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 SNPPF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,143) 143 FORMAT(' MAXIMUM ITERATIONS EXCEEDED.') CALL DPWRST('XXX','BUG ') ENDIF C 9000 CONTINUE RETURN END SUBROUTINE SNRAN(N,ALMBDA,ISKNDF,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE SKEWED NORMAL DISTRIBUTION C WITH SHAPE PARAMETER = ALMBDA. C THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS C THE PROBABILITY DENSITY FUNCTION C SNPDF(X,LAMBDA) = 2*NORCDF(LAMDDA*X)*NORPDF(X) C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --ALMBDA = THE SHAPE (PARAMETER) FOR THE C 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 SKEWED NORMAL DISTRIBUTION C WITH SHAPE PARAMETER = ALMBDA. 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 --"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 --ALGORITHM FOR RANDOM NUMBERS ADAPTED FROM C AZZALINI'S R FUNCTIONS FOR SKEW 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--2003.11 C ORIGINAL VERSION--NOVEMBER 2003. 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 DIMENSION X(*) DIMENSION Y(2) C CHARACTER*4 ISKNDF C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT 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('***** FATAL ERROR--FOR THE 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 ALGORITHM ADAPTED FROM AZZALINI'S R FUNCTION LIBRARY. C IF(ISKNDF.EQ.'DEFA')THEN DO100I=1,N CALL NORRAN(2,ISEED,Y) U1=Y(1) U2=Y(2) ATEMP=ALMBDA*U1 IF(U2.GT.ATEMP)U1=-U1 X(I)=U1 100 CONTINUE ELSE ENDIF C 9999 CONTINUE RETURN END SUBROUTINE STCDF(X,NU,ALMBDA,CDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION C FUNCTION VALUE FOR THE SKEW-T DISTRIBUTION C WITH SHAPE PARAMETERS NU AND LAMBDA. C THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS C THE PROBABILITY DENSITY FUNCTION C STPDF(X,NU,LAMBDA) = 2* C TCDF(LAMBDA*X*SQRT((NU+1)/(X**2+NU)),NU+1)* C TPDF(X,NU) C THE CUMULATIVE DISTRIBUTION IS COMPUTED BY C NUMERICALLY INTEGRATING THE PDF FUNCTION. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT C WHICH THE CUMULATIVE DISTRIBUTION C FUNCTION IS TO BE EVALUATED. C --NU = THE DEGREES OF FREEDOM PARAMETER C --ALMBDA = 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 SKEW-T DISTRIBUTION C WITH SHAPE PARAMETERS NU AND LAMBDA. 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 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--2003.12 C ORIGINAL VERSION--DECEMBER 2003. 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) INTEGER NU REAL X REAL CDF DOUBLE PRECISION EPSABS DOUBLE PRECISION EPSREL DOUBLE PRECISION RESULT DOUBLE PRECISION DCDF DOUBLE PRECISION DX DOUBLE PRECISION ABSERR DOUBLE PRECISION WORK(LENW) C DOUBLE PRECISION STFUN EXTERNAL STFUN C DOUBLE PRECISION DNU DOUBLE PRECISION DLMBDA COMMON/STCOM/DNU,DLMBDA C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT 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 THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C IF(NU.LE.0)THEN WRITE(ICOUT,115) 115 FORMAT('***** FATAL ERROR--THE DEGREES OF FREEDOM SHAPE ', 1 'PARAMETER FOR THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,116) 116 FORMAT(' SKEWED-T DISTRIBUTION IS NON-POSITIVE *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,147)NU 147 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8, 1 ' *****') CALL DPWRST('XXX','BUG ') CDF=0.0 GOTO9000 ENDIF C C ************************************ C ** STEP 1-- ** C ** COMPUTE THE DENSITY FUNCTION ** C ************************************ C INF=-1 EPSABS=0.0D0 EPSREL=1.0D-7 IER=0 CDF=0.0D0 C DX=DBLE(X) DLMBDA=DBLE(ALMBDA) DNU=DBLE(NU) C CALL DQAGI(STFUN,DX,INF,EPSABS,EPSREL,DCDF,ABSERR,NEVAL, 1 IER,LIMIT,LENW,LAST,IWORK,WORK) C 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 STCDF--') 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 STCDF--') 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 STCDF--') 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 STCDF--') 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 STCDF--') 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 STCDF--') 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 STFUN(DX) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE SKEW-T DISTRIBUTION C WITH SHAPE PARAMETERS NU AND LAMBDA. C THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS C THE PROBABILITY DENSITY FUNCTION C STPDF(X,NU,LAMBDA) = 2* C TCDF(LAMBDA*X*SQRT((NU+1)/(X**2+NU)),NU+1)* C TPDF(X,NU) C IDENTICAL TO TNPDF, C BUT DEFINE AS FUNCTION TO BE USED FOR INTEGRATION C CODE CALLED BY TNCDF. ALSO, THIS ROUTINE USES C DOUBLE PRECISION ARITHMETIC. C INPUT ARGUMENTS--DX = THE DOUBLE PRECISION VALUE AT C WHICH THE PROBABILITY DENSITY C FUNCTION IS TO BE EVALUATED. C OUTPUT ARGUMENTS--STFUN = 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 NU AND 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 --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 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 DOUBLE PRECISION DX DOUBLE PRECISION DZ DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 C DOUBLE PRECISION DNU DOUBLE PRECISION DLMBDA COMMON/STCOM/DNU,DLMBDA C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT 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 NU=INT(DNU+0.5) DZ=DLMBDA*DX*DSQRT((DNU+1.0D0)/(DX**2+DNU)) CALL TDCDF(DZ,NU+1,DTERM1) CALL TDPDF(DX,NU,DTERM2) STFUN=2.0D0*DTERM1*DTERM2 C 9000 CONTINUE RETURN END REAL FUNCTION STFU2(X) C C PURPOSE--STPPF CALLS FZERO TO FIND A ROOT FOR THE PERCENT C POINT FUNCTION. STFU2 IS THE FUNCTION FOR WHICH C THE ZERO IS FOUND. IT IS: C P - STCDF(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 STFU2. C PRINTING--NONE. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--STCDF. 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/ST2COM/P C DOUBLE PRECISION DNU DOUBLE PRECISION DLMBDA COMMON/STCOM/DNU,DLMBDA C C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C NU=INT(DNU+0.01D0) CALL STCDF(X,NU,REAL(DLMBDA),CDF) STFU2=P - CDF C 9999 CONTINUE RETURN END SUBROUTINE STPDF(X,NU,ALMBDA,PDF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY C FUNCTION VALUE FOR THE SKEW-T DISTRIBUTION C WITH SHAPE PARAMETERS NU AND LAMBDA. C THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS C THE PROBABILITY DENSITY FUNCTION C STPDF(X,NU,LAMBDA) = 2* C TCDF(LAMBDA*X*SQRT((NU+1)/(X**2+NU)),NU+1)* C TPDF(X,NU) 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 OUTPUT ARGUMENTS--PDF = THE SINGLE PRECISION PROBABILITY C DENSITY FUNCTION VALUE. C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY C FUNCTION VALUE PDF FOR THE SKEWED-T DISTRIBUTION C WITH SHAPE PARAMETERS NU AND LAMBDA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--NONE. C OTHER DATAPAC SUBROUTINES NEEDED--TPDF, TCDF C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--"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--2003.11 C ORIGINAL VERSION--NOVEMBER 2003. C UPDATED --OCTOBER 2006. CALL LIST TO TCDF/TPDF 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,ALMBDAMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C IF(NU.LE.0)THEN WRITE(ICOUT,115) 115 FORMAT('***** FATAL ERROR--THE DEGREES OF FREEDOM SHAPE ', 1 'PARAMETER FOR THE') CALL DPWRST('XXX','BUG ') 116 FORMAT(' SKEWED-T DISTRIBUTION IS NON-POSITIVE *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,147)NU 147 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8, 1 ' *****') CALL DPWRST('XXX','BUG ') PDF=0.0 GOTO9000 ENDIF C C ************************************ C ** STEP 1-- ** C ** COMPUTE THE DENSITY FUNCTION ** C ************************************ C ANU=REAL(NU) Z=ALMBDA*X*SQRT((ANU+1.0)/(X**2+ANU)) CALL TCDF(Z,REAL(NU+1),TERM1) CALL TPDF(X,REAL(NU),TERM2) PDF=2.0D0*TERM1*TERM2 C 9000 CONTINUE RETURN END SUBROUTINE STPPF(P,NU,ALMBDA,PPF) C C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT C FUNCTION VALUE FOR THE SKEW-NORMAL DISTRIBUTION C WITH SHAPE PARAMETER = LAMBDA. C THIS DISTRIBUTION IS DEFINED FOR ALL 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 --NU = THE DEGREES OF FREEDOM PARAMETER C --ALMBDA = THE SKEWNESS 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 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--2003.12 C ORIGINAL VERSION--DECEMBER 2003. C UPDATED --OCTOBER 2006. CALL LIST TO TPPF C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C REAL PPF C REAL STFU2 EXTERNAL STFU2 C REAL P2 COMMON/ST2COM/P2 C DOUBLE PRECISION DNU DOUBLE PRECISION DLMBDA COMMON/STCOM/DNU,DLMBDA C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT 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(NU.LE.0)THEN WRITE(ICOUT,115) 115 FORMAT('***** FATAL ERROR--THE DEGREES OF FREEDOM SHAPE ', 1 'PARAMETER FOR THE') CALL DPWRST('XXX','BUG ') 116 FORMAT(' SKEWED-T DISTRIBUTION IS NON-POSITIVE *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,147)NU 147 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') CALL DPWRST('XXX','BUG ') PPF=0.0 GOTO9000 ENDIF C IF(P.LE.0.0.OR.P.GE.1.0)THEN WRITE(ICOUT,61) 61 FORMAT('***** ERROR--THE FIRST INPUT ARGUMENT ', 1 'TO THE STPPF 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 C STEP 1: FIND BRACKETING INTERVAL. START WITH FACT THAT LAMBDA = 0 C IS THE T DISTRIBUTION AND THE FOLDED-T IS THE C LIMITING DISTRIBUTION AS LAMBDA GOES TO INFINITY. C IF(ALMBDA.EQ.0.0)THEN CALL TPPF(P,REAL(NU),PPF) GOTO9000 ELSE IFLAG2=0 IF(ALMBDA.LT.0.0)IFLAG2=1 P2=P IF(IFLAG2.EQ.1)P2=1.0 - P CALL TPPF(P2,REAL(NU),XLOW) CALL FTPPF(P2,NU,XUP) ENDIF XLOW=XLOW - 0.2 XUP=XUP + 0.2 C AE=1.E-6 RE=1.E-6 DLMBDA=DBLE(ALMBDA) DNU=DBLE(NU) IF(IFLAG2.EQ.1)DLMBDA=-DLMBDA IFLAG=0 CALL FZERO(STFU2,XLOW,XUP,XUP,RE,AE,IFLAG) C PPF=XLOW IF(IFLAG2.EQ.1)PPF=-PPF 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 STPPF--') 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 STPPF--') 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 STPPF--') 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 STPPF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,143) 143 FORMAT(' MAXIMUM ITERATIONS EXCEEDED.') CALL DPWRST('XXX','BUG ') ENDIF C 9000 CONTINUE RETURN END SUBROUTINE STRAN(N,NU,ALMBDA,ISEED,X) C C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N C FROM THE SKEWED T DISTRIBUTION C WITH SHAPE PARAMETERS NU AND ALMBDA. C THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS C THE PROBABILITY DENSITY FUNCTION C STPDF(X,NU,LAMBDA) = 2* C TCDF(LAMBDA*X*SQRT((NU+1)/(X**2+NU)),NU+1)* C TPDF(X,NU) C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER C OF RANDOM NUMBERS TO BE C GENERATED. C --NU = THE FIRST SHAPE PARAMETER C --ALMBDA = 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 SKEWED T DISTRIBUTION C WITH SHAPE PARAMETERS NU AND ALMBDA. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C --NU SHOULD BE A POSITIVE INTEGER. C --ALMBDA CAN BE ANY REAL NUMBER. C OTHER DATAPAC SUBROUTINES NEEDED--CHSRAN, SNRAN. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) 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 REFERENCES--ALGORITHM FOR RANDOM NUMBERS ADAPTED FROM C AZZALINI'S R FUNCTIONS FOR SKEW T. 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.11 C ORIGINAL VERSION--NOVEMBER 2003. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*) DIMENSION Y(1) C CHARACTER*4 ISKNDF C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT 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('***** FATAL ERROR--FOR THE SKEWED T DISTRIBUTION,') 6 FORMAT(' THE REQUESTED NUMBER OF RANDOM NUMBERS WAS ', 1 'NON-POSITIVE.') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') C IF(NU.LE.0)THEN WRITE(ICOUT,115) 115 FORMAT('***** FATAL ERROR--THE DEGREES OF FREEDOM SHAPE ', 1 'PARAMETER FOR THE') CALL DPWRST('XXX','BUG ') 116 FORMAT(' SKEWED-T RANDOM NUMBERS IS NON-POSITIVE *****') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)NU CALL DPWRST('XXX','BUG ') GOTO9999 ENDIF C C ALGORITM ADAPTED FROM AZZALINI'S R FUNCTION LIBRARY. C ISKNDF='DEFA' NTEMP=1 ANU=REAL(NU) DO100I=1,N C CALL SNRAN(1,ALMBDA,ISKNDF,ISEED,Y) Z=Y(1) CALL CHSRAN(1,ANU,ISEED,Y) V=Y(1)/ANU X(I)=Z/SQRT(V) C 100 CONTINUE C 9999 CONTINUE RETURN END REAL FUNCTION SNRM2(N,SX,INCX) C***BEGIN PROLOGUE SNRM2 C***DATE WRITTEN 791001 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D1A3B C***KEYWORDS BLAS,EUCLIDEAN,L2,LENGTH,LINEAR ALGEBRA,NORM,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 Euclidean length (L2 norm) 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 SNRM2 single precision result (zero if N .LE. 0) C C Euclidean norm of the N-vector stored in SX() with storage C increment INCX . C If N .LE. 0, return with result = 0. C If N .GE. 1, then INCX must be .GE. 1 C C C. L. Lawson, 1978 Jan 08 C C Four Phase Method using two built-in constants that are C hopefully applicable to all machines. C CUTLO = maximum of SQRT(U/EPS) over all known machines. C CUTHI = minimum of SQRT(V) over all known machines. C where C EPS = smallest no. such that EPS + 1. .GT. 1. C U = smallest positive no. (underflow limit) C V = largest no. (overflow limit) C C Brief Outline of Algorithm.. C C Phase 1 scans zero components. C Move to phase 2 when a component is nonzero and .LE. CUTLO C Move to phase 3 when a component is .GT. CUTLO C Move to phase 4 when a component is .GE. CUTHI/M C where M = N for X() real and M = 2*N for complex. C C Values for CUTLO and CUTHI.. C From the environmental parameters listed in the IMSL converter C document the limiting values are as follows.. C CUTLO, S.P. U/EPS = 2**(-102) for Honeywell. Close seconds are C Univac and DEC at 2**(-103) C Thus CUTLO = 2**(-51) = 4.44089E-16 C CUTHI, S.P. V = 2**127 for Univac, Honeywell, and DEC. C Thus CUTHI = 2**(63.5) = 1.30438E19 C CUTLO, D.P. U/EPS = 2**(-67) for Honeywell and DEC. C Thus CUTLO = 2**(-33.5) = 8.23181D-11 C CUTHI, D.P. same as S.P. CUTHI = 1.30438D19 C DATA CUTLO, CUTHI / 8.232D-11, 1.304D19 / C DATA CUTLO, CUTHI / 4.441E-16, 1.304E19 / 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 SNRM2 INTEGER NEXT REAL SX(*), CUTLO, CUTHI, HITEST, SUM, XMAX, ZERO, ONE DATA ZERO, ONE /0.0E0, 1.0E0/ C DATA CUTLO, CUTHI / 4.441E-16, 1.304E19 / C***FIRST EXECUTABLE STATEMENT SNRM2 IF(N .GT. 0) GO TO 10 SNRM2 = ZERO GO TO 300 C 10 ASSIGN 30 TO NEXT SUM = ZERO NN = N * INCX C BEGIN MAIN LOOP I = 1 20 GO TO NEXT,(30, 50, 70, 110) 30 IF( ABS(SX(I)) .GT. CUTLO) GO TO 85 ASSIGN 50 TO NEXT XMAX = ZERO C C PHASE 1. SUM IS ZERO C 50 IF( SX(I) .EQ. ZERO) GO TO 200 IF( ABS(SX(I)) .GT. CUTLO) GO TO 85 C C PREPARE FOR PHASE 2. ASSIGN 70 TO NEXT GO TO 105 C C PREPARE FOR PHASE 4. C 100 I = J ASSIGN 110 TO NEXT SUM = (SUM / SX(I)) / SX(I) 105 XMAX = ABS(SX(I)) GO TO 115 C C PHASE 2. SUM IS SMALL. C SCALE TO AVOID DESTRUCTIVE UNDERFLOW. C 70 IF( ABS(SX(I)) .GT. CUTLO ) GO TO 75 C C COMMON CODE FOR PHASES 2 AND 4. C IN PHASE 4 SUM IS LARGE. SCALE TO AVOID OVERFLOW. C 110 IF( ABS(SX(I)) .LE. XMAX ) GO TO 115 SUM = ONE + SUM * (XMAX / SX(I))**2 XMAX = ABS(SX(I)) GO TO 200 C 115 SUM = SUM + (SX(I)/XMAX)**2 GO TO 200 C C C PREPARE FOR PHASE 3. C 75 SUM = (SUM * XMAX) * XMAX C C C FOR REAL OR D.P. SET HITEST = CUTHI/N C FOR COMPLEX SET HITEST = CUTHI/(2*N) C 85 HITEST = CUTHI/FLOAT( N ) C C PHASE 3. SUM IS MID-RANGE. NO SCALING. C DO 95 J =I,NN,INCX IF(ABS(SX(J)) .GE. HITEST) GO TO 100 95 SUM = SUM + SX(J)**2 SNRM2 = SQRT( SUM ) GO TO 300 C 200 CONTINUE I = I + INCX IF ( I .LE. NN ) GO TO 20 C C END OF MAIN LOOP. C C COMPUTE SQUARE ROOT AND ADJUST FOR SCALING. C SNRM2 = XMAX * SQRT(SUM) 300 CONTINUE RETURN END SUBROUTINE SNDOFD(NR,N,XPLS,FPLS,A,SX,RNOISE,STEPSZ,ANBR) CDPLT SUBROUTINE SNDOFD(NR,N,XPLS,OPTFCN,FPLS,A,SX,RNOISE,STEPSZ,ANBR) IMPLICIT DOUBLE PRECISION (A-H,O-Z) C PURPOSE C ------- C FIND SECOND ORDER FORWARD FINITE DIFFERENCE APPROXIMATION "A" C TO THE SECOND DERIVATIVE (HESSIAN) OF THE FUNCTION DEFINED BY THE SUBP C "OPTFCN" EVALUATED AT THE NEW ITERATE "XPLS" C C FOR OPTIMIZATION USE THIS ROUTINE TO ESTIMATE C 1) THE SECOND DERIVATIVE (HESSIAN) OF THE OPTIMIZATION FUNCTION C IF NO ANALYTICAL USER FUNCTION HAS BEEN SUPPLIED FOR EITHER C THE GRADIENT OR THE HESSIAN AND IF THE OPTIMIZATION FUNCTION C "OPTFCN" IS INEXPENSIVE TO EVALUATE. C C PARAMETERS C ---------- C NR --> ROW DIMENSION OF MATRIX C N --> DIMENSION OF PROBLEM C XPLS(N) --> NEW ITERATE: X[K] C OPTFCN --> NAME OF SUBROUTINE TO EVALUATE FUNCTION C FPLS --> FUNCTION VALUE AT NEW ITERATE, F(XPLS) C A(N,N) <-- FINITE DIFFERENCE APPROXIMATION TO HESSIAN C ONLY LOWER TRIANGULAR MATRIX AND DIAGONAL C ARE RETURNED C SX(N) --> DIAGONAL SCALING MATRIX FOR X C RNOISE --> RELATIVE NOISE IN FNAME [F(X)] C STEPSZ(N) --> WORKSPACE (STEPSIZE IN I-TH COMPONENT DIRECTION) C ANBR(N) --> WORKSPACE (NEIGHBOR IN I-TH DIRECTION) C C DIMENSION XPLS(N) DIMENSION SX(N) DIMENSION STEPSZ(N),ANBR(N) DIMENSION A(NR,1) C C FIND I-TH STEPSIZE AND EVALUATE NEIGHBOR IN DIRECTION C OF I-TH UNIT VECTOR. C OV3 = 1.0/3.0 DO 10 I=1,N STEPSZ(I)=RNOISE**OV3 * MAX(ABS(XPLS(I)),1./SX(I)) XTMPI=XPLS(I) XPLS(I)=XTMPI+STEPSZ(I) CALL OPTFCN(N,XPLS,ANBR(I)) XPLS(I)=XTMPI 10 CONTINUE C C CALCULATE COLUMN I OF A C DO 30 I=1,N XTMPI=XPLS(I) XPLS(I)=XTMPI+2.0*STEPSZ(I) CALL OPTFCN(N,XPLS,FHAT) A(I,I)=((FPLS-ANBR(I))+(FHAT-ANBR(I)))/(STEPSZ(I)*STEPSZ(I)) C C CALCULATE SUB-DIAGONAL ELEMENTS OF COLUMN IF(I.EQ.N) GO TO 25 XPLS(I)=XTMPI+STEPSZ(I) IP1=I+1 DO 20 J=IP1,N XTMPJ=XPLS(J) XPLS(J)=XTMPJ+STEPSZ(J) CALL OPTFCN(N,XPLS,FHAT) A(J,I)=((FPLS-ANBR(I))+(FHAT-ANBR(J)))/(STEPSZ(I)*STEPSZ(J)) XPLS(J)=XTMPJ 20 CONTINUE 25 XPLS(I)=XTMPI 30 CONTINUE RETURN END REAL FUNCTION SNV(AJV, ITYPE, GAMMA, DELTA, XLAM, XI, IFAULT) C C ALGORITHM AS 100.2 APPL. STATIST. (1976) VOL.25, P.190 C C CONVERTS A JOHNSON VARIATE (AJV) TO A C STANDARD NORMAL VARIATE (SNV) C REAL AJV, GAMMA, DELTA, XLAM, XI, V, W, C, ZERO, HALF, ONE, $ ZLOG, ZSQRT C DATA ZERO, HALF, ONE, C /0.0, 0.5, 1.0, -63.0/ C ZLOG(W) = ALOG(W) ZSQRT(W) = SQRT(W) C SNV = ZERO IFAULT = 1 IF (ITYPE .LT. 1 .OR. ITYPE .GT. 4) RETURN IFAULT = 0 GOTO (10, 20, 30, 40), ITYPE C C SL DISTRIBUTION C 10 W = XLAM * (AJV - XI) IF (W .LE. ZERO) GOTO 15 SNV = XLAM * (ZLOG(W) * DELTA + GAMMA) RETURN 15 IFAULT = 2 RETURN C C SU DISTRIBUTION C 20 W = (AJV - XI) / XLAM IF (W .GT. C) GOTO 23 W = -HALF / W GOTO 27 23 W = ZSQRT(W * W + ONE) + W 27 SNV = ZLOG(W) * DELTA + GAMMA RETURN C C SB DISTRIBUTION C 30 W = AJV - XI V = XLAM - W IF (W .LE. ZERO .OR. V .LE. ZERO) GOTO 35 SNV = ZLOG(W / V) * DELTA + GAMMA RETURN 35 IFAULT = 2 RETURN C C NORMAL DISTRIBUTION C 40 SNV = DELTA * AJV + GAMMA RETURN END SUBROUTINE SORT(X,N,Y) C C PURPOSE--THIS SUBROUTINE SORTS (IN ASCENDING ORDER) C THE N ELEMENTS OF THE SINGLE PRECISION VECTOR X C AND PUTS THE RESULTING N SORTED VALUES INTO THE C SINGLE PRECISION VECTOR Y. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF C OBSERVATIONS TO BE SORTED. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X. C OUTPUT ARGUMENTS--Y = THE SINGLE PRECISION VECTOR C INTO WHICH THE SORTED DATA VALUES C FROM X WILL BE PLACED. C OUTPUT--THE SINGLE PRECISION VECTOR Y C CONTAINING THE SORTED C (IN ASCENDING ORDER) VALUES C OF THE SINGLE PRECISION VECTOR X. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THE DIMENSIONS OF THE VECTORS IL AND IU C (DEFINED AND USED INTERNALLY WITHIN C THIS SUBROUTINE) DICTATE THE MAXIMUM C ALLOWABLE VALUE OF N FOR THIS SUBROUTINE. C IF IL AND IU EACH HAVE DIMENSION K, C THEN N MAY NOT EXCEED 2**(K+1) - 1. C FOR THIS SUBROUTINE AS WRITTEN, THE DIMENSIONS C OF IL AND IU HAVE BEEN SET TO 36, C THUS THE MAXIMUM ALLOWABLE VALUE OF N IS C APPROXIMATELY 137 BILLION. C SINCE THIS EXCEEDS THE MAXIMUM ALLOWABLE C VALUE FOR AN INTEGER VARIABLE IN MANY COMPUTERS, C AND SINCE A SORT OF 137 BILLION ELEMENTS C IS PRESENTLY IMPRACTICAL AND UNLIKELY, C THEN THERE IS NO PRACTICAL RESTRICTION C ON THE MAXIMUM VALUE OF N FOR THIS SUBROUTINE. C (IN LIGHT OF THE ABOVE, NO CHECK OF THE C UPPER LIMIT OF N HAS BEEN INCORPORATED C INTO THIS SUBROUTINE.) C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C COMMENT--THE SMALLEST ELEMENT OF THE VECTOR X C WILL BE PLACED IN THE FIRST POSITION C OF THE VECTOR Y, C THE SECOND SMALLEST ELEMENT IN THE VECTOR X C WILL BE PLACED IN THE SECOND POSITION C OF THE VECTOR Y, ETC. C COMMENT--THE INPUT VECTOR X REMAINS UNALTERED. C COMMENT--IF THE ANALYST DESIRES A SORT 'IN PLACE', C THIS IS DONE BY HAVING THE SAME C OUTPUT VECTOR AS INPUT VECTOR IN THE CALLING SEQUENCE. C THUS, FOR EXAMPLE, THE CALLING SEQUENCE C CALL SORT(X,N,X) C IS ALLOWABLE AND WILL RESULT IN C THE DESIRED 'IN-PLACE' SORT. C COMMENT--THE SORTING ALGORTHM USED HEREIN C IS THE QUICKSORT. C THIS ALGORTHIM IS EXTREMELY FAST AS THE C FOLLOWING TIME TRIALS INDICATE. C THESE TIME TRIALS WERE CARRIED OUT ON THE C UNIVAC 1108 EXEC 8 SYSTEM AT NBS C IN AUGUST OF 1974. C BY WAY OF COMPARISON, THE TIME TRIAL VALUES C FOR THE EASY-TO-PROGRAM BUT EXTREMELY C INEFFICIENT BUBBLE SORT ALGORITHM HAVE C ALSO BEEN INCLUDED-- C NUMBER OF RANDOM QUICKSORT BUBBLE SORT C NUMBERS SORTED C N = 10 .002 SEC .002 SEC C N = 100 .011 SEC .045 SEC C N = 1000 .141 SEC 4.332 SEC C N = 3000 .476 SEC 37.683 SEC C N = 10000 1.887 SEC NOT COMPUTED C REFERENCES--CACM MARCH 1969, PAGE 186 ( QUICKSORT ALGORITHM C BY RICHARD C. SINGLETON). C --CACM JANUARY 1970, PAGE 54. C --CACM OCTOBER 1970, PAGE 624. C --JACM JANUARY 1961, PAGE 41. 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 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 --NOVEMBER 1975. C UPDATED --JUNE 1981. C UPDATED --AUGUST 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DIMENSION X(*) DIMENSION Y(*) C DIMENSION IU(36) DIMENSION IL(36) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT 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='SORT' ISUBN2=' ' C IERROR='NO' IBUGA3='OFF' 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 SORT--') 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 ** SORT THE VALUES. ** C ************************ C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C IF(N.GE.1)GOTO119 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN SORT--', 1'THE SECOND INPUT ARGUMENT (N) IS SMALLER THAN 1') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,118)N 118 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) CALL DPWRST('XXX','BUG ') GOTO9000 119 CONTINUE C IF(N.EQ.1)GOTO120 GOTO129 120 CONTINUE CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,121) 121 FORMAT('***** NON-FATAL DIAGNOSTIC IN SORT--', 1'THE SECOND INPUT ARGUMENT (N) HAS THE VALUE 1') CCCCC CALL DPWRST('XXX','BUG ') Y(1)=X(1) GOTO9000 129 CONTINUE C HOLD=X(1) DO135I=2,N IF(X(I).NE.HOLD)GOTO139 135 CONTINUE CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,136)HOLD 136 FORMAT('***** NON-FATAL DIAGNOSTIC IN SORT--', 1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) CCCCC CALL DPWRST('XXX','BUG ') DO137I=1,N Y(I)=X(I) 137 CONTINUE GOTO9000 139 CONTINUE C 190 CONTINUE C C ******************************************* C ** STEP 2-- ** C ** COPY THE VECTOR X INTO THE VECTOR Y ** C ******************************************* C DO200I=1,N Y(I)=X(I) 200 CONTINUE C C ********************************************************** C ** STEP 3-- ** C ** CHECK TO SEE IF THE INPUT VECTOR IS ALREADY SORTED ** C ********************************************************** C NM1=N-1 DO250I=1,NM1 IP1=I+1 IF(Y(I).LE.Y(IP1))GOTO250 GOTO290 250 CONTINUE GOTO9000 290 CONTINUE C C *************************** C ** STEP 4-- ** C ** CARRY OUT THE SORT. ** C *************************** C M=1 I=1 J=N 305 IF(I.GE.J)GOTO370 310 K=I MID=(I+J)/2 AMED=Y(MID) IF(Y(I).LE.AMED)GOTO320 Y(MID)=Y(I) Y(I)=AMED AMED=Y(MID) 320 L=J IF(Y(J).GE.AMED)GOTO340 Y(MID)=Y(J) Y(J)=AMED AMED=Y(MID) IF(Y(I).LE.AMED)GOTO340 Y(MID)=Y(I) Y(I)=AMED AMED=Y(MID) GOTO340 330 Y(L)=Y(K) Y(K)=TT 340 L=L-1 IF(Y(L).GT.AMED)GOTO340 TT=Y(L) 350 K=K+1 IF(Y(K).LT.AMED)GOTO350 IF(K.LE.L)GOTO330 LMI=L-I JMK=J-K IF(LMI.LE.JMK)GOTO360 IL(M)=I IU(M)=L I=K M=M+1 GOTO380 360 IL(M)=K IU(M)=J J=L M=M+1 GOTO380 370 M=M-1 IF(M.EQ.0)GOTO9000 I=IL(M) J=IU(M) 380 JMI=J-I IF(JMI.GE.11)GOTO310 IF(I.EQ.1)GOTO305 I=I-1 390 I=I+1 IF(I.EQ.J)GOTO370 AMED=Y(I+1) IF(Y(I).LE.AMED)GOTO390 K=I 395 Y(K+1)=Y(K) K=K-1 IF(AMED.LT.Y(K))GOTO395 Y(K+1)=AMED GOTO390 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 SORT--') 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 ') DO9015I=1,N 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 SORTC(X,Y,N,XS,YC) C C PURPOSE--THIS SUBROUTINE SORTS (IN ASCENDING ORDER) C THE N ELEMENTS OF THE SINGLE PRECISION VECTOR X, C PUTS THE RESULTING N SORTED VALUES INTO THE C SINGLE PRECISION VECTOR XS, C REARRANGES THE ELEMENTS OF THE VECTOR Y C (ACCORDING TO THE SORT ON X), C AND PUTS THE REARRANGED Y VALUES C INTO THE SINGLE PRECISION VECTOR YC. C THIS SUBROUTINE GIVES THE DATA ANALYST C THE ABILITY TO SORT ONE DATA VECTOR C WHILE 'CARRYING ALONG' THE ELEMENTS C OF A SECOND DATA VECTOR. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF C OBSERVATIONS TO BE SORTED. C --Y = THE SINGLE PRECISION VECTOR OF C OBSERVATIONS TO BE 'CARRIED ALONG', C THAT IS, TO BE REARRANGED ACCORDING C TO THE SORT ON X. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X. C OUTPUT ARGUMENTS--XS = THE SINGLE PRECISION VECTOR C INTO WHICH THE SORTED DATA VALUES C FROM X WILL BE PLACED. C --YC = THE SINGLE PRECISION VECTOR C INTO WHICH THE REARRANGED C (ACCORDING TO THE SORT OF THE C VECTOR X) VALUES OF THE VECTOR Y C WILL BE PLACED. C OUTPUT--THE SINGLE PRECISION VECTOR XS C CONTAINING THE SORTED C (IN ASCENDING ORDER) VALUES C OF THE SINGLE PRECISION VECTOR X, AND C THE SINGLE PRECISION VECTOR YC C CONTAINING THE REARRANGED C (ACCORDING TO THE SORT ON X) C VALUES OF THE VECTOR Y. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THE DIMENSIONS OF THE VECTORS IL AND IU C (DEFINED AND USED INTERNALLY WITHIN C THIS SUBROUTINE) DICTATE THE MAXIMUM C ALLOWABLE VALUE OF N FOR THIS SUBROUTINE. C IF IL AND IU EACH HAVE DIMENSION K, C THEN N MAY NOT EXCEED 2**(K+1) - 1. C FOR THIS SUBROUTINE AS WRITTEN, THE DIMENSIONS C OF IL AND IU HAVE BEEN SET TO 36, C THUS THE MAXIMUM ALLOWABLE VALUE OF N IS C APPROXIMATELY 137 BILLION. C SINCE THIS EXCEEDS THE MAXIMUM ALLOWABLE C VALUE FOR AN INTEGER VARIABLE IN MANY COMPUTERS, C AND SINCE A SORT OF 137 BILLION ELEMENTS C IS PRESENTLY IMPRACTICAL AND UNLIKELY, C THEN THERE IS NO PRACTICAL RESTRICTION C ON THE MAXIMUM VALUE OF N FOR THIS SUBROUTINE. C (IN LIGHT OF THE ABOVE, NO CHECK OF THE C UPPER LIMIT OF N HAS BEEN INCORPORATED C INTO THIS SUBROUTINE.) C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C COMMENT--THE SMALLEST ELEMENT OF THE VECTOR X C WILL BE PLACED IN THE FIRST POSITION C OF THE VECTOR XS, C THE SECOND SMALLEST ELEMENT IN THE VECTOR X C WILL BE PLACED IN THE SECOND POSITION C OF THE VECTOR XS, C ETC. C COMMENT--THE ELEMENT IN THE VECTOR Y CORRESPONDING C TO THE SMALLEST ELEMENT IN X C WILL BE PLACED IN THE FIRST POSITION C OF THE VECTOR YC, C THE ELEMENT IN THE VECTOR Y CORRESPONDING C TO THE SECOND SMALLEST ELEMENT IN X C WILL BE PLACED IN THE SECOND POSITION C OF THE VECTOR YC, C ETC. C COMMENT--THE INPUT VECTOR X REMAINS UNALTERED. C COMMENT--IF THE ANALYST DESIRES A SORT 'IN PLACE', C THIS IS DONE BY HAVING THE SAME C OUTPUT VECTOR AS INPUT VECTOR IN THE CALLING SEQUENCE. C THUS, FOR EXAMPLE, THE CALLING SEQUENCE C CALL SORTC(X,Y,N,X,YC) C IS ALLOWABLE AND WILL RESULT IN C THE DESIRED 'IN-PLACE' SORT. C COMMENT--THE SORTING ALGORTHM USED HEREIN C IS THE BINARY SORT. C THIS ALGORTHIM IS EXTREMELY FAST AS THE C FOLLOWING TIME TRIALS INDICATE. C THESE TIME TRIALS WERE CARRIED OUT ON THE C UNIVAC 1108 EXEC 8 SYSTEM AT NBS C IN AUGUST OF 1974. C BY WAY OF COMPARISON, THE TIME TRIAL VALUES C FOR THE EASY-TO-PROGRAM BUT EXTREMELY C INEFFICIENT BUBBLE SORT ALGORITHM HAVE C ALSO BEEN INCLUDED-- C NUMBER OF RANDOM BINARY SORT BUBBLE SORT C NUMBERS SORTED C N = 10 .002 SEC .002 SEC C N = 100 .011 SEC .045 SEC C N = 1000 .141 SEC 4.332 SEC C N = 3000 .476 SEC 37.683 SEC C N = 10000 1.887 SEC NOT COMPUTED C REFERENCES--CACM MARCH 1969, PAGE 186 (BINARY SORT ALGORITHM C BY RICHARD C. SINGLETON). C --CACM JANUARY 1970, PAGE 54. C --CACM OCTOBER 1970, PAGE 624. C --JACM JANUARY 1961, PAGE 41. 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 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 --NOVEMBER 1975. C UPDATED --JUNE 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*),Y(*),XS(*),YC(*) DIMENSION IU(36),IL(36) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)GOTO50 IF(N.EQ.1)GOTO55 HOLD=X(1) DO60I=2,N IF(X(I).NE.HOLD)GOTO90 60 CONTINUE CCCCC WRITE(ICOUT, 9)HOLD CCCCC CALL DPWRST('XXX','BUG ') DO61I=1,N XS(I)=X(I) YC(I)=Y(I) 61 CONTINUE RETURN 50 WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') RETURN 55 CONTINUE CCCCC WRITE(ICOUT,18) CCCCC CALL DPWRST('XXX','BUG ') XS(1)=X(1) YC(1)=Y(1) RETURN 90 CONTINUE 9 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 1ST INPUT ARGUMENT ', 1'(A VECTOR) TO THE SORTC SUBROUTINE HAS ALL ELEMENTS = ',E15.8) 15 FORMAT('***** FATAL ERROR--THE SECOND INPUT ARGUMENT TO THE ', 1'SORTC SUBROUTINE IS NON-POSITIVE *****') 18 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 2ND INPUT ARGUMENT ', 1'TO THE SORTC SUBROUTINE HAS THE VALUE 1') 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') C C COPY THE VECTOR X INTO THE VECTOR XS DO100I=1,N XS(I)=X(I) 100 CONTINUE C C COPY THE VECTOR Y INTO THE VECTOR YS C DO150I=1,N YC(I)=Y(I) 150 CONTINUE C C CHECK TO SEE IF THE INPUT VECTOR IS ALREADY SORTED C NM1=N-1 DO200I=1,NM1 IP1=I+1 IF(XS(I).LE.XS(IP1))GOTO200 GOTO250 200 CONTINUE RETURN 250 M=1 I=1 J=N 305 IF(I.GE.J)GOTO370 310 K=I MID=(I+J)/2 AMED=XS(MID) BMED=YC(MID) IF(XS(I).LE.AMED)GOTO320 XS(MID)=XS(I) YC(MID)=YC(I) XS(I)=AMED YC(I)=BMED AMED=XS(MID) BMED=YC(MID) 320 L=J IF(XS(J).GE.AMED)GOTO340 XS(MID)=XS(J) YC(MID)=YC(J) XS(J)=AMED YC(J)=BMED AMED=XS(MID) BMED=YC(MID) IF(XS(I).LE.AMED)GOTO340 XS(MID)=XS(I) YC(MID)=YC(I) XS(I)=AMED YC(I)=BMED AMED=XS(MID) BMED=YC(MID) GOTO340 330 XS(L)=XS(K) YC(L)=YC(K) XS(K)=TX YC(K)=TY 340 L=L-1 IF(XS(L).GT.AMED)GOTO340 TX=XS(L) TY=YC(L) 350 K=K+1 IF(XS(K).LT.AMED)GOTO350 IF(K.LE.L)GOTO330 LMI=L-I JMK=J-K IF(LMI.LE.JMK)GOTO360 IL(M)=I IU(M)=L I=K M=M+1 GOTO380 360 IL(M)=K IU(M)=J J=L M=M+1 GOTO380 370 M=M-1 IF(M.EQ.0)RETURN I=IL(M) J=IU(M) 380 JMI=J-I IF(JMI.GE.11)GOTO310 IF(I.EQ.1)GOTO305 I=I-1 390 I=I+1 IF(I.EQ.J)GOTO370 AMED=XS(I+1) BMED=YC(I+1) IF(XS(I).LE.AMED)GOTO390 K=I 395 XS(K+1)=XS(K) YC(K+1)=YC(K) K=K-1 IF(AMED.LT.XS(K))GOTO395 XS(K+1)=AMED YC(K+1)=BMED GOTO390 END SUBROUTINE SORTC2(X,Y,N,XS,YC) C C NOTE--THIS SUBROUTINE IS IDENTICAL TO SORTC. C IT HAS BEEN DUPLICATED AND PLACED C ON THIS BRANCH OF THE OVERLAY/SEGMENTATION C TREE STRUCTURE IN ORDER TO ACHIEVE C FASTER EXECUTION TIME. C C PURPOSE--THIS SUBROUTINE SORTS (IN ASCENDING ORDER) C THE N ELEMENTS OF THE SINGLE PRECISION VECTOR X, C PUTS THE RESULTING N SORTED VALUES INTO THE C SINGLE PRECISION VECTOR XS, C REARRANGES THE ELEMENTS OF THE VECTOR Y C (ACCORDING TO THE SORT ON X), C AND PUTS THE REARRANGED Y VALUES C INTO THE SINGLE PRECISION VECTOR YC. C THIS SUBROUTINE GIVES THE DATA ANALYST C THE ABILITY TO SORT ONE DATA VECTOR C WHILE 'CARRYING ALONG' THE ELEMENTS C OF A SECOND DATA VECTOR. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF C OBSERVATIONS TO BE SORTED. C --Y = THE SINGLE PRECISION VECTOR OF C OBSERVATIONS TO BE 'CARRIED ALONG', C THAT IS, TO BE REARRANGED ACCORDING C TO THE SORT ON X. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X. C OUTPUT ARGUMENTS--XS = THE SINGLE PRECISION VECTOR C INTO WHICH THE SORTED DATA VALUES C FROM X WILL BE PLACED. C --YC = THE SINGLE PRECISION VECTOR C INTO WHICH THE REARRANGED C (ACCORDING TO THE SORT OF THE C VECTOR X) VALUES OF THE VECTOR Y C WILL BE PLACED. C OUTPUT--THE SINGLE PRECISION VECTOR XS C CONTAINING THE SORTED C (IN ASCENDING ORDER) VALUES C OF THE SINGLE PRECISION VECTOR X, AND C THE SINGLE PRECISION VECTOR YC C CONTAINING THE REARRANGED C (ACCORDING TO THE SORT ON X) C VALUES OF THE VECTOR Y. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THE DIMENSIONS OF THE VECTORS IL AND IU C (DEFINED AND USED INTERNALLY WITHIN C THIS SUBROUTINE) DICTATE THE MAXIMUM C ALLOWABLE VALUE OF N FOR THIS SUBROUTINE. C IF IL AND IU EACH HAVE DIMENSION K, C THEN N MAY NOT EXCEED 2**(K+1) - 1. C FOR THIS SUBROUTINE AS WRITTEN, THE DIMENSIONS C OF IL AND IU HAVE BEEN SET TO 36, C THUS THE MAXIMUM ALLOWABLE VALUE OF N IS C APPROXIMATELY 137 BILLION. C SINCE THIS EXCEEDS THE MAXIMUM ALLOWABLE C VALUE FOR AN INTEGER VARIABLE IN MANY COMPUTERS, C AND SINCE A SORT OF 137 BILLION ELEMENTS C IS PRESENTLY IMPRACTICAL AND UNLIKELY, C THEN THERE IS NO PRACTICAL RESTRICTION C ON THE MAXIMUM VALUE OF N FOR THIS SUBROUTINE. C (IN LIGHT OF THE ABOVE, NO CHECK OF THE C UPPER LIMIT OF N HAS BEEN INCORPORATED C INTO THIS SUBROUTINE.) C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C COMMENT--THE SMALLEST ELEMENT OF THE VECTOR X C WILL BE PLACED IN THE FIRST POSITION C OF THE VECTOR XS, C THE SECOND SMALLEST ELEMENT IN THE VECTOR X C WILL BE PLACED IN THE SECOND POSITION C OF THE VECTOR XS, C ETC. C COMMENT--THE ELEMENT IN THE VECTOR Y CORRESPONDING C TO THE SMALLEST ELEMENT IN X C WILL BE PLACED IN THE FIRST POSITION C OF THE VECTOR YC, C THE ELEMENT IN THE VECTOR Y CORRESPONDING C TO THE SECOND SMALLEST ELEMENT IN X C WILL BE PLACED IN THE SECOND POSITION C OF THE VECTOR YC, C ETC. C COMMENT--THE INPUT VECTOR X REMAINS UNALTERED. C COMMENT--IF THE ANALYST DESIRES A SORT 'IN PLACE', C THIS IS DONE BY HAVING THE SAME C OUTPUT VECTOR AS INPUT VECTOR IN THE CALLING SEQUENCE. C THUS, FOR EXAMPLE, THE CALLING SEQUENCE C CALL SORTC2(X,Y,N,X,YC) C IS ALLOWABLE AND WILL RESULT IN C THE DESIRED 'IN-PLACE' SORT. C COMMENT--THE SORTING ALGORTHM USED HEREIN C IS THE BINARY SORT. C THIS ALGORTHIM IS EXTREMELY FAST AS THE C FOLLOWING TIME TRIALS INDICATE. C THESE TIME TRIALS WERE CARRIED OUT ON THE C UNIVAC 1108 EXEC 8 SYSTEM AT NBS C IN AUGUST OF 1974. C BY WAY OF COMPARISON, THE TIME TRIAL VALUES C FOR THE EASY-TO-PROGRAM BUT EXTREMELY C INEFFICIENT BUBBLE SORT ALGORITHM HAVE C ALSO BEEN INCLUDED-- C NUMBER OF RANDOM BINARY SORT BUBBLE SORT C NUMBERS SORTED C N = 10 .002 SEC .002 SEC C N = 100 .011 SEC .045 SEC C N = 1000 .141 SEC 4.332 SEC C N = 3000 .476 SEC 37.683 SEC C N = 10000 1.887 SEC NOT COMPUTED C REFERENCES--CACM MARCH 1969, PAGE 186 (BINARY SORT ALGORITHM C BY RICHARD C. SINGLETON). C --CACM JANUARY 1970, PAGE 54. C --CACM OCTOBER 1970, PAGE 624. C --JACM JANUARY 1961, PAGE 41. 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 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 --NOVEMBER 1975. C UPDATED --JUNE 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*),Y(*),XS(*),YC(*) DIMENSION IU(36),IL(36) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)GOTO50 IF(N.EQ.1)GOTO55 HOLD=X(1) DO60I=2,N IF(X(I).NE.HOLD)GOTO90 60 CONTINUE CCCCC WRITE(ICOUT, 9)HOLD CCCCC CALL DPWRST('XXX','BUG ') DO61I=1,N XS(I)=X(I) YC(I)=Y(I) 61 CONTINUE RETURN 50 WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') RETURN 55 CONTINUE CCCCC WRITE(ICOUT,18) CCCCC CALL DPWRST('XXX','BUG ') XS(1)=X(1) YC(1)=Y(1) RETURN 90 CONTINUE 9 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 1ST INPUT ARGUMENT ', 1'(A VECTOR) TO THE SORTC2 SUBROUTINE HAS ALL ELEMENTS = ',E15.7) 15 FORMAT( '***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE 1 SORTC2 SUBROUTINE IS NON-POSITIVE *****') 18 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 2ND INPUT ARGUMENT ', 1'TO THE SORTC2 SUBROUTINE HAS THE VALUE 1') 47 FORMAT( '***** THE VALUE OF THE ARGUMENT IS ',I8 ,'*****') C C COPY THE VECTOR X INTO THE VECTOR XS DO100I=1,N XS(I)=X(I) 100 CONTINUE C C COPY THE VECTOR Y INTO THE VECTOR YS C DO150I=1,N YC(I)=Y(I) 150 CONTINUE C C CHECK TO SEE IF THE INPUT VECTOR IS ALREADY SORTED C NM1=N-1 DO200I=1,NM1 IP1=I+1 IF(XS(I).LE.XS(IP1))GOTO200 GOTO250 200 CONTINUE RETURN 250 M=1 I=1 J=N 305 IF(I.GE.J)GOTO370 310 K=I MID=(I+J)/2 AMED=XS(MID) BMED=YC(MID) IF(XS(I).LE.AMED)GOTO320 XS(MID)=XS(I) YC(MID)=YC(I) XS(I)=AMED YC(I)=BMED AMED=XS(MID) BMED=YC(MID) 320 L=J IF(XS(J).GE.AMED)GOTO340 XS(MID)=XS(J) YC(MID)=YC(J) XS(J)=AMED YC(J)=BMED AMED=XS(MID) BMED=YC(MID) IF(XS(I).LE.AMED)GOTO340 XS(MID)=XS(I) YC(MID)=YC(I) XS(I)=AMED YC(I)=BMED AMED=XS(MID) BMED=YC(MID) GOTO340 330 XS(L)=XS(K) YC(L)=YC(K) XS(K)=TX YC(K)=TY 340 L=L-1 IF(XS(L).GT.AMED)GOTO340 TX=XS(L) TY=YC(L) 350 K=K+1 IF(XS(K).LT.AMED)GOTO350 IF(K.LE.L)GOTO330 LMI=L-I JMK=J-K IF(LMI.LE.JMK)GOTO360 IL(M)=I IU(M)=L I=K M=M+1 GOTO380 360 IL(M)=K IU(M)=J J=L M=M+1 GOTO380 370 M=M-1 IF(M.EQ.0)RETURN I=IL(M) J=IU(M) 380 JMI=J-I IF(JMI.GE.11)GOTO310 IF(I.EQ.1)GOTO305 I=I-1 390 I=I+1 IF(I.EQ.J)GOTO370 AMED=XS(I+1) BMED=YC(I+1) IF(XS(I).LE.AMED)GOTO390 K=I 395 XS(K+1)=XS(K) YC(K+1)=YC(K) K=K-1 IF(AMED.LT.XS(K))GOTO395 XS(K+1)=AMED YC(K+1)=BMED GOTO390 END SUBROUTINE SORTDE(X,N,Y) C C PURPOSE--THIS SUBROUTINE SORTS (IN DESCENDING ORDER) C THE N ELEMENTS OF THE SINGLE PRECISION VECTOR X C AND PUTS THE RESULTING N SORTED VALUES INTO THE C SINGLE PRECISION VECTOR Y. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF C OBSERVATIONS TO BE SORTED. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X. C OUTPUT ARGUMENTS--Y = THE SINGLE PRECISION VECTOR C INTO WHICH THE SORTED DATA VALUES C FROM X WILL BE PLACED. C OUTPUT--THE SINGLE PRECISION VECTOR Y C CONTAINING THE SORTED C (IN ASCENDING ORDER) VALUES C OF THE SINGLE PRECISION VECTOR X. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THE DIMENSIONS OF THE VECTORS IL AND IU C (DEFINED AND USED INTERNALLY WITHIN C THIS SUBROUTINE) DICTATE THE MAXIMUM C ALLOWABLE VALUE OF N FOR THIS SUBROUTINE. C IF IL AND IU EACH HAVE DIMENSION K, C THEN N MAY NOT EXCEED 2**(K+1) - 1. C FOR THIS SUBROUTINE AS WRITTEN, THE DIMENSIONS C OF IL AND IU HAVE BEEN SET TO 36, C THUS THE MAXIMUM ALLOWABLE VALUE OF N IS C APPROXIMATELY 137 BILLION. C SINCE THIS EXCEEDS THE MAXIMUM ALLOWABLE C VALUE FOR AN INTEGER VARIABLE IN MANY COMPUTERS, C AND SINCE A SORT OF 137 BILLION ELEMENTS C IS PRESENTLY IMPRACTICAL AND UNLIKELY, C THEN THERE IS NO PRACTICAL RESTRICTION C ON THE MAXIMUM VALUE OF N FOR THIS SUBROUTINE. C (IN LIGHT OF THE ABOVE, NO CHECK OF THE C UPPER LIMIT OF N HAS BEEN INCORPORATED C INTO THIS SUBROUTINE.) C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C COMMENT--THE SMALLEST ELEMENT OF THE VECTOR X C WILL BE PLACED IN THE FIRST POSITION C OF THE VECTOR Y, C THE SECOND SMALLEST ELEMENT IN THE VECTOR X C WILL BE PLACED IN THE SECOND POSITION C OF THE VECTOR Y, ETC. C COMMENT--THE INPUT VECTOR X REMAINS UNALTERED. C COMMENT--IF THE ANALYST DESIRES A SORT 'IN PLACE', C THIS IS DONE BY HAVING THE SAME C OUTPUT VECTOR AS INPUT VECTOR IN THE CALLING SEQUENCE. C THUS, FOR EXAMPLE, THE CALLING SEQUENCE C CALL SORT(X,N,X) C IS ALLOWABLE AND WILL RESULT IN C THE DESIRED 'IN-PLACE' SORT. C COMMENT--THE SORTING ALGORTHM USED HEREIN C IS THE QUICKSORT. C THIS ALGORTHIM IS EXTREMELY FAST AS THE C FOLLOWING TIME TRIALS INDICATE. C THESE TIME TRIALS WERE CARRIED OUT ON THE C UNIVAC 1108 EXEC 8 SYSTEM AT NBS C IN AUGUST OF 1974. C BY WAY OF COMPARISON, THE TIME TRIAL VALUES C FOR THE EASY-TO-PROGRAM BUT EXTREMELY C INEFFICIENT BUBBLE SORT ALGORITHM HAVE C ALSO BEEN INCLUDED-- C NUMBER OF RANDOM QUICKSORT BUBBLE SORT C NUMBERS SORTED C N = 10 .002 SEC .002 SEC C N = 100 .011 SEC .045 SEC C N = 1000 .141 SEC 4.332 SEC C N = 3000 .476 SEC 37.683 SEC C N = 10000 1.887 SEC NOT COMPUTED C REFERENCES--CACM MARCH 1969, PAGE 186 ( QUICKSORT ALGORITHM C BY RICHARD C. SINGLETON). C --CACM JANUARY 1970, PAGE 54. C --CACM OCTOBER 1970, PAGE 624. C --JACM JANUARY 1961, PAGE 41. 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 LANGUAGE--ANSI FORTRAN (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--88.9 C ORIGINAL VERSION--AUGUST 1988. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DIMENSION X(*) DIMENSION Y(*) C DIMENSION IU(36) DIMENSION IL(36) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT 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='SORT' ISUBN2='DE ' C IERROR='NO' IBUGA3='OFF' 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 SORT--') 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 ** SORT THE VALUES. ** C ************************ C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C IF(N.GE.1)GOTO119 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN SORT--', 1'THE 2ND INPUT ARGUMENT (N) IS SMALLER THAN 1') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,118)N 118 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) CALL DPWRST('XXX','BUG ') GOTO9000 119 CONTINUE C IF(N.EQ.1)GOTO120 GOTO129 120 CONTINUE CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,121) 121 FORMAT('***** NON-FATAL DIAGNOSTIC IN SORT--', 1'THE 2ND INPUT ARGUMENT (N) HAS THE VALUE 1') CCCCC CALL DPWRST('XXX','BUG ') Y(1)=X(1) GOTO9000 129 CONTINUE C HOLD=X(1) DO135I=2,N IF(X(I).NE.HOLD)GOTO139 135 CONTINUE CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,136)HOLD 136 FORMAT('***** NON-FATAL DIAGNOSTIC IN SORT--', 1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) CCCCC CALL DPWRST('XXX','BUG ') DO137I=1,N Y(I)=X(I) 137 CONTINUE GOTO9000 139 CONTINUE C 190 CONTINUE C C ******************************************* C ** STEP 2-- ** C ** COPY THE VECTOR X INTO THE VECTOR Y ** C ******************************************* C DO200I=1,N Y(I)=X(I) 200 CONTINUE C DO210I=1,N Y(I)=(-Y(I)) 210 CONTINUE C C ********************************************************** C ** STEP 3-- ** C ** CHECK TO SEE IF THE INPUT VECTOR IS ALREADY SORTED ** C ********************************************************** C NM1=N-1 DO250I=1,NM1 IP1=I+1 IF(Y(I).LE.Y(IP1))GOTO250 GOTO290 250 CONTINUE GOTO8000 290 CONTINUE C C *************************** C ** STEP 4-- ** C ** CARRY OUT THE SORT. ** C *************************** C M=1 I=1 J=N 305 IF(I.GE.J)GOTO370 310 K=I MID=(I+J)/2 AMED=Y(MID) IF(Y(I).LE.AMED)GOTO320 Y(MID)=Y(I) Y(I)=AMED AMED=Y(MID) 320 L=J IF(Y(J).GE.AMED)GOTO340 Y(MID)=Y(J) Y(J)=AMED AMED=Y(MID) IF(Y(I).LE.AMED)GOTO340 Y(MID)=Y(I) Y(I)=AMED AMED=Y(MID) GOTO340 330 Y(L)=Y(K) Y(K)=TT 340 L=L-1 IF(Y(L).GT.AMED)GOTO340 TT=Y(L) 350 K=K+1 IF(Y(K).LT.AMED)GOTO350 IF(K.LE.L)GOTO330 LMI=L-I JMK=J-K IF(LMI.LE.JMK)GOTO360 IL(M)=I IU(M)=L I=K M=M+1 GOTO380 360 IL(M)=K IU(M)=J J=L M=M+1 GOTO380 370 M=M-1 IF(M.EQ.0)GOTO8000 I=IL(M) J=IU(M) 380 JMI=J-I IF(JMI.GE.11)GOTO310 IF(I.EQ.1)GOTO305 I=I-1 390 I=I+1 IF(I.EQ.J)GOTO370 AMED=Y(I+1) IF(Y(I).LE.AMED)GOTO390 K=I 395 Y(K+1)=Y(K) K=K-1 IF(AMED.LT.Y(K))GOTO395 Y(K+1)=AMED GOTO390 C 8000 CONTINUE DO8100I=1,N Y(I)=(-Y(I)) 8100 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 SORT--') 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 ') DO9015I=1,N 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 SORTI(X,N,XS,AINDEX) C C PURPOSE--THIS SUBROUTINE SORTS (IN ASCENDING ORDER) C THE N ELEMENTS OF THE SINGLE PRECISION VECTOR X, C PUTS THE RESULTING N SORTED VALUES INTO THE C SINGLE PRECISION VECTOR XS, AND C REARRANGES THE ELEMENTS 1, 2, ..., N OF VECTOR AINDEX C (ACCORDING TO THE SORT ON X). C THIS SUBROUTINE GIVES THE DATA ANALYST C THE ABILITY TO SORT ONE DATA VECTOR C WHILE DETERMINING THE POSITION INDEX C AFTER-THE-FACT, SO AS TO SUBSEQUENTLY C 'CARRY ALONG' THE ELEMENTS C OF MANY OTHER DATA VECTORS (DONE ELSEWHERE). C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF C OBSERVATIONS TO BE SORTED. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X. C OUTPUT ARGUMENTS--XS = THE SINGLE PRECISION VECTOR C INTO WHICH THE SORTED DATA VALUES C FROM X WILL BE PLACED. C --AINDEX = THE SINGLE PRECISION VECTOR C INTO WHICH THE REARRANGED C (ACCORDING TO THE SORT OF THE C VECTOR X) VALUES OF 1, 2, ..., N C WILL BE PLACED. C OUTPUT--THE SINGLE PRECISION VECTOR XS C CONTAINING THE SORTED C (IN ASCENDING ORDER) VALUES C OF THE SINGLE PRECISION VECTOR X, AND C THE SINGLE PRECISION VECTOR AINDEX C CONTAINING THE REARRANGED C (ACCORDING TO THE SORT ON X) C VALUES OF 1, 2, ..., N. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THE DIMENSIONS OF THE VECTORS IL AND IU C (DEFINED AND USED INTERNALLY WITHIN C THIS SUBROUTINE) DICTATE THE MAXIMUM C ALLOWABLE VALUE OF N FOR THIS SUBROUTINE. C IF IL AND IU EACH HAVE DIMENSION K, C THEN N MAY NOT EXCEED 2**(K+1) - 1. C FOR THIS SUBROUTINE AS WRITTEN, THE DIMENSIONS C OF IL AND IU HAVE BEEN SET TO 36, C THUS THE MAXIMUM ALLOWABLE VALUE OF N IS C APPROXIMATELY 137 BILLION. C SINCE THIS EXCEEDS THE MAXIMUM ALLOWABLE C VALUE FOR AN INTEGER VARIABLE IN MANY COMPUTERS, C AND SINCE A SORT OF 137 BILLION ELEMENTS C IS PRESENTLY IMPRACTICAL AND UNLIKELY, C THEN THERE IS NO PRACTICAL RESTRICTION C ON THE MAXIMUM VALUE OF N FOR THIS SUBROUTINE. C (IN LIGHT OF THE ABOVE, NO CHECK OF THE C UPPER LIMIT OF N HAS BEEN INCORPORATED C INTO THIS SUBROUTINE.) C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C COMMENT--THE SMALLEST ELEMENT OF THE VECTOR X C WILL BE PLACED IN THE FIRST POSITION C OF THE VECTOR XS, C THE SECOND SMALLEST ELEMENT IN THE VECTOR X C WILL BE PLACED IN THE SECOND POSITION C OF THE VECTOR XS, C ETC. C COMMENT--AT THE END, AINDEX(1) WILL CONTAIN TBE ORIGINAL C POSITION NUMBER WHERE THE SMALLEST VALUE OF X DID RESIDE. C AINDEX(2) WILL CONTAIN THE ORIGINAL C POSITION NUMBER WHERE THE SECOND SMALLEST VALUE OF X DID RESIDE. C AINDEX(N) WILL CONTAIN THE ORIGINAL C POSITION NUMBER WHERE THE LARGEST VALUE OF X DID RESIDE. C COMMENT--THE INPUT VECTOR X REMAINS UNALTERED. C COMMENT--IF THE ANALYST DESIRES A SORT 'IN PLACE', C THIS IS DONE BY HAVING THE SAME C OUTPUT VECTOR AS INPUT VECTOR IN THE CALLING SEQUENCE. C THUS, FOR EXAMPLE, THE CALLING SEQUENCE C CALL SORTI(X,N,X,AINDEX) C IS ALLOWABLE AND WILL RESULT IN C THE DESIRED 'IN-PLACE' SORT. C COMMENT--THE SORTING ALGORTHM USED HEREIN C IS THE BINARY SORT. C THIS ALGORTHIM IS EXTREMELY FAST AS THE C FOLLOWING TIME TRIALS INDICATE. C THESE TIME TRIALS WERE CARRIED OUT ON THE C UNIVAC 1108 EXEC 8 SYSTEM AT NBS C IN AUGUST OF 1974. C BY WAY OF COMPARISON, THE TIME TRIAL VALUES C FOR THE EASY-TO-PROGRAM BUT EXTREMELY C INEFFICIENT BUBBLE SORT ALGORITHM HAVE C ALSO BEEN INCLUDED-- C NUMBER OF RANDOM BINARY SORT BUBBLE SORT C NUMBERS SORTED C N = 10 .002 SEC .002 SEC C N = 100 .011 SEC .045 SEC C N = 1000 .141 SEC 4.332 SEC C N = 3000 .476 SEC 37.683 SEC C N = 10000 1.887 SEC NOT COMPUTED C REFERENCES--CACM MARCH 1969, PAGE 186 (BINARY SORT ALGORITHM C BY RICHARD C. SINGLETON). C --CACM JANUARY 1970, PAGE 54. C --CACM OCTOBER 1970, PAGE 624. C --JACM JANUARY 1961, PAGE 41. 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 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 --NOVEMBER 1975. C UPDATED --JUNE 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C DIMENSION X(*),XS(*),AINDEX(*) DIMENSION IU(36),IL(36) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)GOTO50 IF(N.EQ.1)GOTO55 HOLD=X(1) DO60I=2,N IF(X(I).NE.HOLD)GOTO90 60 CONTINUE CCCCC WRITE(ICOUT, 9)HOLD CCCCC CALL DPWRST('XXX','BUG ') DO61I=1,N XS(I)=X(I) AINDEX(I)=I 61 CONTINUE RETURN 50 WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') RETURN 55 CONTINUE CCCCC WRITE(ICOUT,18) CCCCC CALL DPWRST('XXX','BUG ') XS(1)=X(1) AINDEX(1)=1 RETURN 90 CONTINUE 9 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 1ST INPUT ARGUMENT ', 1'(A VECTOR) TO THE SORTI SUBROUTINE HAS ALL ELEMENTS = ',E15.8) 15 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ', 1'SORTI SUBROUTINE IS NON-POSITIVE *****') 18 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 2ND INPUT ARGUMENT ', 1'TO THE SORTI SUBROUTINE HAS THE VALUE 1') 47 FORMAT( 35H***** THE VALUE OF THE ARGUMENT IS ,I8 ,6H *****) C C COPY THE VECTOR X INTO THE VECTOR XS DO100I=1,N XS(I)=X(I) 100 CONTINUE C C COPY THE VECTOR INDEX INTO THE VECTOR INDEXS C DO150I=1,N AINDEX(I)=I 150 CONTINUE C C CHECK TO SEE IF THE INPUT VECTOR IS ALREADY SORTED C NM1=N-1 DO200I=1,NM1 IP1=I+1 IF(XS(I).LE.XS(IP1))GOTO200 GOTO250 200 CONTINUE RETURN 250 M=1 I=1 J=N 305 IF(I.GE.J)GOTO370 310 K=I MID=(I+J)/2 AMED=XS(MID) BMED=AINDEX(MID) IF(XS(I).LE.AMED)GOTO320 XS(MID)=XS(I) AINDEX(MID)=AINDEX(I) XS(I)=AMED AINDEX(I)=BMED AMED=XS(MID) BMED=AINDEX(MID) 320 L=J IF(XS(J).GE.AMED)GOTO340 XS(MID)=XS(J) AINDEX(MID)=AINDEX(J) XS(J)=AMED AINDEX(J)=BMED AMED=XS(MID) BMED=AINDEX(MID) IF(XS(I).LE.AMED)GOTO340 XS(MID)=XS(I) AINDEX(MID)=AINDEX(I) XS(I)=AMED AINDEX(I)=BMED AMED=XS(MID) BMED=AINDEX(MID) GOTO340 330 XS(L)=XS(K) AINDEX(L)=AINDEX(K) XS(K)=TX AINDEX(K)=TY 340 L=L-1 IF(XS(L).GT.AMED)GOTO340 TX=XS(L) TY=AINDEX(L) 350 K=K+1 IF(XS(K).LT.AMED)GOTO350 IF(K.LE.L)GOTO330 LMI=L-I JMK=J-K IF(LMI.LE.JMK)GOTO360 IL(M)=I IU(M)=L I=K M=M+1 GOTO380 360 IL(M)=K IU(M)=J J=L M=M+1 GOTO380 370 M=M-1 IF(M.EQ.0)RETURN I=IL(M) J=IU(M) 380 JMI=J-I IF(JMI.GE.11)GOTO310 IF(I.EQ.1)GOTO305 I=I-1 390 I=I+1 IF(I.EQ.J)GOTO370 AMED=XS(I+1) BMED=AINDEX(I+1) IF(XS(I).LE.AMED)GOTO390 K=I 395 XS(K+1)=XS(K) AINDEX(K+1)=AINDEX(K) K=K-1 IF(AMED.LT.XS(K))GOTO395 XS(K+1)=AMED AINDEX(K+1)=BMED GOTO390 END SUBROUTINE SORTII(X,N,XS,AINDEX) C C PURPOSE--THIS SUBROUTINE SORTS (IN ASCENDING ORDER) C THE N ELEMENTS OF THE SINGLE PRECISION VECTOR X, C PUTS THE RESULTING N SORTED VALUES INTO THE C SINGLE PRECISION VECTOR XS, AND C REARRANGES THE ELEMENTS 1, 2, ..., N OF VECTOR AINDEX C (ACCORDING TO THE SORT ON X). C THIS SUBROUTINE GIVES THE DATA ANALYST C THE ABILITY TO SORT ONE DATA VECTOR C WHILE DETERMINING THE POSITION INDEX C AFTER-THE-FACT, SO AS TO SUBSEQUENTLY C 'CARRY ALONG' THE ELEMENTS C OF MANY OTHER DATA VECTORS (DONE ELSEWHERE). C C THIS ROUTINE IS IDENTICAL TO SORTII WITH THE C DIFFERENCE THAT THIS ROUTINE ASSUMES X, XS, AND C AINDEX ARE INTEGER RATHER THAN REAL. C C INPUT ARGUMENTS--X = THE INTEGER VECTOR OF C OBSERVATIONS TO BE SORTED. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X. C OUTPUT ARGUMENTS--XS = THE INTEGER VECTOR C INTO WHICH THE SORTED DATA VALUES C FROM X WILL BE PLACED. C --AINDEX = THE INTEGER VECTOR C INTO WHICH THE REARRANGED C (ACCORDING TO THE SORT OF THE C VECTOR X) VALUES OF 1, 2, ..., N C WILL BE PLACED. C OUTPUT--THE SINGLE PRECISION VECTOR XS C CONTAINING THE SORTED C (IN ASCENDING ORDER) VALUES C OF THE SINGLE PRECISION VECTOR X, AND C THE SINGLE PRECISION VECTOR AINDEX C CONTAINING THE REARRANGED C (ACCORDING TO THE SORT ON X) C VALUES OF 1, 2, ..., N. C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. C RESTRICTIONS--THE DIMENSIONS OF THE VECTORS IL AND IU C (DEFINED AND USED INTERNALLY WITHIN C THIS SUBROUTINE) DICTATE THE MAXIMUM C ALLOWABLE VALUE OF N FOR THIS SUBROUTINE. C IF IL AND IU EACH HAVE DIMENSION K, C THEN N MAY NOT EXCEED 2**(K+1) - 1. C FOR THIS SUBROUTINE AS WRITTEN, THE DIMENSIONS C OF IL AND IU HAVE BEEN SET TO 36, C THUS THE MAXIMUM ALLOWABLE VALUE OF N IS C APPROXIMATELY 137 BILLION. C SINCE THIS EXCEEDS THE MAXIMUM ALLOWABLE C VALUE FOR AN INTEGER VARIABLE IN MANY COMPUTERS, C AND SINCE A SORT OF 137 BILLION ELEMENTS C IS PRESENTLY IMPRACTICAL AND UNLIKELY, C THEN THERE IS NO PRACTICAL RESTRICTION C ON THE MAXIMUM VALUE OF N FOR THIS SUBROUTINE. C (IN LIGHT OF THE ABOVE, NO CHECK OF THE C UPPER LIMIT OF N HAS BEEN INCORPORATED C INTO THIS SUBROUTINE.) C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C COMMENT--THE SMALLEST ELEMENT OF THE VECTOR X C WILL BE PLACED IN THE FIRST POSITION C OF THE VECTOR XS, C THE SECOND SMALLEST ELEMENT IN THE VECTOR X C WILL BE PLACED IN THE SECOND POSITION C OF THE VECTOR XS, C ETC. C COMMENT--AT THE END, AINDEX(1) WILL CONTAIN TBE ORIGINAL C POSITION NUMBER WHERE THE SMALLEST VALUE OF X DID RESIDE. C AINDEX(2) WILL CONTAIN THE ORIGINAL C POSITION NUMBER WHERE THE SECOND SMALLEST VALUE OF X DID RESIDE. C AINDEX(N) WILL CONTAIN THE ORIGINAL C POSITION NUMBER WHERE THE LARGEST VALUE OF X DID RESIDE. C COMMENT--THE INPUT VECTOR X REMAINS UNALTERED. C COMMENT--IF THE ANALYST DESIRES A SORT 'IN PLACE', C THIS IS DONE BY HAVING THE SAME C OUTPUT VECTOR AS INPUT VECTOR IN THE CALLING SEQUENCE. C THUS, FOR EXAMPLE, THE CALLING SEQUENCE C CALL SORTI(X,N,X,AINDEX) C IS ALLOWABLE AND WILL RESULT IN C THE DESIRED 'IN-PLACE' SORT. C COMMENT--THE SORTING ALGORTHM USED HEREIN C IS THE BINARY SORT. C THIS ALGORTHIM IS EXTREMELY FAST AS THE C FOLLOWING TIME TRIALS INDICATE. C THESE TIME TRIALS WERE CARRIED OUT ON THE C UNIVAC 1108 EXEC 8 SYSTEM AT NBS C IN AUGUST OF 1974. C BY WAY OF COMPARISON, THE TIME TRIAL VALUES C FOR THE EASY-TO-PROGRAM BUT EXTREMELY C INEFFICIENT BUBBLE SORT ALGORITHM HAVE C ALSO BEEN INCLUDED-- C NUMBER OF RANDOM BINARY SORT BUBBLE SORT C NUMBERS SORTED C N = 10 .002 SEC .002 SEC C N = 100 .011 SEC .045 SEC C N = 1000 .141 SEC 4.332 SEC C N = 3000 .476 SEC 37.683 SEC C N = 10000 1.887 SEC NOT COMPUTED C REFERENCES--CACM MARCH 1969, PAGE 186 (BINARY SORT ALGORITHM C BY RICHARD C. SINGLETON). C --CACM JANUARY 1970, PAGE 54. C --CACM OCTOBER 1970, PAGE 624. C --JACM JANUARY 1961, PAGE 41. 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 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 --NOVEMBER 1975. C UPDATED --JUNE 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C INTEGER X(*),XS(*),AINDEX(*) DIMENSION IU(36),IL(36) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LT.1)GOTO50 IF(N.EQ.1)GOTO55 IHOLD=X(1) DO60I=2,N IF(X(I).NE.IHOLD)GOTO90 60 CONTINUE DO61I=1,N XS(I)=X(I) AINDEX(I)=I 61 CONTINUE RETURN 50 WRITE(ICOUT,15) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,47)N CALL DPWRST('XXX','BUG ') RETURN 55 CONTINUE CCCCC WRITE(ICOUT,18) CCCCC CALL DPWRST('XXX','BUG ') XS(1)=X(1) AINDEX(1)=1 RETURN 90 CONTINUE 9 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 1ST INPUT ARGUMENT ', 1'(A VECTOR) TO THE SORTI SUBROUTINE HAS ALL ELEMENTS = ',E15.8) 15 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ', 1'SORTI SUBROUTINE IS NON-POSITIVE *****') 18 FORMAT('***** NON-FATAL DIAGNOSTIC--THE 2ND INPUT ARGUMENT ', 1'TO THE SORTI SUBROUTINE HAS THE VALUE 1') 47 FORMAT( 35H***** THE VALUE OF THE ARGUMENT IS ,I8 ,6H *****) C C COPY THE VECTOR X INTO THE VECTOR XS DO100I=1,N XS(I)=X(I) 100 CONTINUE C C COPY THE VECTOR INDEX INTO THE VECTOR INDEXS C DO150I=1,N AINDEX(I)=I 150 CONTINUE C C CHECK TO SEE IF THE INPUT VECTOR IS ALREADY SORTED C NM1=N-1 DO200I=1,NM1 IP1=I+1 IF(XS(I).LE.XS(IP1))GOTO200 GOTO250 200 CONTINUE RETURN 250 M=1 I=1 J=N 305 IF(I.GE.J)GOTO370 310 K=I MID=(I+J)/2 AMED=XS(MID) BMED=AINDEX(MID) IF(XS(I).LE.AMED)GOTO320 XS(MID)=XS(I) AINDEX(MID)=AINDEX(I) XS(I)=AMED AINDEX(I)=BMED AMED=XS(MID) BMED=AINDEX(MID) 320 L=J IF(XS(J).GE.AMED)GOTO340 XS(MID)=XS(J) AINDEX(MID)=AINDEX(J) XS(J)=AMED AINDEX(J)=BMED AMED=XS(MID) BMED=AINDEX(MID) IF(XS(I).LE.AMED)GOTO340 XS(MID)=XS(I) AINDEX(MID)=AINDEX(I) XS(I)=AMED AINDEX(I)=BMED AMED=XS(MID) BMED=AINDEX(MID) GOTO340 330 XS(L)=XS(K) AINDEX(L)=AINDEX(K) XS(K)=TX AINDEX(K)=TY 340 L=L-1 IF(XS(L).GT.AMED)GOTO340 TX=XS(L) TY=AINDEX(L) 350 K=K+1 IF(XS(K).LT.AMED)GOTO350 IF(K.LE.L)GOTO330 LMI=L-I JMK=J-K IF(LMI.LE.JMK)GOTO360 IL(M)=I IU(M)=L I=K M=M+1 GOTO380 360 IL(M)=K IU(M)=J J=L M=M+1 GOTO380 370 M=M-1 IF(M.EQ.0)RETURN I=IL(M) J=IU(M) 380 JMI=J-I IF(JMI.GE.11)GOTO310 IF(I.EQ.1)GOTO305 I=I-1 390 I=I+1 IF(I.EQ.J)GOTO370 AMED=XS(I+1) BMED=AINDEX(I+1) IF(XS(I).LE.AMED)GOTO390 K=I 395 XS(K+1)=XS(K) AINDEX(K+1)=AINDEX(K) K=K-1 IF(AMED.LT.XS(K))GOTO395 XS(K+1)=AMED AINDEX(K+1)=BMED GOTO390 END DOUBLE PRECISION FUNCTION SPHINC( N, R ) * * R * SPHINC = K I exp(-t*t/2) t**(N-1) dt, for N > 1. * N 0 * INTEGER I, N DOUBLE PRECISION R, RR, RP, PF, ET, PHI PARAMETER ( RP = 2.5066 28274 63100 04D0 ) IF ( R .GT. 0 ) THEN RR = R*R PF = 1.0D0 DO 100 I = N-2, 2, -2 PF = 1.0D0 + RR*PF/DBLE(I) 100 CONTINUE IF ( MOD( N, 2 ) .EQ. 0 ) THEN ET = LOG(PF) - RR/2.0D0 IF ( ET .GT. -40.0D0 ) THEN SPHINC = 1.0D0 - EXP( ET ) ELSE SPHINC = 1.0D0 END IF ELSE SPHINC = 1 - 2*PHI(-R) ET = LOG(R*PF) - RR/2 IF ( ET .GT. -40 ) SPHINC = SPHINC - 2.0D0*EXP( ET )/RP ENDIF ELSE SPHINC = 0.0D0 ENDIF C RETURN END DOUBLE PRECISION FUNCTION SPHLIM( N, A, B, INFI, Y ) DOUBLE PRECISION A(*), B(*), Y(*), CMN, CMX, SPHINC INTEGER INFI(*), I, N CMN = -10*N CMX = 10*N DO 100 I = 1,N IF ( Y(I) .GT. 0.0D0 ) THEN IF ( INFI(I) .NE. 1 ) CMX = MIN( CMX, B(I)/Y(I) ) IF ( INFI(I) .NE. 0 ) CMN = MAX( CMN, A(I)/Y(I) ) ELSE IF ( INFI(I) .NE. 1 ) CMN = MAX( CMN, B(I)/Y(I) ) IF ( INFI(I) .NE. 0 ) CMX = MIN( CMX, A(I)/Y(I) ) ENDIF 100 CONTINUE IF ( CMN .LT. CMX ) THEN IF ( CMN .GE. 0.0D0 .AND. CMX .GE. 0.0D0 ) THEN SPHLIM = SPHINC( N, CMX ) - SPHINC( N, CMN ) ELSEIF ( CMN .LT. 0.0D0 .AND. CMX .GE. 0.0D0 ) THEN SPHLIM = SPHINC( N, -CMN ) + SPHINC( N, CMX ) ELSE SPHLIM = SPHINC( N, -CMN ) - SPHINC( N, -CMX ) ENDIF ELSE SPHLIM = 0.0D0 ENDIF C RETURN END SUBROUTINE SPHMVN(N, LOWER, UPPER, INFIN, CORREL, MAXPTS, & ABSEPS, RELEPS, ERROR, VALUE, INFORM) * * A subroutine for computing multivariate normal probabilities. * This subroutine uses a Mont-Carlo algorithm given in the paper * "Three Digit Accurate Multiple Normal Probabilities", * pp. 369-380, Numer. Math. 35(1980), by I. Deak * * * 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. * EXTERNAL SPNRML INTEGER N, INFIS, INFIN(*), MAXPTS, MPT, INFORM, NS, IVLS DOUBLE PRECISION CORREL(*), LOWER(*), UPPER(*), & ABSEPS, RELEPS, ERROR, VALUE, D, E, EPS, SPNRNT IF ( N .GT. 100 ) THEN INFORM = 2 VALUE = 0.0D0 ERROR = 1.0D0 RETURN ENDIF INFORM = SPNRNT(N, CORREL, LOWER, UPPER, INFIN, INFIS, D, E, NS) IF ( N-INFIS .EQ. 0 ) THEN VALUE = 1.0D0 ERROR = 0.0D0 ELSE IF ( N-INFIS .EQ. 1 ) THEN VALUE = E - D ERROR = 2E-16 ELSE * * Call then Monte-Carlo integration subroutine * MPT = 25 + NS/N**3 CALL SCRUDE( N-INFIS, MPT, ERROR, VALUE, 0 ) IVLS = MPT*NS 10 EPS = MAX( ABSEPS, RELEPS*ABS(VALUE) ) IF ( ERROR .GT. EPS .AND. IVLS .LT. MAXPTS ) THEN MPT = MAX( MIN( INT(MPT*(ERROR/(EPS))**2), & ( MAXPTS - IVLS )/NS ), 10 ) CALL SCRUDE( N-INFIS, MPT, ERROR, VALUE, 1 ) IVLS = IVLS + MPT*NS GO TO 10 ENDIF IF ( ERROR. GT. EPS .AND. IVLS .GE. MAXPTS ) INFORM = 1 ENDIF C RETURN END SUBROUTINE SPHMVT( N, NU, LOWER, UPPER, INFIN, CORREL, MAXPTS, * ABSEPS, RELEPS, ERROR, VALUE, INFORM ) * * A subroutine for computing multivariate t probabilities. * This subroutine uses a modified version of the Mont-Carlo * algorithm for multivariatie Normal probabilities in the paper * "Three Digit Accurate Multiple Normal Probabilities", * pp. 369-380, Numer. Math. 35(1980), by I. Deak * * * 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 > 50. * EXTERNAL SPMVTI INTEGER N, NU, INFIS, INFIN(*), MAXPTS, MPT, INFORM, NS, IVLS DOUBLE PRECISION CORREL(*), LOWER(*), UPPER(*), * ABSEPS, RELEPS, ERROR, VALUE, D, E, EPS, SPMVTI IF ( N .GT. 50 ) THEN INFORM = 2 VALUE = 0.0D0 ERROR = 1.0D0 RETURN ENDIF INFORM = SPMVTI( N,NU, CORREL, LOWER,UPPER,INFIN, INFIS, D,E, NS ) IF ( N-INFIS .EQ. 0 ) THEN VALUE = 1.0D0 ERROR = 0.0D0 ELSE IF ( N-INFIS .EQ. 1 ) THEN VALUE = E - D ERROR = 2E-16 ELSE * * Call the Monte-Carlo integration subroutine * MPT = 25 + NS/N**3 CALL TCRUDE( N-INFIS, MPT, ERROR, VALUE, 0 ) IVLS = MPT*NS 10 EPS = MAX( ABSEPS, RELEPS*ABS(VALUE) ) IF ( ERROR .GT. EPS .AND. IVLS .LT. MAXPTS ) THEN MPT = MAX( MIN( INT( MPT*( ERROR/EPS )**2 ), * ( MAXPTS - IVLS )/NS ), 10 ) CALL TCRUDE( N-INFIS, MPT, ERROR, VALUE, 1 ) IVLS = IVLS + MPT*NS GO TO 10 ENDIF IF ( ERROR. GT. EPS .AND. IVLS .GE. MAXPTS ) INFORM = 1 ENDIF C RETURN END DOUBLE PRECISION FUNCTION SPHLMT( N, NU, A, B, INFI, Y ) DOUBLE PRECISION A(*), B(*), Y(*), CMN, CMX, SPHNCT INTEGER INFI(*), I, N, NU CMN = -10.0D0*N CMX = 10.0D0*N DO 100 I = 1,N IF ( Y(I) .GT. 0.0D0 ) THEN IF ( INFI(I) .NE. 1 ) CMX = MIN( CMX, B(I)/Y(I) ) IF ( INFI(I) .NE. 0 ) CMN = MAX( CMN, A(I)/Y(I) ) ELSE IF ( INFI(I) .NE. 1 ) CMN = MAX( CMN, B(I)/Y(I) ) IF ( INFI(I) .NE. 0 ) CMX = MIN( CMX, A(I)/Y(I) ) ENDIF 100 CONTINUE IF ( CMN .LT. CMX ) THEN IF ( CMN .GE. 0.0D0 .AND. CMX .GE. 0.0D0 ) THEN SPHLMT = SPHNCT( N, NU, CMX ) - SPHNCT( N, NU, CMN ) ELSEIF ( CMN .LT. 0.0D0 .AND. CMX .GE. 00D0 ) THEN SPHLMT = SPHNCT( N, NU, -CMN ) + SPHNCT( N, NU, CMX ) ELSE SPHLMT = SPHNCT( N, NU, -CMN ) - SPHNCT( N, NU, -CMX ) ENDIF ELSE SPHLMT = 0.0D0 ENDIF C RETURN END DOUBLE PRECISION FUNCTION SPHNCT( M, NU, R ) * * R * SPHNCT = K I ( 1 + t**2/NU )**(-(NU+M)/2 ) t**(M-1) dt, for M > 0. * M 0 * INTEGER I, M, NU, NUOLD DOUBLE PRECISION R, RR, RT, PI, PF, STUDNT, TCON PARAMETER ( PI = 3.14159 26535 89793D0 ) SAVE NUOLD, TCON DATA NUOLD / 0 / IF ( R .GT. 0.0D0 ) THEN IF ( M .LE. 1 ) THEN SPHNCT = 2.0D0*STUDNT( NU, R ) - 1.0D0 ELSE IF ( M .EQ. 2 ) THEN SPHNCT = 1.0D0 - 1.0D0/SQRT( 1.0D0 + R*R/NU )**NU ELSE RR = R*R/NU RT = RR/( 1.0D0 + RR ) PF = 1.0D0 DO 100 I = M - 2, 2, -2 PF = 1 + PF*RT*DBLE( NU + I - 2 )/DBLE(I) 100 CONTINUE PF = PF*SQRT( RT/RR )**NU IF ( MOD( M, 2 ) .EQ. 0 ) THEN SPHNCT = 1.0D0 - PF ELSE IF ( NU .NE. NUOLD ) THEN NUOLD = NU TCON = 1.0D0 IF ( MOD( NU, 2 ) .EQ. 0 ) THEN TCON = TCON/2.0D0 ELSE TCON = TCON/PI END IF DO 200 I = NU-2, 1, -2 TCON = ( I + 1 )*TCON/I 200 CONTINUE END IF SPHNCT = 2.0D0* & ( STUDNT( NU, R ) - TCON*SQRT(RT)*PF ) - 1.0D0 ENDIF ENDIF ELSE SPHNCT = 0.0D0 ENDIF C RETURN END DOUBLE PRECISION FUNCTION SPMVT(N) * * Integrand subroutine * DOUBLE PRECISION LOWER(*), UPPER(*), CORREL(*), D, E, ZERO INTEGER N, INFIN(*), INFIS INTEGER NL, IJ, I, II, J, K, NS, NSO, ND, NU, NUIN PARAMETER ( NL = 50, ND = 2, ZERO = 0 ) DOUBLE PRECISION A(NL), B(NL), U(NL,NL), Y(NL), COV(NL*(NL+1)/2) INTEGER INFI(NL), IS(NL), IC(NL) DOUBLE PRECISION RS, TMP, BT, RNOR, SPHLMT, SPMVTI SAVE NU, A, B, INFI, U * * First generate U = COV*(random orthogonal matrix) * DO 100 K = N-1, 1, -1 TMP = 0 DO 200 J = K, N Y(J) = RNOR() TMP = TMP + Y(J)**2 200 CONTINUE TMP = -SQRT(TMP) BT = 1/( TMP*( Y(K) + TMP ) ) Y(K) = Y(K) + TMP DO 300 I = 1, N TMP = 0 DO 350 J = K, N TMP = TMP + U(I,J)*Y(J) 350 CONTINUE TMP = BT*TMP DO 380 J = K, N U(I,J) = U(I,J) - TMP*Y(J) 380 CONTINUE 300 CONTINUE 100 CONTINUE * * Compute integrand average * RS = SQRT( DBLE(ND) ) DO 400 I = 1,ND IC(I) = I 400 CONTINUE IC(ND+1) = N+1 SPMVT = 0.0D0 NS = 0 10 CONTINUE DO 410 I = 1,ND IS(I) = -1 410 CONTINUE 20 CONTINUE DO 420 I = 1, N TMP = 0 DO 430 J = 1,ND TMP = TMP + IS(J)*U( I, IC(J) ) 430 CONTINUE Y(I) = TMP/RS 420 CONTINUE NS = NS + 1 SPMVT = SPMVT + ( SPHLMT( N, NU, A, B, INFI, Y ) - SPMVT )/NS DO 440 I = 1, ND IS(I) = IS(I) + 2 IF ( IS(I) .LT. 2 ) GO TO 20 IS(I) = -1 440 CONTINUE DO 450 I = 1, ND IC(I) = IC(I) + 1 IF ( IC(I) .LT. IC(I+1) ) GO TO 10 IC(I) = I 450 CONTINUE SPMVT = SPMVT/2.0D0 RETURN * ENTRY SPMVTI( N,NUIN, CORREL, LOWER,UPPER,INFIN, INFIS, D,E, NSO ) SPMVTI = 0.0D0 NU = NUIN * * Initialisation * II = 0 IJ = 0 INFIS = 0 DO 500 I = 1, N INFI(I) = INFIN(I) IF ( INFI(I) .LT. 0 ) THEN INFIS = INFIS + 1 ELSE A(I) = 0.0D0 B(I) = 0.0D0 IF ( INFI(I) .NE. 0 ) A(I) = LOWER(I) IF ( INFI(I) .NE. 1 ) B(I) = UPPER(I) ENDIF DO 550 J = 1, I-1 II = II + 1 IJ = IJ + 1 COV(IJ) = CORREL(II) 550 CONTINUE IJ = IJ + 1 COV(IJ) = 1 500 CONTINUE NSO = 1 DO 600 I = 1,ND NSO = 2*NSO*( N - INFIS - I + 1 )/I 600 CONTINUE * * First move any doubly infinite limits to innermost positions * IF ( INFIS .LT. N ) THEN DO 700 I = N, N-INFIS+1, -1 IF ( INFI(I) .GE. 0 ) THEN DO 750 J = 1,I-1 IF ( INFI(J) .LT. 0 ) THEN CALL RCSWAP( J, I, A, B, INFI, N, COV ) GO TO 700 ENDIF 750 CONTINUE ENDIF 700 CONTINUE ENDIF II = 0 DO 800 I = 1, N-INFIS DO 810 J = 1, I U(J,I) = 0 II = II + 1 U(I,J) = COV(II) 810 CONTINUE 800 CONTINUE * * Determine Cholesky decomposition * DO 900 J = 1, N-INFIS DO 910 I = J, N-INFIS TMP = U(I,J) DO 920 K = 1, J-1 TMP = TMP - U(I,K)*U(J,K) 920 CONTINUE IF ( I .EQ. J ) THEN U(J,J) = SQRT( MAX( TMP, ZERO ) ) ELSE IF ( U(I,I) .GT. 0 ) THEN U(I,J) = TMP/U(J,J) ELSE U(I,J) = 0.0D0 END IF 910 CONTINUE 900 CONTINUE DO 950 I = 1, N-INFIS IF ( U(I,I) .GT. 0 ) THEN IF ( INFI(I) .NE. 0 ) A(I) = A(I)/U(I,I) IF ( INFI(I) .NE. 1 ) B(I) = B(I)/U(I,I) DO 960 J = 1,I U(I,J) = U(I,J)/U(I,I) 960 CONTINUE ENDIF 950 CONTINUE CALL MVTLMS( NU, A(1), B(1), INFI(1), D, E ) C RETURN END DOUBLE PRECISION FUNCTION SPNRML(N) * * Integrand subroutine * DOUBLE PRECISION LOWER(*), UPPER(*), CORREL(*), D, E, ZERO INTEGER N, INFIN(*), INFIS INTEGER NL, IJ, I, J, K, NS, NSO, ND PARAMETER ( NL = 100, ND = 3, ZERO = 0 ) DOUBLE PRECISION A(NL), B(NL), U(NL,NL), Y(NL) INTEGER INFI(NL), IS(NL), IC(NL) DOUBLE PRECISION RS, TMP, BT, RNOR, SPHLIM, SPNRNT SAVE A, B, INFI, U * * First generate U = COV*(random orthogonal matrix) * DO 100 K = N-1, 1, -1 TMP = 0 DO 200 J = K, N Y(J) = RNOR() TMP = TMP + Y(J)**2 200 CONTINUE TMP = -SQRT(TMP) BT = 1/( TMP*( Y(K) + TMP ) ) Y(K) = Y(K) + TMP DO 300 I = 1, N TMP = 0 DO 400 J = K, N TMP = TMP + U(I,J)*Y(J) 400 CONTINUE TMP = BT*TMP DO 500 J = K, N U(I,J) = U(I,J) - TMP*Y(J) 500 CONTINUE 300 CONTINUE 100 CONTINUE * * Compute integrand average * RS = SQRT( DBLE(ND) ) DO 600 I = 1,ND IC(I) = I 600 CONTINUE IC(ND+1) = N+1 SPNRML = 0 NS = 0 10 DO 650 I = 1,ND IS(I) = -1 650 CONTINUE 20 DO 700 I = 1, N TMP = 0 DO 750 J = 1,ND TMP = TMP + IS(J)*U(I,IC(J)) 750 CONTINUE Y(I) = TMP/RS 700 CONTINUE NS = NS + 1 SPNRML = SPNRML + ( SPHLIM( N, A, B, INFI, Y ) - SPNRML )/NS DO 800 I = 1, ND IS(I) = IS(I) + 2 IF ( IS(I) .LT. 2 ) GO TO 20 IS(I) = -1 800 CONTINUE DO 850 I = 1, ND IC(I) = IC(I) + 1 IF ( IC(I) .LT. IC(I+1) ) GO TO 10 IC(I) = I 850 CoNTINUE SPNRML = SPNRML/2 RETURN ENTRY SPNRNT( N, CORREL, LOWER, UPPER, INFIN, INFIS, D, E, NSO ) SPNRNT = 0 * * Initialisation * IJ = 0 INFIS = 0 DO 900 I = 1, N INFI(I) = INFIN(I) IF ( INFI(I) .LT. 0 ) THEN INFIS = INFIS + 1 ELSE A(I) = 0 B(I) = 0 IF ( INFI(I) .NE. 0 ) A(I) = LOWER(I) IF ( INFI(I) .NE. 1 ) B(I) = UPPER(I) ENDIF DO 910 J = 1, I-1 IJ = IJ + 1 U(I,J) = CORREL(IJ) U(J,I) = 0 910 CONTINUE U(I,I) = 1 900 CONTINUE NSO = 1 DO 920 I = 1,ND NSO = 2*NSO*( N - INFIS - I + 1 )/I 920 CONTINUE * * First move any doubly infinite limits to innermost positions * IF ( INFIS .LT. N ) THEN DO 930 I = N, N-INFIS+1, -1 IF ( INFI(I) .GE. 0 ) THEN DO 940 J = 1,I-1 IF ( INFI(J) .LT. 0 ) THEN DO 950 K = 1, J-1 TMP = U(J,K) U(J,K) = U(I,K) U(I,K) = TMP 950 CONTINUE DO 960 K = J+1, I-1 TMP = U(I,K) U(I,K) = U(K,J) U(K,J) = TMP 960 CONTINUE DO 970 K = I+1, N TMP = U(K,J) U(K,J) = U(K,I) U(K,I) = TMP 970 CONTINUE TMP = A(J) A(J) = A(I) A(I) = TMP TMP = B(J) B(J) = B(I) B(I) = TMP TMP = INFI(J) INFI(J) = INFI(I) INFI(I) = TMP GO TO 930 ENDIF 940 CONTINUE ENDIF 930 CONTINUE ENDIF * * Determine Cholesky decomposition * DO 980 J = 1, N-INFIS DO 982 I = J, N-INFIS TMP = U(I,J) DO 984 K = 1, J-1 TMP = TMP - U(I,K)*U(J,K) 984 CONTINUE IF ( I .EQ. J ) THEN U(J,J) = SQRT( MAX( TMP, ZERO ) ) ELSE IF ( U(I,I) .GT. 0 ) THEN U(I,J) = TMP/U(J,J) ELSE U(I,J) = 0 END IF 982 CONTINUE 980 CONTINUE DO 990 I = 1, N-INFIS IF ( U(I,I) .GT. 0 ) THEN IF ( INFI(I) .NE. 0 ) A(I) = A(I)/U(I,I) IF ( INFI(I) .NE. 1 ) B(I) = B(I)/U(I,I) DO 995 J = 1,I U(I,J) = U(I,J)/U(I,I) 995 CONTINUE ENDIF 990 CONTINUE CALL LIMITS( A(1), B(1), INFI(1), D, E ) C RETURN END SUBROUTINE SPOCO(A,LDA,N,RCOND,Z,INFO) C***BEGIN PROLOGUE SPOCO C***DATE WRITTEN 780814 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D2B1B C***KEYWORDS CONDITION,FACTOR,LINEAR ALGEBRA,LINPACK,MATRIX, C POSITIVE DEFINITE C***AUTHOR MOLER, C. B., (U. OF NEW MEXICO) C***PURPOSE Factors a real SYMMETRIC POSITIVE DEFINITE MATRIX C and estimates the condition number of the matrix. C***DESCRIPTION C C SPOCO factors a real symmetric positive definite matrix C and estimates the condition of the matrix. C C If RCOND is not needed, SPOFA is slightly faster. C To solve A*X = B , follow SPOCO by SPOSL. C To compute INVERSE(A)*C , follow SPOCO by SPOSL. C To compute DETERMINANT(A) , follow SPOCO by SPODI. C To compute INVERSE(A) , follow SPOCO by SPODI. C C On Entry C C A REAL(LDA, N) C the symmetric matrix to be factored. Only the C diagonal and upper triangle are used. C C LDA INTEGER C the leading dimension of the array A . C C N INTEGER C the order of the matrix A . C C On Return C C A an upper triangular matrix R so that A = TRANS(R)*R C where TRANS(R) is the transpose. C The strict lower triangle is unaltered. C If INFO .NE. 0 , the factorization is not complete. C C RCOND REAL C an estimate of the reciprocal condition of A . C For the system A*X = B , relative perturbations C in A and B of size EPSILON may cause C relative perturbations in X of size EPSILON/RCOND . C If RCOND is so small that the logical expression C 1.0 + RCOND .EQ. 1.0 C is true, then A may be singular to working C precision. In particular, RCOND is zero if C exact singularity is detected or the estimate C underflows. If INFO .NE. 0 , RCOND is unchanged. C C Z REAL(N) C a work vector whose contents are usually unimportant. C If A is close to a singular matrix, then Z is C an approximate null vector in the sense that C NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . C If INFO .NE. 0 , Z is unchanged. C C INFO INTEGER C = 0 for normal return. C = K signals an error condition. The leading minor C of order K is not positive definite. C C LINPACK. This version dated 08/14/78 . C Cleve Moler, University of New Mexico, Argonne National Lab. C C Subroutines and Functions C C LINPACK SPOFA C BLAS SAXPY,SDOT,SSCAL,SASUM C Fortran ABS,AMAX1,REAL,SIGN C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., C *LINPACK USERS GUIDE*, SIAM, 1979. C***ROUTINES CALLED SASUM,SAXPY,SDOT,SPOFA,SSCAL C***END PROLOGUE SPOCO INTEGER LDA,N,INFO REAL A(LDA,1),Z(1) REAL RCOND C REAL SDOT,EK,T,WK,WKM REAL ANORM,S,SASUM,SM,YNORM INTEGER I,J,JM1,K,KB,KP1 C C FIND NORM OF A USING ONLY UPPER HALF C C***FIRST EXECUTABLE STATEMENT SPOCO DO 30 J = 1, N Z(J) = SASUM(J,A(1,J),1) JM1 = J - 1 IF (JM1 .LT. 1) GO TO 20 DO 10 I = 1, JM1 Z(I) = Z(I) + ABS(A(I,J)) 10 CONTINUE 20 CONTINUE 30 CONTINUE ANORM = 0.0E0 DO 40 J = 1, N ANORM = AMAX1(ANORM,Z(J)) 40 CONTINUE C C FACTOR C CALL SPOFA(A,LDA,N,INFO) IF (INFO .NE. 0) GO TO 180 C C RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . C ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND A*Y = E . C THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL C GROWTH IN THE ELEMENTS OF W WHERE TRANS(R)*W = E . C THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. C C SOLVE TRANS(R)*W = E C EK = 1.0E0 DO 50 J = 1, N Z(J) = 0.0E0 50 CONTINUE DO 110 K = 1, N IF (Z(K) .NE. 0.0E0) EK = SIGN(EK,-Z(K)) IF (ABS(EK-Z(K)) .LE. A(K,K)) GO TO 60 S = A(K,K)/ABS(EK-Z(K)) CALL SSCAL(N,S,Z,1) EK = S*EK 60 CONTINUE WK = EK - Z(K) WKM = -EK - Z(K) S = ABS(WK) SM = ABS(WKM) WK = WK/A(K,K) WKM = WKM/A(K,K) KP1 = K + 1 IF (KP1 .GT. N) GO TO 100 DO 70 J = KP1, N SM = SM + ABS(Z(J)+WKM*A(K,J)) Z(J) = Z(J) + WK*A(K,J) S = S + ABS(Z(J)) 70 CONTINUE IF (S .GE. SM) GO TO 90 T = WKM - WK WK = WKM DO 80 J = KP1, N Z(J) = Z(J) + T*A(K,J) 80 CONTINUE 90 CONTINUE 100 CONTINUE Z(K) = WK 110 CONTINUE S = 1.0E0/SASUM(N,Z,1) CALL SSCAL(N,S,Z,1) C C SOLVE R*Y = W C DO 130 KB = 1, N K = N + 1 - KB IF (ABS(Z(K)) .LE. A(K,K)) GO TO 120 S = A(K,K)/ABS(Z(K)) CALL SSCAL(N,S,Z,1) 120 CONTINUE Z(K) = Z(K)/A(K,K) T = -Z(K) CALL SAXPY(K-1,T,A(1,K),1,Z(1),1) 130 CONTINUE S = 1.0E0/SASUM(N,Z,1) CALL SSCAL(N,S,Z,1) C YNORM = 1.0E0 C C SOLVE TRANS(R)*V = Y C DO 150 K = 1, N Z(K) = Z(K) - SDOT(K-1,A(1,K),1,Z(1),1) IF (ABS(Z(K)) .LE. A(K,K)) GO TO 140 S = A(K,K)/ABS(Z(K)) CALL SSCAL(N,S,Z,1) YNORM = S*YNORM 140 CONTINUE Z(K) = Z(K)/A(K,K) 150 CONTINUE S = 1.0E0/SASUM(N,Z,1) CALL SSCAL(N,S,Z,1) YNORM = S*YNORM C C SOLVE R*Z = V C DO 170 KB = 1, N K = N + 1 - KB IF (ABS(Z(K)) .LE. A(K,K)) GO TO 160 S = A(K,K)/ABS(Z(K)) CALL SSCAL(N,S,Z,1) YNORM = S*YNORM 160 CONTINUE Z(K) = Z(K)/A(K,K) T = -Z(K) CALL SAXPY(K-1,T,A(1,K),1,Z(1),1) 170 CONTINUE C MAKE ZNORM = 1.0 S = 1.0E0/SASUM(N,Z,1) CALL SSCAL(N,S,Z,1) YNORM = S*YNORM C IF (ANORM .NE. 0.0E0) RCOND = YNORM/ANORM IF (ANORM .EQ. 0.0E0) RCOND = 0.0E0 180 CONTINUE RETURN END SUBROUTINE SPOFA(A,LDA,N,INFO) C***BEGIN PROLOGUE SPOFA C***DATE WRITTEN 780814 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D2B1B C***KEYWORDS FACTOR,LINEAR ALGEBRA,LINPACK,MATRIX,POSITIVE DEFINITE C***AUTHOR MOLER, C. B., (U. OF NEW MEXICO) C***PURPOSE Factors a real SYMMETRIC POSITIVE DEFINITE matrix. C***DESCRIPTION C C SPOFA factors a real symmetric positive definite matrix. C C SPOFA is usually called by SPOCO, but it can be called C directly with a saving in time if RCOND is not needed. C (Time for SPOCO) = (1 + 18/N)*(Time for SPOFA) . C C On Entry C C A REAL(LDA, N) C the symmetric matrix to be factored. Only the C diagonal and upper triangle are used. C C LDA INTEGER C the leading dimension of the array A . C C N INTEGER C the order of the matrix A . C C On Return C C A an upper triangular matrix R so that A = TRANS(R)*R C where TRANS(R) is the transpose. C The strict lower triangle is unaltered. C If INFO .NE. 0 , the factorization is not complete. C C INFO INTEGER C = 0 for normal return. C = K signals an error condition. The leading minor C of order K is not positive definite. C C LINPACK. This version dated 08/14/78 . C Cleve Moler, University of New Mexico, Argonne National Lab. C C Subroutines and Functions C C BLAS SDOT C Fortran SQRT C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., C *LINPACK USERS GUIDE*, SIAM, 1979. C***ROUTINES CALLED SDOT C***END PROLOGUE SPOFA INTEGER LDA,N,INFO REAL A(LDA,1) C REAL SDOT,T REAL S INTEGER J,JM1,K C BEGIN BLOCK WITH ...EXITS TO 40 C C C***FIRST EXECUTABLE STATEMENT SPOFA DO 30 J = 1, N INFO = J S = 0.0E0 JM1 = J - 1 IF (JM1 .LT. 1) GO TO 20 DO 10 K = 1, JM1 T = A(K,J) - SDOT(K-1,A(1,K),1,A(1,J),1) T = T/A(K,K) A(K,J) = T S = S + T*T 10 CONTINUE 20 CONTINUE S = A(J,J) - S C ......EXIT IF (S .LE. 0.0E0) GO TO 40 A(J,J) = SQRT(S) 30 CONTINUE INFO = 0 40 CONTINUE RETURN END SUBROUTINE SQRDC(X,LDX,N,P,QRAUX,JPVT,WORK,JOB) C***BEGIN PROLOGUE SQRDC C***DATE WRITTEN 780814 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D5 C***KEYWORDS DECOMPOSITION,LINEAR ALGEBRA,LINPACK,MATRIX, C ORTHOGONAL TRIANGULAR C***AUTHOR STEWART, G. W., (U. OF MARYLAND) C***PURPOSE Uses Householder transformations to compute the QR C factorization of an N by P matrix X. Column pivoting is C a users option. C***DESCRIPTION C C SQRDC uses Householder transformations to compute the QR C factorization of an N by P matrix X. Column pivoting C based on the 2-norms of the reduced columns may be C performed at the user's option. C C On Entry C C X REAL(LDX,P), where LDX .GE. N. C X contains the matrix whose decomposition is to be C computed. C C LDX INTEGER. C LDX is the leading dimension of the array X. C C N INTEGER. C N is the number of rows of the matrix X. C C P INTEGER. C P is the number of columns of the matrix X. C C JPVT INTEGER(P). C JPVT contains integers that control the selection C of the pivot columns. The K-th column X(K) of X C is placed in one of three classes according to the C value of JPVT(K). C C If JPVT(K) .GT. 0, then X(K) is an initial C column. C C If JPVT(K) .EQ. 0, then X(K) is a free column. C C If JPVT(K) .LT. 0, then X(K) is a final column. C C Before the decomposition is computed, initial columns C are moved to the beginning of the array X and final C columns to the end. Both initial and final columns C are frozen in place during the computation and only C free columns are moved. At the K-th stage of the C reduction, if X(K) is occupied by a free column, C it is interchanged with the free column of largest C reduced norm. JPVT is not referenced if C JOB .EQ. 0. C C WORK REAL(P). C WORK is a work array. WORK is not referenced if C JOB .EQ. 0. C C JOB INTEGER. C JOB is an integer that initiates column pivoting. C If JOB .EQ. 0, no pivoting is done. C If JOB .NE. 0, pivoting is done. C C On Return C C X X contains in its upper triangle the upper C triangular matrix R of the QR factorization. C Below its diagonal X contains information from C which the orthogonal part of the decomposition C can be recovered. Note that if pivoting has C been requested, the decomposition is not that C of the original matrix X but that of X C with its columns permuted as described by JPVT. C C QRAUX REAL(P). C QRAUX contains further information required to recover C the orthogonal part of the decomposition. C C JPVT JPVT(K) contains the index of the column of the C original matrix that has been interchanged into C the K-th column, if pivoting was requested. C C LINPACK. This version dated 08/14/78 . C G. W. Stewart, University of Maryland, Argonne National Lab. C C SQRDC uses the following functions and subprograms. C C BLAS SAXPY,SDOT,SSCAL,SSWAP,SNRM2 C Fortran ABS,AMAX1,MIN0,SQRT C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., C *LINPACK USERS GUIDE*, SIAM, 1979. C***ROUTINES CALLED SAXPY,SDOT,SNRM2,SSCAL,SSWAP C***END PROLOGUE SQRDC INTEGER LDX,N,P,JOB INTEGER JPVT(1) REAL X(LDX,1),QRAUX(1),WORK(1) C INTEGER J,JP,L,LP1,LUP,MAXJ,PL,PU REAL MAXNRM,SNRM2,TT REAL SDOT,NRMXL,T LOGICAL NEGJ,SWAPJ C C***FIRST EXECUTABLE STATEMENT SQRDC PL = 1 PU = 0 IF (JOB .EQ. 0) GO TO 60 C C PIVOTING HAS BEEN REQUESTED. REARRANGE THE COLUMNS C ACCORDING TO JPVT. C DO 20 J = 1, P SWAPJ = JPVT(J) .GT. 0 NEGJ = JPVT(J) .LT. 0 JPVT(J) = J IF (NEGJ) JPVT(J) = -J IF (.NOT.SWAPJ) GO TO 10 IF (J .NE. PL) CALL SSWAP(N,X(1,PL),1,X(1,J),1) JPVT(J) = JPVT(PL) JPVT(PL) = J PL = PL + 1 10 CONTINUE 20 CONTINUE PU = P DO 50 JJ = 1, P J = P - JJ + 1 IF (JPVT(J) .GE. 0) GO TO 40 JPVT(J) = -JPVT(J) IF (J .EQ. PU) GO TO 30 CALL SSWAP(N,X(1,PU),1,X(1,J),1) JP = JPVT(PU) JPVT(PU) = JPVT(J) JPVT(J) = JP 30 CONTINUE PU = PU - 1 40 CONTINUE 50 CONTINUE 60 CONTINUE C C COMPUTE THE NORMS OF THE FREE COLUMNS. C IF (PU .LT. PL) GO TO 80 DO 70 J = PL, PU QRAUX(J) = SNRM2(N,X(1,J),1) WORK(J) = QRAUX(J) 70 CONTINUE 80 CONTINUE C C PERFORM THE HOUSEHOLDER REDUCTION OF X. C LUP = MIN0(N,P) DO 200 L = 1, LUP IF (L .LT. PL .OR. L .GE. PU) GO TO 120 C C LOCATE THE COLUMN OF LARGEST NORM AND BRING IT C INTO THE PIVOT POSITION. C MAXNRM = 0.0E0 MAXJ = L DO 100 J = L, PU IF (QRAUX(J) .LE. MAXNRM) GO TO 90 MAXNRM = QRAUX(J) MAXJ = J 90 CONTINUE 100 CONTINUE IF (MAXJ .EQ. L) GO TO 110 CALL SSWAP(N,X(1,L),1,X(1,MAXJ),1) QRAUX(MAXJ) = QRAUX(L) WORK(MAXJ) = WORK(L) JP = JPVT(MAXJ) JPVT(MAXJ) = JPVT(L) JPVT(L) = JP 110 CONTINUE 120 CONTINUE QRAUX(L) = 0.0E0 IF (L .EQ. N) GO TO 190 C C COMPUTE THE HOUSEHOLDER TRANSFORMATION FOR COLUMN L. C NRMXL = SNRM2(N-L+1,X(L,L),1) IF (NRMXL .EQ. 0.0E0) GO TO 180 IF (X(L,L) .NE. 0.0E0) NRMXL = SIGN(NRMXL,X(L,L)) CALL SSCAL(N-L+1,1.0E0/NRMXL,X(L,L),1) X(L,L) = 1.0E0 + X(L,L) C C APPLY THE TRANSFORMATION TO THE REMAINING COLUMNS, C UPDATING THE NORMS. C LP1 = L + 1 IF (P .LT. LP1) GO TO 170 DO 160 J = LP1, P T = -SDOT(N-L+1,X(L,L),1,X(L,J),1)/X(L,L) CALL SAXPY(N-L+1,T,X(L,L),1,X(L,J),1) IF (J .LT. PL .OR. J .GT. PU) GO TO 150 IF (QRAUX(J) .EQ. 0.0E0) GO TO 150 TT = 1.0E0 - (ABS(X(L,J))/QRAUX(J))**2 TT = AMAX1(TT,0.0E0) T = TT TT = 1.0E0 + 0.05E0*TT*(QRAUX(J)/WORK(J))**2 IF (TT .EQ. 1.0E0) GO TO 130 QRAUX(J) = QRAUX(J)*SQRT(T) GO TO 140 130 CONTINUE QRAUX(J) = SNRM2(N-L,X(L+1,J),1) WORK(J) = QRAUX(J) 140 CONTINUE 150 CONTINUE 160 CONTINUE 170 CONTINUE C C SAVE THE TRANSFORMATION. C QRAUX(L) = X(L,L) X(L,L) = -NRMXL 180 CONTINUE 190 CONTINUE 200 CONTINUE RETURN END SUBROUTINE SQRSL(X,LDX,N,K,QRAUX,Y,QY,QTY,B,RSD,XB,JOB,INFO) C***BEGIN PROLOGUE SQRSL C***DATE WRITTEN 780814 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D9,D2A1 C***KEYWORDS LINEAR ALGEBRA,LINPACK,MATRIX,ORTHOGONAL TRIANGULAR,SOLVE C***AUTHOR STEWART, G. W., (U. OF MARYLAND) C***PURPOSE Applies the output of SQRDC to compute coordinate trans- C formations projections, and least squares solutions. C***DESCRIPTION C C SQRSL applies the output of SQRDC to compute coordinate C transformations, projections, and least squares solutions. C For K .LE. MIN(N,P), let XK be the matrix C C XK = (X(JPVT(1)),X(JPVT(2)), ... ,X(JPVT(K))) C C formed from columnns JPVT(1), ... ,JPVT(K) of the original C N x P matrix X that was input to SQRDC (if no pivoting was C done, XK consists of the first K columns of X in their C original order). SQRDC produces a factored orthogonal matrix Q C and an upper triangular matrix R such that C C XK = Q * (R) C (0) C C This information is contained in coded form in the arrays C X and QRAUX. C C On Entry C C X REAL(LDX,P) C X contains the output of SQRDC. C C LDX INTEGER C LDX is the leading dimension of the array X. C C N INTEGER C N is the number of rows of the matrix XK. It must C have the same value as N in SQRDC. C C K INTEGER C K is the number of columns of the matrix XK. K C must not be greater than MIN(N,P), where P is the C same as in the calling sequence to SQRDC. C C QRAUX REAL(P) C QRAUX contains the auxiliary output from SQRDC. C C Y REAL(N) C Y contains an N-vector that is to be manipulated C by SQRSL. C C JOB INTEGER C JOB specifies what is to be computed. JOB has C the decimal expansion ABCDE, with the following C meaning. C C If A .NE. 0, compute QY. C If B,C,D, or E .NE. 0, compute QTY. C If C .NE. 0, compute B. C If D .NE. 0, compute RSD. C If E .NE. 0, compute XB. C C Note that a request to compute B, RSD, or XB C automatically triggers the computation of QTY, for C which an array must be provided in the calling C sequence. C C On Return C C QY REAL(N). C QY contains Q*Y, if its computation has been C requested. C C QTY REAL(N). C QTY contains TRANS(Q)*Y, if its computation has C been requested. Here TRANS(Q) is the C transpose of the matrix Q. C C B REAL(K) C B contains the solution of the least squares problem C C minimize norm2(Y - XK*B), C C if its computation has been requested. (Note that C if pivoting was requested in SQRDC, the J-th C component of B will be associated with column JPVT(J) C of the original matrix X that was input into SQRDC.) C C RSD REAL(N). C RSD contains the least squares residual Y - XK*B, C if its computation has been requested. RSD is C also the orthogonal projection of Y onto the C orthogonal complement of the column space of XK. C C XB REAL(N). C XB contains the least squares approximation XK*B, C if its computation has been requested. XB is also C the orthogonal projection of Y onto the column space C of X. C C INFO INTEGER. C INFO is zero unless the computation of B has C been requested and R is exactly singular. In C this case, INFO is the index of the first zero C diagonal element of R and B is left unaltered. C C The parameters QY, QTY, B, RSD, and XB are not referenced C if their computation is not requested and in this case C can be replaced by dummy variables in the calling program. C To save storage, the user may in some cases use the same C array for different parameters in the calling sequence. A C frequently occuring example is when one wishes to compute C any of B, RSD, or XB and does not need Y or QTY. In this C case one may identify Y, QTY, and one of B, RSD, or XB, while C providing separate arrays for anything else that is to be C computed. Thus the calling sequence C C CALL SQRSL(X,LDX,N,K,QRAUX,Y,DUM,Y,B,Y,DUM,110,INFO) C C will result in the computation of B and RSD, with RSD C overwriting Y. More generally, each item in the following C list contains groups of permissible identifications for C a single callinng sequence. C C 1. (Y,QTY,B) (RSD) (XB) (QY) C C 2. (Y,QTY,RSD) (B) (XB) (QY) C C 3. (Y,QTY,XB) (B) (RSD) (QY) C C 4. (Y,QY) (QTY,B) (RSD) (XB) C C 5. (Y,QY) (QTY,RSD) (B) (XB) C C 6. (Y,QY) (QTY,XB) (B) (RSD) C C In any group the value returned in the array allocated to C the group corresponds to the last member of the group. C C LINPACK. This version dated 08/14/78 . C G. W. Stewart, University of Maryland, Argonne National Lab. C C SQRSL uses the following functions and subprograms. C C BLAS SAXPY,SCOPY,SDOT C Fortran ABS,MIN0,MOD C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., C *LINPACK USERS GUIDE*, SIAM, 1979. C***ROUTINES CALLED SAXPY,SCOPY,SDOT C***END PROLOGUE SQRSL INTEGER LDX,N,K,JOB,INFO REAL X(LDX,1),QRAUX(1),Y(1),QY(1),QTY(1),B(1),RSD(1),XB(1) C INTEGER I,J,JJ,JU,KP1 REAL SDOT,T,TEMP LOGICAL CB,CQY,CQTY,CR,CXB C C SET INFO FLAG. C C***FIRST EXECUTABLE STATEMENT SQRSL INFO = 0 C C DETERMINE WHAT IS TO BE COMPUTED. C CQY = JOB/10000 .NE. 0 CQTY = MOD(JOB,10000) .NE. 0 CB = MOD(JOB,1000)/100 .NE. 0 CR = MOD(JOB,100)/10 .NE. 0 CXB = MOD(JOB,10) .NE. 0 JU = MIN0(K,N-1) C C SPECIAL ACTION WHEN N=1. C IF (JU .NE. 0) GO TO 40 IF (CQY) QY(1) = Y(1) IF (CQTY) QTY(1) = Y(1) IF (CXB) XB(1) = Y(1) IF (.NOT.CB) GO TO 30 IF (X(1,1) .NE. 0.0E0) GO TO 10 INFO = 1 GO TO 20 10 CONTINUE B(1) = Y(1)/X(1,1) 20 CONTINUE 30 CONTINUE IF (CR) RSD(1) = 0.0E0 GO TO 250 40 CONTINUE C C SET UP TO COMPUTE QY OR QTY. C IF (CQY) CALL SCOPY(N,Y,1,QY,1) IF (CQTY) CALL SCOPY(N,Y,1,QTY,1) IF (.NOT.CQY) GO TO 70 C C COMPUTE QY. C DO 60 JJ = 1, JU J = JU - JJ + 1 IF (QRAUX(J) .EQ. 0.0E0) GO TO 50 TEMP = X(J,J) X(J,J) = QRAUX(J) T = -SDOT(N-J+1,X(J,J),1,QY(J),1)/X(J,J) CALL SAXPY(N-J+1,T,X(J,J),1,QY(J),1) X(J,J) = TEMP 50 CONTINUE 60 CONTINUE 70 CONTINUE IF (.NOT.CQTY) GO TO 100 C C COMPUTE TRANS(Q)*Y. C DO 90 J = 1, JU IF (QRAUX(J) .EQ. 0.0E0) GO TO 80 TEMP = X(J,J) X(J,J) = QRAUX(J) T = -SDOT(N-J+1,X(J,J),1,QTY(J),1)/X(J,J) CALL SAXPY(N-J+1,T,X(J,J),1,QTY(J),1) X(J,J) = TEMP 80 CONTINUE 90 CONTINUE 100 CONTINUE C C SET UP TO COMPUTE B, RSD, OR XB. C IF (CB) CALL SCOPY(K,QTY,1,B,1) KP1 = K + 1 IF (CXB) CALL SCOPY(K,QTY,1,XB,1) IF (CR .AND. K .LT. N) CALL SCOPY(N-K,QTY(KP1),1,RSD(KP1),1) IF (.NOT.CXB .OR. KP1 .GT. N) GO TO 120 DO 110 I = KP1, N XB(I) = 0.0E0 110 CONTINUE 120 CONTINUE IF (.NOT.CR) GO TO 140 DO 130 I = 1, K RSD(I) = 0.0E0 130 CONTINUE 140 CONTINUE IF (.NOT.CB) GO TO 190 C C COMPUTE B. C DO 170 JJ = 1, K J = K - JJ + 1 IF (X(J,J) .NE. 0.0E0) GO TO 150 INFO = J C ......EXIT GO TO 180 150 CONTINUE B(J) = B(J)/X(J,J) IF (J .EQ. 1) GO TO 160 T = -B(J) CALL SAXPY(J-1,T,X(1,J),1,B,1) 160 CONTINUE 170 CONTINUE 180 CONTINUE 190 CONTINUE IF (.NOT.CR .AND. .NOT.CXB) GO TO 240 C C COMPUTE RSD OR XB AS REQUIRED. C DO 230 JJ = 1, JU J = JU - JJ + 1 IF (QRAUX(J) .EQ. 0.0E0) GO TO 220 TEMP = X(J,J) X(J,J) = QRAUX(J) IF (.NOT.CR) GO TO 200 T = -SDOT(N-J+1,X(J,J),1,RSD(J),1)/X(J,J) CALL SAXPY(N-J+1,T,X(J,J),1,RSD(J),1) 200 CONTINUE IF (.NOT.CXB) GO TO 210 T = -SDOT(N-J+1,X(J,J),1,XB(J),1)/X(J,J) CALL SAXPY(N-J+1,T,X(J,J),1,XB(J),1) 210 CONTINUE X(J,J) = TEMP 220 CONTINUE 230 CONTINUE 240 CONTINUE 250 CONTINUE RETURN END SUBROUTINE SROT(N,SX,INCX,SY,INCY,SC,SS) C***BEGIN PROLOGUE SROT C***DATE WRITTEN 791001 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D1A8 C***KEYWORDS BLAS,GIVENS ROTATION,LINEAR ALGEBRA,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 Apply s.p. Givens rotation 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 SY single precision vector with N elements C INCY storage spacing between elements of SY C SC element of rotation matrix C SS element of rotation matrix C C --Output-- C SX rotated vector SX (unchanged if N .LE. 0) C SY rotated vector SY (unchanged if N .LE. 0) C C Multiply the 2 x 2 matrix ( SC SS) times the 2 x N matrix (SX**T) C (-SS SC) (SY**T) C where **T indicates transpose. The elements of SX are in C SX(LX+I*INCX), I = 0 to N-1, where LX = 1 if INCX .GE. 0, else C LX = (-INCX)*N, and similarly for SY using LY and INCY. 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 SROT C REAL SX,SY,SC,SS,ZERO,ONE,W,Z DIMENSION SX(*),SY(*) DATA ZERO,ONE/0.E0,1.E0/ C***FIRST EXECUTABLE STATEMENT SROT IF(N .LE. 0 .OR. (SS .EQ. ZERO .AND. SC .EQ. ONE)) GO TO 40 IF(.NOT. (INCX .EQ. INCY .AND. INCX .GT. 0)) GO TO 20 C NSTEPS=INCX*N DO 10 I=1,NSTEPS,INCX W=SX(I) Z=SY(I) SX(I)=SC*W+SS*Z SY(I)=-SS*W+SC*Z 10 CONTINUE GO TO 40 C 20 CONTINUE KX=1 KY=1 C IF(INCX .LT. 0) KX=1-(N-1)*INCX IF(INCY .LT. 0) KY=1-(N-1)*INCY C DO 30 I=1,N W=SX(KX) Z=SY(KY) SX(KX)=SC*W+SS*Z SY(KY)=-SS*W+SC*Z KX=KX+INCX KY=KY+INCY 30 CONTINUE 40 CONTINUE C RETURN END SUBROUTINE SROTG(SA,SB,SC,SS) C***BEGIN PROLOGUE SROTG C***DATE WRITTEN 791001 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D1B10 C***KEYWORDS BLAS,GIVENS ROTATION,LINEAR ALGEBRA,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 Construct s.p. plane Givens rotation C***DESCRIPTION C C B L A S Subprogram C Description of Parameters C C --Input-- C SA single precision scalar C SB single precision scalar C C --Output-- C SA single precision result R C SB single precision result Z C SC single precision result C SS single precision result C C Designed by C. L. Lawson, JPL, 1977 Sept 08 C C C Construct the Givens transformation C C ( SC SS ) C G = ( ) , SC**2 + SS**2 = 1 , C (-SS SC ) C C which zeros the second entry of the 2-vector (SA,SB)**T. C C The quantity R = (+/-)SQRT(SA**2 + SB**2) overwrites SA in C storage. The value of SB is overwritten by a value Z which C allows SC and SS to be recovered by the following algorithm: C C If Z=1 set SC=0. and SS=1. C If ABS(Z) .LT. 1 set SC=SQRT(1-Z**2) and SS=Z C If ABS(Z) .GT. 1 set SC=1/Z and SS=SQRT(1-SC**2) C C Normally, the subprogram SROT(N,SX,INCX,SY,INCY,SC,SS) will C next be called to apply the transformation to a 2 by N matrix. 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 SROTG C C***FIRST EXECUTABLE STATEMENT SROTG IF (ABS(SA) .LE. ABS(SB)) GO TO 10 C C *** HERE ABS(SA) .GT. ABS(SB) *** C U = SA + SA V = SB / U C C NOTE THAT U AND R HAVE THE SIGN OF SA C R = SQRT(.25 + V**2) * U C C NOTE THAT SC IS POSITIVE C SC = SA / R SS = V * (SC + SC) SB = SS SA = R RETURN C C *** HERE ABS(SA) .LE. ABS(SB) *** C 10 IF (SB .EQ. 0.) GO TO 20 U = SB + SB V = SA / U C C NOTE THAT U AND R HAVE THE SIGN OF SB C (R IS IMMEDIATELY STORED IN SA) C SA = SQRT(.25 + V**2) * U C C NOTE THAT SS IS POSITIVE C SS = SB / SA SC = V * (SS + SS) IF (SC .EQ. 0.) GO TO 15 SB = 1. / SC RETURN 15 SB = 1. RETURN C C *** HERE SA = SB = 0. *** C 20 SC = 1. SS = 0. RETURN C END SUBROUTINE SRTMEA(Y,XH1,N,ICASE, 1MAXNXT, 1XH1DIS,STTEMP,TEMP,TEMP2,TEMP3,TEMP4,TEMP5, 1X2,AINDX,NUMSE1, 1ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 1ISUBRO,IBUGA3,IERROR) C C PURPOSE--SORT BY MEAN (OR SOME OTHER LOCATION STATISTIC). C THAT IS, C C LET X2 INDEX = SORT BY MEAN Y X C C WILL SORT X (HERE X IS A GROUP-ID VARIABLE AND C Y IS A RESPONSE VARIABLE) BASED ON THE MEAN C (OR SOME OTHER APPROPRIATE STATISTIC). C WRITTEN BY--ALAN HECKERT C STATISTICAL ENGINEERING DIVISION 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--2005/12 C ORIGINAL VERSION--DECEMBER 2005. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C EXTERNAL SUM EXTERNAL RANGE C CHARACTER*4 ICASE CHARACTER*4 ISUBRO CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 IWRITE C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C DIMENSION Y(*) DIMENSION XH1(*) DIMENSION X2(*) DIMENSION AINDX(*) C DIMENSION XH1DIS(*) DIMENSION STTEMP(*) DIMENSION TEMP(*) DIMENSION TEMP2(*) DIMENSION TEMP3(*) DIMENSION TEMP4(*) DIMENSION TEMP5(*) INTEGER ITEMP1(*) INTEGER ITEMP2(*) INTEGER ITEMP3(*) INTEGER ITEMP4(*) INTEGER ITEMP5(*) INTEGER ITEMP6(*) C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCOST.INC' INCLUDE 'DPCOHK.INC' C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='SRTM' ISUBN2='EA ' C C CHECK THE INPUT ARGUMENTS FOR ERRORS C IF(N.LE.1)THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,31) 31 FORMAT('***** ERROR IN SORT BY --') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,32) 32 FORMAT(' THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 2.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,34)N 34 FORMAT(' THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF C IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'TMEA')THEN WRITE(ICOUT,70) 70 FORMAT('AT THE BEGINNING OF SRTMEA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,71)N,ICASE 71 FORMAT('N,ICASE = ',I8,2X,A4) CALL DPWRST('XXX','BUG ') DO72I=1,N WRITE(ICOUT,73)I,Y(I),XH1(I) 73 FORMAT('I, Y(I), XH1(I) = ',I8,2G15.7) CALL DPWRST('XXX','BUG ') 72 CONTINUE ENDIF C C ****************************************************** C ** STEP 2-- ** C ** DETERMINE THE NUMBER OF DISTINCT VALUES ** C ** FOR VARIABLE 2 (ONE OF THE GROUP VARIABLES). ** C ****************************************************** C ISTEPN='2' IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'TMEA') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C C THE DISTINCT VALUES WILL BE CODED INTO 1, 2, ... , NDIST. C NOTE THAT TRYING TO MAINTAIN ORIGINAL SCALE IS PROBLEMATIC C IF THE DATA HAS GAPS (E.G., 101, 102, 105) SINCE WE HAVE C NO EASY WAY TO AUTOMATICALLY PLACE THE TIC MARK LABELS. C IWRITE='OFF' CALL CODE(XH1,N,IWRITE,TEMP3,IBUGA3,IERROR) DO110I=1,N XH1(I)=TEMP3(I) 110 CONTINUE CALL DISTIN(XH1,N,IWRITE,XH1DIS,NUMSE1,IBUGA3,IERROR) C AN=N ANUMS1=NUMSE1 C DO310I=1,NUMSE1 NTEMP=0 DO320J=1,N IF(XH1(J).EQ.XH1DIS(I))THEN NTEMP=NTEMP+1 TEMP2(NTEMP)=Y(J) ENDIF 320 CONTINUE IWRITE='OFF' IF(NTEMP.GT.0)THEN NUMV=1 CALL CMPSTA(TEMP2,TEMP,TEMP3,TEMP4,TEMP5, 1 MAXNXT,NTEMP,NTEMP,NUMV,ICASE, 1 ISEED,ITEMP1,ITEMP2,ITEMP3, 1 ITEMP4,ITEMP5,ITEMP6, 1 IQUAME,IQUASE, 1 STAT1, 1 ISUBRO,IBUGA3,IERROR) IF(IERROR.EQ.'YES')GOTO9000 STTEMP(I)=STAT1 CCCCC AINDX(I)=REAL(I) AINDX(I)=XH1DIS(I) ELSE IERROR='YES' GOTO9000 ENDIF 310 CONTINUE C CALL SORTC(STTEMP,AINDX,NUMSE1,STTEMP,TEMP3) C DO390I=1,NUMSE1 AINDX(I)=TEMP3(I) 390 CONTINUE C DO410I=1,NUMSE1 AVALUE=0.0 DO415J=1,NUMSE1 IF(XH1DIS(I).EQ.AINDX(J))THEN CCCCC AVALUE=REAL(J) AVALUE=XH1DIS(J) GOTO419 ENDIF 415 CONTINUE 419 CONTINUE DO420J=1,N IF(XH1(J).EQ.XH1DIS(I))THEN X2(J)=AVALUE ENDIF 420 CONTINUE 410 CONTINUE C C ****************** C ** STEP 90-- ** C ** EXIT ** C ****************** C 9000 CONTINUE IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'TMEA')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF SRTMEA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)NUMSE1 9015 FORMAT('NUMSE1 = ',I8) CALL DPWRST('XXX','BUG ') DO9020I=1,NUMSE1 WRITE(ICOUT,9021)I,XH1DIS(I),AINDX(I) 9021 FORMAT('I,XH1DIS(I),AINDX(I) = ',I8,2G15.7) CALL DPWRST('XXX','BUG ') 9020 CONTINUE DO9030I=1,N WRITE(ICOUT,9031)I,Y(I),XH1(I),X2(I) 9031 FORMAT('I,Y(I),XH1(I),X2(I) = ',I8,G15.7) CALL DPWRST('XXX','BUG ') 9030 CONTINUE ENDIF C RETURN END subroutine ss(y,n,np,ns,isdeg,nsjump,userw,rw,season,work1,work2, &work3,work4) c c This routine is part of the Bill Cleveland seasonal loess c program. c integer n, np, ns, isdeg, nsjump, nright, nleft, i, j, k real y(n), rw(n), season(n+2*np), work1(n), work2(n), work3(n), &work4(n), xs logical userw,ok j=1 23105 if(.not.(j .le. np))goto 23107 k = (n-j)/np+1 do 23108 i = 1,k work1(i) = y((i-1)*np+j) 23108 continue if(.not.(userw))goto 23110 do 23112 i = 1,k work3(i) = rw((i-1)*np+j) 23112 continue 23110 continue call ess(work1,k,ns,isdeg,nsjump,userw,work3,work2(2),work4) xs = 0 nright = min0(ns,k) call est(work1,k,ns,isdeg,xs,work2(1),1,nright,work4,userw,work3, &ok) if(.not.( .not. ok))goto 23114 work2(1) = work2(2) 23114 continue xs = k+1 nleft = max0(1,k-ns+1) call est(work1,k,ns,isdeg,xs,work2(k+2),nleft,k,work4,userw,work3, &ok) if(.not.( .not. ok))goto 23116 work2(k+2) = work2(k+1) 23116 continue do 23118 m = 1,k+2 season((m-1)*np+j) = work2(m) 23118 continue j=j+1 goto 23105 23107 continue return end SUBROUTINE SSCAL(N,SA,SX,INCX) C***BEGIN PROLOGUE SSCAL C***DATE WRITTEN 791001 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D1A6 C***KEYWORDS BLAS,LINEAR ALGEBRA,SCALE,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 S.P. vector scale x = a*x 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 SA single precision scale factor C SX single precision vector with N elements C INCX storage spacing between elements of SX C C --Output-- C SX single precision result (unchanged if N .LE. 0) C C Replace single precision SX by single precision SA*SX. C For I = 0 to N-1, replace SX(1+I*INCX) with SA * SX(1+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 SSCAL C REAL SA,SX(*) C***FIRST EXECUTABLE STATEMENT SSCAL IF(N.LE.0)RETURN IF(INCX.EQ.1)GOTO 20 C C CODE FOR INCREMENTS NOT EQUAL TO 1. C NS = N*INCX DO 10 I = 1,NS,INCX SX(I) = SA*SX(I) 10 CONTINUE RETURN C C CODE FOR INCREMENTS EQUAL TO 1. C C C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 5. C 20 M = MOD(N,5) IF( M .EQ. 0 ) GO TO 40 DO 30 I = 1,M SX(I) = SA*SX(I) 30 CONTINUE IF( N .LT. 5 ) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,5 SX(I) = SA*SX(I) SX(I + 1) = SA*SX(I + 1) SX(I + 2) = SA*SX(I + 2) SX(I + 3) = SA*SX(I + 3) SX(I + 4) = SA*SX(I + 4) 50 CONTINUE RETURN END SUBROUTINE SSIEV(A,LDA,N,E,WORK,JOB,INFO) C***BEGIN PROLOGUE SSIEV C***DATE WRITTEN 800808 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D4A1 C***KEYWORDS EIGENVALUE,EIGENVECTOR,MATRIX,REAL,SYMMETRIC C***AUTHOR KAHANER, D. K., (NBS) C MOLER, C. B., (U. OF NEW MEXICO) C STEWART, G. W., (U. OF MARYLAND) C***PURPOSE To compute the eigenvalues and, optionally, the eigen- C vectors of a real SYMMETRIC matrix. C***DESCRIPTION C C LICEPACK. This version dated 08/08/80. C David Kahaner, Cleve Moler, Pete Stewart C N.B.S. U.N.M. N.B.S./U.MD. C C Abstract C SSIEV computes the eigenvalues and, optionally, the eigenvectors C of a real symmetric matrix. C C Call Sequence Parameters- C (The values of parameters marked with * (star) will be changed C by SSIEV.) C C A* REAL (LDA,N) C real symmetric input matrix. C Only the diagonal and upper triangle of A must be input, C as SSIEV copies the upper triangle to the lower. C That is, the user must define A(I,J), I=1,..N, and J=I,. C ..,N. C On return from SSIEV, if the user has set JOB C = 0 the lower triangle of A has been altered. C = nonzero the N eigenvectors of A are stored in its C first N columns. See also INFO below. C C LDA INTEGER C set by the user to C the leading dimension of the array A. C C N INTEGER C set by the user to C the order of the matrix A and C the number of elements in E. C C E* REAL (N) C on return from SSIEV, E contains the N C eigenvalues of A. See also INFO below. C C WORK* REAL (2*N) C temporary storage vector. Contents changed by SSIEV. C C JOB INTEGER C set by user on input C = 0 only calculate eigenvalues of A. C = nonzero calculate eigenvalues and eigenvectors of A. C C INFO* INTEGER C on return from SSIEV, the value of INFO is C = 0 for normal return. C = K if the eigenvalue iteration fails to converge. C eigenvalues and vectors 1 through K-1 are correct. C C C Error Messages- C No. 1 recoverable N is greater than LDA C No. 2 recoverable N is less than one C C Subroutines Used C C EISPACK- TRED1, TRED2, TQLRAT, IMTQL2 C SLATEC- XERROR C***REFERENCES (NONE) C***ROUTINES CALLED IMTQL2,TQLRAT,TRED1,TRED2,XERROR C***END PROLOGUE SSIEV INTEGER INFO,JOB,LDA,N REAL A(LDA,N),E(N),WORK(1) C***FIRST EXECUTABLE STATEMENT SSIEV IF(N .GT. LDA)THEN CCCCC WRITE(*,*) 'FROM SSIEV: N .GT. LDA.' INFO = -1 RETURN ENDIF IF(N .LT. 1) THEN CCCCC WRITE(*,*) 'FROM SSIEV: N .LT. 1' INFO = -2 RETURN ENDIF C C CHECK N=1 CASE C E(1) = A(1,1) INFO = 0 IF(N .EQ. 1) RETURN C C COPY UPPER TRIANGLE TO LOWER C DO 10 J=1,N DO 10 I=1,J A(J,I)=A(I,J) 10 CONTINUE C IF(JOB.NE.0) GO TO 20 C C EIGENVALUES ONLY C CALL TRED1(LDA,N,A,E,WORK(1),WORK(N+1)) CALL TQLRAT(N,E,WORK(N+1),INFO) RETURN C C EIGENVALUES AND EIGENVECTORS C 20 CALL TRED2(LDA,N,A,E,WORK,A) CALL IMTQL2(LDA,N,E,WORK,A,INFO) RETURN END SUBROUTINE SSNC(P1,P2,ALPHA,BETA,N,IC,IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C BINOMIAL BASED SINGLE SAMPLE PLAN (N,C). C INPUT ARGUMENTS--P1 = THE SINGLE PRECISION VALUE FOR C THE ACCEPTABLE QUALITY LEVEL. C --P2 = THE SINGLE PRECISION VALUE FOR C THE LOT TOLERANCE PERCENT DEFECTIVE C --ALPHA = PROBABILITY FOR AQL. C --BETA = PROBABILITY FOR LTPD. C OUTPUT ARGUMENTS--N = THE COMPUTED SAMPLE SIZE. C --IC = ACCEPTABLE NUMBER OF DEFECTIVES. C OTHER DATAPAC SUBROUTINES NEEDED--BINCDF. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--MONTGOMERY, STATISTICAL QUALITY CONTROL, C ALGORITHM IS FORTRAN TRANSLATION OF A BASIC CODE C PROVIDED BY JACK PRINS. 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-075-2899 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 (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 IBUGA3 CHARACTER*4 IERROR C C--------------------------------------------------------------------- C REAL L C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C MAXIT=10000 I=0 100 CONTINUE IF(I.GT.MAXIT)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG') WRITE(ICOUT,101) 101 FORMAT('***** MAXIMUM NUMBER OF ITERATIONS EXCEEDED FOR THE ', 1 'BINOMIAL SINGLE SAMPLE PLAN') CALL DPWRST('XXX','BUG') N=0 IC=0 GOTO9000 ENDIF IDF=2 + 2*I P=1.0 - BETA CALL CHSPPF(P,IDF,PPF) L=0.5*(REAL(I) + (-0.5 + 1.0/P2)*PPF) C IDF=2 + 2*I P=ALPHA CALL CHSPPF(P,IDF,PPF) U=0.5*(REAL(I) + (-0.5 + 1.0/P1)*PPF) C IF(INT(U)-INT(L).LT.1)THEN I=I+1 GOTO100 ENDIF C 200 CONTINUE IF(U.GT.L)THEN N=INT(U) ELSE N=INT(L) ENDIF IC=I C 300 CONTINUE N=N-1 CALL BINCDF(REAL(IC),P2,N,S) IF(S.GT.BETA)GOTO400 BCDF=S GOTO300 C 400 CONTINUE N=N+1 CALL BINCDF(REAL(IC),P1,N,S) ACDF=S C WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG') WRITE(ICOUT,1001) 1001 FORMAT('BINOMIAL SINGLE SAMPLE PLAN') CALL DPWRST('XXX','BUG') WRITE(ICOUT,1011)P1 1011 FORMAT(' P1 (= Acceptable Quality Level) = ',F7.4) CALL DPWRST('XXX','BUG') WRITE(ICOUT,1021)P2 1021 FORMAT(' P2 (= Lot Tolerance Percent Defective) = ',F7.4) CALL DPWRST('XXX','BUG') WRITE(ICOUT,1031)ALPHA 1031 FORMAT(' ALPHA = ',F7.4) CALL DPWRST('XXX','BUG') WRITE(ICOUT,1041)BETA 1041 FORMAT(' BETA = ',F7.4) CALL DPWRST('XXX','BUG') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG') WRITE(ICOUT,1051)N 1051 FORMAT(' Computed Sample Size = ',I8) CALL DPWRST('XXX','BUG') WRITE(ICOUT,1061)IC 1061 FORMAT(' Computed Acceptance Number = ',I8) CALL DPWRST('XXX','BUG') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG') C WRITE(ICOUT,1071) 1071 FORMAT('The sample size and acceptance number are saved in') CALL DPWRST('XXX','BUG') WRITE(ICOUT,1081) 1081 FORMAT('the internal parameters SSN and SSC respectively.') CALL DPWRST('XXX','BUG') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG') C 9000 CONTINUE RETURN END SUBROUTINE SSORT(X,Y,N,KFLAG) C c NOTE: This subroutine used in computing the consensus mean c using the Iyer and Wang generalized tolerance interval c approach. c c Modified for Dataplot 3/2006. c C***BEGIN PROLOGUE SSORT C***DATE WRITTEN 761101 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. N6A2B1 C***KEYWORDS QUICKSORT,SINGLETON QUICKSORT,SORT,SORTING C***AUTHOR JONES, R. E., (SNLA) C WISNIEWSKI, J. A., (SNLA) C***PURPOSE SSORT sorts array X and optionally makes the same C interchanges in array Y. The array X may be sorted in C increasing order or decreasing order. A slightly modified C QUICKSORT algorithm is used. C***DESCRIPTION C C Written by Rondall E. Jones C Modified by John A. Wisniewski to use the Singleton quicksort C algorithm. Date 18 November 1976. C C Abstract C SSORT sorts array X and optionally makes the same C interchanges in array Y. The array X may be sorted in C increasing order or decreasing order. A slightly modified C quicksort algorithm is used. C C Reference C Singleton, R. C., Algorithm 347, An Efficient Algorithm for C Sorting with Minimal Storage, CACM,12(3),1969,185-7. C C Description of Parameters C X - array of values to be sorted (usually abscissas) C Y - array to be (optionally) carried along C N - number of values in array X to be sorted C KFLAG - control parameter C =2 means sort X in increasing order and carry Y along. C =1 means sort X in increasing order (ignoring Y) C =-1 means sort X in decreasing order (ignoring Y) C =-2 means sort X in decreasing order and carry Y along. C***REFERENCES SINGLETON,R.C., ALGORITHM 347, AN EFFICIENT ALGORITHM C FOR SORTING WITH MINIMAL STORAGE, CACM,12(3),1969, C 185-7. C***END PROLOGUE SSORT integer n, kflag double precision X(N),Y(N) integer IL(21),IU(21) c double precision t, tt, r, ty, tty c CHARACTER*4 IERROR 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 C***FIRST EXECUTABLE STATEMENT SSORT NN = N IF (NN.LT.1) THEN WRITE(ICOUT,1) 1 FORMAT('*****ERROR FROM SSORT--') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,2) 2 FORMAT(' THE NUMBER OF VALUES TO BE SORTED WAS NOT ', 1 'POSITIVE.') CALL DPWRST('XXX','WRIT') RETURN ENDIF 10 KK = IABS(KFLAG) IF ((KK.EQ.1).OR.(KK.EQ.2)) GO TO 15 WRITE(ICOUT,1) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,3) 3 FORMAT(' THE SORT CONTROL PARAMETER, K, WAS NOT ', 1 '2, 1, -1, OR -2.') CALL DPWRST('XXX','WRIT') RETURN C C ALTER ARRAY X TO GET DECREASING ORDER IF NEEDED C 15 IF (KFLAG.GE.1) GO TO 30 DO 20 I=1,NN 20 X(I) = -X(I) 30 GO TO (100,200),KK C C SORT X ONLY C 100 CONTINUE M=1 I=1 J=NN R=.375d0 110 IF (I .EQ. J) GO TO 155 115 IF (R .GT. .5898437d0) GO TO 120 R=R+3.90625d-2 GO TO 125 120 R=R-.21875d0 125 K=I C SELECT A CENTRAL ELEMENT OF THE C ARRAY AND SAVE IT IN LOCATION T IJ = I + INT(FLOAT (J-I) * R) T=X(IJ) C IF FIRST ELEMENT OF ARRAY IS GREATER C THAN T, INTERCHANGE WITH T IF (X(I) .LE. T) GO TO 130 X(IJ)=X(I) X(I)=T T=X(IJ) 130 L=J C IF LAST ELEMENT OF ARRAY IS LESS THAN C T, INTERCHANGE WITH T IF (X(J) .GE. T) GO TO 140 X(IJ)=X(J) X(J)=T T=X(IJ) C IF FIRST ELEMENT OF ARRAY IS GREATER C THAN T, INTERCHANGE WITH T IF (X(I) .LE. T) GO TO 140 X(IJ)=X(I) X(I)=T T=X(IJ) GO TO 140 135 TT=X(L) X(L)=X(K) X(K)=TT C FIND AN ELEMENT IN THE SECOND HALF OF C THE ARRAY WHICH IS SMALLER THAN T 140 L=L-1 IF (X(L) .GT. T) GO TO 140 C FIND AN ELEMENT IN THE FIRST HALF OF C THE ARRAY WHICH IS GREATER THAN T 145 K=K+1 IF (X(K) .LT. T) GO TO 145 C INTERCHANGE THESE ELEMENTS IF (K .LE. L) GO TO 135 C SAVE UPPER AND LOWER SUBSCRIPTS OF C THE ARRAY YET TO BE SORTED IF (L-I .LE. J-K) GO TO 150 IL(M)=I IU(M)=L I=K M=M+1 GO TO 160 150 IL(M)=K IU(M)=J J=L M=M+1 GO TO 160 C BEGIN AGAIN ON ANOTHER PORTION OF C THE UNSORTED ARRAY 155 M=M-1 IF (M .EQ. 0) GO TO 300 I=IL(M) J=IU(M) 160 IF (J-I .GE. 1) GO TO 125 IF (I .EQ. 1) GO TO 110 I=I-1 165 I=I+1 IF (I .EQ. J) GO TO 155 T=X(I+1) IF (X(I) .LE. T) GO TO 165 K=I 170 X(K+1)=X(K) K=K-1 IF (T .LT. X(K)) GO TO 170 X(K+1)=T GO TO 165 C C SORT X AND CARRY Y ALONG C 200 CONTINUE M=1 I=1 J=NN R=.375d0 210 IF (I .EQ. J) GO TO 255 215 IF (R .GT. .5898437d0) GO TO 220 R=R+3.90625d-2 GO TO 225 220 R=R-.21875d0 225 K=I C SELECT A CENTRAL ELEMENT OF THE C ARRAY AND SAVE IT IN LOCATION T IJ = I + INT(FLOAT (J-I) *R) T=X(IJ) TY= Y(IJ) C IF FIRST ELEMENT OF ARRAY IS GREATER C THAN T, INTERCHANGE WITH T IF (X(I) .LE. T) GO TO 230 X(IJ)=X(I) X(I)=T T=X(IJ) Y(IJ)= Y(I) Y(I)=TY TY= Y(IJ) 230 L=J C IF LAST ELEMENT OF ARRAY IS LESS THAN C T, INTERCHANGE WITH T IF (X(J) .GE. T) GO TO 240 X(IJ)=X(J) X(J)=T T=X(IJ) Y(IJ)= Y(J) Y(J)=TY TY= Y(IJ) C IF FIRST ELEMENT OF ARRAY IS GREATER C THAN T, INTERCHANGE WITH T IF (X(I) .LE. T) GO TO 240 X(IJ)=X(I) X(I)=T T=X(IJ) Y(IJ)= Y(I) Y(I)=TY TY= Y(IJ) GO TO 240 235 TT=X(L) X(L)=X(K) X(K)=TT TTY= Y(L) Y(L)= Y(K) Y(K)=TTY C FIND AN ELEMENT IN THE SECOND HALF OF C THE ARRAY WHICH IS SMALLER THAN T 240 L=L-1 IF (X(L) .GT. T) GO TO 240 C FIND AN ELEMENT IN THE FIRST HALF OF C THE ARRAY WHICH IS GREATER THAN T 245 K=K+1 IF (X(K) .LT. T) GO TO 245 C INTERCHANGE THESE ELEMENTS IF (K .LE. L) GO TO 235 C SAVE UPPER AND LOWER SUBSCRIPTS OF C THE ARRAY YET TO BE SORTED IF (L-I .LE. J-K) GO TO 250 IL(M)=I IU(M)=L I=K M=M+1 GO TO 260 250 IL(M)=K IU(M)=J J=L M=M+1 GO TO 260 C BEGIN AGAIN ON ANOTHER PORTION OF C THE UNSORTED ARRAY 255 M=M-1 IF (M .EQ. 0) GO TO 300 I=IL(M) J=IU(M) 260 IF (J-I .GE. 1) GO TO 225 IF (I .EQ. 1) GO TO 210 I=I-1 265 I=I+1 IF (I .EQ. J) GO TO 255 T=X(I+1) TY= Y(I+1) IF (X(I) .LE. T) GO TO 265 K=I 270 X(K+1)=X(K) Y(K+1)= Y(K) K=K-1 IF (T .LT. X(K)) GO TO 270 X(K+1)=T Y(K+1)=TY GO TO 265 C C CLEAN UP C 300 IF (KFLAG.GE.1) RETURN DO 310 I=1,NN 310 X(I) = -X(I) RETURN END SUBROUTINE SSVDC(X,LDX,N,P,S,E,U,LDU,V,LDV,WORK,JOB,INFO) C***BEGIN PROLOGUE SSVDC C***DATE WRITTEN 790319 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D6 C***KEYWORDS LINEAR ALGEBRA,LINPACK,MATRIX, C SINGULAR VALUE DECOMPOSITION C***AUTHOR STEWART, G. W., (U. OF MARYLAND) C***PURPOSE Perform the singular value decomposition of a real NXP C matrix C***DESCRIPTION C C SSVDC is a subroutine to reduce a real NxP matrix X by C orthogonal transformations U and V to diagonal form. The C diagonal elements S(I) are the singular values of X. The C columns of U are the corresponding left singular vectors, C and the columns of V the right singular vectors. C C On Entry C C X REAL(LDX,P), where LDX .GE. N. C X contains the matrix whose singular value C decomposition is to be computed. X is C destroyed by SSVDC. C C LDX INTEGER C LDX is the leading dimension of the array X. C C N INTEGER C N is the number of rows of the matrix X. C C P INTEGER C P is the number of columns of the matrix X. C C LDU INTEGER C LDU is the leading dimension of the array U. C (See below). C C LDV INTEGER C LDV is the leading dimension of the array V. C (See below). C C WORK REAL(N) C work is a scratch array. C C JOB INTEGER C JOB controls the computation of the singular C vectors. It has the decimal expansion AB C with the following meaning C C A .EQ. 0 Do not compute the left singular C vectors. C A .EQ. 1 Return the N left singular vectors C in U. C A .GE. 2 Return the first MIN(N,P) singular C vectors in U. C B .EQ. 0 Do not compute the right singular C vectors. C B .EQ. 1 Return the right singular vectors C in V. C C On Return C C S REAL(MM), where MM=MIN(N+1,P). C The first MIN(N,P) entries of S contain the C singular values of X arranged in descending C order of magnitude. C C E REAL(P). C E ordinarily contains zeros. However, see the C discussion of INFO for exceptions. C C U REAL(LDU,K), where LDU .GE. N. If JOBA .EQ. 1, then C K .EQ. N. If JOBA .GE. 2 , then C K .EQ. MIN(N,P). C U contains the matrix of right singular vectors. C U is not referenced if JOBA .EQ. 0. If N .LE. P C or if JOBA .EQ. 2, then U may be identified with X C in the subroutine call. C C V REAL(LDV,P), where LDV .GE. P. C V contains the matrix of right singular vectors. C V is not referenced if JOB .EQ. 0. If P .LE. N, C then V may be identified with X in the C subroutine call. C C INFO INTEGER. C the singular values (and their corresponding C singular vectors) S(INFO+1),S(INFO+2),...,S(M) C are correct (here M=MIN(N,P)). Thus if C INFO .EQ. 0, all the singular values and their C vectors are correct. In any event, the matrix C B = TRANS(U)*X*V is the bidiagonal matrix C with the elements of S on its diagonal and the C elements of E on its super-diagonal (TRANS(U) C is the transpose of U). Thus the singular C values of X and B are the same. C C LINPACK. This version dated 03/19/79 . C G. W. Stewart, University of Maryland, Argonne National Lab. C C ***** Uses the following functions and subprograms. C C External SROT C BLAS SAXPY,SDOT,SSCAL,SSWAP,SNRM2,SROTG C Fortran ABS,AMAX1,MAX0,MIN0,MOD,SQRT C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., C *LINPACK USERS GUIDE*, SIAM, 1979. C***ROUTINES CALLED SAXPY,SDOT,SNRM2,SROT,SROTG,SSCAL,SSWAP C***END PROLOGUE SSVDC INTEGER LDX,N,P,LDU,LDV,JOB,INFO REAL X(LDX,*),S(*),E(*),U(LDU,*),V(LDV,*),WORK(*) C C INTEGER I,ITER,J,JOBU,K,KASE,KK,L,LL,LLS,LM1,LP1,LS,LU,M,MAXIT, 1 MM,MM1,MP1,NCT,NCTP1,NCU,NRT,NRTP1 CCCCC REAL SDOT,T,R REAL SDOT,T REAL B,C,CS,EL,EMM1,F,G,SNRM2,SCALE,SHIFT,SL,SM,SN,SMM1,T1,TEST, 1 ZTEST LOGICAL WANTU,WANTV C C SET THE MAXIMUM NUMBER OF ITERATIONS. C C***FIRST EXECUTABLE STATEMENT SSVDC MAXIT = 30 C C DETERMINE WHAT IS TO BE COMPUTED. C WANTU = .FALSE. WANTV = .FALSE. JOBU = MOD(JOB,100)/10 NCU = N IF (JOBU .GT. 1) NCU = MIN0(N,P) IF (JOBU .NE. 0) WANTU = .TRUE. IF (MOD(JOB,10) .NE. 0) WANTV = .TRUE. C C REDUCE X TO BIDIAGONAL FORM, STORING THE DIAGONAL ELEMENTS C IN S AND THE SUPER-DIAGONAL ELEMENTS IN E. C INFO = 0 NCT = MIN0(N-1,P) NRT = MAX0(0,MIN0(P-2,N)) LU = MAX0(NCT,NRT) IF (LU .LT. 1) GO TO 170 DO 160 L = 1, LU LP1 = L + 1 IF (L .GT. NCT) GO TO 20 C C COMPUTE THE TRANSFORMATION FOR THE L-TH COLUMN AND C PLACE THE L-TH DIAGONAL IN S(L). C S(L) = SNRM2(N-L+1,X(L,L),1) IF (S(L) .EQ. 0.0E0) GO TO 10 IF (X(L,L) .NE. 0.0E0) S(L) = SIGN(S(L),X(L,L)) CALL SSCAL(N-L+1,1.0E0/S(L),X(L,L),1) X(L,L) = 1.0E0 + X(L,L) 10 CONTINUE S(L) = -S(L) 20 CONTINUE IF (P .LT. LP1) GO TO 50 DO 40 J = LP1, P IF (L .GT. NCT) GO TO 30 IF (S(L) .EQ. 0.0E0) GO TO 30 C C APPLY THE TRANSFORMATION. C T = -SDOT(N-L+1,X(L,L),1,X(L,J),1)/X(L,L) CALL SAXPY(N-L+1,T,X(L,L),1,X(L,J),1) 30 CONTINUE C C PLACE THE L-TH ROW OF X INTO E FOR THE C SUBSEQUENT CALCULATION OF THE ROW TRANSFORMATION. C E(J) = X(L,J) 40 CONTINUE 50 CONTINUE IF (.NOT.WANTU .OR. L .GT. NCT) GO TO 70 C C PLACE THE TRANSFORMATION IN U FOR SUBSEQUENT BACK C MULTIPLICATION. C DO 60 I = L, N U(I,L) = X(I,L) 60 CONTINUE 70 CONTINUE IF (L .GT. NRT) GO TO 150 C C COMPUTE THE L-TH ROW TRANSFORMATION AND PLACE THE C L-TH SUPER-DIAGONAL IN E(L). C E(L) = SNRM2(P-L,E(LP1),1) IF (E(L) .EQ. 0.0E0) GO TO 80 IF (E(LP1) .NE. 0.0E0) E(L) = SIGN(E(L),E(LP1)) CALL SSCAL(P-L,1.0E0/E(L),E(LP1),1) E(LP1) = 1.0E0 + E(LP1) 80 CONTINUE E(L) = -E(L) IF (LP1 .GT. N .OR. E(L) .EQ. 0.0E0) GO TO 120 C C APPLY THE TRANSFORMATION. C DO 90 I = LP1, N WORK(I) = 0.0E0 90 CONTINUE DO 100 J = LP1, P CALL SAXPY(N-L,E(J),X(LP1,J),1,WORK(LP1),1) 100 CONTINUE DO 110 J = LP1, P CALL SAXPY(N-L,-E(J)/E(LP1),WORK(LP1),1,X(LP1,J),1) 110 CONTINUE 120 CONTINUE IF (.NOT.WANTV) GO TO 140 C C PLACE THE TRANSFORMATION IN V FOR SUBSEQUENT C BACK MULTIPLICATION. C DO 130 I = LP1, P V(I,L) = E(I) 130 CONTINUE 140 CONTINUE 150 CONTINUE 160 CONTINUE 170 CONTINUE C C SET UP THE FINAL BIDIAGONAL MATRIX OR ORDER M. C M = MIN0(P,N+1) NCTP1 = NCT + 1 NRTP1 = NRT + 1 IF (NCT .LT. P) S(NCTP1) = X(NCTP1,NCTP1) IF (N .LT. M) S(M) = 0.0E0 IF (NRTP1 .LT. M) E(NRTP1) = X(NRTP1,M) E(M) = 0.0E0 C C IF REQUIRED, GENERATE U. C IF (.NOT.WANTU) GO TO 300 IF (NCU .LT. NCTP1) GO TO 200 DO 190 J = NCTP1, NCU DO 180 I = 1, N U(I,J) = 0.0E0 180 CONTINUE U(J,J) = 1.0E0 190 CONTINUE 200 CONTINUE IF (NCT .LT. 1) GO TO 290 DO 280 LL = 1, NCT L = NCT - LL + 1 IF (S(L) .EQ. 0.0E0) GO TO 250 LP1 = L + 1 IF (NCU .LT. LP1) GO TO 220 DO 210 J = LP1, NCU T = -SDOT(N-L+1,U(L,L),1,U(L,J),1)/U(L,L) CALL SAXPY(N-L+1,T,U(L,L),1,U(L,J),1) 210 CONTINUE 220 CONTINUE CALL SSCAL(N-L+1,-1.0E0,U(L,L),1) U(L,L) = 1.0E0 + U(L,L) LM1 = L - 1 IF (LM1 .LT. 1) GO TO 240 DO 230 I = 1, LM1 U(I,L) = 0.0E0 230 CONTINUE 240 CONTINUE GO TO 270 250 CONTINUE DO 260 I = 1, N U(I,L) = 0.0E0 260 CONTINUE U(L,L) = 1.0E0 270 CONTINUE 280 CONTINUE 290 CONTINUE 300 CONTINUE C C IF IT IS REQUIRED, GENERATE V. C IF (.NOT.WANTV) GO TO 350 DO 340 LL = 1, P L = P - LL + 1 LP1 = L + 1 IF (L .GT. NRT) GO TO 320 IF (E(L) .EQ. 0.0E0) GO TO 320 DO 310 J = LP1, P T = -SDOT(P-L,V(LP1,L),1,V(LP1,J),1)/V(LP1,L) CALL SAXPY(P-L,T,V(LP1,L),1,V(LP1,J),1) 310 CONTINUE 320 CONTINUE DO 330 I = 1, P V(I,L) = 0.0E0 330 CONTINUE V(L,L) = 1.0E0 340 CONTINUE 350 CONTINUE C C MAIN ITERATION LOOP FOR THE SINGULAR VALUES. C MM = M ITER = 0 360 CONTINUE C C QUIT IF ALL THE SINGULAR VALUES HAVE BEEN FOUND. C C ...EXIT IF (M .EQ. 0) GO TO 620 C C IF TOO MANY ITERATIONS HAVE BEEN PERFORMED, SET C FLAG AND RETURN. C IF (ITER .LT. MAXIT) GO TO 370 INFO = M C ......EXIT GO TO 620 370 CONTINUE C C THIS SECTION OF THE PROGRAM INSPECTS FOR C NEGLIGIBLE ELEMENTS IN THE S AND E ARRAYS. ON C COMPLETION THE VARIABLES KASE AND L ARE SET AS FOLLOWS. C C KASE = 1 IF S(M) AND E(L-1) ARE NEGLIGIBLE AND L.LT.M C KASE = 2 IF S(L) IS NEGLIGIBLE AND L.LT.M C KASE = 3 IF E(L-1) IS NEGLIGIBLE, L.LT.M, AND C S(L), ..., S(M) ARE NOT NEGLIGIBLE (QR STEP). C KASE = 4 IF E(M-1) IS NEGLIGIBLE (CONVERGENCE). C DO 390 LL = 1, M L = M - LL C ...EXIT IF (L .EQ. 0) GO TO 400 TEST = ABS(S(L)) + ABS(S(L+1)) ZTEST = TEST + ABS(E(L)) IF (ZTEST .NE. TEST) GO TO 380 E(L) = 0.0E0 C ......EXIT GO TO 400 380 CONTINUE 390 CONTINUE 400 CONTINUE IF (L .NE. M - 1) GO TO 410 KASE = 4 GO TO 480 410 CONTINUE LP1 = L + 1 MP1 = M + 1 DO 430 LLS = LP1, MP1 LS = M - LLS + LP1 C ...EXIT IF (LS .EQ. L) GO TO 440 TEST = 0.0E0 IF (LS .NE. M) TEST = TEST + ABS(E(LS)) IF (LS .NE. L + 1) TEST = TEST + ABS(E(LS-1)) ZTEST = TEST + ABS(S(LS)) IF (ZTEST .NE. TEST) GO TO 420 S(LS) = 0.0E0 C ......EXIT GO TO 440 420 CONTINUE 430 CONTINUE 440 CONTINUE IF (LS .NE. L) GO TO 450 KASE = 3 GO TO 470 450 CONTINUE IF (LS .NE. M) GO TO 460 KASE = 1 GO TO 470 460 CONTINUE KASE = 2 L = LS 470 CONTINUE 480 CONTINUE L = L + 1 C C PERFORM THE TASK INDICATED BY KASE. C GO TO (490,520,540,570), KASE C C DEFLATE NEGLIGIBLE S(M). C 490 CONTINUE MM1 = M - 1 F = E(M-1) E(M-1) = 0.0E0 DO 510 KK = L, MM1 K = MM1 - KK + L T1 = S(K) CALL SROTG(T1,F,CS,SN) S(K) = T1 IF (K .EQ. L) GO TO 500 F = -SN*E(K-1) E(K-1) = CS*E(K-1) 500 CONTINUE IF (WANTV) CALL SROT(P,V(1,K),1,V(1,M),1,CS,SN) 510 CONTINUE GO TO 610 C C SPLIT AT NEGLIGIBLE S(L). C 520 CONTINUE F = E(L-1) E(L-1) = 0.0E0 DO 530 K = L, M T1 = S(K) CALL SROTG(T1,F,CS,SN) S(K) = T1 F = -SN*E(K) E(K) = CS*E(K) IF (WANTU) CALL SROT(N,U(1,K),1,U(1,L-1),1,CS,SN) 530 CONTINUE GO TO 610 C C PERFORM ONE QR STEP. C 540 CONTINUE C C CALCULATE THE SHIFT. C SCALE = AMAX1(ABS(S(M)),ABS(S(M-1)),ABS(E(M-1)),ABS(S(L)), 1 ABS(E(L))) SM = S(M)/SCALE SMM1 = S(M-1)/SCALE EMM1 = E(M-1)/SCALE SL = S(L)/SCALE EL = E(L)/SCALE B = ((SMM1 + SM)*(SMM1 - SM) + EMM1**2)/2.0E0 C = (SM*EMM1)**2 SHIFT = 0.0E0 IF (B .EQ. 0.0E0 .AND. C .EQ. 0.0E0) GO TO 550 SHIFT = SQRT(B**2+C) IF (B .LT. 0.0E0) SHIFT = -SHIFT SHIFT = C/(B + SHIFT) 550 CONTINUE F = (SL + SM)*(SL - SM) - SHIFT G = SL*EL C C CHASE ZEROS. C MM1 = M - 1 DO 560 K = L, MM1 CALL SROTG(F,G,CS,SN) IF (K .NE. L) E(K-1) = F F = CS*S(K) + SN*E(K) E(K) = CS*E(K) - SN*S(K) G = SN*S(K+1) S(K+1) = CS*S(K+1) IF (WANTV) CALL SROT(P,V(1,K),1,V(1,K+1),1,CS,SN) CALL SROTG(F,G,CS,SN) S(K) = F F = CS*E(K) + SN*S(K+1) S(K+1) = -SN*E(K) + CS*S(K+1) G = SN*E(K+1) E(K+1) = CS*E(K+1) IF (WANTU .AND. K .LT. N) 1 CALL SROT(N,U(1,K),1,U(1,K+1),1,CS,SN) 560 CONTINUE E(M-1) = F ITER = ITER + 1 GO TO 610 C C CONVERGENCE. C 570 CONTINUE C C MAKE THE SINGULAR VALUE POSITIVE. C IF (S(L) .GE. 0.0E0) GO TO 580 S(L) = -S(L) IF (WANTV) CALL SSCAL(P,-1.0E0,V(1,L),1) 580 CONTINUE C C ORDER THE SINGULAR VALUE. C 590 IF (L .EQ. MM) GO TO 600 C ...EXIT IF (S(L) .GE. S(L+1)) GO TO 600 T = S(L) S(L) = S(L+1) S(L+1) = T IF (WANTV .AND. L .LT. P) 1 CALL SSWAP(P,V(1,L),1,V(1,L+1),1) IF (WANTU .AND. L .LT. N) 1 CALL SSWAP(N,U(1,L),1,U(1,L+1),1) L = L + 1 GO TO 590 600 CONTINUE ITER = 0 M = M - 1 610 CONTINUE GO TO 360 620 CONTINUE RETURN END SUBROUTINE SSWAP(N,SX,INCX,SY,INCY) C***BEGIN PROLOGUE SSWAP C***DATE WRITTEN 791001 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D1A5 C***KEYWORDS BLAS,INTERCHANGE,LINEAR ALGEBRA,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 Interchange s.p vectors 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 SY single precision vector with N elements C INCY storage spacing between elements of SY C C --Output-- C SX input vector SY (unchanged if N .LE. 0) C SY input vector SX (unchanged if N .LE. 0) C C Interchange single precision SX and single precision SY. C For I = 0 to N-1, interchange SX(LX+I*INCX) and SY(LY+I*INCY), C where LX = 1 if INCX .GE. 0, else LX = (-INCX)*N, and LY is C defined in a similar way using INCY. 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 SSWAP C REAL SX(*),SY(*),STEMP1,STEMP2,STEMP3 C***FIRST EXECUTABLE STATEMENT SSWAP IF(N.LE.0)RETURN IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60 5 CONTINUE C C CODE FOR UNEQUAL OR NONPOSITIVE INCREMENTS. C IX = 1 IY = 1 IF(INCX.LT.0)IX = (-N+1)*INCX + 1 IF(INCY.LT.0)IY = (-N+1)*INCY + 1 DO 10 I = 1,N STEMP1 = SX(IX) SX(IX) = SY(IY) SY(IY) = STEMP1 IX = IX + INCX IY = IY + INCY 10 CONTINUE RETURN C C CODE FOR BOTH INCREMENTS EQUAL TO 1 C C C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 3. C 20 M = MOD(N,3) IF( M .EQ. 0 ) GO TO 40 DO 30 I = 1,M STEMP1 = SX(I) SX(I) = SY(I) SY(I) = STEMP1 30 CONTINUE IF( N .LT. 3 ) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,3 STEMP1 = SX(I) STEMP2 = SX(I+1) STEMP3 = SX(I+2) SX(I) = SY(I) SX(I+1) = SY(I+1) SX(I+2) = SY(I+2) SY(I) = STEMP1 SY(I+1) = STEMP2 SY(I+2) = STEMP3 50 CONTINUE RETURN 60 CONTINUE C C CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS. C NS = N*INCX DO 70 I=1,NS,INCX STEMP1 = SX(I) SX(I) = SY(I) SY(I) = STEMP1 70 CONTINUE RETURN END SUBROUTINE START1(A,X,Y,IMX,NS,CN,XC,YC) C C PURPOSE--XX C C WRITTEN BY--DAVID W. BEHRINGER NOAA/AOML (MIAMI). C AS PART OF NOAA'S CONCX V.3 MARCH 1988. C ORIGINAL VERSION (IN DATAPLOT)--AUGUST 1988. C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOCP.INC' C C--------------------------------------------------------------------- C CCCCC DIMENSION A(IMX,2),X(2),Y(2) AUGUST 1988 C DIMENSION A(MAXIMX,2) DIMENSION X(2) DIMENSION Y(2) C C-----START POINT----------------------------------------------------- C DNM=A(1,1)-A(1,2) IF (DNM.NE.0.) THEN R=(CN-A(1,2))/DNM ELSE R=-1. END IF IF ((R.GT.0..AND.R.LT.1.).OR. 1 (R.EQ.0..AND.DNM.LT.0.).OR. 2 (R.EQ.1..AND.DNM.GT.0.)) THEN XC=X(1) YC=Y(2)+R*(Y(1)-Y(2)) ELSE NS=-1 END IF RETURN END SUBROUTINE START2(A,X,Y,IMX,NS,CN,XC,YC) C C PURPOSE--XX C C WRITTEN BY--DAVID W. BEHRINGER NOAA/AOML (MIAMI). C AS PART OF NOAA'S CONCX V.3 MARCH 1988. C ORIGINAL VERSION (IN DATAPLOT)--AUGUST 1988. C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOCP.INC' C C--------------------------------------------------------------------- C CCCCC DIMENSION A(IMX,2),X(2),Y(2) AUGUST 1988 C DIMENSION A(MAXIMX,2) DIMENSION X(2) DIMENSION Y(2) C C-----START POINT----------------------------------------------------- C DNM=A(1,1)-A(2,1) IF (DNM.NE.0.) THEN R=(CN-A(2,1))/DNM ELSE R=-1. END IF IF ((R.GT.0..AND.R.LT.1.).OR. 1 (R.EQ.0..AND.DNM.LT.0.).OR. 2 (R.EQ.1..AND.DNM.GT.0.)) THEN XC=X(2)+R*(X(1)-X(2)) YC=Y(1) ELSE NS=-1 ENDIF RETURN END SUBROUTINE START3(A,X,Y,IMX,NS,CN,XC,YC) C C PURPOSE--XX C C WRITTEN BY--DAVID W. BEHRINGER NOAA/AOML (MIAMI). C AS PART OF NOAA'S CONCX V.3 MARCH 1988. C ORIGINAL VERSION (IN DATAPLOT)--AUGUST 1988. C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOCP.INC' C C--------------------------------------------------------------------- C CCCCC DIMENSION A(IMX,2),X(2),Y(2) AUGUST 1988 C DIMENSION A(MAXIMX,2) DIMENSION X(2) DIMENSION Y(2) C C-----START POINT----------------------------------------------------- C DNM=A(1,2)-A(1,1) IF (DNM.NE.0.) THEN R=(CN-A(1,1))/DNM ELSE R=-1. END IF IF ((R.GT.0..AND.R.LT.1.).OR. 1 (R.EQ.0..AND.DNM.LT.0.).OR. 2 (R.EQ.1..AND.DNM.GT.0.)) THEN XC=X(1) YC=Y(1)+R*(Y(2)-Y(1)) ELSE NS=-1 ENDIF RETURN END SUBROUTINE START4(A,X,Y,IMX,NS,CN,XC,YC) C C PURPOSE--XX C C WRITTEN BY--DAVID W. BEHRINGER NOAA/AOML (MIAMI). C AS PART OF NOAA'S CONCX V.3 MARCH 1988. C ORIGINAL VERSION (IN DATAPLOT)--AUGUST 1988. C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOCP.INC' C C--------------------------------------------------------------------- C CCCCC DIMENSION A(IMX,2),X(2),Y(2) AUGUST 1988 C DIMENSION A(MAXIMX,2) DIMENSION X(2) DIMENSION Y(2) C C-----START POINT----------------------------------------------------- C DNM=A(2,1)-A(1,1) IF (DNM.NE.0.) THEN R=(CN-A(1,1))/DNM ELSE R=-1. END IF IF ((R.GT.0..AND.R.LT.1.).OR. 1 (R.EQ.0..AND.DNM.LT.0.).OR. 2 (R.EQ.1..AND.DNM.GT.0.)) THEN XC=X(1)+R*(X(2)-X(1)) YC=Y(1) ELSE NS=-1 ENDIF RETURN END DOUBLE PRECISION FUNCTION STDINV( N, Z ) * * Inverse Student t Distribution Function * * STDINV * Z = C I (1 + y*y/N)**(-(N+1)/2) dy * N -INF * * Reference: G.W. Hill, Comm. ACM Algorithm 395 * Comm. ACM 13 (1970), pp. 619-620. * * Conversions to double precision and other modifications by * Alan Genz, 1993-4. * INTEGER N DOUBLE PRECISION Z, P, PHINV, A, B, C, D, X, Y, PI, TWO DOUBLE PRECISION STUDNT, STDJAC PARAMETER ( PI = 3.14159 26535 89793D0, TWO = 2 ) IF ( 0.0D0 .LT. Z .AND. Z .LT. 1.0D0 ) THEN IF ( N .EQ. 1 ) THEN STDINV = TAN( PI*( 2*Z - 1 )/2 ) ELSE IF ( N .EQ. 2) THEN STDINV = ( 2.0D0*Z - 1.0D0 )/SQRT( 2.0D0*Z*( 1.0D0 - Z ) ) ELSE IF ( 2.0D0*Z .GE. 1.0D0 ) THEN P = 2.0D0*( 1.0D0 - Z ) ELSE P = 2.0D0*Z END IF A = 1.0D0/( DBLE(N) - 0.5D0 ) B = 48.0D0/( A*A ) C = ( ( 20700.0D0*A/B - 98.0D0 )*A - 16.0D0 )*A + 96.36D0 D = ( ( 94.5D0/( B + C ) - 3.0D0 )/B + 1.0D0 )* & SQRT( A*PI/2.0D0 )*DBLE(N) X = D*P Y = X**( TWO/DBLE(N) ) IF ( Y .GT. A + 0.05D0 ) THEN X = PHINV( P/2.0D0 ) Y = X*X IF ( N .LT. 5 ) C = C + 3.0D0* & ( DBLE(N) - 4.5D0 )*( 10.0D0*X + 6.0D0 )/100.0D0 C = ( ( (D*X - 100.0D0)*X/20.0D0 - 7.0D0 )*X - 2.0D0 ) & *X + B + C Y = (((((4.0D0*Y+63.0D0)*Y/10.0D0+36.0D0)*Y+94.5D0)/ & C-Y-3.0D0)/B + 1.0D0)*X Y = A*Y*Y IF ( Y .GT. 0.002D0) THEN Y = EXP(Y) - 1.0D0 ELSE Y = Y*( 1.0D0 + Y/2.0D0 ) ENDIF ELSE Y = ((1.0D0/((DBLE(N+6)/(DBLE(N)*Y) - & 0.089D0*D - 0.822D0 )*(3.0D0*DBLE(N+6))) & + 0.5D0/DBLE(N+4))*Y - 1.0D0)*DBLE(N+1)/DBLE(N+2) & + 1.0D0/Y END IF STDINV = SQRT(DBLE(N)*Y) IF ( 2.0D0*Z .LT. 1.0D0 ) STDINV = -STDINV IF ( ABS( STDINV ) .GT. 0.0D0 ) THEN * * Use one third order correction to the single precision result * X = STDINV D = Z - STUDNT(N,X) STDINV = X + 2.0D0*D/( 2.0D0/STDJAC(N,X) - & D*DBLE(N+1)/(DBLE(N)/X+X) ) END IF END IF ELSE * * Use cutoff values for Z near 0 or 1. * STDINV = SQRT( DBLE(N)/( 2D-16* & SQRT( 2.0D0*PI*DBLE(N)))**( TWO/N ) ) IF ( 2.0D0*Z .LT. 1.0D0 ) STDINV = -STDINV END IF C RETURN END DOUBLE PRECISION FUNCTION STDJAC( NU, T ) * * Student t Distribution Transformation Jacobean * * T STDINV(NU,T) * I f(y) dy = I f(STDINV(NU,Z) STDJAC(NU,STDINV(NU,Z)) dZ * -INF 0 * INTEGER NU, J DOUBLE PRECISION CONST, NUOLD, PI, T, TT PARAMETER ( PI = 3.14159 26535 89793D0 ) SAVE NUOLD, CONST DATA NUOLD/ 0D0 / IF ( NU .EQ. 1 ) THEN STDJAC = PI*( 1.0D0 + T*T ) ELSE IF ( NU .EQ. 2 ) THEN STDJAC = SQRT( 2.0D0 + T*T )**3 ELSE IF ( NU .NE. NUOLD ) THEN NUOLD = NU IF ( MOD( NU, 2 ) .EQ. 0 ) THEN CONST = SQRT(NUOLD)*2.0D0 ELSE CONST = SQRT(NUOLD)*PI END IF DO 100 J = NU-2, 1, -2 CONST = J*CONST/(J+1) 100 CONTINUE END IF TT = 1 + T*T/NU STDJAC = CONST*TT**( DBLE(NU+1)/2.0D0 ) IF ( MOD( NU, 2 ) .EQ. 0 ) STDJAC = STDJAC*SQRT( TT ) END IF C RETURN END SUBROUTINE STEP(IND, C, S, NW, W, M, LSTFI, LER, N, LV, LLIM, * LT, LP) C PART OF ACM 591 FOR ANOVA C ****************************** STEP ****************************** STE 10 C STE 20 C PERFORMS THE FOLLOWING SUB-STEPS OPERATING UPON THE VECTORS IN THE STE 30 C W ARRAY STE 40 C STE 50 C 1) T = (Y-D*V)/C STE 60 C 2) V = V+T STE 70 C 3) B = B+T STE 80 C 4) T = R(T) STE 90 C 5) V = V-T STE 100 C 6) S = 2*Y*V-V*D*V STE 110 C STE 120 C VECTOR T CONSISTS OF THE FIRST NCELLS LOCATIONS IN VECTOR A OF W; STE 130 C HOWEVER, ALL LOCATIONS IN VECTOR A ARE NEEDED IN SUB-STEP 4. R(T) STE 140 C IS THE RESIDUAL OPERATOR APPLIED TO VECTOR T; IT IS IMPLEMENTED STE 150 C USING SUBROUTINES DECOMP, POOL, AND LABEL. STE 160 C STE 170 C SUB-STEPS 1 AND 6 ARE MODIFIED IN COMPUTING RANK WITH THE R OPTION STE 180 C AND SUB-STEP 1 IS ALSO MODIFIED WHEN SWITCH IBST IS ON; ARGUMENT STE 190 C IND CONTROLS THESE MODIFICATIONS. STE 200 C STE 210 C IND = 1 (ITERATION FOR SSR); IND = 2 (NON-ITERATIVE, IBST IS ON); STE 220 C IND = 3 (ITERATION FOR RANK) STE 230 C STE 240 C S IS EITHER SSR (IND=2), AN APPROXIMATION TO SSR, (IND=1), OR PART STE 250 C OF THE RANK APPROXIMATION (IND=3). C IS A SCALAR CONSTANT SELECT- STE 260 C ED FOR MONOTONICITY OF THE APPROXIMATION TO SSR OR FOR FASTER, BUT STE 270 C NOT MONOTONE, CONVERGENCE. STE 280 C STE 290 C (SEE MAIN PROGRAM COMMENTS FOR DESCRIPTION OF OTHER ARGUMENTS) STE 300 C STE 310 C ****************************************************************** STE 320 DIMENSION W(NW), LSTFI(M), LER(M), LV(N), LLIM(N), LT(N), LP(10) DOUBLE PRECISION W, C, S, T1, T2 C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C S = 0 NCELLS = LSTFI(1) DO 40 I=1,NCELLS C INCREMENT BASE ADDRESSES OF ARRAYS ID1 = NCELLS + I ID2 = ID1 + NCELLS IV = ID2 + NCELLS IB = IV + NCELLS IA = IB + NCELLS C GENERAL ITERATION (IND=1); NON-ITERATIVE (IND=2); RANK (IND=3) IF (IND.EQ.1) GO TO 20 IF (IND.EQ.2) GO TO 10 W(IA) = W(I) - W(IV) IF (W(ID1).EQ.0.0) W(IA) = W(I) GO TO 30 10 W(IA) = -W(IV) IF (W(ID2).GT.0.0) W(IA) = W(IA) + W(I)/W(ID2) GO TO 30 20 W(IA) = (W(I)-W(ID1)*W(IV))/C C V=V+A; B=B+A 30 W(IV) = W(IV) + W(IA) W(IB) = W(IB) + W(IA) 40 CONTINUE C RESIDUAL OPERATOR IA = IB CALL DECOMP(0, IB, IOUT, NW, W, M, LSTFI, N, LT, LV, LLIM, LP) IFLAG = 0 DO 70 I=1,M IF (LER(I).GT.0) GO TO 60 IF (I.EQ.1) GO TO 50 NO = M - I + 1 CALL LABEL(NO, 0, LLIM, IOUT, N, LV, LP) CALL POOL(IFLAG, IA, IB, NW, W, N, LLIM, LT, LP) 50 IFLAG = 1 60 IB = IB + LSTFI(I) 70 CONTINUE C V=V-T; S=2*Y*V-V*D*V DO 90 I=1,NCELLS ID1 = NCELLS + I IV = ID2 + I IA = IA + 1 IF (IFLAG.EQ.1) W(IV) = W(IV) - W(IA) T1 = 2.0D0*W(I) T2 = W(ID1) IF (T2.EQ.0.0) GO TO 80 IF (IND.EQ.3) T2 = 1.0D0 T1 = T1 - W(IV)*T2 80 S = S + T1*W(IV) 90 CONTINUE RETURN END subroutine stl(y,n,np,ns,nt,nl,isdeg,itdeg,ildeg,nsjump,ntjump, &nljump,ni,no,rw,season,trend,work) c c This routine is part of the Bill Cleveland seasonal loess c program. c integer n, np, ns, nt, nl, isdeg, itdeg, ildeg, nsjump, ntjump, &nljump, ni, no, k integer newns, newnt, newnl, newnp real y(n), rw(n), season(n), trend(n), work(n+2*np,5) logical userw userw = .false. k = 0 do 23000 i = 1,n trend(i) = 0.0 23000 continue newns = max0(3,ns) newnt = max0(3,nt) newnl = max0(3,nl) newnp = max0(2,np) if(.not.(mod(newns,2) .eq. 0))goto 23002 newns = newns + 1 23002 continue if(.not.(mod(newnt,2) .eq. 0))goto 23004 newnt = newnt + 1 23004 continue if(.not.(mod(newnl,2) .eq. 0))goto 23006 newnl = newnl + 1 23006 continue 23008 continue call onestp(y,n,newnp,newns,newnt,newnl,isdeg,itdeg,ildeg,nsjump, &ntjump,nljump,ni,userw,rw,season, trend, work) k = k+1 if(.not.(k .gt. no))goto 23011 goto 23010 23011 continue do 23013 i = 1,n work(i,1) = trend(i)+season(i) 23013 continue call rwts(y,n,work(1,1),rw) userw = .true. 23009 goto 23008 23010 continue if(.not.(no .le. 0))goto 23015 do 23017 i = 1,n rw(i) = 1.0 23017 continue 23015 continue return end subroutine stlez(y, n, np, ns, isdeg, itdeg, robust, no, rw, &season, trend, work) c c This routine is part of the Bill Cleveland seasonal loess c program. c logical robust integer n, i, j, np, ns, no, nt, nl, ni, nsjump, ntjump, nljump, &newns, newnp integer isdeg, itdeg, ildeg real y(n), rw(n), season(n), trend(n), work(n+2*np,7) real maxs, mins, maxt, mint, maxds, maxdt, difs, dift ildeg = itdeg newns = max0(3,ns) if(.not.(mod(newns,2) .eq. 0))goto 23120 newns = newns+1 23120 continue newnp = max0(2,np) nt = (1.5*newnp)/(1 - 1.5/newns) + 0.5 nt = max0(3,nt) if(.not.(mod(nt,2) .eq. 0))goto 23122 nt = nt+1 23122 continue nl = newnp if(.not.(mod(nl,2) .eq. 0))goto 23124 nl = nl+1 23124 continue if(.not.(robust))goto 23126 ni = 1 goto 23127 23126 continue ni = 2 23127 continue nsjump = max0(1,int(float(newns)/10 + 0.9)) ntjump = max0(1,int(float(nt)/10 + 0.9)) nljump = max0(1,int(float(nl)/10 + 0.9)) do 23128 i = 1,n trend(i) = 0.0 23128 continue call onestp(y,n,newnp,newns,nt,nl,isdeg,itdeg,ildeg,nsjump,ntjump, &nljump,ni,.false.,rw,season,trend,work) no = 0 if(.not.(robust))goto 23130 j=1 23132 if(.not.(j .le. 15))goto 23134 do 23135 i = 1,n work(i,6) = season(i) work(i,7) = trend(i) work(i,1) = trend(i)+season(i) 23135 continue call rwts(y,n,work(1,1),rw) call onestp(y, n, newnp, newns, nt, nl, isdeg, itdeg, ildeg, &nsjump,ntjump, nljump, ni, .true., rw, season, trend, work) no = no+1 maxs = work(1,6) mins = work(1,6) maxt = work(1,7) mint = work(1,7) maxds = abs(work(1,6) - season(1)) maxdt = abs(work(1,7) - trend(1)) do 23137 i = 2,n if(.not.(maxs .lt. work(i,6)))goto 23139 maxs = work(i,6) 23139 continue if(.not.(maxt .lt. work(i,7)))goto 23141 maxt = work(i,7) 23141 continue if(.not.(mins .gt. work(i,6)))goto 23143 mins = work(i,6) 23143 continue if(.not.(mint .gt. work(i,7)))goto 23145 mint = work(i,7) 23145 continue difs = abs(work(i,6) - season(i)) dift = abs(work(i,7) - trend(i)) if(.not.(maxds .lt. difs))goto 23147 maxds = difs 23147 continue if(.not.(maxdt .lt. dift))goto 23149 maxdt = dift 23149 continue 23137 continue if(.not.((maxds/(maxs-mins) .lt. .01) .and. (maxdt/(maxt-mint) & .lt. .01)))goto 23151 goto 23134 23151 continue j=j+1 goto 23132 23134 continue 23130 continue if(.not.( .not. robust))goto 23153 do 23155 i = 1,n rw(i) = 1.0 23155 continue 23153 continue return end SUBROUTINE STMOM3(X,N,IWRITE,XSMOM3,IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C SAMPLE STANDARDIZED THIRD CENTRAL MOMENT C OF THE DATA IN THE INPUT VECTOR X. C THE SAMPLE STANDARDIZED THIRD CENTRAL MOMENT = C (THE SAMPLE THIRD CENTRAL MOMENT)/((THE SAMPLE C STANDARD DEVIATION)**3). C N (RATHER THAN N-1) HAS BEEN USED IN THE DENOMINATOR C IN THE CALCULATION OF BOTH THE SAMPLE THIRD CENTRAL C MOMENT AND THE SAMPLE STANDARD DEVIATION. 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--XSMOM3 = THE SINGLE PRECISION VALUE OF THE C COMPUTED SAMPLE STANDARDIZED THIRD C CENTRAL MOMENT. C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE C SAMPLE STANDARDIZED THIRD CENTRAL MOMENT. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--KENDALL AND STUART, THE ADVANCED THEORY OF C STATISTICS, VOLUME 1, EDITION 2, 1963, PAGES 85, C 234, 243, 297-298, 305. C --SNEDECOR AND COCHRAN, STATISTICAL METHODS, C EDITION 6, 1967, PAGES 86-90. 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 (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--82.6 C ORIGINAL VERSION--JUNE 1972. C UPDATED --SEPTEMBER 1975. C UPDATED --NOVEMBER 1975. C UPDATED --JUNE 1979. C UPDATED --AUGUST 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DOUBLE PRECISION DN DOUBLE PRECISION DX DOUBLE PRECISION DSUM DOUBLE PRECISION DMEAN DOUBLE PRECISION DVAR DOUBLE PRECISION DSD DOUBLE PRECISION DMOM3 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='STMO' ISUBN2='M3 ' C IERROR='NO' C DSUM=0.0D0 DMEAN=0.0D0 DSD=0.0D0 C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF STMOM3--') 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 STANDARDIZED THIRD CENTRAL MOMENT ** 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 STMOM3--') 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 STANDARDIZED THIRD CENTRAL MOMENT 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 STMOM3--', 1'THE 2ND INPUT ARGUMENT (N) HAS THE VALUE 1') CALL DPWRST('XXX','BUG ') XSMOM3=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 STMOM3--', 1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','BUG ') XSMOM3=0.0 GOTO9000 139 CONTINUE C 190 CONTINUE C C ****************************************************** C ** STEP 2-- ** C ** COMPUTE THE STANDARDIZED THIRD CENTRAL MOMENT. ** C ****************************************************** C DN=N DSUM=0.0D0 DO200I=1,N DX=X(I) DSUM=DSUM+DX 200 CONTINUE DMEAN=DSUM/DN C DSUM=0.0D0 DO300I=1,N DX=X(I) DSUM=DSUM+(DX-DMEAN)**2 300 CONTINUE DVAR=DSUM/(DN-1.0D0) DSD=0.0D0 IF(DVAR.GT.0.0D0)DSD=DSQRT(DVAR) XSD=DSD C DSUM=0.0D0 DO400I=1,N DX=X(I) DSUM=DSUM+(DX-DMEAN)**3 400 CONTINUE DMOM3=DSUM/(DN-1.0D0) XSMOM3=DMOM3/(DSD**3) 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,XSMOM3 811 FORMAT('THE STANDARDIZED THIRD CENTRAL MOMENT 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 STMOM3--') 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)DMEAN,DSD,DSUM 9014 FORMAT('DMEAN,DSD,DSUM = ',3D15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)XSMOM3 9015 FORMAT('XSMOM3 = ',E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE STMOM4(X,N,IWRITE,XSMOM4,IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C SAMPLE STANDARDIZED FOURTH CENTRAL MOMENT C OF THE DATA IN THE INPUT VECTOR X. C THE SAMPLE STANDARDIZED FOURTH CENTRAL MOMENT = C (THE SAMPLE FOURTH CENTRAL MOMENT)/((THE SAMPLE C STANDARD DEVIATION)**4). C N (RATHER THAN N-1) HAS BEEN USED IN THE DENOMINATOR C IN THE CALCULATION OF BOTH THE SAMPLE FOURTH CENTRAL C MOMENT AND THE SAMPLE STANDARD DEVIATION. 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--XSMOM4 = THE SINGLE PRECISION VALUE OF THE C COMPUTED SAMPLE STANDARDIZED FOURTH C CENTRAL MOMENT. C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE C SAMPLE STANDARDIZED FOURTH CENTRAL MOMENT. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--KENDALL AND STUART, THE ADVANCED THEORY OF C STATISTICS, VOLUME 1, EDITION 2, 1963, PAGES 85, 243. C --SNEDECOR AND COCHRAN, STATISTICAL METHODS, C EDITION 6, 1967, PAGES 86-90. 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 (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--82.6 C ORIGINAL VERSION--JUNE 1972. C UPDATED --SEPTEMBER 1975. C UPDATED --NOVEMBER 1975. C UPDATED --JUNE 1979. C UPDATED --AUGUST 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DOUBLE PRECISION DN DOUBLE PRECISION DX DOUBLE PRECISION DSUM DOUBLE PRECISION DMEAN DOUBLE PRECISION DVAR DOUBLE PRECISION DSD DOUBLE PRECISION DMOM4 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='STMO' ISUBN2='M4 ' C IERROR='NO' C DSUM=0.0D0 DMEAN=0.0D0 DSD=0.0D0 C IF(IBUGA3.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF STMOM4--') 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 STANDARDIZED FOURTH CENTRAL MOMENT ** 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 STMOM4--') 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 STANDARDIZED FOURTH CENTRAL MOMENT IS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,115) 115 FORMAT(' TO BE 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 STMOM4--', 1'THE 2ND INPUT ARGUMENT (N) HAS THE VALUE 1') CALL DPWRST('XXX','BUG ') XSMOM4=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 STMOM4--', 1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','BUG ') XSMOM4=0.0 GOTO9000 139 CONTINUE C 190 CONTINUE C C ******************************************************* C ** STEP 2-- ** C ** COMPUTE THE STANDARDIZED FOURTH CENTRAL MOMENT. ** C ******************************************************* C DN=N DSUM=0.0D0 DO200I=1,N DX=X(I) DSUM=DSUM+DX 200 CONTINUE DMEAN=DSUM/DN C DSUM=0.0D0 DO300I=1,N DX=X(I) DSUM=DSUM+(DX-DMEAN)**2 300 CONTINUE DVAR=DSUM/(DN-1.0D0) DSD=0.0D0 IF(DVAR.GT.0.0D0)DSD=DSQRT(DVAR) XSD=DSD C DSUM=0.0D0 DO400I=1,N DX=X(I) DSUM=DSUM+(DX-DMEAN)**4 400 CONTINUE DMOM4=DSUM/(DN-1.0) XSMOM4=DMOM4/(DSD**4) 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,XSMOM4 811 FORMAT('THE STANDARDIZED FOURTH CENTRAL MOMENT 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 STMOM4--') 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)DMEAN,DSD,DSUM 9014 FORMAT('DMEAN,DSD,DSUM = ',3D15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)XSMOM4 9015 FORMAT('XSMOM4 = ',E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE STRDI(T,LDT,N,DET,JOB,INFO) C***BEGIN PROLOGUE STRDI C***DATE WRITTEN 780814 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D2A3,D3A3 C***KEYWORDS DETERMINANT,INVERSE,LINEAR ALGEBRA,LINPACK,MATRIX, C TRIANGULAR C***AUTHOR MOLER, C. B., (U. OF NEW MEXICO) C***PURPOSE Computes the determinant and inverse of a real TRIANGULAR C matrix C***DESCRIPTION C C STRDI computes the determinant and inverse of a real C triangular matrix. C C On Entry C C T REAL(LDT,N) C T contains the triangular matrix. The zero C elements of the matrix are not referenced, and C the corresponding elements of the array can be C used to store other information. C C LDT INTEGER C LDT is the leading dimension of the array T. C C N INTEGER C N is the order of the system. C C JOB INTEGER C = 010 no det, inverse of lower triangular. C = 011 no det, inverse of upper triangular. C = 100 det, no inverse. C = 110 det, inverse of lower triangular. C = 111 det, inverse of upper triangular. C C On Return C C T inverse of original matrix if requested. C Otherwise unchanged. C C DET REAL(2) C determinant of original matrix if requested. C Otherwise not referenced. C Determinant = DET(1) * 10.0**DET(2) C with 1.0 .LE. ABS(DET(1)) .LT. 10.0 C or DET(1) .EQ. 0.0 . C C INFO INTEGER C INFO contains zero if the system is nonsingular C and the inverse is requested. C Otherwise INFO contains the index of C a zero diagonal element of T. C C C LINPACK. This version dated 08/14/78 . C Cleve Moler, University of New Mexico, Argonne National Lab. C C Subroutines and Functions C C BLAS SAXPY,SSCAL C Fortran ABS,MOD C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., C *LINPACK USERS GUIDE*, SIAM, 1979. C***ROUTINES CALLED SAXPY,SSCAL C***END PROLOGUE STRDI INTEGER LDT,N,JOB,INFO REAL T(LDT,1),DET(2) C REAL TEMP REAL TEN INTEGER I,J,K,KB,KM1,KP1 C C BEGIN BLOCK PERMITTING ...EXITS TO 180 C C COMPUTE DETERMINANT C C***FIRST EXECUTABLE STATEMENT STRDI IF (JOB/100 .EQ. 0) GO TO 70 DET(1) = 1.0E0 DET(2) = 0.0E0 TEN = 10.0E0 DO 50 I = 1, N DET(1) = T(I,I)*DET(1) C ...EXIT IF (DET(1) .EQ. 0.0E0) GO TO 60 10 IF (ABS(DET(1)) .GE. 1.0E0) GO TO 20 DET(1) = TEN*DET(1) DET(2) = DET(2) - 1.0E0 GO TO 10 20 CONTINUE 30 IF (ABS(DET(1)) .LT. TEN) GO TO 40 DET(1) = DET(1)/TEN DET(2) = DET(2) + 1.0E0 GO TO 30 40 CONTINUE 50 CONTINUE 60 CONTINUE 70 CONTINUE C C COMPUTE INVERSE OF UPPER TRIANGULAR C IF (MOD(JOB/10,10) .EQ. 0) GO TO 170 IF (MOD(JOB,10) .EQ. 0) GO TO 120 C BEGIN BLOCK PERMITTING ...EXITS TO 110 DO 100 K = 1, N INFO = K C ......EXIT IF (T(K,K) .EQ. 0.0E0) GO TO 110 T(K,K) = 1.0E0/T(K,K) TEMP = -T(K,K) CALL SSCAL(K-1,TEMP,T(1,K),1) KP1 = K + 1 IF (N .LT. KP1) GO TO 90 DO 80 J = KP1, N TEMP = T(K,J) T(K,J) = 0.0E0 CALL SAXPY(K,TEMP,T(1,K),1,T(1,J),1) 80 CONTINUE 90 CONTINUE 100 CONTINUE INFO = 0 110 CONTINUE GO TO 160 120 CONTINUE C C COMPUTE INVERSE OF LOWER TRIANGULAR C DO 150 KB = 1, N K = N + 1 - KB INFO = K C ............EXIT IF (T(K,K) .EQ. 0.0E0) GO TO 180 T(K,K) = 1.0E0/T(K,K) TEMP = -T(K,K) IF (K .NE. N) CALL SSCAL(N-K,TEMP,T(K+1,K),1) KM1 = K - 1 IF (KM1 .LT. 1) GO TO 140 DO 130 J = 1, KM1 TEMP = T(K,J) T(K,J) = 0.0E0 CALL SAXPY(N-K+1,TEMP,T(K,K),1,T(K,J),1) 130 CONTINUE 140 CONTINUE 150 CONTINUE INFO = 0 160 CONTINUE 170 CONTINUE 180 CONTINUE RETURN END SUBROUTINE STRLEZ(ISTR80,LENGTH) C C PURPOSE--DETERMINE THE LENGTH (OUT TO THE LAST NON-BLANK C CHARACTER) OF THE 80-CHARACTER STRING ISTR80. C C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--92/4 C ORIGINAL VERSION--MARCH 1992. C UPDATED --MARCH 2005. RENAME TO STRLEZ TO AVOID NAME CONFLICT C ON MAC OSX. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*80 ISTR80 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 IWIDTH=80 DO1100I=1,IWIDTH IREV=IWIDTH-I+1 IF(ISTR80(IREV:IREV).NE.' ')GOTO1110 1100 CONTINUE LENGTH=0 GOTO9000 1110 CONTINUE LENGTH=IREV GOTO9000 C 9000 CONTINUE RETURN END DOUBLE PRECISION FUNCTION STROM(XVALUE) C C DESCRIPTION: C C This program calculates Stromgren's integral, defined as C C STROM(X) = integral 0 to X { t**7 exp(2t)/[exp(t)-1]**3 } dt C C The code uses a Chebyshev series, the coefficients of which are C given to an accuracy of 20 decimal places. C C C ERROR RETURNS: C C If XVALUE < 0.0, an error message is printed, and the program C returns the value 0.0. C C C MACHINE-DEPENDENT CONSTANTS: C C NTERMS - INTEGER - The number of terms of the array ASTROM to be used. C The recommended value is such that C ASTROM(NTERMS) < EPS/100 C C XLOW0 - DOUBLE PRECISION - The value below which STROM = 0.0 to machine C precision. The recommended value is C 5th root of (130*XMIN) C C XLOW1 - DOUBLE PRECISION - The value below which STROM = 3*(X**5)/(4*(pi**4)) C to machine precision. The recommended value is C 2*EPSNEG C C EPSLN - DOUBLE PRECISION - The value of ln(EPS). Used to determine the no. C of exponential terms for large X. C C EPNGLN - DOUBLE PRECISION - The value of ln(EPSNEG). Used to prevent C overflow for large X. C C XHIGH - DOUBLE PRECISION - The value above which C STROM = 196.52 - 15*(x**7)*exp(-x)/(4pi**4) C to machine precision. The recommended value is C 7 / EPS C C For values of EPS, EPSNEG, and XMIN refer to the file MACHCON.TXT C C The machine-dependent constants are computed internally by C using the D1MACH subroutine. C C C INTRINSIC FUNCTIONS USED: C C EXP, INT, LOG 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 C INTEGER K1,K2,NTERMS,NUMEXP DOUBLE PRECISION ASTROM(0:26),CHEVAL,EPNGLN,EPSLN,FOUR, 1 F15BP4,HALF,ONE,ONEHUN,ONE30,ONE5LN,PI4B3,RK, 2 SEVEN,SUMEXP,SUM2,T,TWO,VALINF,X,XHIGH, 3 XK,XK1,XLOW0,XLOW1,XVALUE,ZERO CCCCC CHARACTER FNNAME*6,ERRMSG*14 C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOMC.INC' CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C CCCCC DATA FNNAME/'STROM '/ CCCCC DATA ERRMSG/'ARGUMENT < 0.0'/ DATA ZERO,HALF,ONE/ 0.0 D 0 , 0.5 D 0 , 1.0 D 0/ DATA TWO,FOUR,SEVEN/ 2.0 D 0 , 4.0 D 0 , 7.0 D 0 / DATA ONEHUN,ONE30,ONE5LN/ 100.0 D 0 , 130.0 D 0 , 0.4055 D 0 / DATA F15BP4/0.38497 43345 50662 56959 D -1 / DATA PI4B3/1.29878 78804 53365 82982 D 2 / DATA VALINF/196.51956 92086 89882 61257 D 0/ DATA ASTROM(0)/ 0.56556 12087 25391 55290 D 0/ DATA ASTROM(1)/ 0.45557 31969 10178 5525 D -1/ DATA ASTROM(2)/ -0.40395 35875 93686 9170 D -1/ DATA ASTROM(3)/ -0.13339 05720 21486 815 D -2/ DATA ASTROM(4)/ 0.18586 25062 50538 030 D -2/ DATA ASTROM(5)/ -0.46855 55868 05365 9 D -4/ DATA ASTROM(6)/ -0.63434 75643 42294 9 D -4/ DATA ASTROM(7)/ 0.57254 87081 43200 D -5/ DATA ASTROM(8)/ 0.15935 28122 16822 D -5/ DATA ASTROM(9)/ -0.28884 32843 1036 D -6/ DATA ASTROM(10)/-0.24466 33604 801 D -7/ DATA ASTROM(11)/ 0.10072 50382 374 D -7/ DATA ASTROM(12)/-0.12482 98610 4 D -9/ DATA ASTROM(13)/-0.26300 62528 3 D -9/ DATA ASTROM(14)/ 0.24904 07578 D -10/ DATA ASTROM(15)/ 0.48545 4902 D -11/ DATA ASTROM(16)/-0.10537 8913 D -11/ DATA ASTROM(17)/-0.36044 17 D -13/ DATA ASTROM(18)/ 0.29920 78 D -13/ DATA ASTROM(19)/-0.16397 1 D -14/ DATA ASTROM(20)/-0.61061 D -15/ DATA ASTROM(21)/ 0.9335 D -16/ DATA ASTROM(22)/ 0.709 D -17/ DATA ASTROM(23)/-0.291 D -17/ DATA ASTROM(24)/ 0.8 D -19/ DATA ASTROM(25)/ 0.6 D -19/ DATA ASTROM(26)/-0.1 D -19/ C C Start execution C X = XVALUE C C Error test C IF ( X .LT. ZERO ) THEN CCCCC CALL ERRPRN(FNNAME,ERRMSG) WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,101)X CALL DPWRST('XXX','BUG ') STROM = ZERO RETURN ENDIF 999 FORMAT(1X) 101 FORMAT('***** ERROR FROM STROM--ARGUMENT MUST BE ', 1 'NON-NEGATIVE, ARGUMENT = ',G15.7) C C Compute the machine-dependent constants. C XK = D1MACH(3) T = XK / ONEHUN IF ( X .LE. FOUR ) THEN DO 10 NTERMS = 26 , 0 , -1 IF ( ABS(ASTROM(NTERMS)) .GT. T ) GOTO 19 10 CONTINUE 19 XLOW0 = ( ONE30 * D1MACH(1) ) ** (ONE/(SEVEN-TWO)) XLOW1 = TWO * XK ELSE EPSLN = LOG ( D1MACH(4) ) EPNGLN = LOG ( XK ) XHIGH = SEVEN / XK ENDIF C C Code for x < = 4.0 C IF ( X .LE. FOUR ) THEN IF ( X .LT. XLOW0 ) THEN STROM = ZERO ELSE IF ( X .LT. XLOW1 ) THEN STROM = (X**5) / PI4B3 ELSE T = ( ( X / TWO ) - HALF ) - HALF STROM = (X**5) * CHEVAL(NTERMS,ASTROM,T) * F15BP4 ENDIF ENDIF ELSE C C Code for x > 4.0 C IF ( X .GT. XHIGH ) THEN SUMEXP = ONE ELSE NUMEXP = INT( EPSLN / (ONE5LN - X ) ) + 1 IF ( NUMEXP .GT. 1 ) THEN T = EXP( -X ) ELSE T = ONE ENDIF RK = ZERO DO 100 K1 = 1 , NUMEXP RK = RK + ONE 100 CONTINUE SUMEXP = ZERO DO 300 K1 = 1 , NUMEXP SUM2 = ONE XK = ONE / ( RK * X ) XK1 = ONE DO 200 K2 = 1 , 7 SUM2 = SUM2 * XK1 * XK + ONE XK1 = XK1 + ONE 200 CONTINUE SUM2 = SUM2 * ( RK + ONE ) / TWO SUMEXP = SUMEXP * T + SUM2 RK = RK - ONE 300 CONTINUE ENDIF T = SEVEN * LOG(X) - X + LOG(SUMEXP) IF ( T .LT. EPNGLN ) THEN STROM = VALINF ELSE STROM = VALINF - EXP(T) * F15BP4 ENDIF ENDIF RETURN END SUBROUTINE STRSL(T,LDT,N,B,JOB,INFO) C***BEGIN PROLOGUE STRSL C***DATE WRITTEN 780814 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D2A3 C***KEYWORDS LINEAR ALGEBRA,LINPACK,MATRIX,SOLVE,TRIANGULAR C***AUTHOR STEWART, G. W., (U. OF MARYLAND) C***PURPOSE Solves systems of the form T*X=B or TRANS(T)*X=B C where T is a TRIANGULAR matrix of order N. C***DESCRIPTION C C STRSL solves systems of the form C C T * X = B C or C TRANS(T) * X = B C C where T is a triangular matrix of order N. Here TRANS(T) C denotes the transpose of the matrix T. C C On Entry C C T REAL(LDT,N) C T contains the matrix of the system. The zero C elements of the matrix are not referenced, and C the corresponding elements of the array can be C used to store other information. C C LDT INTEGER C LDT is the leading dimension of the array T. C C N INTEGER C N is the order of the system. C C B REAL(N). C B contains the right hand side of the system. C C JOB INTEGER C JOB specifies what kind of system is to be solved. C If JOB is C C 00 solve T*X=B, T lower triangular, C 01 solve T*X=B, T upper triangular, C 10 solve TRANS(T)*X=B, T lower triangular, C 11 solve TRANS(T)*X=B, T upper triangular. C C On Return C C B B contains the solution, if INFO .EQ. 0. C Otherwise B is unaltered. C C INFO INTEGER C INFO contains zero if the system is nonsingular. C Otherwise INFO contains the index of C the first zero diagonal element of T. C C LINPACK. This version dated 08/14/78 . C G. W. Stewart, University of Maryland, Argonne National Lab. C C Subroutines and Functions C C BLAS SAXPY,SDOT C Fortran MOD C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., C *LINPACK USERS GUIDE*, SIAM, 1979. C***ROUTINES CALLED SAXPY,SDOT C***END PROLOGUE STRSL INTEGER LDT,N,JOB,INFO REAL T(LDT,1),B(1) C C REAL SDOT,TEMP INTEGER CASE,J,JJ C C BEGIN BLOCK PERMITTING ...EXITS TO 150 C C CHECK FOR ZERO DIAGONAL ELEMENTS. C C***FIRST EXECUTABLE STATEMENT STRSL DO 10 INFO = 1, N C ......EXIT IF (T(INFO,INFO) .EQ. 0.0E0) GO TO 150 10 CONTINUE INFO = 0 C C DETERMINE THE TASK AND GO TO IT. C CASE = 1 IF (MOD(JOB,10) .NE. 0) CASE = 2 IF (MOD(JOB,100)/10 .NE. 0) CASE = CASE + 2 GO TO (20,50,80,110), CASE C C SOLVE T*X=B FOR T LOWER TRIANGULAR C 20 CONTINUE B(1) = B(1)/T(1,1) IF (N .LT. 2) GO TO 40 DO 30 J = 2, N TEMP = -B(J-1) CALL SAXPY(N-J+1,TEMP,T(J,J-1),1,B(J),1) B(J) = B(J)/T(J,J) 30 CONTINUE 40 CONTINUE GO TO 140 C C SOLVE T*X=B FOR T UPPER TRIANGULAR. C 50 CONTINUE B(N) = B(N)/T(N,N) IF (N .LT. 2) GO TO 70 DO 60 JJ = 2, N J = N - JJ + 1 TEMP = -B(J+1) CALL SAXPY(J,TEMP,T(1,J+1),1,B(1),1) B(J) = B(J)/T(J,J) 60 CONTINUE 70 CONTINUE GO TO 140 C C SOLVE TRANS(T)*X=B FOR T LOWER TRIANGULAR. C 80 CONTINUE B(N) = B(N)/T(N,N) IF (N .LT. 2) GO TO 100 DO 90 JJ = 2, N J = N - JJ + 1 B(J) = B(J) - SDOT(JJ-1,T(J+1,J),1,B(J+1),1) B(J) = B(J)/T(J,J) 90 CONTINUE 100 CONTINUE GO TO 140 C C SOLVE TRANS(T)*X=B FOR T UPPER TRIANGULAR. C 110 CONTINUE B(1) = B(1)/T(1,1) IF (N .LT. 2) GO TO 130 DO 120 J = 2, N B(J) = B(J) - SDOT(J-1,T(1,J),1,B(1),1) B(J) = B(J)/T(J,J) 120 CONTINUE 130 CONTINUE 140 CONTINUE 150 CONTINUE RETURN END SUBROUTINE STRSWP(A,N1,N2,N3) C C PURPOSE--XX C C NOTE--RECOMMENDED DIMENSIONS-- C A(N3-1) C C WRITTEN BY--DAVID W. BEHRINGER NOAA/AOML (MIAMI). C AS PART OF NOAA'S CONCX V.3 MARCH 1988. C ORIGINAL VERSION (IN DATAPLOT)--AUGUST 1988. C C--------------------------------------------------------------------- C DIMENSION A(*) C C-----START POINT----------------------------------------------------- C DO 10 N=N1,N2-1 H=A(N1) DO 20 I=N1,N3-2 A(I)=A(I+1) 20 CONTINUE A(N3-1)=H 10 CONTINUE RETURN END DOUBLE PRECISION FUNCTION STUDNT( NU, T ) * * Student t Distribution Function * * T * STUDNT = C I ( 1 + y*y/NU )**( -(NU+1)/2 ) dy * NU -INF * INTEGER NU, J DOUBLE PRECISION T, CSSTHE, SNTHE, POLYN, TT, TS, RN, PI, ZERO PARAMETER ( PI = 3.14159 26535 89793D0, ZERO = 0 ) IF ( NU .EQ. 1 ) THEN STUDNT = ( 1.0D0 + 2.0D0*ATAN(T)/PI )/2.0D0 ELSE IF ( NU .EQ. 2) THEN STUDNT = ( 1.0D0 + T/SQRT( 2.0D0 + T*T ))/2.0D0 ELSE TT = T*T CSSTHE = 1.0D0/( 1.0D0 + TT/DBLE(NU) ) POLYN = 1.0D0 DO 100 J = NU-2, 2, -2 POLYN = 1.0D0 + DBLE( J - 1 )*CSSTHE*POLYN/DBLE(J) 100 CONTINUE IF ( MOD( NU, 2 ) .EQ. 1 ) THEN RN = NU TS = T/SQRT(RN) STUDNT = ( 1.0D0 + 2.0D0* & ( ATAN(TS) + TS*CSSTHE*POLYN )/PI )/2.0D0 ELSE SNTHE = T/SQRT( NU + TT ) STUDNT = ( 1.0D0 + SNTHE*POLYN )/2.0D0 END IF STUDNT = MAX( ZERO, STUDNT ) ENDIF C RETURN END SUBROUTINE STVH0(X,SH0) C C ============================================= C Purpose: Compute Struve function H0(x) C Input : x --- Argument of H0(x) ( x ò 0 ) C Output: SH0 --- H0(x) C ============================================= C IMPLICIT DOUBLE PRECISION (A-H,O-Z) PI=3.141592653589793D0 S=1.0D0 R=1.0D0 IF (X.LE.20.0D0) THEN A0=2.0*X/PI DO 10 K=1,60 R=-R*X/(2.0D0*K+1.0D0)*X/(2.0D0*K+1.0D0) S=S+R IF (DABS(R).LT.DABS(S)*1.0D-12) GO TO 15 10 CONTINUE 15 SH0=A0*S ELSE KM=INT(.5*(X+1.0)) IF (X.GE.50.0) KM=25 DO 20 K=1,KM R=-R*((2.0D0*K-1.0D0)/X)**2 S=S+R IF (DABS(R).LT.DABS(S)*1.0D-12) GO TO 25 20 CONTINUE 25 T=4.0D0/X T2=T*T P0=((((-.37043D-5*T2+.173565D-4)*T2-.487613D-4) & *T2+.17343D-3)*T2-.1753062D-2)*T2+.3989422793D0 Q0=T*(((((.32312D-5*T2-.142078D-4)*T2+.342468D-4)* & T2-.869791D-4)*T2+.4564324D-3)*T2-.0124669441D0) TA0=X-.25D0*PI BY0=2.0D0/DSQRT(X)*(P0*DSIN(TA0)+Q0*DCOS(TA0)) SH0=2.0D0/(PI*X)*S+BY0 ENDIF RETURN END SUBROUTINE STVH1(X,SH1) C C ============================================= C Purpose: Compute Struve function H1(x) C Input : x --- Argument of H1(x) ( x ò 0 ) C Output: SH1 --- H1(x) C ============================================= C IMPLICIT DOUBLE PRECISION (A-H,O-Z) PI=3.141592653589793D0 R=1.0D0 IF (X.LE.20.0D0) THEN S=0.0D0 A0=-2.0D0/PI DO 10 K=1,60 R=-R*X*X/(4.0D0*K*K-1.0D0) S=S+R IF (DABS(R).LT.DABS(S)*1.0D-12) GO TO 15 10 CONTINUE 15 SH1=A0*S ELSE S=1.0D0 KM=INT(.5*X) IF (X.GT.50.D0) KM=25 DO 20 K=1,KM R=-R*(4.0D0*K*K-1.0D0)/(X*X) S=S+R IF (DABS(R).LT.DABS(S)*1.0D-12) GO TO 25 20 CONTINUE 25 T=4.0D0/X T2=T*T P1=((((.42414D-5*T2-.20092D-4)*T2+.580759D-4)*T2 & -.223203D-3)*T2+.29218256D-2)*T2+.3989422819D0 Q1=T*(((((-.36594D-5*T2+.1622D-4)*T2-.398708D-4)* & T2+.1064741D-3)*T2-.63904D-3)*T2+.0374008364D0) TA1=X-.75D0*PI BY1=2.0D0/DSQRT(X)*(P1*DSIN(TA1)+Q1*DCOS(TA1)) SH1=2.0/PI*(1.0D0+S/(X*X))+BY1 ENDIF RETURN END SUBROUTINE STVHV(V,X,HV) C C ===================================================== C Purpose: Compute Struve function Hv(x) with an C arbitrary order v C Input : v --- Order of Hv(x) ( -8.0 ó v ó 12.5 ) C x --- Argument of Hv(x) ( x ò 0 ) C Output: HV --- Hv(x) C Routine called: GAMMA to compute the gamma function C ===================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) PI=3.141592653589793D0 IF (X.EQ.0.0D0) THEN IF (V.GT.-1.0.OR.INT(V)-V.EQ.0.5D0) THEN HV=0.0D0 ELSE IF (V.LT.-1.0D0) THEN HV=(-1)**(INT(0.5D0-V)-1)*1.0D+300 ELSE IF (V.EQ.-1.0D0) THEN HV=2.0D0/PI ENDIF RETURN ENDIF IF (X.LE.20.0D0) THEN V0=V+1.5D0 CCCCC CALL GAMMA(V0,GA) GA=DGAMMA(V0) S=2.0D0/(DSQRT(PI)*GA) R1=1.0D0 DO 10 K=1,100 VA=K+1.5D0 CCCCC CALL GAMMA(VA,GA) GA=DGAMMA(VA) VB=V+K+1.5D0 CCCCC CALL GAMMA(VB,GB) GB=DGAMMA(VB) R1=-R1*(0.5D0*X)**2 R2=R1/(GA*GB) S=S+R2 IF (DABS(R2).LT.DABS(S)*1.0D-12) GO TO 15 10 CONTINUE 15 HV=(0.5D0*X)**(V+1.0D0)*S ELSE SA=(0.5D0*X)**(V-1.0)/PI V0=V+0.5D0 CCCCC CALL GAMMA(V0,GA) GA=DGAMMA(V0) S=DSQRT(PI)/GA R1=1.0D0 DO 20 K=1,12 VA=K+0.5D0 CCCCC CALL GAMMA(VA,GA) GA=DGAMMA(VA) VB=-K+V+0.5D0 CCCCC CALL GAMMA(VB,GB) GB=DGAMMA(VB) R1=R1/(0.5D0*X)**2 S=S+R1*GA/GB 20 CONTINUE S0=SA*S U=DABS(V) N=INT(U) U0=U-N DO 35 L=0,1 VT=4.0D0*(U0+L)**2 R1=1.0D0 PU1=1.0D0 DO 25 K=1,12 R1=-0.0078125D0*R1*(VT-(4.0*K-3.0D0)**2)* & (VT-(4.0D0*K-1.0)**2)/((2.0D0*K-1.0)*K*X*X) PU1=PU1+R1 25 CONTINUE QU1=1.0D0 R2=1.0D0 DO 30 K=1,12 R2=-0.0078125D0*R2*(VT-(4.0D0*K-1.0)**2)* & (VT-(4.0D0*K+1.0)**2)/((2.0D0*K+1.0)*K*X*X) QU1=QU1+R2 30 CONTINUE QU1=0.125D0*(VT-1.0D0)/X*QU1 IF (L.EQ.0) THEN PU0=PU1 QU0=QU1 ENDIF 35 CONTINUE T0=X-(0.5*U0+0.25D0)*PI T1=X-(0.5*U0+0.75D0)*PI SR=DSQRT(2.0D0/(PI*X)) BY0=SR*(PU0*DSIN(T0)+QU0*DCOS(T0)) BY1=SR*(PU1*DSIN(T1)+QU1*DCOS(T1)) BF0=BY0 BF1=BY1 DO 40 K=2,N BF=2.0D0*(K-1.0+U0)/X*BF1-BF0 BF0=BF1 40 BF1=BF IF (N.EQ.0) BYV=BY0 IF (N.EQ.1) BYV=BY1 IF (N.GT.1) BYV=BF HV=BYV+S0 ENDIF RETURN END SUBROUTINE STVL0(X,SL0) C C ================================================ C Purpose: Compute modified Struve function L0(x) C Input : x --- Argument of L0(x) ( x ò 0 ) C Output: SL0 --- L0(x) C ================================================ C IMPLICIT DOUBLE PRECISION (A-H,O-Z) PI=3.141592653589793D0 S=1.0D0 R=1.0D0 IF (X.LE.20.0D0) THEN A0=2.0D0*X/PI DO 10 K=1,60 R=R*(X/(2.0D0*K+1.0D0))**2 S=S+R IF (DABS(R/S).LT.1.0D-12) GO TO 15 10 CONTINUE 15 SL0=A0*S ELSE KM=INT(.5*(X+1.0)) IF (X.GE.50.0) KM=25 DO 20 K=1,KM R=R*((2.0D0*K-1.0D0)/X)**2 S=S+R IF (DABS(R/S).LT.1.0D-12) GO TO 25 20 CONTINUE 25 A1=DEXP(X)/DSQRT(2.0D0*PI*X) R=1.0D0 BI0=1.0D0 DO 30 K=1,16 R=0.125D0*R*(2.0D0*K-1.0D0)**2/(K*X) BI0=BI0+R IF (DABS(R/BI0).LT.1.0D-12) GO TO 35 30 CONTINUE 35 BI0=A1*BI0 SL0=-2.0D0/(PI*X)*S+BI0 ENDIF RETURN END SUBROUTINE STVL1(X,SL1) C C ================================================ C Purpose: Compute modified Struve function L1(x) C Input : x --- Argument of L1(x) ( x ò 0 ) C Output: SL1 --- L1(x) C ================================================ C IMPLICIT DOUBLE PRECISION (A-H,O-Z) PI=3.141592653589793D0 R=1.0D0 IF (X.LE.20.0D0) THEN S=0.0D0 DO 10 K=1,60 R=R*X*X/(4.0D0*K*K-1.0D0) S=S+R IF (DABS(R/S).LT.1.0D-12) GO TO 15 10 CONTINUE 15 SL1=2.0D0/PI*S ELSE S=1.0D0 KM=INT(.50*X) IF (X.GT.50) KM=25 DO 20 K=1,KM R=R*(2.0D0*K+3.0D0)*(2.0D0*K+1.0D0)/(X*X) S=S+R IF (DABS(R/S).LT.1.0D-12) GO TO 25 20 CONTINUE 25 SL1=2.0D0/PI*(-1.0D0+1.0D0/(X*X)+3.0D0*S/X**4) A1=DEXP(X)/DSQRT(2.0D0*PI*X) R=1.0D0 BI1=1.0D0 DO 30 K=1,16 R=-0.125D0*R*(4.0D0-(2.0D0*K-1.0D0)**2)/(K*X) BI1=BI1+R IF (DABS(R/BI1).LT.1.0D-12) GO TO 35 30 CONTINUE 35 SL1=SL1+A1*BI1 ENDIF RETURN END SUBROUTINE STVLV(V,X,SLV) C C ====================================================== C Purpose: Compute modified Struve function Lv(x) with C an arbitrary order v C Input : v --- Order of Lv(x) ( |v| ó 20 ) C x --- Argument of Lv(x) ( x ò 0 ) C Output: SLV --- Lv(x) C Routine called: GAMMA to compute the gamma function C ====================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) PI=3.141592653589793D0 IF (X.EQ.0.0D0) THEN IF (V.GT.-1.0.OR.INT(V)-V.EQ.0.5D0) THEN SLV=0.0D0 ELSE IF (V.LT.-1.0D0) THEN SLV=(-1)**(INT(0.5D0-V)-1)*1.0D+300 ELSE IF (V.EQ.-1.0D0) THEN SLV=2.0D0/PI ENDIF RETURN ENDIF IF (X.LE.40.0D0) THEN V0=V+1.5D0 CCCCC CALL GAMMA(V0,GA) GA=DGAMMA(V0) S=2.0D0/(DSQRT(PI)*GA) R1=1.0D0 DO 10 K=1,100 VA=K+1.5D0 CCCCC CALL GAMMA(VA,GA) GA=DGAMMA(VA) VB=V+K+1.5D0 CCCCC CALL GAMMA(VB,GB) GB=DGAMMA(VB) R1=R1*(0.5D0*X)**2 R2=R1/(GA*GB) S=S+R2 IF (DABS(R2/S).LT.1.0D-12) GO TO 15 10 CONTINUE 15 SLV=(0.5D0*X)**(V+1.0D0)*S ELSE SA=-1.0D0/PI*(0.5D0*X)**(V-1.0) V0=V+0.5D0 CCCCC CALL GAMMA(V0,GA) GA=DGAMMA(V0) S=-DSQRT(PI)/GA R1=-1.0D0 DO 20 K=1,12 VA=K+0.5D0 CCCCC CALL GAMMA(VA,GA) GA=DGAMMA(VA) VB=-K+V+0.5D0 CCCCC CALL GAMMA(VB,GB) GB=DGAMMA(VB) R1=-R1/(0.5D0*X)**2 S=S+R1*GA/GB 20 CONTINUE S0=SA*S U=DABS(V) N=INT(U) U0=U-N DO 35 L=0,1 VT=U0+L R=1.0D0 BIV=1.0D0 DO 25 K=1,16 R=-0.125*R*(4.0*VT*VT-(2.0*K-1.0D0)**2)/(K*X) BIV=BIV+R IF (DABS(R/BIV).LT.1.0D-12) GO TO 30 25 CONTINUE 30 IF (L.EQ.0) BIV0=BIV 35 CONTINUE BF0=BIV0 BF1=BIV DO 40 K=2,N BF=-2.0D0*(K-1.0+U0)/X*BF1+BF0 BF0=BF1 40 BF1=BF IF (N.EQ.0) BIV=BIV0 IF (N.GT.1) BIV=BF SLV=DEXP(X)/DSQRT(2.0D0*PI*X)*BIV+S0 ENDIF RETURN END SUBROUTINE STWS(X,N,IWRITE,YSTWS,IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C STANDARDIZED WILK-SHAPIRO STATISTIC C THE PROTOTYPE NORMAL DISTRIBUTION USED HEREIN C HAS MEAN = 0 AND STANDARD DEVIATION = 1. C THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS C THE PROBABILITY DENSITY FUNCTION C F(X) = (1/SQRT(2*PI)) * EXP(-X*X/2). C THE STANDARDIZED WILK-SHAPIRO STATISTIC IS USEFUL IN C TESTING THE COMPOSITE (THAT IS, C LOCATION AND SCALE PARAMETERS NEED NOT BE SPECIFIED) C HYPOTHESIS THAT THE UNDERLYING DISTRIBUTION C FROM WHICH THE DATA HAVE BEEN RANDOMLY DRAWN C IS THE NORMAL DISTRIBUTION. C IF THE HYPOTHESIS IS TRUE, THE STANDARDIZED C WILK-SHAPIRO STATISTIC SHOULD BE NEAR-ZERO OR POSITIVE. 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--YSTWS = THE SINGLE PRECISION VALUE OF THE C COMPUTED STANDARDIZED WILK-SHAPIRO STATISTIC. C OUTPUT--NONE. C PRINTING--YES. C RESTRICTIONS--THE MAXIMUM ALLOWABLE VALUE OF N C FOR THIS SUBROUTINE IS 1000. C OTHER DATAPAC SUBROUTINES NEEDED--SORT, UNIMED, NORPPF. C FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT. C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--FILLIBEN, 'TECHNIQUES FOR TAIL LENGTH ANALYSIS', C PROCEEDINGS OF THE EIGHTEENTH CONFERENCE C ON THE DESIGN OF EXPERIMENTS IN ARMY RESEARCH C DEVELOPMENT AND TESTING (ABERDEEN, MARYLAND, C OCTOBER, 1972), PAGES 425-450. C --HAHN AND SHAPIRO, STATISTICAL METHODS IN ENGINEERING, C 1967, PAGES 260-308. 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 (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 UPDATED --JUNE 1990. TEMPORARY ARRAYS TO GARBAGE COMMON C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION X(*) DIMENSION Y(MAXOBV) CCCCC FOLLOWING LINES ADDED JUNE, 1990 INCLUDE 'DPCOZ2.INC' EQUIVALENCE (G2RBAG(IGAR45),Y(1)) CCCCC END CHANGE C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C ISUBN1='STWS' ISUBN2=' ' C IERROR='NO' IUPPER=MAXOBV C EWILKS=0.0 SDWILK=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 STWS--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA3 52 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)N 53 FORMAT('N = ',I8) CALL DPWRST('XXX','BUG ') DO55I=1,N WRITE(ICOUT,56)I,X(I) 56 FORMAT('I,X(I) = ',I8,E15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE 90 CONTINUE C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C AN=N C IF(1.LE.N.AND.N.LE.IUPPER)GOTO119 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN STWS--') 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 STANDARDIZED WILK-SHAPIRO') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,115) 115 FORMAT(' STATISTIC 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 STWS--', 1'THE 2ND INPUT ARGUMENT (N) HAS THE VALUE 1') CALL DPWRST('XXX','BUG ') YSTWS=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 STWS--', 1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','BUG ') YSTWS=0.0 GOTO9000 139 CONTINUE C 190 CONTINUE C C ******************************** C ** STEP 2-- ** C ** COMPUTE THE ** C ** WILK-SHAPIRO STATISTIC ** C ******************************** C CALL SORT(X,N,Y) C AL=ALOG10(AN) GAMMA=.327511+.058212*AL-.009776*AL*AL C SUM=0.0 DO100I=1,N SUM=SUM+Y(I) 100 CONTINUE YBAR=SUM/AN C SUM=0.0 DO200I=1,N SUM=SUM+(Y(I)-YBAR)**2 200 CONTINUE BVAR=SUM/AN BS=0.0 IF(BVAR.GT.0.0)BS=SQRT(BVAR) C SUM=0.0 IF(N.LE.20)ARG=N IF(N.GT.20)ARG=N+1 ASUBN=SQRT((1.0+(1.0/(4.0*ARG)))/SQRT(ARG)) ASUB1=-ASUBN SUM=SUM+ASUB1*Y(1)+ASUBN*Y(N) IF(N.LE.2)GOTO510 NM1=N-1 DO500I=2,NM1 AI=I PI=(AI-GAMMA)/(AN-2.0*GAMMA+1.0) CALL NORPPF(PI,EI) COEFI =2.0*EI /SQRT(-2.722+4.083*AN) SUM=SUM+COEFI*Y(I) 500 CONTINUE 510 CONTINUE WILKSH=SUM*SUM/(AN*BS*BS) C C **************************************************************** C ** STEP 3-- C ** COMPUTE THE EXPECTED VALUE AND STANDARD DEVIATION C ** OF THE WILK-SHAPIRO STATISTIC UNDER THE NORMALITY ASSUMPTION C ** REFERENCE--JJF APPROXIMATION TO MOMENTS C ** ON PAGE 601 OF BIOMETRIKA (1965) C **************************************************************** C IF(N.LE.2)EWILKS=1.0 IF(N.EQ.3)EWILKS=.9135 IF(N.EQ.4)EWILKS=.9012 IF(N.GE.5)EWILKS=.9026+(AN-5.0)/(44.608+13.593*SQRT(AN)+10.267*AN) C IF(N.LE.2)SDWILK=1.0 IF(N.EQ.3)SDWILK=.0755 IF(N.EQ.4)SDWILK=.0719 IF(N.GE.5)SDWILK=.0670+(AN-5.0)/(-42.368-5.026*SQRT(AN)-14.925*AN) YSTWS=(WILKSH-EWILKS)/SDWILK C C ******************************* C ** STEP 4-- ** 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 STANDARDIZED WILK-SHAPIRO STATISTIC') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,812)N,YSTWS 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 STWS--') 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)YSTWS 9015 FORMAT('YSTWS = ',E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE SUBSAM(Y1,Y2,N1,N2,IWRITE, 1Y3,N3,IBUGA3,ISUBRO,IERROR) C C PURPOSE--EXTRACT A RANDOM SUBSAMPLE C OF THE DATA IN Y1(.) BASED ON THE INDICES IN Y2(.). C NOTE--CONTRARY TO BOOTSS, N2 NEED NOT BE THE SAME AS N1 C (BUT SHOULD NOT EXCEED N1). C C INPUT ARGUMENTS--Y1 = ORIGINAL SAMPLE C --Y2 = INDEX FOR RANDOM SUBSAMPLE C OUTPUT ARGUMENTS--Y3 = RANDOM SUBSAMPLE C C NOTE--IT IS PERMISSIBLE TO HAVE THE OUTPUT VECTOR Y3(.) C BEING IDENTICAL TO EITHER OF THE INPUT VECTORS Y1(.) OR Y2(.) C NOTE--IF AN ELEMENT OF THE INPUT INDEX (Y2) IS SMALLER THAN 1 C OR LARGER THAN N1, THEN THIS WILL BE INTERPRETED AS C A NON-OPERATION. 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--90/2 C ORIGINAL VERSION--JANUARY 1990. 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 INCLUDE 'DPCOPA.INC' C DIMENSION Y1(*) DIMENSION Y2(*) 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='SUBS' ISUBN2='AM ' C IERROR='NO' C IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'OTSS')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF SUBSAM--') 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)N1,N2 53 FORMAT('N1,N2 = ',2I8) CALL DPWRST('XXX','BUG ') DO55I=1,N1 WRITE(ICOUT,56)I,Y1(I) 56 FORMAT('I,Y1(I) = ',I8,E13.5) CALL DPWRST('XXX','BUG ') 55 CONTINUE DO65I=1,N2 WRITE(ICOUT,66)I,Y2(I) 66 FORMAT('I,Y2(I) = ',I8,E13.5) CALL DPWRST('XXX','BUG ') 65 CONTINUE 90 CONTINUE C C ************************************* C ** CONSTRUCT A RANDOM SUBSAMPLE ** C ************************************* C C ******************************************** C ** STEP 11-- ** C ** CHECK NUMBER OF INPUT OBSERVATIONS. ** C ******************************************** C IF(N1.LT.1)GOTO1110 GOTO1119 C 1110 CONTINUE IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1111) 1111 FORMAT('***** ERROR IN SUBSAM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1112) 1112 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1113) 1113 FORMAT(' IN THE VARIABLE FOR WHICH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1114) 1114 FORMAT(' THE RANDOM SAMPLE IS TO BE ', 1'EXTRACTED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1115) 1115 FORMAT(' MUST BE 1 OR LARGER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1116) 1116 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1117)N1 1117 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 1'.') CALL DPWRST('XXX','BUG ') GOTO9000 1119 CONTINUE C IF(N2.LT.1)GOTO1120 GOTO1129 C 1120 CONTINUE IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1121) 1121 FORMAT('***** ERROR IN SUBSAM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1122) 1122 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1123) 1123 FORMAT(' IN THE VARIABLE SPECIFYING THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1124) 1124 FORMAT(' INDEX OF THE RANDOM SAMPLE TO BE ', 1'EXTRACTED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1125) 1125 FORMAT(' MUST BE 1 OR LARGER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1126) 1126 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1127)N2 1127 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 1'.') CALL DPWRST('XXX','BUG ') GOTO9000 1129 CONTINUE C J=0 DO1300I=1,N2 INDEX=Y2(I)+0.1 IF(INDEX.LT.1.OR.INDEX.GT.N1)GOTO1300 J=J+1 Y3(J)=Y1(INDEX) 1300 CONTINUE N3=J 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 SUBSAM--') 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 ') WRITE(ICOUT,9017)N1,N2,N3 9017 FORMAT('N1,N2,N3 = ',3I8) CALL DPWRST('XXX','BUG ') IF(N1.LE.0)GOTO9023 DO9021I=1,N1 WRITE(ICOUT,9022)I,Y1(I) 9022 FORMAT('I,Y1(I) = ',I8,E13.5) CALL DPWRST('XXX','BUG ') 9021 CONTINUE 9023 CONTINUE IF(N2.LE.0)GOTO9033 DO9031I=1,N2 WRITE(ICOUT,9032)I,Y2(I) 9032 FORMAT('I,Y2(I) = ',I8,E13.5) CALL DPWRST('XXX','BUG ') 9031 CONTINUE 9033 CONTINUE 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 SUFIT (XBAR, SD, RB1, B2, GAMMA, DELTA, XLAM, XI) C C ALGORITHM AS 99.1 APPL. STATIST. (1976) VOL.25, P.180 C C FINDS PARAMETERS OF JOHNSON SU CURVE WITH C GIVEN FIRST FOUR MOMENTS C REAL XBAR, SD, RB1, B2, GAMMA, DELTA, XLAM, XI, TOL, B1, $ B3, W, Y, W1, WM1, Z, V, A, B, X, ZERO, ONE, TWO, THREE, $ FOUR, SIX, SEVEN, EIGHT, NINE, TEN, HALF, ONE5, TWO8, CCCCC$ SIXTEN, ZABS, ZEXP, ZLOG, ZSIGN, ZSQRT $ SIXTEN, ZABS, ZEXP, ZLOG, ZSQRT C DATA TOL /0.01/ DATA ZERO, ONE, TWO, THREE, FOUR, SIX, SEVEN, $ EIGHT, NINE, TEN, SIXTEN, HALF, ONE5, TWO8 $ /0.0, 1.0, 2.0, 3.0, 4.0, 6.0, 7.0, $ 8.0, 9.0, 10.0, 16.0, 0.5, 1.5, 2.8/ C ZABS(X) = ABS(X) ZEXP(X) = EXP(X) ZLOG(X) = ALOG(X) CCCCC ZSIGN(X, Y) = SIGN(X, Y) ZSQRT(X) = SQRT(X) C B1 = RB1 * RB1 B3 = B2 - THREE C C W IS FIRST ESTIMATE OF EXP(DELTA ** (-2)) C W = ZSQRT(TWO * B2 - TWO8 * B1 - TWO) W = ZSQRT(W-ONE) IF (ZABS(RB1) .GT. TOL) GOTO 10 C C SYMMETRICAL CASE - RESULTS ARE KNOWN C Y = ZERO GOTO 20 C C JOHNSON ITERATION (USING Y FOR HIS M) C 10 W1 = W + ONE WM1 = W - ONE Z = W1 * B3 V = W * (SIX + W * (THREE + W)) A = EIGHT * (WM1 * (THREE + W * (SEVEN + V)) - Z) B = SIXTEN * (WM1 * (SIX + V) - B3) Y = (ZSQRT(A * A - TWO * B * (WM1 * (THREE + W * $ (NINE + W * (TEN + V))) - TWO * W1 * Z)) - A) / B Z = Y * WM1 * (FOUR * (W + TWO) * Y + THREE * W1 * W1) ** 2 / $ (TWO * (TWO * Y + W1) ** 3) V = W * W W = ZSQRT(ONE - TWO * (ONE5 - B2 + (B1 * $ (B2 - ONE5 - V * (ONE + HALF * V))) / Z)) W = ZSQRT(W-ONE) IF (ZABS(B1 - Z) .GT. TOL) GOTO 10 C C END OF ITERATION C Y = Y / W Y = ZLOG(ZSQRT(Y) + ZSQRT(Y + ONE)) IF (RB1 .GT. ZERO) Y = -Y 20 X = ZSQRT(ONE / ZLOG(W)) DELTA = X GAMMA = Y * X Y = ZEXP(Y) Z = Y * Y X = SD / ZSQRT(HALF * (W - ONE) * (HALF * W * $ (Z + ONE / Z) + ONE)) XLAM = X XI = (HALF * ZSQRT(W) * (Y - ONE / Y)) * X + XBAR RETURN END SUBROUTINE SUM(X,N,IWRITE,XSUM,IBUGA3,IERROR) C C PURPOSE--THIS SUBROUTINE COMPUTES THE C SAMPLE SUM C OF THE DATA IN THE INPUT VECTOR X. C THE SAMPLE SUM = SUM OF ALL OBSERVATIONS IN X. C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF C (UNSORTED OR SORTED) OBSERVATIONS. C --N = THE INTEGER NUMBER OF OBSERVATIONS C IN THE VECTOR X. C OUTPUT ARGUMENTS--XSUM = THE SINGLE PRECISION VALUE OF THE C COMPUTED SAMPLE SUM. C OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE C SAMPLE SUM. C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE C OF N FOR THIS SUBROUTINE. C OTHER DATAPAC SUBROUTINES NEEDED--NONE. C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. C LANGUAGE--ANSI FORTRAN (1977) C REFERENCES--KENDALL AND STUART, THE ADVANCED THEORY OF C STATISTICS, VOLUME 2, EDITION 1, 1961, PAGE 4. C --MOOD AND GRABLE, INTRODUCTION TO THE THEORY C OF STATISTICS, EDITION 2, 1963, PAGE 146. C --DIXON AND MASSEY, INTRODUCTION TO STATISTICAL C ANALYSIS, EDITION 2, 1957, PAGE 14. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C 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 (1966) C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS C DENOTED BY QUOTES RATHER THAN NH. C VERSION NUMBER--82.6 C ORIGINAL VERSION--JUNE 1972. C UPDATED --SEPTEMBER 1975. C UPDATED --NOVEMBER 1975. C UPDATED --OCTOBER 1978. C UPDATED --JUNE 1979. C UPDATED --JULY 1979. C UPDATED --AUGUST 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IWRITE CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DOUBLE PRECISION DX DOUBLE PRECISION 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='SUM ' 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 SUM--') 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 SUM ** 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 SUM--') 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 SUM IS TO BE COMPUTED') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,115) 115 FORMAT(' MUST BE 1 OR LARGER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,116) 116 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,117)N 117 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 1'.') CALL DPWRST('XXX','BUG ') GOTO9000 119 CONTINUE C IF(N.EQ.1)GOTO120 GOTO129 120 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,121) 121 FORMAT('***** NON-FATAL DIAGNOSTIC IN SUM--', 1'THE 2ND INPUT ARGUMENT (N) HAS THE VALUE 1') CALL DPWRST('XXX','BUG ') XSUM=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 SUM--', 1'THE FIRST INPUT ARGUMENT (A VECTOR) HAS ALL ELEMENTS = ',E15.7) CALL DPWRST('XXX','BUG ') XSUM=AN*HOLD GOTO9000 139 CONTINUE C 190 CONTINUE C C ************************ C ** STEP 2-- ** C ** COMPUTE THE SUM. ** C ************************ C DSUM=0.0D0 DO200I=1,N DX=X(I) DSUM=DSUM+DX 200 CONTINUE XSUM=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,XSUM 811 FORMAT('THE SUM 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 SUM--') 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)XSUM 9015 FORMAT('XSUM = ',E15.7) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END REAL FUNCTION SUNIF(IR) CCCCC DATAPLOT NOTE (5/2002): CURRENTLY, ONLY USE THE UNIFORM CCCCC RANDOM NUMBER GENERATOR FROM THIS PACKAGE (ACTIVATE BY: CCCCC SET RANDOM NUMBER GENERATOR MULTIPLICATIVE CONGRUENTIAL C C ALGORITHM 599, COLLECTED ALGORITHMS FROM ACM. C ALGORITHM APPEARED IN ACM-TRANS. MATH. SOFTWARE, VOL.9, NO. 2, C JUN., 1983, P. 255-257. C**********************************************************************CSUN 10 C**********************************************************************CSUN 20 C**********************************************************************CSUN 30 C CSUN 40 C CSUN 50 C CSUN 60 C F O R T R A N SOFTWARE PACKAGE FOR RANDOM NUMBER GENERATION CSUN 70 C CSUN 80 C CSUN 90 C CSUN 100 C**********************************************************************CSUN 110 C**********************************************************************CSUN 120 C**********************************************************************CSUN 130 C SUN 140 C SUN 150 C SUN 160 C CONTENTS: SUN 170 C SUN 180 C 1) SUNIF - 0,1 -UNIFORM DISTRIBUTION SUN 190 C SUN 200 C 2) SEXPO - (STANDARD-) EXPONENTIAL DISTRIBUTION SUN 210 C SUN 220 C 3) SNORM - (STANDARD-) NORMAL DISTRIBUTION SUN 230 C SUN 240 C 4) SGAMMA - (STANDARD-) GAMMA DISTRIBUTION SUN 250 C SUN 260 C 5) KPOISS - POISSON DISTRIBUTION SUN 270 C SUN 280 C SUN 290 C THIS PACKAGE CONSTITUTES A FORTRAN-77 DOCUMENTATION OF A SET OF SUN 300 C ASSEMBLER FUNCTIONS FOR SAMPLING FROM THE ABOVE DISTRIBUTIONS. SUN 310 C ALL ROUTINES MAKE AMPLE USE OF BINARY REPRESENTATIONS OF NUMBERS, SUN 320 C THEY ARE AMONG THE MOST ACCURATE AND FAST SAMPLING FUNCTIONS SUN 330 C KNOWN. THE FORTRAN PROGRAMS BELOW YIELD THE SAME RANDOM NUMBER SUN 340 C SEQUENCES AS THE ONES FROM OUR ASSEMBLER PACKAGE, BUT THEY ARE SUN 350 C OF COURSE MUCH SLOWER (BY FACTORS 5-8 ON OUR SIEMENS 7760 SUN 360 C COMPUTER.) SUN 370 C THE SET OF ROUTINES WILL ALSO BE ACCEPTABLE TO FORTRAN IV SUN 380 C COMPILERS WHICH ALLOW DATA STATEMENTS FOR ARRAYS WITHOUT SUN 390 C IMPLICIT DO-LOOPS. SUN 400 C SUN 410 C SUN 420 C REMARKS: SUN 430 C SUN 440 C - NO CARE IS TAKEN TO ENSURE THAT THE PARAMETER VALUES LIE SUN 450 C IN THE ALLOWED RANGE (E.G. A/MU > 0.0 FOR SGAMMA/KPOISS). SUN 460 C SUN 470 C - THE PARAMETER 'IR' MUST BE SET TO SOME 4*K+1 > 0 BEFORE SUN 480 C THE FIRST CALL OF ANY OF THE GENERATORS. THEREAFTER IR SUN 490 C MUST NOT BE ALTERED UNTIL A NEW INITIALIZATION IS DESIRED. SUN 500 C SUN 510 C - THE PACKAGE PROVIDES RANDOM DEVIATES OF 6-7 DIGITS ACCURACY. SUN 520 C ON MORE ACCURATE COMPUTERS THE CONSTANTS IN SEXPO, SNORM, SUN 530 C SGAMMA AND KPOISS OUGHT TO BE ADJUSTED ACCORDING TO LOCAL SUN 540 C COMMENTS OR WITH THE AID OF THE TABLES IN THE LITERATURE SUN 550 C QUOTED AT THE BEGINNING OF EACH FUNCTION. SUN 560 C SUN 570 C SUN 580 C**********************************************************************CSUN 590 C**********************************************************************CSUN 600 C CSUN 610 C CSUN 620 C 0 , 1 - U N I F O R M DISTRIBUTION CSUN 630 C CSUN 640 C CSUN 650 C**********************************************************************CSUN 660 C**********************************************************************CSUN 670 C CSUN 680 C FOR DETAILS SEE: CSUN 690 C CSUN 700 C AHRENS, J.H., DIETER, U. AND GRUBE, A. CSUN 710 C PSEUDO-RANDOM NUMBERS: A NEW PROPOSAL CSUN 720 C FOR THE CHOICE OF MULTIPLICATORS CSUN 730 C COMPUTING, 6 (1970), 121 - 138 CSUN 740 C CSUN 750 C**********************************************************************CSUN 760 C SUN 770 DOUBLE PRECISION R,FACTOR,TWO28 SAVE R C C FACTOR - INTEGER OF THE FORM 8*K+5 AS CLOSE AS POSSIBLE C TO 2**26 * (SQRT(5)-1)/2 (GOLDEN SECTION) C TWO28 = 2**28 (I.E. 28 SIGNIFICANT BITS FOR DEVIATES) C DATA FACTOR /41475557.0D0/, TWO28 /268435456.0D0/ C C RETURNS SAMPLE U FROM THE 0,1 -UNIFORM DISTRIBUTION C BY A MULTIPLICATIVE CONGRUENTIAL GENERATOR OF THE FORM C R := R * FACTOR (MOD 1) . C IN THE FIRST CALL R IS INITIALIZED TO C R := IR / 2**28 , C WHERE IR MUST BE OF THE FORM IR = 4*K+1. C THEN R ASSUMES ALL VALUES 0 < (4*K+1)/2**28 < 1 DURING C A FULL PERIOD 2**26 OF SUNIF. C THE PARAMETER IR IS USED ONLY IN THE FIRST CALL FOR C INITIALIZATION OF SUNIF. THEREAFTER (WHEN NEGATIVE) C IR BECOMES A DUMMY VARIABLE. C IF (IR .GE. 0) GO TO 1 C C STANDARD CASE: SAMPLING C R=DMOD(R*FACTOR,1.0D0) SUNIF=SNGL(R) RETURN C C FIRST CALL: INITIALIZATION C 1 R=DBLE(FLOAT(IR))/TWO28 R=DMOD(R*FACTOR,1.0D0) SUNIF=SNGL(R) IR=-1 RETURN END SUBROUTINE SWILK (INIT, X, N, N1, N2, A, W, PW, IFAULT) C C ALGORITHM AS R94 APPL. STATIST. (1995) VOL.44, NO.4 C C Calculates the Shapiro-Wilk W test and its significance level C INTEGER N, N1, N2, IFAULT REAL X(*), A(*), PW, W REAL C1(6), C2(6), C3(4), C4(4), C5(4), C6(3), C7(2) REAL C8(2), C9(2), G(2) REAL Z90, Z95, Z99, ZM, ZSS, BF1, XX90, XX95, ZERO, ONE, TWO REAL THREE, SQRTH, QTR, TH, SMALL, PI6, STQR REAL SUMM2, SSUMM2, FAC, RSN, AN, AN25, A1, A2, DELTA, RANGE REAL SA, SX, SSX, SSA, SAX, ASA, XSX, SSASSX, W1, Y, XX, XI REAL GAMMA, M, S, LD, BF, Z90F, Z95F, Z99F, ZFM, ZSD, ZBAR C C Auxiliary routines C REAL PPND, POLY DOUBLE PRECISION ALNORM C INTEGER NCENS, NN2, I, I1, J LOGICAL INIT, UPPER C DATA C1 /0.0E0, 0.221157E0, -0.147981E0, -0.207119E1, * 0.4434685E1, -0.2706056E1/ DATA C2 /0.0E0, 0.42981E-1, -0.293762E0, -0.1752461E1, * 0.5682633E1, -0.3582633E1/ DATA C3 /0.5440E0, -0.39978E0, 0.25054E-1, -0.6714E-3/ DATA C4 /0.13822E1, -0.77857E0, 0.62767E-1, -0.20322E-2/ DATA C5 /-0.15861E1, -0.31082E0, -0.83751E-1, 0.38915E-2/ DATA C6 /-0.4803E0, -0.82676E-1, 0.30302E-2/ DATA C7 /0.164E0, 0.533E0/ DATA C8 /0.1736E0, 0.315E0/ DATA C9 /0.256E0, -0.635E-2/ DATA G /-0.2273E1, 0.459E0/ DATA Z90, Z95, Z99 /0.12816E1, 0.16449E1, 0.23263E1/ DATA ZM, ZSS /0.17509E1, 0.56268E0/ DATA BF1 /0.8378E0/, XX90, XX95 /0.556E0, 0.622E0/ DATA ZERO /0.0E0/, ONE/1.0E0/, TWO/2.0E0/, THREE/3.0E0/ DATA SQRTH /0.70711E0/, QTR/0.25E0/, TH/0.375E0/, SMALL/1E-19/ DATA PI6 /0.1909859E1/, STQR/0.1047198E1/, UPPER/.TRUE./ C PW = ONE IF (W .GE. ZERO) W = ONE AN = N IFAULT = 3 NN2 = N/2 IF (N2 .LT. NN2) RETURN IFAULT = 1 IF (N .LT. 3) RETURN C C If INIT is false, calculates coefficients for the test C IF (.NOT. INIT) THEN IF (N .EQ. 3) THEN A(1) = SQRTH ELSE AN25 = AN + QTR SUMM2 = ZERO DO 30 I = 1, N2 A(I) = PPND((REAL(I) - TH)/AN25,IFAULT) SUMM2 = SUMM2 + A(I) ** 2 30 CONTINUE SUMM2 = SUMM2 * TWO SSUMM2 = SQRT(SUMM2) RSN = ONE / SQRT(AN) A1 = POLY(C1, 6, RSN) - A(1) / SSUMM2 C C Normalize coefficients C IF (N .GT. 5) THEN I1 = 3 A2 = -A(2)/SSUMM2 + POLY(C2,6,RSN) FAC = SQRT((SUMM2 - TWO * A(1) ** 2 - TWO * * A(2) ** 2)/(ONE - TWO * A1 ** 2 - TWO * A2 ** 2)) A(1) = A1 A(2) = A2 ELSE I1 = 2 FAC = SQRT((SUMM2 - TWO * A(1) ** 2)/ * (ONE - TWO * A1 ** 2)) A(1) = A1 END IF DO 40 I = I1, NN2 A(I) = -A(I)/FAC 40 CONTINUE END IF INIT = .TRUE. END IF IF (N1 .LT. 3) RETURN NCENS = N - N1 IFAULT = 4 IF (NCENS .LT. 0 .OR. (NCENS .GT. 0 .AND. N .LT. 20)) RETURN IFAULT = 5 DELTA = FLOAT(NCENS)/AN IF (DELTA .GT. 0.8) RETURN C C If W input as negative, calculate significance level of -W C IF (W .LT. ZERO) THEN W1 = ONE + W IFAULT = 0 GOTO 70 END IF C C Check for zero range C IFAULT = 6 RANGE = X(N1) - X(1) IF (RANGE .LT. SMALL) RETURN C C Check for correct sort order on range - scaled X C IFAULT = 7 XX = X(1)/RANGE SX = XX SA = -A(1) J = N - 1 DO 50 I = 2, N1 XI = X(I)/RANGE CCCCC IF (XX-XI .GT. SMALL) PRINT *,' ANYTHING' SX = SX + XI IF (I .NE. J) SA = SA + SIGN(1, I - J) * A(MIN(I, J)) XX = XI J = J - 1 50 CONTINUE IFAULT = 0 IF (N .GT. 5000) IFAULT = 2 C C Calculate W statistic as squared correlation C between data and coefficients C SA = SA/N1 SX = SX/N1 SSA = ZERO SSX = ZERO SAX = ZERO J = N DO 60 I = 1, N1 IF (I .NE. J) THEN ASA = SIGN(1, I - J) * A(MIN(I, J)) - SA ELSE ASA = -SA END IF XSX = X(I)/RANGE - SX SSA = SSA + ASA * ASA SSX = SSX + XSX * XSX SAX = SAX + ASA * XSX J = J - 1 60 CONTINUE C C W1 equals (1-W) claculated to avoid excessive rounding error C for W very near 1 (a potential problem in very large samples) C SSASSX = SQRT(SSA * SSX) W1 = (SSASSX - SAX) * (SSASSX + SAX)/(SSA * SSX) 70 W = ONE - W1 C C Calculate significance level for W (exact for N=3) C IF (N .EQ. 3) THEN PW = PI6 * (ASIN(SQRT(W)) - STQR) RETURN END IF Y = LOG(W1) XX = LOG(AN) M = ZERO S = ONE IF (N .LE. 11) THEN GAMMA = POLY(G, 2, AN) IF (Y .GE. GAMMA) THEN PW = SMALL RETURN END IF Y = -LOG(GAMMA - Y) M = POLY(C3, 4, AN) S = EXP(POLY(C4, 4, AN)) ELSE M = POLY(C5, 4, XX) S = EXP(POLY(C6, 3, XX)) END IF IF (NCENS .GT. 0) THEN C C Censoring by proportion NCENS/N. Calculate mean and sd C of normal equivalent deviate of W. C LD = -LOG(DELTA) BF = ONE + XX * BF1 Z90F = Z90 + BF * POLY(C7, 2, XX90 ** XX) ** LD Z95F = Z95 + BF * POLY(C8, 2, XX95 ** XX) ** LD Z99F = Z99 + BF * POLY(C9, 2, XX) ** LD C C Regress Z90F,...,Z99F on normal deviates Z90,...,Z99 to get C pseudo-mean and pseudo-sd of z as the slope and intercept C ZFM = (Z90F + Z95F + Z99F)/THREE ZSD = (Z90*(Z90F-ZFM)+Z95*(Z95F-ZFM)+Z99*(Z99F-ZFM))/ZSS ZBAR = ZFM - ZSD * ZM M = M + ZBAR * S S = S * ZSD END IF PW = REAL(ALNORM(DBLE((Y - M)/S), UPPER)) C RETURN END SUBROUTINE SYMINV(N, LOWINV, DET) * * Computes lower symmetric inverse and determinant in situ * INTEGER I, II, N DOUBLE PRECISION LOWINV(*), DET CALL CHOLSK(N, LOWINV) DET = 1 II = 0 DO 100 I = 1,N II = II + I DET = DET*LOWINV(II) 100 CONTINUE DET = DET*DET CALL CHOLNV(N, LOWINV) CALL CHOLPI(N, LOWINV) C RETURN END DOUBLE PRECISION FUNCTION SYNCH1(XVALUE) C C DESCRIPTION: C C This function calculates the synchrotron radiation function C defined as C C SYNCH1(x) = x * Integral{x to inf} K(5/3)(t) dt, C C where K(5/3) is a modified Bessel function of order 5/3. C C The code uses Chebyshev expansions, the coefficients of which C are given to 20 decimal places. C C C ERROR RETURNS: C C The function is undefined if x < 0.0. If XVALUE < 0.0, C an error message is printed and the function returns C the value 0.0. C C C MACHINE-DEPENDENT CONSTANTS: C C NTERM1 - INTEGER - The no. of terms needed from the array C ASYNC1. The recommended value is such that C ABS(ASYNC1(NTERM1)) < EPS/100. C C NTERM2 - INTEGER - The no. of terms needed from the array C ASYNC2. The recommended value is such that C ABS(ASYNC2(NTERM2)) < EPS/100. C C NTERM3 - INTEGER - The no. of terms needed from the array C ASYNCA. The recommended value is such that C ABS(ASYNCA(NTERM3)) < EPS/100. C C XLOW - DOUBLE PRECISION - The value below which C SYNCH1(x) = 2.14952.. * (x**(1/3)) C to machine precision. The recommended value C is sqrt (8*EPSNEG) C C XHIGH1 - DOUBLE PRECISION - The value above which C SYNCH1(x) = 0.0 C to machine precision. The recommended value C is -8*LN(XMIN)/7 C C XHIGH2 - DOUBLE PRECISION - The value of LN(XMIN). This is used C to prevent underflow in calculations C for large x. C C For values of EPS, EPSNEG, and XMIN refer to the file MACHCON.TXT C C The machine-dependent constants are computed internally by C using the D1MACH subroutine. C C C INTRINSIC FUNCTIONS USED: C C EXP , 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 Paisley, C SCOTLAND C PA1 2BE C C ( e-mail: macl_ms0@paisley.ac.uk ) C C C LATEST UPDATE: C 23 January, 1996 C C INTEGER NTERM1,NTERM2,NTERM3 DOUBLE PRECISION ASYNC1(0:13),ASYNC2(0:11),ASYNCA(0:24), 1 CHEB1,CHEB2,CHEVAL,CONLOW,EIGHT,FOUR,HALF, 2 LNRTP2,ONE,ONEHUN,PIBRT3,T,THREE,TWELVE,X,XHIGH1, 3 XHIGH2,XLOW,XPOWTH,XVALUE,ZERO CCCCC CHARACTER FNNAME*6,ERRMSG*14 C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOMC.INC' CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C CCCCC DATA FNNAME/'SYNCH1'/ CCCCC DATA ERRMSG/'ARGUMENT < 0.0'/ DATA ZERO,HALF,ONE/ 0.0 D 0 , 0.5 D 0 , 1.0 D 0 / DATA THREE,FOUR/ 3.0 D 0 , 4.0 D 0 / DATA EIGHT,TWELVE/ 8.0 D 0 , 12.0 D 0 / DATA ONEHUN/ 100.0 D 0 / DATA CONLOW/2.14952 82415 34478 63671 D 0/ DATA PIBRT3/1.81379 93642 34217 85059 D 0/ DATA LNRTP2/0.22579 13526 44727 43236 D 0/ DATA ASYNC1/30.36468 29825 01076 27340 D 0, 1 17.07939 52774 08394 57449 D 0, 2 4.56013 21335 45072 88887 D 0, 3 0.54928 12467 30419 97963 D 0, 4 0.37297 60750 69301 1724 D -1, 5 0.16136 24302 01041 242 D -2, 6 0.48191 67721 20370 7 D -4, 7 0.10512 42528 89384 D -5, 8 0.17463 85046 697 D -7, 9 0.22815 48654 4 D -9, X 0.24044 3082 D -11, 1 0.20865 88 D -13, 2 0.15167 D -15, 3 0.94 D -18/ DATA ASYNC2/0.44907 21623 53266 08443 D 0, 1 0.89835 36779 94187 2179 D -1, 2 0.81044 57377 21512 894 D -2, 3 0.42617 16991 08916 19 D -3, 4 0.14760 96312 70746 0 D -4, 5 0.36286 33615 3998 D -6, 6 0.66634 80749 84 D -8, 7 0.94907 71655 D -10, 8 0.10791 2491 D -11, 9 0.10022 01 D -13, X 0.7745 D -16, 1 0.51 D -18/ DATA ASYNCA(0)/ 2.13293 05161 35500 09848 D 0/ DATA ASYNCA(1)/ 0.74135 28649 54200 2401 D -1/ DATA ASYNCA(2)/ 0.86968 09990 99641 978 D -2/ DATA ASYNCA(3)/ 0.11703 82624 87756 921 D -2/ DATA ASYNCA(4)/ 0.16451 05798 61919 15 D -3/ DATA ASYNCA(5)/ 0.24020 10214 20640 3 D -4/ DATA ASYNCA(6)/ 0.35827 75638 93885 D -5/ DATA ASYNCA(7)/ 0.54477 47626 9837 D -6/ DATA ASYNCA(8)/ 0.83880 28561 957 D -7/ DATA ASYNCA(9)/ 0.13069 88268 416 D -7/ DATA ASYNCA(10)/0.20530 99071 44 D -8/ DATA ASYNCA(11)/0.32518 75368 8 D -9/ DATA ASYNCA(12)/0.51791 40412 D -10/ DATA ASYNCA(13)/0.83002 9881 D -11/ DATA ASYNCA(14)/0.13352 7277 D -11/ DATA ASYNCA(15)/0.21591 498 D -12/ DATA ASYNCA(16)/0.34996 73 D -13/ DATA ASYNCA(17)/0.56994 2 D -14/ DATA ASYNCA(18)/0.92906 D -15/ DATA ASYNCA(19)/0.15222 D -15/ DATA ASYNCA(20)/0.2491 D -16/ DATA ASYNCA(21)/0.411 D -17/ DATA ASYNCA(22)/0.67 D -18/ DATA ASYNCA(23)/0.11 D -18/ DATA ASYNCA(24)/0.2 D -19/ C C Start calculation C X = XVALUE 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 ') SYNCH1 = ZERO RETURN ENDIF 999 FORMAT(1X) 101 FORMAT('***** ERROR FROM SYNCH1--ARGUMENT MUST BE ', 1 'NON-NEGATIVE, ARGUMENT = ',G15.7) C C Compute the machine-dependent constants. C CHEB1 = D1MACH(3) T = CHEB1 / ONEHUN IF ( X .LE. FOUR ) THEN DO 10 NTERM1 = 13 , 0 , -1 IF ( ABS(ASYNC1(NTERM1)) .GT. T ) GOTO 19 10 CONTINUE 19 DO 20 NTERM2 = 11 , 0 , -1 IF ( ABS(ASYNC2(NTERM2)) .GT. T ) GOTO 29 20 CONTINUE 29 XLOW = SQRT ( EIGHT * CHEB1 ) ELSE DO 40 NTERM3 = 24 , 0 , -1 IF ( ABS(ASYNCA(NTERM3)) .GT. T ) GOTO 49 40 CONTINUE 49 XHIGH2 = LOG(D1MACH(1)) XHIGH1 = -EIGHT * XHIGH2 / ( EIGHT - ONE ) ENDIF C C Code for 0 <= x <= 4 C IF ( X .LE. FOUR ) THEN XPOWTH = X ** ( ONE / THREE ) IF ( X .LT. XLOW ) THEN SYNCH1 = CONLOW * XPOWTH ELSE T = ( X * X / EIGHT - HALF ) - HALF CHEB1 = CHEVAL(NTERM1,ASYNC1,T) CHEB2 = CHEVAL(NTERM2,ASYNC2,T) T = XPOWTH * CHEB1 - ( XPOWTH**11 ) * CHEB2 SYNCH1 = T - PIBRT3 * X ENDIF ELSE IF ( X .GT. XHIGH1 ) THEN SYNCH1 = ZERO ELSE T = ( TWELVE - X ) / ( X + FOUR ) CHEB1 = CHEVAL(NTERM3,ASYNCA,T) T = LNRTP2 - X + LOG( SQRT(X) * CHEB1 ) IF ( T .LT. XHIGH2 ) THEN SYNCH1 = ZERO ELSE SYNCH1 = EXP(T) ENDIF ENDIF ENDIF RETURN END DOUBLE PRECISION FUNCTION SYNCH2(XVALUE) C C DESCRIPTION: C C This function calculates the synchrotron radiation function C defined as C C SYNCH2(x) = x * K(2/3)(x) C C where K(2/3) is a modified Bessel function of order 2/3. C C The code uses Chebyshev expansions, the coefficients of which C are given to 20 decimal places. C C C ERROR RETURNS: C C The function is undefined if x < 0.0. If XVALUE < 0.0, C an error message is printed and the function returns C the value 0.0. C C C MACHINE-DEPENDENT CONSTANTS: C C NTERM1 - INTEGER - The no. of terms needed from the array C ASYNC1. The recommended value is such that C ABS(ASYN21(NTERM1)) < EPS/100. C C NTERM2 - INTEGER - The no. of terms needed from the array C ASYNC2. The recommended value is such that C ABS(ASYN22(NTERM2)) < EPS/100. C C NTERM3 - INTEGER - The no. of terms needed from the array C ASYNCA. The recommended value is such that C ABS(ASYN2A(NTERM3)) < EPS/100. C C XLOW - DOUBLE PRECISION - The value below which C SYNCH2(x) = 1.074764... * (x**(1/3)) C to machine precision. The recommended value C is sqrt (8*EPSNEG) C C XHIGH1 - DOUBLE PRECISION - The value above which C SYNCH2(x) = 0.0 C to machine precision. The recommended value C is -8*LN(XMIN)/7 C C XHIGH2 - DOUBLE PRECISION - The value of LN(XMIN). This is used C to prevent underflow in calculations C for large x. C C For values of EPS, EPSNEG, and XMIN refer to the file MACHCON.TXT C C The machine-dependent constants are computed internally by C using the D1MACH subroutine. C C C INTRINSIC FUNCTIONS USED: C C EXP , 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 Paisley, C SCOTLAND C PA1 2BE C C (e-mail: macl_ms0@paisley.ac.uk) C C C LATEST UPDATE: C 23 January, 1996 C INTEGER NTERM1,NTERM2,NTERM3 DOUBLE PRECISION ASYN21(0:14),ASYN22(0:13),ASYN2A(0:18), 1 CHEB1,CHEB2,CHEVAL,CONLOW,EIGHT,FOUR,HALF, 2 LNRTP2,ONE,ONEHUN,T,TEN,THREE,TWO,X,XHIGH1, 3 XHIGH2,XLOW,XPOWTH,XVALUE,ZERO CCCCC CHARACTER FNNAME*6,ERRMSG*14 C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOMC.INC' CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C CCCCC DATA FNNAME/'SYNCH2'/ CCCCC DATA ERRMSG/'ARGUMENT < 0.0'/ DATA ZERO,HALF,ONE/ 0.0 D 0 , 0.5 D 0 , 1.0 D 0 / DATA TWO,THREE,FOUR/ 2.0 D 0 , 3.0 D 0 , 4.0 D 0 / DATA EIGHT,TEN,ONEHUN/ 8.0 D 0 , 10.0 D 0 , 100.0 D 0/ DATA CONLOW/1.07476 41207 67239 31836 D 0/ DATA LNRTP2/0.22579 13526 44727 43236 D 0/ DATA ASYN21/38.61783 99238 43085 48014 D 0, 1 23.03771 55949 63734 59697 D 0, 2 5.38024 99868 33570 59676 D 0, 3 0.61567 93806 99571 07760 D 0, 4 0.40668 80046 68895 5843 D -1, 5 0.17296 27455 26484 141 D -2, 6 0.51061 25883 65769 9 D -4, 7 0.11045 95950 22012 D -5, 8 0.18235 53020 649 D -7, 9 0.23707 69803 4 D -9, X 0.24887 2963 D -11, 1 0.21528 68 D -13, 2 0.15607 D -15, 3 0.96 D -18, 4 0.1 D -19/ DATA ASYN22/7.90631 48270 66080 42875 D 0, 1 3.13534 63612 85342 56841 D 0, 2 0.48548 79477 45371 45380 D 0, 3 0.39481 66758 27237 2337 D -1, 4 0.19661 62233 48088 022 D -2, 5 0.65907 89322 93042 0 D -4, 6 0.15857 56134 98559 D -5, 7 0.28686 53011 233 D -7, 8 0.40412 02359 5 D -9, 9 0.45568 4443 D -11, X 0.42045 90 D -13, 1 0.32326 D -15, 2 0.210 D -17, 3 0.1 D -19/ DATA ASYN2A/2.02033 70941 70713 60032 D 0, 1 0.10956 23712 18074 0443 D -1, 2 0.85423 84730 11467 55 D -3, 3 0.72343 02421 32822 2 D -4, 4 0.63124 42796 26992 D -5, 5 0.56481 93141 1744 D -6, 6 0.51283 24801 375 D -7, 7 0.47196 53291 45 D -8, 8 0.43807 44214 3 D -9, 9 0.41026 81493 D -10, X 0.38623 0721 D -11, 1 0.36613 228 D -12, 2 0.34802 32 D -13, 3 0.33301 0 D -14, 4 0.31856 D -15, 5 0.3074 D -16, 6 0.295 D -17, 7 0.29 D -18, 8 0.3 D -19/ C C Start calculation C X = XVALUE 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 ') SYNCH2 = ZERO RETURN ENDIF 999 FORMAT(1X) 101 FORMAT('***** ERROR FROM SYNCH2--ARGUMENT MUST BE ', 1 'NON-NEGATIVE, ARGUMENT = ',G15.7) C C Compute the machine-dependent constants. C CHEB1 = D1MACH(3) T = CHEB1 / ONEHUN IF ( X .LE. FOUR ) THEN DO 10 NTERM1 = 14 , 0 , -1 IF ( ABS(ASYN21(NTERM1)) .GT. T ) GOTO 19 10 CONTINUE 19 DO 20 NTERM2 = 13 , 0 , -1 IF ( ABS(ASYN22(NTERM2)) .GT. T ) GOTO 29 20 CONTINUE 29 XLOW = SQRT ( EIGHT * CHEB1 ) ELSE DO 40 NTERM3 = 18 , 0 , -1 IF ( ABS(ASYN2A(NTERM3)) .GT. T ) GOTO 49 40 CONTINUE 49 XHIGH2 = LOG(D1MACH(1)) XHIGH1 = -EIGHT * XHIGH2 / ( EIGHT - ONE ) ENDIF C C Code for 0 <= x <= 4 C IF ( X .LE. FOUR ) THEN XPOWTH = X ** ( ONE / THREE ) IF ( X .LT. XLOW ) THEN SYNCH2 = CONLOW * XPOWTH ELSE T = ( X * X / EIGHT - HALF ) - HALF CHEB1 = CHEVAL(NTERM1,ASYN21,T) CHEB2 = CHEVAL(NTERM2,ASYN22,T) SYNCH2 = XPOWTH * CHEB1 - ( XPOWTH**5 ) * CHEB2 ENDIF ELSE IF ( X .GT. XHIGH1 ) THEN SYNCH2 = ZERO ELSE T = ( TEN - X ) / ( X + TWO ) CHEB1 = CHEVAL(NTERM3,ASYN2A,T) T = LNRTP2 - X + LOG( SQRT(X) * CHEB1 ) IF ( T .LT. XHIGH2 ) THEN SYNCH2 = ZERO ELSE SYNCH2 = EXP(T) ENDIF ENDIF ENDIF RETURN END