1/* Helper function for cshift functions. 2 Copyright (C) 2008-2022 Free Software Foundation, Inc. 3 Contributed by Thomas Koenig <tkoenig@gcc.gnu.org> 4 5This file is part of the GNU Fortran runtime library (libgfortran). 6 7Libgfortran is free software; you can redistribute it and/or 8modify it under the terms of the GNU General Public 9License as published by the Free Software Foundation; either 10version 3 of the License, or (at your option) any later version. 11 12Libgfortran is distributed in the hope that it will be useful, 13but WITHOUT ANY WARRANTY; without even the implied warranty of 14MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15GNU General Public License for more details. 16 17Under Section 7 of GPL version 3, you are granted additional 18permissions described in the GCC Runtime Library Exception, version 193.1, as published by the Free Software Foundation. 20 21You should have received a copy of the GNU General Public License and 22a copy of the GCC Runtime Library Exception along with this program; 23see the files COPYING3 and COPYING.RUNTIME respectively. If not, see 24<http://www.gnu.org/licenses/>. */ 25 26#include "libgfortran.h" 27#include <string.h> 28 29 30#if defined (HAVE_GFC_REAL_17) 31 32void 33cshift0_r17 (gfc_array_r17 *ret, const gfc_array_r17 *array, ptrdiff_t shift, 34 int which) 35{ 36 /* r.* indicates the return array. */ 37 index_type rstride[GFC_MAX_DIMENSIONS]; 38 index_type rstride0; 39 index_type roffset; 40 GFC_REAL_17 *rptr; 41 42 /* s.* indicates the source array. */ 43 index_type sstride[GFC_MAX_DIMENSIONS]; 44 index_type sstride0; 45 index_type soffset; 46 const GFC_REAL_17 *sptr; 47 48 index_type count[GFC_MAX_DIMENSIONS]; 49 index_type extent[GFC_MAX_DIMENSIONS]; 50 index_type dim; 51 index_type len; 52 index_type n; 53 54 bool do_blocked; 55 index_type r_ex, a_ex; 56 57 which = which - 1; 58 sstride[0] = 0; 59 rstride[0] = 0; 60 61 extent[0] = 1; 62 count[0] = 0; 63 n = 0; 64 /* Initialized for avoiding compiler warnings. */ 65 roffset = 1; 66 soffset = 1; 67 len = 0; 68 69 r_ex = 1; 70 a_ex = 1; 71 72 if (which > 0) 73 { 74 /* Test if both ret and array are contiguous. */ 75 do_blocked = true; 76 dim = GFC_DESCRIPTOR_RANK (array); 77 for (n = 0; n < dim; n ++) 78 { 79 index_type rs, as; 80 rs = GFC_DESCRIPTOR_STRIDE (ret, n); 81 if (rs != r_ex) 82 { 83 do_blocked = false; 84 break; 85 } 86 as = GFC_DESCRIPTOR_STRIDE (array, n); 87 if (as != a_ex) 88 { 89 do_blocked = false; 90 break; 91 } 92 r_ex *= GFC_DESCRIPTOR_EXTENT (ret, n); 93 a_ex *= GFC_DESCRIPTOR_EXTENT (array, n); 94 } 95 } 96 else 97 do_blocked = false; 98 99 n = 0; 100 101 if (do_blocked) 102 { 103 /* For contiguous arrays, use the relationship that 104 105 dimension(n1,n2,n3) :: a, b 106 b = cshift(a,sh,3) 107 108 can be dealt with as if 109 110 dimension(n1*n2*n3) :: an, bn 111 bn = cshift(a,sh*n1*n2,1) 112 113 we can used a more blocked algorithm for dim>1. */ 114 sstride[0] = 1; 115 rstride[0] = 1; 116 roffset = 1; 117 soffset = 1; 118 len = GFC_DESCRIPTOR_STRIDE(array, which) 119 * GFC_DESCRIPTOR_EXTENT(array, which); 120 shift *= GFC_DESCRIPTOR_STRIDE(array, which); 121 for (dim = which + 1; dim < GFC_DESCRIPTOR_RANK (array); dim++) 122 { 123 count[n] = 0; 124 extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim); 125 rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim); 126 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,dim); 127 n++; 128 } 129 dim = GFC_DESCRIPTOR_RANK (array) - which; 130 } 131 else 132 { 133 for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++) 134 { 135 if (dim == which) 136 { 137 roffset = GFC_DESCRIPTOR_STRIDE(ret,dim); 138 if (roffset == 0) 139 roffset = 1; 140 soffset = GFC_DESCRIPTOR_STRIDE(array,dim); 141 if (soffset == 0) 142 soffset = 1; 143 len = GFC_DESCRIPTOR_EXTENT(array,dim); 144 } 145 else 146 { 147 count[n] = 0; 148 extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim); 149 rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim); 150 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,dim); 151 n++; 152 } 153 } 154 if (sstride[0] == 0) 155 sstride[0] = 1; 156 if (rstride[0] == 0) 157 rstride[0] = 1; 158 159 dim = GFC_DESCRIPTOR_RANK (array); 160 } 161 162 rstride0 = rstride[0]; 163 sstride0 = sstride[0]; 164 rptr = ret->base_addr; 165 sptr = array->base_addr; 166 167 /* Avoid the costly modulo for trivially in-bound shifts. */ 168 if (shift < 0 || shift >= len) 169 { 170 shift = len == 0 ? 0 : shift % (ptrdiff_t)len; 171 if (shift < 0) 172 shift += len; 173 } 174 175 while (rptr) 176 { 177 /* Do the shift for this dimension. */ 178 179 /* If elements are contiguous, perform the operation 180 in two block moves. */ 181 if (soffset == 1 && roffset == 1) 182 { 183 size_t len1 = shift * sizeof (GFC_REAL_17); 184 size_t len2 = (len - shift) * sizeof (GFC_REAL_17); 185 memcpy (rptr, sptr + shift, len2); 186 memcpy (rptr + (len - shift), sptr, len1); 187 } 188 else 189 { 190 /* Otherwise, we will have to perform the copy one element at 191 a time. */ 192 GFC_REAL_17 *dest = rptr; 193 const GFC_REAL_17 *src = &sptr[shift * soffset]; 194 195 for (n = 0; n < len - shift; n++) 196 { 197 *dest = *src; 198 dest += roffset; 199 src += soffset; 200 } 201 for (src = sptr, n = 0; n < shift; n++) 202 { 203 *dest = *src; 204 dest += roffset; 205 src += soffset; 206 } 207 } 208 209 /* Advance to the next section. */ 210 rptr += rstride0; 211 sptr += sstride0; 212 count[0]++; 213 n = 0; 214 while (count[n] == extent[n]) 215 { 216 /* When we get to the end of a dimension, reset it and increment 217 the next dimension. */ 218 count[n] = 0; 219 /* We could precalculate these products, but this is a less 220 frequently used path so probably not worth it. */ 221 rptr -= rstride[n] * extent[n]; 222 sptr -= sstride[n] * extent[n]; 223 n++; 224 if (n >= dim - 1) 225 { 226 /* Break out of the loop. */ 227 rptr = NULL; 228 break; 229 } 230 else 231 { 232 count[n]++; 233 rptr += rstride[n]; 234 sptr += sstride[n]; 235 } 236 } 237 } 238 239 return; 240} 241 242#endif 243