1*b1e83836Smrg /* Helper function for repacking arrays.
2*b1e83836Smrg Copyright (C) 2003-2022 Free Software Foundation, Inc.
3*b1e83836Smrg Contributed by Paul Brook <paul@nowt.org>
4*b1e83836Smrg
5*b1e83836Smrg This file is part of the GNU Fortran runtime library (libgfortran).
6*b1e83836Smrg
7*b1e83836Smrg Libgfortran is free software; you can redistribute it and/or
8*b1e83836Smrg modify it under the terms of the GNU General Public
9*b1e83836Smrg License as published by the Free Software Foundation; either
10*b1e83836Smrg version 3 of the License, or (at your option) any later version.
11*b1e83836Smrg
12*b1e83836Smrg Libgfortran is distributed in the hope that it will be useful,
13*b1e83836Smrg but WITHOUT ANY WARRANTY; without even the implied warranty of
14*b1e83836Smrg MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15*b1e83836Smrg GNU General Public License for more details.
16*b1e83836Smrg
17*b1e83836Smrg Under Section 7 of GPL version 3, you are granted additional
18*b1e83836Smrg permissions described in the GCC Runtime Library Exception, version
19*b1e83836Smrg 3.1, as published by the Free Software Foundation.
20*b1e83836Smrg
21*b1e83836Smrg You should have received a copy of the GNU General Public License and
22*b1e83836Smrg a copy of the GCC Runtime Library Exception along with this program;
23*b1e83836Smrg see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
24*b1e83836Smrg <http://www.gnu.org/licenses/>. */
25*b1e83836Smrg
26*b1e83836Smrg #include "libgfortran.h"
27*b1e83836Smrg #include <string.h>
28*b1e83836Smrg
29*b1e83836Smrg
30*b1e83836Smrg #if defined (HAVE_GFC_REAL_17)
31*b1e83836Smrg
32*b1e83836Smrg void
internal_unpack_r17(gfc_array_r17 * d,const GFC_REAL_17 * src)33*b1e83836Smrg internal_unpack_r17 (gfc_array_r17 * d, const GFC_REAL_17 * src)
34*b1e83836Smrg {
35*b1e83836Smrg index_type count[GFC_MAX_DIMENSIONS];
36*b1e83836Smrg index_type extent[GFC_MAX_DIMENSIONS];
37*b1e83836Smrg index_type stride[GFC_MAX_DIMENSIONS];
38*b1e83836Smrg index_type stride0;
39*b1e83836Smrg index_type dim;
40*b1e83836Smrg index_type dsize;
41*b1e83836Smrg GFC_REAL_17 * restrict dest;
42*b1e83836Smrg
43*b1e83836Smrg dest = d->base_addr;
44*b1e83836Smrg if (src == dest || !src)
45*b1e83836Smrg return;
46*b1e83836Smrg
47*b1e83836Smrg dim = GFC_DESCRIPTOR_RANK (d);
48*b1e83836Smrg dsize = 1;
49*b1e83836Smrg for (index_type n = 0; n < dim; n++)
50*b1e83836Smrg {
51*b1e83836Smrg count[n] = 0;
52*b1e83836Smrg stride[n] = GFC_DESCRIPTOR_STRIDE(d,n);
53*b1e83836Smrg extent[n] = GFC_DESCRIPTOR_EXTENT(d,n);
54*b1e83836Smrg if (extent[n] <= 0)
55*b1e83836Smrg return;
56*b1e83836Smrg
57*b1e83836Smrg if (dsize == stride[n])
58*b1e83836Smrg dsize *= extent[n];
59*b1e83836Smrg else
60*b1e83836Smrg dsize = 0;
61*b1e83836Smrg }
62*b1e83836Smrg
63*b1e83836Smrg if (dsize != 0)
64*b1e83836Smrg {
65*b1e83836Smrg memcpy (dest, src, dsize * sizeof (GFC_REAL_17));
66*b1e83836Smrg return;
67*b1e83836Smrg }
68*b1e83836Smrg
69*b1e83836Smrg stride0 = stride[0];
70*b1e83836Smrg
71*b1e83836Smrg while (dest)
72*b1e83836Smrg {
73*b1e83836Smrg /* Copy the data. */
74*b1e83836Smrg *dest = *(src++);
75*b1e83836Smrg /* Advance to the next element. */
76*b1e83836Smrg dest += stride0;
77*b1e83836Smrg count[0]++;
78*b1e83836Smrg /* Advance to the next source element. */
79*b1e83836Smrg index_type n = 0;
80*b1e83836Smrg while (count[n] == extent[n])
81*b1e83836Smrg {
82*b1e83836Smrg /* When we get to the end of a dimension, reset it and increment
83*b1e83836Smrg the next dimension. */
84*b1e83836Smrg count[n] = 0;
85*b1e83836Smrg /* We could precalculate these products, but this is a less
86*b1e83836Smrg frequently used path so probably not worth it. */
87*b1e83836Smrg dest -= stride[n] * extent[n];
88*b1e83836Smrg n++;
89*b1e83836Smrg if (n == dim)
90*b1e83836Smrg {
91*b1e83836Smrg dest = NULL;
92*b1e83836Smrg break;
93*b1e83836Smrg }
94*b1e83836Smrg else
95*b1e83836Smrg {
96*b1e83836Smrg count[n]++;
97*b1e83836Smrg dest += stride[n];
98*b1e83836Smrg }
99*b1e83836Smrg }
100*b1e83836Smrg }
101*b1e83836Smrg }
102*b1e83836Smrg
103*b1e83836Smrg #endif
104*b1e83836Smrg
105