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