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