Call type bound procedure of a derived type attribute

Accelerated Computing HPC Compilers Legacy PGI Compilers
1

Dear PGI developers,
I am building a big library with the PGI Fortran compiler, i factorized as much as possible the runtime error i get.

The result of this program must be

gfortran -g -O0  -c f_module.F90
gfortran -g -O0 -o run f_module.o test_scalar_field_2d.F90
./run
 get mesh
          64          64

But i get

pgfortran -o f_module.o -c f_module.F90
pgfortran -o test_scalar_field_2d.o -c test_scalar_field_2d.F90
pgfortran -o run f_module.o test_scalar_field_2d.o
./run
 get mesh
Segmentation fault: 11

I paste the program, i tried to give the smallest example:

module m_meshes

  implicit none

  type :: t_mesh
     integer :: num_cells1
     integer :: num_cells2
  end type t_mesh

end module m_meshes

module m_transformation

  use m_meshes

  implicit none

  type :: t_transformation
     type(t_mesh), pointer :: mesh => null()
   contains
     procedure :: get_mesh => get_mesh
  end type t_transformation

contains

  function f_new_transformation(mesh) result(this)

    type(t_transformation), pointer :: this
    type(t_mesh),            target  :: mesh

    allocate(this)
    this%mesh => mesh

  end function f_new_transformation

  function get_mesh( this ) result(res)

    class(t_transformation) :: this
    type(t_mesh), pointer    :: res

    res => this%mesh

  end function get_mesh

end module m_transformation

module m_scalar_field

  use m_meshes
  use m_transformation

  implicit none

  type :: t_scalar_field
    type(t_mesh),             pointer :: mesh
    class(t_transformation), pointer :: t
  contains
    procedure :: get_mesh => get_mesh_from_field
  end type t_scalar_field

contains

  function f_new_scalar_field( transformation  ) result(this)

    type(t_scalar_field), pointer          :: this
    class(t_transformation), target :: transformation

    allocate(this)

    this%T => transformation

  end function f_new_scalar_field

  function get_mesh_from_field( this ) result(res)

    class(t_scalar_field), intent(in) :: this
    class(t_mesh), pointer :: res

    res => this%T%get_mesh()

  end function get_mesh_from_field

end module m_scalar_field

The main program

program test_scalar_field

use m_meshes
use m_transformation
use m_scalar_field

implicit none

type(t_mesh)                     :: mesh
class(t_transformation), pointer :: T
class(t_scalar_field),   pointer :: field
type(t_mesh),            pointer :: res_mesh

mesh = t_mesh( 64, 64 )

T => f_new_transformation( mesh )

field => f_new_scalar_field( T)

print*, 'get mesh '
res_mesh  => field%get_mesh()
print*, res_mesh%num_cells1, res_mesh%num_cells2

end program test_scalar_field

Thanks for your help
Pierre

2

In function
f_new_transformation(mesh)
I change the declaration from class to type and it works…

function f_new_transformation(mesh) result(this)

    type(t_transformation), pointer :: this
    type(t_mesh),            target  :: mesh

    allocate(this)
    this%mesh => mesh
    
  end function f_new_transformation
3

f_new_transformation(mesh) already has everything defined as type,
and the program still seg faults.

What did you actually change from ‘class’ to ‘type’ that made the program work?


dave

4

I made a mistake it is in
In function f_new_scalar_field
I still have a lot of problem with this code, i will probably add new examples to this post.

5

Okay.

6

Sorry but every time i try to make the code shorter, it works:
I have two modules with abstract classes

First module:

module m_transformation_base

  implicit none

  type :: t_mesh
     integer  :: num_cells1
     integer  :: num_cells2
     real(8)  :: eta1_min
     real(8)  :: eta1_max
     real(8)  :: eta2_min
     real(8)  :: eta2_max
     real(8)  :: delta_eta1
     real(8)  :: delta_eta2
  end type t_mesh

  type, abstract :: c_transformation_base
     type(t_mesh), pointer :: mesh => null()
   contains
     procedure(geometry_function), deferred, pass :: x1
     procedure(geometry_function), deferred, pass :: x2
  end type c_transformation_base

  abstract interface
     function geometry_function( this, eta1, eta2 )
       import c_transformation_base
       class(c_transformation_base) :: this
       real(8)   :: eta1
       real(8)   :: eta2
       real(8)   :: geometry_function
     end function geometry_function
  end interface

