This is a branch-off (isolation of first single test) from (will be posted below due to stupid restriction)
test_alloc_polymorph.f90 (4.1 KB)
The following test leads to a segmentation fault with nvfortran but shouldn’t.
module kinds
implicit none
integer, parameter, public :: i16 = selected_int_kind (4)
end module kinds
!!!!
module rng_base
use kinds, only: i16
implicit none
private
public :: rng_t
public :: rng_factory_t
type, abstract :: rng_t
contains
procedure (rng_init), deferred :: init
end type rng_t
type, abstract :: rng_factory_t
contains
procedure (rng_factory_init), deferred :: init
end type rng_factory_t
abstract interface
subroutine rng_init (rng, seed)
import
class(rng_t), intent(out) :: rng
integer, intent(in), optional :: seed
end subroutine rng_init
end interface
abstract interface
subroutine rng_factory_init (factory, seed)
import
class(rng_factory_t), intent(out) :: factory
integer(i16), intent(in), optional :: seed
end subroutine rng_factory_init
end interface
end module rng_base
!!!!!
module rng_base_uti
use kinds, only: i16
use rng_base
implicit none
private
public :: rng_test_t
public :: rng_test_factory_t
type, extends (rng_t) :: rng_test_t
integer :: state = 1
contains
procedure :: init => rng_test_init
end type rng_test_t
type, extends (rng_factory_t) :: rng_test_factory_t
integer :: seed = 1
contains
procedure :: init => rng_test_factory_init
end type rng_test_factory_t
contains
subroutine rng_test_init (rng, seed)
class(rng_test_t), intent(out) :: rng
integer, intent(in), optional :: seed
if (present (seed)) rng%state = seed
end subroutine rng_test_init
subroutine rng_test_factory_init (factory, seed)
class(rng_test_factory_t), intent(out) :: factory
integer(i16), intent(in), optional :: seed
if (present (seed)) factory%seed = mod (seed * 2 + 1, 10)
end subroutine rng_test_factory_init
end module rng_base_uti
!!!!!
module rng_base_ut
use rng_base_uti
implicit none
private
public :: rng_test_t
public :: rng_test_factory_t
end module rng_base_ut
!!!!!
module dispatch_rng
use kinds, only: i16
use rng_base
implicit none
private
public :: dispatch_rng_factory
public :: dispatch_rng_factory_fallback
procedure (dispatch_rng_factory), pointer :: &
dispatch_rng_factory_fallback => null ()
contains
subroutine dispatch_rng_factory (rng_factory, next_rng_seed)
class(rng_factory_t), allocatable, intent(inout) :: rng_factory
integer, intent(out) :: next_rng_seed
integer :: seed
character(30) :: buffer
integer(i16) :: s
seed = 1
print *, "The seed is ", seed
s = int (mod (seed, 32768), i16)
if (associated (dispatch_rng_factory_fallback)) then
call dispatch_rng_factory_fallback &
(rng_factory, next_rng_seed)
end if
write (buffer, "(I0)") s
call rng_factory%init (s)
end subroutine dispatch_rng_factory
end module dispatch_rng
!!!!!
module dispatch_rng_uti
use rng_base
use dispatch_rng
implicit none
private
public :: dispatch_rng_factory_test
public :: dispatch_rng_1
contains
subroutine dispatch_rng_1 (u)
integer, intent(in) :: u
integer :: next_rng_seed
class(rng_factory_t), allocatable :: rng_factory
call dispatch_rng_factory (rng_factory, next_rng_seed)
deallocate (rng_factory)
end subroutine dispatch_rng_1
subroutine dispatch_rng_factory_test (rng_factory, next_rng_seed)
use rng_base
use rng_base_ut, only: rng_test_factory_t
class(rng_factory_t), allocatable, intent(inout) :: rng_factory
integer, intent(out) :: next_rng_seed
next_rng_seed = 2
allocate (rng_test_factory_t :: rng_factory)
print *, "RNG: Initializing Test random-number generator"
end subroutine dispatch_rng_factory_test
end module dispatch_rng_uti
!!!!!
module dispatch_rng_ut
use dispatch_rng_uti
implicit none
private
public :: dispatch_rng_factory_test
end module dispatch_rng_ut
!!!!!
program main_ut
use dispatch_rng, only: dispatch_rng_factory_fallback
use dispatch_rng_uti
use dispatch_rng_ut, only: dispatch_rng_factory_test
implicit none
dispatch_rng_factory_fallback => dispatch_rng_factory_test
call dispatch_rng_1 (6)
end program main_ut