GNU Octave: libcruft/ranlib/initgn.f Source File

Go to the documentation of this file.
00001       SUBROUTINE initgn(isdtyp)
00002 C**********************************************************************
00003 C
00004 C     SUBROUTINE INITGN(ISDTYP)
00005 C          INIT-ialize current G-e-N-erator
00006 C
00007 C     Reinitializes the state of the current generator
00008 C
00009 C     This is a transcription from Pascal to Fortran of routine
00010 C     Init_Generator from the paper
00011 C
00012 C     L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package
00013 C     with Splitting Facilities." ACM Transactions on Mathematical
00014 C     Software, 17:98-111 (1991)
00015 C
00016 C
00017 C                              Arguments
00018 C
00019 C
00020 C     ISDTYP -> The state to which the generator is to be set
00021 C
00022 C          ISDTYP = -1  => sets the seeds to their initial value
00023 C          ISDTYP =  0  => sets the seeds to the first value of
00024 C                          the current block
00025 C          ISDTYP =  1  => sets the seeds to the first value of
00026 C                          the next block
00027 C
00028 C                                   INTEGER ISDTYP
00029 C
00030 C**********************************************************************
00031 C     .. Parameters ..
00032       INTEGER numg
00033       PARAMETER (numg=32)
00034 C     ..
00035 C     .. Scalar Arguments ..
00036       INTEGER isdtyp
00037 C     ..
00038 C     .. Scalars in Common ..
00039       INTEGER a1,a1vw,a1w,a2,a2vw,a2w,m1,m2
00040 C     ..
00041 C     .. Arrays in Common ..
00042       INTEGER cg1(numg),cg2(numg),ig1(numg),ig2(numg),lg1(numg),
00043      +        lg2(numg)
00044       LOGICAL qanti(numg)
00045 C     ..
00046 C     .. Local Scalars ..
00047       INTEGER g
00048 C     ..
00049 C     .. External Functions ..
00050       LOGICAL qrgnin
00051       INTEGER mltmod
00052       EXTERNAL qrgnin,mltmod
00053 C     ..
00054 C     .. External Subroutines ..
00055       EXTERNAL getcgn
00056 C     ..
00057 C     .. Common blocks ..
00058       COMMON /globe/m1,m2,a1,a2,a1w,a2w,a1vw,a2vw,ig1,ig2,lg1,lg2,cg1,
00059      +       cg2,qanti
00060 C     ..
00061 C     .. Save statement ..
00062       SAVE /globe/
00063 C     ..
00064 C     .. Executable Statements ..
00065 C     Abort unless random number generator initialized
00066       IF (qrgnin()) GO TO 10
00067       WRITE (*,*) ' INITGN called before random number generator ',
00068      +  ' initialized -- abort!'
00069       CALL XSTOPX 
00070      + (' INITGN called before random number generator initialized')
00071 
00072    10 CALL getcgn(g)
00073       IF ((-1).NE. (isdtyp)) GO TO 20
00074       lg1(g) = ig1(g)
00075       lg2(g) = ig2(g)
00076       GO TO 50
00077 
00078    20 IF ((0).NE. (isdtyp)) GO TO 30
00079       CONTINUE
00080       GO TO 50
00081 C     do nothing
00082    30 IF ((1).NE. (isdtyp)) GO TO 40
00083       lg1(g) = mltmod(a1w,lg1(g),m1)
00084       lg2(g) = mltmod(a2w,lg2(g),m2)
00085       GO TO 50
00086 
00087    40 CALL XSTOPX ('ISDTYP NOT IN RANGE')
00088 
00089    50 cg1(g) = lg1(g)
00090       cg2(g) = lg2(g)
00091       RETURN
00092 
00093       END