libgfortran/intrinsics/random_init.f90

   1 ! Copyright (C) 2018-2023 Free Software Foundation, Inc.
   2 ! Contributed by Steven G. Kargl <kargl@gcc.gnu.org>
   3 !
   4 ! This file is part of the GNU Fortran runtime library (libgfortran).
   5 !
   6 ! Libgfortran is free software; you can redistribute it and/or
   7 ! modify it under the terms of the GNU General Public
   8 ! License as published by the Free Software Foundation; either
   9 ! version 3 of the License, or (at your option) any later version.
  10 !
  11 ! Libgfortran is distributed in the hope that it will be useful,
  12 ! but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ! GNU General Public License for more details.
  15 !
  16 ! Under Section 7 of GPL version 3, you are granted additional
  17 ! permissions described in the GCC Runtime Library Exception, version
  18 ! 3.1, as published by the Free Software Foundation.
  19 !
  20 ! You should have received a copy of the GNU General Public License and
  21 ! a copy of the GCC Runtime Library Exception along with this program;
  22 ! see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
  23 ! <http://www.gnu.org/licenses/>.
  24 !
  25 ! WARNING:  This file should never be compiled with an option that changes
  26 ! default logical kind from 4 to some other value or changes default integer
  27 ! kind from 4 to some other value.
  28 !
  29 ! There are four combinations of repeatable and image_distinct.  The
  30 ! language below is from the F2018 standard (actually, J3/18-007r1).
  31 !
  32 ! This routine is only used for non-coarray programs or with programs
  33 ! compiled with -fcoarray=single.  Use of -fcoarray=lib or -fcoarray=shared
  34 ! requires different routines due to the need for communication between
  35 ! images under case(iv).
  36 !
  37 ! Technically, neither image_distinct nor image_num are now needed.  The
  38 ! interface to _gfortran_random_init() is maintained for libgfortran ABI.
  39 ! Note, the Fortran standard requires the image_distinct argument, so
  40 ! it will always have a valid value, and the frontend generates an value
  41 ! of 0 for image_num.
  42 !
  43 impure subroutine _gfortran_random_init(repeatable, image_distinct, image_num)
  44
  45    implicit none
  46
  47    logical, value, intent(in) :: repeatable
  48    logical, value, intent(in) :: image_distinct
  49    integer, value, intent(in) :: image_num
  50
  51    logical, save :: once = .true.
  52    integer :: nseed, lcg_seed
  53    integer, save, allocatable :: seed(:)
  54
  55    if (repeatable) then
  56       if (once) then
  57          once = .false.
  58          call random_seed(size=nseed)
  59          allocate(seed(nseed))
  60          lcg_seed = 57911963
  61          call _gfortran_lcg(seed)
  62       end if
  63       call random_seed(put=seed)
  64    else
  65       call random_seed()
  66       !
  67       ! This cannot happen; but, prevent gfortran complaining about
  68       ! unused variables.
  69       !
  70       if (image_num > 2) then
  71          block
  72             use iso_fortran_env, only : error_unit
  73             write(error_unit, '(A)') 'whoops: random_init(.false., .false.)'
  74             if (image_distinct) error stop image_num + 1
  75             error stop image_num
  76          end block
  77       end if
  78    end if
  79
  80    contains
  81       !
  82       ! SK Park and KW Miller, ``Random number generators: good ones are hard
  83       ! to find,'' Comm. ACM, 31(10), 1192--1201, (1988).
  84       !
  85       ! Implementation of a prime modulus multiplicative linear congruential
  86       ! generator, which avoids overflow and provides the full period.
  87       !
  88       impure elemental subroutine _gfortran_lcg(i)
  89          implicit none
  90          integer, intent(out) :: i
  91          integer, parameter :: a = 16807     ! Multiplier
  92          integer, parameter :: m = huge(a)   ! Modulus
  93          integer, parameter :: q = 127773    ! Quotient to avoid overflow
  94          integer, parameter :: r = 2836      ! Remainder to avoid overflow
  95          lcg_seed = a * mod(lcg_seed, q) - r * (lcg_seed / q)
  96          if (lcg_seed <= 0) lcg_seed = lcg_seed + m
  97          i = lcg_seed
  98       end subroutine _gfortran_lcg
  99
 100 end subroutine _gfortran_random_init