1! { dg-do run }
2!
3! Third, complete example from the PGInsider article:
4! "Object-Oriented Programming in Fortran 2003 Part 3: Parameterized Derived Types"
5! by Mark Leair
6!
7!     Copyright (c) 2013, NVIDIA CORPORATION.  All rights reserved.
8!
9! NVIDIA CORPORATION and its licensors retain all intellectual property
10! and proprietary rights in and to this software, related documentation
11! and any modifications thereto.  Any use, reproduction, disclosure or
12! distribution of this software and related documentation without an express
13! license agreement from NVIDIA CORPORATION is strictly prohibited.
14!
15
16!          THIS CODE AND INFORMATION ARE PROVIDED "AS IS" WITHOUT
17!   WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING BUT
18!   NOT LIMITED TO THE IMPLIED WARRANTIES OF MERCHANTABILITY AND/OR
19!   FITNESS FOR A PARTICULAR PURPOSE.
20!
21! Note that modification had to be made all of which are commented.
22!
23module matrix
24
25type :: base_matrix(k,c,r)
26  private
27    integer, kind :: k = 4
28    integer, len :: c = 1
29    integer, len :: r = 1
30end type base_matrix
31
32type, extends(base_matrix) ::  adj_matrix
33  private
34    class(*), pointer :: m(:,:) => null()
35end type adj_matrix
36
37interface getKind
38  module procedure getKind4
39  module procedure getKind8
40end interface getKind
41
42interface getColumns
43  module procedure getNumCols4
44  module procedure getNumCols8
45end interface getColumns
46
47interface getRows
48  module procedure getNumRows4
49  module procedure getNumRows8
50end interface getRows
51
52interface adj_matrix
53   module procedure construct_4   ! kind=4 constructor
54   module procedure construct_8   ! kind=8 constructor
55end interface adj_matrix
56
57interface assignment(=)
58   module procedure m2m4          ! assign kind=4 matrix
59   module procedure a2m4          ! assign kind=4 array
60   module procedure m2m8          ! assign kind=8 matrix
61   module procedure a2m8          ! assign kind=8 array
62   module procedure m2a4          ! assign kind=4 matrix to array
63   module procedure m2a8          ! assign kind=8 matrix to array
64end interface assignment(=)
65
66
67contains
68
69  function getKind4(this) result(rslt)
70   class(adj_matrix(4,*,*)) :: this
71   integer :: rslt
72   rslt = this%k
73  end function getKind4
74
75 function getKind8(this) result(rslt)
76   class(adj_matrix(8,*,*)) :: this
77   integer :: rslt
78   rslt = this%k
79 end function getKind8
80
81  function getNumCols4(this) result(rslt)
82   class(adj_matrix(4,*,*)) :: this
83   integer :: rslt
84   rslt = this%c
85  end function getNumCols4
86
87  function getNumCols8(this) result(rslt)
88   class(adj_matrix(8,*,*)) :: this
89   integer :: rslt
90   rslt = this%c
91  end function getNumCols8
92
93  function getNumRows4(this) result(rslt)
94   class(adj_matrix(4,*,*)) :: this
95   integer :: rslt
96   rslt = this%r
97  end function getNumRows4
98
99  function getNumRows8(this) result(rslt)
100   class(adj_matrix(8,*,*)) :: this
101   integer :: rslt
102   rslt = this%r
103  end function getNumRows8
104
105
106 function construct_4(k,c,r) result(mat)
107     integer(4) :: k
108     integer :: c
109     integer :: r
110     class(adj_matrix(4,:,:)),allocatable :: mat
111
112     allocate(adj_matrix(4,c,r)::mat)
113
114  end function construct_4
115
116  function construct_8(k,c,r) result(mat)
117     integer(8) :: k
118     integer :: c
119     integer :: r
120     class(adj_matrix(8,:,:)),allocatable :: mat
121
122     allocate(adj_matrix(8,c,r)::mat)
123
124  end function construct_8
125
126  subroutine a2m4(d,s)
127   class(adj_matrix(4,:,:)),allocatable :: d
128   class(*),dimension(:,:) :: s
129
130   if (allocated(d)) deallocate(d)
131!    allocate(adj_matrix(4,size(s,1),size(s,2))::d)     ! generates assembler error
132   allocate(d, mold = adj_matrix(4,size(s,1),size(s,2)))
133   allocate(d%m(size(s,1),size(s,2)),source=s)
134 end subroutine a2m4
135
136 subroutine a2m8(d,s)
137   class(adj_matrix(8,:,:)),allocatable :: d
138   class(*),dimension(:,:) :: s
139
140   if (allocated(d)) deallocate(d)
141!    allocate(adj_matrix(8,size(s,1),size(s,2))::d)     ! generates assembler error
142   allocate(d, mold = adj_matrix(8_8,size(s,1),size(s,2))) ! Needs 8_8 to match arg1 of 'construct_8'
143   allocate(d%m(size(s,1),size(s,2)),source=s)
144 end subroutine a2m8
145
146subroutine m2a8(a,this)
147class(adj_matrix(8,*,*)), intent(in) :: this         ! Intents required for
148real(8),allocatable, intent(out) :: a(:,:)           ! defined assignment
149  select type (array => this%m)                      ! Added SELECT TYPE because...
150    type is (real(8))
151  if (allocated(a)) deallocate(a)
152  allocate(a,source=array)
153  end select
154!   allocate(a(size(this%m,1),size(this%m,2)),source=this%m) ! ...CLASS(*) source does not work in gfortran
155 end subroutine m2a8
156
157 subroutine m2a4(a,this)
158 class(adj_matrix(4,*,*)), intent(in) :: this        ! Intents required for
159 real(4),allocatable, intent(out) :: a(:,:)          ! defined assignment
160  select type (array => this%m)                      ! Added SELECT TYPE because...
161    type is (real(4))
162   if (allocated(a)) deallocate(a)
163   allocate(a,source=array)
164  end select
165!   allocate(a(size(this%m,1),size(this%m,2)),source=this%m) ! ...CLASS(*) source does not work in gfortran
166 end subroutine m2a4
167
168  subroutine m2m4(d,s)
169   CLASS(adj_matrix(4,:,:)),allocatable, intent(OUT) :: d   ! Intents required for
170   CLASS(adj_matrix(4,*,*)), intent(in) :: s                ! defined assignment
171
172   if (allocated(d)) deallocate(d)
173   allocate(d,source=s)
174 end subroutine m2m4
175
176 subroutine m2m8(d,s)
177   CLASS(adj_matrix(8,:,:)),allocatable, intent(OUT) :: d   ! Intents required for
178   CLASS(adj_matrix(8,*,*)), intent(in) :: s                ! defined assignment
179
180   if (allocated(d)) deallocate(d)
181   allocate(d,source=s)
182 end subroutine m2m8
183
184
185end module matrix
186
187
188program adj3
189
190  use matrix
191  implicit none
192  integer(8) :: i
193
194  class(adj_matrix(8,:,:)),allocatable :: adj             ! Was TYPE: Fails in
195  real(8) :: a(2,3)                                       ! defined assignment
196  real(8),allocatable :: b(:,:)
197
198  class(adj_matrix(4,:,:)),allocatable :: adj_4           ! Ditto and ....
199  real(4) :: a_4(3,2)                                     ! ... these declarations were
200  real(4),allocatable :: b_4(:,:)                         ! added to check KIND=4
201
202! Check constructor of PDT and instrinsic assignment
203  adj = adj_matrix(INT(8,8),2,4)
204  if (adj%k .ne. 8) STOP 1
205  if (adj%c .ne. 2) STOP 2
206  if (adj%r .ne. 4) STOP 3
207  a = reshape ([(i, i = 1, 6)], [2,3])
208  adj = a
209  b = adj
210  if (any (b .ne. a)) STOP 4
211
212! Check allocation with MOLD of PDT. Note that only KIND parameters set.
213  allocate (adj_4, mold = adj_matrix(4,3,2))           ! Added check of KIND = 4
214  if (adj_4%k .ne. 4) STOP 5
215  a_4 = reshape (a, [3,2])
216  adj_4 = a_4
217  b_4 = adj_4
218  if (any (b_4 .ne. a_4)) STOP 6
219
220end program adj3
221
222
223
224