OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [libgfortran/] [generated/] [maxloc1_16_r4.c] - Blame information for rev 733

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 733 jeremybenn
/* Implementation of the MAXLOC intrinsic
2
   Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc.
3
   Contributed by Paul Brook <paul@nowt.org>
4
 
5
This file is part of the GNU Fortran runtime library (libgfortran).
6
 
7
Libgfortran is free software; you can redistribute it and/or
8
modify it under the terms of the GNU General Public
9
License as published by the Free Software Foundation; either
10
version 3 of the License, or (at your option) any later version.
11
 
12
Libgfortran is distributed in the hope that it will be useful,
13
but WITHOUT ANY WARRANTY; without even the implied warranty of
14
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15
GNU General Public License for more details.
16
 
17
Under Section 7 of GPL version 3, you are granted additional
18
permissions described in the GCC Runtime Library Exception, version
19
3.1, as published by the Free Software Foundation.
20
 
21
You should have received a copy of the GNU General Public License and
22
a copy of the GCC Runtime Library Exception along with this program;
23
see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
24
<http://www.gnu.org/licenses/>.  */
25
 
26
#include "libgfortran.h"
27
#include <stdlib.h>
28
#include <assert.h>
29
#include <limits.h>
30
 
31
 
32
#if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_INTEGER_16)
33
 
34
 
35
extern void maxloc1_16_r4 (gfc_array_i16 * const restrict,
36
        gfc_array_r4 * const restrict, const index_type * const restrict);
37
export_proto(maxloc1_16_r4);
38
 
39
void
40
maxloc1_16_r4 (gfc_array_i16 * const restrict retarray,
41
        gfc_array_r4 * const restrict array,
42
        const index_type * const restrict pdim)
43
{
44
  index_type count[GFC_MAX_DIMENSIONS];
45
  index_type extent[GFC_MAX_DIMENSIONS];
46
  index_type sstride[GFC_MAX_DIMENSIONS];
47
  index_type dstride[GFC_MAX_DIMENSIONS];
48
  const GFC_REAL_4 * restrict base;
49
  GFC_INTEGER_16 * restrict dest;
50
  index_type rank;
51
  index_type n;
52
  index_type len;
53
  index_type delta;
54
  index_type dim;
55
  int continue_loop;
56
 
57
  /* Make dim zero based to avoid confusion.  */
58
  dim = (*pdim) - 1;
59
  rank = GFC_DESCRIPTOR_RANK (array) - 1;
60
 
61
  len = GFC_DESCRIPTOR_EXTENT(array,dim);
62
  if (len < 0)
63
    len = 0;
64
  delta = GFC_DESCRIPTOR_STRIDE(array,dim);
65
 
66
  for (n = 0; n < dim; n++)
67
    {
68
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
69
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
70
 
71
      if (extent[n] < 0)
72
        extent[n] = 0;
73
    }
74
  for (n = dim; n < rank; n++)
75
    {
76
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
77
      extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
78
 
79
      if (extent[n] < 0)
80
        extent[n] = 0;
81
    }
82
 
83
  if (retarray->data == NULL)
84
    {
85
      size_t alloc_size, str;
86
 
87
      for (n = 0; n < rank; n++)
88
        {
89
          if (n == 0)
90
            str = 1;
91
          else
92
            str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
93
 
94
          GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
95
 
96
        }
97
 
98
      retarray->offset = 0;
99
      retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
100
 
101
      alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
102
                   * extent[rank-1];
103
 
104
      retarray->data = internal_malloc_size (alloc_size);
105
      if (alloc_size == 0)
106
        {
107
          /* Make sure we have a zero-sized array.  */
108
          GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
109
          return;
110
 
111
        }
112
    }
113
  else
114
    {
115
      if (rank != GFC_DESCRIPTOR_RANK (retarray))
116
        runtime_error ("rank of return array incorrect in"
117
                       " MAXLOC intrinsic: is %ld, should be %ld",
118
                       (long int) (GFC_DESCRIPTOR_RANK (retarray)),
119
                       (long int) rank);
120
 
121
      if (unlikely (compile_options.bounds_check))
122
        bounds_ifunction_return ((array_t *) retarray, extent,
123
                                 "return value", "MAXLOC");
124
    }
125
 
126
  for (n = 0; n < rank; n++)
127
    {
128
      count[n] = 0;
129
      dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
130
      if (extent[n] <= 0)
131
        return;
132
    }
133
 
134
  base = array->data;
135
  dest = retarray->data;
136
 
137
  continue_loop = 1;
138
  while (continue_loop)
139
    {
140
      const GFC_REAL_4 * restrict src;
141
      GFC_INTEGER_16 result;
142
      src = base;
143
      {
144
 
145
        GFC_REAL_4 maxval;
146
#if defined (GFC_REAL_4_INFINITY)
147
        maxval = -GFC_REAL_4_INFINITY;
148
#else
149
        maxval = -GFC_REAL_4_HUGE;
150
#endif
151
        result = 1;
152
        if (len <= 0)
153
          *dest = 0;
154
        else
155
          {
156
            for (n = 0; n < len; n++, src += delta)
157
              {
158
 
159
#if defined (GFC_REAL_4_QUIET_NAN)
160
                if (*src >= maxval)
161
                  {
162
                    maxval = *src;
163
                    result = (GFC_INTEGER_16)n + 1;
164
                    break;
165
                  }
166
              }
167
            for (; n < len; n++, src += delta)
168
              {
169
#endif
170
                if (*src > maxval)
171
                  {
172
                    maxval = *src;
173
                    result = (GFC_INTEGER_16)n + 1;
174
                  }
175
              }
176
 
177
            *dest = result;
178
          }
179
      }
180
      /* Advance to the next element.  */
181
      count[0]++;
182
      base += sstride[0];
183
      dest += dstride[0];
184
      n = 0;
185
      while (count[n] == extent[n])
186
        {
187
          /* When we get to the end of a dimension, reset it and increment
188
             the next dimension.  */
189
          count[n] = 0;
190
          /* We could precalculate these products, but this is a less
191
             frequently used path so probably not worth it.  */
192
          base -= sstride[n] * extent[n];
193
          dest -= dstride[n] * extent[n];
194
          n++;
195
          if (n == rank)
196
            {
197
              /* Break out of the look.  */
198
              continue_loop = 0;
199
              break;
200
            }
201
          else
202
            {
203
              count[n]++;
204
              base += sstride[n];
205
              dest += dstride[n];
206
            }
207
        }
208
    }
209
}
210
 
