1 /*
2 * Copyright (c) 1996-2019, NVIDIA CORPORATION. All rights reserved.
3 *
4 * Licensed under the Apache License, Version 2.0 (the "License");
5 * you may not use this file except in compliance with the License.
6 * You may obtain a copy of the License at
7 *
8 * http://www.apache.org/licenses/LICENSE-2.0
9 *
10 * Unless required by applicable law or agreed to in writing, software
11 * distributed under the License is distributed on an "AS IS" BASIS,
12 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
13 * See the License for the specific language governing permissions and
14 * limitations under the License.
15 *
16 */
17
18 /* clang-format off */
19
20 /* red_maxloc.c -- intrinsic reduction function */
21
22 #include "stdioInterf.h"
23 #include "fioMacros.h"
24 #include "red.h"
25
26 MLOCFNLKN(>, maxloc_int1, __INT1_T, 1)
27 MLOCFNLKN(>, maxloc_int2, __INT2_T, 1)
28 MLOCFNLKN(>, maxloc_int4, __INT4_T, 1)
29 MLOCFNLKN(>, maxloc_int8, __INT8_T, 1)
30 MLOCFNLKN(>, maxloc_real4, __REAL4_T, 1)
31 MLOCFNLKN(>, maxloc_real8, __REAL8_T, 1)
32 MLOCFNLKN(>, maxloc_real16, __REAL16_T, 1)
33 MLOCSTRFNLKN(>, maxloc_str, __STR_T, 1)
34
35 MLOCFNLKN(>, maxloc_int1, __INT1_T, 2)
36 MLOCFNLKN(>, maxloc_int2, __INT2_T, 2)
37 MLOCFNLKN(>, maxloc_int4, __INT4_T, 2)
38 MLOCFNLKN(>, maxloc_int8, __INT8_T, 2)
39 MLOCFNLKN(>, maxloc_real4, __REAL4_T, 2)
40 MLOCFNLKN(>, maxloc_real8, __REAL8_T, 2)
41 MLOCFNLKN(>, maxloc_real16, __REAL16_T, 2)
42 MLOCSTRFNLKN(>, maxloc_str, __STR_T, 2)
43
44 MLOCFNLKN(>, maxloc_int1, __INT1_T, 4)
45 MLOCFNLKN(>, maxloc_int2, __INT2_T, 4)
46 MLOCFNLKN(>, maxloc_int4, __INT4_T, 4)
47 MLOCFNLKN(>, maxloc_int8, __INT8_T, 4)
48 MLOCFNLKN(>, maxloc_real4, __REAL4_T, 4)
49 MLOCFNLKN(>, maxloc_real8, __REAL8_T, 4)
50 MLOCFNLKN(>, maxloc_real16, __REAL16_T, 4)
51 MLOCSTRFNLKN(>, maxloc_str, __STR_T, 4)
52
53 MLOCFNLKN(>, maxloc_int1, __INT1_T, 8)
54 MLOCFNLKN(>, maxloc_int2, __INT2_T, 8)
55 MLOCFNLKN(>, maxloc_int4, __INT4_T, 8)
56 MLOCFNLKN(>, maxloc_int8, __INT8_T, 8)
57 MLOCFNLKN(>, maxloc_real4, __REAL4_T, 8)
58 MLOCFNLKN(>, maxloc_real8, __REAL8_T, 8)
59 MLOCFNLKN(>, maxloc_real16, __REAL16_T, 8)
60 MLOCSTRFNLKN(>, maxloc_str, __STR_T, 8)
61
62 MLOCFNG(>, maxloc_int1, __INT1_T)
63 MLOCFNG(>, maxloc_int2, __INT2_T)
64 MLOCFNG(>, maxloc_int4, __INT4_T)
65 MLOCFNG(>, maxloc_int8, __INT8_T)
66 MLOCFNG(>, maxloc_real4, __REAL4_T)
67 MLOCFNG(>, maxloc_real8, __REAL8_T)
68 MLOCFNG(>, maxloc_real16, __REAL16_T)
69 MLOCSTRFNG(>, maxloc_str, __STR_T)
70
71 static void (*l_maxloc_b[4][__NTYPES])() = TYPELIST3LK(l_maxloc_);
72 static void (*g_maxloc[__NTYPES])() = TYPELIST3(g_maxloc_);
73
74 KMLOCFNLKN(>, kmaxloc_int1, __INT1_T, 1)
75 KMLOCFNLKN(>, kmaxloc_int2, __INT2_T, 1)
76 KMLOCFNLKN(>, kmaxloc_int4, __INT4_T, 1)
77 KMLOCFNLKN(>, kmaxloc_int8, __INT8_T, 1)
78 KMLOCFNLKN(>, kmaxloc_real4, __REAL4_T, 1)
79 KMLOCFNLKN(>, kmaxloc_real8, __REAL8_T, 1)
80 KMLOCFNLKN(>, kmaxloc_real16, __REAL16_T, 1)
81 KMLOCSTRFNLKN(>, kmaxloc_str, __STR_T, 1)
82
83 KMLOCFNLKN(>, kmaxloc_int1, __INT1_T, 2)
84 KMLOCFNLKN(>, kmaxloc_int2, __INT2_T, 2)
85 KMLOCFNLKN(>, kmaxloc_int4, __INT4_T, 2)
86 KMLOCFNLKN(>, kmaxloc_int8, __INT8_T, 2)
87 KMLOCFNLKN(>, kmaxloc_real4, __REAL4_T, 2)
88 KMLOCFNLKN(>, kmaxloc_real8, __REAL8_T, 2)
89 KMLOCFNLKN(>, kmaxloc_real16, __REAL16_T, 2)
90 KMLOCSTRFNLKN(>, kmaxloc_str, __STR_T, 2)
91
92 KMLOCFNLKN(>, kmaxloc_int1, __INT1_T, 4)
93 KMLOCFNLKN(>, kmaxloc_int2, __INT2_T, 4)
94 KMLOCFNLKN(>, kmaxloc_int4, __INT4_T, 4)
95 KMLOCFNLKN(>, kmaxloc_int8, __INT8_T, 4)
96 KMLOCFNLKN(>, kmaxloc_real4, __REAL4_T, 4)
97 KMLOCFNLKN(>, kmaxloc_real8, __REAL8_T, 4)
98 KMLOCFNLKN(>, kmaxloc_real16, __REAL16_T, 4)
99 KMLOCSTRFNLKN(>, kmaxloc_str, __STR_T, 4)
100
101 KMLOCFNLKN(>, kmaxloc_int1, __INT1_T, 8)
102 KMLOCFNLKN(>, kmaxloc_int2, __INT2_T, 8)
103 KMLOCFNLKN(>, kmaxloc_int4, __INT4_T, 8)
104 KMLOCFNLKN(>, kmaxloc_int8, __INT8_T, 8)
105 KMLOCFNLKN(>, kmaxloc_real4, __REAL4_T, 8)
106 KMLOCFNLKN(>, kmaxloc_real8, __REAL8_T, 8)
107 KMLOCFNLKN(>, kmaxloc_real16, __REAL16_T, 8)
108 KMLOCSTRFNLKN(>, kmaxloc_str, __STR_T, 8)
109
110 KMLOCFNG(>, kmaxloc_int1, __INT1_T)
111 KMLOCFNG(>, kmaxloc_int2, __INT2_T)
112 KMLOCFNG(>, kmaxloc_int4, __INT4_T)
113 KMLOCFNG(>, kmaxloc_int8, __INT8_T)
114 KMLOCFNG(>, kmaxloc_real4, __REAL4_T)
115 KMLOCFNG(>, kmaxloc_real8, __REAL8_T)
116 KMLOCFNG(>, kmaxloc_real16, __REAL16_T)
117 KMLOCSTRFNG(>, kmaxloc_str, __STR_T)
118
119 static void (*l_kmaxloc_b[4][__NTYPES])() = TYPELIST3LK(l_kmaxloc_);
120 static void (*g_kmaxloc[__NTYPES])() = TYPELIST3(g_kmaxloc_);
121
122 /* dim absent */
123 /* Shared code for MAXLOC with and without BACK for backward compatibility */
124 static void
maxlocs_common(red_parm * z,__INT_T * rb,char * ab,char * mb,F90_Desc * rs,F90_Desc * as,F90_Desc * ms)125 maxlocs_common(red_parm *z, __INT_T *rb, char *ab, char *mb, F90_Desc *rs,
126 F90_Desc *as, F90_Desc *ms)
127 {
128 double vb[4];
129 char *strvb;
130
131 __fort_red_what = "MAXLOC";
132 z->kind = F90_KIND_G(as);
133 z->len = F90_LEN_G(as);
134 z->mask_present = (F90_TAG_G(ms) == __DESC && F90_RANK_G(ms) > 0);
135 if (!z->mask_present) {
136 z->lk_shift = GET_DIST_SHIFTS(__LOG);
137 } else {
138 z->lk_shift = GET_DIST_SHIFTS(F90_KIND_G(ms));
139 }
140 z->l_fn_b = l_maxloc_b[z->lk_shift][z->kind];
141 z->g_fn = g_maxloc[z->kind];
142 z->zb = GET_DIST_MINS(z->kind);
143
144 if (z->kind == __STR) {
145 strvb = (char *)__fort_gmalloc(z->len);
146 memset(strvb, *((char *)z->zb), z->len);
147 I8(__fort_red_scalarlk)(z, strvb, ab, mb, rs, as, ms, rb, __MAXLOC);
148 __fort_gfree(strvb);
149 } else {
150 I8(__fort_red_scalarlk)(z, (char *)vb, ab, mb, rs, as, ms, rb, __MAXLOC);
151 }
152 }
153
154 /* MAXLOC without BACK */
ENTFTN(MAXLOCS,maxlocs)155 void ENTFTN(MAXLOCS, maxlocs)(__INT_T *rb, char *ab, char *mb, F90_Desc *rs,
156 F90_Desc *as, F90_Desc *ms)
157 {
158 red_parm z;
159
160 INIT_RED_PARM(z);
161
162 maxlocs_common(&z, rb, ab, mb, rs, as, ms);
163 }
164
165 /* MAXLOC with BACK */
ENTFTN(MAXLOCS_B,maxlocs_b)166 void ENTFTN(MAXLOCS_B, maxlocs_b)(__INT_T *rb, char *ab, char *mb,
167 __INT_T *back, F90_Desc *rs, F90_Desc *as,
168 F90_Desc *ms)
169 {
170 red_parm z;
171
172 INIT_RED_PARM(z);
173
174 z.back = *(__LOG_T *)back;
175 maxlocs_common(&z, rb, ab, mb, rs, as, ms);
176 }
177
178 /* dim present */
maxloc_common(red_parm * z,char * rb,char * ab,char * mb,char * db,F90_Desc * rs,F90_Desc * as,F90_Desc * ms,F90_Desc * ds)179 static void maxloc_common(red_parm *z, char *rb, char *ab, char *mb, char *db,
180 F90_Desc *rs, F90_Desc *as, F90_Desc *ms,
181 F90_Desc *ds)
182 {
183 __fort_red_what = "MAXLOC";
184 z->kind = F90_KIND_G(as);
185 z->len = F90_LEN_G(as);
186 z->mask_present = (F90_TAG_G(ms) == __DESC && F90_RANK_G(ms) > 0);
187 if (!z->mask_present) {
188 z->lk_shift = GET_DIST_SHIFTS(__LOG);
189 } else {
190 z->lk_shift = GET_DIST_SHIFTS(F90_KIND_G(ms));
191 }
192 z->l_fn_b = l_maxloc_b[z->lk_shift][z->kind];
193 z->g_fn = g_maxloc[z->kind];
194 z->zb = GET_DIST_MINS(z->kind);
195 if (z->kind == __STR)
196 memset(rb, *((char *)z->zb), z->len);
197 if (ISSCALAR(ms)) {
198 DECL_HDR_VARS(ms2);
199
200 mb = (char *)I8(__fort_create_conforming_mask_array)(__fort_red_what, ab, mb,
201 as, ms, ms2);
202 I8(__fort_red_array)(z, rb, ab, mb, db, rs, as, ms2, ds, __MAXLOC);
203 __fort_gfree(mb);
204 } else {
205 I8(__fort_red_arraylk)(z, rb, ab, mb, db, rs, as, ms, ds, __MAXLOC);
206 }
207 }
208
ENTFTN(MAXLOC,maxloc)209 void ENTFTN(MAXLOC, maxloc)(char *rb, char *ab, char *mb, char *db,
210 F90_Desc *rs, F90_Desc *as, F90_Desc *ms,
211 F90_Desc *ds)
212 {
213 red_parm z;
214
215 INIT_RED_PARM(z);
216 maxloc_common(&z, rb, ab, mb, db, rs, as, ms, ds);
217 }
218
ENTFTN(MAXLOC_B,maxloc_b)219 void ENTFTN(MAXLOC_B, maxloc_b)(char *rb, char *ab, char *mb, char *db,
220 __INT_T *back, F90_Desc *rs, F90_Desc *as,
221 F90_Desc *ms, F90_Desc *ds)
222 {
223 red_parm z;
224
225 INIT_RED_PARM(z);
226 z.back = *(__LOG_T *)back;
227 maxloc_common(&z, rb, ab, mb, db, rs, as, ms, ds);
228 }
229
230 /* dim absent */
kmaxlocs_common(red_parm * z,__INT8_T * rb,char * ab,char * mb,F90_Desc * rs,F90_Desc * as,F90_Desc * ms)231 static void kmaxlocs_common(red_parm *z, __INT8_T *rb, char *ab, char *mb,
232 F90_Desc *rs, F90_Desc *as, F90_Desc *ms)
233 {
234 double vb[4];
235 char *strvb;
236
237 z->kind = F90_KIND_G(as);
238 z->len = F90_LEN_G(as);
239 z->mask_present = (F90_TAG_G(ms) == __DESC && F90_RANK_G(ms) > 0);
240 if (!z->mask_present) {
241 z->lk_shift = GET_DIST_SHIFTS(__LOG);
242 } else {
243 z->lk_shift = GET_DIST_SHIFTS(F90_KIND_G(ms));
244 }
245 z->l_fn_b = l_kmaxloc_b[z->lk_shift][z->kind];
246 z->g_fn = g_kmaxloc[z->kind];
247 z->zb = GET_DIST_MINS(z->kind);
248
249 if (z->kind == __STR) {
250 strvb = (char *)__fort_gmalloc(z->len);
251 memset(strvb, *((char *)z->zb), z->len);
252 I8(__fort_kred_scalarlk)(z, strvb, ab, mb, rs, as, ms, rb, __MAXLOC);
253 __fort_gfree(strvb);
254 } else {
255 I8(__fort_kred_scalarlk)(z, (char *)vb, ab, mb, rs, as, ms, rb, __MAXLOC);
256 }
257 }
258
ENTFTN(KMAXLOCS,kmaxlocs)259 void ENTFTN(KMAXLOCS, kmaxlocs)(__INT8_T *rb, char *ab, char *mb, F90_Desc *rs,
260 F90_Desc *as, F90_Desc *ms)
261 {
262 red_parm z;
263
264 INIT_RED_PARM(z);
265 __fort_red_what = "MAXLOC";
266
267 kmaxlocs_common(&z, rb, ab, mb, rs, as, ms);
268 }
269
ENTFTN(KMAXLOCS_B,kmaxlocs_b)270 void ENTFTN(KMAXLOCS_B, kmaxlocs_b)(__INT8_T *rb, char *ab, char *mb,
271 __INT8_T *back, F90_Desc *rs, F90_Desc *as,
272 F90_Desc *ms)
273 {
274 red_parm z;
275
276 INIT_RED_PARM(z);
277 __fort_red_what = "MAXLOC";
278
279 z.back = *(__LOG_T *)back;
280 kmaxlocs_common(&z, rb, ab, mb, rs, as, ms);
281 }
282
283 /* dim present */
kmaxloc_common(red_parm * z,char * rb,char * ab,char * mb,char * db,F90_Desc * rs,F90_Desc * as,F90_Desc * ms,F90_Desc * ds)284 static void kmaxloc_common(red_parm *z, char *rb, char *ab, char *mb, char *db,
285 F90_Desc *rs, F90_Desc *as, F90_Desc *ms,
286 F90_Desc *ds)
287 {
288 __fort_red_what = "MAXLOC";
289
290 z->kind = F90_KIND_G(as);
291 z->len = F90_LEN_G(as);
292 z->mask_present = (F90_TAG_G(ms) == __DESC && F90_RANK_G(ms) > 0);
293 if (!z->mask_present) {
294 z->lk_shift = GET_DIST_SHIFTS(__LOG);
295 } else {
296 z->lk_shift = GET_DIST_SHIFTS(F90_KIND_G(ms));
297 }
298 z->l_fn_b = l_kmaxloc_b[z->lk_shift][z->kind];
299 z->g_fn = g_kmaxloc[z->kind];
300 z->zb = GET_DIST_MINS(z->kind);
301
302 if (z->kind == __STR)
303 memset(rb, *((char *)z->zb), z->len);
304 if (ISSCALAR(ms)) {
305 DECL_HDR_VARS(ms2);
306
307 mb = (char *)I8(__fort_create_conforming_mask_array)(__fort_red_what, ab, mb,
308 as, ms, ms2);
309 I8(__fort_red_array)(z, rb, ab, mb, db, rs, as, ms2, ds, __MAXLOC);
310 __fort_gfree(mb);
311 } else {
312 I8(__fort_kred_arraylk)(z, rb, ab, mb, db, rs, as, ms, ds, __MAXLOC);
313 }
314 }
315
ENTFTN(KMAXLOC,kmaxloc)316 void ENTFTN(KMAXLOC, kmaxloc)(char *rb, char *ab, char *mb, char *db,
317 F90_Desc *rs, F90_Desc *as, F90_Desc *ms,
318 F90_Desc *ds)
319 {
320 red_parm z;
321
322 INIT_RED_PARM(z);
323
324 kmaxloc_common(&z, rb, ab, mb, db, rs, as, ms, ds);
325 }
326
ENTFTN(KMAXLOC_B,kmaxloc_b)327 void ENTFTN(KMAXLOC_B, kmaxloc_b)(char *rb, char *ab, char *mb, char *db,
328 __INT8_T *back, F90_Desc *rs, F90_Desc *as,
329 F90_Desc *ms, F90_Desc *ds)
330 {
331 red_parm z;
332
333 INIT_RED_PARM(z);
334
335 z.back = *(__LOG_T *)back;
336 kmaxloc_common(&z, rb, ab, mb, db, rs, as, ms, ds);
337 }
338