Math-Random-0.71/040755 017522 000266 00000000000 11064014750 013234 5ustar00yxrdss000000 000000 Math-Random-0.71/test2.pl100644 017522 000266 00000006633 11064014433 014635 0ustar00yxrdss000000 000000 # Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl test.pl' #------ Tests for revised version of phrtsd ################# We start with some black magic to print on failure. BEGIN { $| = 1; print "1..16\n"; } END {print "not ok 1\n" unless $loaded;} use Math::Random qw(:all); $loaded = 1; print "ok 1\n"; ################# End of black magic. #------ SUBROUTINES #--- Compare two 3-element arrays for equality to 5 decimal places. sub eq5a { $a0 = sprintf("%.5f", $_[0]); $a1 = sprintf("%.5f", $_[1]); $a2 = sprintf("%.5f", $_[2]); $b0 = sprintf("%.5f", $_[3]); $b1 = sprintf("%.5f", $_[4]); $b2 = sprintf("%.5f", $_[5]); return ($a0 eq $b0) && ($a1 eq $b1) && ($a2 eq $b2); } sub was_it_ok { my ($num, $test) = @_; if ($test) { print "ok $num\n"; } else { print "not ok $num\n"; $failed++; } } #------ TESTS # NOTE: Do not change the order of these tests!! Since at least # one new variate is produced every time, the results will differ # if the order is changed. If new tests have to be added, add them # at the end. $failed = 0; random_set_seed_from_phrase("En arkhe en ho Logos"); print "random_uniform.................."; @result = random_uniform(3, 0, 1.5); was_it_ok(2, eq5a(@result, 0.05617, 0.51721, 0.83203)); print "random_uniform_integer.........."; @result = random_uniform_integer(3, 1, 999999); was_it_ok(3, eq5a(@result, 134416, 581232, 488982)); print "random_permutation.............."; @result = random_permutation(qw[A 2 c iv E 6 g viii]); was_it_ok(4, "@result" eq "A g E 6 viii 2 c iv"); print "random_permuted_index..........."; @result = random_permuted_index(9); was_it_ok(5, "@result" eq "3 7 6 8 1 0 2 5 4"); print "random_normal..................."; @result = random_normal(3, 50, 2.3); was_it_ok(6, eq5a(@result, 51.32045, 52.86931, 51.42714)); print "random_chi_square..............."; @result = random_chi_square(3, 4); was_it_ok(7, eq5a(@result, 3.06391, 2.69547, 3.06120)); print "random_f........................"; @result = random_f(3, 2, 5); was_it_ok(8, eq5a(@result, 20.49306, 1.76842, 0.18747)); print "random_beta....................."; @result = random_beta(3, 17, 23); was_it_ok(9, eq5a(@result, 0.42553, 0.39371, 0.35722)); print "random_binomial................."; @result = random_binomial(3, 31, 0.43); was_it_ok(10, eq5a(@result, 14, 13, 10)); print "random_poisson.................."; @result = random_poisson(3, 555); was_it_ok(11, eq5a(@result, 510, 557, 536)); print "random_exponential.............."; @result = random_exponential(3, 444); was_it_ok(12, eq5a(@result, 127.98662, 8.24119, 397.19221)); print "random_gamma...................."; @result = random_gamma(3, 11, 4); was_it_ok(13, eq5a(@result, 0.47858, 0.32865, 0.56708)); print "random_multinomial.............."; @result = random_multinomial(3, 0.1, 0.72, 0.18); was_it_ok(14, eq5a(@result, 0, 2, 1)); print "random_negative_binomial........"; @result = random_negative_binomial(3, 10, 0.63); was_it_ok(15, eq5a(@result, 0, 2, 5)); print "random_multivariate_normal......"; @result = random_multivariate_normal(2,1,1, [0.1,0.0], [0.0,0.1]); @result = (map { @$_ } @result); was_it_ok(16, eq5a(@result[0..2], -0.06076, 0.89337, 1.51428)); if ($failed == 0) { print "All tests successful.\n" } else { $tt = ($failed == 1) ? "1 test" : "$failed tests"; print "$tt failed! There is no joy in Mudville.\n"; } Math-Random-0.71/helper.c100644 017522 000266 00000020244 11064014433 014654 0ustar00yxrdss000000 000000 /* NOTE: RETURN CODES HAVE BEEN CHANGED TO MATCH PERL, I.E. 1 - NOW MEANS OK 0 - NOW MEANS ERROR */ #include "randlib.h" #include #include #include "helper.h" static long *iwork = NULL; /* perl long array, alloc. in 'rspriw' */ static double *fwork = NULL; /* perl float array, alloc. in 'rsprfw' */ static double *parm = NULL; /* maintained by 'psetmn' for 'pgenmn' */ /**************************************************************************** Perl <-> C (Long) Integer Helper Functions (these pass single values back and forth, to load/read/manage working array) ****************************************************************************/ long gvpriw(long index) { /* Gets the Value at index of the PeRl (long) Integer Working array */ extern long *iwork; return *(iwork + index); } int rspriw(long size) { /* Request Size for PeRl's (long) int Working array * returns: * 1 if successful * 0 if out of memory */ extern long *iwork; static long siwork = 0L; if (size <= siwork) return 1; /* else reset array */ if (iwork != NULL) free(iwork); iwork = (long *) malloc(sizeof(long) * size); if (iwork != NULL) { siwork = size; return 1; } fputs(" Unable to allocate randlib (long) int working array:\n",stderr); fprintf(stderr," Requested number of entries = %ld\n",size); fputs(" Out of memory in RSPRIW - ABORT\n",stderr); siwork = 0L; return 0; } /**************************************************************************** Perl <-> C Float Helper Functions (these pass single values back and forth, to load/read/manage working array) ****************************************************************************/ double gvprfw(long index) { /* Gets the Value at index of the PeRl Float Working array */ extern double *fwork; return *(fwork + index); } void svprfw(long index, double value) { /* Sets Value in PeRl's Float Working array */ extern double *fwork; *(fwork + index) = value; } int rsprfw(long size) { /* Request Size for PeRl's Float Working array * returns: * 1 if successful * 0 if out of memory */ extern double *fwork; static long sfwork = 0L; if (size <= sfwork) return 1; /* else reset array */ if (fwork != NULL) free(fwork); fwork = (double*) malloc(sizeof(double) * size); if (fwork != NULL) { sfwork = size; return 1; } fputs(" Unable to allocate randlib float working array:\n",stderr); fprintf(stderr," Requested number of entries = %ld\n",size); fputs(" Out of memory in RSPRFW - ABORT\n",stderr); sfwork = 0L; return 0; } /***************************************************************************** Randlib Helper Functions These routines call those randlib routines which depend on pointers (typically those with array input and/or output) *****************************************************************************/ void pgnprm(long n) { /* Perl's GeNerate PeRMutation * Fills perl's (long) integer working array with 0, ... ,n-1 * and randomly permutes it. * Note: if n <= 0, it does what you'd expect: * N == 1: array of 0 of length 1 * N < 1: array of length 0 */ /* NOTE: EITHER HERE OR IN PERL IWORK MUST HAVE SIZE CHECKED */ extern long *iwork; long i; /* Fills working array ... */ for (i=0L;i mean[1] * fwork[1] <-> mean[2] * ... ... * fwork[p - 1] <-> mean[p] * fwork[0 + 0*p + p] <-> covm[1,1] * fwork[1 + 0*p + p] <-> covm[2,1] * ... ... * fwork[i-1 + (j-1)*p + p] <-> covm[i,j] * ... ... * fwork[p-1 + (p-1)*p + p] <-> covm[p,p] * Tot: p*p + p elements p*p + p elements * This should all be done by the Perl calling routine. * * Side Effects: * parm[p*(p+3)/2 + 1] is a file static array which contains all the * information needed to generate the deviates. * fwork is essentially destroyed (but not reallocated). * * Returns: * 1 if initialization succeeded * 0 if out of memory * * Method: * Calls 'setgmn' in "randlib.c": * void setgmn(double *meanv,double *covm,long p,double *parm) */ extern double *fwork, *parm; static long oldp = 0L; /* p from last reallocate of parm */ if (p > oldp) { /* pmn_param is too small; reallocate */ if (parm != NULL) free(parm); parm = (double *) malloc(sizeof(double)*(p*(p+3L)/2L + 1L)); if (parm == NULL) { fputs("Out of memory in PSETMN - ABORT",stderr); fprintf(stderr, "P = %ld; Requested # of doubles %ld\n",p,p*(p+3L)/2L + 1L); oldp = 0L; return 0; } else { oldp = p; /* keep track of last reallocation */ } } /* initialize parm */ setgmn(fwork, fwork + p, p, parm); return 1; } int pgenmn(void) { /* * Perl's GENerate Multivariate Normal * * Input: (None) * * p - dimension of multivariate normal deviate - gotten from parm[]. * 'psetmn' must be called successfully before this routine is called. * If that be so, then fwork[] has enough space for the deviate * and scratch space used by the routine, and parm[] has the * parameters needed. * * Output: * 0 - generation failed * 1 - generation succeeded * * Side Effects: * fwork[0] ... fwork[p-1] will contain the deviate. * * Method: * Calls 'genmn' in "randlib.c": * void genmn(double *parm,double *x,double *work) */ extern double *fwork, *parm; /* NOTE: CHECK OF PARM ONLY NEEDED IF PERL SET/GENERATE IS SPLIT */ if (parm != NULL) { /* initialized OK */ long p = (long) *(parm); genmn(parm,fwork,fwork+p); /* put deviate in fwork */ return 1; } else { /* not initialized - ABORT */ fputs("PGENMN called before PSETMN called successfully - ABORT\n", stderr); fputs("parm not properly initialized in PGENMN - ABORT\n",stderr); return 0; } } void salfph(char* phrase) { /* ********************************************************************** void salfph(char* phrase) Set ALl From PHrase Function Uses a phrase (character string) to generate two seeds for the RGN random number generator, then sets the initial seed of generator 1 to the results. The initial seeds of the other generators are set accordingly, and all generators' states are set to these seeds. Arguments phrase --> Phrase to be used for random number generation Method Calls 'setall' (from com.c) with the results of 'phrtsd' (here in randlib.c). Please see those functions' comments for details. ********************************************************************** */ extern void phrtsd(char* phrase,long *seed1,long *seed2); extern void setall(long iseed1,long iseed2); static long iseed1, iseed2; phrtsd(phrase,&iseed1,&iseed2); setall(iseed1,iseed2); } f length 1 * N < 1: array of length 0 */ /* NOTE: EITHER HERE OR IN PERL IWORK MUST HAVE SIZE CHECKED */ extern long *iwork; long i; /* Fills working array ... */ for (i=0L;i #include static long Xm1,Xm2,Xa1,Xa2,Xcg1[32],Xcg2[32],Xa1w,Xa2w,Xig1[32],Xig2[32], Xlg1[32],Xlg2[32],Xa1vw,Xa2vw; static long Xqanti[32]; void advnst(long k) /* ********************************************************************** void advnst(long k) ADV-a-N-ce ST-ate Advances the state of the current generator by 2^K values and resets the initial seed to that value. This is a transcription from Pascal to Fortran of routine Advance_State from the paper L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package with Splitting Facilities." ACM Transactions on Mathematical Software, 17:98-111 (1991) Arguments k -> The generator is advanced by2^K values ********************************************************************** */ { #define numg 32L extern void gsrgs(long getset,long *qvalue); extern void gscgn(long getset,long *g); extern long Xm1,Xm2,Xa1,Xa2,Xcg1[],Xcg2[]; static long g,i,ib1,ib2; static long qrgnin; /* Abort unless random number generator initialized */ gsrgs(0L,&qrgnin); if(qrgnin) goto S10; fputs(" ADVNST called before random generator initialized - ABORT\n", stderr); exit(1); S10: gscgn(0L,&g); ib1 = Xa1; ib2 = Xa2; for(i=1; i<=k; i++) { ib1 = mltmod(ib1,ib1,Xm1); ib2 = mltmod(ib2,ib2,Xm2); } setsd(mltmod(ib1,*(Xcg1+g-1),Xm1),mltmod(ib2,*(Xcg2+g-1),Xm2)); /* NOW, IB1 = A1**K AND IB2 = A2**K */ #undef numg } void getsd(long *iseed1,long *iseed2) /* ********************************************************************** void getsd(long *iseed1,long *iseed2) GET SeeD Returns the value of two integer seeds of the current generator This is a transcription from Pascal to Fortran of routine Get_State from the paper L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package with Splitting Facilities." ACM Transactions on Mathematical Software, 17:98-111 (1991) Arguments iseed1 <- First integer seed of generator G iseed2 <- Second integer seed of generator G ********************************************************************** */ { #define numg 32L extern void gsrgs(long getset,long *qvalue); extern void gscgn(long getset,long *g); extern long Xcg1[],Xcg2[]; static long g; static long qrgnin; /* Abort unless random number generator initialized */ gsrgs(0L,&qrgnin); if(qrgnin) goto S10; fprintf(stderr,"%s\n", " GETSD called before random number generator initialized -- abort!"); exit(0); S10: gscgn(0L,&g); *iseed1 = *(Xcg1+g-1); *iseed2 = *(Xcg2+g-1); #undef numg } long ignlgi(void) /* ********************************************************************** long ignlgi(void) GeNerate LarGe Integer Returns a random integer following a uniform distribution over (1, 2147483562) using the current generator. This is a transcription from Pascal to Fortran of routine Random from the paper L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package with Splitting Facilities." ACM Transactions on Mathematical Software, 17:98-111 (1991) ********************************************************************** */ { #define numg 32L extern void gsrgs(long getset,long *qvalue); extern void gssst(long getset,long *qset); extern void gscgn(long getset,long *g); extern void inrgcm(void); extern long Xm1,Xm2,Xa1,Xa2,Xcg1[],Xcg2[]; extern long Xqanti[]; static long ignlgi,curntg,k,s1,s2,z; static long qqssd,qrgnin; /* IF THE RANDOM NUMBER PACKAGE HAS NOT BEEN INITIALIZED YET, DO SO. IT CAN BE INITIALIZED IN ONE OF TWO WAYS : 1) THE FIRST CALL TO THIS ROUTINE 2) A CALL TO SETALL. */ gsrgs(0L,&qrgnin); if(!qrgnin) inrgcm(); gssst(0,&qqssd); if(!qqssd) setall(1234567890L,123456789L); /* Get Current Generator */ gscgn(0L,&curntg); s1 = *(Xcg1+curntg-1); s2 = *(Xcg2+curntg-1); k = s1/53668L; s1 = Xa1*(s1-k*53668L)-k*12211; if(s1 < 0) s1 += Xm1; k = s2/52774L; s2 = Xa2*(s2-k*52774L)-k*3791; if(s2 < 0) s2 += Xm2; *(Xcg1+curntg-1) = s1; *(Xcg2+curntg-1) = s2; z = s1-s2; if(z < 1) z += (Xm1-1); if(*(Xqanti+curntg-1)) z = Xm1-z; ignlgi = z; return ignlgi; #undef numg } void initgn(long isdtyp) /* ********************************************************************** void initgn(long isdtyp) INIT-ialize current G-e-N-erator Reinitializes the state of the current generator This is a transcription from Pascal to C of routine Init_Generator from the paper L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package with Splitting Facilities." ACM Transactions on Mathematical Software, 17:98-111 (1991) Arguments isdtyp -> The state to which the generator is to be set isdtyp = -1 => sets the seeds to their initial value isdtyp = 0 => sets the seeds to the first value of the current block isdtyp = 1 => sets the seeds to the first value of the next block WGR, 12/19/00: replaced S10, S20, etc. with C blocks {} per original paper. ********************************************************************** */ { #define numg 32L extern void gsrgs(long getset,long *qvalue); extern void gscgn(long getset,long *g); extern long Xm1,Xm2,Xa1w,Xa2w,Xig1[],Xig2[],Xlg1[],Xlg2[],Xcg1[],Xcg2[]; static long g; static long qrgnin; /* Abort unless random number generator initialized */ gsrgs(0L,&qrgnin); if (! qrgnin) { fprintf(stderr,"%s\n", " INITGN called before random number generator initialized -- abort!"); exit(1); } gscgn(0L,&g); if(isdtyp == -1) { /* Initial seed */ *(Xlg1+g-1) = *(Xig1+g-1); *(Xlg2+g-1) = *(Xig2+g-1); } else if (isdtyp == 0) { ; } /* Last seed */ else if (isdtyp == 1) { /* New seed */ *(Xlg1+g-1) = mltmod(Xa1w,*(Xlg1+g-1),Xm1); *(Xlg2+g-1) = mltmod(Xa2w,*(Xlg2+g-1),Xm2); } else { fprintf(stderr,"%s\n","isdtyp not in range in INITGN"); exit(1); } *(Xcg1+g-1) = *(Xlg1+g-1); *(Xcg2+g-1) = *(Xlg2+g-1); #undef numg } void inrgcm(void) /* ********************************************************************** void inrgcm(void) INitialize Random number Generator CoMmon Function Initializes common area for random number generator. This saves the nuisance of a BLOCK DATA routine and the difficulty of assuring that the routine is loaded with the other routines. ********************************************************************** */ { #define numg 32L extern void gsrgs(long getset,long *qvalue); extern long Xm1,Xm2,Xa1,Xa2,Xa1w,Xa2w,Xa1vw,Xa2vw; extern long Xqanti[]; static long T1; static long i; /* V=20; W=30; A1W = MOD(A1**(2**W),M1) A2W = MOD(A2**(2**W),M2) A1VW = MOD(A1**(2**(V+W)),M1) A2VW = MOD(A2**(2**(V+W)),M2) If V or W is changed A1W, A2W, A1VW, and A2VW need to be recomputed. An efficient way to precompute a**(2*j) MOD m is to start with a and square it j times modulo m using the function MLTMOD. */ Xm1 = 2147483563L; Xm2 = 2147483399L; Xa1 = 40014L; Xa2 = 40692L; Xa1w = 1033780774L; Xa2w = 1494757890L; Xa1vw = 2082007225L; Xa2vw = 784306273L; for(i=0; i First of two integer seeds iseed2 -> Second of two integer seeds ********************************************************************** */ { #define numg 32L extern void gsrgs(long getset,long *qvalue); extern void gssst(long getset,long *qset); extern void gscgn(long getset,long *g); extern long Xm1,Xm2,Xa1vw,Xa2vw,Xig1[],Xig2[]; static long T1; static long g,ocgn; static long qrgnin; T1 = 1; /* TELL IGNLGI, THE ACTUAL NUMBER GENERATOR, THAT THIS ROUTINE HAS BEEN CALLED. */ gssst(1,&T1); gscgn(0L,&ocgn); /* Initialize Common Block if Necessary */ gsrgs(0L,&qrgnin); if(!qrgnin) inrgcm(); *Xig1 = iseed1; *Xig2 = iseed2; initgn(-1L); for(g=2; g<=numg; g++) { *(Xig1+g-1) = mltmod(Xa1vw,*(Xig1+g-2),Xm1); *(Xig2+g-1) = mltmod(Xa2vw,*(Xig2+g-2),Xm2); gscgn(1L,&g); initgn(-1L); } gscgn(1L,&ocgn); #undef numg } void setant(long qvalue) /* ********************************************************************** void setant(long qvalue) SET ANTithetic Sets whether the current generator produces antithetic values. If X is the value normally returned from a uniform [0,1] random number generator then 1 - X is the antithetic value. If X is the value normally returned from a uniform [0,N] random number generator then N - 1 - X is the antithetic value. All generators are initialized to NOT generate antithetic values. This is a transcription from Pascal to Fortran of routine Set_Antithetic from the paper L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package with Splitting Facilities." ACM Transactions on Mathematical Software, 17:98-111 (1991) Arguments qvalue -> nonzero if generator G is to generating antithetic values, otherwise zero ********************************************************************** */ { #define numg 32L extern void gsrgs(long getset,long *qvalue); extern void gscgn(long getset,long *g); extern long Xqanti[]; static long g; static long qrgnin; /* Abort unless random number generator initialized */ gsrgs(0L,&qrgnin); if(qrgnin) goto S10; fprintf(stderr,"%s\n", " SETANT called before random number generator initialized -- abort!"); exit(1); S10: gscgn(0L,&g); Xqanti[g-1] = qvalue; #undef numg } void setsd(long iseed1,long iseed2) /* ********************************************************************** void setsd(long iseed1,long iseed2) SET S-ee-D of current generator Resets the initial seed of the current generator to ISEED1 and ISEED2. The seeds of the other generators remain unchanged. This is a transcription from Pascal to Fortran of routine Set_Seed from the paper L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package with Splitting Facilities." ACM Transactions on Mathematical Software, 17:98-111 (1991) Arguments iseed1 -> First integer seed iseed2 -> Second integer seed ********************************************************************** */ { #define numg 32L extern void gsrgs(long getset,long *qvalue); extern void gscgn(long getset,long *g); extern long Xig1[],Xig2[]; static long g; static long qrgnin; /* Abort unless random number generator initialized */ gsrgs(0L,&qrgnin); if(qrgnin) goto S10; fprintf(stderr,"%s\n", " SETSD called before random number generator initialized -- abort!"); exit(1); S10: gscgn(0L,&g); *(Xig1+g-1) = iseed1; *(Xig2+g-1) = iseed2; initgn(-1L); #undef numg } isdtyp -> The state to which the generator is to be set isdtyp = -1 => sets the seeds to their initial value Math-Random-0.71/MANIFEST100644 017522 000266 00000000350 11064014432 014355 0ustar00yxrdss000000 000000 Changes INSTALL Index MANIFEST Makefile.PL README Random.pm Random.xs com.c example.pl helper.c helper.h linpack.c randlib.c randlib.h test1.pl test2.pl META.yml Module meta-data (added by MakeMaker) 757890L; Xa1vw = 2082007225L; Xa2vw = 784306273L; for(i=0; i #include #include #define ABS(x) ((x) >= 0 ? (x) : -(x)) #define min(a,b) ((a) <= (b) ? (a) : (b)) #define max(a,b) ((a) >= (b) ? (a) : (b)) void ftnstop(char*); double genbet(double aa,double bb) /* ********************************************************************** double genbet(double aa,double bb) GeNerate BETa random deviate Function Returns a single random deviate from the beta distribution with parameters A and B. The density of the beta is x^(a-1) * (1-x)^(b-1) / B(a,b) for 0 < x < 1 Arguments aa --> First parameter of the beta distribution bb --> Second parameter of the beta distribution Method R. C. H. Cheng Generating Beta Variates with Nonintegral Shape Parameters Communications of the ACM, 21:317-322 (1978) (Algorithms BB and BC) ********************************************************************** */ { /* JJV changed expmax (log(1.0E38)==87.49823), and added minlog */ #define expmax 87.4982335337737 #define infnty 1.0E38 #define minlog 1.0E-37 static double olda = -1.0E37; static double oldb = -1.0E37; static double genbet,a,alpha,b,beta,delta,gamma,k1,k2,r,s,t,u1,u2,v,w,y,z; static long qsame; qsame = olda == aa && oldb == bb; if(qsame) goto S20; if(!(aa < minlog || bb < minlog)) goto S10; fputs(" AA or BB < 1.0E-37 in GENBET - Abort!\n",stderr); fprintf(stderr," AA: %16.6E BB %16.6E\n",aa,bb); exit(1); S10: olda = aa; oldb = bb; S20: if(!(min(aa,bb) > 1.0)) goto S100; /* Algorithm BB Initialize */ if(qsame) goto S30; a = min(aa,bb); b = max(aa,bb); alpha = a+b; beta = sqrt((alpha-2.0)/(2.0*a*b-alpha)); gamma = a+1.0/beta; S30: u1 = ranf(); /* Step 1 */ u2 = ranf(); v = beta*log(u1/(1.0-u1)); /* JJV altered this */ if(v > expmax) goto S55; /* * JJV added checker to see if a*exp(v) will overflow * JJV S50 _was_ w = a*exp(v); also note here a > 1.0 */ w = exp(v); if(w > infnty/a) goto S55; w *= a; goto S60; S55: w = infnty; S60: z = pow(u1,2.0)*u2; r = gamma*v-1.38629436111989; s = a+r-w; /* Step 2 */ if(s+2.60943791243410 >= 5.0*z) goto S70; /* Step 3 */ t = log(z); if(s > t) goto S70; /* * Step 4 * * JJV added checker to see if log(alpha/(b+w)) will * JJV overflow. If so, we count the log as -INF, and * JJV consequently evaluate conditional as true, i.e. * JJV the algorithm rejects the trial and starts over * JJV May not need this here since alpha > 2.0 */ if(alpha/(b+w) < minlog) goto S30; if(r+alpha*log(alpha/(b+w)) < t) goto S30; S70: /* Step 5 */ if(aa == a) { genbet = w/(b+w); } else { genbet = b/(b+w); } goto S230; S100: /* Algorithm BC Initialize */ if(qsame) goto S110; a = max(aa,bb); b = min(aa,bb); alpha = a+b; beta = 1.0/b; delta = 1.0+a-b; k1 = delta*(1.38888888888889E-2+4.16666666666667E-2*b) / (a*beta-0.777777777777778); k2 = 0.25+(0.5+0.25/delta)*b; S110: S120: u1 = ranf(); /* Step 1 */ u2 = ranf(); if(u1 >= 0.5) goto S130; /* Step 2 */ y = u1*u2; z = u1*y; if(0.25*u2+z-y >= k1) goto S120; goto S170; S130: /* Step 3 */ z = pow(u1,2.0)*u2; if(!(z <= 0.25)) goto S160; v = beta*log(u1/(1.0-u1)); /* * JJV instead of checking v > expmax at top, I will check * JJV if a < 1, then check the appropriate values */ if(a > 1.0) goto S135; /* JJV a < 1 so it can help out if exp(v) would overflow */ if(v > expmax) goto S132; w = a*exp(v); goto S200; S132: w = v + log(a); if(w > expmax) goto S140; w = exp(w); goto S200; S135: /* JJV in this case a > 1 */ if(v > expmax) goto S140; w = exp(v); if(w > infnty/a) goto S140; w *= a; goto S200; S140: w = infnty; goto S200; /* * JJV old code * if(!(v > expmax)) goto S140; * w = infnty; * goto S150; *S140: * w = a*exp(v); *S150: * goto S200; */ S160: if(z >= k2) goto S120; S170: /* Step 4 Step 5 */ v = beta*log(u1/(1.0-u1)); /* JJV same kind of checking as above */ if(a > 1.0) goto S175; /* JJV a < 1 so it can help out if exp(v) would overflow */ if(v > expmax) goto S172; w = a*exp(v); goto S190; S172: w = v + log(a); if(w > expmax) goto S180; w = exp(w); goto S190; S175: /* JJV in this case a > 1.0 */ if(v > expmax) goto S180; w = exp(v); if(w > infnty/a) goto S180; w *= a; goto S190; S180: w = infnty; /* * JJV old code * if(!(v > expmax)) goto S180; * w = infnty; * goto S190; *S180: * w = a*exp(v); */ S190: /* * JJV here we also check to see if log overlows; if so, we treat it * JJV as -INF, which means condition is true, i.e. restart */ if(alpha/(b+w) < minlog) goto S120; if(alpha*(log(alpha/(b+w))+v)-1.38629436111989 < log(z)) goto S120; S200: /* Step 6 */ if(a == aa) { genbet = w/(b+w); } else { genbet = b/(b+w); } S230: return genbet; #undef expmax #undef infnty #undef minlog } double genchi(double df) /* ********************************************************************** double genchi(double df) Generate random value of CHIsquare variable Function Generates random deviate from the distribution of a chisquare with DF degrees of freedom random variable. Arguments df --> Degrees of freedom of the chisquare (Must be positive) Method Uses relation between chisquare and gamma. ********************************************************************** */ { static double genchi; if(!(df <= 0.0)) goto S10; fputs(" DF <= 0 in GENCHI - ABORT\n",stderr); fprintf(stderr," Value of DF: %16.6E\n",df); exit(1); S10: /* * JJV changed the code to call SGAMMA directly * genchi = 2.0*gengam(1.0,df/2.0); <- OLD */ genchi = 2.0*sgamma(df/2.0); return genchi; } double genexp(double av) /* ********************************************************************** double genexp(double av) GENerate EXPonential random deviate Function Generates a single random deviate from an exponential distribution with mean AV. Arguments av --> The mean of the exponential distribution from which a random deviate is to be generated. JJV (av >= 0) Method Renames SEXPO from TOMS as slightly modified by BWB to use RANF instead of SUNIF. For details see: Ahrens, J.H. and Dieter, U. Computer Methods for Sampling From the Exponential and Normal Distributions. Comm. ACM, 15,10 (Oct. 1972), 873 - 882. ********************************************************************** */ { static double genexp; /* JJV added check that av >= 0 */ if(av >= 0.0) goto S10; fputs(" AV < 0 in GENEXP - ABORT\n",stderr); fprintf(stderr," Value of AV: %16.6E\n",av); exit(1); S10: genexp = sexpo()*av; return genexp; } double genf(double dfn,double dfd) /* ********************************************************************** double genf(double dfn,double dfd) GENerate random deviate from the F distribution Function Generates a random deviate from the F (variance ratio) distribution with DFN degrees of freedom in the numerator and DFD degrees of freedom in the denominator. Arguments dfn --> Numerator degrees of freedom (Must be positive) dfd --> Denominator degrees of freedom (Must be positive) Method Directly generates ratio of chisquare variates ********************************************************************** */ { static double genf,xden,xnum; if(!(dfn <= 0.0 || dfd <= 0.0)) goto S10; fputs(" Degrees of freedom nonpositive in GENF - abort!\n",stderr); fprintf(stderr," DFN value: %16.6E DFD value: %16.6E\n",dfn,dfd); exit(1); S10: /* * JJV changed this to call SGAMMA directly * * GENF = ( GENCHI( DFN ) / DFN ) / ( GENCHI( DFD ) / DFD ) * xnum = genchi(dfn)/dfn; <- OLD * xden = genchi(dfd)/dfd; <- OLD */ xnum = 2.0*sgamma(dfn/2.0)/dfn; xden = 2.0*sgamma(dfd/2.0)/dfd; /* * JJV changed constant to prevent underflow at compile time. * if(!(xden <= 9.999999999998E-39*xnum)) goto S20; */ if(!(xden <= 1.0E-37*xnum)) goto S20; fputs(" GENF - generated numbers would cause overflow\n",stderr); fprintf(stderr," Numerator %16.6E Denominator %16.6E\n",xnum,xden); /* * JJV changed next 2 lines to reflect constant change above in the * JJV truncated value returned. * fputs(" GENF returning 1.0E38\n",stderr); * genf = 1.0E38; */ fputs(" GENF returning 1.0E37\n",stderr); genf = 1.0E37; goto S30; S20: genf = xnum/xden; S30: return genf; } double gengam(double a,double r) /* ********************************************************************** double gengam(double a,double r) GENerates random deviates from GAMma distribution Function Generates random deviates from the gamma distribution whose density is (A**R)/Gamma(R) * X**(R-1) * Exp(-A*X) Arguments a --> Location parameter of Gamma distribution JJV (a > 0) r --> Shape parameter of Gamma distribution JJV (r > 0) Method Renames SGAMMA from TOMS as slightly modified by BWB to use RANF instead of SUNIF. For details see: (Case R >= 1.0) Ahrens, J.H. and Dieter, U. Generating Gamma Variates by a Modified Rejection Technique. Comm. ACM, 25,1 (Jan. 1982), 47 - 54. Algorithm GD JJV altered following to reflect argument ranges (Case 0.0 < R < 1.0) Ahrens, J.H. and Dieter, U. Computer Methods for Sampling from Gamma, Beta, Poisson and Binomial Distributions. Computing, 12 (1974), 223-246/ Adapted algorithm GS. ********************************************************************** */ { static double gengam; /* JJV added argument checker */ if(a > 0.0 && r > 0.0) goto S10; fputs(" A or R nonpositive in GENGAM - abort!\n",stderr); fprintf(stderr," A value: %16.6E R value: %16.6E\n",a,r); exit(1); S10: gengam = sgamma(r); gengam /= a; return gengam; } void genmn(double *parm,double *x,double *work) /* ********************************************************************** void genmn(double *parm,double *x,double *work) GENerate Multivariate Normal random deviate Arguments parm --> Parameters needed to generate multivariate normal deviates (MEANV and Cholesky decomposition of COVM). Set by a previous call to SETGMN. 1 : 1 - size of deviate, P 2 : P + 1 - mean vector P+2 : P*(P+3)/2 + 1 - upper half of cholesky decomposition of cov matrix x <-- Vector deviate generated. work <--> Scratch array Method 1) Generate P independent standard normal deviates - Ei ~ N(0,1) 2) Using Cholesky decomposition find A s.t. trans(A)*A = COVM 3) trans(A)E + MEANV ~ N(MEANV,COVM) ********************************************************************** */ { static long i,icount,j,p,D1,D2,D3,D4; static double ae; p = (long) (*parm); /* Generate P independent normal deviates - WORK ~ N(0,1) */ for(i=1; i<=p; i++) *(work+i-1) = snorm(); for(i=1,D3=1,D4=(p-i+D3)/D3; D4>0; D4--,i+=D3) { /* PARM (P+2 : P*(P+3)/2 + 1) contains A, the Cholesky decomposition of the desired covariance matrix. trans(A)(1,1) = PARM(P+2) trans(A)(2,1) = PARM(P+3) trans(A)(2,2) = PARM(P+2+P) trans(A)(3,1) = PARM(P+4) trans(A)(3,2) = PARM(P+3+P) trans(A)(3,3) = PARM(P+2-1+2P) ... trans(A)*WORK + MEANV ~ N(MEANV,COVM) */ icount = 0; ae = 0.0; for(j=1,D1=1,D2=(i-j+D1)/D1; D2>0; D2--,j+=D1) { icount += (j-1); ae += (*(parm+i+(j-1)*p-icount+p)**(work+j-1)); } *(x+i-1) = ae+*(parm+i); } } void genmul(long n,double *p,long ncat,long *ix) /* ********************************************************************** void genmul(int n,double *p,int ncat,int *ix) GENerate an observation from the MULtinomial distribution Arguments N --> Number of events that will be classified into one of the categories 1..NCAT P --> Vector of probabilities. P(i) is the probability that an event will be classified into category i. Thus, P(i) must be [0,1]. Only the first NCAT-1 P(i) must be defined since P(NCAT) is 1.0 minus the sum of the first NCAT-1 P(i). NCAT --> Number of categories. Length of P and IX. IX <-- Observation from multinomial distribution. All IX(i) will be nonnegative and their sum will be N. Method Algorithm from page 559 of Devroye, Luc Non-Uniform Random Variate Generation. Springer-Verlag, New York, 1986. ********************************************************************** */ { static double prob,ptot,sum; static long i,icat,ntot; if(n < 0) ftnstop("N < 0 in GENMUL"); if(ncat <= 1) ftnstop("NCAT <= 1 in GENMUL"); ptot = 0.0F; for(i=0; i 1.0F) ftnstop("Some P(i) > 1 in GENMUL"); ptot += *(p+i); } if(ptot > 0.99999F) ftnstop("Sum of P(i) > 1 in GENMUL"); /* Initialize variables */ ntot = n; sum = 1.0F; for(i=0; i Degrees of freedom of the chisquare (Must be >= 1.0) xnonc --> Noncentrality parameter of the chisquare (Must be >= 0.0) Method Uses fact that noncentral chisquare is the sum of a chisquare deviate with DF-1 degrees of freedom plus the square of a normal deviate with mean XNONC and standard deviation 1. ********************************************************************** */ { static double gennch; if(!(df < 1.0 || xnonc < 0.0)) goto S10; fputs("DF < 1 or XNONC < 0 in GENNCH - ABORT\n",stderr); fprintf(stderr,"Value of DF: %16.6E Value of XNONC: %16.6E\n",df,xnonc); exit(1); /* JJV changed code to call SGAMMA, SNORM directly */ S10: if(df >= 1.000000001) goto S20; /* * JJV case df == 1.0 * gennch = pow(gennor(sqrt(xnonc),1.0),2.0); <- OLD */ gennch = pow(snorm()+sqrt(xnonc),2.0); goto S30; S20: /* * JJV case df > 1.0 * gennch = genchi(df-1.0)+pow(gennor(sqrt(xnonc),1.0),2.0); <- OLD */ gennch = 2.0*sgamma((df-1.0)/2.0)+pow(snorm()+sqrt(xnonc),2.0); S30: return gennch; } double gennf(double dfn,double dfd,double xnonc) /* ********************************************************************** double gennf(double dfn,double dfd,double xnonc) GENerate random deviate from the Noncentral F distribution Function Generates a random deviate from the noncentral F (variance ratio) distribution with DFN degrees of freedom in the numerator, and DFD degrees of freedom in the denominator, and noncentrality parameter XNONC. Arguments dfn --> Numerator degrees of freedom (Must be >= 1.0) dfd --> Denominator degrees of freedom (Must be positive) xnonc --> Noncentrality parameter (Must be nonnegative) Method Directly generates ratio of noncentral numerator chisquare variate to central denominator chisquare variate. ********************************************************************** */ { static double gennf,xden,xnum; static long qcond; /* JJV changed qcond, error message to allow dfn == 1.0 */ qcond = dfn < 1.0 || dfd <= 0.0 || xnonc < 0.0; if(!qcond) goto S10; fputs("In GENNF - Either (1) Numerator DF < 1.0 or\n",stderr); fputs(" (2) Denominator DF <= 0.0 or\n",stderr); fputs(" (3) Noncentrality parameter < 0.0\n",stderr); fprintf(stderr, "DFN value: %16.6E DFD value: %16.6E XNONC value: \n%16.6E\n",dfn,dfd, xnonc); exit(1); S10: /* * JJV changed the code to call SGAMMA and SNORM directly * GENNF = ( GENNCH( DFN, XNONC ) / DFN ) / ( GENCHI( DFD ) / DFD ) * xnum = gennch(dfn,xnonc)/dfn; <- OLD * xden = genchi(dfd)/dfd; <- OLD */ if(dfn >= 1.000001) goto S20; /* JJV case dfn == 1.0, dfn is counted as exactly 1.0 */ xnum = pow(snorm()+sqrt(xnonc),2.0); goto S30; S20: /* JJV case df > 1.0 */ xnum = (2.0*sgamma((dfn-1.0)/2.0)+pow(snorm()+sqrt(xnonc),2.0))/dfn; S30: xden = 2.0*sgamma(dfd/2.0)/dfd; /* * JJV changed constant to prevent underflow at compile time. * if(!(xden <= 9.999999999998E-39*xnum)) goto S40; */ if(!(xden <= 1.0E-37*xnum)) goto S40; fputs(" GENNF - generated numbers would cause overflow\n",stderr); fprintf(stderr," Numerator %16.6E Denominator %16.6E\n",xnum,xden); /* * JJV changed next 2 lines to reflect constant change above in the * JJV truncated value returned. * fputs(" GENNF returning 1.0E38\n",stderr); * gennf = 1.0E38; */ fputs(" GENNF returning 1.0E37\n",stderr); gennf = 1.0E37; goto S50; S40: gennf = xnum/xden; S50: return gennf; } double gennor(double av,double sd) /* ********************************************************************** double gennor(double av,double sd) GENerate random deviate from a NORmal distribution Function Generates a single random deviate from a normal distribution with mean, AV, and standard deviation, SD. Arguments av --> Mean of the normal distribution. sd --> Standard deviation of the normal distribution. JJV (sd >= 0) Method Renames SNORM from TOMS as slightly modified by BWB to use RANF instead of SUNIF. For details see: Ahrens, J.H. and Dieter, U. Extensions of Forsythe's Method for Random Sampling from the Normal Distribution. Math. Comput., 27,124 (Oct. 1973), 927 - 937. ********************************************************************** */ { static double gennor; /* JJV added argument checker */ if(sd >= 0.0) goto S10; fputs(" SD < 0 in GENNOR - ABORT\n",stderr); fprintf(stderr," Value of SD: %16.6E\n",sd); exit(1); S10: gennor = sd*snorm()+av; return gennor; } void genprm(long *iarray,int larray) /* ********************************************************************** void genprm(long *iarray,int larray) GENerate random PeRMutation of iarray Arguments iarray <--> On output IARRAY is a random permutation of its value on input larray <--> Length of IARRAY ********************************************************************** */ { static long i,itmp,iwhich,D1,D2; for(i=1,D1=1,D2=(larray-i+D1)/D1; D2>0; D2--,i+=D1) { iwhich = ignuin(i,larray); itmp = *(iarray+iwhich-1); *(iarray+iwhich-1) = *(iarray+i-1); *(iarray+i-1) = itmp; } } double genunf(double low,double high) /* ********************************************************************** double genunf(double low,double high) GeNerate Uniform Real between LOW and HIGH Function Generates a real uniformly distributed between LOW and HIGH. Arguments low --> Low bound (exclusive) on real value to be generated high --> High bound (exclusive) on real value to be generated ********************************************************************** */ { static double genunf; if(!(low > high)) goto S10; fprintf(stderr,"LOW > HIGH in GENUNF: LOW %16.6E HIGH: %16.6E\n",low,high); fputs("Abort\n",stderr); exit(1); S10: genunf = low+(high-low)*ranf(); return genunf; } void gscgn(long getset,long *g) /* ********************************************************************** void gscgn(long getset,long *g) Get/Set GeNerator Gets or returns in G the number of the current generator Arguments getset --> 0 Get 1 Set g <-- Number of the current random number generator (1..32) ********************************************************************** */ { #define numg 32L static long curntg = 1; if(getset == 0) *g = curntg; else { if(*g < 0 || *g > numg) { fputs(" Generator number out of range in GSCGN\n",stderr); exit(0); } curntg = *g; } #undef numg } void gsrgs(long getset,long *qvalue) /* ********************************************************************** void gsrgs(long getset,long *qvalue) Get/Set Random Generators Set Gets or sets whether random generators set (initialized). Initially (data statement) state is not set If getset is 1 state is set to qvalue If getset is 0 state returned in qvalue ********************************************************************** */ { static long qinit = 0; if(getset == 0) *qvalue = qinit; else qinit = *qvalue; } void gssst(long getset,long *qset) /* ********************************************************************** void gssst(long getset,long *qset) Get or Set whether Seed is Set Initialize to Seed not Set If getset is 1 sets state to Seed Set If getset is 0 returns T in qset if Seed Set Else returns F in qset ********************************************************************** */ { static long qstate = 0; if(getset != 0) qstate = 1; else *qset = qstate; } long ignbin(long n,double pp) /* ********************************************************************** long ignbin(long n,double pp) GENerate BINomial random deviate Function Generates a single random deviate from a binomial distribution whose number of trials is N and whose probability of an event in each trial is P. Arguments n --> The number of trials in the binomial distribution from which a random deviate is to be generated. JJV (N >= 0) pp --> The probability of an event in each trial of the binomial distribution from which a random deviate is to be generated. JJV (0.0 <= PP <= 1.0) ignbin <-- A random deviate yielding the number of events from N independent trials, each of which has a probability of event P. Method This is algorithm BTPE from: Kachitvichyanukul, V. and Schmeiser, B. W. Binomial Random Variate Generation. Communications of the ACM, 31, 2 (February, 1988) 216. ********************************************************************** SUBROUTINE BTPEC(N,PP,ISEED,JX) BINOMIAL RANDOM VARIATE GENERATOR MEAN .LT. 30 -- INVERSE CDF MEAN .GE. 30 -- ALGORITHM BTPE: ACCEPTANCE-REJECTION VIA FOUR REGION COMPOSITION. THE FOUR REGIONS ARE A TRIANGLE (SYMMETRIC IN THE CENTER), A PAIR OF PARALLELOGRAMS (ABOVE THE TRIANGLE), AND EXPONENTIAL LEFT AND RIGHT TAILS. BTPE REFERS TO BINOMIAL-TRIANGLE-PARALLELOGRAM-EXPONENTIAL. BTPEC REFERS TO BTPE AND "COMBINED." THUS BTPE IS THE RESEARCH AND BTPEC IS THE IMPLEMENTATION OF A COMPLETE USABLE ALGORITHM. REFERENCE: VORATAS KACHITVICHYANUKUL AND BRUCE SCHMEISER, "BINOMIAL RANDOM VARIATE GENERATION," COMMUNICATIONS OF THE ACM, FORTHCOMING WRITTEN: SEPTEMBER 1980. LAST REVISED: MAY 1985, JULY 1987 REQUIRED SUBPROGRAM: RAND() -- A UNIFORM (0,1) RANDOM NUMBER GENERATOR ARGUMENTS N : NUMBER OF BERNOULLI TRIALS (INPUT) PP : PROBABILITY OF SUCCESS IN EACH TRIAL (INPUT) ISEED: RANDOM NUMBER SEED (INPUT AND OUTPUT) JX: RANDOMLY GENERATED OBSERVATION (OUTPUT) VARIABLES PSAVE: VALUE OF PP FROM THE LAST CALL TO BTPEC NSAVE: VALUE OF N FROM THE LAST CALL TO BTPEC XNP: VALUE OF THE MEAN FROM THE LAST CALL TO BTPEC P: PROBABILITY USED IN THE GENERATION PHASE OF BTPEC FFM: TEMPORARY VARIABLE EQUAL TO XNP + P M: INTEGER VALUE OF THE CURRENT MODE FM: FLOATING POINT VALUE OF THE CURRENT MODE XNPQ: TEMPORARY VARIABLE USED IN SETUP AND SQUEEZING STEPS P1: AREA OF THE TRIANGLE C: HEIGHT OF THE PARALLELOGRAMS XM: CENTER OF THE TRIANGLE XL: LEFT END OF THE TRIANGLE XR: RIGHT END OF THE TRIANGLE AL: TEMPORARY VARIABLE XLL: RATE FOR THE LEFT EXPONENTIAL TAIL XLR: RATE FOR THE RIGHT EXPONENTIAL TAIL P2: AREA OF THE PARALLELOGRAMS P3: AREA OF THE LEFT EXPONENTIAL TAIL P4: AREA OF THE RIGHT EXPONENTIAL TAIL U: A U(0,P4) RANDOM VARIATE USED FIRST TO SELECT ONE OF THE FOUR REGIONS AND THEN CONDITIONALLY TO GENERATE A VALUE FROM THE REGION V: A U(0,1) RANDOM NUMBER USED TO GENERATE THE RANDOM VALUE (REGION 1) OR TRANSFORMED INTO THE VARIATE TO ACCEPT OR REJECT THE CANDIDATE VALUE IX: INTEGER CANDIDATE VALUE X: PRELIMINARY CONTINUOUS CANDIDATE VALUE IN REGION 2 LOGIC AND A FLOATING POINT IX IN THE ACCEPT/REJECT LOGIC K: ABSOLUTE VALUE OF (IX-M) F: THE HEIGHT OF THE SCALED DENSITY FUNCTION USED IN THE ACCEPT/REJECT DECISION WHEN BOTH M AND IX ARE SMALL ALSO USED IN THE INVERSE TRANSFORMATION R: THE RATIO P/Q G: CONSTANT USED IN CALCULATION OF PROBABILITY MP: MODE PLUS ONE, THE LOWER INDEX FOR EXPLICIT CALCULATION OF F WHEN IX IS GREATER THAN M IX1: CANDIDATE VALUE PLUS ONE, THE LOWER INDEX FOR EXPLICIT CALCULATION OF F WHEN IX IS LESS THAN M I: INDEX FOR EXPLICIT CALCULATION OF F FOR BTPE AMAXP: MAXIMUM ERROR OF THE LOGARITHM OF NORMAL BOUND YNORM: LOGARITHM OF NORMAL BOUND ALV: NATURAL LOGARITHM OF THE ACCEPT/REJECT VARIATE V X1,F1,Z,W,Z2,X2,F2, AND W2 ARE TEMPORARY VARIABLES TO BE USED IN THE FINAL ACCEPT/REJECT TEST QN: PROBABILITY OF NO SUCCESS IN N TRIALS REMARK IX AND JX COULD LOGICALLY BE THE SAME VARIABLE, WHICH WOULD SAVE A MEMORY POSITION AND A LINE OF CODE. HOWEVER, SOME COMPILERS (E.G.,CDC MNF) OPTIMIZE BETTER WHEN THE ARGUMENTS ARE NOT INVOLVED. ISEED NEEDS TO BE DOUBLE PRECISION IF THE IMSL ROUTINE GGUBFS IS USED TO GENERATE UNIFORM RANDOM NUMBER, OTHERWISE TYPE OF ISEED SHOULD BE DICTATED BY THE UNIFORM GENERATOR ********************************************************************** *****DETERMINE APPROPRIATE ALGORITHM AND WHETHER SETUP IS NECESSARY */ { /* JJV changed initial values to ridiculous values */ static double psave = -1.0E37; static long nsave = -214748365; static long ignbin,i,ix,ix1,k,m,mp,T1; static double al,alv,amaxp,c,f,f1,f2,ffm,fm,g,p,p1,p2,p3,p4,q,qn,r,u,v,w,w2,x,x1, x2,xl,xll,xlr,xm,xnp,xnpq,xr,ynorm,z,z2; if(pp != psave) goto S10; if(n != nsave) goto S20; if(xnp < 30.0) goto S150; goto S30; S10: /* *****SETUP, PERFORM ONLY WHEN PARAMETERS CHANGE JJV added checks to ensure 0.0 <= PP <= 1.0 */ if(pp < 0.0F) ftnstop("PP < 0.0 in IGNBIN"); if(pp > 1.0F) ftnstop("PP > 1.0 in IGNBIN"); psave = pp; p = min(psave,1.0-psave); q = 1.0-p; S20: /* JJV added check to ensure N >= 0 */ if(n < 0L) ftnstop("N < 0 in IGNBIN"); xnp = n*p; nsave = n; if(xnp < 30.0) goto S140; ffm = xnp+p; m = ffm; fm = m; xnpq = xnp*q; p1 = (long) (2.195*sqrt(xnpq)-4.6*q)+0.5; xm = fm+0.5; xl = xm-p1; xr = xm+p1; c = 0.134+20.5/(15.3+fm); al = (ffm-xl)/(ffm-xl*p); xll = al*(1.0+0.5*al); al = (xr-ffm)/(xr*q); xlr = al*(1.0+0.5*al); p2 = p1*(1.0+c+c); p3 = p2+c/xll; p4 = p3+c/xlr; S30: /* *****GENERATE VARIATE */ u = ranf()*p4; v = ranf(); /* TRIANGULAR REGION */ if(u > p1) goto S40; ix = xm-p1*v+u; goto S170; S40: /* PARALLELOGRAM REGION */ if(u > p2) goto S50; x = xl+(u-p1)/c; v = v*c+1.0-ABS(xm-x)/p1; if(v > 1.0 || v <= 0.0) goto S30; ix = x; goto S70; S50: /* LEFT TAIL */ if(u > p3) goto S60; ix = xl+log(v)/xll; if(ix < 0) goto S30; v *= ((u-p2)*xll); goto S70; S60: /* RIGHT TAIL */ ix = xr-log(v)/xlr; if(ix > n) goto S30; v *= ((u-p3)*xlr); S70: /* *****DETERMINE APPROPRIATE WAY TO PERFORM ACCEPT/REJECT TEST */ k = ABS(ix-m); if(k > 20 && k < xnpq/2-1) goto S130; /* EXPLICIT EVALUATION */ f = 1.0; r = p/q; g = (n+1)*r; T1 = m-ix; if(T1 < 0) goto S80; else if(T1 == 0) goto S120; else goto S100; S80: mp = m+1; for(i=mp; i<=ix; i++) f *= (g/i-r); goto S120; S100: ix1 = ix+1; for(i=ix1; i<=m; i++) f /= (g/i-r); S120: if(v <= f) goto S170; goto S30; S130: /* SQUEEZING USING UPPER AND LOWER BOUNDS ON ALOG(F(X)) */ amaxp = k/xnpq*((k*(k/3.0+0.625)+0.1666666666666)/xnpq+0.5); ynorm = -(k*k/(2.0*xnpq)); alv = log(v); if(alv < ynorm-amaxp) goto S170; if(alv > ynorm+amaxp) goto S30; /* STIRLING'S FORMULA TO MACHINE ACCURACY FOR THE FINAL ACCEPTANCE/REJECTION TEST */ x1 = ix+1.0; f1 = fm+1.0; z = n+1.0-fm; w = n-ix+1.0; z2 = z*z; x2 = x1*x1; f2 = f1*f1; w2 = w*w; if(alv <= xm*log(f1/x1)+(n-m+0.5)*log(z/w)+(ix-m)*log(w*p/(x1*q))+(13860.0- (462.0-(132.0-(99.0-140.0/f2)/f2)/f2)/f2)/f1/166320.0+(13860.0-(462.0- (132.0-(99.0-140.0/z2)/z2)/z2)/z2)/z/166320.0+(13860.0-(462.0-(132.0- (99.0-140.0/x2)/x2)/x2)/x2)/x1/166320.0+(13860.0-(462.0-(132.0-(99.0 -140.0/w2)/w2)/w2)/w2)/w/166320.0) goto S170; goto S30; S140: /* INVERSE CDF LOGIC FOR MEAN LESS THAN 30 */ /* The following change was recommended by Paul B. to get around an error when using gcc under AIX. 2006-09-12. */ /** qn = pow(q,(double)n); <- OLD **/ qn = exp( (double)n * log(q) ); r = p/q; g = r*(n+1); S150: ix = 0; f = qn; u = ranf(); S160: if(u < f) goto S170; if(ix > 110) goto S150; u -= f; ix += 1; f *= (g/ix-r); goto S160; S170: if(psave > 0.5) ix = n-ix; ignbin = ix; return ignbin; } long ignnbn(long n,double p) /* ********************************************************************** long ignnbn(long n,double p) GENerate Negative BiNomial random deviate Function Generates a single random deviate from a negative binomial distribution. Arguments N --> The number of trials in the negative binomial distribution from which a random deviate is to be generated. JJV (N > 0) P --> The probability of an event. JJV (0.0 < P < 1.0) Method Algorithm from page 480 of Devroye, Luc Non-Uniform Random Variate Generation. Springer-Verlag, New York, 1986. ********************************************************************** */ { static long ignnbn; static double y,a,r; /* .. .. Executable Statements .. */ /* Check Arguments */ if(n <= 0L) ftnstop("N <= 0 in IGNNBN"); if(p <= 0.0F) ftnstop("P <= 0.0 in IGNNBN"); if(p >= 1.0F) ftnstop("P >= 1.0 in IGNNBN"); /* Generate Y, a random gamma (n,(1-p)/p) variable JJV Note: the above parametrization is consistent with Devroye, JJV but gamma (p/(1-p),n) is the equivalent in our code */ r = (double)n; a = p/(1.0F-p); /* * JJV changed this to call SGAMMA directly * y = gengam(a,r); <- OLD */ y = sgamma(r)/a; /* Generate a random Poisson(y) variable */ ignnbn = ignpoi(y); return ignnbn; } long ignpoi(double mu) /* ********************************************************************** long ignpoi(double mu) GENerate POIsson random deviate Function Generates a single random deviate from a Poisson distribution with mean MU. Arguments mu --> The mean of the Poisson distribution from which a random deviate is to be generated. (mu >= 0.0) ignpoi <-- The random deviate. Method Renames KPOIS from TOMS as slightly modified by BWB to use RANF instead of SUNIF. For details see: Ahrens, J.H. and Dieter, U. Computer Generation of Poisson Deviates From Modified Normal Distributions. ACM Trans. Math. Software, 8, 2 (June 1982),163-179 ********************************************************************** ********************************************************************** P O I S S O N DISTRIBUTION ********************************************************************** ********************************************************************** FOR DETAILS SEE: AHRENS, J.H. AND DIETER, U. COMPUTER GENERATION OF POISSON DEVIATES FROM MODIFIED NORMAL DISTRIBUTIONS. ACM TRANS. MATH. SOFTWARE, 8,2 (JUNE 1982), 163 - 179. (SLIGHTLY MODIFIED VERSION OF THE PROGRAM IN THE ABOVE ARTICLE) ********************************************************************** INTEGER FUNCTION IGNPOI(IR,MU) INPUT: IR=CURRENT STATE OF BASIC RANDOM NUMBER GENERATOR MU=MEAN MU OF THE POISSON DISTRIBUTION OUTPUT: IGNPOI=SAMPLE FROM THE POISSON-(MU)-DISTRIBUTION MUPREV=PREVIOUS MU, MUOLD=MU AT LAST EXECUTION OF STEP P OR B. TABLES: COEFFICIENTS A0-A7 FOR STEP F. FACTORIALS FACT COEFFICIENTS A(K) - FOR PX = FK*V*V*SUM(A(K)*V**K)-DEL SEPARATION OF CASES A AND B */ { extern double fsign( double num, double sign ); static double a0 = -0.5; static double a1 = 0.3333333343; static double a2 = -0.2499998565; static double a3 = 0.1999997049; static double a4 = -0.1666848753; static double a5 = 0.1428833286; static double a6 = -0.1241963125; static double a7 = 0.1101687109; static double a8 = -0.1142650302; static double a9 = 0.1055093006; /* JJV changed the initial values of MUPREV and MUOLD */ static double muold = -1.0E37; static double muprev = -1.0E37; static double fact[10] = { 1.0,1.0,2.0,6.0,24.0,120.0,720.0,5040.0,40320.0,362880.0 }; /* JJV added ll to the list, for Case A */ static long ignpoi,j,k,kflag,l,ll,m; static double b1,b2,c,c0,c1,c2,c3,d,del,difmuk,e,fk,fx,fy,g,omega,p,p0,px,py,q,s, t,u,v,x,xx,pp[35]; if(mu == muprev) goto S10; if(mu < 10.0) goto S120; /* C A S E A. (RECALCULATION OF S,D,LL IF MU HAS CHANGED) JJV changed l in Case A to ll */ muprev = mu; s = sqrt(mu); d = 6.0*mu*mu; /* THE POISSON PROBABILITIES PK EXCEED THE DISCRETE NORMAL PROBABILITIES FK WHENEVER K >= M(MU). LL=IFIX(MU-1.1484) IS AN UPPER BOUND TO M(MU) FOR ALL MU >= 10 . */ ll = (long) (mu-1.1484); S10: /* STEP N. NORMAL SAMPLE - SNORM(IR) FOR STANDARD NORMAL DEVIATE */ g = mu+s*snorm(); if(g < 0.0) goto S20; ignpoi = (long) (g); /* STEP I. IMMEDIATE ACCEPTANCE IF IGNPOI IS LARGE ENOUGH */ if(ignpoi >= ll) return ignpoi; /* STEP S. SQUEEZE ACCEPTANCE - SUNIF(IR) FOR (0,1)-SAMPLE U */ fk = (double)ignpoi; difmuk = mu-fk; u = ranf(); if(d*u >= difmuk*difmuk*difmuk) return ignpoi; S20: /* STEP P. PREPARATIONS FOR STEPS Q AND H. (RECALCULATIONS OF PARAMETERS IF NECESSARY) .3989423=(2*PI)**(-.5) .416667E-1=1./24. .1428571=1./7. THE QUANTITIES B1, B2, C3, C2, C1, C0 ARE FOR THE HERMITE APPROXIMATIONS TO THE DISCRETE NORMAL PROBABILITIES FK. C=.1069/MU GUARANTEES MAJORIZATION BY THE 'HAT'-FUNCTION. */ if(mu == muold) goto S30; muold = mu; omega = 0.398942280401433/s; b1 = 4.16666666666667E-2/mu; b2 = 0.3*b1*b1; c3 = 0.142857142857143*b1*b2; c2 = b2-15.0*c3; c1 = b1-6.0*b2+45.0*c3; c0 = 1.0-b1+3.0*b2-15.0*c3; c = 0.1069/mu; S30: if(g < 0.0) goto S50; /* 'SUBROUTINE' F IS CALLED (KFLAG=0 FOR CORRECT RETURN) */ kflag = 0; goto S70; S40: /* STEP Q. QUOTIENT ACCEPTANCE (RARE CASE) */ if(fy-u*fy <= py*exp(px-fx)) return ignpoi; S50: /* STEP E. EXPONENTIAL SAMPLE - SEXPO(IR) FOR STANDARD EXPONENTIAL DEVIATE E AND SAMPLE T FROM THE LAPLACE 'HAT' (IF T <= -.6744 THEN PK < FK FOR ALL MU >= 10.) */ e = sexpo(); u = ranf(); u += (u-1.0); t = 1.8+fsign(e,u); if(t <= -0.6744) goto S50; ignpoi = (long) (mu+s*t); fk = (double)ignpoi; difmuk = mu-fk; /* 'SUBROUTINE' F IS CALLED (KFLAG=1 FOR CORRECT RETURN) */ kflag = 1; goto S70; S60: /* STEP H. HAT ACCEPTANCE (E IS REPEATED ON REJECTION) */ if(c*fabs(u) > py*exp(px+e)-fy*exp(fx+e)) goto S50; return ignpoi; S70: /* STEP F. 'SUBROUTINE' F. CALCULATION OF PX,PY,FX,FY. CASE IGNPOI .LT. 10 USES FACTORIALS FROM TABLE FACT */ if(ignpoi >= 10) goto S80; px = -mu; py = pow(mu,(double)ignpoi)/ *(fact+ignpoi); goto S110; S80: /* CASE IGNPOI .GE. 10 USES POLYNOMIAL APPROXIMATION A0-A7 FOR ACCURACY WHEN ADVISABLE .8333333E-1=1./12. .3989423=(2*PI)**(-.5) */ del = 8.33333333E-2/fk; del -= (4.8*del*del*del); v = difmuk/fk; if(fabs(v) <= 0.25) goto S90; px = fk*log(1.0+v)-difmuk-del; goto S100; S90: px = fk*v*v*((((((((a8*v+a7)*v+a6)*v+a5)*v+a4)*v+a3)*v+a2)*v+a1)*v+a0)-del; S100: py = 0.398942280401433/sqrt(fk); S110: x = (0.5-difmuk)/s; xx = x*x; fx = -0.5*xx; fy = omega*(((c3*xx+c2)*xx+c1)*xx+c0); if(kflag <= 0) goto S40; goto S60; S120: /* C A S E B. (START NEW TABLE AND CALCULATE P0 IF NECESSARY) JJV changed MUPREV assignment to initial value */ muprev = -1.0E37; if(mu == muold) goto S130; /* JJV added argument checker here */ if(mu >= 0.0) goto S125; fprintf(stderr,"MU < 0 in IGNPOI: MU %16.6E\n",mu); fputs("Abort\n",stderr); exit(1); S125: muold = mu; m = max(1L,(long) (mu)); l = 0; p = exp(-mu); q = p0 = p; S130: /* STEP U. UNIFORM SAMPLE FOR INVERSION METHOD */ u = ranf(); ignpoi = 0; if(u <= p0) return ignpoi; /* STEP T. TABLE COMPARISON UNTIL THE END PP(L) OF THE PP-TABLE OF CUMULATIVE POISSON PROBABILITIES (0.458=PP(9) FOR MU=10) */ if(l == 0) goto S150; j = 1; if(u > 0.458) j = min(l,m); for(k=j; k<=l; k++) { if(u <= *(pp+k-1)) goto S180; } if(l == 35) goto S130; S150: /* STEP C. CREATION OF NEW POISSON PROBABILITIES P AND THEIR CUMULATIVES Q=PP(K) */ l += 1; for(k=l; k<=35; k++) { p = p*mu/(double)k; q += p; *(pp+k-1) = q; if(u <= q) goto S170; } l = 35; goto S130; S170: l = k; S180: ignpoi = k; return ignpoi; } long ignuin(long low,long high) /* ********************************************************************** long ignuin(long low,long high) GeNerate Uniform INteger Function Generates an integer uniformly distributed between LOW and HIGH. Arguments low --> Low bound (inclusive) on integer value to be generated high --> High bound (inclusive) on integer value to be generated Note If (HIGH-LOW) > 2,147,483,561 prints error message on * unit and stops the program. ********************************************************************** IGNLGI generates integers between 1 and 2147483562 MAXNUM is 1 less than maximum generable value */ { #define maxnum 2147483561L static long ignuin,ign,maxnow,range,ranp1; if(!(low > high)) goto S10; fputs(" low > high in ignuin - ABORT\n",stderr); exit(1); S10: range = high-low; if(!(range > maxnum)) goto S20; fputs(" high - low too large in ignuin - ABORT\n",stderr); exit(1); S20: if(!(low == high)) goto S30; ignuin = low; return ignuin; S30: /* Number to be generated should be in range 0..RANGE Set MAXNOW so that the number of integers in 0..MAXNOW is an integral multiple of the number in 0..RANGE */ ranp1 = range+1; maxnow = maxnum/ranp1*ranp1; S40: ign = ignlgi()-1; if(!(ign <= maxnow)) goto S40; ignuin = low+ign%ranp1; return ignuin; #undef maxnum #undef err1 #undef err2 } long lennob( char *str ) /* Returns the length of str ignoring trailing blanks but not other white space. */ { long i, i_nb; for (i=0, i_nb= -1L; *(str+i); i++) if ( *(str+i) != ' ' ) i_nb = i; return (i_nb+1); } long mltmod(long a,long s,long m) /* ********************************************************************** long mltmod(long a,long s,long m) Returns (A*S) MOD M This is a transcription from Pascal to C of routine MultMod_Decompos from the paper L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package with Splitting Facilities." ACM Transactions on Mathematical Software, 17:98-111 (1991) Arguments a, s, m --> WGR, 12/19/00: replaced S10, S20, etc. with C blocks {} per original paper. ********************************************************************** */ { #define h 32768L static long a0,a1,k,p,q,qh,rh; /* H = 2**((b-2)/2) where b = 32 because we are using a 32 bit machine. On a different machine recompute H. */ if (a <= 0 || a >= m || s <= 0 || s >= m) { fputs(" a, m, s out of order in mltmod - ABORT!\n",stderr); fprintf(stderr," a = %12ld s = %12ld m = %12ld\n",a,s,m); fputs(" mltmod requires: 0 < a < m; 0 < s < m\n",stderr); exit(1); } if (a < h) { a0 = a; p = 0; } else { a1 = a/h; a0 = a - h*a1; qh = m/h; rh = m - h*qh; if (a1 >= h) { /* A2=1 */ a1 -= h; k = s/qh; p = h*(s-k*qh) - k*rh; while (p < 0) { p += m; } } else { p = 0; } /* P = (A2*S*H)MOD M */ if (a1 != 0) { q = m/a1; k = s/q; p -= k*(m - a1*q); if (p > 0) { p -= m; } p += a1*(s - k*q); while (p < 0) { p += m; } } /* P = ((A2*H + A1)*S)MOD M */ k = p/qh; p = h*(p-k*qh) - k*rh; while (p < 0) { p += m; } } /* P = ((A2*H + A1)*H*S)MOD M */ if (a0 != 0) { q = m/a0; k = s/q; p -= k*(m-a0*q); if (p > 0) { p -= m; } p += a0*(s-k*q); while (p < 0) { p += m; } } return p; #undef h } void phrtsd(char* phrase,long *seed1,long *seed2) /* ********************************************************************** void phrtsd(char* phrase,long *seed1,long *seed2) PHRase To SeeDs Function Uses a phrase (character string) to generate two seeds for the RGN random number generator. Arguments phrase --> Phrase to be used for random number generation seed1 <-- First seed for generator seed2 <-- Second seed for generator Note Trailing blanks are eliminated before the seeds are generated. Generated seed values will fall in the range 1..2^30 (1..1,073,741,824) ********************************************************************** */ { static char table[] = "abcdefghijklmnopqrstuvwxyz\ ABCDEFGHIJKLMNOPQRSTUVWXYZ\ 0123456789\ !@#$%^&*()_+[];:'\\\"<>?,./ "; /* WGR added space, 5/19/1999 */ long ix; static long twop30 = 1073741824L; static long shift[5] = { 1L,64L,4096L,262144L,16777216L }; #ifdef PHRTSD_ORIG /*----------------------------- Original phrtsd */ static long i,ichr,j,lphr,values[5]; extern long lennob(char *str); *seed1 = 1234567890L; *seed2 = 123456789L; lphr = lennob(phrase); if(lphr < 1) return; for(i=0; i<=(lphr-1); i++) { for (ix=0; table[ix]; ix++) if (*(phrase+i) == table[ix]) break; /* JJV added ix++; to bring index in line with fortran's index*/ ix++; if (!table[ix]) ix = 0; ichr = ix % 64; if(ichr == 0) ichr = 63; for(j=1; j<=5; j++) { *(values+j-1) = ichr-j; if(*(values+j-1) < 1) *(values+j-1) += 63; } for(j=1; j<=5; j++) { *seed1 = ( *seed1+*(shift+j-1)**(values+j-1) ) % twop30; *seed2 = ( *seed2+*(shift+j-1)**(values+6-j-1) ) % twop30; } } #else /*----------------------------- New phrtsd */ static long i,j, ichr,lphr; static long values[8] = { 8521739, 5266711, 3254959, 2011673, 1243273, 768389, 474899, 293507 }; extern long lennob(char *str); *seed1 = 1234567890L; *seed2 = 123456789L; lphr = lennob(phrase); if(lphr < 1) return; for(i=0; i<(lphr-1); i++) { ichr = phrase[i]; j = i % 8; *seed1 = ( *seed1 + (values[j] * ichr) ) % twop30; *seed2 = ( *seed2 + (values[7-j] * ichr) ) % twop30; } #endif } double ranf(void) /* ********************************************************************** double ranf(void) RANDom number generator as a Function Returns a random floating point number from a uniform distribution over 0 - 1 (endpoints of this interval are not returned) using the current generator. This is a transcription from Pascal to C of routine Uniform_01 from the paper L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package with Splitting Facilities." ACM Transactions on Mathematical Software, 17:98-111 (1991) WGR, 2/12/01: increased precision. ********************************************************************** */ { static double ranf; /* 4.656613057E-10 is 1/M1 M1 is set in a data statement in IGNLGI and is currently 2147483563. If M1 changes, change this also. */ ranf = ignlgi()*4.65661305739177E-10; return ranf; } void setgmn(double *meanv,double *covm,long p,double *parm) /* ********************************************************************** void setgmn(double *meanv,double *covm,long p,double *parm) SET Generate Multivariate Normal random deviate Function Places P, MEANV, and the Cholesky factorization of COVM in GENMN. Arguments meanv --> Mean vector of multivariate normal distribution. covm <--> (Input) Covariance matrix of the multivariate normal distribution (Output) Destroyed on output p --> Dimension of the normal, or length of MEANV. parm <-- Array of parameters needed to generate multivariate norma deviates (P, MEANV and Cholesky decomposition of COVM). 1 : 1 - P 2 : P + 1 - MEANV P+2 : P*(P+3)/2 + 1 - Cholesky decomposition of COVM Needed dimension is (p*(p+3)/2 + 1) ********************************************************************** */ { extern void spofa(double *a,long lda,long n,long *info); static long T1; static long i,icount,info,j,D2,D3,D4,D5; T1 = p*(p+3)/2+1; /* TEST THE INPUT */ if(!(p <= 0)) goto S10; fputs("P nonpositive in SETGMN\n",stderr); fprintf(stderr,"Value of P: %12ld\n",p); exit(1); S10: *parm = p; /* PUT P AND MEANV INTO PARM */ for(i=2,D2=1,D3=(p+1-i+D2)/D2; D3>0; D3--,i+=D2) *(parm+i-1) = *(meanv+i-2); /* Cholesky decomposition to find A s.t. trans(A)*(A) = COVM */ spofa(covm,p,p,&info); if(!(info != 0)) goto S30; fputs(" COVM not positive definite in SETGMN\n",stderr); exit(1); S30: icount = p+1; /* PUT UPPER HALF OF A, WHICH IS NOW THE CHOLESKY FACTOR, INTO PARM COVM(1,1) = PARM(P+2) COVM(1,2) = PARM(P+3) : COVM(1,P) = PARM(2P+1) COVM(2,2) = PARM(2P+2) ... */ for(i=1,D4=1,D5=(p-i+D4)/D4; D5>0; D5--,i+=D4) { for(j=i-1; j *q1) goto S60; sexpo = a+u; return sexpo; S60: i = 1; ustar = ranf(); umin = ustar; S70: ustar = ranf(); if(ustar < umin) umin = ustar; i += 1; if(u > *(q+i-1)) goto S70; sexpo = a+umin**q1; return sexpo; } double sgamma(double a) /* ********************************************************************** (STANDARD-) G A M M A DISTRIBUTION ********************************************************************** ********************************************************************** PARAMETER A >= 1.0 ! ********************************************************************** FOR DETAILS SEE: AHRENS, J.H. AND DIETER, U. GENERATING GAMMA VARIATES BY A MODIFIED REJECTION TECHNIQUE. COMM. ACM, 25,1 (JAN. 1982), 47 - 54. STEP NUMBERS CORRESPOND TO ALGORITHM 'GD' IN THE ABOVE PAPER (STRAIGHTFORWARD IMPLEMENTATION) Modified by Barry W. Brown, Feb 3, 1988 to use RANF instead of SUNIF. The argument IR thus goes away. ********************************************************************** PARAMETER 0.0 < A < 1.0 ! ********************************************************************** FOR DETAILS SEE: AHRENS, J.H. AND DIETER, U. COMPUTER METHODS FOR SAMPLING FROM GAMMA, BETA, POISSON AND BINOMIAL DISTRIBUTIONS. COMPUTING, 12 (1974), 223 - 246. (ADAPTED IMPLEMENTATION OF ALGORITHM 'GS' IN THE ABOVE PAPER) ********************************************************************** INPUT: A =PARAMETER (MEAN) OF THE STANDARD GAMMA DISTRIBUTION OUTPUT: SGAMMA = SAMPLE FROM THE GAMMA-(A)-DISTRIBUTION COEFFICIENTS Q(K) - FOR Q0 = SUM(Q(K)*A**(-K)) COEFFICIENTS A(K) - FOR Q = Q0+(T*T/2)*SUM(A(K)*V**K) COEFFICIENTS E(K) - FOR EXP(Q)-1 = SUM(E(K)*Q**K) PREVIOUS A PRE-SET TO ZERO - AA IS A', AAA IS A" SQRT32 IS THE SQUAREROOT OF 32 = 5.656854249492380 */ { extern double fsign( double num, double sign ); static double q1 = 4.16666664E-2; static double q2 = 2.08333723E-2; static double q3 = 7.9849875E-3; static double q4 = 1.5746717E-3; static double q5 = -3.349403E-4; static double q6 = 3.340332E-4; static double q7 = 6.053049E-4; static double q8 = -4.701849E-4; static double q9 = 1.710320E-4; static double a1 = 0.333333333; static double a2 = -0.249999949; static double a3 = 0.199999867; static double a4 = -0.166677482; static double a5 = 0.142873973; static double a6 = -0.124385581; static double a7 = 0.110368310; static double a8 = -0.112750886; static double a9 = 0.104089866; static double e1 = 1.0; static double e2 = 0.499999994; static double e3 = 0.166666848; static double e4 = 4.1664508E-2; static double e5 = 8.345522E-3; static double e6 = 1.353826E-3; static double e7 = 2.47453E-4; static double aa = 0.0; static double aaa = 0.0; static double sqrt32 = 5.65685424949238; /* JJV added b0 to fix rare and subtle bug */ static double sgamma,s2,s,d,t,x,u,r,q0,b,b0,si,c,v,q,e,w,p; if(a == aa) goto S10; if(a < 1.0) goto S120; /* STEP 1: RECALCULATIONS OF S2,S,D IF A HAS CHANGED */ aa = a; s2 = a-0.5; s = sqrt(s2); d = sqrt32-12.0*s; S10: /* STEP 2: T=STANDARD NORMAL DEVIATE, X=(S,1/2)-NORMAL DEVIATE. IMMEDIATE ACCEPTANCE (I) */ t = snorm(); x = s+0.5*t; sgamma = x*x; if(t >= 0.0) return sgamma; /* STEP 3: U= 0,1 -UNIFORM SAMPLE. SQUEEZE ACCEPTANCE (S) */ u = ranf(); if(d*u <= t*t*t) return sgamma; /* STEP 4: RECALCULATIONS OF Q0,B,SI,C IF NECESSARY */ if(a == aaa) goto S40; aaa = a; r = 1.0/a; q0 = ((((((((q9*r+q8)*r+q7)*r+q6)*r+q5)*r+q4)*r+q3)*r+q2)*r+q1)*r; /* APPROXIMATION DEPENDING ON SIZE OF PARAMETER A THE CONSTANTS IN THE EXPRESSIONS FOR B, SI AND C WERE ESTABLISHED BY NUMERICAL EXPERIMENTS */ if(a <= 3.686) goto S30; if(a <= 13.022) goto S20; /* CASE 3: A .GT. 13.022 */ b = 1.77; si = 0.75; c = 0.1515/s; goto S40; S20: /* CASE 2: 3.686 .LT. A .LE. 13.022 */ b = 1.654+7.6E-3*s2; si = 1.68/s+0.275; c = 6.2E-2/s+2.4E-2; goto S40; S30: /* CASE 1: A .LE. 3.686 */ b = 0.463+s+0.178*s2; si = 1.235; c = 0.195/s-7.9E-2+1.6E-1*s; S40: /* STEP 5: NO QUOTIENT TEST IF X NOT POSITIVE */ if(x <= 0.0) goto S70; /* STEP 6: CALCULATION OF V AND QUOTIENT Q */ v = t/(s+s); if(fabs(v) <= 0.25) goto S50; q = q0-s*t+0.25*t*t+(s2+s2)*log(1.0+v); goto S60; S50: q = q0+0.5*t*t*((((((((a9*v+a8)*v+a7)*v+a6)*v+a5)*v+a4)*v+a3)*v+a2)*v+a1)*v; S60: /* STEP 7: QUOTIENT ACCEPTANCE (Q) */ if(log(1.0-u) <= q) return sgamma; S70: /* STEP 8: E=STANDARD EXPONENTIAL DEVIATE U= 0,1 -UNIFORM DEVIATE T=(B,SI)-DOUBLE EXPONENTIAL (LAPLACE) SAMPLE */ e = sexpo(); u = ranf(); u += (u-1.0); t = b+fsign(si*e,u); /* STEP 9: REJECTION IF T .LT. TAU(1) = -.71874483771719 */ if(t < -0.71874483771719) goto S70; /* STEP 10: CALCULATION OF V AND QUOTIENT Q */ v = t/(s+s); if(fabs(v) <= 0.25) goto S80; q = q0-s*t+0.25*t*t+(s2+s2)*log(1.0+v); goto S90; S80: q = q0+0.5*t*t*((((((((a9*v+a8)*v+a7)*v+a6)*v+a5)*v+a4)*v+a3)*v+a2)*v+a1)*v; S90: /* STEP 11: HAT ACCEPTANCE (H) (IF Q NOT POSITIVE GO TO STEP 8) */ if(q <= 0.0) goto S70; if(q <= 0.5) goto S100; /* * JJV modified the code through line 115 to handle large Q case */ if(q < 15.0) goto S95; /* * JJV Here Q is large enough that Q = log(exp(Q) - 1.0) (for real Q) * JJV so reformulate test at 110 in terms of one EXP, if not too big * JJV 87.49823 is close to the largest real which can be * JJV exponentiated (87.49823 = log(1.0E38)) */ if((q+e-0.5*t*t) > 87.4982335337737) goto S115; if(c*fabs(u) > exp(q+e-0.5*t*t)) goto S70; goto S115; S95: w = exp(q)-1.0; goto S110; S100: w = ((((((e7*q+e6)*q+e5)*q+e4)*q+e3)*q+e2)*q+e1)*q; S110: /* IF T IS REJECTED, SAMPLE AGAIN AT STEP 8 */ if(c*fabs(u) > w*exp(e-0.5*t*t)) goto S70; S115: x = s+0.5*t; sgamma = x*x; return sgamma; S120: /* ALTERNATE METHOD FOR PARAMETERS A BELOW 1 (.3678794=EXP(-1.)) JJV changed B to B0 (which was added to declarations for this) JJV in 120 to END to fix rare and subtle bug. JJV Line: 'aa = 0.0' was removed (unnecessary, wasteful). JJV Reasons: the state of AA only serves to tell the A >= 1.0 JJV case if certain A-dependent constants need to be recalculated. JJV The A < 1.0 case (here) no longer changes any of these, and JJV the recalculation of B (which used to change with an JJV A < 1.0 call) is governed by the state of AAA anyway. aa = 0.0; */ b0 = 1.0+ 0.3678794411714423*a; S130: p = b0*ranf(); if(p >= 1.0) goto S140; sgamma = exp(log(p)/ a); if(sexpo() < sgamma) goto S130; return sgamma; S140: sgamma = -log((b0-p)/ a); if(sexpo() < (1.0-a)*log(sgamma)) goto S130; return sgamma; } double snorm(void) /* ********************************************************************** (STANDARD-) N O R M A L DISTRIBUTION ********************************************************************** ********************************************************************** FOR DETAILS SEE: AHRENS, J.H. AND DIETER, U. EXTENSIONS OF FORSYTHE'S METHOD FOR RANDOM SAMPLING FROM THE NORMAL DISTRIBUTION. MATH. COMPUT., 27,124 (OCT. 1973), 927 - 937. ALL STATEMENT NUMBERS CORRESPOND TO THE STEPS OF ALGORITHM 'FL' (M=5) IN THE ABOVE PAPER (SLIGHTLY MODIFIED IMPLEMENTATION) Modified by Barry W. Brown, Feb 3, 1988 to use RANF instead of SUNIF. The argument IR thus goes away. ********************************************************************** THE DEFINITIONS OF THE CONSTANTS A(K), D(K), T(K) AND H(K) ARE ACCORDING TO THE ABOVEMENTIONED ARTICLE */ { static double a[32] = { 0.0, 0.03917608550309, 0.07841241273311, 0.11776987457909, 0.15731068461017, 0.19709908429430, 0.23720210932878, 0.27769043982157, 0.31863936396437, 0.36012989178957, 0.40225006532172, 0.44509652498551, 0.48877641111466, 0.53340970624127, 0.57913216225555, 0.62609901234641, 0.67448975019607, 0.72451438349236, 0.77642176114792, 0.83051087820539, 0.88714655901887, 0.94678175630104, 1.00999016924958, 1.07751556704027, 1.15034938037600, 1.22985875921658, 1.31801089730353, 1.41779713799625, 1.53412054435253, 1.67593972277344, 1.86273186742164, 2.15387469406144 }; static double d[31] = { 0.0, 0.0, 0.0, 0.0, 0.0, 0.26368432217502, 0.24250845238097, 0.22556744380930, 0.21163416577204, 0.19992426749317, 0.18991075842246, 0.18122518100691, 0.17360140038056, 0.16684190866667, 0.16079672918053, 0.15534971747692, 0.15040938382813, 0.14590257684509, 0.14177003276856, 0.13796317369537, 0.13444176150074, 0.13117215026483, 0.12812596512583, 0.12527909006226, 0.12261088288608, 0.12010355965651, 0.11774170701949, 0.11551189226063, 0.11340234879117, 0.11140272044119, 0.10950385201710 }; static double t[31] = { 7.6738283767E-4, 2.30687039764E-3, 3.86061844387E-3, 5.43845406707E-3, 7.05069876857E-3, 8.70839582019E-3, 1.042356984914E-2, 1.220953194966E-2, 1.408124734637E-2, 1.605578804548E-2, 1.815290075142E-2, 2.039573175398E-2, 2.281176732513E-2, 2.543407332319E-2, 2.830295595118E-2, 3.146822492920E-2, 3.499233438388E-2, 3.895482964836E-2, 4.345878381672E-2, 4.864034918076E-2, 5.468333844273E-2, 6.184222395816E-2, 7.047982761667E-2, 8.113194985866E-2, 9.462443534514E-2, 0.11230007889456, 0.13649799954975, 0.17168856004707, 0.22762405488269, 0.33049802776911, 0.58470309390507 }; static double h[31] = { 3.920617164634E-2, 3.932704963665E-2, 3.950999486086E-2, 3.975702679515E-2, 4.007092772490E-2, 4.045532602655E-2, 4.091480886081E-2, 4.145507115859E-2, 4.208311051344E-2, 4.280748137995E-2, 4.363862733472E-2, 4.458931789605E-2, 4.567522779560E-2, 4.691571371696E-2, 4.833486978119E-2, 4.996298427702E-2, 5.183858644724E-2, 5.401138183398E-2, 5.654656186515E-2, 5.953130423884E-2, 6.308488965373E-2, 6.737503494905E-2, 7.264543556657E-2, 7.926471414968E-2, 8.781922325338E-2, 9.930398323927E-2, 0.11555994154118, 0.14043438342816, 0.18361418337460, 0.27900163464163, 0.70104742502766 }; static long i; static double snorm,u,s,ustar,aa,w,y,tt; u = ranf(); s = 0.0; if(u > 0.5) s = 1.0; u += (u-s); u = 32.0*u; i = (long) (u); if(i == 32) i = 31; if(i == 0) goto S100; /* START CENTER */ ustar = u-(double)i; aa = *(a+i-1); S40: if(ustar <= *(t+i-1)) goto S60; w = (ustar-*(t+i-1))**(h+i-1); S50: /* EXIT (BOTH CASES) */ y = aa+w; snorm = y; if(s == 1.0) snorm = -y; return snorm; S60: /* CENTER CONTINUED */ u = ranf(); w = u*(*(a+i)-aa); tt = (0.5*w+aa)*w; goto S80; S70: tt = u; ustar = ranf(); S80: if(ustar > tt) goto S50; u = ranf(); if(ustar >= u) goto S70; ustar = ranf(); goto S40; S100: /* START TAIL */ i = 6; aa = *(a+31); goto S120; S110: aa += *(d+i-1); i += 1; S120: u += u; if(u < 1.0) goto S110; u -= 1.0; S140: w = u**(d+i-1); tt = (0.5*w+aa)*w; goto S160; S150: tt = u; S160: ustar = ranf(); if(ustar > tt) goto S50; u = ranf(); if(ustar >= u) goto S150; u = ranf(); goto S140; } double fsign( double num, double sign ) /* Transfers sign of argument sign to argument num */ { if ( ( sign>0.0f && num<0.0f ) || ( sign<0.0f && num>0.0f ) ) return -num; else return num; } /************************************************************************ FTNSTOP: Prints msg to standard error and then exits ************************************************************************/ void ftnstop(char* msg) /* msg - error message */ { if (msg != NULL) fprintf(stderr,"%s\n",msg); exit(0); } double sqrt32 = 5.65685424949238; /* JJV added b0 to fix rare and subtle bug */ static double sgamma,s2,s,d,t,x,u,r,q0,b,b0,si,c,v,q,e,w,p; if(a == aa) goto S10; if(a < 1.0) goto S120; /* STEP 1: RECALCULATIONS OF S2,S,D IF A HAS CHANGED */ aa = a; s2 = aMath-Random-0.71/META.yml100644 017522 000266 00000000451 11064014750 014502 0ustar00yxrdss000000 000000 # http://module-build.sourceforge.net/META-spec.html #XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# name: Math-Random version: 0.71 version_from: Random.pm installdirs: site requires: distribution_type: module generated_by: ExtUtils::MakeMaker version 6.17 0.67448975019607, 0.72451438349236, 0.77642176114792, 0.83051087820539, 0.88714655901887, 0.94678175630104, 1.00999016924958, 1.07751556704027, 1.15034938037600, 1.22985875921658, 1.31801089730353, 1.417Math-Random-0.71/Index100644 017522 000266 00000002124 11064014432 014217 0ustar00yxrdss000000 000000 advnst com.c fsign randlib.c ftnstop randlib.c ftnstop randlib.c genbet randlib.c genchi randlib.c genexp randlib.c genf randlib.c gengam randlib.c genmn randlib.c genmul randlib.c gennch randlib.c gennf randlib.c gennor randlib.c genprm randlib.c genunf randlib.c getsd com.c gscgn randlib.c gsrgs randlib.c gssst randlib.c gvprfw helper.c gvpriw helper.c ignbin randlib.c ignlgi com.c ignnbn randlib.c ignpoi randlib.c ignuin randlib.c initgn com.c inrgcm com.c lennob randlib.c mltmod randlib.c pgenmn helper.c pgnmul helper.c pgnprm helper.c phrtsd randlib.c psetmn helper.c ranf randlib.c rsprfw helper.c rspriw helper.c salfph helper.c sdot linpack.c setall com.c setant com.c setgmn randlib.c setsd com.c sexpo randlib.c sgamma randlib.c snorm randlib.c spofa linpack.c svprfw helper.c 5.43845406707E-3, 7.05069876857E-3, 8.70839582019E-3, 1.042356984914E-2, 1.220953194966E-2, 1.408124734637E-2, 1.605578804548E-2, 1.815290075142E-2, 2.039573175398E-2, 2.281176732513E-2, 2.543407332319E-2, 2.830295595118E-2, 3.146822492920E-2, 3.499233438388E-2, 3.895482964836E-2, 4.345878381672E-2, 4.864034918076E-2, 5.468333844273E-2, 6.184222395816E-2, 7.047982761667E-2, 8.113194985866E-2, 9.4624Math-Random-0.71/Random.xs100644 017522 000266 00000004422 11064014433 015025 0ustar00yxrdss000000 000000 #ifdef __cplusplus extern "C" { #endif #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #ifdef __cplusplus } #endif #include "randlib.h" #include "helper.h" static int not_here(s) char *s; { croak("%s not implemented on this architecture", s); return -1; } static double constant(name, arg) char *name; int arg; { errno = 0; switch (*name) { } errno = EINVAL; return 0; not_there: errno = ENOENT; return 0; } MODULE = Math::Random PACKAGE = Math::Random double genbet (aa,bb) INPUT: double aa double bb double genchi (df) INPUT: double df double genexp (av) INPUT: double av double genf (dfn,dfd) INPUT: double dfn double dfd double gengam (a,r) INPUT: double a double r int psetmn (p) INPUT: long p int pgenmn () PROTOTYPE: INPUT: CODE: RETVAL = pgenmn(); OUTPUT: RETVAL int rspriw (size) INPUT: long size int rsprfw (size) INPUT: long size void svprfw (index,value) INPUT: long index double value void pgnmul (n,ncat) INPUT: long n long ncat long gvpriw (index) INPUT: long index double gennch (df,xnonc) INPUT: double df double xnonc double gennf (dfn,dfd,xnonc) INPUT: double dfn double dfd double xnonc double gennor (av,sd) INPUT: double av double sd void pgnprm (n) PROTOTYPE: $ INPUT: long n CODE: pgnprm(n); OUTPUT: double genunf (low,high) INPUT: double low double high long ignpoi (mu) INPUT: double mu long ignuin (low,high) INPUT: long low long high long ignnbn (n,p) INPUT: long n double p long ignbin (n,pp) INPUT: long n double pp void phrtsd (phrase) PROTOTYPE: $ INPUT: char * phrase PREINIT: long newseed1; long newseed2; PPCODE: phrtsd(phrase,&newseed1,&newseed2); EXTEND(sp, 2); PUSHs(sv_2mortal(newSViv(newseed1))); PUSHs(sv_2mortal(newSViv(newseed2))); void getsd () PROTOTYPE: PREINIT: long newseed1; long newseed2; PPCODE: getsd(&newseed1,&newseed2); EXTEND(sp, 2); PUSHs(sv_2mortal(newSViv(newseed1))); PUSHs(sv_2mortal(newSViv(newseed2))); void salfph (phrase) PROTOTYPE: $ INPUT: char * phrase CODE: salfph(phrase); OUTPUT: void setall (iseed1,iseed2) PROTOTYPE: $$ INPUT: long iseed1 long iseed2 CODE: setall(iseed1,iseed2); OUTPUT: double gvprfw (index) INPUT: long index static double constant(name, arg) char *name; int arg; { errno = 0; switch (*name) { } errno = EINVAL; return 0; not_there: errno = ENOENT; return 0; } MODULE = Math::Random PACKAGE = Math::Random doubMath-Random-0.71/linpack.c100644 017522 000266 00000005177 11064014433 015026 0ustar00yxrdss000000 000000 #include double sdot(long n,double *sx,long incx,double *sy,long incy) { static long i,ix,iy,m,mp1; static double sdot,stemp; stemp = sdot = 0.0; if(n <= 0) return sdot; if(incx == 1 && incy == 1) goto S20; ix = iy = 1; if(incx < 0) ix = (-n+1)*incx+1; if(incy < 0) iy = (-n+1)*incy+1; for(i=1; i<=n; i++) { stemp += (*(sx+ix-1)**(sy+iy-1)); ix += incx; iy += incy; } sdot = stemp; return sdot; S20: m = n % 5L; if(m == 0) goto S40; for(i=0; i tt) goto S50; u = ranf(); if(ustar >= u) goto S70; ustar = ranf(); goto S40; S100: /* START TAIL */ i = 6; aa = *(a+31); goto S120; S110: aa += *(d+i-1); i += 1; S120: u += u; if(u < 1.0) goto S110; u -= 1.0; S140: w = u**(d+i-1); tt = (0.5*w+aaMath-Random-0.71/Random.pm100755 017522 000266 00000110470 11064014670 015016 0ustar00yxrdss000000 000000 package Math::Random; use strict; use Carp; use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $AUTOLOAD); require Exporter; require DynaLoader; require AutoLoader; @ISA = qw(Exporter DynaLoader); $VERSION = '0.71'; @EXPORT = qw(random_normal random_permutation random_permuted_index random_uniform random_uniform_integer random_seed_from_phrase random_get_seed random_set_seed_from_phrase random_set_seed ); @EXPORT_OK = qw(random_beta random_chi_square random_exponential random_f random_gamma random_multivariate_normal random_multinomial random_noncentral_chi_square random_noncentral_f random_normal random_permutation random_permuted_index random_uniform random_poisson random_uniform_integer random_negative_binomial random_binomial random_seed_from_phrase random_get_seed random_set_seed_from_phrase random_set_seed ); %EXPORT_TAGS = ( all => [ @EXPORT_OK ] ); sub AUTOLOAD { # This AUTOLOAD is used to 'autoload' constants from the constant() # XS function. If a constant is not found then control is passed # to the AUTOLOAD in AutoLoader. my $constname; ($constname = $AUTOLOAD) =~ s/.*:://; croak "& not defined" if $constname eq 'constant'; my $val = constant($constname, @_ ? $_[0] : 0); if ($! != 0) { if ($! =~ /Invalid/) { $AutoLoader::AUTOLOAD = $AUTOLOAD; goto &AutoLoader::AUTOLOAD; } else { croak "Your vendor has not defined Math::Random macro $constname"; } } *$AUTOLOAD = sub () { $val }; goto &$AUTOLOAD; } bootstrap Math::Random $VERSION; ### set seeds by default salfph(scalar(localtime())); ##################################################################### # RANDOM DEVIATE GENERATORS # ##################################################################### sub random_beta { # Arguments: ($n,$aa,$bb) croak "Usage: random_beta(\$n,\$aa,\$bb)" if scalar(@_) < 3; my($n, $aa, $bb) = @_; croak("($aa = \$aa < 1.0E-37) or ($bb = \$bb < 1.0E-37)\nin ". "random_beta(\$n,\$aa,\$bb)") if (($aa < 1.0E-37) or ($bb < 1.0E-37)); return genbet($aa,$bb) unless wantarray(); my $val; my @ans = (0) x $n; foreach $val (@ans) { $val = genbet($aa,$bb); } return @ans; } sub random_chi_square { # Arguments: ($n,$df) croak "Usage: random_chi_square(\$n,\$df)" if scalar(@_) < 2; my($n, $df) = @_; croak "$df = \$df <= 0\nin random_chi_square(\$n,\$df)" if ($df <= 0); return genchi($df) unless wantarray(); my $val; my @ans = (0) x $n; foreach $val (@ans) { $val = genchi($df); } return @ans; } sub random_exponential { # Arguments: ($n,$av), defaults (1,1) return wantarray() ? (genexp(1)) : genexp(1) if scalar(@_) == 0; # default behavior if no arguments my($n, $av) = @_; $av = 1 unless defined($av); # default $av is 1 croak "$av = \$av < 0\nin random_exponential(\$n,\$av)" if ($av < 0); return genexp($av) unless wantarray(); my $val; my @ans = (0) x $n; foreach $val (@ans) { $val = genexp($av); } return @ans; } sub random_f { # Arguments: ($n,$dfn,$dfd) croak "Usage: random_f(\$n,\$dfn,\$dfd)" if scalar(@_) < 3; my($n, $dfn, $dfd) = @_; croak("($dfn = \$dfn <= 0) or ($dfd = \$dfd <= 0)\nin ". "random_f(\$n,\$dfn,\$dfd)") if (($dfn <= 0) or ($dfd <= 0)); return genf($dfn,$dfd) unless wantarray(); my $val; my @ans = (0) x $n; foreach $val (@ans) { $val = genf($dfn,$dfd); } return @ans; } sub random_gamma { # Arguments: ($n,$a,$r) croak "Usage: random_gamma(\$n,\$a,\$r)" if scalar(@_) < 3; my($n, $a, $r) = @_; croak "($a = \$a <= 0) or ($r = \$r <= 0)\nin random_gamma(\$n,\$a,\$r)" if (($a <= 0) or ($r <= 0)); return gengam($a,$r) unless wantarray(); my $val; my @ans = (0) x $n; foreach $val (@ans) { $val = gengam($a,$r); } return @ans; } sub random_multivariate_normal { # Arguments: ($n, @mean, @covar(2-dim'l)) croak "Usage: random_multivariate_normal(\$n,\@mean,\@covar(2-dim'l))" if (scalar(@_)) < 3; my $n = shift(@_); # first element is number of obs. desired my $p = scalar(@_)/2; # best guess at dimension of deviate # check outline of arguments croak("Sizes of \@mean and \@covar don't match\nin ". "random_multivariate_normal(\$n, \@mean, \@covar(2-dim'l))") unless (($p == int($p)) and ("$_[$p - 1]" !~ /^ARRAY/) and ("$_[$p]" =~ /^ARRAY/)); # linearize input - it seems faster to push my @linear = (); push @linear, splice(@_, 0, $p); # fill first $p slots w/ mean # expand array references my $ref; foreach $ref (@_) { # for the rest of the input # check length of row of @covariance croak("\@covar is not a $p by $p array ($p is size of \@mean)\nin ". "random_multivariate_normal(\$n, \@mean, \@covar(2-dim'l))") unless (scalar(@{$ref}) == $p); push @linear, @{$ref}; } # load float working array with linearized input putflt(@linear) or croak "Unable to allocate memory\nin random_multivariate_normal"; # initialize parameter array for multivariate normal generator psetmn($p) or croak "Unable to allocate memory\nin random_multivariate_normal"; unless (wantarray()) { ### if called in a scalar context, returns single refernce to obs pgenmn(); return [ getflt($p) ]; } # otherwise return an $n by $p array of obs. my @ans = (0) x $n; foreach $ref (@ans) { pgenmn(); $ref = [ getflt($p) ]; } return @ans; } sub random_multinomial { # Arguments: ($n,@p) my($n, @p) = @_; my $ncat = scalar(@p); # number of categories $n = int($n); croak "$n = \$n < 0\nin random_multinomial(\$n,\@p)" if ($n < 0); croak "$ncat = (length of \@p) < 2\nin random_multinomial(\$n,\@p)" if ($ncat < 2); rspriw($ncat) or croak "Unable to allocate memory\nin random_multinomial"; my($i,$sum,$val) = (0,0,0); pop @p; rsprfw(scalar(@p)) or croak "Unable to allocate memory\nin random_multinomial"; foreach $val (@p) { croak "$val = (some \$p[i]) < 0 or > 1\nin random_multinomial(\$n,\@p)" if (($val < 0) or ($val > 1)); svprfw($i,$val); $i++; $sum += $val; } croak "Sum of \@p > 1\nin random_multinomial(\$n,\@p)" if ($sum > 0.99999); pgnmul($n, $ncat); ### get the results $i = 0; foreach $val (@p) { $val = gvpriw($i); $i++; } push @p, gvpriw($i); return @p; } sub random_noncentral_chi_square { # Arguments: ($n,$df,$nonc) croak "Usage: random_noncentral_chi_square(\$n,\$df,\$nonc)" if scalar(@_) < 3; my($n, $df, $nonc) = @_; croak("($df = \$df < 1) or ($nonc = \$nonc) < 0\n". "in random_noncentral_chi_square(\$n,\$df,\$nonc)") if (($df < 1) or ($nonc < 0)); return gennch($df,$nonc) unless wantarray(); my $val; my @ans = (0) x $n; foreach $val (@ans) { $val = gennch($df,$nonc); } return @ans; } sub random_noncentral_f { # Arguments: ($n,$dfn,$dfd,$nonc) croak "Usage: random_noncentral_f(\$n,\$dfn,\$dfd,\$nonc)" if scalar(@_) < 4; my($n, $dfn, $dfd, $nonc) = @_; croak("($dfn = \$dfn < 1) or ($dfd = \$dfd <= 0) or ($nonc ". "= \$nonc < 0)\nin random_noncentral_f(\$n,\$dfn,\$dfd,\$nonc)") if (($dfn < 1) or ($dfd <= 0) or ($nonc < 0)); return gennf($dfn,$dfd,$nonc) unless wantarray(); my $val; my @ans = (0) x $n; foreach $val (@ans) { $val = gennf($dfn,$dfd,$nonc); } return @ans; } sub random_normal { # Arguments: ($n,$av,$sd), defaults (1,0,1) return wantarray() ? (gennor(0,1)) : gennor(0,1) if scalar(@_) == 0; # default behavior if no arguments my($n, $av, $sd) = @_; $av = 0 unless defined($av); # $av defaults to 0 $sd = 1 unless defined($sd); # $sd defaults to 1, even if $av specified croak "$sd = \$sd < 0\nin random_normal([\$n[,\$av[,\$sd]]])" if ($sd < 0); return gennor($av,$sd) unless wantarray(); my $val; my @ans = (0) x $n; foreach $val (@ans) { $val = gennor($av,$sd); } return @ans; } sub random_permutation { # Argument: (@array) - array to be permuted. my $n = scalar(@_); # number of elements to be permuted return () if $n == 0; rspriw($n) or croak "Unable to allocate memory\nin random_permutation"; pgnprm($n); my($val, $i) = (0,0); my @ans = (0) x $n; foreach $val (@ans) { $val = gvpriw($i); $i++; } return @_[@ans]; } sub random_permuted_index { # Argument: $n = scalar(@array) (for permutation) croak "Usage: random_permuted_index(\$n)" if scalar(@_) < 1; my $n = int(shift(@_)); # number of elements to be permuted croak "$n = \$n < 0 in random_permuted_index(\$n)" if $n < 0; return () if $n == 0; rspriw($n) or croak "Unable to allocate memory\nin random_permuted_index"; pgnprm($n); my($val, $i) = (0,0); my @ans = (0) x $n; foreach $val (@ans) { $val = gvpriw($i); $i++; } return @ans; } sub random_uniform { # Arguments: ($n,$low,$high), defaults (1,0,1) return wantarray() ? (genunf(0,1)) : genunf(0,1) if scalar(@_) == 0; croak "Usage: random_uniform([\$n,[\$low,\$high]])" if scalar(@_) == 2; # only default is (0,1) for ($low,$high) both undef my($n, $low, $high) = @_; $low = 0 unless defined($low); # default for $low is 0 $high = 1 unless defined($high); # default for $high is 1 croak("$low = \$low > \$high = $high\nin ". "random_uniform([\$n,[\$low,\$high]])") if ($low > $high); return genunf($low,$high) unless wantarray(); my $val; my @ans = (0) x $n; foreach $val (@ans) { $val = genunf($low,$high); } return @ans; } sub random_poisson { # Arguments: ($n, $mu) croak "Usage: random_poisson(\$n,\$mu)" if scalar(@_) < 2; my($n, $mu) = @_; croak "$mu = \$mu < 0\nin random_poisson(\$n,\$mu)" if ($mu < 0); return ignpoi($mu) unless wantarray(); my $val; my @ans = (0) x $n; foreach $val (@ans) { $val = ignpoi($mu); } return @ans; } sub random_uniform_integer { # Arguments: ($n,$low,$high) croak "Usage: random_uniform_integer(\$n,\$low,\$high)" if scalar(@_) < 3; my($n, $low, $high) = @_; $low = int($low); $high = int($high); croak("$low = \$low > \$high = $high\nin ". "random_uniform_integer(\$n,\$low,\$high)") if ($low > $high); my $range = $high - $low; croak("$range = (\$high - \$low) > 2147483561\nin ". "random_uniform_integer(\$n,\$low,\$high)") if ($range > 2147483561); return ($low + ignuin(0,$range)) unless wantarray(); my $val; my @ans = (0) x $n; foreach $val (@ans) { $val = $low + ignuin(0,$range); } return @ans; } sub random_negative_binomial { # Arguments: ($n,$ne,$p) croak "Usage: random_negative_binomial(\$n,\$ne,\$p)" if scalar(@_) < 3; my($n, $ne, $p) = @_; $ne = int($ne); croak("($ne = \$ne <= 0) or ($p = \$p <= 0 or >= 1)\nin ". "random_negative_binomial(\$n,\$ne,\$p)") if (($ne <= 0) or (($p <= 0) or ($p >= 1))); return ignnbn($ne,$p) unless wantarray(); my $val; my @ans = (0) x $n; foreach $val (@ans) { $val = ignnbn($ne,$p); } return @ans; } sub random_binomial { # Arguments: ($n,$nt,$p) croak "Usage: random_binomial(\$n,\$nt,\$p)" if scalar(@_) < 3; my($n, $nt, $p) = @_; $nt = int($nt); croak("($nt = \$nt < 0) or ($p = \$p < 0 or > 1)\nin ". "random_binomial(\$n,\$nt,\$p)") if (($nt < 0) or (($p < 0) or ($p > 1))); return ignbin($nt,$p) unless wantarray(); my $val; my @ans = (0) x $n; foreach $val (@ans) { $val = ignbin($nt,$p); } return @ans; } ##################################################################### # SEED HANDLER FUNCTIONS # ##################################################################### sub random_seed_from_phrase { # Argument $phrase my $phrase = shift(@_); $phrase ||= ""; return phrtsd($phrase); } sub random_get_seed { # no argument return getsd(); } sub random_set_seed_from_phrase { # Argument $phrase my $phrase = shift(@_); $phrase ||= ""; salfph($phrase); return 1; } sub random_set_seed { # Argument @seed my($seed1,$seed2) = @_; croak("Usage: random_set_seed(\@seed)\n\@seed[0,1] must be two integers ". "in the range (1,1) to (2147483562,2147483398)\nand usually comes ". "from a call to random_get_seed() ". "or\nrandom_seed_from_phrase(\$phrase).") unless (((($seed1 == int($seed1)) and ($seed2 == int($seed2))) and (($seed1 > 0) and ($seed2 > 0))) and (($seed1 < 2147483563) and ($seed2 < 2147483399))); setall($seed1,$seed2); return 1; } ##################################################################### # HELPER ROUTINES # # These use the C work arrays and are not intended for export # # (Currently only used in random_multivariate_normal) # ##################################################################### sub getflt { my $n = $_[0]; my $val; my $i = 0; my @junk = (0) x $n; foreach $val (@junk) { $val = gvprfw($i); $i++; } return @junk; } sub putflt { my $n = scalar(@_); rsprfw($n) or return 0; my $val; my $i = 0; foreach $val (@_) { # load up floats svprfw($i,$val); $i++; } return 1; } # Autoload methods go after =cut, and are processed by the autosplit program. 1; __END__ =head1 NAME B - Random Number Generators =head1 SYNOPSIS =over 4 =item * use Math::Random; Exports the following routines by default (see L<"Default Routines">): random_set_seed_from_phrase random_get_seed random_seed_from_phrase random_set_seed random_uniform random_uniform_integer random_permutation random_permuted_index random_normal In this case the extended routines (see L<"Extended Routines">) can be used by qualifying them explicitly with C, for example: C<$stdexp = Math::Random::random_exponential();> =item * use Math::Random qw(random_beta random_chi_square random_exponential random_f random_gamma random_multivariate_normal random_multinomial random_noncentral_chi_square random_noncentral_f random_normal random_permutation random_permuted_index random_uniform random_poisson random_uniform_integer random_negative_binomial random_binomial random_seed_from_phrase random_get_seed random_set_seed_from_phrase random_set_seed ); Exports all the routines explicitly. Use a subset of the list for the routines you want. =item * use Math::Random qw(:all); Exports all the routines, as well. =back =head1 DESCRIPTION B is a B port of the B version of B, which is a suite of routines for generating random deviates. See L<"RANDLIB"> for more information. This port supports all of the distributions from which the B and B versions generate deviates. The major functionalities that are excluded are the multiple generators/splitting facility and antithetic random number generation. These facilities, along with some of the distributions which I included, are probably not of interest except to the very sophisticated user. If there is sufficient interest, the excluded facilities will be included in a future release. The code to perform the excluded facilities is available as B in B and B source. =head2 Default Routines The routines which are exported by default are the only ones that the average Perl programmer is likely to need. =over 4 =item C Sets the seed of the base generator to a value determined by I<$phrase>. If the module is installed with the default option, the value depends on the machine collating sequence. It should, however, be the same for 7-bit ASCII character strings on all ASCII machines. In the original randlib, the value generated for a given I<$phrase> was consistent from implementation to implementation (it did not rely on the machine collating sequence). Check with your Perl administrator to see if the module was installed with the original seed generator. B When the Perl processor loads package B the seed is set to a value based on the current time. The seed changes each time B generates something random. The ability to set the seed is useful for debugging, or for those who like reproducible runs. =item C Returns an array of length two which contains the two integers constituting the seed (assuming a call in array context). An invocation in a scalar context returns the integer 2, which is probably not useful. =item C Returns an array of length two which contains the two integers constituting the seed (assuming a call in array context). An invocation in a scalar context returns the integer 2, which is probably not useful. The seed generated is the seed used to set the seed in a call to C. B the following two calls (for the same I<$phrase>) are equivalent: random_set_seed(random_seed_from_phrase($phrase)); and random_set_seed_from_phrase($phrase); =item C Sets the seed of the base generator to the value I<@seed>[0,1]. Usually, the argument I<@seed> should be the result of a call to C or C. I<@seed>[0,1] must be two integers in the range S<(1, 1)> to S<(2147483562, 2147483398)>, inclusive. =item C =item C =item C When called in an array context, returns an array of I<$n> deviates generated from a IS< >I<$high)> distribution. When called in a scalar context, generates and returns only one such deviate as a scalar, regardless of the value of I<$n>. Argument restrictions: I<$low> must be less than or equal to I<$high>. Defaults are (1, 0, 1). B I<$high> must be specified if I<$low> is specified. =item C When called in an array context, returns an array of I<$n> integer deviates generated from a IS< >I<$high)> distribution on the integers. When called in a scalar context, generates and returns only one such deviate as a scalar, regardless of the value of I<$n>. Argument restrictions: I<$low> and I<$high> are first rounded using C; the resulting I<$low> must be less than or equal to I<$high>, and the resulting range I<($high - $low)> must not be greater than 2147483561. There are no defaults; all three arguments must be provided. =item C Returns I<@array>, randomly permuted. =item C Returns an array of array indices, randomly permuted. The indices used are S<(0, ... ,>(I<$n>S< - >1)). This produces the indices used by C for a given seed, without passing arrays. B the following are equivalent: random_set_seed_from_phrase('jjv'); random_permutation(@array); and random_set_seed_from_phrase('jjv'); @array[(random_permuted_index(scalar(@array)))]; =item C =item C =item C =item C When called in an array context, returns an array of I<$n> deviates generated from a I distribution. When called in a scalar context, generates and returns only one such deviate as a scalar, regardless of the value of I<$n>. Argument restrictions: I<$sd> must be non-negative. Defaults are (1, 0, 1). =back =head2 Extended Routines These routines generate deviates from many other distributions. B The parameterizations of these deviates are standard (insofar as there I a standard ... ) but particular attention should be paid to the distributions of the I and I deviates (noted in C and C below). =over 4 =item C When called in an array context, returns an array of I<$n> deviates generated from the I distribution with parameters I<$aa> and I<$bb>. The density of the beta is: X^(I<$aa> - 1) * (1 - X)^(I<$bb> - 1) / S(I<$aa> , I<$bb>) for 0 < X < 1. When called in a scalar context, generates and returns only one such deviate as a scalar, regardless of the value of I<$n>. Argument restrictions: Both I<$aa> and I<$bb> must not be less than C<1.0E-37>. There are no defaults; all three arguments must be provided. =item C When called in an array context, returns an array of I<$n> outcomes generated from the I distribution with number of trials I<$nt> and probability of an event in each trial I<$p>. When called in a scalar context, generates and returns only one such outcome as a scalar, regardless of the value of I<$n>. Argument restrictions: I<$nt> is rounded using C; the result must be non-negative. I<$p> must be between 0 and 1 inclusive. There are no defaults; both arguments must be provided. =item C When called in an array context, returns an array of I<$n> deviates generated from the I distribution with I<$df> degrees of freedom. When called in a scalar context, generates and returns only one such deviate as a scalar, regardless of the value of I<$n>. Argument restrictions: I<$df> must be positive. There are no defaults; both arguments must be provided. =item C =item C =item C When called in an array context, returns an array of I<$n> deviates generated from the I distribution with mean I<$av>. When called in a scalar context, generates and returns only one such deviate as a scalar, regardless of the value of I<$n>. Argument restrictions: I<$av> must be non-negative. Defaults are (1, 1). =item C When called in an array context, returns an array of I<$n> deviates generated from the I (variance ratio) distribution with degrees of freedom I<$dfn> (numerator) and I<$dfd> (denominator). When called in a scalar context, generates and returns only one such deviate as a scalar, regardless of the value of I<$n>. Argument restrictions: Both I<$dfn> and I<$dfd> must be positive. There are no defaults; all three arguments must be provided. =item C When called in an array context, returns an array of I<$n> deviates generated from the I distribution with parameters I<$a> and I<$r>. The density of the gamma is: (I<$a>**I<$r>) / Gamma(I<$r>) * X**(I<$r> - 1) * Exp(-I<$a>*X) When called in a scalar context, generates and returns only one such deviate as a scalar, regardless of the value of I<$n>. Argument restrictions: Both I<$a> and I<$r> must be positive. There are no defaults; all three arguments must be provided. =item C When called in an array context, returns single observation from the I distribution, with I<$n> events classified into as many categories as the length of I<@p>. The probability of an event being classified into category I is given by the Ith element of I<@p>. The observation is an array with length equal to I<@p>, so when called in a scalar context it returns the length of @p. The sum of the elements of the observation is equal to I<$n>. Argument restrictions: I<$n> is rounded with C before it is used; the result must be non-negative. I<@p> must have length at least 2. All elements of I<@p> except the last must be between 0 and 1 inclusive, and sum to no more than 0.99999. B The last element of I<@p> is a dummy to indicate the number of categories, and it is adjusted to bring the sum of the elements of I<@p> to 1. There are no defaults; both arguments must be provided. =item C When called in an array context, returns an array of I<$n> deviates (each deviate being an array reference) generated from the I distribution with mean vector I<@mean> and variance-covariance matrix I<@covar>. When called in a scalar context, generates and returns only one such deviate as an array reference, regardless of the value of I<$n>. Argument restrictions: If the dimension of the deviate to be generated is I

