00001 * 00002 * $Id: mvt.f 3864 2008-02-10 16:43:04Z hothorn $ 00003 * 00004 SUBROUTINE MVTDST( N, NU, LOWER, UPPER, INFIN, CORREL, DELTA, 00005 & MAXPTS, ABSEPS, RELEPS, ERROR, VALUE, INFORM ) 00006 * 00007 * A subroutine for computing non-central multivariate t probabilities. 00008 * This subroutine uses an algorithm (QRSVN) described in the paper 00009 * 00010 "Comparison of Methods for the Computation of Multivariate * t-Probabilities", by Alan Genz and Frank Bretz 00011 * J. Comp. Graph. Stat. 11 (2002), pp. 950-971. 00012 * 00013 * Alan Genz 00014 * Department of Mathematics 00015 * Washington State University 00016 * Pullman, WA 99164-3113 00017 * Email : AlanGenz@wsu.edu 00018 * 00019 * Original source available from 00020 * http://www.math.wsu.edu/faculty/genz/software/fort77/mvtdstpack.f 00021 * 00022 * This is version 7/7 with better support for 100 < dimension < 1000 00023 * 00024 * Parameters 00025 * 00026 * N INTEGER, the number of variables. 00027 * NU INTEGER, the number of degrees of freedom. 00028 * If NU < 1, then an MVN probability is computed. 00029 * LOWER DOUBLE PRECISION, array of lower integration limits. 00030 * UPPER DOUBLE PRECISION, array of upper integration limits. 00031 * INFIN INTEGER, array of integration limits flags: 00032 * if INFIN(I) < 0, Ith limits are (-infinity, infinity); 00033 * if INFIN(I) = 0, Ith limits are (-infinity, UPPER(I)]; 00034 * if INFIN(I) = 1, Ith limits are [LOWER(I), infinity); 00035 * if INFIN(I) = 2, Ith limits are [LOWER(I), UPPER(I)]. 00036 * CORREL DOUBLE PRECISION, array of correlation coefficients; 00037 * the correlation coefficient in row I column J of the 00038 * correlation matrixshould be stored in 00039 * CORREL( J + ((I-2)*(I-1))/2 ), for J < I. 00040 * The correlation matrix must be positive semi-definite. 00041 * DELTA DOUBLE PRECISION, array of non-centrality parameters. 00042 * MAXPTS INTEGER, maximum number of function values allowed. This 00043 * parameter can be used to limit the time. A sensible 00044 * strategy is to start with MAXPTS = 1000*N, and then 00045 * increase MAXPTS if ERROR is too large. 00046 * ABSEPS DOUBLE PRECISION absolute error tolerance. 00047 * RELEPS DOUBLE PRECISION relative error tolerance. 00048 * ERROR DOUBLE PRECISION estimated absolute error, 00049 * with 99% confidence level. 00050 * VALUE DOUBLE PRECISION estimated value for the integral 00051 * INFORM INTEGER, termination status parameter: 00052 * if INFORM = 0, normal completion with ERROR < EPS; 00053 * if INFORM = 1, completion with ERROR > EPS and MAXPTS 00054 * function vaules used; increase MAXPTS to 00055 * decrease ERROR; 00056 * if INFORM = 2, N > 1000 or N < 1. 00057 * if INFORM = 3, correlation matrix not positive semi-definite. 00058 * 00059 EXTERNAL MVSUBR 00060 INTEGER N, ND, NU, INFIN(*), MAXPTS, INFORM, IVLS 00061 DOUBLE PRECISION CORREL(*), LOWER(*), UPPER(*), DELTA(*), RELEPS, 00062 & ABSEPS, ERROR, VALUE, E(1), V(1) 00063 COMMON /PTBLCK/IVLS 00064 IVLS = 0 00065 IF ( N .GT. 1000 .OR. N .LT. 1 ) THEN 00066 VALUE = 0 00067 ERROR = 1 00068 INFORM = 2 00069 ELSE 00070 CALL MVINTS( N, NU, CORREL, LOWER, UPPER, DELTA, INFIN, 00071 & ND, VALUE, ERROR, INFORM ) 00072 IF ( INFORM .EQ. 0 .AND. ND .GT. 0 ) THEN 00073 * 00074 * Call the lattice rule integration subroutine 00075 * 00076 CALL MVKBRV( ND, IVLS, MAXPTS, 1, MVSUBR, ABSEPS, RELEPS, 00077 & E, V, INFORM ) 00078 ERROR = E(1) 00079 VALUE = V(1) 00080 ENDIF 00081 ENDIF 00082 END 00083 * 00084 SUBROUTINE MVSUBR( N, W, NF, F ) 00085 * 00086 * Integrand subroutine 00087 * 00088 INTEGER N, NF, NUIN, INFIN(*), NL 00089 DOUBLE PRECISION W(*),F(*), LOWER(*),UPPER(*), CORREL(*), DELTA(*) 00090 PARAMETER ( NL = 1000 ) 00091 INTEGER INFI(NL), NU, ND, INFORM, NY 00092 DOUBLE PRECISION COV(NL*(NL+1)/2), A(NL), B(NL), DL(NL), Y(NL) 00093 DOUBLE PRECISION MVCHNV, SNU, R, VL, ER, DI, EI 00094 SAVE NU, SNU, INFI, A, B, DL, COV 00095 IF ( NU .LE. 0 ) THEN 00096 R = 1 00097 CALL MVVLSB( N+1, W, R, DL,INFI,A,B,COV, Y, DI,EI, NY, F(1) ) 00098 ELSE 00099 R = MVCHNV( NU, W(N) )/SNU 00100 CALL MVVLSB( N , W, R, DL,INFI,A,B,COV, Y, DI,EI, NY, F(1) ) 00101 END IF 00102 RETURN 00103 * 00104 * Entry point for intialization. 00105 * 00106 ENTRY MVINTS( N, NUIN, CORREL, LOWER, UPPER, DELTA, INFIN, 00107 & ND, VL, ER, INFORM ) 00108 * 00109 * Initialization and computation of covariance Cholesky factor. 00110 * 00111 CALL MVSORT( N, LOWER, UPPER, DELTA, CORREL, INFIN, Y, .TRUE., 00112 & ND, A, B, DL, COV, INFI, INFORM ) 00113 NU = NUIN 00114 CALL MVSPCL( ND, NU, A, B, DL, COV, INFI, SNU, VL, ER, INFORM ) 00115 END 00116 * 00117 SUBROUTINE MVSPCL( ND, NU, A,B,DL, COV, INFI, SNU, VL,ER, INFORM ) 00118 * 00119 * Special cases subroutine 00120 * 00121 DOUBLE PRECISION COV(*), A(*), B(*), DL(*), SNU, R, VL, ER 00122 INTEGER ND, NU, INFI(*), INFORM 00123 DOUBLE PRECISION MVBVT, MVSTDT 00124 IF ( INFORM .GT. 0 ) THEN 00125 VL = 0 00126 ER = 1 00127 ELSE 00128 * 00129 * Special cases 00130 * 00131 IF ( ND .EQ. 0 ) THEN 00132 ER = 0 00133 ELSE IF ( ND.EQ.1 .AND. ( NU.LT.1 .OR. ABS(DL(1)).EQ.0 ) ) THEN 00134 * 00135 * 1-d case for normal or central t 00136 * 00137 VL = 1 00138 IF ( INFI(1) .NE. 1 ) VL = MVSTDT( NU, B(1) - DL(1) ) 00139 IF ( INFI(1) .NE. 0 ) VL = VL - MVSTDT( NU, A(1) - DL(1) ) 00140 IF ( VL .LT. 0 ) VL = 0 00141 ER = 2D-16 00142 ND = 0 00143 ELSE IF ( ND .EQ. 2 .AND. 00144 & ( NU .LT. 1 .OR. ABS(DL(1))+ABS(DL(2)) .EQ. 0 ) ) THEN 00145 * 00146 * 2-d case for normal or central t 00147 * 00148 IF ( INFI(1) .NE. 0 ) A(1) = A(1) - DL(1) 00149 IF ( INFI(1) .NE. 1 ) B(1) = B(1) - DL(1) 00150 IF ( INFI(2) .NE. 0 ) A(2) = A(2) - DL(2) 00151 IF ( INFI(2) .NE. 1 ) B(2) = B(2) - DL(2) 00152 IF ( ABS( COV(3) ) .GT. 0 ) THEN 00153 * 00154 * 2-d nonsingular case 00155 * 00156 R = SQRT( 1 + COV(2)**2 ) 00157 IF ( INFI(2) .NE. 0 ) A(2) = A(2)/R 00158 IF ( INFI(2) .NE. 1 ) B(2) = B(2)/R 00159 COV(2) = COV(2)/R 00160 VL = MVBVT( NU, A, B, INFI, COV(2) ) 00161 ER = 1D-15 00162 ELSE 00163 * 00164 * 2-d singular case 00165 * 00166 IF ( INFI(1) .NE. 0 ) THEN 00167 IF ( INFI(2) .NE. 0 ) A(1) = MAX( A(1), A(2) ) 00168 ELSE 00169 IF ( INFI(2) .NE. 0 ) A(1) = A(2) 00170 END IF 00171 IF ( INFI(1) .NE. 1 ) THEN 00172 IF ( INFI(2) .NE. 1 ) B(1) = MIN( B(1), B(2) ) 00173 ELSE 00174 IF ( INFI(2) .NE. 1 ) B(1) = B(2) 00175 END IF 00176 IF ( INFI(1) .NE. INFI(2) ) INFI(1) = 2 00177 VL = 1 00178 IF ( INFI(1) .NE. 1 ) VL = MVSTDT( NU, B(1)-DL(1) ) 00179 IF ( INFI(1) .NE. 0 ) VL = VL - MVSTDT( NU, A(1)-DL(1) ) 00180 IF ( VL .LT. 0 ) VL = 0 00181 ER = 2D-16 00182 END IF 00183 ND = 0 00184 ELSE 00185 IF ( NU .GT. 0 ) THEN 00186 SNU = SQRT( DBLE(NU) ) 00187 ELSE 00188 ND = ND - 1 00189 END IF 00190 END IF 00191 END IF 00192 END 00193 * 00194 SUBROUTINE MVVLSB( N,W,R,DL,INFI, A,B,COV, Y, DI,EI, ND, VALUE ) 00195 * 00196 * Integrand subroutine 00197 * 00198 INTEGER N, INFI(*), ND 00199 DOUBLE PRECISION W(*), R, DL(*), A(*), B(*), COV(*), Y(*) 00200 INTEGER I, J, IJ, INFA, INFB 00201 DOUBLE PRECISION SUM, AI, BI, DI, EI, MVPHNV, VALUE 00202 VALUE = 1 00203 INFA = 0 00204 INFB = 0 00205 ND = 0 00206 IJ = 0 00207 DO I = 1, N 00208 SUM = DL(I) 00209 DO J = 1, I-1 00210 IJ = IJ + 1 00211 IF ( J .LE. ND ) SUM = SUM + COV(IJ)*Y(J) 00212 END DO 00213 IF ( INFI(I) .NE. 0 ) THEN 00214 IF ( INFA .EQ. 1 ) THEN 00215 AI = MAX( AI, R*A(I) - SUM ) 00216 ELSE 00217 AI = R*A(I) - SUM 00218 INFA = 1 00219 END IF 00220 END IF 00221 IF ( INFI(I) .NE. 1 ) THEN 00222 IF ( INFB .EQ. 1 ) THEN 00223 BI = MIN( BI, R*B(I) - SUM ) 00224 ELSE 00225 BI = R*B(I) - SUM 00226 INFB = 1 00227 END IF 00228 END IF 00229 IJ = IJ + 1 00230 IF ( I .EQ. N .OR. COV(IJ+ND+2) .GT. 0 ) THEN 00231 CALL MVLIMS( AI, BI, INFA + INFA + INFB - 1, DI, EI ) 00232 IF ( DI .GE. EI ) THEN 00233 VALUE = 0 00234 RETURN 00235 ELSE 00236 VALUE = VALUE*( EI - DI ) 00237 ND = ND + 1 00238 IF ( I .LT. N ) Y(ND) = MVPHNV( DI + W(ND)*( EI - DI ) ) 00239 INFA = 0 00240 INFB = 0 00241 END IF 00242 END IF 00243 END DO 00244 END 00245 * 00246 SUBROUTINE MVSORT( N, LOWER, UPPER, DELTA, CORREL, INFIN, Y,PIVOT, 00247 & ND, A, B, DL, COV, INFI, INFORM ) 00248 * 00249 * Subroutine to sort integration limits and determine Cholesky factor. 00250 * 00251 INTEGER N, ND, INFIN(*), INFI(*), INFORM 00252 LOGICAL PIVOT 00253 DOUBLE PRECISION A(*), B(*), DL(*), COV(*), 00254 & LOWER(*), UPPER(*), DELTA(*), CORREL(*), Y(*) 00255 INTEGER I, J, K, L, M, II, IJ, IL, JL, JMIN 00256 DOUBLE PRECISION SUMSQ, AJ, BJ, SUM, EPS, EPSI, D, E 00257 DOUBLE PRECISION CVDIAG, AMIN, BMIN, DEMIN, MVTDNS 00258 PARAMETER ( EPS = 1D-6 ) 00259 INFORM = 0 00260 IJ = 0 00261 II = 0 00262 ND = N 00263 DO I = 1, N 00264 A(I) = 0 00265 B(I) = 0 00266 DL(I) = 0 00267 INFI(I) = INFIN(I) 00268 IF ( INFI(I) .LT. 0 ) THEN 00269 ND = ND - 1 00270 ELSE 00271 IF ( INFI(I) .NE. 0 ) A(I) = LOWER(I) 00272 IF ( INFI(I) .NE. 1 ) B(I) = UPPER(I) 00273 DL(I) = DELTA(I) 00274 ENDIF 00275 DO J = 1, I-1 00276 IJ = IJ + 1 00277 II = II + 1 00278 COV(IJ) = CORREL(II) 00279 END DO 00280 IJ = IJ + 1 00281 COV(IJ) = 1 00282 END DO 00283 * 00284 * First move any doubly infinite limits to innermost positions. 00285 * 00286 IF ( ND .GT. 0 ) THEN 00287 DO I = N, ND + 1, -1 00288 IF ( INFI(I) .GE. 0 ) THEN 00289 DO J = 1, I-1 00290 IF ( INFI(J) .LT. 0 ) THEN 00291 CALL MVSWAP( J, I, A, B, DL, INFI, N, COV ) 00292 GO TO 10 00293 ENDIF 00294 END DO 00295 ENDIF 00296 END DO 00297 10 CONTINUE 00298 * 00299 * Sort remaining limits and determine Cholesky factor. 00300 * 00301 II = 0 00302 JL = ND 00303 DO I = 1, ND 00304 * 00305 * Determine the integration limits for variable with minimum 00306 * expected probability and interchange that variable with Ith. 00307 * 00308 DEMIN = 1 00309 JMIN = I 00310 CVDIAG = 0 00311 IJ = II 00312 EPSI = EPS*I*I 00313 IF ( .NOT. PIVOT ) JL = I 00314 DO J = I, JL 00315 IF ( COV(IJ+J) .GT. EPSI ) THEN 00316 SUMSQ = SQRT( COV(IJ+J) ) 00317 SUM = DL(J) 00318 DO K = 1, I-1 00319 SUM = SUM + COV(IJ+K)*Y(K) 00320 END DO 00321 AJ = ( A(J) - SUM )/SUMSQ 00322 BJ = ( B(J) - SUM )/SUMSQ 00323 CALL MVLIMS( AJ, BJ, INFI(J), D, E ) 00324 IF ( DEMIN .GE. E - D ) THEN 00325 JMIN = J 00326 AMIN = AJ 00327 BMIN = BJ 00328 DEMIN = E - D 00329 CVDIAG = SUMSQ 00330 ENDIF 00331 ENDIF 00332 IJ = IJ + J 00333 END DO 00334 IF ( JMIN .GT. I ) THEN 00335 CALL MVSWAP( I, JMIN, A, B, DL, INFI, N, COV ) 00336 END IF 00337 IF ( COV(II+I) .LT. -EPSI ) THEN 00338 INFORM = 3 00339 END IF 00340 COV(II+I) = CVDIAG 00341 * 00342 * Compute Ith column of Cholesky factor. 00343 * Compute expected value for Ith integration variable and 00344 * scale Ith covariance matrix row and limits. 00345 * 00346 IF ( CVDIAG .GT. 0 ) THEN 00347 IL = II + I 00348 DO L = I+1, ND 00349 COV(IL+I) = COV(IL+I)/CVDIAG 00350 IJ = II + I 00351 DO J = I+1, L 00352 COV(IL+J) = COV(IL+J) - COV(IL+I)*COV(IJ+I) 00353 IJ = IJ + J 00354 END DO 00355 IL = IL + L 00356 END DO 00357 * 00358 * Expected Y = -( density(b) - density(a) )/( b - a ) 00359 * 00360 IF ( DEMIN .GT. EPSI ) THEN 00361 Y(I) = 0 00362 IF ( INFI(I) .NE. 0 ) Y(I) = MVTDNS( 0, AMIN ) 00363 IF ( INFI(I) .NE. 1 ) Y(I) = Y(I) - MVTDNS( 0, BMIN ) 00364 Y(I) = Y(I)/DEMIN 00365 ELSE 00366 IF ( INFI(I) .EQ. 0 ) Y(I) = BMIN 00367 IF ( INFI(I) .EQ. 1 ) Y(I) = AMIN 00368 IF ( INFI(I) .EQ. 2 ) Y(I) = ( AMIN + BMIN )/2 00369 END IF 00370 DO J = 1, I 00371 II = II + 1 00372 COV(II) = COV(II)/CVDIAG 00373 END DO 00374 A(I) = A(I)/CVDIAG 00375 B(I) = B(I)/CVDIAG 00376 DL(I) = DL(I)/CVDIAG 00377 ELSE 00378 IL = II + I 00379 DO L = I+1, ND 00380 COV(IL+I) = 0 00381 IL = IL + L 00382 END DO 00383 * 00384 * If the covariance matrix diagonal entry is zero, 00385 * permute limits and rows, if necessary. 00386 * 00387 * 00388 DO J = I-1, 1, -1 00389 IF ( ABS( COV(II+J) ) .GT. EPSI ) THEN 00390 A(I) = A(I)/COV(II+J) 00391 B(I) = B(I)/COV(II+J) 00392 DL(I) = DL(I)/COV(II+J) 00393 IF ( COV(II+J) .LT. 0 ) THEN 00394 CALL MVSSWP( A(I), B(I) ) 00395 IF ( INFI(I) .NE. 2 ) INFI(I) = 1 - INFI(I) 00396 END IF 00397 DO L = 1, J 00398 COV(II+L) = COV(II+L)/COV(II+J) 00399 END DO 00400 DO L = J+1, I-1 00401 IF( COV((L-1)*L/2+J+1) .GT. 0 ) THEN 00402 IJ = II 00403 DO K = I-1, L, -1 00404 DO M = 1, K 00405 CALL MVSSWP( COV(IJ-K+M), COV(IJ+M) ) 00406 END DO 00407 CALL MVSSWP( A(K), A(K+1) ) 00408 CALL MVSSWP( B(K), B(K+1) ) 00409 CALL MVSSWP( DL(K), DL(K+1) ) 00410 M = INFI(K) 00411 INFI(K) = INFI(K+1) 00412 INFI(K+1) = M 00413 IJ = IJ - K 00414 END DO 00415 GO TO 20 00416 END IF 00417 END DO 00418 GO TO 20 00419 END IF 00420 COV(II+J) = 0 00421 END DO 00422 20 II = II + I 00423 Y(I) = 0 00424 END IF 00425 END DO 00426 ENDIF 00427 END 00428 * 00429 DOUBLE PRECISION FUNCTION MVTDNS( NU, X ) 00430 INTEGER NU, I 00431 DOUBLE PRECISION X, PROD, PI, SQTWPI 00432 PARAMETER ( PI = 3.141592653589793D0 ) 00433 PARAMETER ( SQTWPI = 2.506628274631001D0 ) 00434 MVTDNS = 0 00435 IF ( NU .GT. 0 ) THEN 00436 PROD = 1/SQRT( DBLE(NU) ) 00437 DO I = NU - 2, 1, -2 00438 PROD = PROD*( I + 1 )/I 00439 END DO 00440 IF ( MOD( NU, 2 ) .EQ. 0 ) THEN 00441 PROD = PROD/2 00442 ELSE 00443 PROD = PROD/PI 00444 END IF 00445 MVTDNS = PROD/SQRT( 1 + X*X/NU )**( NU + 1 ) 00446 ELSE 00447 IF ( ABS(X) .LT. 10 ) MVTDNS = EXP( -X*X/2 )/SQTWPI 00448 END IF 00449 END 00450 * 00451 SUBROUTINE MVLIMS( A, B, INFIN, LOWER, UPPER ) 00452 DOUBLE PRECISION A, B, LOWER, UPPER, MVPHI 00453 INTEGER INFIN 00454 LOWER = 0 00455 UPPER = 1 00456 IF ( INFIN .GE. 0 ) THEN 00457 IF ( INFIN .NE. 0 ) LOWER = MVPHI(A) 00458 IF ( INFIN .NE. 1 ) UPPER = MVPHI(B) 00459 ENDIF 00460 UPPER = MAX( UPPER, LOWER ) 00461 END 00462 * 00463 SUBROUTINE MVSSWP( X, Y ) 00464 DOUBLE PRECISION X, Y, T 00465 T = X 00466 X = Y 00467 Y = T 00468 END 00469 * 00470 SUBROUTINE MVSWAP( P, Q, A, B, D, INFIN, N, C ) 00471 * 00472 * Swaps rows and columns P and Q in situ, with P <= Q. 00473 * 00474 DOUBLE PRECISION A(*), B(*), C(*), D(*) 00475 INTEGER INFIN(*), P, Q, N, I, J, II, JJ 00476 CALL MVSSWP( A(P), A(Q) ) 00477 CALL MVSSWP( B(P), B(Q) ) 00478 CALL MVSSWP( D(P), D(Q) ) 00479 J = INFIN(P) 00480 INFIN(P) = INFIN(Q) 00481 INFIN(Q) = J 00482 JJ = ( P*( P - 1 ) )/2 00483 II = ( Q*( Q - 1 ) )/2 00484 CALL MVSSWP( C(JJ+P), C(II+Q) ) 00485 DO J = 1, P-1 00486 CALL MVSSWP( C(JJ+J), C(II+J) ) 00487 END DO 00488 JJ = JJ + P 00489 DO I = P+1, Q-1 00490 CALL MVSSWP( C(JJ+P), C(II+I) ) 00491 JJ = JJ + I 00492 END DO 00493 II = II + Q 00494 DO I = Q+1, N 00495 CALL MVSSWP( C(II+P), C(II+Q) ) 00496 II = II + I 00497 END DO 00498 END 00499 * 00500 DOUBLE PRECISION FUNCTION MVPHI(Z) 00501 * 00502 * Normal distribution probabilities accurate to 1d-15. 00503 * Reference: J.L. Schonfelder, Math Comp 32(1978), pp 1232-1240. 00504 * 00505 INTEGER I, IM 00506 DOUBLE PRECISION A(0:43), BM, B, BP, P, RTWO, T, XA, Z 00507 PARAMETER( RTWO = 1.414213562373095048801688724209D0, IM = 24 ) 00508 SAVE A 00509 DATA ( A(I), I = 0, 43 )/ 00510 & 6.10143081923200417926465815756D-1, 00511 & -4.34841272712577471828182820888D-1, 00512 & 1.76351193643605501125840298123D-1, 00513 & -6.0710795609249414860051215825D-2, 00514 & 1.7712068995694114486147141191D-2, 00515 & -4.321119385567293818599864968D-3, 00516 & 8.54216676887098678819832055D-4, 00517 & -1.27155090609162742628893940D-4, 00518 & 1.1248167243671189468847072D-5, 3.13063885421820972630152D-7, 00519 & -2.70988068537762022009086D-7, 3.0737622701407688440959D-8, 00520 & 2.515620384817622937314D-9, -1.028929921320319127590D-9, 00521 & 2.9944052119949939363D-11, 2.6051789687266936290D-11, 00522 & -2.634839924171969386D-12, -6.43404509890636443D-13, 00523 & 1.12457401801663447D-13, 1.7281533389986098D-14, 00524 & -4.264101694942375D-15, -5.45371977880191D-16, 00525 & 1.58697607761671D-16, 2.0899837844334D-17, 00526 & -5.900526869409D-18, -9.41893387554D-19, 2.14977356470D-19, 00527 & 4.6660985008D-20, -7.243011862D-21, -2.387966824D-21, 00528 & 1.91177535D-22, 1.20482568D-22, -6.72377D-25, -5.747997D-24, 00529 & -4.28493D-25, 2.44856D-25, 4.3793D-26, -8.151D-27, -3.089D-27, 00530 & 9.3D-29, 1.74D-28, 1.6D-29, -8.0D-30, -2.0D-30 / 00531 * 00532 XA = ABS(Z)/RTWO 00533 IF ( XA .GT. 100 ) THEN 00534 P = 0 00535 ELSE 00536 T = ( 8*XA - 30 ) / ( 4*XA + 15 ) 00537 BM = 0 00538 B = 0 00539 DO I = IM, 0, -1 00540 BP = B 00541 B = BM 00542 BM = T*B - BP + A(I) 00543 END DO 00544 P = EXP( -XA*XA )*( BM - BP )/4 00545 END IF 00546 IF ( Z .GT. 0 ) P = 1 - P 00547 MVPHI = P 00548 END 00549 * 00550 DOUBLE PRECISION FUNCTION MVPHNV(P) 00551 * 00552 * ALGORITHM AS241 APPL. STATIST. (1988) VOL. 37, NO. 3 00553 * 00554 * Produces the normal deviate Z corresponding to a given lower 00555 * tail area of P. 00556 * 00557 * The hash sums below are the sums of the mantissas of the 00558 * coefficients. They are included for use in checking 00559 * transcription. 00560 * 00561 DOUBLE PRECISION SPLIT1, SPLIT2, CONST1, CONST2, 00562 * A0, A1, A2, A3, A4, A5, A6, A7, B1, B2, B3, B4, B5, B6, B7, 00563 * C0, C1, C2, C3, C4, C5, C6, C7, D1, D2, D3, D4, D5, D6, D7, 00564 * E0, E1, E2, E3, E4, E5, E6, E7, F1, F2, F3, F4, F5, F6, F7, 00565 * P, Q, R 00566 PARAMETER ( SPLIT1 = 0.425, SPLIT2 = 5, 00567 * CONST1 = 0.180625D0, CONST2 = 1.6D0 ) 00568 * 00569 * Coefficients for P close to 0.5 00570 * 00571 PARAMETER ( 00572 * A0 = 3.38713 28727 96366 6080D0, 00573 * A1 = 1.33141 66789 17843 7745D+2, 00574 * A2 = 1.97159 09503 06551 4427D+3, 00575 * A3 = 1.37316 93765 50946 1125D+4, 00576 * A4 = 4.59219 53931 54987 1457D+4, 00577 * A5 = 6.72657 70927 00870 0853D+4, 00578 * A6 = 3.34305 75583 58812 8105D+4, 00579 * A7 = 2.50908 09287 30122 6727D+3, 00580 * B1 = 4.23133 30701 60091 1252D+1, 00581 * B2 = 6.87187 00749 20579 0830D+2, 00582 * B3 = 5.39419 60214 24751 1077D+3, 00583 * B4 = 2.12137 94301 58659 5867D+4, 00584 * B5 = 3.93078 95800 09271 0610D+4, 00585 * B6 = 2.87290 85735 72194 2674D+4, 00586 * B7 = 5.22649 52788 52854 5610D+3 ) 00587 * HASH SUM AB 55.88319 28806 14901 4439 00588 * 00589 * Coefficients for P not close to 0, 0.5 or 1. 00590 * 00591 PARAMETER ( 00592 * C0 = 1.42343 71107 49683 57734D0, 00593 * C1 = 4.63033 78461 56545 29590D0, 00594 * C2 = 5.76949 72214 60691 40550D0, 00595 * C3 = 3.64784 83247 63204 60504D0, 00596 * C4 = 1.27045 82524 52368 38258D0, 00597 * C5 = 2.41780 72517 74506 11770D-1, 00598 * C6 = 2.27238 44989 26918 45833D-2, 00599 * C7 = 7.74545 01427 83414 07640D-4, 00600 * D1 = 2.05319 16266 37758 82187D0, 00601 * D2 = 1.67638 48301 83803 84940D0, 00602 * D3 = 6.89767 33498 51000 04550D-1, 00603 * D4 = 1.48103 97642 74800 74590D-1, 00604 * D5 = 1.51986 66563 61645 71966D-2, 00605 * D6 = 5.47593 80849 95344 94600D-4, 00606 * D7 = 1.05075 00716 44416 84324D-9 ) 00607 * HASH SUM CD 49.33206 50330 16102 89036 00608 * 00609 * Coefficients for P near 0 or 1. 00610 * 00611 PARAMETER ( 00612 * E0 = 6.65790 46435 01103 77720D0, 00613 * E1 = 5.46378 49111 64114 36990D0, 00614 * E2 = 1.78482 65399 17291 33580D0, 00615 * E3 = 2.96560 57182 85048 91230D-1, 00616 * E4 = 2.65321 89526 57612 30930D-2, 00617 * E5 = 1.24266 09473 88078 43860D-3, 00618 * E6 = 2.71155 55687 43487 57815D-5, 00619 * E7 = 2.01033 43992 92288 13265D-7, 00620 * F1 = 5.99832 20655 58879 37690D-1, 00621 * F2 = 1.36929 88092 27358 05310D-1, 00622 * F3 = 1.48753 61290 85061 48525D-2, 00623 * F4 = 7.86869 13114 56132 59100D-4, 00624 * F5 = 1.84631 83175 10054 68180D-5, 00625 * F6 = 1.42151 17583 16445 88870D-7, 00626 * F7 = 2.04426 31033 89939 78564D-15 ) 00627 * HASH SUM EF 47.52583 31754 92896 71629 00628 * 00629 Q = ( 2*P - 1 )/2 00630 IF ( ABS(Q) .LE. SPLIT1 ) THEN 00631 R = CONST1 - Q*Q 00632 MVPHNV = Q*( ( ( ((((A7*R + A6)*R + A5)*R + A4)*R + A3) 00633 * *R + A2 )*R + A1 )*R + A0 ) 00634 * /( ( ( ((((B7*R + B6)*R + B5)*R + B4)*R + B3) 00635 * *R + B2 )*R + B1 )*R + 1 ) 00636 ELSE 00637 R = MIN( P, 1 - P ) 00638 IF ( R .GT. 0 ) THEN 00639 R = SQRT( -LOG(R) ) 00640 IF ( R .LE. SPLIT2 ) THEN 00641 R = R - CONST2 00642 MVPHNV = ( ( ( ((((C7*R + C6)*R + C5)*R + C4)*R + C3) 00643 * *R + C2 )*R + C1 )*R + C0 ) 00644 * /( ( ( ((((D7*R + D6)*R + D5)*R + D4)*R + D3) 00645 * *R + D2 )*R + D1 )*R + 1 ) 00646 ELSE 00647 R = R - SPLIT2 00648 MVPHNV = ( ( ( ((((E7*R + E6)*R + E5)*R + E4)*R + E3) 00649 * *R + E2 )*R + E1 )*R + E0 ) 00650 * /( ( ( ((((F7*R + F6)*R + F5)*R + F4)*R + F3) 00651 * *R + F2 )*R + F1 )*R + 1 ) 00652 END IF 00653 ELSE 00654 MVPHNV = 9 00655 END IF 00656 IF ( Q .LT. 0 ) MVPHNV = - MVPHNV 00657 END IF 00658 END 00659 DOUBLE PRECISION FUNCTION MVBVN( LOWER, UPPER, INFIN, CORREL ) 00660 * 00661 * A function for computing bivariate normal probabilities. 00662 * 00663 * Parameters 00664 * 00665 * LOWER REAL, array of lower integration limits. 00666 * UPPER REAL, array of upper integration limits. 00667 * INFIN INTEGER, array of integration limits flags: 00668 * if INFIN(I) = 0, Ith limits are (-infinity, UPPER(I)]; 00669 * if INFIN(I) = 1, Ith limits are [LOWER(I), infinity); 00670 * if INFIN(I) = 2, Ith limits are [LOWER(I), UPPER(I)]. 00671 * CORREL REAL, correlation coefficient. 00672 * 00673 DOUBLE PRECISION LOWER(*), UPPER(*), CORREL, MVBVU 00674 INTEGER INFIN(*) 00675 IF ( INFIN(1) .EQ. 2 .AND. INFIN(2) .EQ. 2 ) THEN 00676 MVBVN = MVBVU ( LOWER(1), LOWER(2), CORREL ) 00677 + - MVBVU ( UPPER(1), LOWER(2), CORREL ) 00678 + - MVBVU ( LOWER(1), UPPER(2), CORREL ) 00679 + + MVBVU ( UPPER(1), UPPER(2), CORREL ) 00680 ELSE IF ( INFIN(1) .EQ. 2 .AND. INFIN(2) .EQ. 1 ) THEN 00681 MVBVN = MVBVU ( LOWER(1), LOWER(2), CORREL ) 00682 + - MVBVU ( UPPER(1), LOWER(2), CORREL ) 00683 ELSE IF ( INFIN(1) .EQ. 1 .AND. INFIN(2) .EQ. 2 ) THEN 00684 MVBVN = MVBVU ( LOWER(1), LOWER(2), CORREL ) 00685 + - MVBVU ( LOWER(1), UPPER(2), CORREL ) 00686 ELSE IF ( INFIN(1) .EQ. 2 .AND. INFIN(2) .EQ. 0 ) THEN 00687 MVBVN = MVBVU ( -UPPER(1), -UPPER(2), CORREL ) 00688 + - MVBVU ( -LOWER(1), -UPPER(2), CORREL ) 00689 ELSE IF ( INFIN(1) .EQ. 0 .AND. INFIN(2) .EQ. 2 ) THEN 00690 MVBVN = MVBVU ( -UPPER(1), -UPPER(2), CORREL ) 00691 + - MVBVU ( -UPPER(1), -LOWER(2), CORREL ) 00692 ELSE IF ( INFIN(1) .EQ. 1 .AND. INFIN(2) .EQ. 0 ) THEN 00693 MVBVN = MVBVU ( LOWER(1), -UPPER(2), -CORREL ) 00694 ELSE IF ( INFIN(1) .EQ. 0 .AND. INFIN(2) .EQ. 1 ) THEN 00695 MVBVN = MVBVU ( -UPPER(1), LOWER(2), -CORREL ) 00696 ELSE IF ( INFIN(1) .EQ. 1 .AND. INFIN(2) .EQ. 1 ) THEN 00697 MVBVN = MVBVU ( LOWER(1), LOWER(2), CORREL ) 00698 ELSE IF ( INFIN(1) .EQ. 0 .AND. INFIN(2) .EQ. 0 ) THEN 00699 MVBVN = MVBVU ( -UPPER(1), -UPPER(2), CORREL ) 00700 ELSE 00701 MVBVN = 1 00702 END IF 00703 END 00704 DOUBLE PRECISION FUNCTION MVBVU( SH, SK, R ) 00705 * 00706 * A function for computing bivariate normal probabilities; 00707 * developed using 00708 * Drezner, Z. and Wesolowsky, G. O. (1989), 00709 * On the Computation of the Bivariate Normal Integral, 00710 * J. Stat. Comput. Simul.. 35 pp. 101-107. 00711 * with extensive modications for double precisions by 00712 * Alan Genz and Yihong Ge 00713 * Department of Mathematics 00714 * Washington State University 00715 * Pullman, WA 99164-3113 00716 * Email : alangenz@wsu.edu 00717 * 00718 * BVN - calculate the probability that X is larger than SH and Y is 00719 * larger than SK. 00720 * 00721 * Parameters 00722 * 00723 * SH REAL, integration limit 00724 * SK REAL, integration limit 00725 * R REAL, correlation coefficient 00726 * LG INTEGER, number of Gauss Rule Points and Weights 00727 * 00728 DOUBLE PRECISION BVN, SH, SK, R, ZERO, TWOPI 00729 INTEGER I, LG, NG 00730 PARAMETER ( ZERO = 0, TWOPI = 6.283185307179586D0 ) 00731 DOUBLE PRECISION X(10,3), W(10,3), AS, A, B, C, D, RS, XS 00732 DOUBLE PRECISION MVPHI, SN, ASR, H, K, BS, HS, HK 00733 SAVE X, W 00734 * Gauss Legendre Points and Weights, N = 6 00735 DATA ( W(I,1), X(I,1), I = 1, 3 ) / 00736 * 0.1713244923791705D+00,-0.9324695142031522D+00, 00737 * 0.3607615730481384D+00,-0.6612093864662647D+00, 00738 * 0.4679139345726904D+00,-0.2386191860831970D+00/ 00739 * Gauss Legendre Points and Weights, N = 12 00740 DATA ( W(I,2), X(I,2), I = 1, 6 ) / 00741 * 0.4717533638651177D-01,-0.9815606342467191D+00, 00742 * 0.1069393259953183D+00,-0.9041172563704750D+00, 00743 * 0.1600783285433464D+00,-0.7699026741943050D+00, 00744 * 0.2031674267230659D+00,-0.5873179542866171D+00, 00745 * 0.2334925365383547D+00,-0.3678314989981802D+00, 00746 * 0.2491470458134029D+00,-0.1252334085114692D+00/ 00747 * Gauss Legendre Points and Weights, N = 20 00748 DATA ( W(I,3), X(I,3), I = 1, 10 ) / 00749 * 0.1761400713915212D-01,-0.9931285991850949D+00, 00750 * 0.4060142980038694D-01,-0.9639719272779138D+00, 00751 * 0.6267204833410906D-01,-0.9122344282513259D+00, 00752 * 0.8327674157670475D-01,-0.8391169718222188D+00, 00753 * 0.1019301198172404D+00,-0.7463319064601508D+00, 00754 * 0.1181945319615184D+00,-0.6360536807265150D+00, 00755 * 0.1316886384491766D+00,-0.5108670019508271D+00, 00756 * 0.1420961093183821D+00,-0.3737060887154196D+00, 00757 * 0.1491729864726037D+00,-0.2277858511416451D+00, 00758 * 0.1527533871307259D+00,-0.7652652113349733D-01/ 00759 IF ( ABS(R) .LT. 0.3 ) THEN 00760 NG = 1 00761 LG = 3 00762 ELSE IF ( ABS(R) .LT. 0.75 ) THEN 00763 NG = 2 00764 LG = 6 00765 ELSE 00766 NG = 3 00767 LG = 10 00768 ENDIF 00769 H = SH 00770 K = SK 00771 HK = H*K 00772 BVN = 0 00773 IF ( ABS(R) .LT. 0.925 ) THEN 00774 HS = ( H*H + K*K )/2 00775 ASR = ASIN(R) 00776 DO I = 1, LG 00777 SN = SIN(ASR*( X(I,NG)+1 )/2) 00778 BVN = BVN + W(I,NG)*EXP( ( SN*HK - HS )/( 1 - SN*SN ) ) 00779 SN = SIN(ASR*(-X(I,NG)+1 )/2) 00780 BVN = BVN + W(I,NG)*EXP( ( SN*HK - HS )/( 1 - SN*SN ) ) 00781 END DO 00782 BVN = BVN*ASR/(2*TWOPI) + MVPHI(-H)*MVPHI(-K) 00783 ELSE 00784 IF ( R .LT. 0 ) THEN 00785 K = -K 00786 HK = -HK 00787 ENDIF 00788 IF ( ABS(R) .LT. 1 ) THEN 00789 AS = ( 1 - R )*( 1 + R ) 00790 A = SQRT(AS) 00791 BS = ( H - K )**2 00792 C = ( 4 - HK )/8 00793 D = ( 12 - HK )/16 00794 BVN = A*EXP( -(BS/AS + HK)/2 ) 00795 + *( 1 - C*(BS - AS)*(1 - D*BS/5)/3 + C*D*AS*AS/5 ) 00796 IF ( HK .GT. -160 ) THEN 00797 B = SQRT(BS) 00798 BVN = BVN - EXP(-HK/2)*SQRT(TWOPI)*MVPHI(-B/A)*B 00799 + *( 1 - C*BS*( 1 - D*BS/5 )/3 ) 00800 ENDIF 00801 A = A/2 00802 DO I = 1, LG 00803 XS = ( A*(X(I,NG)+1) )**2 00804 RS = SQRT( 1 - XS ) 00805 BVN = BVN + A*W(I,NG)* 00806 + ( EXP( -BS/(2*XS) - HK/(1+RS) )/RS 00807 + - EXP( -(BS/XS+HK)/2 )*( 1 + C*XS*( 1 + D*XS ) ) ) 00808 XS = AS*(-X(I,NG)+1)**2/4 00809 RS = SQRT( 1 - XS ) 00810 BVN = BVN + A*W(I,NG)*EXP( -(BS/XS + HK)/2 ) 00811 + *( EXP( -HK*(1-RS)/(2*(1+RS)) )/RS 00812 + - ( 1 + C*XS*( 1 + D*XS ) ) ) 00813 END DO 00814 BVN = -BVN/TWOPI 00815 ENDIF 00816 IF ( R .GT. 0 ) BVN = BVN + MVPHI( -MAX( H, K ) ) 00817 IF ( R .LT. 0 ) BVN = -BVN + MAX( ZERO, MVPHI(-H) - MVPHI(-K) ) 00818 ENDIF 00819 MVBVU = BVN 00820 END 00821 * 00822 DOUBLE PRECISION FUNCTION MVSTDT( NU, T ) 00823 * 00824 * Student t Distribution Function 00825 * 00826 * T 00827 * TSTDNT = C I ( 1 + y*y/NU )**( -(NU+1)/2 ) dy 00828 * NU -INF 00829 * 00830 INTEGER NU, J 00831 DOUBLE PRECISION MVPHI, T, CSTHE, SNTHE, POLYN, TT, TS, RN, PI 00832 PARAMETER ( PI = 3.141592653589793D0 ) 00833 IF ( NU .LT. 1 ) THEN 00834 MVSTDT = MVPHI( T ) 00835 ELSE IF ( NU .EQ. 1 ) THEN 00836 MVSTDT = ( 1 + 2*ATAN( T )/PI )/2 00837 ELSE IF ( NU .EQ. 2) THEN 00838 MVSTDT = ( 1 + T/SQRT( 2 + T*T ))/2 00839 ELSE 00840 TT = T*T 00841 CSTHE = NU/( NU + TT ) 00842 POLYN = 1 00843 DO J = NU - 2, 2, -2 00844 POLYN = 1 + ( J - 1 )*CSTHE*POLYN/J 00845 END DO 00846 IF ( MOD( NU, 2 ) .EQ. 1 ) THEN 00847 RN = NU 00848 TS = T/SQRT(RN) 00849 MVSTDT = ( 1 + 2*( ATAN( TS ) + TS*CSTHE*POLYN )/PI )/2 00850 ELSE 00851 SNTHE = T/SQRT( NU + TT ) 00852 MVSTDT = ( 1 + SNTHE*POLYN )/2 00853 END IF 00854 IF ( MVSTDT .LT. 0 ) MVSTDT = 0 00855 ENDIF 00856 END 00857 * 00858 DOUBLE PRECISION FUNCTION MVBVT( NU, LOWER, UPPER, INFIN, CORREL ) 00859 * 00860 * A function for computing bivariate normal and t probabilities. 00861 * 00862 * Parameters 00863 * 00864 * NU INTEGER degrees of freedom parameter; NU < 1 gives normal case. 00865 * LOWER REAL, array of lower integration limits. 00866 * UPPER REAL, array of upper integration limits. 00867 * INFIN INTEGER, array of integration limits flags: 00868 * if INFIN(I) = 0, Ith limits are (-infinity, UPPER(I)]; 00869 * if INFIN(I) = 1, Ith limits are [LOWER(I), infinity); 00870 * if INFIN(I) = 2, Ith limits are [LOWER(I), UPPER(I)]. 00871 * CORREL REAL, correlation coefficient. 00872 * 00873 DOUBLE PRECISION LOWER(*), UPPER(*), CORREL, MVBVN, MVBVTL 00874 INTEGER NU, INFIN(*) 00875 IF ( NU .LT. 1 ) THEN 00876 MVBVT = MVBVN ( LOWER, UPPER, INFIN, CORREL ) 00877 ELSE 00878 IF ( INFIN(1) .EQ. 2 .AND. INFIN(2) .EQ. 2 ) THEN 00879 MVBVT = MVBVTL ( NU, UPPER(1), UPPER(2), CORREL ) 00880 + - MVBVTL ( NU, UPPER(1), LOWER(2), CORREL ) 00881 + - MVBVTL ( NU, LOWER(1), UPPER(2), CORREL ) 00882 + + MVBVTL ( NU, LOWER(1), LOWER(2), CORREL ) 00883 ELSE IF ( INFIN(1) .EQ. 2 .AND. INFIN(2) .EQ. 1 ) THEN 00884 MVBVT = MVBVTL ( NU, -LOWER(1), -LOWER(2), CORREL ) 00885 + - MVBVTL ( NU, -UPPER(1), -LOWER(2), CORREL ) 00886 ELSE IF ( INFIN(1) .EQ. 1 .AND. INFIN(2) .EQ. 2 ) THEN 00887 MVBVT = MVBVTL ( NU, -LOWER(1), -LOWER(2), CORREL ) 00888 + - MVBVTL ( NU, -LOWER(1), -UPPER(2), CORREL ) 00889 ELSE IF ( INFIN(1) .EQ. 2 .AND. INFIN(2) .EQ. 0 ) THEN 00890 MVBVT = MVBVTL ( NU, UPPER(1), UPPER(2), CORREL ) 00891 + - MVBVTL ( NU, LOWER(1), UPPER(2), CORREL ) 00892 ELSE IF ( INFIN(1) .EQ. 0 .AND. INFIN(2) .EQ. 2 ) THEN 00893 MVBVT = MVBVTL ( NU, UPPER(1), UPPER(2), CORREL ) 00894 + - MVBVTL ( NU, UPPER(1), LOWER(2), CORREL ) 00895 ELSE IF ( INFIN(1) .EQ. 1 .AND. INFIN(2) .EQ. 0 ) THEN 00896 MVBVT = MVBVTL ( NU, -LOWER(1), UPPER(2), -CORREL ) 00897 ELSE IF ( INFIN(1) .EQ. 0 .AND. INFIN(2) .EQ. 1 ) THEN 00898 MVBVT = MVBVTL ( NU, UPPER(1), -LOWER(2), -CORREL ) 00899 ELSE IF ( INFIN(1) .EQ. 1 .AND. INFIN(2) .EQ. 1 ) THEN 00900 MVBVT = MVBVTL ( NU, -LOWER(1), -LOWER(2), CORREL ) 00901 ELSE IF ( INFIN(1) .EQ. 0 .AND. INFIN(2) .EQ. 0 ) THEN 00902 MVBVT = MVBVTL ( NU, UPPER(1), UPPER(2), CORREL ) 00903 ELSE 00904 MVBVT = 1 00905 END IF 00906 END IF 00907 END 00908 * 00909 DOUBLE PRECISION FUNCTION MVBVTC( NU, L, U, INFIN, RHO ) 00910 * 00911 * A function for computing complementary bivariate normal and t 00912 * probabilities. 00913 * 00914 * Parameters 00915 * 00916 * NU INTEGER degrees of freedom parameter. 00917 * L REAL, array of lower integration limits. 00918 * U REAL, array of upper integration limits. 00919 * INFIN INTEGER, array of integration limits flags: 00920 * if INFIN(1) INFIN(2), then MVBVTC computes 00921 * 0 0 P( X>U(1), Y>U(2) ) 00922 * 1 0 P( X<L(1), Y>U(2) ) 00923 * 0 1 P( X>U(1), Y<L(2) ) 00924 * 1 1 P( X<L(1), Y<L(2) ) 00925 * 2 0 P( X>U(1), Y>U(2) ) + P( X<L(1), Y>U(2) ) 00926 * 2 1 P( X>U(1), Y<L(2) ) + P( X<L(1), Y<L(2) ) 00927 * 0 2 P( X>U(1), Y>U(2) ) + P( X>U(1), Y<L(2) ) 00928 * 1 2 P( X<L(1), Y>U(2) ) + P( X<L(1), Y<L(2) ) 00929 * 2 2 P( X>U(1), Y<L(2) ) + P( X<L(1), Y<L(2) ) 00930 * + P( X>U(1), Y>U(2) ) + P( X<L(1), Y>U(2) ) 00931 * 00932 * RHO REAL, correlation coefficient. 00933 * 00934 DOUBLE PRECISION L(*), U(*), LW(2), UP(2), B, RHO, MVBVT 00935 INTEGER I, NU, INFIN(*), INF(2) 00936 * 00937 DO I = 1, 2 00938 IF ( MOD( INFIN(I), 2 ) .EQ. 0 ) THEN 00939 INF(I) = 1 00940 LW(I) = U(I) 00941 ELSE 00942 INF(I) = 0 00943 UP(I) = L(I) 00944 END IF 00945 END DO 00946 B = MVBVT( NU, LW, UP, INF, RHO ) 00947 DO I = 1, 2 00948 IF ( INFIN(I) .EQ. 2 ) THEN 00949 INF(I) = 0 00950 UP(I) = L(I) 00951 B = B + MVBVT( NU, LW, UP, INF, RHO ) 00952 END IF 00953 END DO 00954 IF ( INFIN(1) .EQ. 2 .AND. INFIN(2) .EQ. 2 ) THEN 00955 INF(1) = 1 00956 LW(1) = U(1) 00957 B = B + MVBVT( NU, LW, UP, INF, RHO ) 00958 END IF 00959 MVBVTC = B 00960 END 00961 * 00962 double precision function mvbvtl( nu, dh, dk, r ) 00963 * 00964 * a function for computing bivariate t probabilities. 00965 * 00966 * Alan Genz 00967 * Department of Mathematics 00968 * Washington State University 00969 * Pullman, Wa 99164-3113 00970 * Email : alangenz@wsu.edu 00971 * 00972 * this function is based on the method described by 00973 * Dunnett, C.W. and M. Sobel, (1954), 00974 * A bivariate generalization of Student 00975 00976 00977 00978 00979 00980 00981 00982 00983 00984 00985 00986 00987 00988 00989 00990 00991 00992 00993 00994 00995 00996 00997 00998 00999 01000 01001 01002 01003 01004 01005 01006 01007 01008 01009 01010 01011 01012 01013 01014 01015 01016 01017 01018 01019 01020 01021 01022 01023 01024 01025 01026 01027 01028 01029 01030 01031 01032 01033 01034 01035 01036 01037 01038 01039 01040 01041 01042 01043 01044 01045 01046 01047 01048 01049 01050 01051 01052 01053 01054 01055 01056 01057 01058 01059 01060 01061 01062 01063 01064 01065 01066 01067 01068 01069 01070 01071 01072 01073 01074 01075 01076 01077 01078 01079 01080 01081 01082 01083 01084 01085 01086 01087 01088 01089 01090 01091 01092 01093 01094 01095 01096 01097 01098 01099 01100 01101 01102 01103 01104 01105 01106 01107 01108 01109 01110 01111 01112 01113 01114 01115 01116 01117 01118 01119 01120 01121 01122 01123 01124 01125 01126 01127 01128 01129 01130 01131 01132 01133 01134 01135 01136 01137 01138 01139 01140 01141 01142 01143 01144 01145 01146 01147 01148 01149 01150 01151 01152 01153 01154 01155 01156 01157 01158 01159 01160 01161 01162 01163 01164 01165 01166 01167 01168 01169 01170 01171 01172 01173 01174 01175 01176 01177 01178 01179 01180 01181 01182 01183 01184 01185 01186 01187 01188 01189 01190 01191 01192 01193 01194 01195 01196 01197 01198 01199 01200 01201 01202 01203 01204 01205 01206 01207 01208 01209 01210 01211 01212 01213 01214 01215 01216 01217 01218 01219 01220 01221 01222 01223 01224 01225 01226 01227 01228 01229 01230 01231 01232 01233 01234 01235 01236 01237 01238 01239 01240 01241 01242 01243 01244 01245 01246 01247 01248 01249 01250 01251 01252 01253 01254 01255 01256 01257 01258 01259 01260 01261 01262 01263 01264 01265 01266 01267 01268 01269 01270 01271 01272 01273 01274 01275 01276 01277 01278 01279 01280 01281 01282 01283 01284 01285 01286 01287 01288 01289 01290 01291 01292 01293 01294 01295 01296 01297 01298 01299 01300 01301 01302 01303 01304 01305 01306 01307 01308 01309 01310 01311 01312 01313 01314 01315 01316 01317 01318 01319 01320 01321 01322 01323 01324 01325 01326 01327 01328 01329 01330 01331 01332 01333 01334 01335 01336 01337 01338 01339 01340 01341 01342 01343 01344 01345 01346 01347 01348 01349 01350 01351 01352 01353 01354 01355 01356 01357 01358 01359 01360 01361 01362 01363 01364 01365 01366 01367 01368 01369 01370 01371 01372 01373 01374 01375 01376 01377 01378 01379 01380 01381 01382 01383 01384 01385 01386 01387 01388 01389 01390 01391 01392 01393 01394 01395 01396 01397 01398 01399 01400 01401 01402 01403 01404 01405 01406 01407 01408 01409 01410 01411 01412 01413 01414 01415 01416 01417 01418 01419 01420 01421 01422 01423 01424 01425 01426 01427 01428 01429 01430 01431 01432 01433 01434 01435 01436 01437 01438 01439 01440 01441 01442 01443 01444 01445 01446 01447 01448 01449 01450 01451 01452 01453 01454 01455 01456 01457 01458 01459 01460 01461 01462 01463 01464 01465 01466 01467 01468 01469 01470 01471 01472 01473 01474 01475 01476 01477 01478 01479 01480 01481 01482 01483 01484 01485 01486 01487 01488 01489 01490 01491 01492 01493 's t-distribution* with tables for certain special cases,* Biometrika 41, pp. 153-169.** mvbvtl - calculate the probability that x < dh and y < dk. ** parameters** nu number of degrees of freedom* dh 1st lower integration limit* dk 2nd lower integration limit* r correlation coefficient* integer nu, j, hs, ks double precision dh, dk, r double precision tpi, pi, ors, hrk, krh, bvt, snu double precision gmph, gmpk, xnkh, xnhk, qhrk, hkn, hpk, hkrn double precision btnckh, btnchk, btpdkh, btpdhk, one parameter ( pi = 3.14159265358979323844d0, tpi = 2*pi, one = 1 ) snu = sqrt( dble(nu) ) ors = 1 - r*r hrk = dh - r*dk krh = dk - r*dh if ( abs(hrk) + ors .gt. 0 ) then xnhk = hrk**2/( hrk**2 + ors*( nu + dk**2 ) ) xnkh = krh**2/( krh**2 + ors*( nu + dh**2 ) ) else xnhk = 0 xnkh = 0 end if hs = sign( one, dh - r*dk ) ks = sign( one, dk - r*dh ) if ( mod( nu, 2 ) .eq. 0 ) then bvt = atan2( sqrt(ors), -r )/tpi gmph = dh/sqrt( 16*( nu + dh**2 ) ) gmpk = dk/sqrt( 16*( nu + dk**2 ) ) btnckh = 2*atan2( sqrt( xnkh ), sqrt( 1 - xnkh ) )/pi btpdkh = 2*sqrt( xnkh*( 1 - xnkh ) )/pi btnchk = 2*atan2( sqrt( xnhk ), sqrt( 1 - xnhk ) )/pi btpdhk = 2*sqrt( xnhk*( 1 - xnhk ) )/pi do j = 1, nu/2 bvt = bvt + gmph*( 1 + ks*btnckh ) bvt = bvt + gmpk*( 1 + hs*btnchk ) btnckh = btnckh + btpdkh btpdkh = 2*j*btpdkh*( 1 - xnkh )/( 2*j + 1 ) btnchk = btnchk + btpdhk btpdhk = 2*j*btpdhk*( 1 - xnhk )/( 2*j + 1 ) gmph = gmph*( 2*j - 1 )/( 2*j*( 1 + dh**2/nu ) ) gmpk = gmpk*( 2*j - 1 )/( 2*j*( 1 + dk**2/nu ) ) end do else qhrk = sqrt( dh**2 + dk**2 - 2*r*dh*dk + nu*ors ) hkrn = dh*dk + r*nu hkn = dh*dk - nu hpk = dh + dk bvt = atan2(-snu*(hkn*qhrk+hpk*hkrn),hkn*hkrn-nu*hpk*qhrk)/tpi if ( bvt .lt. -1d-15 ) bvt = bvt + 1 gmph = dh/( tpi*snu*( 1 + dh**2/nu ) ) gmpk = dk/( tpi*snu*( 1 + dk**2/nu ) ) btnckh = sqrt( xnkh ) btpdkh = btnckh btnchk = sqrt( xnhk ) btpdhk = btnchk do j = 1, ( nu - 1 )/2 bvt = bvt + gmph*( 1 + ks*btnckh ) bvt = bvt + gmpk*( 1 + hs*btnchk ) btpdkh = ( 2*j - 1 )*btpdkh*( 1 - xnkh )/( 2*j ) btnckh = btnckh + btpdkh btpdhk = ( 2*j - 1 )*btpdhk*( 1 - xnhk )/( 2*j ) btnchk = btnchk + btpdhk gmph = 2*j*gmph/( ( 2*j + 1 )*( 1 + dh**2/nu ) ) gmpk = 2*j*gmpk/( ( 2*j + 1 )*( 1 + dk**2/nu ) ) end do end if mvbvtl = bvt ** end mvbvtl* end* DOUBLE PRECISION FUNCTION MVCHNV( N, P )** MVCHNV* P = 1 - K I exp(-t*t/2) t**(N-1) dt, for N >= 1.* N 0* INTEGER I, N, NO DOUBLE PRECISION P, TWO, R, RO, LRP, LKN, MVPHNV, MVCHNC PARAMETER ( LRP = -.22579135264472743235D0, TWO = 2 )* LRP = LOG( SQRT( 2/PI ) ) SAVE NO, LKN DATA NO / 0 / IF ( N .LE. 1 ) THEN R = -MVPHNV( P/2 ) ELSE IF ( P .LT. 1 ) THEN IF ( N .EQ. 2 ) THEN R = SQRT( -2*LOG(P) ) ELSE IF ( N .NE. NO ) THEN NO = N LKN = 0 DO I = N-2, 2, -2 LKN = LKN - LOG( DBLE(I) ) END DO IF ( MOD( N, 2 ) .EQ. 1 ) LKN = LKN + LRP END IF IF ( N .GE. -5*LOG(1-P)/4 ) THEN R = TWO/( 9*N ) R = N*( -MVPHNV(P)*SQRT(R) + 1 - R )**3 IF ( R .GT. 2*N+6 ) THEN R = 2*( LKN - LOG(P) ) + ( N - 2 )*LOG(R) END IF ELSE R = EXP( ( LOG( (1-P)*N ) - LKN )*TWO/N ) END IF R = SQRT(R) RO = R R = MVCHNC( LKN, N, P, R ) IF ( ABS( R - RO ) .GT. 1D-6 ) THEN RO = R R = MVCHNC( LKN, N, P, R ) IF ( ABS( R - RO ) .GT. 1D-6 ) R = MVCHNC( LKN, N, P, R ) END IF END IF ELSE R = 0 END IF MVCHNV = R END* DOUBLE PRECISION FUNCTION MVCHNC( LKN, N, P, R )** Third order Schroeder correction to R for MVCHNV* INTEGER I, N DOUBLE PRECISION P, R, LKN, DF, RR, RN, CHI, MVPHI DOUBLE PRECISION LRP, TWO, AL, DL, AI, BI, CI, DI, EPS PARAMETER ( LRP = -.22579135264472743235D0, TWO = 2, EPS = 1D-14 )* LRP = LOG( SQRT( 2/PI ) ) RR = R*R IF ( N .LT. 2 ) THEN CHI = 2*MVPHI(-R) ELSE IF ( N .LT. 100 ) THEN** Use standard Chi series* RN = 1 DO I = N - 2, 2, -2 RN = 1 + RR*RN/I END DO RR = RR/2 IF ( MOD( N, 2 ) .EQ. 0 ) THEN CHI = EXP( LOG( RN ) - RR ) ELSE CHI = EXP( LRP + LOG( R*RN ) - RR ) + 2*MVPHI(-R) ENDIF ELSE RR = RR/2 AL = N/TWO CHI = EXP( -RR + AL*LOG(RR) + LKN + LOG(TWO)*( N - 2 )/2 ) IF ( RR .LT. AL + 1 ) THEN ** Use Incomplete Gamma series* DL = CHI DO I = 1, 1000 DL = DL*RR/( AL + I ) CHI = CHI + DL IF ( ABS( DL*RR/( AL + I + 1 - RR ) ) .LT. EPS ) GO TO 10 END DO 10 CHI = 1 - CHI/AL ELSE** Use Incomplete Gamma continued fraction* BI = RR + 1 - AL CI = 1/EPS DI = BI CHI = CHI/BI DO I = 1, 250 AI = I*( AL - I ) BI = BI + 2 CI = BI + AI/CI IF ( CI .EQ. 0 ) CI = EPS DI = BI + AI/DI IF ( DI .EQ. 0 ) DI = EPS DL = CI/DI CHI = CHI*DL IF ( ABS( DL - 1 ) .LT. EPS ) GO TO 20 END DO END IF END IF 20 DF = ( P - CHI )/EXP( LKN + ( N - 1 )*LOG(R) - RR ) MVCHNC = R - DF*( 1 - DF*( R - ( N - 1 )/R )/2 ) END* SUBROUTINE MVKBRV( NDIM, MINVLS, MAXVLS, NF, FUNSUB, & ABSEPS, RELEPS, ABSERR, FINEST, INFORM )** Automatic Multidimensional Integration Subroutine* * AUTHOR: Alan Genz* Department of Mathematics* Washington State University* Pulman, WA 99164-3113* Email: AlanGenz@wsu.edu** Last Change: 12/15/00** MVKBRV computes an approximation to the integral** 1 1 1* I I ... I F(X) dx(NDIM)...dx(2)dx(1)* 0 0 0** F(X) is a real NF-vector of integrands.** It uses randomized Korobov rules. The primary references are* "Randomization of Number Theoretic Methods for Multiple Integration"* R. Cranley and T.N.L. Patterson, SIAM J Numer Anal, 13, pp. 904-14,* and * "Optimal Parameters for Multidimensional Integration", * P. Keast, SIAM J Numer Anal, 10, pp.831-838.* If there are more than 100 variables, the remaining variables are* integrated using the rules described in the reference* "On a Number-Theoretical Integration Method"* H. Niederreiter, Aequationes Mathematicae, 8(1972), pp. 304-11.**************** Parameters ************************************************** Input parameters* NDIM Number of variables, must exceed 1, but not exceed 100* MINVLS Integer minimum number of function evaluations allowed.* MINVLS must not exceed MAXVLS. If MINVLS < 0 then the* routine assumes a previous call has been made with * the same integrands and continues that calculation.* MAXVLS Integer maximum number of function evaluations allowed.* NF Number of integrands, must exceed 1, but not exceed 5000* FUNSUB EXTERNALly declared user defined integrand subroutine.* It must have parameters ( NDIM, Z, NF, FUNVLS ), where * Z is a real NDIM-vector and FUNVLS is a real NF-vector.* * ABSEPS Required absolute accuracy.* RELEPS Required relative accuracy.****** Output parameters* MINVLS Actual number of function evaluations used.* ABSERR Maximum norm of estimated absolute accuracy of FINEST.* FINEST Estimated NF-vector of values of the integrals.* INFORM INFORM = 0 for normal exit, when * ABSERR <= MAX(ABSEPS, RELEPS*||FINEST||)* and * INTVLS <= MAXCLS.* INFORM = 1 If MAXVLS was too small to obtain the required * accuracy. In this case a value FINEST is returned with * estimated absolute accuracy ABSERR.************************************************************************ EXTERNAL FUNSUB DOUBLE PRECISION ABSEPS, RELEPS, FINEST(*), ABSERR, ONE INTEGER NDIM, NF, MINVLS, MAXVLS, INFORM, NP, PLIM, KLIM, & NLIM, FLIM, SAMPLS, I, K, INTVLS, MINSMP, KMX PARAMETER ( PLIM = 28, NLIM = 1000, KLIM = 100, FLIM = 5000 ) PARAMETER ( MINSMP = 8 ) INTEGER P(PLIM), C(PLIM,KLIM-1), PR(NLIM) DOUBLE PRECISION DIFINT, FINVAL(FLIM), VARSQR(FLIM), VAREST(FLIM), & VARPRD, X(NLIM), R(NLIM), VK(NLIM), VALUES(FLIM), FS(FLIM) PARAMETER ( ONE = 1 ) SAVE P, C, SAMPLS, NP, VAREST INFORM = 1 INTVLS = 0 VARPRD = 0 IF ( MINVLS .GE. 0 ) THEN DO K = 1, NF FINEST(K) = 0 VAREST(K) = 0 END DO SAMPLS = MINSMP DO I = MIN( NDIM, 10 ), PLIM NP = I IF ( MINVLS .LT. 2*SAMPLS*P(I) ) GO TO 10 END DO SAMPLS = MAX( MINSMP, MINVLS/( 2*P(NP) ) ) ENDIF 10 VK(1) = ONE/P(NP) K = 1 DO I = 2, NDIM IF ( I .LE. KLIM ) THEN K = MOD( C(NP, MIN(NDIM-1,KLIM-1))*DBLE(K), DBLE(P(NP)) ) VK(I) = K*VK(1) ELSE VK(I) = INT( P(NP)*2**( DBLE(I-KLIM)/(NDIM-KLIM+1) ) ) VK(I) = MOD( VK(I)/P(NP), ONE ) END IF END DO DO K = 1, NF FINVAL(K) = 0 VARSQR(K) = 0 END DO* DO I = 1, SAMPLS CALL MVKRSV( NDIM,KLIM,VALUES, P(NP),VK, NF,FUNSUB, X,R,PR,FS ) DO K = 1, NF DIFINT = ( VALUES(K) - FINVAL(K) )/I FINVAL(K) = FINVAL(K) + DIFINT VARSQR(K) = ( I - 2 )*VARSQR(K)/I + DIFINT**2 END DO END DO* INTVLS = INTVLS + 2*SAMPLS*P(NP) KMX = 1 DO K = 1, NF VARPRD = VAREST(K)*VARSQR(K) FINEST(K) = FINEST(K) + ( FINVAL(K) - FINEST(K) )/( 1+VARPRD ) IF ( VARSQR(K) .GT. 0 ) VAREST(K) = ( 1 + VARPRD )/VARSQR(K) IF ( ABS(FINEST(K)) .GT. ABS(FINEST(KMX)) ) KMX = K END DO ABSERR = 7*SQRT( VARSQR(KMX)/( 1 + VARPRD ) )/2 IF ( ABSERR .GT. MAX( ABSEPS, ABS(FINEST(KMX))*RELEPS ) ) THEN IF ( NP .LT. PLIM ) THEN NP = NP + 1 ELSE SAMPLS = MIN( 3*SAMPLS/2, ( MAXVLS - INTVLS )/( 2*P(NP) ) ) SAMPLS = MAX( MINSMP, SAMPLS ) ENDIF IF ( INTVLS + 2*SAMPLS*P(NP) .LE. MAXVLS ) GO TO 10 ELSE INFORM = 0 ENDIF MINVLS = INTVLS** Optimal Parameters for Lattice Rules* DATA P( 1),(C( 1,I),I = 1,99)/ 31, 12, 2*9, 13, 8*12, 3*3, 12, & 2*7, 9*12, 3*3, 12, 2*7, 9*12, 3*3, 12, 2*7, 9*12, 3*3, 12, 2*7, & 8*12, 7, 3*3, 3*7, 21*3/ DATA P( 2),(C( 2,I),I = 1,99)/ 47, 13, 11, 17, 10, 6*15, & 22, 2*15, 3*6, 2*15, 9, 13, 3*2, 13, 2*11, 10, 9*15, 3*6, 2*15, & 9, 13, 3*2, 13, 2*11, 10, 9*15, 3*6, 2*15, 9, 13, 3*2, 13, 2*11, & 2*10, 8*15, 6, 2, 3, 2, 3, 12*2/ DATA P( 3),(C( 3,I),I = 1,99)/ 73, 27, 28, 10, 2*11, 20, & 2*11, 28, 2*13, 28, 3*13, 16*14, 2*31, 3*5, 31, 13, 6*11, 7*13, & 16*14, 2*31, 3*5, 11, 13, 7*11, 2*13, 11, 13, 4*5, 14, 13, 8*5/ DATA P( 4),(C( 4,I),I = 1,99)/ 113, 35, 2*27, 36, 22, 2*29, & 20, 45, 3*5, 16*21, 29, 10*17, 12*23, 21, 27, 3*3, 24, 2*27, & 17, 3*29, 17, 4*5, 16*21, 3*17, 6, 2*17, 6, 3, 2*6, 5*3/ DATA P( 5),(C( 5,I),I = 1,99)/ 173, 64, 66, 2*28, 2*44, 55, & 67, 6*10, 2*38, 5*10, 12*49, 2*38, 31, 2*4, 31, 64, 3*4, 64, & 6*45, 19*66, 11, 9*66, 45, 11, 7, 3, 3*2, 27, 5, 2*3, 2*5, 7*2/ DATA P( 6),(C( 6,I),I = 1,99)/ 263, 111, 42, 54, 118, 20, & 2*31, 72, 17, 94, 2*14, 11, 3*14, 94, 4*10, 7*14, 3*11, 7*8, & 5*18, 113, 2*62, 2*45, 17*113, 2*63, 53, 63, 15*67, 5*51, 12, & 51, 12, 51, 5, 2*3, 2*2, 5/ DATA P( 7),(C( 7,I),I = 1,99)/ 397, 163, 154, 83, 43, 82, & 92, 150, 59, 2*76, 47, 2*11, 100, 131, 6*116, 9*138, 21*101, & 6*116, 5*100, 5*138, 19*101, 8*38, 5*3/ DATA P( 8),(C( 8,I),I = 1,99)/ 593, 246, 189, 242, 102, & 2*250, 102, 250, 280, 118, 196, 118, 191, 215, 2*121, & 12*49, 34*171, 8*161, 17*14, 6*10, 103, 4*10, 5/ DATA P( 9),(C( 9,I),I = 1,99)/ 907, 347, 402, 322, 418, & 215, 220, 3*339, 337, 218, 4*315, 4*167, 361, 201, 11*124, & 2*231, 14*90, 4*48, 23*90, 10*243, 9*283, 16, 283, 16, 2*283/ DATA P(10),(C(10,I),I = 1,99)/ 1361, 505, 220, 601, 644, & 612, 160, 3*206, 422, 134, 518, 2*134, 518, 652, 382, & 206, 158, 441, 179, 441, 56, 2*559, 14*56, 2*101, 56, & 8*101, 7*193, 21*101, 17*122, 4*101/ DATA P(11),(C(11,I),I = 1,99)/ 2053, 794, 325, 960, 528, & 2*247, 338, 366, 847, 2*753, 236, 2*334, 461, 711, 652, & 3*381, 652, 7*381, 226, 7*326, 126, 10*326, 2*195, 19*55, & 7*195, 11*132, 13*387/ DATA P(12),(C(12,I),I = 1,99)/ 3079, 1189, 888, 259, 1082, 725, & 811, 636, 965, 2*497, 2*1490, 392, 1291, 2*508, 2*1291, 508, & 1291, 2*508, 4*867, 934, 7*867, 9*1284, 4*563, 3*1010, 208, & 838, 3*563, 2*759, 564, 2*759, 4*801, 5*759, 8*563, 22*226/ DATA P(13),(C(13,I),I = 1,99)/ 4621, 1763, 1018, 1500, 432, & 1332, 2203, 126, 2240, 1719, 1284, 878, 1983, 4*266, & 2*747, 2*127, 2074, 127, 2074, 1400, 10*1383, 1400, 7*1383, & 507, 4*1073, 5*1990, 9*507, 17*1073, 6*22, 1073, 6*452, 318, & 4*301, 2*86, 15/ DATA P(14),(C(14,I),I = 1,99)/ 6947, 2872, 3233, 1534, 2941, & 2910, 393, 1796, 919, 446, 2*919, 1117, 7*103, 2311, 3117, 1101, & 2*3117, 5*1101, 8*2503, 7*429, 3*1702, 5*184, 34*105, 13*784/ DATA P(15),(C(15,I),I = 1,99)/ 10427, 4309, 3758, 4034, 1963, & 730, 642, 1502, 2246, 3834, 1511, 2*1102, 2*1522, 2*3427, & 3928, 2*915, 4*3818, 3*4782, 3818, 4782, 2*3818, 7*1327, 9*1387, & 13*2339, 18*3148, 3*1776, 3*3354, 925, 2*3354, 5*925, 8*2133/ DATA P(16),(C(16,I),I = 1,99)/ 15641, 6610, 6977, 1686, 3819, & 2314, 5647, 3953, 3614, 5115, 2*423, 5408, 7426, 2*423, & 487, 6227, 2660, 6227, 1221, 3811, 197, 4367, 351, & 1281, 1221, 3*351, 7245, 1984, 6*2999, 3995, 4*2063, 1644, & 2063, 2077, 3*2512, 4*2077, 19*754, 2*1097, 4*754, 248, 754, & 4*1097, 4*222, 754,11*1982/ DATA P(17),(C(17,I),I = 1,99)/ 23473, 9861, 3647, 4073, 2535, & 3430, 9865, 2830, 9328, 4320, 5913, 10365, 8272, 3706, 6186, & 3*7806, 8610, 2563, 2*11558, 9421, 1181, 9421, 3*1181, 9421, & 2*1181, 2*10574, 5*3534, 3*2898, 3450, 7*2141, 15*7055, 2831, & 24*8204, 3*4688, 8*2831/ DATA P(18),(C(18,I),I = 1,99)/ 35221, 10327, 7582, 7124, 8214, & 9600, 10271, 10193, 10800, 9086, 2365, 4409, 13812, & 5661, 2*9344, 10362, 2*9344, 8585, 11114, 3*13080, 6949, & 3*3436, 13213, 2*6130, 2*8159, 11595, 8159, 3436, 18*7096, & 4377, 7096, 5*4377, 2*5410, 32*4377, 2*440, 3*1199/ DATA P(19),(C(19,I),I = 1,99)/ 52837, 19540, 19926, 11582, & 11113, 24585, 8726, 17218, 419, 3*4918, 15701, 17710, & 2*4037, 15808, 11401, 19398, 2*25950, 4454, 24987, 11719, & 8697, 5*1452, 2*8697, 6436, 21475, 6436, 22913, 6434, 18497, & 4*11089, 2*3036, 4*14208, 8*12906, 4*7614, 6*5021, 24*10145, & 6*4544, 4*8394/ DATA P(20),(C(20,I),I = 1,99)/ 79259, 34566, 9579, 12654, & 26856, 37873, 38806, 29501, 17271, 3663, 10763, 18955, & 1298, 26560, 2*17132, 2*4753, 8713, 18624, 13082, 6791, & 1122, 19363, 34695, 4*18770, 15628, 4*18770, 33766, 6*20837, & 5*6545, 14*12138, 5*30483, 19*12138, 9305, 13*11107, 2*9305/ DATA P(21),(C(21,I),I = 1,99)/118891, 31929, 49367, 10982, 3527, & 27066, 13226, 56010, 18911, 40574, 2*20767, 9686, 2*47603, & 2*11736, 41601, 12888, 32948, 30801, 44243, 2*53351, 16016, & 2*35086, 32581, 2*2464, 49554, 2*2464, 2*49554, 2464, 81, 27260, & 10681, 7*2185, 5*18086, 2*17631, 3*18086, 37335, 3*37774, & 13*26401, 12982, 6*40398, 3*3518, 9*37799, 4*4721, 4*7067/ DATA P(22),(C(22,I),I = 1,99)/178349, 40701, 69087, 77576, 64590, & 39397, 33179, 10858, 38935, 43129, 2*35468, 5279, 2*61518, 27945, & 2*70975, 2*86478, 2*20514, 2*73178, 2*43098, 4701, & 2*59979, 58556, 69916, 2*15170, 2*4832, 43064, 71685, 4832, & 3*15170, 3*27679, 2*60826, 2*6187, 5*4264, 45567, 4*32269, & 9*62060, 13*1803, 12*51108, 2*55315, 5*54140, 13134/ DATA P(23),(C(23,I),I = 1,99)/267523, 103650, 125480, 59978, & 46875, 77172, 83021, 126904, 14541, 56299, 43636, 11655, & 52680, 88549, 29804, 101894, 113675, 48040, 113675, & 34987, 48308, 97926, 5475, 49449, 6850, 2*62545, 9440, & 33242, 9440, 33242, 9440, 33242, 9440, 62850, 3*9440, & 3*90308, 9*47904, 7*41143, 5*36114, 24997, 14*65162, 7*47650, & 7*40586, 4*38725, 5*88329/ DATA P(24),(C(24,I),I = 1,99)/401287, 165843, 90647, 59925, & 189541, 67647, 74795, 68365, 167485, 143918, 74912, & 167289, 75517, 8148, 172106, 126159,3*35867, 121694, & 52171, 95354, 2*113969, 76304, 2*123709, 144615, 123709, & 2*64958, 32377, 2*193002, 25023, 40017, 141605, 2*189165, & 141605, 2*189165, 3*141605, 189165, 20*127047, 10*127785, & 6*80822, 16*131661, 7114, 131661/ DATA P(25),(C(25,I),I = 1,99)/601943, 130365, 236711, 110235, & 125699, 56483, 93735, 234469, 60549, 1291, 93937, & 245291, 196061, 258647, 162489, 176631, 204895, 73353, & 172319, 28881, 136787,2*122081, 275993, 64673, 3*211587, & 2*282859, 211587, 242821, 3*256865, 122203, 291915, 122203, & 2*291915, 122203, 2*25639, 291803, 245397, 284047, & 7*245397, 94241, 2*66575, 19*217673, 10*210249, 15*94453/ DATA P(26),(C(26,I),I = 1,99)/902933, 333459, 375354, 102417, & 383544, 292630, 41147, 374614, 48032, 435453, 281493, 358168, & 114121, 346892, 238990, 317313, 164158, 35497, 2*70530, 434839, & 3*24754, 393656, 2*118711, 148227, 271087, 355831, 91034, & 2*417029, 2*91034, 417029, 91034, 2*299843, 2*413548, 308300, & 3*413548, 3*308300, 413548, 5*308300, 4*15311, 2*176255, 6*23613, & 172210, 4* 204328, 5*121626, 5*200187, 2*121551, 12*248492, & 5*13942/ DATA P(27), (C(27,I), I = 1,99)/ 1354471, 500884, 566009, 399251, & 652979, 355008, 430235, 328722, 670680, 2*405585, 424646, & 2*670180, 641587, 215580, 59048, 633320, 81010, 20789, 2*389250, & 2*638764, 2*389250, 398094, 80846, 2*147776, 296177, 2*398094, & 2*147776, 396313, 3*578233, 19482, 620706, 187095, 620706, & 187095, 126467, 12*241663, 321632, 2*23210, 3*394484, 3*78101, & 19*542095, 3*277743, 12*457259/ DATA P(28), (C(28,I), I = 1, 99)/ 2031713, 858339, 918142, 501970, & 234813, 460565, 31996, 753018, 256150, 199809, 993599, 245149, & 794183, 121349, 150619, 376952, 2*809123, 804319, 67352, 969594, & 434796, 969594, 804319, 391368, 761041, 754049, 466264, 2*754049, & 466264, 2*754049, 282852, 429907, 390017, 276645, 994856, 250142, & 144595, 907454, 689648, 4*687580, 978368, 687580, 552742, 105195, & 942843, 768249, 4*307142, 7*880619, 11*117185, 11*60731, & 4*178309, 8*74373, 3*214965/* END* SUBROUTINE MVKRSV( NDIM,KL,VALUES,PRIME,VK, NF,FUNSUB, X,R,PR,FS )** For lattice rule sums* INTEGER NDIM, NF, PRIME, KL, K, J, JP, PR(*) DOUBLE PRECISION VALUES(*), VK(*), FS(*), X(*), R(*), MVUNI DO J = 1, NF VALUES(J) = 0 END DO** Determine random shifts for each variable; scramble lattice rule* DO J = 1, NDIM R(J) = MVUNI() IF ( J .LT. KL ) THEN JP = 1 + J*R(J) IF ( JP .LT. J ) PR(J) = PR(JP) PR(JP) = J ELSE PR(J) = J END IF END DO** Compute latice rule sums* DO K = 1, PRIME DO J = 1, NDIM R(J) = R(J) + VK(PR(J)) IF ( R(J) .GT. 1 ) R(J) = R(J) - 1 X(J) = ABS( 2*R(J) - 1 ) END DO CALL FUNSUB( NDIM, X, NF, FS ) DO J = 1, NF VALUES(J) = VALUES(J) + ( FS(J) - VALUES(J) )/( 2*K-1 ) END DO DO J = 1, NDIM X(J) = 1 - X(J) END DO CALL FUNSUB( NDIM, X, NF, FS ) DO J = 1, NF VALUES(J) = VALUES(J) + ( FS(J) - VALUES(J) )/( 2*K ) END DO END DO* END* DOUBLE PRECISION FUNCTION MVUNI()** Uniform (0,1) random number generator** use R's random number generator directly 01494 * the way `Writing R extentions 01495 01496 01497 01498 01499 01500