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_minval.c -- intrinsic reduction function */
21
22 #include "stdioInterf.h"
23 #include "fioMacros.h"
24 #include "red.h"
25
26 CONDFNLKN(<, minval_int1, __INT1_T, 1)
27 CONDFNLKN(<, minval_int2, __INT2_T, 1)
28 CONDFNLKN(<, minval_int4, __INT4_T, 1)
29 CONDFNLKN(<, minval_int8, __INT8_T, 1)
30 CONDFNLKN(<, minval_real4, __REAL4_T, 1)
31 CONDFNLKN(<, minval_real8, __REAL8_T, 1)
32 CONDFNLKN(<, minval_real16, __REAL16_T, 1)
33 CONDSTRFNLKN(<, minval_str, __STR_T, 1)
34
35 CONDFNLKN(<, minval_int1, __INT1_T, 2)
36 CONDFNLKN(<, minval_int2, __INT2_T, 2)
37 CONDFNLKN(<, minval_int4, __INT4_T, 2)
38 CONDFNLKN(<, minval_int8, __INT8_T, 2)
39 CONDFNLKN(<, minval_real4, __REAL4_T, 2)
40 CONDFNLKN(<, minval_real8, __REAL8_T, 2)
41 CONDFNLKN(<, minval_real16, __REAL16_T, 2)
42 CONDSTRFNLKN(<, minval_str, __STR_T, 2)
43
44 CONDFNLKN(<, minval_int1, __INT1_T, 4)
45 CONDFNLKN(<, minval_int2, __INT2_T, 4)
46 CONDFNLKN(<, minval_int4, __INT4_T, 4)
47 CONDFNLKN(<, minval_int8, __INT8_T, 4)
48 CONDFNLKN(<, minval_real4, __REAL4_T, 4)
49 CONDFNLKN(<, minval_real8, __REAL8_T, 4)
50 CONDFNLKN(<, minval_real16, __REAL16_T, 4)
51 CONDSTRFNLKN(<, minval_str, __STR_T, 4)
52
53 CONDFNLKN(<, minval_int1, __INT1_T, 8)
54 CONDFNLKN(<, minval_int2, __INT2_T, 8)
55 CONDFNLKN(<, minval_int4, __INT4_T, 8)
56 CONDFNLKN(<, minval_int8, __INT8_T, 8)
57 CONDFNLKN(<, minval_real4, __REAL4_T, 8)
58 CONDFNLKN(<, minval_real8, __REAL8_T, 8)
59 CONDFNLKN(<, minval_real16, __REAL16_T, 8)
60 CONDSTRFNLKN(<, minval_str, __STR_T, 8)
61
62 CONDFNG(<, minval_int1, __INT1_T)
63 CONDFNG(<, minval_int2, __INT2_T)
64 CONDFNG(<, minval_int4, __INT4_T)
65 CONDFNG(<, minval_int8, __INT8_T)
66 CONDFNG(<, minval_real4, __REAL4_T)
67 CONDFNG(<, minval_real8, __REAL8_T)
68 CONDFNG(<, minval_real16, __REAL16_T)
69 CONDSTRFNG(<, minval_str, __STR_T)
70
71 static void (*l_minval[4][__NTYPES])() = TYPELIST3LK(l_minval_);
72 static void (*g_minval[__NTYPES])() = TYPELIST3(g_minval_);
73
74 /* dim absent */
75
ENTFTN(MINVALS,minvals)76 void ENTFTN(MINVALS, minvals)(char *rb, char *ab, char *mb, F90_Desc *rs,
77 F90_Desc *as, F90_Desc *ms)
78 {
79 red_parm z;
80
81 INIT_RED_PARM(z);
82 __fort_red_what = "MINVAL";
83
84 z.kind = F90_KIND_G(as);
85 z.len = F90_LEN_G(as);
86 z.mask_present = (F90_TAG_G(ms) == __DESC && F90_RANK_G(ms) > 0);
87 if (!z.mask_present) {
88 z.lk_shift = GET_DIST_SHIFTS(__LOG);
89 } else {
90 z.lk_shift = GET_DIST_SHIFTS(F90_KIND_G(ms));
91 }
92 z.l_fn = l_minval[z.lk_shift][z.kind];
93 z.g_fn = g_minval[z.kind];
94 z.zb = GET_DIST_MAXS(z.kind);
95 if (z.kind == __STR)
96 memset(rb, *((char *)(z.zb)), z.len);
97 I8(__fort_red_scalarlk)(&z, rb, ab, mb, rs, as, ms, NULL, __MINVAL);
98 }
99
100 /* dim present */
101
ENTFTN(MINVAL,minval)102 void ENTFTN(MINVAL, minval)(char *rb, char *ab, char *mb, char *db,
103 F90_Desc *rs, F90_Desc *as, F90_Desc *ms,
104 F90_Desc *ds)
105 {
106 red_parm z;
107
108 INIT_RED_PARM(z);
109 __fort_red_what = "MINVAL";
110
111 z.kind = F90_KIND_G(as);
112 z.len = F90_LEN_G(as);
113 z.mask_present = (F90_TAG_G(ms) == __DESC && F90_RANK_G(ms) > 0);
114 if (!z.mask_present) {
115 z.lk_shift = GET_DIST_SHIFTS(__LOG);
116 } else {
117 z.lk_shift = GET_DIST_SHIFTS(F90_KIND_G(ms));
118 }
119 z.l_fn = l_minval[z.lk_shift][z.kind];
120 z.g_fn = g_minval[z.kind];
121 z.zb = GET_DIST_MAXS(z.kind);
122 if (z.kind == __STR)
123 memset(rb, *((char *)(z.zb)), z.len);
124
125 if (ISSCALAR(ms)) {
126 DECL_HDR_VARS(ms2);
127
128 mb = (char *)I8(__fort_create_conforming_mask_array)(__fort_red_what, ab, mb,
129 as, ms, ms2);
130 I8(__fort_red_array)(&z, rb, ab, mb, db, rs, as, ms2, ds, __MINVAL);
131 __fort_gfree(mb);
132 } else {
133 I8(__fort_red_arraylk)(&z, rb, ab, mb, db, rs, as, ms, ds, __MINVAL);
134 }
135 }
136
137 /* global MINVAL accumulation */
138
ENTFTN(REDUCE_MINVAL,reduce_minval)139 void ENTFTN(REDUCE_MINVAL, reduce_minval)(char *hb, __INT_T *dimsb,
140 __INT_T *nargb, char *rb,
141 F90_Desc *hd, F90_Desc *dimsd,
142 F90_Desc *nargd, F90_Desc *rd)
143 {
144 #if defined(DEBUG)
145 if (dimsd == NULL || F90_TAG_G(dimsd) != __INT)
146 __fort_abort("GLOBAL_MINVAL: invalid dims descriptor");
147 if (nargd == NULL || F90_TAG_G(nargd) != __INT)
148 __fort_abort("REDUCE_MINVAL: invalid arg count descriptor");
149 if (*nargb != 1)
150 __fort_abort("REDUCE_MINVAL: arg count not 1");
151 #endif
152 I8(__fort_global_reduce)(rb, hb, *dimsb, rd, hd, "MINVAL", g_minval);
153 }
154
ENTFTN(GLOBAL_MINVAL,global_minval)155 void ENTFTN(GLOBAL_MINVAL, global_minval)(char *rb, char *hb, __INT_T *dimsb,
156 F90_Desc *rd, F90_Desc *hd,
157 F90_Desc *dimsd)
158 {
159 I8(__fort_global_reduce)(rb, hb, *dimsb, rd, hd, "MINVAL", g_minval);
160 }
161