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
18 : !> This include file contains procedure implementations of [pm_arrayCompact](@ref pm_arrayCompact).
19 : !>
20 : !> \finmain
21 : !>
22 : !> \author
23 : !> \AmirShahmoradi, Saturday 1:48 AM, August 20, 2016, Institute for Computational Engineering and Sciences, UT Austin, TX
24 :
25 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
26 :
27 : ! Define logical comparison.
28 : #if LK_ENABLED
29 : #define IS_NEQ(a,b) a .neqv. b
30 : #elif SK_ENABLED || IK_ENABLED || CK_ENABLED || RK_ENABLED
31 : #define IS_NEQ(a,b) a /= b
32 : #else
33 : #error "Unrecognized interface."
34 : #endif
35 : ! Define array indexing rule.
36 : #if SK_ENABLED && D0_ENABLED
37 : #define GET_INDEX(i) i:i
38 : #define GET_SIZE len
39 : #elif D1_ENABLED || D2_ENABLED
40 : #define GET_INDEX(i) i
41 : #define GET_SIZE size
42 : #else
43 : #error "Unrecognized interface."
44 : #endif
45 : integer(IK) :: ip
46 : #if D2_ENABLED
47 : integer(IK) :: nd, np
48 : #endif
49 : #if getCompact_ENABLED
50 : #define EVALUATE(THIS)
51 : #define ARRAY compact
52 : integer(IK) :: csize
53 : #if SK_ENABLED && D0_ENABLED
54 3 : allocate(character(len(array,IK),SKC) :: compact)
55 : #else
56 273 : allocate(compact, mold = array)
57 : #endif
58 : #elif setCompact_ENABLED
59 : #define EVALUATE(THIS) THIS
60 : #else
61 : #error "Unrecognized interface."
62 : #endif
63 254 : if (GET_SIZE(array, kind = IK) == 0_IK) then
64 : #if setCompact_ENABLED
65 19 : csize = 0_IK
66 : #elif !getCompact_ENABLED
67 : #error "Unrecognized interface."
68 : #endif
69 77 : return
70 : end if
71 : !%%%%%%%%%%%%%%%%%%%%%%%
72 : #if D0_ENABLED || D1_ENABLED
73 : !%%%%%%%%%%%%%%%%%%%%%%%
74 26 : csize = 1_IK
75 : #if getCompact_ENABLED
76 26 : ARRAY(GET_INDEX(1)) = array(GET_INDEX(1)) ! fpp
77 : #elif setCompact_ENABLED
78 78 : CHECK_ASSERTION(__LINE__, size(weight, kind = IK) == GET_SIZE(array, kind = IK), \
79 : SK_"The size of `weight` must equal the size of `array`. size(array), size(weight) = "\
80 : //getStr([GET_SIZE(array, kind = IK), size(weight, kind = IK)])) ! fpp
81 26 : weight(csize) = 1_IK
82 : #else
83 : #error "Unrecognized interface."
84 : #endif
85 1897 : do ip = 2_IK, GET_SIZE(array, kind = IK) ! fpp
86 1897 : if (IS_NEQ(array(GET_INDEX(ip-1_IK)), array(GET_INDEX(ip)))) then ! fpp
87 328 : csize = csize + 1_IK
88 164 : EVALUATE(weight(csize) = 1_IK) ! fpp
89 328 : EVALUATE(if (csize /= ip)) ARRAY(GET_INDEX(csize)) = array(GET_INDEX(ip)) ! fpp
90 : else
91 717 : EVALUATE(weight(csize) = weight(csize) + 1_IK)
92 : end if
93 : end do
94 : #if getCompact_ENABLED
95 402 : ARRAY = ARRAY(1:csize) ! fpp
96 : #endif
97 : !%%%%%%%%%
98 : #elif D2_ENABLED
99 : !%%%%%%%%%
100 86 : CHECK_ASSERTION(__LINE__, dim == 1_IK .or. dim == 2_IK, \
101 : SK_"The input `dim` must be either 1 or 2. dim = "//getStr(dim)) ! fpp
102 : #if setCompact_ENABLED
103 172 : CHECK_ASSERTION(__LINE__, size(weight, kind = IK) == size(array, dim, IK), \
104 : SK_"The size of `weight` must equal the size of `array` along dimension `dim`. dim, size(array, dim), size(weight) = "\
105 : //getStr([dim, size(array, dim, IK), size(weight, 1, IK)])) ! fpp
106 : #endif
107 86 : np = size(array, dim, IK)
108 86 : if (dim == 2_IK) then
109 48 : nd = size(array, 1_IK, IK)
110 24 : csize = 1_IK
111 : #if getCompact_ENABLED
112 91 : ARRAY(1:nd,GET_INDEX(1)) = array(1:nd,GET_INDEX(1)) ! fpp
113 : #endif
114 24 : EVALUATE(weight(csize) = 1_IK)
115 308 : do ip = 2_IK, np
116 710 : if (any(IS_NEQ(array(1:nd,ip-1), array(1:nd,ip)))) then ! fpp
117 116 : csize = csize + 1_IK
118 58 : EVALUATE(weight(csize) = 1_IK) ! fpp
119 424 : EVALUATE(if (csize /= ip)) ARRAY(1:nd,csize) = array(1:nd,ip) ! fpp
120 : else
121 72 : EVALUATE(weight(csize) = weight(csize) + 1_IK) ! fpp
122 : end if
123 : end do
124 : #if getCompact_ENABLED
125 656 : ARRAY = ARRAY(1:nd,1:csize) ! fpp
126 : #endif
127 38 : elseif (dim == 1_IK) then
128 38 : nd = size(array, dim = 2_IK, kind = IK)
129 19 : csize = 1_IK
130 : #if getCompact_ENABLED
131 76 : ARRAY(GET_INDEX(1),1:nd) = array(GET_INDEX(1),1:nd) ! fpp
132 : #endif
133 19 : EVALUATE(weight(csize) = 1_IK) ! fpp
134 228 : do ip = 2_IK, np
135 570 : if (any(IS_NEQ(array(ip-1,1:nd), array(ip,1:nd)))) then ! fpp
136 76 : csize = csize + 1_IK
137 38 : EVALUATE(weight(csize) = 1_IK) ! fpp
138 304 : EVALUATE(if (csize /= ip)) ARRAY(csize,1:nd) = array(ip,1:nd) ! fpp
139 : else
140 57 : EVALUATE(weight(csize) = weight(csize) + 1_IK) ! fpp
141 : end if
142 : end do
143 : #if getCompact_ENABLED
144 495 : ARRAY = ARRAY(1:csize,1:nd) ! fpp
145 : #endif
146 : end if
147 : #else
148 : !%%%%%%%%%%%%%%%%%%%%%%%%
149 : #error "Unrecognized interface."
150 : !%%%%%%%%%%%%%%%%%%%%%%%%
151 : #endif
152 :
153 : #undef CHECK_SUM_WEIGHT
154 : #undef GET_INDEX
155 : #undef GET_SIZE
156 : #undef EVALUATE
157 : #undef IS_NEQ
158 : #undef ARRAY
|