, I<@mean> should be a length I

array of real numbers. I<@covar> should be a length I

array of references to length I

arrays of real numbers (i.e. a I

by I

matrix). Further, I<@covar> should be a symmetric positive-definite matrix, although the B code does not check positive-definiteness, and the underlying B code assumes the matrix is symmetric. Given that the variance-covariance matrix is symmetric, it doesn't matter if the references refer to rows or columns. If a non-positive definite matrix is passed to the function, it will abort with the following message: COVM not positive definite in SETGMN Also, a non-symmetric I<@covar> may produce deviates without complaint, although they may not be from the expected distribution. For these reasons, you are encouraged to I. The B code I check the dimensionality of I<@mean> and I<@covar> for consistency. It does so by checking that the length of the argument vector passed is odd, that what should be the last element of I<@mean> and the first element of I<@covar> look like they are a number followed by an array reference respectively, and that the arrays referred to in I<@covar> are as long as I<@mean>. There are no defaults; all three arguments must be provided. =item C When called in an array context, returns an array of I<$n> outcomes generated from the I distribution with number of events I<$ne> and probability of an event in each trial I<$p>. When called in a scalar context, generates and returns only one such outcome as a scalar, regardless of the value of I<$n>. Argument restrictions: I<$ne> is rounded using C, the result must be positive. I<$p> must be between 0 and 1 exclusive. There are no defaults; both arguments must be provided. =item C When called in an array context, returns an array of I<$n> deviates generated from the I distribution with I<$df> degrees of freedom and noncentrality parameter I<$nonc>. When called in a scalar context, generates and returns only one such deviate as a scalar, regardless of the value of I<$n>. Argument restrictions: I<$df> must be at least 1, I<$nonc> must be non-negative. There are no defaults; all three arguments must be provided. =item C When called in an array context, returns an array of I<$n> deviates generated from the I (variance ratio) distribution with degrees of freedom I<$dfn> (numerator) and I<$dfd> (denominator); and noncentrality parameter I<$nonc>. When called in a scalar context, generates and returns only one such deviate as a scalar, regardless of the value of I<$n>. Argument restrictions: I<$dfn> must be at least 1, I<$dfd> must be positive, and I<$nonc> must be non-negative. There are no defaults; all four arguments must be provided. =item C When called in an array context, returns an array of I<$n> outcomes generated from the I distribution with mean I<$mu>. When called in a scalar context, generates and returns only one such outcome as a scalar, regardless of the value of I<$n>. Argument restrictions: I<$mu> must be non-negative. There are no defaults; both arguments must be provided. =back =head1 ERROR HANDLING The B code should C if bad arguments are passed or if the underlying B code cannot allocate the necessary memory. The only error which should kill the job without Cing is a non-positive definite variance-covariance matrix passed to C (see L<"Extended Routines">). =head1 RANDLIB B is available in B and B source form, and will soon be available in B source as well. B can be obtained from B. Send mail whose message is I<'send randlib.c.shar from general'> to: statlib@lib.stat.cmu.edu B can also be obtained by anonymous B to: odin.mdacc.tmc.edu (143.111.62.32) where it is available as /pub/source/randlib.c-1.3.tar.gz For obvious reasons, the original B (in B) has been renamed to /pub/source/randlib.f-1.3.tar.gz on the same machine. Our FTP index is on file C<./pub/index>. If you have Internet access and a browser you might note the following web site addresses: University of Texas M. D. Anderson Cancer Center Home Page: http://www.mdanderson.org/ Department of Biomathematics Home Page: http://odin.mdacc.tmc.edu/ Available software: http://biostatistics.mdanderson.org/SoftwareDownload/ =head1 SUPPORT This work was supported in part by grant CA-16672 from the National Cancer Institute. We are grateful to Larry and Pat McNeil of Corpus Cristi for their generous support. Some equipment used in this effort was provided by IBM as part of a cooperative study agreement; we thank them. =head1 CODE MANIPULATION The B version of B was obtained by translating the original B B using B, and performing some hand crafting of the result. Information on B can be obtained from: PROMULA Development Corporation 3620 N. High Street, Suite 301 Columbus, Ohio 43214 (614) 263-5454 F (now obsolete) was created by using B, and performing some modification of the result. B also produced the skeleton of F. Information on B can be obtained from: http://www.swig.org =head1 SOURCES The following routines, which were written by others and lightly modified for consistency in packaging, are included in B. =over 4 =item Bottom Level Routines These routines are a transliteration of the B in the reference to B, and thence to B. L'Ecuyer, P., and Cote, S. "Implementing a Random Number Package with Splitting Facilities." ACM Transactions on Mathematical Software, 17:98-111 (1991). =item Exponential This code was obtained from Netlib. Ahrens, J. H., and Dieter, U. "Computer Methods for Sampling from the Exponential and Normal Distributions." Comm. ACM, 15,10 (Oct. 1972), 873-882. =item Gamma (Case R >= 1.0) Ahrens, J. H., and Dieter, U. "Generating Gamma Variates by a Modified Rejection Technique." Comm. ACM, 25,1 (Jan. 1982), 47-54. Algorithm GD (Case 0.0 <= R <= 1.0) Ahrens, J. H., and Dieter, U. "Computer Methods for Sampling from Gamma, Beta, Poisson and Binomial Distributions." Computing, 12 (1974), 223-246. Adaptation of algorithm GS. =item Normal This code was obtained from netlib. Ahrens, J. H., and Dieter, U. "Extensions of Forsythe's Method for Random Sampling from the Normal Distribution." Math. Comput., 27,124 (Oct. 1973), 927-937. =item Binomial This code was kindly sent to Dr. Brown by Dr. Kachitvichyanukul. Kachitvichyanukul, V., and Schmeiser, B. W. "Binomial Random Variate Generation." Comm. ACM, 31, 2 (Feb. 1988), 216. =item Poisson This code was obtained from netlib. Ahrens, J. H., and Dieter, U. "Computer Generation of Poisson Deviates from Modified Normal Distributions." ACM Trans. Math. Software, 8, 2 (June 1982), 163-179. =item Beta This code was written by us following the recipe in the following. Cheng, R. C. H. "Generating Beta Variables with Nonintegral Shape Parameters." Comm. ACM, 21:317-322 (1978). (Algorithms BB and BC) =item Linpack Routines C and C are used to perform the Cholesky decomposition of the covariance matrix in C (used for the generation of multivariate normal deviates). Dongarra, J. J., Moler, C. B., Bunch, J. R., and Stewart, G. W. Linpack User's Guide. SIAM Press, Philadelphia. (1979) =item Multinomial The algorithm is from page 559 of Devroye, Luc Non-Uniform Random Variate Generation. New York: Springer-Verlag, 1986. =item Negative Binomial The algorithm is from page 480 of Devroye, Luc Non-Uniform Random Variate Generation. New York: Springer-Verlag, 1986. =back =head1 VERSION This POD documents B version 0.71. =head1 AUTHORS =over 4 =item * B (the B port of B) was put together by John Venier and Barry W. Brown with help from B. For version 0.61, Geoffrey Rommel made various cosmetic changes. Version 0.64 uses plain vanilla XS rather than SWIG. =item * B was compiled and written by Barry W. Brown, James Lovato, Kathy Russell, and John Venier. =item * Correspondence regarding B or B should be addressed to John Venier by email to jvenier@mdanderson.org =item * Our address is: Department of Biomathematics, Box 237 The University of Texas, M.D. Anderson Cancer Center 1515 Holcombe Boulevard Houston, TX 77030 =item * Geoffrey Rommel may be reached at grommel [at] cpan [dot] org. =back =head1 LEGALITIES =over 4 =item * The programs in the B code distributed with B and in the B code F, as well as the documentation, are copyright by John Venier and Barry W. Brown for the University of Texas M. D. Anderson Cancer Center in 1997. They may be distributed and used under the same conditions as B. =item * F, F, and F are from B (See L<"RANDLIB">) and are distributed with the following legalities. Code that appeared in an ACM publication is subject to their algorithms policy: Submittal of an algorithm for publication in one of the ACM Transactions implies that unrestricted use of the algorithm within a computer is permissible. General permission to copy and distribute the algorithm without fee is granted provided that the copies are not made or distributed for direct commercial advantage. The ACM copyright notice and the title of the publication and its date appear, and notice is given that copying is by permission of the Association for Computing Machinery. To copy otherwise, or to republish, requires a fee and/or specific permission. Krogh, F. "Algorithms Policy." ACM Tran. Math. Softw. 13 (1987), 183-186. Note, however, that only the particular expression of an algorithm can be copyrighted, not the algorithm per se; see 17 USC 102E<40>bE<41>. We place the Randlib code that we have written in the public domain. =item * B and B are distributed with B. See L<"NO WARRANTY">. =back =head1 NO WARRANTY WE PROVIDE ABSOLUTELY NO WARRANTY OF ANY KIND EITHER EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THIS PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. IN NO EVENT SHALL THE UNIVERSITY OF TEXAS OR ANY OF ITS COMPONENT INSTITUTIONS INCLUDING M. D. ANDERSON HOSPITAL BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY LOST PROFITS, LOST MONIES, OR OTHER SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA OR ITS ANALYSIS BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY THIRD PARTIES FROM) THE PROGRAM. (Above NO WARRANTY modified from the GNU NO WARRANTY statement.) =cut such outcome as a scalar, regardless of the value of I<$n>. Argument restrictions: I<$ne> is rounded using C, the result must be positive. I<$p> must be between 0 and 1 exclusive. There Math-Random-0.71/INSTALL100644 017522 000266 00000001737 11064014432 014267 0ustar00yxrdss000000 000000 Beginning with version 0.68, two versions of the phrtsd routine are available. If you want the new version, run 'perl Makefile.PL' as usual. If you want the original version, run: perl Makefile.PL phrtsd_orig The original version, which is the same as the phrtsd routine in the original Fortran library, generates the same seed numbers for all permutations of the same characters. For instance, 'abc', 'bca', and 'cab' will all generate the same seeds. Some users find this behavior surprising. Also, when Math::Random is loaded, it sets the seeds from scalar(localtime), which will be a string like 'Mon Jun 26 15:45:12 2006'. Nine seconds later, however, 'Mon Jun 26 15:45:21 2006' will generate the very same seeds. The new version uses an entirely different algorithm that will generate different seeds for such strings. This should be suitable for most applications, but the original version is still available for those who need to reproduce the behavior of the Fortran randlib. called in an array context, retuMath-Random-0.71/example.pl100755 017522 000266 00000032233 11064014433 015225 0ustar00yxrdss000000 000000 #!/usr/bin/perl -w use Math::Random qw(:all); use Carp; use strict; my $max_choice = 17; my $ans = ""; my $input = ""; my @args = (); my @result = (); TEST: while (1) { print " Enter number corresponding to choice:\n", " (0) Exit this program\n", " (1) Generate Chi-Square deviates\n", " (2) Generate noncentral Chi-Square deviates\n", " (3) Generate F deviates\n", " (4) Generate noncentral F deviates\n", " (5) Generate random permutation\n", " (6) Generate uniform integers\n", " (7) Generate uniform reals\n", " (8) Generate beta deviates\n", " (9) Generate binomial outcomes\n", " (10) Generate Poisson outcomes\n", " (11) Generate exponential deviates\n", " (12) Generate gamma deviates\n", " (13) Generate multinomial outcomes\n", " (14) Generate normal deviates\n", " (15) Generate negative binomial outcomes\n", " (16) Generate multivariate normal deviates\n", " (17) Generate random permuted index\n"; $ans = ; chomp $ans; $ans = int($ans); last TEST if $ans == 0; unless ($ans > 0 and $ans <= $max_choice) { print "Try one of (1, ... $max_choice)\n"; next TEST; } print "Enter phrase to initialize seeds:\n"; my $phrase = ; chomp $phrase; random_set_seed_from_phrase($phrase); if ($ans == 1) { print "Enter (space-separated) N, DF for chi-square deviates:\n"; $input = ; chomp $input; @args = split(/\s+/,$input); @result = random_chi_square(@args); shift(@args); print_results(sampstat(@result),scalar(@result), true_stats('chis',@args)); next TEST; } if ($ans == 2) { print "Enter (space-separated) N, DF, NONC for ", "noncentral chi-square deviates:\n"; $input = ; chomp $input; @args = split(/\s+/,$input); @result = random_noncentral_chi_square(@args); shift(@args); print_results(sampstat(@result),scalar(@result), true_stats('ncch',@args)); next TEST; } if ($ans == 3) { print "Enter (space-separated) N, DFN, DFD for F deviates:\n"; $input = ; chomp $input; @args = split(/\s+/,$input); @result = random_f(@args); shift(@args); print_results(sampstat(@result),scalar(@result), true_stats('f',@args)); next TEST; } if ($ans == 4) { print "Enter (space-separated) N, DFN, DFD, NONC for ", "non-central F deviates:\n"; $input = ; chomp $input; @args = split(/\s+/,$input); @result = random_noncentral_f(@args); shift(@args); print_results(sampstat(@result),scalar(@result), true_stats('ncf',@args)); next TEST; } if ($ans == 5) { print "Enter (space-separated) list for random permutation:\n"; $input = ; chomp $input; @args = split(/\s+/,$input); print "Result (' : ' separated):\n", join(" : ", random_permutation(@args)),"\n"; next TEST; } if ($ans == 6) { print "Enter (space-separated) Maximum integer, Replications ", "per integer:\n"; $input = ; chomp $input; @args = split(/\s+/,$input); @result = random_uniform_integer($args[0] * $args[1], 1, $args[0]); my @totals = (0) x ($args[0] + 1); my $val = 0; foreach $val (@result) { $totals[$val]++; } shift @totals; print "Result (' : ' separated):\n",join(" : ", @totals),"\n"; next TEST; } if ($ans == 7) { print "Enter (space-separated) N, LOWER, UPPER for ", "uniform real deviates:\n"; $input = ; chomp $input; @args = split(/\s+/,$input); @result = random_uniform(@args); shift(@args); $args[0] = 0 unless defined($args[0]); $args[1] = 1 unless defined($args[1]); print_results(sampstat(@result),scalar(@result), true_stats('unif',@args)); next TEST; } if ($ans == 8) { print "Enter (space-separated) N, A, B for ", "beta deviates:\n"; $input = ; chomp $input; @args = split(/\s+/,$input); @result = random_beta(@args); shift(@args); print_results(sampstat(@result),scalar(@result), true_stats('beta',@args)); next TEST; } if ($ans == 9) { print "Enter (space-separated) N, NTrials, P for ", "binomial outcomes:\n"; $input = ; chomp $input; @args = split(/\s+/,$input); @result = random_binomial(@args); shift(@args); print_results(sampstat(@result),scalar(@result), true_stats('bin',@args)); next TEST; } if ($ans == 10) { print "Enter (space-separated) N, MU for ", "poisson outcomes:\n"; $input = ; chomp $input; @args = split(/\s+/,$input); @result = random_poisson(@args); shift(@args); print_results(sampstat(@result),scalar(@result), true_stats('pois',@args)); next TEST; } if ($ans == 11) { print "Enter (space-separated) N, AV for ", "exponential deviates:\n"; $input = ; chomp $input; @args = split(/\s+/,$input); @result = random_exponential(@args); shift(@args); $args[0] = 1 unless defined($args[0]); print_results(sampstat(@result),scalar(@result), true_stats('expo',@args)); next TEST; } if ($ans == 12) { print "Enter (space-separated) N, A, R for ", "gamma deviates:\n"; $input = ; chomp $input; @args = split(/\s+/,$input); @result = random_gamma(@args); shift(@args); print_results(sampstat(@result),scalar(@result), true_stats('gamm',@args)); next TEST; } if ($ans == 13) { print "Enter (space-separated) list of prob.s for categories ", "for multinomial outcomes:\n"; my $input = ; chomp $input; @args = split(/\s+/,$input); print "Please enter number of events to be classified:\n"; my $n = ; chomp $n; @result = random_multinomial($n,@args); print "Result:\n",join(" ", @result),"\n"; my $sum = 0; my $val; foreach $val (@result) {$sum += $val; } foreach $val (@result) {$val /= $sum; } print "Observed proportions:\n",join(" ", @result),"\n"; pop @args; $sum = 0; foreach $val (@args) {$sum += $val; } push @args, (1 - $sum); print "Expected proportions:\n",join(" ", @args),"\n"; next TEST; } if ($ans == 14) { print "Enter (space-separated) N, AV, SD for ", "normal deviates:\n"; $input = ; chomp $input; @args = split(/\s+/,$input); @result = random_normal(@args); shift(@args); $args[0] = 0 unless defined($args[0]); $args[1] = 1 unless defined($args[1]); print_results(sampstat(@result),scalar(@result), true_stats('norm',@args)); next TEST; } if ($ans == 15) { print "Enter (space-separated) N, NEvents, P for ", "negative binomial outcomes:\n"; $input = ; chomp $input; @args = split(/\s+/,$input); @result = random_negative_binomial(@args); shift(@args); print_results(sampstat(@result),scalar(@result), true_stats('nbin',@args)); next TEST; } if ($ans == 16) { print "Enter dimension of multivariate deviate:\n"; my $p = ; chomp $p; print "Enter mean vector of length $p (space separated):\n"; my $temp = ; chomp $temp; $temp =~ s/^\s*//; my @mean; @mean = split(/\s+/,$temp); print "Enter (symmetric, $p by $p) covariance matrix\n", "One space-separated row per line:\n"; my $val; my @covariance = (0) x $p; foreach $val (@covariance) { $temp = ; chomp $temp; $temp =~ s/^\s*//; $val = [ split(/\s+/,$temp) ]; } print "Enter number of observations:\n"; my $n = ; chomp $n; my @ans = random_multivariate_normal($n,@mean,@covariance); my $template = join(" ",('%15.7g') x $p); print "\nResults:\n"; foreach $val (@ans) { printf "$template\n",@{$val}; } } if ($ans == 17) { print "Enter N (size of array) for random permuted index:\n"; $input = ; chomp $input; print "Result (' : ' separated):\n", join(" : ", random_permuted_index($input)),"\n"; next TEST; } } print "Normal termination of tester.\n"; sub sampstat { # gets sample statistics for array - returns array of stats my $n = scalar(@_); return () unless $n > 0; return ($_[0], 0, $_[0], $_[0]) unless $n > 1; my($min) = my($max) = $_[0]; my $val; my $avg = 0; foreach $val (@_) { $avg += $val; $min = $val if $val < $min; $max = $val if $val > $max; } $avg /= $n; my $var = 0; foreach $val (@_) { $var += ($val - $avg)**2; } $var /= ($n - 1); return ($avg, $var, $min, $max); } sub print_results { # Arguments: $avg, $var, $min, $max, $nobs, $travg, $trvar my($avg, $var, $min, $max, $nobs, $travg, $trvar) = @_; print "Results:\n"; printf "Number of observations: %d\n", $nobs; printf "Mean : %15.7g True : %15.7g\n", $avg, $travg; printf "Variance: %15.7g True : %15.7g\n", $var, $trvar; printf "Minimum : %15.7g Maximum : %15.7g\n", $min, $max; } sub true_stats { # Arguments: $type, @parin; Returns: $av, $var ######################################################################## # Returns mean and variance for a number of statistical distribution # as a function of their parameters. # # # Arguments # # # $type --> Character string indicating type of distribution # 'chis' chisquare # 'ncch' noncentral chisquare # 'f' F (variance ratio) # 'ncf' noncentral f # 'unif' uniform # 'beta' beta distribution # 'bin' binomial # 'pois' poisson # 'expo' exponential # 'gamm' gamma # 'norm' normal # 'nbin' negative binomial # # @parin --> Array containing parameters of distribution # chisquare # $parin[0] is df # noncentral chisquare # $parin[0] is df # $parin[1] is noncentrality parameter # F (variance ratio) # $parin[0] is df numerator # $parin[1] is df denominator # noncentral F # $parin[0] is df numerator # $parin[1] is df denominator # $parin[2] is noncentrality parameter # uniform # $parin[0] is LOW bound # $parin[1] is HIGH bound # beta # $parin[0] is A # $parin[1] is B # binomial # $parin[0] is Number of trials # $parin[1] is Prob Event at Each Trial # poisson # $parin[0] is Mean # exponential # $parin[0] is Mean # gamma # $parin[0] is A # $parin[1] is R # normal # $parin[0] is Mean # $parin[1] is Standard Deviation # negative binomial # $parin[0] is required Number of events # $parin[1] is Probability of event # # $av <-- Mean of specified distribution with specified parameters # # $var <-- Variance of specified distribution with specified paramete # # # Note # # # $av and $var will be returned -1 if mean or variance is infinite # #********************************************************************** my $type = shift(@_); my @parin = @_; my($av, $var, $a, $b, $range) = (-1,-1,0,0,0); TYPE: { if (('chis') eq ($type)){ $av = $parin[0]; $var = 2.0*$parin[0]; last TYPE;} if (('ncch') eq ($type)) { $a = $parin[0] + $parin[1]; $b = $parin[1]/$a; $av = $a; $var = 2.0*$a* (1.0+$b); last TYPE;} if (('f') eq ($type)) { unless ($parin[1] <= 2.0001) { $av = $parin[1]/ ($parin[1]-2.0); } unless ($parin[1] <= 4.0001) { $var = (2.0*$parin[1]**2* ($parin[0]+$parin[1]-2.0))/ ($parin[0]* ($parin[1]-2.0)**2* ($parin[1]-4.0)); } last TYPE;} if (('ncf') eq ($type)) { unless ($parin[1] <= 2.0001){ $av = ($parin[1]* ($parin[0]+$parin[2]))/ (($parin[1]-2.0)*$parin[0]); } unless ($parin[1] <= 4.0001) { $a = ($parin[0]+$parin[2])**2 + ($parin[0]+2.0*$parin[2])* ($parin[1]-2.0); $b = ($parin[1]-2.0)**2* ($parin[1]-4.0); $var = 2.0* ($parin[1]/$parin[0])**2* ($a/$b); } last TYPE;} if (('unif') eq ($type)) { $range = $parin[1] - $parin[0]; $av = $parin[0] + $range/2.0; $var = $range**2/12.0; last TYPE;} if (('beta') eq ($type)) { $av = $parin[0]/ ($parin[0]+$parin[1]); $var = ($av*$parin[1])/ (($parin[0]+$parin[1])* ($parin[0]+$parin[1]+1.0)); last TYPE;} if (('bin') eq ($type)) { $av = $parin[0]*$parin[1]; $var = $av* (1.0-$parin[1]); last TYPE;} if (('pois') eq ($type)) { $av = $parin[0]; $var = $parin[0]; last TYPE;} if (('expo') eq ($type)) { $av = $parin[0]; $var = $parin[0]**2; last TYPE;} if (('gamm') eq ($type)) { $av = $parin[1] / $parin[0]; $var = $av / $parin[0]; last TYPE;} if (('norm') eq ($type)) { $av = $parin[0]; $var = $parin[1]**2; last TYPE;} if (('nbin') eq ($type)) { $av = $parin[0] * (1.0 - $parin[1]) / $parin[1]; $var = $av / $parin[1]; last TYPE;} croak "Unimplemented \$type: $type in true_stats"; } return ($av,$var); } ated) N, AV, SD for ", "normal deviates:\n"; $input = ; chomp $input; @args = split(/\s+/,$input); @result = random_normal(@args); shift(@args); $args[0] = 0 unless defined($args[0]); $args[1] = 1 unless defined($args[1]); print_results(sampstat(@result),scalar(@result), true_stats('norm',@args)); next TEST; } Math-Random-0.71/README100755 017522 000266 00000005152 11064014433 014115 0ustar00yxrdss000000 000000 Math::Random -- Random number generators This module generates a variety of random numbers. Capabilities of wide interest include the generation of: uniform numbers between 0 and 1 (or user chosen boundaries) random integers between user specified bounds random permutations of a list (shuffle a deck of cards) The starting value for the random number generators can be specified as a phrase. The user's name would make the value easy to remember. Of course, the Perl time function can be used to provide a pseudo-random starting value. Also included in the package are generators for a large number of distributions known primarily to statisticians. These include the normal, exponential, binomial, beta, gamma, t, F, and others. THE GOOD NEWS. The generators are taken from published sources, are of high quality, and are largely machine independent. We say "largely" because different machines handle floating point somewhat differently, so values may differ slightly. The integer calculations (random integers and permutations) should be the same from machine to machine. Devotees of Donald Knuth will be reassured to know that many of the algorithms used here are mentioned favorably in his treatment of random numbers. See The Art of Computer Programming, vol. 2 (Semi- numerical Algorithms), 3rd edition (Reading, Mass.: Addison-Wesley, 1997), pp. 106-108 (Table 1, line 21), 129-137. THE BAD NEWS. We adapted or modified many routines published in the ACM's Transactions on Mathematical Software. The ACM has copyright on these routines (see the ACM statement on software policy in the POD/man page). Commercial incorporation of these routines into products to be sold requires permission and perhaps payment to the ACM. But if you don't plan to sell them, enjoy. (Note, however, that algorithms per se cannot be copyrighted; see 17 USC 102(b).) How to Install ============== The usual: perl Makefile.PL make make test make install Starting with version 0.68, two versions of the phrtsd routine are available. For details, see the INSTALL file. Who Deserves the Credit? And Who Deserves the Blame? ===================================================== Math::Random was put together by John Venier and Barry W. Brown with help from SWIG. For version 0.61, Geoffrey Rommel made various cosmetic changes. Correspondence regarding Math::Random or randlib should be addressed to John Venier by email to jvenier@mdanderson.org Our address is: Department of Biomathematics, Box 237 The University of Texas, M.D. Anderson Cancer Center 1515 Holcombe Boulevard Houston, TX 77030 May 1999 $parin[1] is noncentrality parameter # F (variance ratio) # $parin[0] is df numerator # $parin[1] is df denominator # noncentral F # $parin[0] is df numerator # $parin[1] is df denominator # $parin[2] is noncentrality parameter # uniform # $parin[0] is LOW bound # Math-Random-0.71/Makefile.PL100644 017522 000266 00000001342 11064014433 015201 0ustar00yxrdss000000 000000 use ExtUtils::MakeMaker; #--- Original or revised phrtsd? $OPT = $ARGV[0]; if ($OPT =~ /phrtsd_orig/i) { warn "*"x40, "\nUsing original phrtsd\n", "*"x40, "\n"; $def = '-DPHRTSD_ORIG'; copy('test1.pl', 'test.pl'); } else { $def = ''; copy('test2.pl', 'test.pl'); } WriteMakefile( 'NAME' => 'Math::Random', 'VERSION_FROM' => 'Random.pm', 'OBJECT' => '$(O_FILES)', 'LIBS' => ['-lm'], 'DEFINE' => $def, 'INC' => '', # e.g., '-I/opt/pkg/perl5.002/dist' 'dist' => { COMPRESS=>"gzip -9", SUFFIX=>"gz" }, ); sub copy { my ($in, $out) = @_; open(I, $in) or die "Could not open $in: $!"; open(O, ">$out") or die "Could not open $out: $!"; while () { print O; } close I; close O; } largely" because different machines handle floating point somewhat differently, so values may differ slightly. The integer calculations (random integers and permutations) should be the same from machine to machine. Devotees of Donald Knuth will be reassured to know that many of the a 'norm' normal # 'nbin' negative binomial # # @parin --> Array containing parameters of distribution # chisquare # $parin[0] is df # noncentral chisquare # $parin[0] is df # $parin[1] is noncentrality parameter # F (variance ratio) # $parin[0] is df numerator # $parin[1] is df denominator # noncentral F # $parin[0] is df numerator # $parin[1] is df denominator # $parin[2] is noncentrality parameter # uniform # $parin[0] is LOW bound # $parin[1] is HIGH bound # beta # $parin[0] is A # $parin[1] is B # binomial # $parin[0] is Number of trials # $parin[1] is Prob Event at Each Trial # poisson # $parin[0] is Mean # exponential # $parin[0] is Mean # gamma # $parin[0] is A # $parin[1] is R # normal # $parin[0] is Mean # $parin[1] is Standard Deviation # negative binomial # $parin[0] is required Number of events # $parin[1] is Probability of event # # $av <-- Mean of specified distribution with specified parameters # # $var <-- Variance of specified distribution with specified paramete # # # Note # # # $av and $var will be returned -1 if mean or variance is infinite # #********************************************************************** my $type = shift(@_); my @parin = @_; my($av, $var, $a, $b, $range) = (-1,-1,0,0,0); TYPE: { if (('chis') eq ($type)){ $av = $parin[0]; $var = 2.0*$parin[0]; last TYPE;} if (('ncch') eq ($type)) { $a = $parin[0] + $parin[1]; $b = $parin[1]/$a; $av = $a; $var = 2.0*$a* (1.0+$b); last TYPE;} if (('f') eq ($type)) { unless ($parin[1] <= 2.0001) { $av = $parin[1]/ ($parin[1]-2.0); } unless ($parin[1] <= 4.0001) { $var = (2.0*$parin[1]**2* ($parin[0]+$parin[1]-2.0))/ ($parin[0]* ($parin[1]-2.0)**2* ($parin[1]-4.0)); } last TYPE;} if (('ncf') eq ($type)) { unless ($parin[1] <= 2.0001){ $av = ($parin[1]* ($parin[0]+$parin[2]))/ (($parin[1]-2.0)*$parin[0]); } unless ($parin[1] <= 4.0001) { $a = ($parin[0]+$parin[2])**2 + ($parin[0]+2.0*$parin[2])* ($parin[1]-2.0); $b = ($parin[1]-2.0)**2* ($parin[1]-4.0); $var = 2.0* ($parin[1]/$parin[0])**2* ($a/$b); } last TYPE;} if (('unif') eq ($type)) { $range = $parin[1] - $parin[0]; $av = $parin[0] + $range/2.0; $var = $range**2/12.0; last TYPE;} if (('beta') eq ($type)) { $av = $parin[0]/ ($parin[0]+$parin[1]); $var = ($av*$parin[1])/ (($parin[0]+$parin[1])* ($parin[0]+$parin[1]+1.0)); last TYPE;} if (('bin') eq ($type)) { $av = $parin[0]*$parin[1]; $var = $av* (1.0-$parin[1]); last TYPE;} if (('pois') eq ($type)) { $av = $parin[0]; $var = $parin[0]; last TYPE;} if (('expo') eq ($type)) { $av = $parin[0]; $var = $parin[0]**2; last TYPE;} if (('gamm') eq ($type)) { $av = $parin[1] / $parin[0]; $var = $av / $parin[0]; last TYPE;} if (('norm') eq ($type)) { $av = $parin[0]; $var = $parin[1]**2; last TYPE;} if (('nbin') eq ($type)) { $av = $parin[0] * (1.0 - $parin[1]) / $parin[1]; $var = $av / $parin[1]; last TYPE;} croak "Unimplemented \$type: $type in true_stats"; } return ($av,$var); } ated) N, AV, SD for ", "normal deviates:\n"; $input = ; chomp $input; @args = split(/\s+/,$input); @result = random_normal(@args); shift(@args); $args[0] = 0 unless defined($args[0]); $args[1] = 1 unless defined($args[1]); print_results(sampstat(@result),scalar(@result), true_stats('norm',@args)); next TEST; } Math-Random-0.71/README100755 017522 000266 00000005152 11064014433 014115 0ustar00yxrdss000000 000000 Math::Random -- Random number generators This module generates a variety of random numbers. Capabilities of wide interest include the generation of: uniform numbers between 0 and 1 (or user chosen boundaries) random integers between user specified bounds random permutations of a list (shuffle a deck of cards) The starting value for the random number generators can be specified as a phrase. The user's name would make the value easy to remember. Of course, the Perl time function can be used to provide a pseudo-random starting value. Also included in the package are generators for a large number of distributions known primarily to statisticians. These include the normal, exponential, binomial, beta, gamma, t, F, and others. THE GOOD NEWS. The generators are taken from published sources, are of high quality, and are largely machine independent. We say "largely" because different machines handle floating point somewhat differently, so values may differ slightly. The integer calculations (random integers and permutations) should be the same from machine to machine. Devotees of Donald Knuth will be reassured to know that many of the algorithms used here are mentioned favorably in his treatment of random numbers. See The Art of Computer Programming, vol. 2 (Semi- numerical Algorithms), 3rd edition (Reading, Mass.: Addison-Wesley, 1997), pp. 106-108 (Table 1, line 21), 129-137. THE BAD NEWS. We adapted or modified many routines published in the ACM's Transactions on Mathematical Software. The ACM has copyright on these routines (see the ACM statement on software policy in the POD/man page). Commercial incorporation of these routines into products to be sold requires permission and perhaps payment to the ACM. But if you don't plan to sell them, enjoy. (Note, however, that algorithms per se cannot be copyrighted; see 17 USC 102(b).) How to Install ============== The usual: perl Makefile.PL make make test make install Starting with version 0.68, two versions of the phrtsd routine are available. For details, see the INSTALL file. Who Deserves the Credit? And Who Deserves the Blame? ===================================================== Math::Random was put together by John Venier and Barry W. Brown with help from SWIG. For version 0.61, Geoffrey Rommel made various cosmetic changes. Correspondence regarding Math::Random or randlib should be addressed to John Venier by email to jvenier@mdanderson.org Our address is: Department of Biomathematics, Box 237 The University of Texas, M.D. Anderson Cancer Center 1515 Holcombe Boulevard Houston, TX 77030 May 1999 $parin[1] is noncentrality parameter # F (variance ratio) # $parin[0] is df numerator # $parin[1] is df denominator # noncentral F # $parin[0] is df numerator # $parin[1] is df denominator # $parin[2] is noncentrality parameter # uniform # $parin[0] is LOW bound #