211
 
212
extern void mmaxloc1_16_r4 (gfc_array_i16 * const restrict,
213
        gfc_array_r4 * const restrict, const index_type * const restrict,
214
        gfc_array_l1 * const restrict);
215
export_proto(mmaxloc1_16_r4);
216
 
217
void
218
mmaxloc1_16_r4 (gfc_array_i16 * const restrict retarray,
219
        gfc_array_r4 * const restrict array,
220
        const index_type * const restrict pdim,
221
        gfc_array_l1 * const restrict mask)
222
{
223
  index_type count[GFC_MAX_DIMENSIONS];
224
  index_type extent[GFC_MAX_DIMENSIONS];
225
  index_type sstride[GFC_MAX_DIMENSIONS];
226
  index_type dstride[GFC_MAX_DIMENSIONS];
227
  index_type mstride[GFC_MAX_DIMENSIONS];
228
  GFC_INTEGER_16 * restrict dest;
229
  const GFC_REAL_4 * restrict base;
230
  const GFC_LOGICAL_1 * restrict mbase;
231
  int rank;
232
  int dim;
233
  index_type n;
234
  index_type len;
235
  index_type delta;
236
  index_type mdelta;
237
  int mask_kind;
238
 
239
  dim = (*pdim) - 1;
240
  rank = GFC_DESCRIPTOR_RANK (array) - 1;
241
 
242
  len = GFC_DESCRIPTOR_EXTENT(array,dim);
243
  if (len <= 0)
244
    return;
245
 
246
  mbase = mask->data;
247
 
248
  mask_kind = GFC_DESCRIPTOR_SIZE (mask);
249
 
250
  if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
251
#ifdef HAVE_GFC_LOGICAL_16
252
      || mask_kind == 16
253
#endif
254
      )
255
    mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
256
  else
257
    runtime_error ("Funny sized logical array");
258
 
259
  delta = GFC_DESCRIPTOR_STRIDE(array,dim);
260
  mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
261
 
262
  for (n = 0; n < dim; n++)
