3 ! Third, complete example from the PGInsider article:
4 ! "Object-Oriented Programming in Fortran 2003 Part 3: Parameterized Derived Types"
7 ! Copyright (c) 2013, NVIDIA CORPORATION. All rights reserved.
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.
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.
21 ! Note that modification had to be made all of which are commented.
25 type :: base_matrix(k,c,r)
27 integer, kind :: k = 4
32 type, extends(base_matrix) :: adj_matrix
34 class(*), pointer :: m(:,:) => null()
38 module procedure getKind4
39 module procedure getKind8
43 module procedure getNumCols4
44 module procedure getNumCols8
45 end interface getColumns
48 module procedure getNumRows4
49 module procedure getNumRows8
53 module procedure construct_4 ! kind=4 constructor
54 module procedure construct_8 ! kind=8 constructor
55 end interface adj_matrix
57 interface 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
64 end interface assignment(=)
69 function getKind4(this) result(rslt)
70 class(adj_matrix(4,*,*)) :: this
75 function getKind8(this) result(rslt)
76 class(adj_matrix(8,*,*)) :: this
81 function getNumCols4(this) result(rslt)
82 class(adj_matrix(4,*,*)) :: this
85 end function getNumCols4
87 function getNumCols8(this) result(rslt)
88 class(adj_matrix(8,*,*)) :: this
91 end function getNumCols8
93 function getNumRows4(this) result(rslt)
94 class(adj_matrix(4,*,*)) :: this
97 end function getNumRows4
99 function getNumRows8(this) result(rslt)
100 class(adj_matrix(8,*,*)) :: this
103 end function getNumRows8
106 function construct_4(k,c,r) result(mat)
110 class(adj_matrix(4,:,:)),allocatable :: mat
112 allocate(adj_matrix(4,c,r)::mat)
114 end function construct_4
116 function construct_8(k,c,r) result(mat)
120 class(adj_matrix(8,:,:)),allocatable :: mat
122 allocate(adj_matrix(8,c,r)::mat)
124 end function construct_8
127 class(adj_matrix(4,:,:)),allocatable :: d
128 class(*),dimension(:,:) :: s
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)
137 class(adj_matrix(8,:,:)),allocatable :: d
138 class(*),dimension(:,:) :: s
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)
146 subroutine m2a8(a,this)
147 class(adj_matrix(8,*,*)), intent(in) :: this ! Intents required for
148 real(8),allocatable, intent(out) :: a(:,:) ! defined assignment
149 select type (array => this%m) ! Added SELECT TYPE because...
151 if (allocated(a)) deallocate(a)
152 allocate(a,source=array)
154 ! allocate(a(size(this%m,1),size(this%m,2)),source=this%m) ! ...CLASS(*) source does not work in gfortran
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...
162 if (allocated(a)) deallocate(a)
163 allocate(a,source=array)
165 ! allocate(a(size(this%m,1),size(this%m,2)),source=this%m) ! ...CLASS(*) source does not work in gfortran
169 CLASS(adj_matrix(4,:,:)),allocatable, intent(OUT) :: d ! Intents required for
170 CLASS(adj_matrix(4,*,*)), intent(in) :: s ! defined assignment
172 if (allocated(d)) deallocate(d)
177 CLASS(adj_matrix(8,:,:)),allocatable, intent(OUT) :: d ! Intents required for
178 CLASS(adj_matrix(8,*,*)), intent(in) :: s ! defined assignment
180 if (allocated(d)) deallocate(d)
194 class(adj_matrix(8,:,:)),allocatable :: adj ! Was TYPE: Fails in
195 real(8) :: a(2,3) ! defined assignment
196 real(8),allocatable :: b(:,:)
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
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])
210 if (any (b .ne. a)) STOP 4
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])
218 if (any (b_4 .ne. a_4)) STOP 6