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 /* red.h -- header for intrinsic reduction functions */ 19 /* FIXME: still used */ 20 21 #include "fort_vars.h" 22 23 /* intrinsic reduction function enumeration */ 24 25 typedef enum { 26 __ALL, /* 0 logical and */ 27 __ANY, /* 1 logical or */ 28 __COUNT, /* 2 logical count */ 29 __IALL, /* 3 bitwise and */ 30 __IANY, /* 4 bitwise or */ 31 __IPARITY, /* 5 bitwise xor */ 32 __MAXLOC, /* 6 location of maximum */ 33 __MAXVAL, /* 7 maximum value */ 34 __MINLOC, /* 8 location of minimum */ 35 __MINVAL, /* 9 minimum value */ 36 __PARITY, /* 10 logical xor */ 37 __PRODUCT, /* 11 product */ 38 __SUM, /* 12 sum */ 39 __FINDLOC, /* 13 location of value */ 40 __NREDS /* 14 number of reduction functions */ 41 } red_enum; 42 43 /* parameter struct for intrinsic reductions */ 44 45 typedef struct { 46 void (*l_fn)(void *, __INT_T, void *, __INT_T, __LOG_T *, __INT_T, __INT_T *, 47 __INT_T, __INT_T, __INT_T); /* local reduction function */ 48 void (*l_fn_b)(void *, __INT_T, void *, __INT_T, __LOG_T *, __INT_T, 49 __INT_T *, __INT_T, __INT_T, __INT_T, __LOG_T); 50 /* local reduction function with "back" arg */ 51 void (*g_fn)(__INT_T, void *, void *, void *, void *, __INT_T); 52 /* global reduction function */ 53 char *rb, *ab; /* result, array base addresses */ 54 void *zb; /* null value */ 55 __LOG_T *mb; /* mask base address */ 56 __INT_T *xb; /* location base address (max/minloc) */ 57 DECL_HDR_PTRS(rs); 58 DECL_HDR_PTRS(as); 59 DECL_HDR_PTRS(ms); /* result, array, mask descriptors */ 60 int dim; /* dim argument (when present) */ 61 dtype kind; /* result (max/minloc temp) kind & length */ 62 int len; 63 __LOG_T back; /* back argument (when present) */ 64 __INT_T mi[MAXDIMS]; /* mask index */ 65 int mask_present; /* mask is non-scalar */ 66 int mask_stored_alike; 67 int lk_shift; /* mask logical kind, where kind value is 68 * computed as 1<<lk_shift, where, 69 * lk_shift = 0, 1, 2, 3, ... 70 */ 71 } red_parm; 72 73 #define INIT_RED_PARM(z) memset(&z, '\0', sizeof(red_parm)) 74 75 /* prototypes */ 76 77 void __fort_red_unimplemented(); 78 79 void __fort_red_abort(char *msg); 80 81 void I8(__fort_red_scalar)(red_parm *z, char *rb, char *ab, char *mb, 82 F90_Desc *rs, F90_Desc *as, F90_Desc *ms, __INT_T *xb, 83 red_enum op); 84 85 void I8(__fort_red_scalarlk)(red_parm *z, char *rb, char *ab, char *mb, 86 F90_Desc *rs, F90_Desc *as, F90_Desc *ms, 87 __INT_T *xb, red_enum op); 88 89 void I8(__fort_kred_scalarlk)(red_parm *z, char *rb, char *ab, char *mb, 90 F90_Desc *rs, F90_Desc *as, F90_Desc *ms, 91 __INT8_T *xb, red_enum op); 92 93 void I8(__fort_red_array)(red_parm *z, char *rb0, char *ab, char *mb, char *db, 94 F90_Desc *rs0, F90_Desc *as, F90_Desc *ms, 95 F90_Desc *ds, red_enum op); 96 97 void I8(__fort_red_arraylk)(red_parm *z, char *rb0, char *ab, char *mb, char *db, 98 F90_Desc *rs0, F90_Desc *as, F90_Desc *ms, 99 F90_Desc *ds, red_enum op); 100 101 void I8(__fort_kred_arraylk)(red_parm *z, char *rb0, char *ab, char *mb, 102 char *db, F90_Desc *rs0, F90_Desc *as, F90_Desc *ms, 103 F90_Desc *ds, red_enum op); 104 105 void I8(__fort_global_reduce)(char *rb, char *hb, int dims, F90_Desc *rd, 106 F90_Desc *hd, char *what, void (*fn[__NTYPES])()); 107 108 /* prototype local reduction function (name beginning with l_): 109 110 void l_NAME(void *r, __INT_T n, void *v, __INT_T vs, 111 __LOG_T *m, __INT_T ms, __INT_T *loc, __INT_T li, __INT_T ls); 112 where 113 r = result address (scalar) 114 n = vector length 115 v = vector base address 116 vs = vector stride 117 m = mask vector address 118 ms = mask vector stride 119 loc = maxloc/minloc element location 120 li = initial location 121 ls = location stride 122 len = use for length of string 123 124 prototype global parallel reduction function (name beginning with g_): 125 126 void g_NAME(__INT_T n, RTYP *rl, RTYP *rr, void *vl, void *vr, __INT_T len); 127 where 128 n = vector length 129 lr = local result vector 130 rr = remote result vector 131 lv = local min/max value vector 132 rv = remote min/max value vector 133 len = use for length of string 134 */ 135 136 /* arithmetic reduction functions 137 RTYP = result & vector type 138 ATYP = accumulator type 139 */ 140 141 #define ARITHFN(OP, NAME, RTYP, ATYP) \ 142 static void l_##NAME(RTYP *r, __INT_T n, RTYP *v, __INT_T vs, __LOG_T *m, \ 143 __INT_T ms, __INT_T *loc, __INT_T li, __INT_T ls, \ 144 __INT_T len) \ 145 { \ 146 __INT_T i, j; \ 147 ATYP x = *r; \ 148 __LOG_T mask_log; \ 149 if (ms == 0) \ 150 for (i = 0; n > 0; n--, i += vs) { \ 151 x = x OP v[i]; \ 152 } \ 153 else { \ 154 mask_log = GET_DIST_MASK_LOG; \ 155 for (i = j = 0; n > 0; n--, i += vs, j += ms) { \ 156 if (m[j] & mask_log) \ 157 x = x OP v[i]; \ 158 } \ 159 } \ 160 *r = x; \ 161 } \ 162 static void g_##NAME(__INT_T n, RTYP *lr, RTYP *rr, void *lv, void *rv) \ 163 { \ 164 __INT_T i; \ 165 for (i = 0; i < n; i++) { \ 166 lr[i] = lr[i] OP rr[i]; \ 167 } \ 168 } 169 170 #define ARITHFNLKN(OP, NAME, RTYP, ATYP, N) \ 171 static void l_##NAME##l##N(RTYP *r, __INT_T n, RTYP *v, __INT_T vs, \ 172 __LOG##N##_T *m, __INT_T ms, __INT_T *loc, \ 173 __INT_T li, __INT_T ls, __INT_T len) \ 174 { \ 175 __INT_T i, j; \ 176 ATYP x = *r; \ 177 __LOG##N##_T mask_log; \ 178 if (ms == 0) \ 179 for (i = 0; n > 0; n--, i += vs) { \ 180 x = x OP v[i]; \ 181 } \ 182 else { \ 183 mask_log = GET_DIST_MASK_LOG##N; \ 184 for (i = j = 0; n > 0; n--, i += vs, j += ms) { \ 185 if (m[j] & mask_log) \ 186 x = x OP v[i]; \ 187 } \ 188 } \ 189 *r = x; \ 190 } 191 192 /* note: all, any, parity, and count do not have mask arguments */ 193 194 #define LOGFN(OP, NAME, RTYP) \ 195 static void l_##NAME(RTYP *r, __INT_T n, RTYP *v, __INT_T vs, __LOG_T *m, \ 196 __INT_T ms, __INT_T *loc, __INT_T li, __INT_T ls, \ 197 __INT_T len) \ 198 { \ 199 int x; \ 200 __INT_T i; \ 201 __LOG_T mask_log = GET_DIST_MASK_LOG; \ 202 x = ((*r & mask_log) != 0); \ 203 for (i = 0; n > 0; n--, i += vs) { \ 204 x = x OP((v[i] & mask_log) != 0); \ 205 } \ 206 *r = (RTYP)(x ? GET_DIST_TRUE_LOG : 0); \ 207 } \ 208 static void g_##NAME(__INT_T n, RTYP *lr, RTYP *rr, void *lv, void *rv, \ 209 __INT_T len) \ 210 { \ 211 __INT_T i; \ 212 for (i = 0; i < n; i++) { \ 213 lr[i] = lr[i] OP rr[i]; \ 214 } \ 215 } 216 217 #define LOGFNLKN(OP, NAME, RTYP, N) \ 218 static void l_##NAME##l##N(RTYP *r, __INT_T n, RTYP *v, __INT_T vs, \ 219 __LOG##N##_T *m, __INT_T ms, __INT_T *loc, \ 220 __INT_T li, __INT_T ls, __INT_T len) \ 221 { \ 222 int x; \ 223 __INT_T i; \ 224 __LOG##N##_T mask_log = GET_DIST_MASK_LOG##N; \ 225 x = ((*r & mask_log) != 0); \ 226 for (i = 0; n > 0; n--, i += vs) { \ 227 x = x OP((v[i] & mask_log) != 0); \ 228 } \ 229 *r = (RTYP)(x ? GET_DIST_TRUE_LOG : 0); \ 230 } 231 232 #define CONDFN(COND, NAME, RTYP) \ 233 static void l_##NAME(RTYP *r, __INT_T n, RTYP *v, __INT_T vs, __LOG_T *m, \ 234 __INT_T ms, __INT_T *loc, __INT_T li, __INT_T ls, \ 235 __INT_T len) \ 236 { \ 237 __INT_T i, j; \ 238 RTYP x = *r; \ 239 __LOG_T mask_log; \ 240 if (ms == 0) \ 241 for (i = 0; n > 0; n--, i += vs) { \ 242 if (v[i] COND x) \ 243 x = v[i]; \ 244 } \ 245 else { \ 246 mask_log = GET_DIST_MASK_LOG; \ 247 for (i = j = 0; n > 0; n--, i += vs, j += ms) { \ 248 if (m[j] & mask_log && v[i] COND x) \ 249 x = v[i]; \ 250 } \ 251 } \ 252 *r = x; \ 253 } \ 254 static void g_##NAME(__INT_T n, RTYP *lr, RTYP *rr, void *lv, void *rv, \ 255 __INT_T len) \ 256 { \ 257 __INT_T i; \ 258 for (i = 0; i < n; i++) { \ 259 if (rr[i] COND lr[i]) \ 260 lr[i] = rr[i]; \ 261 } \ 262 } 263 264 #define CONDFNG(COND, NAME, RTYP) \ 265 static void g_##NAME(__INT_T n, RTYP *lr, RTYP *rr, void *lv, void *rv, \ 266 __INT_T len) \ 267 { \ 268 __INT_T i; \ 269 for (i = 0; i < n; i++) { \ 270 if (rr[i] COND lr[i]) \ 271 lr[i] = rr[i]; \ 272 } \ 273 } 274 275 #define CONDSTRFNG(COND, NAME, RTYP) \ 276 static void g_##NAME(__INT_T n, RTYP *lr, RTYP *rr, void *lv, void *rv, \ 277 __INT_T len) \ 278 { \ 279 __INT_T i; \ 280 for (i = 0; i < n; i++, lr += len, rr += len) { \ 281 if (strncmp(rr, lr, len) COND 0) \ 282 strncpy(lr, rr, len); \ 283 } \ 284 } 285 286 #define CONDFNLKN(COND, NAME, RTYP, N) \ 287 static void l_##NAME##l##N(RTYP *r, __INT_T n, RTYP *v, __INT_T vs, \ 288 __LOG##N##_T *m, __INT_T ms, __INT_T *loc, \ 289 __INT_T li, __INT_T ls, __INT_T len) \ 290 { \ 291 __INT_T i, j; \ 292 RTYP x = *r; \ 293 __LOG##N##_T mask_log; \ 294 if (ms == 0) \ 295 for (i = 0; n > 0; n--, i += vs) { \ 296 if (v[i] COND x) \ 297 x = v[i]; \ 298 } \ 299 else { \ 300 mask_log = GET_DIST_MASK_LOG##N; \ 301 for (i = j = 0; n > 0; n--, i += vs, j += ms) { \ 302 if (m[j] & mask_log && v[i] COND x) \ 303 x = v[i]; \ 304 } \ 305 } \ 306 *r = x; \ 307 } 308 309 #define CONDSTRFNLKN(COND, NAME, RTYP, N) \ 310 static void l_##NAME##l##N(RTYP *r, __INT_T n, RTYP *v, __INT_T vs, \ 311 __LOG##N##_T *m, __INT_T ms, __INT_T *loc, \ 312 __INT_T li, __INT_T ls, __INT_T len) \ 313 { \ 314 __INT_T i, j, ahop; \ 315 RTYP *x = r; \ 316 __LOG##N##_T mask_log; \ 317 ahop = len * vs; \ 318 if (ms == 0) \ 319 for (i = 0; n > 0; n--, i += vs, v += (ahop)) { \ 320 if (strncmp(v, x, len) COND 0) \ 321 x = v; \ 322 } \ 323 else { \ 324 mask_log = GET_DIST_MASK_LOG##N; \ 325 for (i = j = 0; n > 0; n--, i += vs, j += ms, v += (ahop)) { \ 326 if (m[j] & mask_log && strncmp(v, x, len) COND 0) \ 327 x = v; \ 328 } \ 329 } \ 330 strncpy(r, x, len); \ 331 } 332 333 #define MLOCFN(COND, NAME, RTYP) \ 334 static void l_##NAME(RTYP *r, __INT_T n, RTYP *v, __INT_T vs, __LOG_T *m, \ 335 __INT_T ms, __INT4_T *loc, __INT_T li, __INT_T ls, \ 336 __INT_T len) \ 337 { \ 338 __INT4_T i, j; \ 339 __INT4_T t_loc = 0; \ 340 RTYP val = *r; \ 341 __LOG_T mask_log; \ 342 if (ms == 0) { \ 343 for (i = 0; n > 0; n--, i += vs, li += ls) { \ 344 if (v[i] COND val) { \ 345 t_loc = li; \ 346 val = v[i]; \ 347 } else if (v[i] == val && t_loc == 0 && *loc == 0) { \ 348 t_loc = li; \ 349 } \ 350 } \ 351 } else { \ 352 mask_log = GET_DIST_MASK_LOG; \ 353 for (i = j = 0; n > 0; n--, i += vs, j += ms, li += ls) { \ 354 if ((m[j] & mask_log)) { \ 355 if (v[i] COND val) { \ 356 t_loc = li; \ 357 val = v[i]; \ 358 } else if (v[i] == val && t_loc == 0 && *loc == 0) { \ 359 t_loc = li; \ 360 } \ 361 } \ 362 } \ 363 } \ 364 *r = val; \ 365 if (t_loc != 0) \ 366 *loc = t_loc; \ 367 } \ 368 static void g_##NAME(__INT_T n, RTYP *lval, RTYP *rval, __INT4_T *lloc, \ 369 __INT_T *rloc, __INT_T len) \ 370 { \ 371 __INT4_T i; \ 372 for (i = 0; i < n; i++) { \ 373 if (rval[i] COND lval[i]) { \ 374 lloc[i] = rloc[i]; \ 375 lval[i] = rval[i]; \ 376 } else if (rval[i] == lval[i] && rloc[i] < lloc[i]) { \ 377 lloc[i] = rloc[i]; \ 378 } \ 379 } \ 380 } 381 382 #define MLOCSTRFN(COND, NAME, RTYP) \ 383 static void l_##NAME(RTYP *r, __INT_T n, RTYP *v, __INT_T vs, __LOG_T *m, \ 384 __INT_T ms, __INT4_T *loc, __INT_T li, __INT_T ls, \ 385 __INT_T len) \ 386 { \ 387 __INT4_T i, j, ahop; \ 388 __INT4_T t_loc = 0; \ 389 RTYP *val = r; \ 390 __LOG_T mask_log; \ 391 ahop = len * vs; \ 392 if (ms == 0) { \ 393 for (i = 0; n > 0; n--, i += vs, li += ls, v += (ahop)) { \ 394 if (strncmp(v, val, len) COND 0) { \ 395 t_loc = li; \ 396 val = v; \ 397 } else if (strncmp(v, val, len) == 0 && t_loc == 0 && *loc == 0) { \ 398 t_loc = li; \ 399 } \ 400 } \ 401 } else { \ 402 mask_log = GET_DIST_MASK_LOG; \ 403 for (i = j = 0; n > 0; n--, i += vs, j += ms, li += ls, v += (ahop)) { \ 404 if ((m[j] & mask_log)) { \ 405 if (strncmp(v, val, len) COND 0) { \ 406 t_loc = li; \ 407 val = v; \ 408 } else if (strncmp(v, val, len) == 0 && t_loc == 0 && *loc == 0) { \ 409 t_loc = li; \ 410 } \ 411 } \ 412 } \ 413 } \ 414 strncpy(r, val, len); \ 415 if (t_loc != 0) \ 416 *loc = t_loc; \ 417 } \ 418 static void g_##NAME(__INT_T n, RTYP *lval, RTYP *rval, __INT4_T *lloc, \ 419 __INT_T *rloc, __INT_T len) \ 420 { \ 421 __INT4_T i; \ 422 for (i = 0; i < n; i++, rval += len, lval += len) { \ 423 if (strncmp(rval, lval, len) COND 0) { \ 424 lloc[i] = rloc[i]; \ 425 strncpy(lval, rval, len); \ 426 } else if (strncmp(rval, lval, len) == 0 && rloc[i] < lloc[i]) { \ 427 lloc[i] = rloc[i]; \ 428 } \ 429 } \ 430 } 431 432 #define MLOCFNG(COND, NAME, RTYP) \ 433 static void g_##NAME(__INT_T n, RTYP *lval, RTYP *rval, __INT4_T *lloc, \ 434 __INT_T *rloc, __INT_T len) \ 435 { \ 436 __INT4_T i; \ 437 for (i = 0; i < n; i++) { \ 438 if (rval[i] COND lval[i]) { \ 439 lloc[i] = rloc[i]; \ 440 lval[i] = rval[i]; \ 441 } else if (rval[i] == lval[i] && rloc[i] < lloc[i]) { \ 442 lloc[i] = rloc[i]; \ 443 } \ 444 } \ 445 } 446 447 #define MLOCSTRFNG(COND, NAME, RTYP) \ 448 static void g_##NAME(__INT_T n, RTYP *lval, RTYP *rval, __INT4_T *lloc, \ 449 __INT_T *rloc, __INT_T len) \ 450 { \ 451 __INT4_T i; \ 452 for (i = 0; i < n; i++, rval += len, lval += len) { \ 453 if (strncmp(rval, lval, len) COND 0) { \ 454 lloc[i] = rloc[i]; \ 455 strncpy(lval, rval, len); \ 456 } else if (strncmp(rval, lval, len) == 0 && rloc[i] < lloc[i]) { \ 457 lloc[i] = rloc[i]; \ 458 } \ 459 } \ 460 } 461 462 #define MLOCFNLKN(COND, NAME, RTYP, N) \ 463 static void l_##NAME##l##N(RTYP *r, __INT_T n, RTYP *v, __INT_T vs, \ 464 __LOG##N##_T *m, __INT_T ms, __INT4_T *loc, \ 465 __INT_T li, __INT_T ls, __INT_T len, __LOG_T back)\ 466 { \ 467 __INT4_T i, j, t_loc = 0; \ 468 RTYP val = *r; \ 469 __LOG##N##_T mask_log; \ 470 if (ms == 0) { \ 471 for (i = 0; n > 0; n--, i += vs, li += ls) { \ 472 if (v[i] COND val) { \ 473 t_loc = li; \ 474 val = v[i]; \ 475 } else if (v[i] == val && (back || (t_loc == 0 && *loc == 0))) { \ 476 t_loc = li; \ 477 } \ 478 } \ 479 } else { \ 480 mask_log = GET_DIST_MASK_LOG##N; \ 481 for (i = j = 0; n > 0; n--, i += vs, j += ms, li += ls) { \ 482 if ((m[j] & mask_log)) { \ 483 if (v[i] COND val) { \ 484 t_loc = li; \ 485 val = v[i]; \ 486 } else if (v[i] == val && (back || (t_loc == 0 && *loc == 0))) { \ 487 t_loc = li; \ 488 } \ 489 } \ 490 } \ 491 } \ 492 *r = val; \ 493 if (t_loc != 0) \ 494 *loc = t_loc; \ 495 } 496 497 #define MLOCSTRFNLKN(COND, NAME, RTYP, N) \ 498 static void l_##NAME##l##N(RTYP *r, __INT_T n, RTYP *v, __INT_T vs, \ 499 __LOG##N##_T *m, __INT_T ms, __INT4_T *loc, \ 500 __INT_T li, __INT_T ls, __INT_T len, __LOG_T back)\ 501 { \ 502 __INT4_T i, j, ahop, t_loc = 0; \ 503 RTYP *val = r; \ 504 __LOG##N##_T mask_log; \ 505 ahop = len * vs; \ 506 if (ms == 0) { \ 507 for (i = 0; n > 0; n--, i += vs, li += ls, v += (ahop)) { \ 508 if (strncmp(v, val, len) COND 0) { \ 509 t_loc = li; \ 510 val = v; \ 511 } else if (strncmp(v, val, len) == 0 \ 512 && (back || (t_loc == 0 && *loc == 0))) { \ 513 t_loc = li; \ 514 } \ 515 } \ 516 } else { \ 517 mask_log = GET_DIST_MASK_LOG##N; \ 518 for (i = j = 0; n > 0; n--, i += vs, j += ms, li += ls, v += (ahop)) { \ 519 if ((m[j] & mask_log)) { \ 520 if (strncmp(v, val, len) COND 0) { \ 521 t_loc = li; \ 522 val = v; \ 523 } else if (strncmp(v, val, len) == 0 \ 524 && (back || (t_loc == 0 && *loc == 0))) { \ 525 t_loc = li; \ 526 } \ 527 } \ 528 } \ 529 } \ 530 strncpy(r, val, len); \ 531 if (t_loc != 0) \ 532 *loc = t_loc; \ 533 } 534 535 #define KMLOCFNG(COND, NAME, RTYP) \ 536 static void g_##NAME(__INT_T n, RTYP *lval, RTYP *rval, __INT8_T *lloc, \ 537 __INT8_T *rloc, __INT_T len) \ 538 { \ 539 __INT_T i; \ 540 for (i = 0; i < n; i++) { \ 541 if (rval[i] COND lval[i]) { \ 542 lloc[i] = rloc[i]; \ 543 lval[i] = rval[i]; \ 544 } else if (rval[i] == lval[i] && rloc[i] < lloc[i]) { \ 545 lloc[i] = rloc[i]; \ 546 } \ 547 } \ 548 } 549 550 #define KMLOCSTRFNG(COND, NAME, RTYP) \ 551 static void g_##NAME(__INT_T n, RTYP *lval, RTYP *rval, __INT8_T *lloc, \ 552 __INT8_T *rloc, __INT_T len) \ 553 { \ 554 __INT_T i; \ 555 for (i = 0; i < n; i++, lval += len, rval += len) { \ 556 if (strncmp(rval, lval, len) COND 0) { \ 557 lloc[i] = rloc[i]; \ 558 strncpy(lval, rval, len); \ 559 } else if (strncmp(rval, lval, len) == 0 && rloc[i] < lloc[i]) { \ 560 lloc[i] = rloc[i]; \ 561 } \ 562 } \ 563 } 564 565 #define KMLOCFNLKN(COND, NAME, RTYP, N) \ 566 static void l_##NAME##l##N(RTYP *r, __INT_T n, RTYP *v, __INT_T vs, \ 567 __LOG##N##_T *m, __INT_T ms, __INT8_T *loc, \ 568 __INT_T li, __INT_T ls, __INT_T len, __LOG_T back)\ 569 { \ 570 __INT_T i, j, t_loc = 0; \ 571 RTYP val = *r; \ 572 __LOG##N##_T mask_log; \ 573 if (ms == 0) { \ 574 for (i = 0; n > 0; n--, i += vs, li += ls) { \ 575 if (v[i] COND val) { \ 576 t_loc = li; \ 577 val = v[i]; \ 578 } else if (v[i] == val && (back || (t_loc == 0 && *loc == 0))) { \ 579 t_loc = li; \ 580 } \ 581 } \ 582 } else { \ 583 mask_log = GET_DIST_MASK_LOG##N; \ 584 for (i = j = 0; n > 0; n--, i += vs, j += ms, li += ls) { \ 585 if ((m[j] & mask_log)) { \ 586 if (v[i] COND val) { \ 587 t_loc = li; \ 588 val = v[i]; \ 589 } else if (v[i] == val && (back || (t_loc == 0 && *loc == 0))) { \ 590 t_loc = li; \ 591 } \ 592 } \ 593 } \ 594 } \ 595 *r = val; \ 596 if (t_loc != 0) \ 597 *loc = t_loc; \ 598 } 599 600 #define KMLOCSTRFNLKN(COND, NAME, RTYP, N) \ 601 static void l_##NAME##l##N(RTYP *r, __INT_T n, RTYP *v, __INT_T vs, \ 602 __LOG##N##_T *m, __INT_T ms, __INT8_T *loc, \ 603 __INT_T li, __INT_T ls, __INT_T len, __INT_T back)\ 604 { \ 605 __INT_T i, j, ahop, t_loc = 0; \ 606 RTYP *val = r; \ 607 __LOG##N##_T mask_log; \ 608 ahop = len * vs; \ 609 if (ms == 0) { \ 610 for (i = 0; n > 0; n--, i += vs, li += ls, v += (ahop)) { \ 611 if (strncmp(v, val, len) COND 0) { \ 612 t_loc = li; \ 613 val = v; \ 614 } else if (strncmp(v, val, len) == 0 \ 615 && (back || (t_loc == 0 && *loc == 0))) { \ 616 t_loc = li; \ 617 } \ 618 } \ 619 } else { \ 620 mask_log = GET_DIST_MASK_LOG##N; \ 621 for (i = j = 0; n > 0; n--, i += vs, j += ms, li += ls, v += (ahop)) { \ 622 if ((m[j] & mask_log)) { \ 623 if (strncmp(v, val, len) COND 0) { \ 624 t_loc = li; \ 625 val = v; \ 626 } else if (strncmp(v, val, len) == 0 \ 627 && (back || (t_loc == 0 && *loc == 0))) { \ 628 t_loc = li; \ 629 } \ 630 } \ 631 } \ 632 } \ 633 strncpy(r, val, len); \ 634 if (t_loc != 0) \ 635 *loc = t_loc; \ 636 } 637 638 #define FLOCFN(COND, NAME, RTYP) \ 639 static void l_##NAME(RTYP *r, __INT_T n, RTYP *v, __INT_T vs, __LOG_T *m, \ 640 __INT_T ms, __INT4_T *loc, __INT_T li, __INT_T ls, \ 641 __INT_T len, __LOG_T back) \ 642 { \ 643 __INT4_T i, j; \ 644 __INT4_T t_loc = 0; \ 645 RTYP val = *r; \ 646 __LOG_T mask_log; \ 647 if (!back && *loc != 0) \ 648 return; \ 649 if (ms == 0) { \ 650 for (i = 0; n > 0; n--, i += vs, li += ls) { \ 651 if (v[i] COND val) { \ 652 t_loc = li; \ 653 if (!back) \ 654 break; \ 655 } \ 656 } \ 657 } else { \ 658 mask_log = GET_DIST_MASK_LOG; \ 659 for (i = j = 0; n > 0; n--, i += vs, j += ms, li += ls) { \ 660 if ((m[j] & mask_log)) { \ 661 if (v[i] COND val) { \ 662 t_loc = li; \ 663 if (!back) \ 664 break; \ 665 } \ 666 } \ 667 } \ 668 } \ 669 if (t_loc != 0) \ 670 *loc = t_loc; \ 671 } \ 672 static void g_##NAME(__INT_T n, RTYP *lval, RTYP *rval, __INT4_T *lloc, \ 673 __INT_T *rloc, __INT_T len, __LOG_T back) \ 674 { \ 675 __INT4_T i; \ 676 for (i = 0; i < n; i++) { \ 677 if (rval[i] COND lval[i]) { \ 678 lloc[i] = rloc[i]; \ 679 } else if (rval[i] == lval[i] && rloc[i] < lloc[i]) { \ 680 lloc[i] = rloc[i]; \ 681 } \ 682 } \ 683 } 684 685 #define FLOCSTRFN(COND, NAME, RTYP) \ 686 static void l_ ## NAME(RTYP *r, __INT_T n, RTYP *v, __INT_T vs, \ 687 __LOG_T *m, __INT_T ms, __INT4_T *loc, __INT_T li, __INT_T ls, __INT_T len), \ 688 __LOG_T back ) \ 689 { \ 690 __INT4_T i, j, ahop; \ 691 __INT4_T t_loc = 0; \ 692 RTYP *val = v; \ 693 __LOG_T mask_log; \ 694 if (!back && *loc != 0) \ 695 return; \ 696 ahop = len * vs; \ 697 if (ms == 0) { \ 698 for (i = 0; n > 0; n--, i += vs, li += ls, v += (ahop)) { \ 699 if (strncmp(r, v, len) COND 0) { \ 700 t_loc = li; \ 701 if (!back) \ 702 break; \ 703 } \ 704 } \ 705 } else { \ 706 mask_log = GET_DIST_MASK_LOG; \ 707 for (i = j = 0; n > 0; n--, i += vs, j += ms, li += ls, v += (ahop)) { \ 708 if ((m[j] & mask_log)) { \ 709 if (strncmp(r, v, len) COND 0) { \ 710 t_loc = li; \ 711 if (!back) \ 712 break; \ 713 } \ 714 } \ 715 } \ 716 } \ 717 if (t_loc != 0) \ 718 *loc = t_loc; \ 719 } \ 720 static void g_##NAME(__INT_T n, RTYP *lval, RTYP *rval, __INT4_T *lloc, \ 721 __INT_T *rloc, __INT_T len, __LOG_T back) \ 722 { \ 723 __INT4_T i; \ 724 for (i = 0; i < n; i++, rval += len, lval += len) { \ 725 if (strncmp(rval, lval, len) COND 0) { \ 726 lloc[i] = rloc[i]; \ 727 if (!back) \ 728 break; \ 729 } else if (strncmp(rval, lval, len) == 0 && rloc[i] < lloc[i]) { \ 730 lloc[i] = rloc[i]; \ 731 if (!back) \ 732 break; \ 733 } \ 734 } \ 735 } 736 737 #define FLOCFNG(COND, NAME, RTYP) \ 738 static void g_##NAME(__INT_T n, RTYP *lval, RTYP *rval, __INT4_T *lloc, \ 739 __INT_T *rloc, __INT_T len, __LOG_T back) \ 740 { \ 741 __INT4_T i; \ 742 for (i = 0; i < n; i++) { \ 743 if (rval[i] COND lval[i]) { \ 744 lloc[i] = rloc[i]; \ 745 } else if (rval[i] == lval[i] && rloc[i] < lloc[i]) { \ 746 lloc[i] = rloc[i]; \ 747 } \ 748 } \ 749 } 750 751 #define FLOCSTRFNG(COND, NAME, RTYP) \ 752 static void g_##NAME(__INT_T n, RTYP *lval, RTYP *rval, __INT4_T *lloc, \ 753 __INT_T *rloc, __INT_T len, __LOG_T back) \ 754 { \ 755 __INT4_T i; \ 756 for (i = 0; i < n; i++, rval += len, lval += len) { \ 757 if (strncmp(rval, lval, len) COND 0) { \ 758 lloc[i] = rloc[i]; \ 759 } \ 760 } \ 761 } 762 763 #define FLOCFNLKN(COND, NAME, RTYP, N) \ 764 static void l_##NAME##l##N( \ 765 RTYP *r, __INT_T n, RTYP *v, __INT_T vs, __LOG##N##_T *m, __INT_T ms, \ 766 __INT4_T *loc, __INT_T li, __INT_T ls, __INT_T len, __LOG_T back) \ 767 { \ 768 __INT4_T i, j, t_loc = 0; \ 769 RTYP val = *r; \ 770 __LOG##N##_T mask_log; \ 771 if (!back && *loc != 0) \ 772 return; \ 773 if (ms == 0) { \ 774 for (i = 0; n > 0; n--, i += vs, li += ls) { \ 775 if (v[i] COND val) { \ 776 t_loc = li; \ 777 if (!back) \ 778 break; \ 779 } \ 780 } \ 781 } else { \ 782 mask_log = GET_DIST_MASK_LOG##N; \ 783 for (i = j = 0; n > 0; n--, i += vs, j += ms, li += ls) { \ 784 if ((m[j] & mask_log)) { \ 785 if (v[i] COND val) { \ 786 t_loc = li; \ 787 if (!back) \ 788 break; \ 789 } \ 790 } \ 791 } \ 792 } \ 793 if (t_loc != 0) \ 794 *loc = t_loc; \ 795 } 796 797 #define FLOCSTRFNLKN(COND, NAME, RTYP, N) \ 798 static void l_##NAME##l##N( \ 799 RTYP *r, __INT_T n, RTYP *v, __INT_T vs, __LOG##N##_T *m, __INT_T ms, \ 800 __INT4_T *loc, __INT_T li, __INT_T ls, __INT_T len, __LOG_T back) \ 801 { \ 802 __INT4_T i, j, ahop, t_loc = 0; \ 803 RTYP *val = v; \ 804 __LOG##N##_T mask_log; \ 805 if (!back && *loc != 0) \ 806 return; \ 807 ahop = len * vs; \ 808 if (ms == 0) { \ 809 for (i = 0; n > 0; n--, i += vs, li += ls, v += (ahop)) { \ 810 if (strncmp(r, v, len) COND 0) { \ 811 t_loc = li; \ 812 if (!back) \ 813 break; \ 814 } \ 815 } \ 816 } else { \ 817 mask_log = GET_DIST_MASK_LOG##N; \ 818 for (i = j = 0; n > 0; n--, i += vs, j += ms, li += ls, v += (ahop)) { \ 819 if ((m[j] & mask_log)) { \ 820 if (strncmp(r, v, len) COND 0) { \ 821 t_loc = li; \ 822 if (!back) \ 823 break; \ 824 } \ 825 } \ 826 } \ 827 } \ 828 if (t_loc != 0) \ 829 *loc = t_loc; \ 830 } 831 832 #define KFLOCFNG(COND, NAME, RTYP) \ 833 static void g_##NAME(__INT_T n, RTYP *lval, RTYP *rval, __INT8_T *lloc, \ 834 __INT8_T *rloc, __INT_T len, __LOG_T back) \ 835 { \ 836 __INT_T i; \ 837 for (i = 0; i < n; i++) { \ 838 if (rval[i] COND lval[i]) { \ 839 lloc[i] = rloc[i]; \ 840 if (!back) \ 841 break; \ 842 } else if (rval[i] == lval[i] && rloc[i] < lloc[i]) { \ 843 lloc[i] = rloc[i]; \ 844 if (!back) \ 845 break; \ 846 } \ 847 } \ 848 } 849 850 #define KFLOCSTRFNG(COND, NAME, RTYP) \ 851 static void g_##NAME(__INT_T n, RTYP *lval, RTYP *rval, __INT8_T *lloc, \ 852 __INT8_T *rloc, __INT_T len, __LOG_T back) \ 853 { \ 854 __INT_T i; \ 855 for (i = 0; i < n; i++, lval += len, rval += len) { \ 856 if (strncmp(rval, lval, len) COND 0) { \ 857 lloc[i] = rloc[i]; \ 858 if (!back) \ 859 break; \ 860 } else if (strncmp(rval, lval, len) == 0 && rloc[i] < lloc[i]) { \ 861 lloc[i] = rloc[i]; \ 862 if (!back) \ 863 break; \ 864 } \ 865 } \ 866 } 867 868 #define KFLOCFNLKN(COND, NAME, RTYP, N) \ 869 static void l_##NAME##l##N( \ 870 RTYP *r, __INT_T n, RTYP *v, __INT_T vs, __LOG##N##_T *m, __INT_T ms, \ 871 __INT8_T *loc, __INT_T li, __INT_T ls, __INT_T len, __LOG_T back) \ 872 { \ 873 __INT_T i, j, t_loc = 0; \ 874 RTYP val = *r; \ 875 __LOG##N##_T mask_log; \ 876 if (!back && *loc != 0) \ 877 return; \ 878 if (ms == 0) { \ 879 for (i = 0; n > 0; n--, i += vs, li += ls) { \ 880 if (v[i] COND val) { \ 881 t_loc = li; \ 882 if (!back) \ 883 break; \ 884 } \ 885 } \ 886 } else { \ 887 mask_log = GET_DIST_MASK_LOG##N; \ 888 for (i = j = 0; n > 0; n--, i += vs, j += ms, li += ls) { \ 889 if ((m[j] & mask_log)) { \ 890 if (v[i] COND val) { \ 891 t_loc = li; \ 892 if (!back) \ 893 break; \ 894 } \ 895 } \ 896 } \ 897 } \ 898 if (t_loc != 0) \ 899 *loc = t_loc; \ 900 } 901 902 #define KFLOCSTRFNLKN(COND, NAME, RTYP, N) \ 903 static void l_##NAME##l##N( \ 904 RTYP *r, __INT_T n, RTYP *v, __INT_T vs, __LOG##N##_T *m, __INT_T ms, \ 905 __INT8_T *loc, __INT_T li, __INT_T ls, __INT_T len, __LOG_T back) \ 906 { \ 907 __INT_T i, j, ahop, t_loc = 0; \ 908 RTYP *val = v; \ 909 __LOG##N##_T mask_log; \ 910 if (!back && *loc != 0) \ 911 return; \ 912 ahop = len * vs; \ 913 if (ms == 0) { \ 914 for (i = 0; n > 0; n--, i += vs, li += ls, v += (ahop)) { \ 915 if (strncmp(r, v, len) COND 0) { \ 916 t_loc = li; \ 917 if (!back) \ 918 break; \ 919 } \ 920 } \ 921 } else { \ 922 mask_log = GET_DIST_MASK_LOG##N; \ 923 for (i = j = 0; n > 0; n--, i += vs, j += ms, li += ls, v += (ahop)) { \ 924 if ((m[j] & mask_log)) { \ 925 if (strncmp(r, v, len) COND 0) { \ 926 t_loc = li; \ 927 if (!back) \ 928 break; \ 929 } \ 930 } \ 931 } \ 932 } \ 933 if (t_loc != 0) \ 934 *loc = t_loc; \ 935 } 936 937 /* type list 1 -- sum, product */ 938 939 #define TYPELIST1(NAME) \ 940 { \ 941 __fort_red_unimplemented, /* 0 __NONE no type */ \ 942 __fort_red_unimplemented, /* 1 __SHORT short */ \ 943 __fort_red_unimplemented, /* 2 __USHORT unsigned short */ \ 944 __fort_red_unimplemented, /* 3 __CINT int */ \ 945 __fort_red_unimplemented, /* 4 __UINT unsigned int */ \ 946 __fort_red_unimplemented, /* 5 __LONG long */ \ 947 __fort_red_unimplemented, /* 6 __ULONG unsigned long */ \ 948 __fort_red_unimplemented, /* 7 __FLOAT float */ \ 949 __fort_red_unimplemented, /* 8 __DOUBLE double */ \ 950 NAME##cplx8, /* 9 __CPLX8 float complex */ \ 951 NAME##cplx16, /* 10 __CPLX16 double complex */ \ 952 __fort_red_unimplemented, /* 11 __CHAR char */ \ 953 __fort_red_unimplemented, /* 12 __UCHAR unsigned char */ \ 954 __fort_red_unimplemented, /* 13 __LONGDOUBLE long double */ \ 955 __fort_red_unimplemented, /* 14 __STR string */ \ 956 __fort_red_unimplemented, /* 15 __LONGLONG long long */ \ 957 __fort_red_unimplemented, /* 16 __ULONGLONG unsigned long long */ \ 958 __fort_red_unimplemented, /* 17 __LOG1 logical*1 */ \ 959 __fort_red_unimplemented, /* 18 __LOG2 logical*2 */ \ 960 __fort_red_unimplemented, /* 19 __LOG4 logical*4 */ \ 961 __fort_red_unimplemented, /* 20 __LOG8 logical*8 */ \ 962 __fort_red_unimplemented, /* 21 __WORD4 typeless */ \ 963 __fort_red_unimplemented, /* 22 __WORD8 double typeless */ \ 964 __fort_red_unimplemented, /* 23 __NCHAR ncharacter - kanji */ \ 965 NAME##int2, /* 24 __INT2 integer*2 */ \ 966 NAME##int4, /* 25 __INT4 integer*4 */ \ 967 NAME##int8, /* 26 __INT8 integer*8 */ \ 968 NAME##real4, /* 27 __REAL4 real*4 */ \ 969 NAME##real8, /* 28 __REAL8 real*8 */ \ 970 NAME##real16, /* 29 __REAL16 real*16 */ \ 971 NAME##cplx32, /* 30 __CPLX32 complex*32 */ \ 972 __fort_red_unimplemented, /* 31 __WORD16 quad typeless */ \ 973 NAME##int1, /* 32 __INT1 integer*1 */ \ 974 __fort_red_unimplemented /* 33 __DERIVED derived type */ \ 975 } 976 977 /* type list 1 with logical kind -- sum, product */ 978 979 #define TYPELIST1LKN(NAME, N) \ 980 { \ 981 __fort_red_unimplemented, /* 0 __NONE no type */ \ 982 __fort_red_unimplemented, /* 1 __SHORT short */ \ 983 __fort_red_unimplemented, /* 2 __USHORT unsigned short */ \ 984 __fort_red_unimplemented, /* 3 __CINT int */ \ 985 __fort_red_unimplemented, /* 4 __UINT unsigned int */ \ 986 __fort_red_unimplemented, /* 5 __LONG long */ \ 987 __fort_red_unimplemented, /* 6 __ULONG unsigned long */ \ 988 __fort_red_unimplemented, /* 7 __FLOAT float */ \ 989 __fort_red_unimplemented, /* 8 __DOUBLE double */ \ 990 NAME##cplx8##l##N, /* 9 __CPLX8 float complex */ \ 991 NAME##cplx16##l##N, /* 10 __CPLX16 double complex */ \ 992 __fort_red_unimplemented, /* 11 __CHAR char */ \ 993 __fort_red_unimplemented, /* 12 __UCHAR unsigned char */ \ 994 __fort_red_unimplemented, /* 13 __LONGDOUBLE long double */ \ 995 __fort_red_unimplemented, /* 14 __STR string */ \ 996 __fort_red_unimplemented, /* 15 __LONGLONG long long */ \ 997 __fort_red_unimplemented, /* 16 __ULONGLONG unsigned long long */ \ 998 __fort_red_unimplemented, /* 17 __LOG1 logical*1 */ \ 999 __fort_red_unimplemented, /* 18 __LOG2 logical*2 */ \ 1000 __fort_red_unimplemented, /* 19 __LOG4 logical*4 */ \ 1001 __fort_red_unimplemented, /* 20 __LOG8 logical*8 */ \ 1002 __fort_red_unimplemented, /* 21 __WORD4 typeless */ \ 1003 __fort_red_unimplemented, /* 22 __WORD8 double typeless */ \ 1004 __fort_red_unimplemented, /* 23 __NCHAR ncharacter - kanji */ \ 1005 NAME##int2##l##N, /* 24 __INT2 integer*2 */ \ 1006 NAME##int4##l##N, /* 25 __INT4 integer*4 */ \ 1007 NAME##int8##l##N, /* 26 __INT8 integer*8 */ \ 1008 NAME##real4##l##N, /* 27 __REAL4 real*4 */ \ 1009 NAME##real8##l##N, /* 28 __REAL8 real*8 */ \ 1010 NAME##real16##l##N, /* 29 __REAL16 real*16 */ \ 1011 NAME##cplx32##l##N, /* 30 __CPLX32 complex*32 */ \ 1012 __fort_red_unimplemented, /* 31 __WORD16 quad typeless */ \ 1013 NAME##int1##l##N, /* 32 __INT1 integer*1 */ \ 1014 __fort_red_unimplemented /* 33 __DERIVED derived type */ \ 1015 } 1016 1017 /* type list 1 for all logical kind -- for sum, product */ 1018 1019 #define TYPELIST1LK(NAME) \ 1020 { \ 1021 TYPELIST1LKN(NAME, 1), \ 1022 TYPELIST1LKN(NAME, 2), \ 1023 TYPELIST1LKN(NAME, 4), \ 1024 TYPELIST1LKN(NAME, 8) \ 1025 } 1026 1027 /* type list 2 -- iall, iany, iparity, all, any, parity, count */ 1028 1029 #define TYPELIST2(NAME) \ 1030 { \ 1031 __fort_red_unimplemented, /* 0 __NONE no type */ \ 1032 __fort_red_unimplemented, /* 1 __SHORT short */ \ 1033 __fort_red_unimplemented, /* 2 __USHORT unsigned short */ \ 1034 __fort_red_unimplemented, /* 3 __CINT int */ \ 1035 __fort_red_unimplemented, /* 4 __UINT unsigned int */ \ 1036 __fort_red_unimplemented, /* 5 __LONG long */ \ 1037 __fort_red_unimplemented, /* 6 __ULONG unsigned long */ \ 1038 __fort_red_unimplemented, /* 7 __FLOAT float */ \ 1039 __fort_red_unimplemented, /* 8 __DOUBLE double */ \ 1040 __fort_red_unimplemented, /* 9 __CPLX8 float complex */ \ 1041 __fort_red_unimplemented, /* 10 __CPLX16 double complex */ \ 1042 __fort_red_unimplemented, /* 11 __CHAR char */ \ 1043 __fort_red_unimplemented, /* 12 __UCHAR unsigned char */ \ 1044 __fort_red_unimplemented, /* 13 __LONGDOUBLE long double */ \ 1045 __fort_red_unimplemented, /* 14 __STR string */ \ 1046 __fort_red_unimplemented, /* 15 __LONGLONG long long */ \ 1047 __fort_red_unimplemented, /* 16 __ULONGLONG unsigned long long */ \ 1048 NAME##log1, /* 17 __LOG1 logical*1 */ \ 1049 NAME##log2, /* 18 __LOG2 logical*2 */ \ 1050 NAME##log4, /* 19 __LOG4 logical*4 */ \ 1051 NAME##log8, /* 20 __LOG8 logical*8 */ \ 1052 __fort_red_unimplemented, /* 21 __WORD4 typeless */ \ 1053 __fort_red_unimplemented, /* 22 __WORD8 double typeless */ \ 1054 __fort_red_unimplemented, /* 23 __NCHAR ncharacter - kanji */ \ 1055 NAME##int2, /* 24 __INT2 integer*2 */ \ 1056 NAME##int4, /* 25 __INT4 integer*4 */ \ 1057 NAME##int8, /* 26 __INT8 integer*8 */ \ 1058 __fort_red_unimplemented, /* 27 __REAL4 real*4 */ \ 1059 __fort_red_unimplemented, /* 28 __REAL8 real*8 */ \ 1060 __fort_red_unimplemented, /* 29 __REAL16 real*16 */ \ 1061 __fort_red_unimplemented, /* 30 __CPLX32 complex*32 */ \ 1062 __fort_red_unimplemented, /* 31 __WORD16 quad typeless */ \ 1063 NAME##int1, /* 32 __INT1 integer*1 */ \ 1064 __fort_red_unimplemented /* 33 __DERIVED derived type */ \ 1065 } 1066 1067 /* type list 2 with logical kind mask -- iall, iany, iparity, all, any, parity, 1068 * count */ 1069 1070 #define TYPELIST2LKN(NAME, N) \ 1071 { \ 1072 __fort_red_unimplemented, /* 0 __NONE no type */ \ 1073 __fort_red_unimplemented, /* 1 __SHORT short */ \ 1074 __fort_red_unimplemented, /* 2 __USHORT unsigned short */ \ 1075 __fort_red_unimplemented, /* 3 __CINT int */ \ 1076 __fort_red_unimplemented, /* 4 __UINT unsigned int */ \ 1077 __fort_red_unimplemented, /* 5 __LONG long */ \ 1078 __fort_red_unimplemented, /* 6 __ULONG unsigned long */ \ 1079 __fort_red_unimplemented, /* 7 __FLOAT float */ \ 1080 __fort_red_unimplemented, /* 8 __DOUBLE double */ \ 1081 __fort_red_unimplemented, /* 9 __CPLX8 float complex */ \ 1082 __fort_red_unimplemented, /* 10 __CPLX16 double complex */ \ 1083 __fort_red_unimplemented, /* 11 __CHAR char */ \ 1084 __fort_red_unimplemented, /* 12 __UCHAR unsigned char */ \ 1085 __fort_red_unimplemented, /* 13 __LONGDOUBLE long double */ \ 1086 __fort_red_unimplemented, /* 14 __STR string */ \ 1087 __fort_red_unimplemented, /* 15 __LONGLONG long long */ \ 1088 __fort_red_unimplemented, /* 16 __ULONGLONG unsigned long long */ \ 1089 NAME##log1##l##N, /* 17 __LOG1 logical*1 */ \ 1090 NAME##log2##l##N, /* 18 __LOG2 logical*2 */ \ 1091 NAME##log4##l##N, /* 19 __LOG4 logical*4 */ \ 1092 NAME##log8##l##N, /* 20 __LOG8 logical*8 */ \ 1093 __fort_red_unimplemented, /* 21 __WORD4 typeless */ \ 1094 __fort_red_unimplemented, /* 22 __WORD8 double typeless */ \ 1095 __fort_red_unimplemented, /* 23 __NCHAR ncharacter - kanji */ \ 1096 NAME##int2##l##N, /* 24 __INT2 integer*2 */ \ 1097 NAME##int4##l##N, /* 25 __INT4 integer*4 */ \ 1098 NAME##int8##l##N, /* 26 __INT8 integer*8 */ \ 1099 __fort_red_unimplemented, /* 27 __REAL4 real*4 */ \ 1100 __fort_red_unimplemented, /* 28 __REAL8 real*8 */ \ 1101 __fort_red_unimplemented, /* 29 __REAL16 real*16 */ \ 1102 __fort_red_unimplemented, /* 30 __CPLX32 complex*32 */ \ 1103 __fort_red_unimplemented, /* 31 __WORD16 quad typeless */ \ 1104 NAME##int1##l##N, /* 32 __INT1 integer*1 */ \ 1105 __fort_red_unimplemented /* 33 __DERIVED derived type */ \ 1106 } 1107 1108 /* type list 2 for all logical kind -- for sum, product */ 1109 1110 #define TYPELIST2LK(NAME) \ 1111 { \ 1112 TYPELIST2LKN(NAME, 1), \ 1113 TYPELIST2LKN(NAME, 2), \ 1114 TYPELIST2LKN(NAME, 4), \ 1115 TYPELIST2LKN(NAME, 8) \ 1116 } 1117 1118 /* type list 3 -- for maxval, minval, maxloc, minloc */ 1119 1120 #define TYPELIST3(NAME) \ 1121 { \ 1122 __fort_red_unimplemented, /* 0 __NONE no type */ \ 1123 __fort_red_unimplemented, /* 1 __SHORT short */ \ 1124 __fort_red_unimplemented, /* 2 __USHORT unsigned short */ \ 1125 __fort_red_unimplemented, /* 3 __CINT int */ \ 1126 __fort_red_unimplemented, /* 4 __UINT unsigned int */ \ 1127 __fort_red_unimplemented, /* 5 __LONG long */ \ 1128 __fort_red_unimplemented, /* 6 __ULONG unsigned long */ \ 1129 __fort_red_unimplemented, /* 7 __FLOAT float */ \ 1130 __fort_red_unimplemented, /* 8 __DOUBLE double */ \ 1131 __fort_red_unimplemented, /* 9 __CPLX8 float complex */ \ 1132 __fort_red_unimplemented, /* 10 __CPLX16 double complex */ \ 1133 __fort_red_unimplemented, /* 11 __CHAR char */ \ 1134 __fort_red_unimplemented, /* 12 __UCHAR unsigned char */ \ 1135 __fort_red_unimplemented, /* 13 __LONGDOUBLE long double */ \ 1136 NAME##str, /* 14 __STR string */ \ 1137 __fort_red_unimplemented, /* 15 __LONGLONG long long */ \ 1138 __fort_red_unimplemented, /* 16 __ULONGLONG unsigned long long */ \ 1139 __fort_red_unimplemented, /* 17 __LOG1 logical*1 */ \ 1140 __fort_red_unimplemented, /* 18 __LOG2 logical*2 */ \ 1141 __fort_red_unimplemented, /* 19 __LOG4 logical*4 */ \ 1142 __fort_red_unimplemented, /* 20 __LOG8 logical*8 */ \ 1143 __fort_red_unimplemented, /* 21 __WORD4 typeless */ \ 1144 __fort_red_unimplemented, /* 22 __WORD8 double typeless */ \ 1145 __fort_red_unimplemented, /* 23 __NCHAR ncharacter - kanji */ \ 1146 NAME##int2, /* 24 __INT2 integer*2 */ \ 1147 NAME##int4, /* 25 __INT4 integer*4 */ \ 1148 NAME##int8, /* 26 __INT8 integer*8 */ \ 1149 NAME##real4, /* 27 __REAL4 real*4 */ \ 1150 NAME##real8, /* 28 __REAL8 real*8 */ \ 1151 NAME##real16, /* 29 __REAL16 real*16 */ \ 1152 __fort_red_unimplemented, /* 30 __CPLX32 complex*32 */ \ 1153 __fort_red_unimplemented, /* 31 __WORD16 quad typeless */ \ 1154 NAME##int1, /* 32 __INT1 integer*1 */ \ 1155 __fort_red_unimplemented /* 33 __DERIVED derived type */ \ 1156 } 1157 1158 /* type list 3 with logical kind -- for maxval, minval, maxloc, minloc */ 1159 1160 #define TYPELIST3LKN(NAME, N) \ 1161 { \ 1162 __fort_red_unimplemented, /* 0 __NONE no type */ \ 1163 __fort_red_unimplemented, /* 1 __SHORT short */ \ 1164 __fort_red_unimplemented, /* 2 __USHORT unsigned short */ \ 1165 __fort_red_unimplemented, /* 3 __CINT int */ \ 1166 __fort_red_unimplemented, /* 4 __UINT unsigned int */ \ 1167 __fort_red_unimplemented, /* 5 __LONG long */ \ 1168 __fort_red_unimplemented, /* 6 __ULONG unsigned long */ \ 1169 __fort_red_unimplemented, /* 7 __FLOAT float */ \ 1170 __fort_red_unimplemented, /* 8 __DOUBLE double */ \ 1171 __fort_red_unimplemented, /* 9 __CPLX8 float complex */ \ 1172 __fort_red_unimplemented, /* 10 __CPLX16 double complex */ \ 1173 __fort_red_unimplemented, /* 11 __CHAR char */ \ 1174 __fort_red_unimplemented, /* 12 __UCHAR unsigned char */ \ 1175 __fort_red_unimplemented, /* 13 __LONGDOUBLE long double */ \ 1176 NAME##str##l##N, /* 14 __STR string */ \ 1177 __fort_red_unimplemented, /* 15 __LONGLONG long long */ \ 1178 __fort_red_unimplemented, /* 16 __ULONGLONG unsigned long long */ \ 1179 __fort_red_unimplemented, /* 17 __LOG1 logical*1 */ \ 1180 __fort_red_unimplemented, /* 18 __LOG2 logical*2 */ \ 1181 __fort_red_unimplemented, /* 19 __LOG4 logical*4 */ \ 1182 __fort_red_unimplemented, /* 20 __LOG8 logical*8 */ \ 1183 __fort_red_unimplemented, /* 21 __WORD4 typeless */ \ 1184 __fort_red_unimplemented, /* 22 __WORD8 double typeless */ \ 1185 __fort_red_unimplemented, /* 23 __NCHAR ncharacter - kanji */ \ 1186 NAME##int2##l##N, /* 24 __INT2 integer*2 */ \ 1187 NAME##int4##l##N, /* 25 __INT4 integer*4 */ \ 1188 NAME##int8##l##N, /* 26 __INT8 integer*8 */ \ 1189 NAME##real4##l##N, /* 27 __REAL4 real*4 */ \ 1190 NAME##real8##l##N, /* 28 __REAL8 real*8 */ \ 1191 NAME##real16##l##N, /* 29 __REAL16 real*16 */ \ 1192 __fort_red_unimplemented, /* 30 __CPLX32 complex*32 */ \ 1193 __fort_red_unimplemented, /* 31 __WORD16 quad typeless */ \ 1194 NAME##int1##l##N, /* 32 __INT1 integer*1 */ \ 1195 __fort_red_unimplemented /* 33 __DERIVED derived type */ \ 1196 } 1197 1198 /* type list 3 for all logical kind -- for maxval, minval, maxloc, minloc */ 1199 1200 #define TYPELIST3LK(NAME) \ 1201 { \ 1202 TYPELIST3LKN(NAME, 1), \ 1203 TYPELIST3LKN(NAME, 2), \ 1204 TYPELIST3LKN(NAME, 4), \ 1205 TYPELIST3LKN(NAME, 8) \ 1206 } 1207