1/* Implementation of the CSHIFT intrinsic. 2 Copyright (C) 2017-2022 Free Software Foundation, Inc. 3 Contributed by Thomas Koenig <tkoenig@gcc.gnu.org> 4 5This file is part of the GNU Fortran 95 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#if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_INTEGER_16) 30 31void 32cshift1_16_r10 (gfc_array_r10 * const restrict ret, 33 const gfc_array_r10 * const restrict array, 34 const gfc_array_i16 * const restrict h, 35 const GFC_INTEGER_16 * const restrict pwhich) 36{ 37 /* r.* indicates the return array. */ 38 index_type rstride[GFC_MAX_DIMENSIONS]; 39 index_type rstride0; 40 index_type roffset; 41 GFC_REAL_10 *rptr; 42 GFC_REAL_10 *dest; 43 /* s.* indicates the source array. */ 44 index_type sstride[GFC_MAX_DIMENSIONS]; 45 index_type sstride0; 46 index_type soffset; 47 const GFC_REAL_10 *sptr; 48 const GFC_REAL_10 *src; 49 /* h.* indicates the shift array. */ 50 index_type hstride[GFC_MAX_DIMENSIONS]; 51 index_type hstride0; 52 const GFC_INTEGER_16 *hptr; 53 54 index_type count[GFC_MAX_DIMENSIONS]; 55 index_type extent[GFC_MAX_DIMENSIONS]; 56 index_type rs_ex[GFC_MAX_DIMENSIONS]; 57 index_type ss_ex[GFC_MAX_DIMENSIONS]; 58 index_type hs_ex[GFC_MAX_DIMENSIONS]; 59 60 index_type dim; 61 index_type len; 62 index_type n; 63 int which; 64 GFC_INTEGER_16 sh; 65 66 /* Bounds checking etc is already done by the caller. */ 67 68 if (pwhich) 69 which = *pwhich - 1; 70 else 71 which = 0; 72 73 extent[0] = 1; 74 count[0] = 0; 75 n = 0; 76 77 /* Initialized for avoiding compiler warnings. */ 78 roffset = 1; 79 soffset = 1; 80 len = 0; 81 82 for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++) 83 { 84 if (dim == which) 85 { 86 roffset = GFC_DESCRIPTOR_STRIDE(ret,dim); 87 if (roffset == 0) 88 roffset = 1; 89 soffset = GFC_DESCRIPTOR_STRIDE(array,dim); 90 if (soffset == 0) 91 soffset = 1; 92 len = GFC_DESCRIPTOR_EXTENT(array,dim); 93 } 94 else 95 { 96 count[n] = 0; 97 extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim); 98 rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim); 99 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,dim); 100 hstride[n] = GFC_DESCRIPTOR_STRIDE(h,n); 101 rs_ex[n] = rstride[n] * extent[n]; 102 ss_ex[n] = sstride[n] * extent[n]; 103 hs_ex[n] = hstride[n] * extent[n]; 104 n++; 105 } 106 } 107 if (sstride[0] == 0) 108 sstride[0] = 1; 109 if (rstride[0] == 0) 110 rstride[0] = 1; 111 if (hstride[0] == 0) 112 hstride[0] = 1; 113 114 dim = GFC_DESCRIPTOR_RANK (array); 115 rstride0 = rstride[0]; 116 sstride0 = sstride[0]; 117 hstride0 = hstride[0]; 118 rptr = ret->base_addr; 119 sptr = array->base_addr; 120 hptr = h->base_addr; 121 122 while (rptr) 123 { 124 /* Do the shift for this dimension. */ 125 sh = *hptr; 126 /* Normal case should be -len < sh < len; try to 127 avoid the expensive remainder operation if possible. */ 128 if (sh < 0) 129 sh += len; 130 if (unlikely(sh >= len || sh < 0)) 131 { 132 sh = sh % len; 133 if (sh < 0) 134 sh += len; 135 } 136 src = &sptr[sh * soffset]; 137 dest = rptr; 138 if (soffset == 1 && roffset == 1) 139 { 140 size_t len1 = sh * sizeof (GFC_REAL_10); 141 size_t len2 = (len - sh) * sizeof (GFC_REAL_10); 142 memcpy (rptr, sptr + sh, len2); 143 memcpy (rptr + (len - sh), sptr, len1); 144 } 145 else 146 { 147 for (n = 0; n < len - sh; n++) 148 { 149 *dest = *src; 150 dest += roffset; 151 src += soffset; 152 } 153 for (src = sptr, n = 0; n < sh; n++) 154 { 155 *dest = *src; 156 dest += roffset; 157 src += soffset; 158 } 159 } 160 161 /* Advance to the next section. */ 162 rptr += rstride0; 163 sptr += sstride0; 164 hptr += hstride0; 165 count[0]++; 166 n = 0; 167 while (count[n] == extent[n]) 168 { 169 /* When we get to the end of a dimension, reset it and increment 170 the next dimension. */ 171 count[n] = 0; 172 rptr -= rs_ex[n]; 173 sptr -= ss_ex[n]; 174 hptr -= hs_ex[n]; 175 n++; 176 if (n >= dim - 1) 177 { 178 /* Break out of the loop. */ 179 rptr = NULL; 180 break; 181 } 182 else 183 { 184 count[n]++; 185 rptr += rstride[n]; 186 sptr += sstride[n]; 187 hptr += hstride[n]; 188 } 189 } 190 } 191} 192 193#endif 194