URL https://opencores.org/ocsvn/openrisc_2011-10-31/openrisc_2011-10-31/trunk

Subversion Repositories openrisc_2011-10-31

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.2.2/] [gcc/] [testsuite/] [gfortran.dg/] [func_derived_4.f90] - Blame information for rev 154

Details | Compare with Previous | 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_scalar_field class_mesh" } }

Line No.	Rev	Author	Line
1	149	jeremybenn	`! { 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_scalar_field class_mesh" } }`

Browse

Tools

Subversion Repositories openrisc_2011-10-31

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.2.2/] [gcc/] [testsuite/] [gfortran.dg/] [func_derived_4.f90] - Blame information for rev 154