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