end module m_transformation_base

module m_transformation

  use m_transformation_base

  implicit none

  interface
     function i_transformation_function( eta1, eta2 ) result(res)
       real(8) :: eta1
       real(8) :: eta2
       real(8) :: res
     end function i_transformation_function
  end interface

  type, extends(c_transformation_base) :: t_transformation
     procedure(i_transformation_function), pointer, nopass :: x1_func
     procedure(i_transformation_function), pointer, nopass :: x2_func
   contains
     procedure, pass(this) :: x1 => x1_analytic
     procedure, pass(this) :: x2 => x2_analytic
  end type t_transformation


contains

  function f_new_mesh(num_cells1, num_cells2, eta1_min, eta1_max, &
    eta2_min, eta2_max ) result(mesh)

    type(t_mesh), pointer :: mesh
    integer :: num_cells1, num_cells2
    real(8) :: eta1_min, eta1_max, eta2_min, eta2_max

    allocate(mesh)

    mesh%num_cells1 = num_cells1
    mesh%num_cells2 = num_cells2

    mesh%eta1_min = eta1_min
    mesh%eta1_max = eta1_max
    mesh%eta2_min = eta2_min
    mesh%eta2_max = eta2_max

    mesh%delta_eta1 = (eta1_max - eta1_min)/real(num_cells1,8)
    mesh%delta_eta2 = (eta2_max - eta2_min)/real(num_cells2,8)

  end function f_new_mesh

  function f_new_transformation( mesh, x1_func, x2_func) result(T)

    type(t_transformation),                 pointer :: T
    type(t_mesh),                           pointer :: mesh
    procedure(i_transformation_function)            :: x1_func
    procedure(i_transformation_function)            :: x2_func

    allocate(T)

    T%mesh    => mesh
    T%x1_func => x1_func
    T%x2_func => x2_func

  end function f_new_transformation

  function x1_analytic( this, eta1, eta2 ) result(val)
    class(t_transformation) :: this
    real(8)                 :: eta1
    real(8)                 :: eta2
    real(8)                 :: val

    val = this%x1_func(eta1, eta2)

  end function x1_analytic

  function x2_analytic( this, eta1, eta2 ) result(val)
    real(8)                 :: val
    class(t_transformation) :: this
    real(8)                 :: eta1
    real(8)                 :: eta2

    val = this%x2_func(eta1, eta2)

  end function x2_analytic

end module m_transformation

Second module

module m_field_base

use m_transformation_base

implicit none

type, abstract :: c_field_base
  class(c_transformation_base), pointer :: t
 contains
   procedure(function_evaluation_real), deferred, pass :: value_at_point
end type c_field_base

abstract interface
   function function_evaluation_real( field, eta1, eta2 )
     import c_field_base
     class(c_field_base), intent(in) :: field
     real(8) :: eta1
     real(8) :: eta2
     real(8) :: function_evaluation_real
   end function function_evaluation_real
end interface

end module m_field_base


module m_field

  use m_transformation
  use m_field_base

  implicit none

  interface

    function i_two_var_function( eta1, eta2 )
      real(8) :: eta1
      real(8) :: eta2
      real(8) :: i_two_var_function
    end function i_two_var_function

  end interface

  type, extends(c_field_base) :: t_field

    procedure(i_two_var_function), pointer, nopass :: func

  contains

    procedure, pass(field) :: value_at_point => value_at_pt_analytic

  end type t_field

