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! 8module class_mesh 9 type mesh 10 real(kind(1.d0)), allocatable :: area(:) 11 end type mesh 12contains 13 subroutine create_mesh(msh) 14 type(mesh), intent(out) :: msh 15 allocate(msh%area(10)) 16 return 17 end subroutine create_mesh 18end module class_mesh 19 20module 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 39contains 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_ 52end module class_field 53 54module 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 75contains 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 91end module class_scalar_field 92 93program 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) 103end program test_pnt 104