263
    {
264
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
265
      mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
266
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
267
 
268
      if (extent[n] < 0)
269
        extent[n] = 0;
270
 
271
    }
272
  for (n = dim; n < rank; n++)
273
    {
274
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
275
      mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
276
      extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
277
 
278
      if (extent[n] < 0)
279
        extent[n] = 0;
280
    }
281
 
282
  if (retarray->data == NULL)
283
    {
284
      size_t alloc_size, str;
285
 
286
      for (n = 0; n < rank; n++)
287
        {
288
          if (n == 0)
289
            str = 1;
290
          else
291
            str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
292
 
293
          GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
294
 
295
        }
296
 
297
      alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
298
                   * extent[rank-1];
299
 
300
      retarray->offset = 0;
301
      retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
302
 
303
      if (alloc_size == 0)
304
        {
305
          /* Make sure we have a zero-sized array.  */
306
          GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
307
          return;
308
        }
309
      else
310
        retarray->data = internal_malloc_size (alloc_size);
311
 
312
    }
313
  else
314
    {
315
      if (rank != GFC_DESCRIPTOR_RANK (retarray))
316
        runtime_error ("rank of return array incorrect in MAXLOC intrinsic");
317
 
318
      if (unlikely (compile_options.bounds_check))
319
        {
320
          bounds_ifunction_return ((array_t *) retarray, extent,
321
                                   "return value", "MAXLOC");
322
          bounds_equal_extents ((array_t *) mask, (array_t *) array,
323
                                "MASK argument", "MAXLOC");
324
        }
325
    }
326
 
327
  for (n = 0; n < rank; n++)
328
    {
329
      count[n] = 0;
330
      dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
331
      if (extent[n] <= 0)
332
        return;
333
    }
334
 
335
  dest = retarray->data;
336
  base = array->data;
337
 
338
  while (base)
339
    {
340
      const GFC_REAL_4 * restrict src;
341
      const GFC_LOGICAL_1 * restrict msrc;
342
      GFC_INTEGER_16 result;
343
      src = base;
344
      msrc = mbase;
345
      {
346
 
347
        GFC_REAL_4 maxval;
348
#if defined (GFC_REAL_4_INFINITY)
349
        maxval = -GFC_REAL_4_INFINITY;
350
#else
351
        maxval = -GFC_REAL_4_HUGE;
352
#endif
353
#if defined (GFC_REAL_4_QUIET_NAN)
354
        GFC_INTEGER_16 result2 = 0;
355
#endif
356
        result = 0;
357
        if (len <= 0)
358
          *dest = 0;
359
        else
360
          {
361
            for (n = 0; n < len; n++, src += delta, msrc += mdelta)
362
              {
363
 
364
                if (*msrc)
365
                  {
366
#if defined (GFC_REAL_4_QUIET_NAN)
367
                    if (!result2)
368
                      result2 = (GFC_INTEGER_16)n + 1;
369
                    if (*src >= maxval)
370
#endif
371
                      {
372
                        maxval = *src;
373
                        result = (GFC_INTEGER_16)n + 1;
374
                        break;
375
                      }
376
                  }
377
              }
378
#if defined (GFC_REAL_4_QUIET_NAN)
379
            if (unlikely (n >= len))
380
              result = result2;
381
            else
382
#endif
383
            for (; n < len; n++, src += delta, msrc += mdelta)
384
              {
385
                if (*msrc && *src > maxval)
386
                  {
387
                    maxval = *src;
388
                    result = (GFC_INTEGER_16)n + 1;
389
                  }
390
              }
391
            *dest = result;
392
          }
393
      }
394
      /* Advance to the next element.  */
395
      count[0]++;
396
      base += sstride[0];
397
      mbase += mstride[0];
398
      dest += dstride[0];
399
      n = 0;
400
      while (count[n] == extent[n])
401
        {
402
          /* When we get to the end of a dimension, reset it and increment
403
             the next dimension.  */
404
          count[n] = 0;
405
          /* We could precalculate these products, but this is a less
406
             frequently used path so probably not worth it.  */
407
          base -= sstride[n] * extent[n];
408
          mbase -= mstride[n] * extent[n];
409
          dest -= dstride[n] * extent[n];
410
          n++;
411
          if (n == rank)
412
            {
413
              /* Break out of the look.  */
414
              base = NULL;
415
              break;
416
            }
417
          else
418
            {
419
              count[n]++;
420
              base += sstride[n];
421
              mbase += mstride[n];
422
              dest += dstride[n];
423
            }
424
        }
425
    }
