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