OpenCores
URL https://opencores.org/ocsvn/openrisc_me/openrisc_me/trunk

Subversion Repositories openrisc_me

[/] [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

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" } }

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.