var/da/da_define_structures/da_random_seed.inc

   1 subroutine da_random_seed
   2
   3    !-----------------------------------------------------------------------
   4    ! Purpose: TBD
   5    !-----------------------------------------------------------------------
   6
   7    implicit none
   8
   9 #ifdef DM_PARALLEL
  10    INCLUDE 'mpif.h'
  11 #endif
  12
  13    integer              :: seed_size
  14    integer, allocatable :: seed_array(:)
  15
  16    integer              :: myproc,ierr,i
  17    character(len=32)    :: fmtstring
  18
  19    if (trace_use) call da_trace_entry("da_random_seed")
  20
  21    !----------------------------------------------------------------------------
  22    !  Check that right seed_size is being used:
  23    !----------------------------------------------------------------------------
  24
  25    myproc=0
  26 #ifdef DM_PARALLEL
  27    call wrf_get_dm_communicator (comm)
  28    call mpi_comm_rank (comm, myproc, ierr)
  29 #endif
  30
  31    call random_seed(size=seed_size)              ! Get size of seed array.
  32    write(unit=message(1),fmt='(a,i6)') 'Size of the random_seed array is ', seed_size
  33    call da_message(message(1:1))
  34    allocate(seed_array(1:seed_size))
  35    seed_array(1:seed_size) = 1
  36
  37    if (put_rand_seed) then            ! Manually set random seed.
  38
  39       if ( (seed_array1 == 0) .or. (seed_array2 == 0) ) then
  40          write(unit=message(1),fmt='(a)') ' Error: can not use "0" as a random seed!'
  41          write(unit=message(2),fmt='(a,i16)') ' seed_array1 = ',seed_array1
  42          write(unit=message(3),fmt='(a,i16)') ' seed_array2 = ',seed_array2
  43          call da_error(__FILE__,__LINE__,message(1:3))
  44       end if
  45
  46       if (seed_size == 1) then
  47          write(unit=message(1),fmt='(a)') &
  48             ' Warning: this compiler only supports a single random seed; only using seed_array1!'
  49          call da_warning(__FILE__,__LINE__,message(1:1))
  50          seed_array(1) = seed_array1
  51          write(unit=message(1),fmt='(a,i16)')' Setting seed_array(1) = ', seed_array(1)
  52       else if (seed_size > 2) then
  53          write(unit=message(1),fmt='(a,i2,a)') &
  54             ' Note: this compiler expects an array of ',seed_size,' integers to the "random_seed" function; '
  55          write(unit=message(2),fmt='(a)') &
  56             ' filling the rest of the array with copies of seed_array1 and seed_array2'
  57          call da_warning(__FILE__,__LINE__,message(1:2))
  58          do i = 1,seed_size
  59             if ( mod (i,2) == 1 ) then
  60                seed_array(i) = seed_array1
  61             else
  62                seed_array(i) = seed_array2 * seed_array1 + myproc*10000000
  63             end if
  64             write(unit=message(1),fmt='(a,i0,a,i16)')' Setting seed_array(',i,') = ', seed_array(i)
  65             call da_message(message(1:1))
  66          end do
  67       else if (seed_size == 2) then
  68          seed_array(1) = seed_array1
  69          seed_array(2) = seed_array2 * seed_array1 + myproc*10000000
  70          write(unit=message(1),fmt='(a,i16)')' Setting seed_array(1) = ', seed_array(1)
  71          write(unit=message(2),fmt='(a,i16)')' Setting seed_array(2) = ', seed_array(2)
  72          call da_message(message(1:2))
  73       else
  74          write(unit=message(1),fmt='(a)') ' Error: failure in random number generator'
  75          write(unit=message(1),fmt='(a)') ' Your compiler does not follow the Fortran 95 standard!'
  76          call da_error(__FILE__,__LINE__,message(1:2))
  77       end if
  78       call random_seed(put=seed_array(1:seed_size)) ! Set random seed.
  79
  80    else                                 ! Random seed set "randomly"
  81       call random_seed
  82       call random_seed(get=seed_array(1:seed_size))
  83       write(fmtstring, '(a,i3,a)') '(a27,', seed_size, '(i16))'
  84       write(unit=message(1),fmt=trim(fmtstring)) 'Random number seed array = ', (seed_array(i), i=1, seed_size)
  85       call da_message(message(1:1))
  86    end if
  87
  88    deallocate(seed_array)
  89
  90    if (trace_use) call da_trace_exit("da_random_seed")
  91
  92 end subroutine da_random_seed
  93
  94