mvt.f

Go to the documentation of this file.
00001 *
00002 *    $Id: mvt.f 195 2009-03-25 11:39:37Z thothorn $
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 *     "Comparison of Methods for the Computation of Multivariate 
00010 *         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/10 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 
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 *           Call the lattice rule integration subroutine
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 *     Integrand subroutine
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 *     Entry point for intialization.
00107 *
00108       ENTRY MVINTS( N, NUIN, CORREL, LOWER, UPPER, DELTA, INFIN, 
00109      &     ND, VL, ER, INFORM )
00110 *
00111 *     Initialization and computation of covariance Cholesky factor.
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 *     Special cases subroutine
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 *        Special cases
00132 *
00133          IF ( ND .EQ. 0 ) THEN
00134             ER = 0
00135 *  Code added to fix ND = 0 bug, 24/03/2009 ->
00136             VL = 1
00137 *  <- Code added to fix ND = 0 bug, 24/03/2009
00138 
00139          ELSE IF ( ND.EQ.1 .AND. ( NU.LT.1 .OR. ABS(DL(1)).EQ.0 ) ) THEN
00140 *     
00141 *           1-d case for normal or central t
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 *           2-d case for normal or central t
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 *              2-d nonsingular case
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 *              2-d singular case
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 *     Integrand subroutine
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 *     Subroutine to sort integration limits and determine Cholesky factor.
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 *     First move any doubly infinite limits to innermost positions.
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 *     Sort remaining limits and determine Cholesky factor.
00306 *
00307          II = 0
00308          JL = ND
00309          DO I = 1, ND
00310 *
00311 *        Determine the integration limits for variable with minimum
00312 *        expected probability and interchange that variable with Ith.
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 *        Compute Ith column of Cholesky factor.
00349 *        Compute expected value for Ith integration variable and
00350 *         scale Ith covariance matrix row and limits.
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 *              Expected Y = -( density(b) - density(a) )/( b - a )
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 *        If the covariance matrix diagonal entry is zero, 
00391 *         permute limits and rows, if necessary.
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 *     Swaps rows and columns P and Q in situ, with P <= Q.
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 *     Normal distribution probabilities accurate to 1d-15.
00509 *     Reference: J.L. Schonfelder, Math Comp 32(1978), pp 1232-1240. 
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 *       ALGORITHM AS241  APPL. STATIST. (1988) VOL. 37, NO. 3
00559 *
00560 *       Produces the normal deviate Z corresponding to a given lower
00561 *       tail area of P.
00562 *
00563 *       The hash sums below are the sums of the mantissas of the
00564 *       coefficients.   They are included for use in checking
00565 *       transcription.
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 *     Coefficients for P close to 0.5
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 *     HASH SUM AB    55.88319 28806 14901 4439
00594 *     
00595 *     Coefficients for P not close to 0, 0.5 or 1.
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 *     HASH SUM CD    49.33206 50330 16102 89036
00614 *
00615 *       Coefficients for P near 0 or 1.
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 *     HASH SUM EF    47.52583 31754 92896 71629
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 *     A function for computing bivariate normal probabilities.
00668 *
00669 *  Parameters
00670 *
00671 *     LOWER  REAL, array of lower integration limits.
00672 *     UPPER  REAL, array of upper integration limits.
00673 *     INFIN  INTEGER, array of integration limits flags:
00674 *            if INFIN(I) = 0, Ith limits are (-infinity, UPPER(I)];
00675 *            if INFIN(I) = 1, Ith limits are [LOWER(I), infinity);
00676 *            if INFIN(I) = 2, Ith limits are [LOWER(I), UPPER(I)].
00677 *     CORREL REAL, correlation coefficient.
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 *     A function for computing bivariate normal probabilities;
00713 *       developed using 
00714 *         Drezner, Z. and Wesolowsky, G. O. (1989),
00715 *         On the Computation of the Bivariate Normal Integral,
00716 *         J. Stat. Comput. Simul.. 35 pp. 101-107.
00717 *       with extensive modications for double precisions by    
00718 *         Alan Genz and Yihong Ge
00719 *         Department of Mathematics
00720 *         Washington State University
00721 *         Pullman, WA 99164-3113
00722 *         Email : alangenz@wsu.edu
00723 *
00724 * BVN - calculate the probability that X is larger than SH and Y is
00725 *       larger than SK.
00726 *
00727 * Parameters
00728 *
00729 *   SH  REAL, integration limit
00730 *   SK  REAL, integration limit
00731 *   R   REAL, correlation coefficient
00732 *   LG  INTEGER, number of Gauss Rule Points and Weights
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 *     Gauss Legendre Points and Weights, N =  6
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 *     Gauss Legendre Points and Weights, N = 12
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 *     Gauss Legendre Points and Weights, N = 20
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 *     Student t Distribution Function
00831 *
00832 *                       T
00833 *         TSTDNT = C   I  ( 1 + y*y/NU )**( -(NU+1)/2 ) dy
00834 *                   NU -INF
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 *     A function for computing bivariate normal and t probabilities.
00867 *
00868 *  Parameters
00869 *
00870 *     NU     INTEGER degrees of freedom parameter; NU < 1 gives normal case.
00871 *     LOWER  REAL, array of lower integration limits.
00872 *     UPPER  REAL, array of upper integration limits.
00873 *     INFIN  INTEGER, array of integration limits flags:
00874 *            if INFIN(I) = 0, Ith limits are (-infinity, UPPER(I)];
00875 *            if INFIN(I) = 1, Ith limits are [LOWER(I), infinity);
00876 *            if INFIN(I) = 2, Ith limits are [LOWER(I), UPPER(I)].
00877 *     CORREL REAL, correlation coefficient.
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 *     A function for computing complementary bivariate normal and t 
00918 *       probabilities.
00919 *
00920 *  Parameters
00921 *
00922 *     NU     INTEGER degrees of freedom parameter.
00923 *     L      REAL, array of lower integration limits.
00924 *     U      REAL, array of upper integration limits.
00925 *     INFIN  INTEGER, array of integration limits flags:
00926 *            if INFIN(1) INFIN(2),        then MVBVTC computes
00927 *                 0         0              P( X>U(1), Y>U(2) )
00928 *                 1         0              P( X<L(1), Y>U(2) )
00929 *                 0         1              P( X>U(1), Y<L(2) )
00930 *                 1         1              P( X<L(1), Y<L(2) )
00931 *                 2         0      P( X>U(1), Y>U(2) ) + P( X<L(1), Y>U(2) )
00932 *                 2         1      P( X>U(1), Y<L(2) ) + P( X<L(1), Y<L(2) )
00933 *                 0         2      P( X>U(1), Y>U(2) ) + P( X>U(1), Y<L(2) )
00934 *                 1         2      P( X<L(1), Y>U(2) ) + P( X<L(1), Y<L(2) )
00935 *                 2         2      P( X>U(1), Y<L(2) ) + P( X<L(1), Y<L(2) )
00936 *                               +  P( X>U(1), Y>U(2) ) + P( X<L(1), Y>U(2) )
00937 *
00938 *     RHO    REAL, correlation coefficient.
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 *     a function for computing bivariate t probabilities.
00971 *
00972 *       Alan Genz
00973 *       Department of Mathematics
00974 *       Washington State University
00975 *       Pullman, Wa 99164-3113
00976 *       Email : alangenz@wsu.edu
00977 *
00978 *    this function is based on the method described by 
00979 *        Dunnett, C.W. and M. Sobel, (1954),
00980 *        A bivariate generalization of Student's t-distribution
00981 *        with tables for certain special cases,
00982 *        Biometrika 41, pp. 153-169.
00983 *
00984 * mvbvtl - calculate the probability that x < dh and y < dk. 
00985 *
00986 * parameters
00987 *
00988 *   nu number of degrees of freedom
00989 *   dh 1st lower integration limit
00990 *   dk 2nd lower integration limit
00991 *   r   correlation coefficient
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 *     end mvbvtl
01057 *
01058       end
01059 *
01060       DOUBLE PRECISION FUNCTION MVCHNV( N, P )
01061 *
01062 *                  MVCHNV
01063 *     P =  1 - K  I     exp(-t*t/2) t**(N-1) dt, for N >= 1.
01064 *               N  0
01065 *
01066       INTEGER I, N, NO
01067       DOUBLE PRECISION P, TWO, R, RO, LRP, LKN, MVPHNV, MVCHNC
01068       PARAMETER ( LRP = -.22579135264472743235D0, TWO = 2 )
01069 *                 LRP =   LOG( SQRT( 2/PI ) )
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 *     Third order Schroeder correction to R for MVCHNV
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 *                 LRP =   LOG( SQRT( 2/PI ) )
01119       RR = R*R
01120       IF ( N .LT. 2 ) THEN
01121          CHI = 2*MVPHI(-R)
01122       ELSE IF ( N .LT. 100 ) THEN
01123 *
01124 *        Use standard Chi series
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 *           Use Incomplete Gamma series
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 *           Use Incomplete Gamma continued fraction
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 *  Automatic Multidimensional Integration Subroutine
01180 *               
01181 *         AUTHOR: Alan Genz
01182 *                 Department of Mathematics
01183 *                 Washington State University
01184 *                 Pulman, WA 99164-3113
01185 *                 Email: AlanGenz@wsu.edu
01186 *
01187 *         Last Change: 12/15/00
01188 *
01189 *  MVKBRV computes an approximation to the integral
01190 *
01191 *      1  1     1
01192 *     I  I ... I       F(X)  dx(NDIM)...dx(2)dx(1)
01193 *      0  0     0
01194 *
01195 *    F(X) is a real NF-vector of integrands.
01196 *
01197 *  It uses randomized Korobov rules. The primary references are
01198 *   "Randomization of Number Theoretic Methods for Multiple Integration"
01199 *    R. Cranley and T.N.L. Patterson, SIAM J Numer Anal, 13, pp. 904-14,
01200 *  and 
01201 *   "Optimal Parameters for Multidimensional Integration", 
01202 *    P. Keast, SIAM J Numer Anal, 10, pp.831-838.
01203 *  If there are more than 100 variables, the remaining variables are
01204 *  integrated using the rules described in the reference
01205 *   "On a Number-Theoretical Integration Method"
01206 *   H. Niederreiter, Aequationes Mathematicae, 8(1972), pp. 304-11.
01207 *
01208 ***************  Parameters ********************************************
01209 ****** Input parameters
01210 *  NDIM    Number of variables, must exceed 1, but not exceed 100
01211 *  MINVLS  Integer minimum number of function evaluations allowed.
01212 *          MINVLS must not exceed MAXVLS.  If MINVLS < 0 then the
01213 *          routine assumes a previous call has been made with 
01214 *          the same integrands and continues that calculation.
01215 *  MAXVLS  Integer maximum number of function evaluations allowed.
01216 *  NF      Number of integrands, must exceed 1, but not exceed 5000
01217 *  FUNSUB  EXTERNALly declared user defined integrand subroutine.
01218 *          It must have parameters ( NDIM, Z, NF, FUNVLS ), where 
01219 *          Z is a real NDIM-vector and FUNVLS is a real NF-vector.
01220 *                                     
01221 *  ABSEPS  Required absolute accuracy.
01222 *  RELEPS  Required relative accuracy.
01223 ****** Output parameters
01224 *  MINVLS  Actual number of function evaluations used.
01225 *  ABSERR  Maximum norm of estimated absolute accuracy of FINEST.
01226 *  FINEST  Estimated NF-vector of values of the integrals.
01227 *  INFORM  INFORM = 0 for normal exit, when 
01228 *                     ABSERR <= MAX(ABSEPS, RELEPS*||FINEST||)
01229 *                  and 
01230 *                     INTVLS <= MAXCLS.
01231 *          INFORM = 1 If MAXVLS was too small to obtain the required 
01232 *          accuracy. In this case a value FINEST is returned with 
01233 *          estimated absolute accuracy ABSERR.
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 *    Optimal Parameters for Lattice Rules
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 *     For lattice rule sums
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 *     Determine random shifts for each variable; scramble lattice rule
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 *     Compute latice rule sums
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 *     Uniform (0,1) random number generator
01498 *
01499 *     use R's random number generator directly
01500 *     the way `Writing R extentions' advertises.
01501 *
01502       DOUBLE PRECISION unifrnd, x
01503 
01504       x = unifrnd()
01505       MVUNI = x
01506       END
Generated on Tue Jul 6 16:21:02 2010 for party by  doxygen 1.6.3