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