Particulars/random_init.F90 at master · uihsnv/Particulars · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
!----------------------------------------------------------------------
!                      RANDOM NUMBER INITIATORS                       !
!----------------------------------------------------------------------
!
!   Copyright (C) 2015-2018  Vishnu V. Krishnan : vishnugb@gmail.com
!
!   This program is free software: you can redistribute it and/or modify
!   it under the terms of the GNU General Public License as published by
!   the Free Software Foundation, either version 3 of the License, or
!   (at your option) any later version.
!
!   This program is distributed in the hope that it will be useful,
!   but WITHOUT ANY WARRANTY; without even the implied warranty of
!   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!   GNU General Public License for more details.
!
!   You should have received a copy of the GNU General Public License
!   along with this program.  If not, see <https://www.gnu.org/licenses/>.

MODULE random_init

    !!DIR$ IF DEFINED (__INTEL_COMPILER)
#ifdef __INTEL_COMPILER
    USE IFPORT
#endif
    !!DIR$ END IF

CONTAINS

    SUBROUTINE init_random_seed()

        USE iso_fortran_env, ONLY: int64

        INTEGER, DIMENSION(:), ALLOCATABLE :: seed
        INTEGER :: i, n, un, istat, dt(8), pid
        INTEGER(int64) :: t

        CALL RANDOM_SEED(size = n)
        ALLOCATE(seed(n))
        ! First try if the OS provides a random number generator

        OPEN(NEWUNIT=un, FILE="/dev/urandom", ACCESS="stream", &
             FORM="unformatted", ACTION="read", STATUS="old", IOSTAT=istat)

        IF (istat == 0) THEN

            READ(un) seed
            CLOSE(un)

        ELSE

            ! Fallback to XOR:ing the current time and pid. The PID is
            ! useful in case one launches multiple instances of the same
            ! program in parallel.
            CALL SYSTEM_CLOCK(t)
            IF (t == 0) THEN
                CALL DATE_AND_TIME(values=dt)
                t = (dt(1) - 1970) * 365_int64 * 24 * 60 * 60 * 1000 &
                   + dt(2) * 31_int64 * 24 * 60 * 60 * 1000 &
                   + dt(3) * 24_int64 * 60 * 60 * 1000 &
                   + dt(5) * 60 * 60 * 1000 &
                   + dt(6) * 60 * 1000 + dt(7) * 1000 &
                   + dt(8)
            END IF
            pid = GETPID()
            t = IEOR(t, INT(pid, KIND(t)))
            DO i = 1, n
                seed(i) = lcg(t)
            END DO

        END IF
        CALL RANDOM_SEED(put=seed)

        CONTAINS
          ! This simple PRNG might not be good enough for real work, but is
          ! sufficient for seeding a better PRNG.
            FUNCTION lcg(s)
              INTEGER :: lcg
              INTEGER(int64) :: s
              IF (s == 0) THEN
                 s = 104729
              ELSE
                 s = MOD(s, 4294967296_int64)
              END IF
              s = MOD(s * 279470273_int64, 4294967291_int64)
              lcg = INT(MOD(s, INT(HUGE(0), int64)), KIND(0))
            end function lcg

    END SUBROUTINE init_random_seed


    SUBROUTINE init_random_seed_primitive()

        INTEGER :: i, n, clock
        INTEGER, DIMENSION(:), ALLOCATABLE :: seed

        CALL RANDOM_SEED(size = n)
        ALLOCATE(seed(n))

        CALL SYSTEM_CLOCK(COUNT=clock)

        seed = clock + 37 * [(i - 1, i = 1, n)]
        CALL RANDOM_SEED(PUT = seed)

        DEALLOCATE(seed)
    END SUBROUTINE


    SUBROUTINE init_random_seed_fixed()

        INTEGER :: i, n
        INTEGER, DIMENSION(:), ALLOCATABLE :: seed

        CALL RANDOM_SEED(size = n)
        ALLOCATE(seed(n))

        seed = 37 * [(i - 1, i = 1, n)]
        CALL RANDOM_SEED(PUT = seed)

        DEALLOCATE(seed)
    END SUBROUTINE

END MODULE random_init