00001
00002
00003
00004 SUBROUTINE MVTDST( N, NU, LOWER, UPPER, INFIN, CORREL, DELTA,
00005 & MAXPTS, ABSEPS, RELEPS, ERROR, VALUE, INFORM )
00006
00007
00008
00009
00010
00011
00012
00013
00014
00015
00016
00017
00018
00019
00020
00021
00022
00023
00024
00025
00026
00027
00028
00029
00030
00031
00032
00033
00034
00035
00036
00037
00038
00039
00040
00041
00042
00043
00044
00045
00046
00047
00048
00049
00050
00051
00052
00053
00054
00055
00056
00057
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
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
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
00105
00106 ENTRY MVINTS( N, NUIN, CORREL, LOWER, UPPER, DELTA, INFIN,
00107 & ND, VL, ER, INFORM )
00108
00109
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
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
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
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
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
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
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
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
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
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
00300
00301 II = 0
00302 JL = ND
00303 DO I = 1, ND
00304
00305
00306
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
00343
00344
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
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
00385
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
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
00503
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
00553
00554
00555
00556
00557
00558
00559
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
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
00588
00589
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
00608
00609
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
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
00662
00663
00664
00665
00666
00667
00668
00669
00670
00671
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
00707
00708
00709
00710
00711
00712
00713
00714
00715
00716
00717
00718
00719
00720
00721
00722
00723
00724
00725
00726
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
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
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
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
00825
00826
00827
00828
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
00861
00862
00863
00864
00865
00866
00867
00868
00869
00870
00871
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
00912
00913
00914
00915
00916
00917
00918
00919
00920
00921
00922
00923
00924
00925
00926
00927
00928
00929
00930
00931
00932
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
00965
00966
00967
00968
00969
00970
00971
00972
00973
00974
00975
00976
00977
00978
00979
00980
00981
00982
00983
00984
00985
00986
00987 integer nu, j, hs, ks
00988 double precision dh, dk, r
00989 double precision tpi, pi, ors, hrk, krh, bvt, snu
00990 double precision gmph, gmpk, xnkh, xnhk, qhrk, hkn, hpk, hkrn
00991 double precision btnckh, btnchk, btpdkh, btpdhk, one
00992 parameter ( pi = 3.14159265358979323844d0, tpi = 2*pi, one = 1 )
00993 snu = sqrt( dble(nu) )
00994 ors = 1 - r*r
00995 hrk = dh - r*dk
00996 krh = dk - r*dh
00997 if ( abs(hrk) + ors .gt. 0 ) then
00998 xnhk = hrk**2/( hrk**2 + ors*( nu + dk**2 ) )
00999 xnkh = krh**2/( krh**2 + ors*( nu + dh**2 ) )
01000 else
01001 xnhk = 0
01002 xnkh = 0
01003 end if
01004 hs = sign( one, dh - r*dk )
01005 ks = sign( one, dk - r*dh )
01006 if ( mod( nu, 2 ) .eq. 0 ) then
01007 bvt = atan2( sqrt(ors), -r )/tpi
01008 gmph = dh/sqrt( 16*( nu + dh**2 ) )
01009 gmpk = dk/sqrt( 16*( nu + dk**2 ) )
01010 btnckh = 2*atan2( sqrt( xnkh ), sqrt( 1 - xnkh ) )/pi
01011 btpdkh = 2*sqrt( xnkh*( 1 - xnkh ) )/pi
01012 btnchk = 2*atan2( sqrt( xnhk ), sqrt( 1 - xnhk ) )/pi
01013 btpdhk = 2*sqrt( xnhk*( 1 - xnhk ) )/pi
01014 do j = 1, nu/2
01015 bvt = bvt + gmph*( 1 + ks*btnckh )
01016 bvt = bvt + gmpk*( 1 + hs*btnchk )
01017 btnckh = btnckh + btpdkh
01018 btpdkh = 2*j*btpdkh*( 1 - xnkh )/( 2*j + 1 )
01019 btnchk = btnchk + btpdhk
01020 btpdhk = 2*j*btpdhk*( 1 - xnhk )/( 2*j + 1 )
01021 gmph = gmph*( 2*j - 1 )/( 2*j*( 1 + dh**2/nu ) )
01022 gmpk = gmpk*( 2*j - 1 )/( 2*j*( 1 + dk**2/nu ) )
01023 end do
01024 else
01025 qhrk = sqrt( dh**2 + dk**2 - 2*r*dh*dk + nu*ors )
01026 hkrn = dh*dk + r*nu
01027 hkn = dh*dk - nu
01028 hpk = dh + dk
01029 bvt = atan2(-snu*(hkn*qhrk+hpk*hkrn),hkn*hkrn-nu*hpk*qhrk)/tpi
01030 if ( bvt .lt. -1d-15 ) bvt = bvt + 1
01031 gmph = dh/( tpi*snu*( 1 + dh**2/nu ) )
01032 gmpk = dk/( tpi*snu*( 1 + dk**2/nu ) )
01033 btnckh = sqrt( xnkh )
01034 btpdkh = btnckh
01035 btnchk = sqrt( xnhk )
01036 btpdhk = btnchk
01037 do j = 1, ( nu - 1 )/2
01038 bvt = bvt + gmph*( 1 + ks*btnckh )
01039 bvt = bvt + gmpk*( 1 + hs*btnchk )
01040 btpdkh = ( 2*j - 1 )*btpdkh*( 1 - xnkh )/( 2*j )
01041 btnckh = btnckh + btpdkh
01042 btpdhk = ( 2*j - 1 )*btpdhk*( 1 - xnhk )/( 2*j )
01043 btnchk = btnchk + btpdhk
01044 gmph = 2*j*gmph/( ( 2*j + 1 )*( 1 + dh**2/nu ) )
01045 gmpk = 2*j*gmpk/( ( 2*j + 1 )*( 1 + dk**2/nu ) )
01046 end do
01047 end if
01048 mvbvtl = bvt
01049
01050
01051
01052 end
01053
01054 DOUBLE PRECISION FUNCTION MVCHNV( N, P )
01055
01056
01057
01058
01059
01060 INTEGER I, N, NO
01061 DOUBLE PRECISION P, TWO, R, RO, LRP, LKN, MVPHNV, MVCHNC
01062 PARAMETER ( LRP = -.22579135264472743235D0, TWO = 2 )
01063
01064 SAVE NO, LKN
01065 DATA NO / 0 /
01066 IF ( N .LE. 1 ) THEN
01067 R = -MVPHNV( P/2 )
01068 ELSE IF ( P .LT. 1 ) THEN
01069 IF ( N .EQ. 2 ) THEN
01070 R = SQRT( -2*LOG(P) )
01071 ELSE
01072 IF ( N .NE. NO ) THEN
01073 NO = N
01074 LKN = 0
01075 DO I = N-2, 2, -2
01076 LKN = LKN - LOG( DBLE(I) )
01077 END DO
01078 IF ( MOD( N, 2 ) .EQ. 1 ) LKN = LKN + LRP
01079 END IF
01080 IF ( N .GE. -5*LOG(1-P)/4 ) THEN
01081 R = TWO/( 9*N )
01082 R = N*( -MVPHNV(P)*SQRT(R) + 1 - R )**3
01083 IF ( R .GT. 2*N+6 ) THEN
01084 R = 2*( LKN - LOG(P) ) + ( N - 2 )*LOG(R)
01085 END IF
01086 ELSE
01087 R = EXP( ( LOG( (1-P)*N ) - LKN )*TWO/N )
01088 END IF
01089 R = SQRT(R)
01090 RO = R
01091 R = MVCHNC( LKN, N, P, R )
01092 IF ( ABS( R - RO ) .GT. 1D-6 ) THEN
01093 RO = R
01094 R = MVCHNC( LKN, N, P, R )
01095 IF ( ABS( R - RO ) .GT. 1D-6 ) R = MVCHNC( LKN, N, P, R )
01096 END IF
01097 END IF
01098 ELSE
01099 R = 0
01100 END IF
01101 MVCHNV = R
01102 END
01103
01104 DOUBLE PRECISION FUNCTION MVCHNC( LKN, N, P, R )
01105
01106
01107
01108 INTEGER I, N
01109 DOUBLE PRECISION P, R, LKN, DF, RR, RN, CHI, MVPHI
01110 DOUBLE PRECISION LRP, TWO, AL, DL, AI, BI, CI, DI, EPS
01111 PARAMETER ( LRP = -.22579135264472743235D0, TWO = 2, EPS = 1D-14 )
01112
01113 RR = R*R
01114 IF ( N .LT. 2 ) THEN
01115 CHI = 2*MVPHI(-R)
01116 ELSE IF ( N .LT. 100 ) THEN
01117
01118
01119
01120 RN = 1
01121 DO I = N - 2, 2, -2
01122 RN = 1 + RR*RN/I
01123 END DO
01124 RR = RR/2
01125 IF ( MOD( N, 2 ) .EQ. 0 ) THEN
01126 CHI = EXP( LOG( RN ) - RR )
01127 ELSE
01128 CHI = EXP( LRP + LOG( R*RN ) - RR ) + 2*MVPHI(-R)
01129 ENDIF
01130 ELSE
01131 RR = RR/2
01132 AL = N/TWO
01133 CHI = EXP( -RR + AL*LOG(RR) + LKN + LOG(TWO)*( N - 2 )/2 )
01134 IF ( RR .LT. AL + 1 ) THEN
01135
01136
01137
01138 DL = CHI
01139 DO I = 1, 1000
01140 DL = DL*RR/( AL + I )
01141 CHI = CHI + DL
01142 IF ( ABS( DL*RR/( AL + I + 1 - RR ) ) .LT. EPS ) GO TO 10
01143 END DO
01144 10 CHI = 1 - CHI/AL
01145 ELSE
01146
01147
01148
01149 BI = RR + 1 - AL
01150 CI = 1/EPS
01151 DI = BI
01152 CHI = CHI/BI
01153 DO I = 1, 250
01154 AI = I*( AL - I )
01155 BI = BI + 2
01156 CI = BI + AI/CI
01157 IF ( CI .EQ. 0 ) CI = EPS
01158 DI = BI + AI/DI
01159 IF ( DI .EQ. 0 ) DI = EPS
01160 DL = CI/DI
01161 CHI = CHI*DL
01162 IF ( ABS( DL - 1 ) .LT. EPS ) GO TO 20
01163 END DO
01164 END IF
01165 END IF
01166 20 DF = ( P - CHI )/EXP( LKN + ( N - 1 )*LOG(R) - RR )
01167 MVCHNC = R - DF*( 1 - DF*( R - ( N - 1 )/R )/2 )
01168 END
01169
01170 SUBROUTINE MVKBRV( NDIM, MINVLS, MAXVLS, NF, FUNSUB,
01171 & ABSEPS, RELEPS, ABSERR, FINEST, INFORM )
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 EXTERNAL FUNSUB
01230 DOUBLE PRECISION ABSEPS, RELEPS, FINEST(*), ABSERR, ONE
01231 INTEGER NDIM, NF, MINVLS, MAXVLS, INFORM, NP, PLIM, KLIM,
01232 & NLIM, FLIM, SAMPLS, I, K, INTVLS, MINSMP, KMX
01233 PARAMETER ( PLIM = 28, NLIM = 1000, KLIM = 100, FLIM = 5000 )
01234 PARAMETER ( MINSMP = 8 )
01235 INTEGER P(PLIM), C(PLIM,KLIM-1), PR(NLIM)
01236 DOUBLE PRECISION DIFINT, FINVAL(FLIM), VARSQR(FLIM), VAREST(FLIM),
01237 & VARPRD, X(NLIM), R(NLIM), VK(NLIM), VALUES(FLIM), FS(FLIM)
01238 PARAMETER ( ONE = 1 )
01239 SAVE P, C, SAMPLS, NP, VAREST
01240 INFORM = 1
01241 INTVLS = 0
01242 VARPRD = 0
01243 IF ( MINVLS .GE. 0 ) THEN
01244 DO K = 1, NF
01245 FINEST(K) = 0
01246 VAREST(K) = 0
01247 END DO
01248 SAMPLS = MINSMP
01249 DO I = MIN( NDIM, 10 ), PLIM
01250 NP = I
01251 IF ( MINVLS .LT. 2*SAMPLS*P(I) ) GO TO 10
01252 END DO
01253 SAMPLS = MAX( MINSMP, MINVLS/( 2*P(NP) ) )
01254 ENDIF
01255 10 VK(1) = ONE/P(NP)
01256 K = 1
01257 DO I = 2, NDIM
01258 IF ( I .LE. KLIM ) THEN
01259 K = MOD( C(NP, MIN(NDIM-1,KLIM-1))*DBLE(K), DBLE(P(NP)) )
01260 VK(I) = K*VK(1)
01261 ELSE
01262 VK(I) = INT( P(NP)*2**( DBLE(I-KLIM)/(NDIM-KLIM+1) ) )
01263 VK(I) = MOD( VK(I)/P(NP), ONE )
01264 END IF
01265 END DO
01266 DO K = 1, NF
01267 FINVAL(K) = 0
01268 VARSQR(K) = 0
01269 END DO
01270
01271 DO I = 1, SAMPLS
01272 CALL MVKRSV( NDIM,KLIM,VALUES, P(NP),VK, NF,FUNSUB, X,R,PR,FS )
01273 DO K = 1, NF
01274 DIFINT = ( VALUES(K) - FINVAL(K) )/I
01275 FINVAL(K) = FINVAL(K) + DIFINT
01276 VARSQR(K) = ( I - 2 )*VARSQR(K)/I + DIFINT**2
01277 END DO
01278 END DO
01279
01280 INTVLS = INTVLS + 2*SAMPLS*P(NP)
01281 KMX = 1
01282 DO K = 1, NF
01283 VARPRD = VAREST(K)*VARSQR(K)
01284 FINEST(K) = FINEST(K) + ( FINVAL(K) - FINEST(K) )/( 1+VARPRD )
01285 IF ( VARSQR(K) .GT. 0 ) VAREST(K) = ( 1 + VARPRD )/VARSQR(K)
01286 IF ( ABS(FINEST(K)) .GT. ABS(FINEST(KMX)) ) KMX = K
01287 END DO
01288 ABSERR = 7*SQRT( VARSQR(KMX)/( 1 + VARPRD ) )/2
01289 IF ( ABSERR .GT. MAX( ABSEPS, ABS(FINEST(KMX))*RELEPS ) ) THEN
01290 IF ( NP .LT. PLIM ) THEN
01291 NP = NP + 1
01292 ELSE
01293 SAMPLS = MIN( 3*SAMPLS/2, ( MAXVLS - INTVLS )/( 2*P(NP) ) )
01294 SAMPLS = MAX( MINSMP, SAMPLS )
01295 ENDIF
01296 IF ( INTVLS + 2*SAMPLS*P(NP) .LE. MAXVLS ) GO TO 10
01297 ELSE
01298 INFORM = 0
01299 ENDIF
01300 MINVLS = INTVLS
01301
01302
01303
01304 DATA P( 1),(C( 1,I),I = 1,99)/ 31, 12, 2*9, 13, 8*12, 3*3, 12,
01305 & 2*7, 9*12, 3*3, 12, 2*7, 9*12, 3*3, 12, 2*7, 9*12, 3*3, 12, 2*7,
01306 & 8*12, 7, 3*3, 3*7, 21*3/
01307 DATA P( 2),(C( 2,I),I = 1,99)/ 47, 13, 11, 17, 10, 6*15,
01308 & 22, 2*15, 3*6, 2*15, 9, 13, 3*2, 13, 2*11, 10, 9*15, 3*6, 2*15,
01309 & 9, 13, 3*2, 13, 2*11, 10, 9*15, 3*6, 2*15, 9, 13, 3*2, 13, 2*11,
01310 & 2*10, 8*15, 6, 2, 3, 2, 3, 12*2/
01311 DATA P( 3),(C( 3,I),I = 1,99)/ 73, 27, 28, 10, 2*11, 20,
01312 & 2*11, 28, 2*13, 28, 3*13, 16*14, 2*31, 3*5, 31, 13, 6*11, 7*13,
01313 & 16*14, 2*31, 3*5, 11, 13, 7*11, 2*13, 11, 13, 4*5, 14, 13, 8*5/
01314 DATA P( 4),(C( 4,I),I = 1,99)/ 113, 35, 2*27, 36, 22, 2*29,
01315 & 20, 45, 3*5, 16*21, 29, 10*17, 12*23, 21, 27, 3*3, 24, 2*27,
01316 & 17, 3*29, 17, 4*5, 16*21, 3*17, 6, 2*17, 6, 3, 2*6, 5*3/
01317 DATA P( 5),(C( 5,I),I = 1,99)/ 173, 64, 66, 2*28, 2*44, 55,
01318 & 67, 6*10, 2*38, 5*10, 12*49, 2*38, 31, 2*4, 31, 64, 3*4, 64,
01319 & 6*45, 19*66, 11, 9*66, 45, 11, 7, 3, 3*2, 27, 5, 2*3, 2*5, 7*2/
01320 DATA P( 6),(C( 6,I),I = 1,99)/ 263, 111, 42, 54, 118, 20,
01321 & 2*31, 72, 17, 94, 2*14, 11, 3*14, 94, 4*10, 7*14, 3*11, 7*8,
01322 & 5*18, 113, 2*62, 2*45, 17*113, 2*63, 53, 63, 15*67, 5*51, 12,
01323 & 51, 12, 51, 5, 2*3, 2*2, 5/
01324 DATA P( 7),(C( 7,I),I = 1,99)/ 397, 163, 154, 83, 43, 82,
01325 & 92, 150, 59, 2*76, 47, 2*11, 100, 131, 6*116, 9*138, 21*101,
01326 & 6*116, 5*100, 5*138, 19*101, 8*38, 5*3/
01327 DATA P( 8),(C( 8,I),I = 1,99)/ 593, 246, 189, 242, 102,
01328 & 2*250, 102, 250, 280, 118, 196, 118, 191, 215, 2*121,
01329 & 12*49, 34*171, 8*161, 17*14, 6*10, 103, 4*10, 5/
01330 DATA P( 9),(C( 9,I),I = 1,99)/ 907, 347, 402, 322, 418,
01331 & 215, 220, 3*339, 337, 218, 4*315, 4*167, 361, 201, 11*124,
01332 & 2*231, 14*90, 4*48, 23*90, 10*243, 9*283, 16, 283, 16, 2*283/
01333 DATA P(10),(C(10,I),I = 1,99)/ 1361, 505, 220, 601, 644,
01334 & 612, 160, 3*206, 422, 134, 518, 2*134, 518, 652, 382,
01335 & 206, 158, 441, 179, 441, 56, 2*559, 14*56, 2*101, 56,
01336 & 8*101, 7*193, 21*101, 17*122, 4*101/
01337 DATA P(11),(C(11,I),I = 1,99)/ 2053, 794, 325, 960, 528,
01338 & 2*247, 338, 366, 847, 2*753, 236, 2*334, 461, 711, 652,
01339 & 3*381, 652, 7*381, 226, 7*326, 126, 10*326, 2*195, 19*55,
01340 & 7*195, 11*132, 13*387/
01341 DATA P(12),(C(12,I),I = 1,99)/ 3079, 1189, 888, 259, 1082, 725,
01342 & 811, 636, 965, 2*497, 2*1490, 392, 1291, 2*508, 2*1291, 508,
01343 & 1291, 2*508, 4*867, 934, 7*867, 9*1284, 4*563, 3*1010, 208,
01344 & 838, 3*563, 2*759, 564, 2*759, 4*801, 5*759, 8*563, 22*226/
01345 DATA P(13),(C(13,I),I = 1,99)/ 4621, 1763, 1018, 1500, 432,
01346 & 1332, 2203, 126, 2240, 1719, 1284, 878, 1983, 4*266,
01347 & 2*747, 2*127, 2074, 127, 2074, 1400, 10*1383, 1400, 7*1383,
01348 & 507, 4*1073, 5*1990, 9*507, 17*1073, 6*22, 1073, 6*452, 318,
01349 & 4*301, 2*86, 15/
01350 DATA P(14),(C(14,I),I = 1,99)/ 6947, 2872, 3233, 1534, 2941,
01351 & 2910, 393, 1796, 919, 446, 2*919, 1117, 7*103, 2311, 3117, 1101,
01352 & 2*3117, 5*1101, 8*2503, 7*429, 3*1702, 5*184, 34*105, 13*784/
01353 DATA P(15),(C(15,I),I = 1,99)/ 10427, 4309, 3758, 4034, 1963,
01354 & 730, 642, 1502, 2246, 3834, 1511, 2*1102, 2*1522, 2*3427,
01355 & 3928, 2*915, 4*3818, 3*4782, 3818, 4782, 2*3818, 7*1327, 9*1387,
01356 & 13*2339, 18*3148, 3*1776, 3*3354, 925, 2*3354, 5*925, 8*2133/
01357 DATA P(16),(C(16,I),I = 1,99)/ 15641, 6610, 6977, 1686, 3819,
01358 & 2314, 5647, 3953, 3614, 5115, 2*423, 5408, 7426, 2*423,
01359 & 487, 6227, 2660, 6227, 1221, 3811, 197, 4367, 351,
01360 & 1281, 1221, 3*351, 7245, 1984, 6*2999, 3995, 4*2063, 1644,
01361 & 2063, 2077, 3*2512, 4*2077, 19*754, 2*1097, 4*754, 248, 754,
01362 & 4*1097, 4*222, 754,11*1982/
01363 DATA P(17),(C(17,I),I = 1,99)/ 23473, 9861, 3647, 4073, 2535,
01364 & 3430, 9865, 2830, 9328, 4320, 5913, 10365, 8272, 3706, 6186,
01365 & 3*7806, 8610, 2563, 2*11558, 9421, 1181, 9421, 3*1181, 9421,
01366 & 2*1181, 2*10574, 5*3534, 3*2898, 3450, 7*2141, 15*7055, 2831,
01367 & 24*8204, 3*4688, 8*2831/
01368 DATA P(18),(C(18,I),I = 1,99)/ 35221, 10327, 7582, 7124, 8214,
01369 & 9600, 10271, 10193, 10800, 9086, 2365, 4409, 13812,
01370 & 5661, 2*9344, 10362, 2*9344, 8585, 11114, 3*13080, 6949,
01371 & 3*3436, 13213, 2*6130, 2*8159, 11595, 8159, 3436, 18*7096,
01372 & 4377, 7096, 5*4377, 2*5410, 32*4377, 2*440, 3*1199/
01373 DATA P(19),(C(19,I),I = 1,99)/ 52837, 19540, 19926, 11582,
01374 & 11113, 24585, 8726, 17218, 419, 3*4918, 15701, 17710,
01375 & 2*4037, 15808, 11401, 19398, 2*25950, 4454, 24987, 11719,
01376 & 8697, 5*1452, 2*8697, 6436, 21475, 6436, 22913, 6434, 18497,
01377 & 4*11089, 2*3036, 4*14208, 8*12906, 4*7614, 6*5021, 24*10145,
01378 & 6*4544, 4*8394/
01379 DATA P(20),(C(20,I),I = 1,99)/ 79259, 34566, 9579, 12654,
01380 & 26856, 37873, 38806, 29501, 17271, 3663, 10763, 18955,
01381 & 1298, 26560, 2*17132, 2*4753, 8713, 18624, 13082, 6791,
01382 & 1122, 19363, 34695, 4*18770, 15628, 4*18770, 33766, 6*20837,
01383 & 5*6545, 14*12138, 5*30483, 19*12138, 9305, 13*11107, 2*9305/
01384 DATA P(21),(C(21,I),I = 1,99)/118891, 31929, 49367, 10982, 3527,
01385 & 27066, 13226, 56010, 18911, 40574, 2*20767, 9686, 2*47603,
01386 & 2*11736, 41601, 12888, 32948, 30801, 44243, 2*53351, 16016,
01387 & 2*35086, 32581, 2*2464, 49554, 2*2464, 2*49554, 2464, 81, 27260,
01388 & 10681, 7*2185, 5*18086, 2*17631, 3*18086, 37335, 3*37774,
01389 & 13*26401, 12982, 6*40398, 3*3518, 9*37799, 4*4721, 4*7067/
01390 DATA P(22),(C(22,I),I = 1,99)/178349, 40701, 69087, 77576, 64590,
01391 & 39397, 33179, 10858, 38935, 43129, 2*35468, 5279, 2*61518, 27945,
01392 & 2*70975, 2*86478, 2*20514, 2*73178, 2*43098, 4701,
01393 & 2*59979, 58556, 69916, 2*15170, 2*4832, 43064, 71685, 4832,
01394 & 3*15170, 3*27679, 2*60826, 2*6187, 5*4264, 45567, 4*32269,
01395 & 9*62060, 13*1803, 12*51108, 2*55315, 5*54140, 13134/
01396 DATA P(23),(C(23,I),I = 1,99)/267523, 103650, 125480, 59978,
01397 & 46875, 77172, 83021, 126904, 14541, 56299, 43636, 11655,
01398 & 52680, 88549, 29804, 101894, 113675, 48040, 113675,
01399 & 34987, 48308, 97926, 5475, 49449, 6850, 2*62545, 9440,
01400 & 33242, 9440, 33242, 9440, 33242, 9440, 62850, 3*9440,
01401 & 3*90308, 9*47904, 7*41143, 5*36114, 24997, 14*65162, 7*47650,
01402 & 7*40586, 4*38725, 5*88329/
01403 DATA P(24),(C(24,I),I = 1,99)/401287, 165843, 90647, 59925,
01404 & 189541, 67647, 74795, 68365, 167485, 143918, 74912,
01405 & 167289, 75517, 8148, 172106, 126159,3*35867, 121694,
01406 & 52171, 95354, 2*113969, 76304, 2*123709, 144615, 123709,
01407 & 2*64958, 32377, 2*193002, 25023, 40017, 141605, 2*189165,
01408 & 141605, 2*189165, 3*141605, 189165, 20*127047, 10*127785,
01409 & 6*80822, 16*131661, 7114, 131661/
01410 DATA P(25),(C(25,I),I = 1,99)/601943, 130365, 236711, 110235,
01411 & 125699, 56483, 93735, 234469, 60549, 1291, 93937,
01412 & 245291, 196061, 258647, 162489, 176631, 204895, 73353,
01413 & 172319, 28881, 136787,2*122081, 275993, 64673, 3*211587,
01414 & 2*282859, 211587, 242821, 3*256865, 122203, 291915, 122203,
01415 & 2*291915, 122203, 2*25639, 291803, 245397, 284047,
01416 & 7*245397, 94241, 2*66575, 19*217673, 10*210249, 15*94453/
01417 DATA P(26),(C(26,I),I = 1,99)/902933, 333459, 375354, 102417,
01418 & 383544, 292630, 41147, 374614, 48032, 435453, 281493, 358168,
01419 & 114121, 346892, 238990, 317313, 164158, 35497, 2*70530, 434839,
01420 & 3*24754, 393656, 2*118711, 148227, 271087, 355831, 91034,
01421 & 2*417029, 2*91034, 417029, 91034, 2*299843, 2*413548, 308300,
01422 & 3*413548, 3*308300, 413548, 5*308300, 4*15311, 2*176255, 6*23613,
01423 & 172210, 4* 204328, 5*121626, 5*200187, 2*121551, 12*248492,
01424 & 5*13942/
01425 DATA P(27), (C(27,I), I = 1,99)/ 1354471, 500884, 566009, 399251,
01426 & 652979, 355008, 430235, 328722, 670680, 2*405585, 424646,
01427 & 2*670180, 641587, 215580, 59048, 633320, 81010, 20789, 2*389250,
01428 & 2*638764, 2*389250, 398094, 80846, 2*147776, 296177, 2*398094,
01429 & 2*147776, 396313, 3*578233, 19482, 620706, 187095, 620706,
01430 & 187095, 126467, 12*241663, 321632, 2*23210, 3*394484, 3*78101,
01431 & 19*542095, 3*277743, 12*457259/
01432 DATA P(28), (C(28,I), I = 1, 99)/ 2031713, 858339, 918142, 501970,
01433 & 234813, 460565, 31996, 753018, 256150, 199809, 993599, 245149,
01434 & 794183, 121349, 150619, 376952, 2*809123, 804319, 67352, 969594,
01435 & 434796, 969594, 804319, 391368, 761041, 754049, 466264, 2*754049,
01436 & 466264, 2*754049, 282852, 429907, 390017, 276645, 994856, 250142,
01437 & 144595, 907454, 689648, 4*687580, 978368, 687580, 552742, 105195,
01438 & 942843, 768249, 4*307142, 7*880619, 11*117185, 11*60731,
01439 & 4*178309, 8*74373, 3*214965/
01440
01441 END
01442
01443 SUBROUTINE MVKRSV( NDIM,KL,VALUES,PRIME,VK, NF,FUNSUB, X,R,PR,FS )
01444
01445
01446
01447 INTEGER NDIM, NF, PRIME, KL, K, J, JP, PR(*)
01448 DOUBLE PRECISION VALUES(*), VK(*), FS(*), X(*), R(*), MVUNI
01449 DO J = 1, NF
01450 VALUES(J) = 0
01451 END DO
01452
01453
01454
01455 DO J = 1, NDIM
01456 R(J) = MVUNI()
01457 IF ( J .LT. KL ) THEN
01458 JP = 1 + J*R(J)
01459 IF ( JP .LT. J ) PR(J) = PR(JP)
01460 PR(JP) = J
01461 ELSE
01462 PR(J) = J
01463 END IF
01464 END DO
01465
01466
01467
01468 DO K = 1, PRIME
01469 DO J = 1, NDIM
01470 R(J) = R(J) + VK(PR(J))
01471 IF ( R(J) .GT. 1 ) R(J) = R(J) - 1
01472 X(J) = ABS( 2*R(J) - 1 )
01473 END DO
01474 CALL FUNSUB( NDIM, X, NF, FS )
01475 DO J = 1, NF
01476 VALUES(J) = VALUES(J) + ( FS(J) - VALUES(J) )/( 2*K-1 )
01477 END DO
01478 DO J = 1, NDIM
01479 X(J) = 1 - X(J)
01480 END DO
01481 CALL FUNSUB( NDIM, X, NF, FS )
01482 DO J = 1, NF
01483 VALUES(J) = VALUES(J) + ( FS(J) - VALUES(J) )/( 2*K )
01484 END DO
01485 END DO
01486
01487 END
01488
01489 DOUBLE PRECISION FUNCTION MVUNI()
01490
01491
01492
01493
01494
01495
01496 DOUBLE PRECISION unifrnd, x
01497
01498 x = unifrnd()
01499 MVUNI = x
01500 END