1 /*
2 * Copyright (c) 2017, 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_any.c -- intrinsic reduction function */
21
22 #include "stdioInterf.h"
23 #include "fioMacros.h"
24 #include "red.h"
25
26 static __INT_T mask_desc = __LOG; /* scalar mask descriptor */
27
28 LOGFN(|, any_log1, __LOG1_T)
29 LOGFN(|, any_log2, __LOG2_T)
30 LOGFN(|, any_log4, __LOG4_T)
31 LOGFN(|, any_log8, __LOG8_T)
32 LOGFN(|, any_int1, __INT1_T)
33 LOGFN(|, any_int2, __INT2_T)
34 LOGFN(|, any_int4, __INT4_T)
35 LOGFN(|, any_int8, __INT8_T)
36
37 LOGFNLKN(|, any_log1, __LOG1_T, 1)
38 LOGFNLKN(|, any_log2, __LOG2_T, 1)
39 LOGFNLKN(|, any_log4, __LOG4_T, 1)
40 LOGFNLKN(|, any_log8, __LOG8_T, 1)
41 LOGFNLKN(|, any_int1, __INT1_T, 1)
42 LOGFNLKN(|, any_int2, __INT2_T, 1)
43 LOGFNLKN(|, any_int4, __INT4_T, 1)
44 LOGFNLKN(|, any_int8, __INT8_T, 1)
45
46 LOGFNLKN(|, any_log1, __LOG1_T, 2)
47 LOGFNLKN(|, any_log2, __LOG2_T, 2)
48 LOGFNLKN(|, any_log4, __LOG4_T, 2)
49 LOGFNLKN(|, any_log8, __LOG8_T, 2)
50 LOGFNLKN(|, any_int1, __INT1_T, 2)
51 LOGFNLKN(|, any_int2, __INT2_T, 2)
52 LOGFNLKN(|, any_int4, __INT4_T, 2)
53 LOGFNLKN(|, any_int8, __INT8_T, 2)
54
55 LOGFNLKN(|, any_log1, __LOG1_T, 4)
56 LOGFNLKN(|, any_log2, __LOG2_T, 4)
57 LOGFNLKN(|, any_log4, __LOG4_T, 4)
58 LOGFNLKN(|, any_log8, __LOG8_T, 4)
59 LOGFNLKN(|, any_int1, __INT1_T, 4)
60 LOGFNLKN(|, any_int2, __INT2_T, 4)
61 LOGFNLKN(|, any_int4, __INT4_T, 4)
62 LOGFNLKN(|, any_int8, __INT8_T, 4)
63
64 LOGFNLKN(|, any_log1, __LOG1_T, 8)
65 LOGFNLKN(|, any_log2, __LOG2_T, 8)
66 LOGFNLKN(|, any_log4, __LOG4_T, 8)
67 LOGFNLKN(|, any_log8, __LOG8_T, 8)
68 LOGFNLKN(|, any_int1, __INT1_T, 8)
69 LOGFNLKN(|, any_int2, __INT2_T, 8)
70 LOGFNLKN(|, any_int4, __INT4_T, 8)
71 LOGFNLKN(|, any_int8, __INT8_T, 8)
72
73 static void (*l_any[4][__NTYPES])() = TYPELIST2LK(l_any_);
74 static void (*g_any[__NTYPES])() = TYPELIST2(g_any_);
75
76 /* dim absent */
77
ENTFTN(ANYS,anys)78 void ENTFTN(ANYS, anys)(char *rb, char *mb, F90_Desc *rs, F90_Desc *ms)
79 {
80 red_parm z;
81
82 INIT_RED_PARM(z);
83 __fort_red_what = "ANY";
84
85 z.kind = F90_KIND_G(ms);
86 z.len = F90_LEN_G(ms);
87 z.mask_present = (F90_TAG_G(ms) == __DESC && F90_RANK_G(ms) > 0);
88 if (!z.mask_present) {
89 z.lk_shift = GET_DIST_SHIFTS(__LOG);
90 } else {
91 z.lk_shift = GET_DIST_SHIFTS(F90_KIND_G(ms));
92 }
93 z.l_fn = l_any[z.lk_shift][z.kind];
94 z.g_fn = g_any[z.kind];
95 z.zb = GET_DIST_ZED;
96 I8(__fort_red_scalar)(&z, rb, mb, (char *)GET_DIST_TRUE_LOG_ADDR,
97 rs, ms, (F90_Desc *)&mask_desc, NULL, __ANY);
98 }
99
100 /* dim present */
101
ENTFTN(ANY,any)102 void ENTFTN(ANY, any)(char *rb, char *mb, char *db, F90_Desc *rs, F90_Desc *ms,
103 F90_Desc *ds)
104 {
105 red_parm z;
106
107 INIT_RED_PARM(z);
108 __fort_red_what = "ANY";
109
110 z.kind = F90_KIND_G(ms);
111 z.len = F90_LEN_G(ms);
112 z.mask_present = (F90_TAG_G(ms) == __DESC && F90_RANK_G(ms) > 0);
113 if (!z.mask_present) {
114 z.lk_shift = GET_DIST_SHIFTS(__LOG);
115 } else {
116 z.lk_shift = GET_DIST_SHIFTS(F90_KIND_G(ms));
117 }
118 z.l_fn = l_any[z.lk_shift][z.kind];
119 z.g_fn = g_any[z.kind];
120 z.zb = GET_DIST_ZED;
121 I8(__fort_red_array)(&z, rb, mb, (char *)GET_DIST_TRUE_LOG_ADDR, db,
122 rs, ms, (F90_Desc *)&mask_desc, ds, __ANY);
123 }
124
125 /* global ANY accumulation */
126
ENTFTN(REDUCE_ANY,reduce_any)127 void ENTFTN(REDUCE_ANY, reduce_any)(char *hb, __INT_T *dimsb, __INT_T *nargb,
128 char *rb, F90_Desc *hd, F90_Desc *dimsd,
129 F90_Desc *nargd, F90_Desc *rd)
130
131 {
132 #if defined(DEBUG)
133 if (dimsd == NULL || F90_TAG_G(dimsd) != __INT)
134 __fort_abort("GLOBAL_ANY: invalid dims descriptor");
135 if (nargd == NULL || F90_TAG_G(nargd) != __INT)
136 __fort_abort("REDUCE_ANY: invalid arg count descriptor");
137 if (*nargb != 1)
138 __fort_abort("REDUCE_ANY: arg count not 1");
139 #endif
140 I8(__fort_global_reduce)(rb, hb, *dimsb, rd, hd, "ANY", g_any);
141 }
142
ENTFTN(GLOBAL_ANY,global_any)143 void ENTFTN(GLOBAL_ANY, global_any)(char *rb, char *hb, __INT_T *dimsb,
144 F90_Desc *rd, F90_Desc *hd, F90_Desc *dimsd)
145 {
146 I8(__fort_global_reduce)(rb, hb, *dimsb, rd, hd, "ANY", g_any);
147 }
148