1
2! KGEN-generated Fortran source file
3!
4! Filename    : mo_random_numbers.f90
5! Generated at: 2015-02-19 15:30:29
6! KGEN version: 0.4.4
7
8
9
10    MODULE mo_random_numbers
11        USE mo_kind, ONLY: dp
12        USE mo_kind, ONLY: i8
13        IMPLICIT NONE
14        LOGICAL, parameter :: big_endian = (transfer(1_i8, 1) == 0)
15        INTEGER, parameter :: state_size = 4
16        INTEGER :: global_seed(state_size)  =              (/123456789,362436069,21288629,14921776/)
17        PRIVATE
18        PUBLIC get_random
19
20        INTERFACE get_random
21            MODULE PROCEDURE kisssca, kiss_global, kissvec, kissvec_all, kissvec_global
22        END INTERFACE get_random
23            PUBLIC read_externs_mo_random_numbers
24
25        ! read interface
26        PUBLIC kgen_read_var
27        interface kgen_read_var
28            module procedure read_var_integer_4_dim1
29        end interface kgen_read_var
30
31        CONTAINS
32
33        ! module extern variables
34
35        SUBROUTINE read_externs_mo_random_numbers(kgen_unit)
36        integer, intent(in) :: kgen_unit
37        READ(UNIT=kgen_unit) global_seed
38        END SUBROUTINE read_externs_mo_random_numbers
39
40
41        ! read subroutines
42        subroutine read_var_integer_4_dim1(var, kgen_unit)
43            integer, intent(in) :: kgen_unit
44            integer(kind=4), intent(out), dimension(:), allocatable :: var
45            integer, dimension(2,1) :: kgen_bound
46            logical is_save
47
48            READ(UNIT = kgen_unit) is_save
49            if ( is_save ) then
50                READ(UNIT = kgen_unit) kgen_bound(1, 1)
51                READ(UNIT = kgen_unit) kgen_bound(2, 1)
52                ALLOCATE(var(kgen_bound(2, 1) - kgen_bound(1, 1) + 1))
53                READ(UNIT = kgen_unit) var
54            end if
55        end subroutine
56        ! -----------------------------------------------
57
58        ! -----------------------------------------------
59
60        ! -----------------------------------------------
61
62        SUBROUTINE kissvec_all(kproma, kbdim, seed, harvest)
63            INTEGER, intent(in   ) :: kbdim
64            INTEGER, intent(in   ) :: kproma
65            INTEGER, intent(inout) :: seed(:,:) ! Dimension nproma, seed_size
66            REAL(KIND=dp), intent(  out) :: harvest(:) ! Dimension nproma
67            LOGICAL :: mask(kbdim)
68            mask(:) = .true.
69            CALL kissvec(kproma, kbdim, seed, mask, harvest)
70        END SUBROUTINE kissvec_all
71        ! -----------------------------------------------
72
73        SUBROUTINE kissvec(kproma, kbdim, seed, mask, harvest)
74            INTEGER, intent(in   ) :: kbdim
75            INTEGER, intent(in   ) :: kproma
76            INTEGER, intent(inout) :: seed(:,:) ! Dimension kbdim, seed_size or bigger
77            LOGICAL, intent(in   ) :: mask(kbdim)
78            REAL(KIND=dp), intent(  out) :: harvest(kbdim)
79            INTEGER(KIND=i8) :: kiss(kproma)
80            INTEGER :: jk
81            DO jk = 1, kproma
82                IF (mask(jk)) THEN
83                    kiss(jk) = 69069_i8 * seed(jk,1) + 1327217885
84                    seed(jk,1) = low_byte(kiss(jk))
85                    seed(jk,2) = m (m (m (seed(jk,2), 13), - 17), 5)
86                    seed(jk,3) = 18000 * iand (seed(jk,3), 65535) + ishft (seed(jk,3), - 16)
87                    seed(jk,4) = 30903 * iand (seed(jk,4), 65535) + ishft (seed(jk,4), - 16)
88                    kiss(jk) = int(seed(jk,1), i8) + seed(jk,2) + ishft (seed(jk,3), 16) + seed(jk,4)
89                    harvest(jk) = low_byte(kiss(jk))*2.328306e-10_dp + 0.5_dp
90                    ELSE
91                    harvest(jk) = 0._dp
92                END IF
93            END DO
94        END SUBROUTINE kissvec
95        ! -----------------------------------------------
96
97        SUBROUTINE kisssca(seed, harvest)
98            INTEGER, intent(inout) :: seed(:)
99            REAL(KIND=dp), intent(  out) :: harvest
100            INTEGER(KIND=i8) :: kiss
101            kiss = 69069_i8 * seed(1) + 1327217885
102            seed(1) = low_byte(kiss)
103            seed(2) = m (m (m (seed(2), 13), - 17), 5)
104            seed(3) = 18000 * iand (seed(3), 65535) + ishft (seed(3), - 16)
105            seed(4) = 30903 * iand (seed(4), 65535) + ishft (seed(4), - 16)
106            kiss = int(seed(1), i8) + seed(2) + ishft (seed(3), 16) + seed(4)
107            harvest = low_byte(kiss)*2.328306e-10_dp + 0.5_dp
108        END SUBROUTINE kisssca
109        ! -----------------------------------------------
110
111        SUBROUTINE kiss_global(harvest)
112            REAL(KIND=dp), intent(inout) :: harvest
113            CALL kisssca(global_seed, harvest)
114        END SUBROUTINE kiss_global
115        ! -----------------------------------------------
116
117        SUBROUTINE kissvec_global(harvest)
118            REAL(KIND=dp), intent(inout) :: harvest(:)
119            INTEGER :: i
120            DO i = 1, size(harvest)
121                CALL kisssca(global_seed, harvest(i))
122            END DO
123        END SUBROUTINE kissvec_global
124        ! -----------------------------------------------
125
126        elemental integer FUNCTION m(k, n)
127            INTEGER, intent(in) :: k
128            INTEGER, intent(in) :: n
129            m = ieor (k, ishft (k, n)) ! UNRESOLVED: m
130        END FUNCTION m
131        ! -----------------------------------------------
132
133        elemental integer FUNCTION low_byte(i)
134            INTEGER(KIND=i8), intent(in) :: i
135            IF (big_endian) THEN
136                low_byte = transfer(ishft(i,bit_size(1)),1) ! UNRESOLVED: low_byte
137                ELSE
138                low_byte = transfer(i,1) ! UNRESOLVED: low_byte
139            END IF
140        END FUNCTION low_byte
141    END MODULE mo_random_numbers
142