gcc/testsuite/gfortran.dg/func_derived_4.f90

   1 ! { dg-do run }
   2 ! PR fortran/30793
   3 ! Check that pointer-returing functions
   4 ! work derived types.
   5 !
   6 ! Contributed by Salvatore Filippone.
   7 !
   8 module class_mesh
   9   type mesh
  10     real(kind(1.d0)), allocatable :: area(:)
  11   end type mesh
  12 contains
  13   subroutine create_mesh(msh)
  14     type(mesh), intent(out) :: msh
  15     allocate(msh%area(10))
  16     return
  17   end subroutine create_mesh
  18 end module class_mesh
  19
  20 module class_field
  21   use class_mesh
  22   implicit none
  23   private ! Default
  24   public :: create_field, field
  25   public :: msh_
  26
  27   type field
  28      private
  29      type(mesh),     pointer :: msh   => null()
  30      integer                 :: isize(2)
  31   end type field
  32
  33   interface msh_
  34     module procedure msh_
  35   end interface
  36   interface create_field
  37     module procedure create_field
  38   end interface
  39 contains
  40   subroutine create_field(fld,msh)
  41     type(field),      intent(out)        :: fld
  42     type(mesh),       intent(in), target :: msh
  43     fld%msh => msh
  44     fld%isize = 1
  45   end subroutine create_field
  46
  47   function msh_(fld)
  48     type(mesh), pointer :: msh_
  49     type(field), intent(in) :: fld
  50     msh_ => fld%msh
  51   end function msh_
  52 end module class_field
  53
  54 module class_scalar_field
  55   use class_field
  56   implicit none
  57   private
  58   public :: create_field, scalar_field
  59   public :: msh_
  60
  61   type scalar_field
  62     private
  63     type(field) :: base
  64     real(kind(1.d0)), allocatable :: x(:)
  65     real(kind(1.d0)), allocatable :: bx(:)
  66     real(kind(1.d0)), allocatable :: x_old(:)
  67   end type scalar_field
  68
  69   interface create_field
  70     module procedure create_scalar_field
  71   end interface
  72   interface msh_
  73     module procedure get_scalar_field_msh
  74   end interface
  75 contains
  76   subroutine create_scalar_field(fld,msh)
  77     use class_mesh
  78     type(scalar_field), intent(out)          :: fld
  79     type(mesh),         intent(in), target   :: msh
  80     call create_field(fld%base,msh)
  81     allocate(fld%x(10),fld%bx(20))
  82   end subroutine create_scalar_field
  83
  84   function get_scalar_field_msh(fld)
  85     use class_mesh
  86     type(mesh), pointer :: get_scalar_field_msh
  87     type(scalar_field), intent(in), target  :: fld
  88
  89     get_scalar_field_msh => msh_(fld%base)
  90   end function get_scalar_field_msh
  91 end module class_scalar_field
  92
  93 program test_pnt
  94   use class_mesh
  95   use class_scalar_field
  96   implicit none
  97   type(mesh) :: msh
  98   type(mesh), pointer  :: mshp
  99   type(scalar_field) :: quality
 100   call create_mesh(msh)
 101   call create_field(quality,msh)
 102   mshp => msh_(quality)
 103 end program test_pnt
 104
 105 ! { dg-final { cleanup-modules "class_mesh class_field class_scalar_field" } }