contains

  function f_new_field( func, t ) result(field)

    procedure(i_two_var_function), pointer :: func
    class(c_transformation_base),  pointer :: T
    type(t_field),                 pointer :: field

    allocate(field)

    field%T         => T
    field%func      => func

  end function f_new_field

  function value_at_pt_analytic( field, eta1, eta2 )

    class(t_field), intent(in) :: field
    real(8)                    :: eta1
    real(8)                    :: eta2
    real(8)                    :: value_at_pt_analytic

    value_at_pt_analytic = field%func(eta1,eta2)

  end function value_at_pt_analytic


end module m_field

main program

module m_functions

implicit none

contains

  function f_identity_x1 ( eta1, eta2 )
    real(8) :: f_identity_x1
    real(8) :: eta1
    real(8) :: eta2
    f_identity_x1 = eta1
  end function f_identity_x1

  function f_identity_x2 ( eta1, eta2 )
    real(8) :: f_identity_x2
    real(8) :: eta1
    real(8) :: eta2
    f_identity_x2 = eta2
  end function f_identity_x2

  function test_function( eta1, eta2 )
    real(8) :: eta1
    real(8) :: eta2
    real(8) :: test_function

    test_function = (eta1/0.25_8)*10+eta2/0.25_8 +11_8

  end function test_function

end module m_functions

program test_scalar_field_2d

use m_functions
use m_transformation
use m_field_base
use m_field

implicit none

type(t_mesh),                 pointer :: mesh
class(c_transformation_base), pointer :: T
class(c_field_base),          pointer :: field
integer                               :: nptsx1
integer                               :: nptsx2
real(8), dimension(:,:), allocatable  :: x1coords
real(8), dimension(:,:), allocatable  :: x2coords
real(8), dimension(:,:), allocatable  :: values
real(8)                               :: eta1
real(8)                               :: eta2
integer                               :: i
integer                               :: j

procedure(i_transformation_function), pointer :: x1
procedure(i_transformation_function), pointer :: x2
procedure(i_two_var_function),        pointer :: f

x1 => f_identity_x1
x2 => f_identity_x2
f  => test_function

mesh => f_new_mesh( 4, 4, 0.0_8, 1.0_8, 0.0_8, 1.0_8 )

T => f_new_transformation( mesh, x1, x2)

field  => f_new_field( f, T)

nptsx1 = mesh%num_cells1 + 1
nptsx2 = mesh%num_cells2 + 1

allocate(x1coords(nptsx1,nptsx2))
allocate(x2coords(nptsx1,nptsx2))
allocate(values(nptsx1,nptsx2))

! Fill the arrays with the needed information.
do j=1, nptsx2
  eta2 = field%T%mesh%eta2_min + real(j-1,8)*field%T%mesh%delta_eta2
  do i=1, nptsx1
    eta1 = field%T%mesh%eta1_min + real(i-1,8)*field%T%mesh%delta_eta1
    x1coords(i,j) = field%T%x1(eta1,eta2)
    x2coords(i,j) = field%T%x2(eta1,eta2)
    values(i,j)   = field%value_at_point(eta1,eta2)
  end do
end do

do i = 1, nptsx1
  print"(5f5.0)", values(i,:)
end do

deallocate(x1coords)
deallocate(x2coords)
deallocate(values)

end program test_scalar_field_2d

Result must be:

./run
  11.  12.  13.  14.  15.
  21.  22.  23.  24.  25.
  31.  32.  33.  34.  35.
  41.  42.  43.  44.  45.
  51.  52.  53.  54.  55.

But i got a segmentation fault with pgi compiler.
Sorry for this very long code, i am keep looking the error.
Thanks
Pierre

7

I uploaded the code on github

https://github.com/pnavaro/test_pgi

Pierre

8

PGI does not like the function

function f_new_field( func, t ) result(field) 

    procedure(i_two_var_function), pointer :: func 
    class(c_transformation_base),  pointer :: T 
    type(t_field),                 pointer :: field 

    allocate(field) 

    field%T         => T 
    field%func      => func 

  end function f_new_field

This kind of function to set the type of the class works well for the transformation class but it does not work for the field class. Perhaps, PGI compiler does not like that field class contains an abstract class.

9

We have replicated the failure and we have created TPR 23629 to address
the issue.

Thanks again for example that demonstrates. It was not too big.


dave