]>
Commit | Line | Data |
---|---|---|
2bd74949 | 1 | /* Implementation of the IRAND, RAND, and SRAND intrinsics. |
7adcbafe | 2 | Copyright (C) 2004-2022 Free Software Foundation, Inc. |
2bd74949 SK |
3 | Contributed by Steven G. Kargl <kargls@comcast.net>. |
4 | ||
5 | This file is part of the GNU Fortran 95 runtime library (libgfortran). | |
6 | ||
7 | Libgfortran is free software; you can redistribute it and/or | |
57dea9f6 | 8 | modify it under the terms of the GNU General Public |
2bd74949 | 9 | License as published by the Free Software Foundation; either |
748086b7 | 10 | version 3 of the License, or (at your option) any later version. |
2bd74949 SK |
11 | |
12 | Libgfortran is distributed in the hope that it will be useful, | |
13 | but WITHOUT ANY WARRANTY; without even the implied warranty of | |
14 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
57dea9f6 | 15 | GNU General Public License for more details. |
2bd74949 | 16 | |
748086b7 JJ |
17 | Under Section 7 of GPL version 3, you are granted additional |
18 | permissions described in the GCC Runtime Library Exception, version | |
19 | 3.1, as published by the Free Software Foundation. | |
20 | ||
21 | You should have received a copy of the GNU General Public License and | |
22 | a copy of the GCC Runtime Library Exception along with this program; | |
23 | see the files COPYING3 and COPYING.RUNTIME respectively. If not, see | |
24 | <http://www.gnu.org/licenses/>. */ | |
2bd74949 SK |
25 | |
26 | /* Simple multiplicative congruent algorithm. | |
27 | The period of this generator is approximately 2^31-1, which means that | |
28 | it should not be used for anything serious. The implementation here | |
29 | is based of an algorithm from S.K. Park and K.W. Miller, Comm. ACM, | |
30 | 31, 1192-1201 (1988). It is also provided solely for compatibility | |
31 | with G77. */ | |
32 | ||
2bd74949 | 33 | #include "libgfortran.h" |
7606c786 | 34 | #include <gthr.h> |
2bd74949 SK |
35 | |
36 | #define GFC_RAND_A 16807 | |
37 | #define GFC_RAND_M 2147483647 | |
38 | #define GFC_RAND_M1 (GFC_RAND_M - 1) | |
39 | ||
40 | static GFC_UINTEGER_8 rand_seed = 1; | |
5e805e44 JJ |
41 | #ifdef __GTHREAD_MUTEX_INIT |
42 | static __gthread_mutex_t rand_seed_lock = __GTHREAD_MUTEX_INIT; | |
43 | #else | |
44 | static __gthread_mutex_t rand_seed_lock; | |
45 | #endif | |
2bd74949 SK |
46 | |
47 | ||
48 | /* Set the seed of the irand generator. Note 0 is a bad seed. */ | |
49 | ||
7d7b8bfe RH |
50 | static void |
51 | srand_internal (GFC_INTEGER_8 i) | |
2bd74949 | 52 | { |
7d7b8bfe | 53 | rand_seed = i ? i : 123459876; |
2bd74949 SK |
54 | } |
55 | ||
7d7b8bfe RH |
56 | extern void PREFIX(srand) (GFC_INTEGER_4 *i); |
57 | export_proto_np(PREFIX(srand)); | |
58 | ||
59 | void | |
60 | PREFIX(srand) (GFC_INTEGER_4 *i) | |
61 | { | |
5e805e44 | 62 | __gthread_mutex_lock (&rand_seed_lock); |
7d7b8bfe | 63 | srand_internal (*i); |
5e805e44 | 64 | __gthread_mutex_unlock (&rand_seed_lock); |
7d7b8bfe | 65 | } |
2bd74949 SK |
66 | |
67 | /* Return an INTEGER in the range [1,GFC_RAND_M-1]. */ | |
68 | ||
7d7b8bfe RH |
69 | extern GFC_INTEGER_4 irand (GFC_INTEGER_4 *); |
70 | iexport_proto(irand); | |
71 | ||
2bd74949 | 72 | GFC_INTEGER_4 |
7d7b8bfe | 73 | irand (GFC_INTEGER_4 *i) |
2bd74949 | 74 | { |
7a003d8e CY |
75 | GFC_INTEGER_4 j; |
76 | if (i) | |
77 | j = *i; | |
78 | else | |
79 | j = 0; | |
2bd74949 | 80 | |
5e805e44 JJ |
81 | __gthread_mutex_lock (&rand_seed_lock); |
82 | ||
2bd74949 SK |
83 | switch (j) |
84 | { | |
85 | /* Return the next RN. */ | |
86 | case 0: | |
87 | break; | |
88 | ||
89 | /* Reset the RN sequence to system-dependent sequence and return the | |
90 | first value. */ | |
91 | case 1: | |
7d7b8bfe | 92 | srand_internal (0); |
2bd74949 SK |
93 | break; |
94 | ||
95 | /* Seed the RN sequence with j and return the first value. */ | |
96 | default: | |
7d7b8bfe RH |
97 | srand_internal (j); |
98 | break; | |
2bd74949 SK |
99 | } |
100 | ||
101 | rand_seed = GFC_RAND_A * rand_seed % GFC_RAND_M; | |
5e805e44 JJ |
102 | j = (GFC_INTEGER_4) rand_seed; |
103 | ||
104 | __gthread_mutex_unlock (&rand_seed_lock); | |
2bd74949 | 105 | |
5e805e44 | 106 | return j; |
2bd74949 | 107 | } |
7d7b8bfe | 108 | iexport(irand); |
2bd74949 SK |
109 | |
110 | ||
a9e7b9d3 | 111 | /* Return a random REAL in the range [0,1). */ |
2bd74949 | 112 | |
7d7b8bfe RH |
113 | extern GFC_REAL_4 PREFIX(rand) (GFC_INTEGER_4 *i); |
114 | export_proto_np(PREFIX(rand)); | |
115 | ||
2bd74949 | 116 | GFC_REAL_4 |
7d7b8bfe | 117 | PREFIX(rand) (GFC_INTEGER_4 *i) |
2bd74949 | 118 | { |
cdc5524f TK |
119 | GFC_UINTEGER_4 mask; |
120 | #if GFC_REAL_4_RADIX == 2 | |
121 | mask = ~ (GFC_UINTEGER_4) 0u << (32 - GFC_REAL_4_DIGITS + 1); | |
122 | #elif GFC_REAL_4_RADIX == 16 | |
123 | mask = ~ (GFC_UINTEGER_4) 0u << ((8 - GFC_REAL_4_DIGITS) * 4 + 1); | |
124 | #else | |
125 | #error "GFC_REAL_4_RADIX has unknown value" | |
126 | #endif | |
127 | return ((GFC_UINTEGER_4) (irand(i) -1) & mask) * (GFC_REAL_4) 0x1.p-31f; | |
2bd74949 | 128 | } |
5e805e44 JJ |
129 | |
130 | #ifndef __GTHREAD_MUTEX_INIT | |
131 | static void __attribute__((constructor)) | |
132 | init (void) | |
133 | { | |
134 | __GTHREAD_MUTEX_INIT_FUNCTION (&rand_seed_lock); | |
135 | } | |
136 | #endif |