URL
https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc
[/] [openrisc/] [tags/] [gnu-src/] [gcc-4.5.1/] [gcc-4.5.1-or32-1.0rc3/] [gcc/] [testsuite/] [gfortran.dg/] [func_derived_4.f90] - Rev 302
Go to most recent revision | Compare with Previous | Blame | View Log
! { dg-do run }
! PR fortran/30793
! Check that pointer-returing functions
! work derived types.
!
! Contributed by Salvatore Filippone.
!
module class_mesh
type mesh
real(kind(1.d0)), allocatable :: area(:)
end type mesh
contains
subroutine create_mesh(msh)
type(mesh), intent(out) :: msh
allocate(msh%area(10))
return
end subroutine create_mesh
end module class_mesh
module class_field
use class_mesh
implicit none
private ! Default
public :: create_field, field
public :: msh_
type field
private
type(mesh), pointer :: msh => null()
integer :: isize(2)
end type field
interface msh_
module procedure msh_
end interface
interface create_field
module procedure create_field
end interface
contains
subroutine create_field(fld,msh)
type(field), intent(out) :: fld
type(mesh), intent(in), target :: msh
fld%msh => msh
fld%isize = 1
end subroutine create_field
function msh_(fld)
type(mesh), pointer :: msh_
type(field), intent(in) :: fld
msh_ => fld%msh
end function msh_
end module class_field
module class_scalar_field
use class_field
implicit none
private
public :: create_field, scalar_field
public :: msh_
type scalar_field
private
type(field) :: base
real(kind(1.d0)), allocatable :: x(:)
real(kind(1.d0)), allocatable :: bx(:)
real(kind(1.d0)), allocatable :: x_old(:)
end type scalar_field
interface create_field
module procedure create_scalar_field
end interface
interface msh_
module procedure get_scalar_field_msh
end interface
contains
subroutine create_scalar_field(fld,msh)
use class_mesh
type(scalar_field), intent(out) :: fld
type(mesh), intent(in), target :: msh
call create_field(fld%base,msh)
allocate(fld%x(10),fld%bx(20))
end subroutine create_scalar_field
function get_scalar_field_msh(fld)
use class_mesh
type(mesh), pointer :: get_scalar_field_msh
type(scalar_field), intent(in), target :: fld
get_scalar_field_msh => msh_(fld%base)
end function get_scalar_field_msh
end module class_scalar_field
program test_pnt
use class_mesh
use class_scalar_field
implicit none
type(mesh) :: msh
type(mesh), pointer :: mshp
type(scalar_field) :: quality
call create_mesh(msh)
call create_field(quality,msh)
mshp => msh_(quality)
end program test_pnt
! { dg-final { cleanup-modules "class_mesh class_field class_scalar_field" } }
Go to most recent revision | Compare with Previous | Blame | View Log