mvt.f

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

Generated on Tue Jun 16 09:15:20 2009 for party by  doxygen 1.5.8