426
}
427
 
428
 
429
extern void smaxloc1_16_r4 (gfc_array_i16 * const restrict,
430
        gfc_array_r4 * const restrict, const index_type * const restrict,
431
        GFC_LOGICAL_4 *);
432
export_proto(smaxloc1_16_r4);
433
 
434
void
435
smaxloc1_16_r4 (gfc_array_i16 * const restrict retarray,
436
        gfc_array_r4 * const restrict array,
437
        const index_type * const restrict pdim,
438
        GFC_LOGICAL_4 * mask)
439
{
440
  index_type count[GFC_MAX_DIMENSIONS];
441
  index_type extent[GFC_MAX_DIMENSIONS];
442
  index_type dstride[GFC_MAX_DIMENSIONS];
443
  GFC_INTEGER_16 * restrict dest;
444
  index_type rank;
445
  index_type n;
446
  index_type dim;
447
 
448
 
449
  if (*mask)
450
    {
451
      maxloc1_16_r4 (retarray, array, pdim);
452
      return;
453
    }
454
  /* Make dim zero based to avoid confusion.  */
455
  dim = (*pdim) - 1;
456
  rank = GFC_DESCRIPTOR_RANK (array) - 1;
457
 
458
  for (n = 0; n < dim; n++)
459
    {
460
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
461
 
462
      if (extent[n] <= 0)
463
        extent[n] = 0;
464
    }
465
 
466
  for (n = dim; n < rank; n++)
467
    {
468
      extent[n] =
469
        GFC_DESCRIPTOR_EXTENT(array,n + 1);
470
 
471
      if (extent[n] <= 0)
472
        extent[n] = 0;
473
    }
474
 
475
  if (retarray->data == NULL)
476
    {
477
      size_t alloc_size, str;
478
 
479
      for (n = 0; n < rank; n++)
480
        {
481
          if (n == 0)
482
            str = 1;
483
          else
484
            str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
485
 
486
          GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
487
 
488
        }
489
 
490
      retarray->offset = 0;
491
      retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
492
 
493
      alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
494
                   * extent[rank-1];
495
 
496
      if (alloc_size == 0)
497
        {
498
          /* Make sure we have a zero-sized array.  */
499
          GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
500
          return;
501
        }
502
      else
503
        retarray->data = internal_malloc_size (alloc_size);
504
    }
505
  else
506
    {
507
      if (rank != GFC_DESCRIPTOR_RANK (retarray))
508
        runtime_error ("rank of return array incorrect in"
509
                       " MAXLOC intrinsic: is %ld, should be %ld",
510
                       (long int) (GFC_DESCRIPTOR_RANK (retarray)),
511
                       (long int) rank);
512
 
513
      if (unlikely (compile_options.bounds_check))
514
        {
515
          for (n=0; n < rank; n++)
516
            {
517
              index_type ret_extent;
518
 
519
              ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
520
              if (extent[n] != ret_extent)
521
                runtime_error ("Incorrect extent in return value of"
522
                               " MAXLOC intrinsic in dimension %ld:"
523
                               " is %ld, should be %ld", (long int) n + 1,
524
                               (long int) ret_extent, (long int) extent[n]);
525
            }
526
        }
527
    }
528
 
529
  for (n = 0; n < rank; n++)
530
    {
531
      count[n] = 0;
532
      dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
533
    }
534
 
535
  dest = retarray->data;
536
 
537
  while(1)
538
    {
539
      *dest = 0;
540
      count[0]++;
541
      dest += dstride[0];
542
      n = 0;
543
      while (count[n] == extent[n])
544
        {
545
          /* When we get to the end of a dimension, reset it and increment
546
             the next dimension.  */
547
          count[n] = 0;
548
          /* We could precalculate these products, but this is a less
549
             frequently used path so probably not worth it.  */
550
          dest -= dstride[n] * extent[n];
551
          n++;
552
          if (n == rank)
553
            return;
554
          else
555
            {
556
              count[n]++;
557
              dest += dstride[n];
558
            }
559
        }
560
    }
561
}
562
 
563
#endif

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.