Mercurial > hg > octave-nkf
diff libcruft/ranlib/phrtsd.f @ 2329:30c606bec7a8
[project @ 1996-07-19 01:29:05 by jwe]
Initial revision
author | jwe |
---|---|
date | Fri, 19 Jul 1996 01:29:55 +0000 |
parents | |
children | df7c57a6639d |
line wrap: on
line diff
new file mode 100644 --- /dev/null +++ b/libcruft/ranlib/phrtsd.f @@ -0,0 +1,84 @@ + SUBROUTINE phrtsd(phrase,seed1,seed2) +C********************************************************************** +C +C SUBROUTINE PHRTSD( PHRASE, SEED1, SEED2 ) +C PHRase To SeeDs +C +C +C Function +C +C +C Uses a phrase (character string) to generate two seeds for the RGN +C random number generator. +C +C +C Arguments +C +C +C PHRASE --> Phrase to be used for random number generation +C CHARACTER*(*) PHRASE +C +C SEED1 <-- First seed for RGN generator +C INTEGER SEED1 +C +C SEED2 <-- Second seed for RGN generator +C INTEGER SEED2 +C +C +C Note +C +C +C Trailing blanks are eliminated before the seeds are generated. +C +C Generated seed values will fall in the range 1..2^30 +C (1..1,073,741,824) +C +C********************************************************************** +C .. Parameters .. + CHARACTER*(*) table + PARAMETER (table='abcdefghijklmnopqrstuvwxyz'// + + 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'//'0123456789'// + + '!@#$%^&*()_+[];:''"<>?,./') + INTEGER twop30 + PARAMETER (twop30=1073741824) +C .. +C .. Scalar Arguments .. + INTEGER seed1,seed2 + CHARACTER phrase* (*) +C .. +C .. Local Scalars .. + INTEGER i,ichr,j,lphr +C .. +C .. Local Arrays .. + INTEGER shift(0:4),values(5) +C .. +C .. External Functions .. + INTEGER lennob + EXTERNAL lennob +C .. +C .. Intrinsic Functions .. + INTRINSIC index,mod +C .. +C .. Data statements .. + DATA shift/1,64,4096,262144,16777216/ +C .. +C .. Executable Statements .. + seed1 = 1234567890 + seed2 = 123456789 + lphr = lennob(phrase) + IF (lphr.LT.1) RETURN + DO 30,i = 1,lphr + ichr = mod(index(table,phrase(i:i)),64) + IF (ichr.EQ.0) ichr = 63 + DO 10,j = 1,5 + values(j) = ichr - j + IF (values(j).LT.1) values(j) = values(j) + 63 + 10 CONTINUE + DO 20,j = 1,5 + seed1 = mod(seed1+shift(j-1)*values(j),twop30) + seed2 = mod(seed2+shift(j-1)*values(6-j),twop30) + 20 CONTINUE + 30 CONTINUE + RETURN + + END