Line data Source code
1 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3 : !!!! !!!!
4 : !!!! ParaMonte: Parallel Monte Carlo and Machine Learning Library. !!!!
5 : !!!! !!!!
6 : !!!! Copyright (C) 2012-present, The Computational Data Science Lab !!!!
7 : !!!! !!!!
8 : !!!! This file is part of the ParaMonte library. !!!!
9 : !!!! !!!!
10 : !!!! LICENSE !!!!
11 : !!!! !!!!
12 : !!!! https://github.com/cdslaborg/paramonte/blob/main/LICENSE.md !!!!
13 : !!!! !!!!
14 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
15 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
16 :
17 : !> \brief This file contains the implementations of the tests of module [pm_distanceEuclid](@ref pm_distanceEuclid).
18 : !>
19 : !> \fintest
20 : !>
21 : !> \author
22 : !> \AmirShahmoradi, March 22, 2012, 2:21 PM, National Institute for Fusion Studies, The University of Texas at Austin
23 :
24 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
25 :
26 :
27 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
28 : #if getDisEuclid_ENABLED || setDisEuclid_ENABLED
29 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
30 :
31 : integer(IK), parameter :: ntry = 100
32 : real(TKC), parameter :: EPS = epsilon(0._TKC) * 100
33 : real(TKC), allocatable :: distance(:,:), distance_ref(:,:)
34 : real(TKC), allocatable :: point(:,:), ref(:,:)
35 : real(TKC), allocatable :: diff(:,:)
36 8 : type(csp_type), allocatable :: method(:)
37 8 : type(css_type), allocatable :: mnames(:)
38 : integer(IK) :: ndim, npnt, nref
39 : integer(IK) :: itry, imethod
40 : logical(LK) :: isorigin
41 :
42 8 : assertion = .true._LK
43 :
44 88 : method = [csp_type(euclid), csp_type(euclidu), csp_type(euclidsq)]
45 64 : mnames = [css_type("euclid"), css_type("euclidu"), css_type("euclidsq")]
46 :
47 864 : do itry = 1, ntry
48 :
49 800 : isorigin = getUnifRand()
50 800 : ndim = getUnifRand(1_IK, 10_IK)
51 800 : npnt = getUnifRand(1_IK, 20_IK)
52 800 : nref = getUnifRand(1_IK, 20_IK)
53 :
54 100131 : diff = getFilled(0._TKC, nref, npnt)
55 800 : if (isorigin) then
56 28767 : ref = getFilled(0._TKC, ndim, nref)
57 : else
58 28571 : ref = getUnifRand(-1._TKC, 1._TKC, ndim, nref)
59 : end if
60 55338 : point = getUnifRand(-1._TKC, 1._TKC, ndim, npnt)
61 2400 : call setResized(distance, [nref, npnt])
62 :
63 3208 : do imethod = 1, size(method)
64 3199 : distance_ref = getDisEuclid_ref(point, ref, method(imethod)%val)
65 : #if getDisEuclid_ENABLED
66 1600 : if (isorigin) then
67 : ! D1_XX
68 : block
69 : integer(IK) :: ipnt, iref
70 : ipnt = 1_IK; iref = 1_IK
71 582 : distance(iref,ipnt) = getDisEuclid(point(:,ipnt), method(imethod)%val)
72 582 : diff(iref,ipnt) = abs(distance(iref,ipnt) - distance_ref(iref,ipnt))
73 582 : assertion = assertion .and. diff(iref,ipnt) < EPS
74 582 : call report(__LINE__, mnames(imethod)%val, point(:,ipnt), ref(:,iref), distance(iref,ipnt), distance_ref(iref,ipnt), diff(iref,ipnt))
75 : end block
76 : ! D2_XX
77 : block
78 : integer(IK) :: iref
79 : iref = 1_IK
80 7065 : distance(iref,:) = getDisEuclid(point(:,:), method(imethod)%val)
81 7065 : diff(iref,:) = abs(distance(iref,:) - distance_ref(iref,:))
82 7065 : assertion = assertion .and. all(diff(iref,:) < EPS)
83 582 : call report(__LINE__, mnames(imethod)%val, point(:,:), ref(:,iref), distance(iref,:), distance_ref(iref,:), diff(iref,:))
84 : end block
85 : else
86 : ! D1_D1
87 : block
88 : integer(IK) :: ipnt, iref
89 : ipnt = 1_IK; iref = 1_IK
90 618 : distance(iref,ipnt) = getDisEuclid(point(:,ipnt), ref(:,iref), method(imethod)%val)
91 618 : diff(iref,ipnt) = abs(distance(iref,ipnt) - distance_ref(iref,ipnt))
92 618 : assertion = assertion .and. diff(iref,ipnt) < EPS
93 618 : call report(__LINE__, mnames(imethod)%val, point(:,ipnt), ref(:,iref), distance(iref,ipnt), distance_ref(iref,ipnt), diff(iref,ipnt))
94 : end block
95 : ! D1_D2
96 : block
97 : integer(IK), allocatable :: ipnt
98 : ipnt = 1_IK
99 7008 : distance(:,ipnt) = getDisEuclid(point(:,ipnt), ref(:,:), method(imethod)%val)
100 7008 : diff(:,ipnt) = abs(distance(:,ipnt) - distance_ref(:,ipnt))
101 7008 : assertion = assertion .and. all(diff(:,ipnt) < EPS)
102 618 : call report(__LINE__, mnames(imethod)%val, point(:,ipnt), ref(:,:), distance(:,ipnt), distance_ref(:,ipnt), diff(:,ipnt))
103 : end block
104 : ! D2_D1
105 : block
106 : integer(IK) :: iref
107 : iref = 1_IK
108 7071 : distance(iref,:) = getDisEuclid(point(:,:), ref(:,iref), method(imethod)%val)
109 7071 : diff(iref,:) = abs(distance(iref,:) - distance_ref(iref,:))
110 7071 : assertion = assertion .and. all(diff(iref,:) < EPS)
111 618 : call report(__LINE__, mnames(imethod)%val, point(:,:), ref(:,iref), distance(iref,:), distance_ref(iref,:), diff(iref,:))
112 : end block
113 : ! D2_D2
114 : block
115 73545 : distance(:,:) = getDisEuclid(point(:,:), ref(:,:), method(imethod)%val)
116 73545 : diff(:,:) = abs(distance(:,:) - distance_ref(:,:))
117 73545 : assertion = assertion .and. all(diff(:,:) < EPS)
118 618 : call report(__LINE__, mnames(imethod)%val, point(:,:), ref(:,:), distance(:,:), distance_ref(:,:), diff(:,:))
119 : end block
120 : end if
121 : #elif setDisEuclid_ENABLED
122 1600 : if (isorigin) then
123 : ! D1_XX
124 : block
125 : integer(IK) :: ipnt, iref
126 : ipnt = 1_IK; iref = 1_IK
127 630 : if (same_type_as(method(imethod)%val, euclid)) then
128 210 : call setDisEuclid(distance(iref,ipnt), point(:,ipnt), euclid)
129 420 : elseif (same_type_as(method(imethod)%val, euclidu)) then
130 210 : call setDisEuclid(distance(iref,ipnt), point(:,ipnt), euclidu)
131 210 : elseif (same_type_as(method(imethod)%val, euclidsq)) then
132 210 : call setDisEuclid(distance(iref,ipnt), point(:,ipnt), euclidsq)
133 : else
134 : error stop "@test_pm_distanceEuclid@test_setDisEuclid(): Internal library error occurred. Unrecognized `method`." ! LCOV_EXCL_LINE
135 : end if
136 630 : diff(iref,ipnt) = abs(distance(iref,ipnt) - distance_ref(iref,ipnt))
137 630 : assertion = assertion .and. diff(iref,ipnt) < EPS
138 630 : call report(__LINE__, mnames(imethod)%val, point(:,ipnt), ref(:,iref), distance(iref,ipnt), distance_ref(iref,ipnt), diff(iref,ipnt))
139 : end block
140 : ! D2_XX
141 : block
142 : integer(IK) :: iref
143 : iref = 1_IK
144 630 : if (same_type_as(method(imethod)%val, euclid)) then
145 2363 : call setDisEuclid(distance(iref,:), point(:,:), euclid)
146 420 : elseif (same_type_as(method(imethod)%val, euclidu)) then
147 2363 : call setDisEuclid(distance(iref,:), point(:,:), euclidu)
148 210 : elseif (same_type_as(method(imethod)%val, euclidsq)) then
149 2363 : call setDisEuclid(distance(iref,:), point(:,:), euclidsq)
150 : else
151 : error stop "@test_pm_distanceEuclid@test_setDisEuclid(): Internal library error occurred. Unrecognized `method`." ! LCOV_EXCL_LINE
152 : end if
153 7089 : diff(iref,:) = abs(distance(iref,:) - distance_ref(iref,:))
154 7089 : assertion = assertion .and. all(diff(iref,:) < EPS)
155 630 : call report(__LINE__, mnames(imethod)%val, point(:,:), ref(:,iref), distance(iref,:), distance_ref(iref,:), diff(iref,:))
156 : end block
157 : else
158 : ! D1_D1
159 : block
160 : integer(IK) :: ipnt, iref
161 : ipnt = 1_IK; iref = 1_IK
162 570 : if (same_type_as(method(imethod)%val, euclid)) then
163 190 : call setDisEuclid(distance(iref,ipnt), point(:,ipnt), ref(:,iref), euclid)
164 380 : elseif (same_type_as(method(imethod)%val, euclidu)) then
165 190 : call setDisEuclid(distance(iref,ipnt), point(:,ipnt), ref(:,iref), euclidu)
166 190 : elseif (same_type_as(method(imethod)%val, euclidsq)) then
167 190 : call setDisEuclid(distance(iref,ipnt), point(:,ipnt), ref(:,iref), euclidsq)
168 : else
169 : error stop "@test_pm_distanceEuclid@test_setDisEuclid(): Internal library error occurred. Unrecognized `method`." ! LCOV_EXCL_LINE
170 : end if
171 570 : diff(iref,ipnt) = abs(distance(iref,ipnt) - distance_ref(iref,ipnt))
172 570 : assertion = assertion .and. diff(iref,ipnt) < EPS
173 570 : call report(__LINE__, mnames(imethod)%val, point(:,ipnt), ref(:,iref), distance(iref,ipnt), distance_ref(iref,ipnt), diff(iref,ipnt))
174 : end block
175 : ! D1_D2
176 : block
177 : integer(IK), allocatable :: ipnt
178 570 : ipnt = 1_IK
179 570 : if (same_type_as(method(imethod)%val, euclid)) then
180 190 : call setDisEuclid(distance(:,ipnt), point(:,ipnt), ref(:,:), euclid)
181 380 : elseif (same_type_as(method(imethod)%val, euclidu)) then
182 190 : call setDisEuclid(distance(:,ipnt), point(:,ipnt), ref(:,:), euclidu)
183 190 : elseif (same_type_as(method(imethod)%val, euclidsq)) then
184 190 : call setDisEuclid(distance(:,ipnt), point(:,ipnt), ref(:,:), euclidsq)
185 : else
186 : error stop "@test_pm_distanceEuclid@test_setDisEuclid(): Internal library error occurred. Unrecognized `method`." ! LCOV_EXCL_LINE
187 : end if
188 6825 : diff(:,ipnt) = abs(distance(:,ipnt) - distance_ref(:,ipnt))
189 6825 : assertion = assertion .and. all(diff(:,ipnt) < EPS)
190 570 : call report(__LINE__, mnames(imethod)%val, point(:,ipnt), ref(:,:), distance(:,ipnt), distance_ref(:,ipnt), diff(:,ipnt))
191 : end block
192 : ! D2_D1
193 : block
194 : integer(IK) :: iref
195 : iref = 1_IK
196 570 : if (same_type_as(method(imethod)%val, euclid)) then
197 2208 : call setDisEuclid(distance(iref,:), point(:,:), ref(:,iref), euclid)
198 380 : elseif (same_type_as(method(imethod)%val, euclidu)) then
199 2208 : call setDisEuclid(distance(iref,:), point(:,:), ref(:,iref), euclidu)
200 190 : elseif (same_type_as(method(imethod)%val, euclidsq)) then
201 2208 : call setDisEuclid(distance(iref,:), point(:,:), ref(:,iref), euclidsq)
202 : else
203 : error stop "@test_pm_distanceEuclid@test_setDisEuclid(): Internal library error occurred. Unrecognized `method`." ! LCOV_EXCL_LINE
204 : end if
205 6624 : diff(iref,:) = abs(distance(iref,:) - distance_ref(iref,:))
206 6624 : assertion = assertion .and. all(diff(iref,:) < EPS)
207 570 : call report(__LINE__, mnames(imethod)%val, point(:,:), ref(:,iref), distance(iref,:), distance_ref(iref,:), diff(iref,:))
208 : end block
209 : ! D2_D2
210 : block
211 570 : if (same_type_as(method(imethod)%val, euclid)) then
212 190 : call setDisEuclid(distance(:,:), point(:,:), ref(:,:), euclid)
213 380 : elseif (same_type_as(method(imethod)%val, euclidu)) then
214 190 : call setDisEuclid(distance(:,:), point(:,:), ref(:,:), euclidu)
215 190 : elseif (same_type_as(method(imethod)%val, euclidsq)) then
216 190 : call setDisEuclid(distance(:,:), point(:,:), ref(:,:), euclidsq)
217 : else
218 : error stop "@test_pm_distanceEuclid@test_setDisEuclid(): Internal library error occurred. Unrecognized `method`." ! LCOV_EXCL_LINE
219 : end if
220 73344 : diff(:,:) = abs(distance(:,:) - distance_ref(:,:))
221 73344 : assertion = assertion .and. all(diff(:,:) < EPS)
222 570 : call report(__LINE__, mnames(imethod)%val, point(:,:), ref(:,:), distance(:,:), distance_ref(:,:), diff(:,:))
223 : end block
224 : end if
225 : #endif
226 : end do
227 :
228 : end do
229 :
230 : contains
231 :
232 2400 : pure function getDisEuclid_ref(point, ref, method) result(distance_ref)
233 : real(TKC), intent(in), contiguous :: point(:,:), ref(:,:)
234 : class(*), intent(in) :: method
235 : real(TKC) :: distance_ref(size(ref, 2, IK), size(point, 2, IK))
236 : integer(IK) :: ndim, npnt, nref
237 : integer(IK) :: ipnt, iref
238 2400 : ndim = size(point, 1, IK)
239 : npnt = size(point, 2, IK)
240 : nref = size(ref, 2, IK)
241 27849 : do ipnt = 1, npnt
242 297993 : do iref = 1, nref
243 1787214 : distance_ref(iref, ipnt) = sum((point(1:ndim, ipnt) - ref(1:ndim, iref))**2)
244 : end do
245 : end do
246 2400 : if (same_type_as(method, euclidsq)) return
247 198662 : distance_ref = sqrt(distance_ref)
248 : end function
249 :
250 7176 : subroutine report(line, method, point, ref, distance, distance_ref, diff)
251 : real(TKC), intent(in) :: point(..), ref(..), distance(..), distance_ref(..), diff(..)
252 : integer, intent(in) :: line
253 : character(*, SK) :: method
254 7176 : if (test%traceable .and. .not. assertion) then
255 : ! LCOV_EXCL_START
256 : call test%disp%skip()
257 : call test%disp%show("[rank(point), rank(ref), rank(diff)]")
258 : call test%disp%show( [rank(point), rank(ref), rank(diff)] )
259 : call test%disp%show("[ndim, npnt, nref]")
260 : call test%disp%show( [ndim, npnt, nref] )
261 : call test%disp%show("method")
262 : call test%disp%show( method )
263 : call display(point, "point")
264 : call display(ref, "ref")
265 : call display(distance_ref, "distance_ref")
266 : call display(distance, "distance")
267 : call display(diff, "diff")
268 : call test%disp%skip()
269 : ! LCOV_EXCL_STOP
270 : end if
271 7176 : call test%assert(assertion, SK_"The procedure setDisEuclid() must correctly correctly compute the distance.", int(line, IK))
272 7176 : end subroutine
273 :
274 : ! LCOV_EXCL_START
275 : subroutine display(object, name)
276 : real(TKC), intent(in) :: object(..)
277 : character(*, SK), intent(in) :: name
278 : select rank(object)
279 : rank(0)
280 : call test%disp%show(name)
281 : call test%disp%show(object)
282 : rank(1)
283 : call test%disp%show(name)
284 : call test%disp%show(object)
285 : rank(2)
286 : call test%disp%show(name)
287 : call test%disp%show(object)
288 : rank(*)
289 : error stop "Unrecognized rank for `object`."
290 : end select
291 : end subroutine
292 : ! LCOV_EXCL_STOP
293 :
294 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
295 : #elif getDisMatEuclid_ENABLED || setDisMatEuclid_ENABLED
296 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
297 :
298 : integer(IK), parameter :: ntry = 100
299 : real(TKC), parameter :: EPS = epsilon(0._TKC) * 100
300 : real(TKC), allocatable :: distance(:,:), distance_ref(:,:), point(:,:), diff(:,:)
301 8 : type(csp_type), allocatable :: method(:), subset(:), pack(:)
302 8 : type(css_type), allocatable :: mnames(:), snames(:), pnames(:)
303 : integer(IK) :: itry, ipack, isubset, imethod
304 : integer(IK) :: ndim, npnt
305 :
306 8 : assertion = .true._LK
307 :
308 48 : pack = [csp_type(rdpack)]
309 32 : pnames = [css_type("rdpack")]
310 :
311 64 : subset = [csp_type(uppLow), csp_type(uppLowDia)]
312 48 : snames = [css_type("uppLow"), css_type("uppLowDia")]
313 :
314 88 : method = [csp_type(euclid), csp_type(euclidu), csp_type(euclidsq)]
315 64 : mnames = [css_type("euclid"), css_type("euclidu"), css_type("euclidsq")]
316 :
317 912 : do itry = 1, ntry
318 :
319 800 : ndim = getUnifRand(1_IK, 10_IK)
320 800 : npnt = getUnifRand(1_IK, 20_IK)
321 57002 : point = getUnifRand(-1._TKC, 1._TKC, ndim, npnt)
322 1608 : do ipack = 1, size(pack)
323 3200 : do isubset = 1, size(subset)
324 7200 : do imethod = 1, size(method)
325 736761 : distance_ref = getDisMatEuclid_ref(point, pack(ipack)%val, subset(isubset)%val, method(imethod)%val)
326 : #if getDisMatEuclid_ENABLED
327 800 : block
328 2400 : if (same_type_as(pack(ipack)%val, rdpack)) then
329 2400 : if (same_type_as(subset(isubset)%val, uppLowDia)) then
330 389136 : distance = getDisMatEuclid(rdpack, uppLowDia, point, method(imethod)%val)
331 1200 : elseif (same_type_as(subset(isubset)%val, uppLow)) then
332 363180 : distance = getDisMatEuclid(rdpack, uppLow, point, method(imethod)%val)
333 : else
334 : error stop "Unrecognized `pack` value." ! LCOV_EXCL_LINE
335 : end if
336 : else
337 : error stop "Unrecognized `pack` value." ! LCOV_EXCL_LINE
338 : end if
339 378558 : diff = abs(distance - distance_ref)
340 376158 : assertion = assertion .and. all(diff < EPS)
341 2400 : call report(__LINE__, pnames(ipack)%val, snames(isubset)%val, mnames(imethod)%val, point, distance, distance_ref, diff)
342 : end block
343 : #elif setDisMatEuclid_ENABLED
344 800 : block
345 2400 : if (same_type_as(pack(ipack)%val, rdpack)) then
346 2400 : if (same_type_as(subset(isubset)%val, uppLowDia)) then
347 3600 : call setResized(distance, [npnt, npnt])
348 1200 : if (same_type_as(method(imethod)%val, euclid)) then
349 400 : call setDisMatEuclid(distance, rdpack, uppLowDia, point, euclid)
350 800 : elseif (same_type_as(method(imethod)%val, euclidu)) then
351 400 : call setDisMatEuclid(distance, rdpack, uppLowDia, point, euclidu)
352 400 : elseif (same_type_as(method(imethod)%val, euclidsq)) then
353 400 : call setDisMatEuclid(distance, rdpack, uppLowDia, point, euclidsq)
354 : else
355 : error stop "Unrecognized `method` value." ! LCOV_EXCL_LINE
356 : end if
357 1200 : elseif (same_type_as(subset(isubset)%val, uppLow)) then
358 3600 : call setResized(distance, [npnt - 1, npnt])
359 1200 : if (same_type_as(method(imethod)%val, euclid)) then
360 400 : call setDisMatEuclid(distance, rdpack, uppLow, point, euclid)
361 800 : elseif (same_type_as(method(imethod)%val, euclidu)) then
362 400 : call setDisMatEuclid(distance, rdpack, uppLow, point, euclidu)
363 400 : elseif (same_type_as(method(imethod)%val, euclidsq)) then
364 400 : call setDisMatEuclid(distance, rdpack, uppLow, point, euclidsq)
365 : else
366 : error stop "Unrecognized `method` value." ! LCOV_EXCL_LINE
367 : end if
368 : else
369 : error stop "Unrecognized `pack` value." ! LCOV_EXCL_LINE
370 : end if
371 : else
372 : error stop "Unrecognized `pack` value." ! LCOV_EXCL_LINE
373 : end if
374 358203 : diff = abs(distance - distance_ref)
375 355803 : assertion = assertion .and. all(diff < EPS)
376 2400 : call report(__LINE__, pnames(ipack)%val, snames(isubset)%val, mnames(imethod)%val, point, distance, distance_ref, diff)
377 : end block
378 : #endif
379 : end do
380 : end do
381 : end do
382 :
383 : end do
384 :
385 : contains
386 :
387 4800 : function getDisMatEuclid_ref(point, pack, subset, method) result(distance_ref)
388 : ! \bug
389 : ! Intel ifort 2021 passes incorrect size of [0, 0] for distance inside setDisEuclid, call from within getDisEuclid(), called below.
390 : ! This apparently happens if the contiguous attribute of the `point` argument is missing.
391 : real(TKC), intent(in), contiguous :: point(:,:)
392 : class(*), intent(in) :: pack, subset, method
393 : real(TKC), allocatable :: distance_ref(:,:)
394 : integer(IK) :: ndim, npnt, ipnt
395 : ndim = size(point, 1, IK)
396 4800 : npnt = size(point, 2, IK)
397 : select type(subset)
398 : type is (uppLowDia_type)
399 2400 : if (same_type_as(pack, rdpack)) then
400 7200 : call setResized(distance_ref, [npnt, npnt])
401 381216 : distance_ref = getDisEuclid(point, point, method)
402 : else
403 : error stop "Unrecognized `pack` value." ! LCOV_EXCL_LINE
404 : end if
405 : type is (uppLow_type)
406 7200 : call setResized(distance_ref, [npnt - 1, npnt])
407 2400 : if (same_type_as(pack, rdpack)) then
408 25671 : do ipnt = 1, npnt - 1
409 : ! \bug
410 : ! Intel ifort 2024 and older pass a zero length for distance that could not be resolved in any way.
411 : ! For now, setDisEuclid() is used as a substitute.
412 : !distance_ref(ipnt : npnt - 1, ipnt) = getDisEuclid(point(:, ipnt), point(:, ipnt + 1 : npnt), method)
413 23271 : if (same_type_as(method, euclid)) then
414 7757 : call setDisEuclid(distance_ref(ipnt : npnt - 1, ipnt), point(:, ipnt), point(:, ipnt + 1 : npnt), euclid)
415 15514 : elseif (same_type_as(method, euclidu)) then
416 7757 : call setDisEuclid(distance_ref(ipnt : npnt - 1, ipnt), point(:, ipnt), point(:, ipnt + 1 : npnt), euclidu)
417 7757 : elseif (same_type_as(method, euclidsq)) then
418 7757 : call setDisEuclid(distance_ref(ipnt : npnt - 1, ipnt), point(:, ipnt), point(:, ipnt + 1 : npnt), euclidsq)
419 : end if
420 188208 : distance_ref(ipnt, ipnt + 1 : npnt) = distance_ref(ipnt : npnt - 1, ipnt)
421 : end do
422 : else
423 : error stop "Unrecognized `pack` value." ! LCOV_EXCL_LINE
424 : end if
425 : class default
426 : error stop "Unrecognized `subset` value." ! LCOV_EXCL_LINE
427 : end select
428 4800 : end function
429 :
430 4800 : subroutine report(line, pack, subset, method, point, distance, distance_ref, diff)
431 : real(TKC), intent(in) :: point(..), distance(..), distance_ref(..), diff(..)
432 : integer, intent(in) :: line
433 : character(*, SK) :: pack, subset, method
434 4800 : if (test%traceable .and. .not. assertion) then
435 : ! LCOV_EXCL_START
436 : call test%disp%skip()
437 : call test%disp%show("[ndim, npnt]")
438 : call test%disp%show( [ndim, npnt] )
439 : call test%disp%show("pack")
440 : call test%disp%show( pack )
441 : call test%disp%show("subset")
442 : call test%disp%show( subset )
443 : call test%disp%show("method")
444 : call test%disp%show( method )
445 : call display(point, "point")
446 : call display(distance_ref, "distance_ref")
447 : call display(distance, "distance")
448 : call display(diff, "diff")
449 : call test%disp%skip()
450 : ! LCOV_EXCL_STOP
451 : end if
452 4800 : call test%assert(assertion, SK_"The procedure setDisMatEuclid() must correctly correctly compute the distance.", int(line, IK))
453 4800 : end subroutine
454 :
455 : ! LCOV_EXCL_START
456 : subroutine display(object, name)
457 : real(TKC), intent(in) :: object(..)
458 : character(*, SK), intent(in) :: name
459 : call test%disp%show(SK_"shape("//name//SK_")")
460 : call test%disp%show(shape(object))
461 : select rank(object)
462 : rank(0)
463 : call test%disp%show(name)
464 : call test%disp%show(object)
465 : rank(1)
466 : call test%disp%show(name)
467 : call test%disp%show(object)
468 : rank(2)
469 : call test%disp%show(name)
470 : call test%disp%show(object)
471 : rank(*)
472 : error stop "Unrecognized rank for `object`."
473 : end select
474 : end subroutine
475 : ! LCOV_EXCL_STOP
476 :
477 : #else
478 : !%%%%%%%%%%%%%%%%%%%%%%%%
479 : #error "Unrecognized interface."
480 : !%%%%%%%%%%%%%%%%%%%%%%%%
481 : #endif
|
