libgfortran/intrinsics/unpack_generic.c

   1 /* Generic implementation of the UNPACK intrinsic
   2    Copyright 2002, 2003, 2004, 2005, 2007, 2009 Free Software Foundation, Inc.
   3    Contributed by Paul Brook <paul@nowt.org>
   4
   5 This file is part of the GNU Fortran 95 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 Ligbfortran 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 <string.h>
  30
  31 /* All the bounds checking for unpack in one function.  If field is NULL,
  32    we don't check it, for the unpack0 functions.  */
  33
  34 static void
  35 unpack_bounds (gfc_array_char *ret, const gfc_array_char *vector,
  36          const gfc_array_l1 *mask, const gfc_array_char *field)
  37 {
  38   index_type vec_size, mask_count;
  39   vec_size = size0 ((array_t *) vector);
  40   mask_count = count_0 (mask);
  41   if (vec_size < mask_count)
  42     runtime_error ("Incorrect size of return value in UNPACK"
  43                    " intrinsic: should be at least %ld, is"
  44                    " %ld", (long int) mask_count,
  45                    (long int) vec_size);
  46
  47   if (field != NULL)
  48     bounds_equal_extents ((array_t *) field, (array_t *) mask,
  49                           "FIELD", "UNPACK");
  50
  51   if (ret->data != NULL)
  52     bounds_equal_extents ((array_t *) ret, (array_t *) mask,
  53                           "return value", "UNPACK");
  54
  55 }
  56
  57 static void
  58 unpack_internal (gfc_array_char *ret, const gfc_array_char *vector,
  59                  const gfc_array_l1 *mask, const gfc_array_char *field,
  60                  index_type size, index_type fsize)
  61 {
  62   /* r.* indicates the return array.  */
  63   index_type rstride[GFC_MAX_DIMENSIONS];
  64   index_type rstride0;
  65   index_type rs;
  66   char * restrict rptr;
  67   /* v.* indicates the vector array.  */
  68   index_type vstride0;
  69   char *vptr;
  70   /* f.* indicates the field array.  */
  71   index_type fstride[GFC_MAX_DIMENSIONS];
  72   index_type fstride0;
  73   const char *fptr;
  74   /* m.* indicates the mask array.  */
  75   index_type mstride[GFC_MAX_DIMENSIONS];
  76   index_type mstride0;
  77   const GFC_LOGICAL_1 *mptr;
  78
  79   index_type count[GFC_MAX_DIMENSIONS];
  80   index_type extent[GFC_MAX_DIMENSIONS];
  81   index_type n;
  82   index_type dim;
  83
  84   int empty;
  85   int mask_kind;
  86
  87   empty = 0;
  88
  89   mptr = mask->data;
  90
  91   /* Use the same loop for all logical types, by using GFC_LOGICAL_1
  92      and using shifting to address size and endian issues.  */
  93
  94   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
  95
  96   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
  97 #ifdef HAVE_GFC_LOGICAL_16
  98       || mask_kind == 16
  99 #endif
 100       )
 101     {
 102       /*  Don't convert a NULL pointer as we use test for NULL below.  */
 103       if (mptr)
 104         mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind);
 105     }
 106   else
 107     runtime_error ("Funny sized logical array");
 108
 109   if (ret->data == NULL)
 110     {
 111       /* The front end has signalled that we need to populate the
 112          return array descriptor.  */
 113       dim = GFC_DESCRIPTOR_RANK (mask);
 114       rs = 1;
 115       for (n = 0; n < dim; n++)
 116         {
 117           count[n] = 0;
 118           GFC_DIMENSION_SET(ret->dim[n], 0,
 119                             GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs);
 120           extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
 121           empty = empty || extent[n] <= 0;
 122           rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret, n);
 123           fstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(field, n);
 124           mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n);
 125           rs *= extent[n];
 126         }
 127       ret->offset = 0;
 128       ret->data = internal_malloc_size (rs * size);
 129     }
 130   else
 131     {
 132       dim = GFC_DESCRIPTOR_RANK (ret);
 133       for (n = 0; n < dim; n++)
 134         {
 135           count[n] = 0;
 136           extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
 137           empty = empty || extent[n] <= 0;
 138           rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret, n);
 139           fstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(field, n);
 140           mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n);
 141         }
 142     }
 143
 144   if (empty)
 145     return;
 146
 147   vstride0 = GFC_DESCRIPTOR_STRIDE_BYTES(vector,0);
 148   rstride0 = rstride[0];
 149   fstride0 = fstride[0];
 150   mstride0 = mstride[0];
 151   rptr = ret->data;
 152   fptr = field->data;
 153   vptr = vector->data;
 154
 155   while (rptr)
 156     {
 157       if (*mptr)
 158         {
 159           /* From vector.  */
 160           memcpy (rptr, vptr, size);
 161           vptr += vstride0;
 162         }
 163       else
 164         {
 165           /* From field.  */
 166           memcpy (rptr, fptr, size);
 167         }
 168       /* Advance to the next element.  */
 169       rptr += rstride0;
 170       fptr += fstride0;
 171       mptr += mstride0;
 172       count[0]++;
 173       n = 0;
 174       while (count[n] == extent[n])
 175         {
 176           /* When we get to the end of a dimension, reset it and increment
 177              the next dimension.  */
 178           count[n] = 0;
 179           /* We could precalculate these products, but this is a less
 180              frequently used path so probably not worth it.  */
 181           rptr -= rstride[n] * extent[n];
 182           fptr -= fstride[n] * extent[n];
 183           mptr -= mstride[n] * extent[n];
 184           n++;
 185           if (n >= dim)
 186             {
 187               /* Break out of the loop.  */
 188               rptr = NULL;
 189               break;
 190             }
 191           else
 192             {
 193               count[n]++;
 194               rptr += rstride[n];
 195               fptr += fstride[n];
 196               mptr += mstride[n];
 197             }
 198         }
 199     }
 200 }
 201
 202 extern void unpack1 (gfc_array_char *, const gfc_array_char *,
 203                      const gfc_array_l1 *, const gfc_array_char *);
 204 export_proto(unpack1);
 205
 206 void
 207 unpack1 (gfc_array_char *ret, const gfc_array_char *vector,
 208          const gfc_array_l1 *mask, const gfc_array_char *field)
 209 {
 210   index_type type_size;
 211   index_type size;
 212
 213   if (unlikely(compile_options.bounds_check))
 214     unpack_bounds (ret, vector, mask, field);
 215
 216   type_size = GFC_DTYPE_TYPE_SIZE (vector);
 217   size = GFC_DESCRIPTOR_SIZE (vector);
 218
 219   switch(type_size)
 220     {
 221     case GFC_DTYPE_LOGICAL_1:
 222     case GFC_DTYPE_INTEGER_1:
 223     case GFC_DTYPE_DERIVED_1:
 224       unpack1_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) vector,
 225                   mask, (gfc_array_i1 *) field);
 226       return;
 227
 228     case GFC_DTYPE_LOGICAL_2:
 229     case GFC_DTYPE_INTEGER_2:
 230       unpack1_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector,
 231                   mask, (gfc_array_i2 *) field);
 232       return;
 233
 234     case GFC_DTYPE_LOGICAL_4:
 235     case GFC_DTYPE_INTEGER_4:
 236       unpack1_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector,
 237                   mask, (gfc_array_i4 *) field);
 238       return;
 239
 240     case GFC_DTYPE_LOGICAL_8:
 241     case GFC_DTYPE_INTEGER_8:
 242       unpack1_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector,
 243                   mask, (gfc_array_i8 *) field);
 244       return;
 245
 246 #ifdef HAVE_GFC_INTEGER_16
 247     case GFC_DTYPE_LOGICAL_16:
 248     case GFC_DTYPE_INTEGER_16:
 249       unpack1_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector,
 250                    mask, (gfc_array_i16 *) field);
 251       return;
 252 #endif
 253     case GFC_DTYPE_REAL_4:
 254       unpack1_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) vector,
 255                   mask, (gfc_array_r4 *) field);
 256       return;
 257
 258     case GFC_DTYPE_REAL_8:
 259       unpack1_r8 ((gfc_array_r8 *) ret, (gfc_array_r8 *) vector,
 260                   mask, (gfc_array_r8 *) field);
 261       return;
 262
 263 #ifdef HAVE_GFC_REAL_10
 264     case GFC_DTYPE_REAL_10:
 265       unpack1_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) vector,
 266                    mask, (gfc_array_r10 *) field);
 267           return;
 268 #endif
 269
 270 #ifdef HAVE_GFC_REAL_16
 271     case GFC_DTYPE_REAL_16:
 272       unpack1_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) vector,
 273                    mask, (gfc_array_r16 *) field);
 274       return;
 275 #endif
 276
 277     case GFC_DTYPE_COMPLEX_4:
 278       unpack1_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) vector,
 279                   mask, (gfc_array_c4 *) field);
 280       return;
 281
 282     case GFC_DTYPE_COMPLEX_8:
 283       unpack1_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) vector,
 284                   mask, (gfc_array_c8 *) field);
 285       return;
 286
 287 #ifdef HAVE_GFC_COMPLEX_10
 288     case GFC_DTYPE_COMPLEX_10:
 289       unpack1_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) vector,
 290                    mask, (gfc_array_c10 *) field);
 291       return;
 292 #endif
 293
 294 #ifdef HAVE_GFC_COMPLEX_16
 295     case GFC_DTYPE_COMPLEX_16:
 296       unpack1_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) vector,
 297                    mask, (gfc_array_c16 *) field);
 298       return;
 299 #endif
 300
 301     case GFC_DTYPE_DERIVED_2:
 302       if (GFC_UNALIGNED_2(ret->data) || GFC_UNALIGNED_2(vector->data)
 303           || GFC_UNALIGNED_2(field->data))
 304         break;
 305       else
 306         {
 307           unpack1_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector,
 308                       mask, (gfc_array_i2 *) field);
 309           return;
 310         }
 311
 312     case GFC_DTYPE_DERIVED_4:
 313       if (GFC_UNALIGNED_4(ret->data) || GFC_UNALIGNED_4(vector->data)
 314           || GFC_UNALIGNED_4(field->data))
 315         break;
 316       else
 317         {
 318           unpack1_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector,
 319                       mask, (gfc_array_i4 *) field);
 320           return;
 321         }
 322
 323     case GFC_DTYPE_DERIVED_8:
 324       if (GFC_UNALIGNED_8(ret->data) || GFC_UNALIGNED_8(vector->data)
 325           || GFC_UNALIGNED_8(field->data))
 326         break;
 327       else
 328         {
 329           unpack1_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector,
 330                       mask, (gfc_array_i8 *) field);
 331           return;
 332         }
 333
 334 #ifdef HAVE_GFC_INTEGER_16
 335     case GFC_DTYPE_DERIVED_16:
 336       if (GFC_UNALIGNED_16(ret->data) || GFC_UNALIGNED_16(vector->data)
 337           || GFC_UNALIGNED_16(field->data))
 338         break;
 339       else
 340         {
 341           unpack1_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector,
 342                        mask, (gfc_array_i16 *) field);
 343           return;
 344         }
 345 #endif
 346     }
 347
 348   unpack_internal (ret, vector, mask, field, size,
 349                    GFC_DESCRIPTOR_SIZE (field));
 350 }
 351
 352
 353 extern void unpack1_char (gfc_array_char *, GFC_INTEGER_4,
 354                           const gfc_array_char *, const gfc_array_l1 *,
 355                           const gfc_array_char *, GFC_INTEGER_4,
 356                           GFC_INTEGER_4);
 357 export_proto(unpack1_char);
 358
 359 void
 360 unpack1_char (gfc_array_char *ret,
 361               GFC_INTEGER_4 ret_length __attribute__((unused)),
 362               const gfc_array_char *vector, const gfc_array_l1 *mask,
 363               const gfc_array_char *field, GFC_INTEGER_4 vector_length,
 364               GFC_INTEGER_4 field_length)
 365 {
 366
 367   if (unlikely(compile_options.bounds_check))
 368     unpack_bounds (ret, vector, mask, field);
 369
 370   unpack_internal (ret, vector, mask, field, vector_length, field_length);
 371 }
 372
 373
 374 extern void unpack1_char4 (gfc_array_char *, GFC_INTEGER_4,
 375                            const gfc_array_char *, const gfc_array_l1 *,
 376                            const gfc_array_char *, GFC_INTEGER_4,
 377                            GFC_INTEGER_4);
 378 export_proto(unpack1_char4);
 379
 380 void
 381 unpack1_char4 (gfc_array_char *ret,
 382                GFC_INTEGER_4 ret_length __attribute__((unused)),
 383                const gfc_array_char *vector, const gfc_array_l1 *mask,
 384                const gfc_array_char *field, GFC_INTEGER_4 vector_length,
 385                GFC_INTEGER_4 field_length)
 386 {
 387
 388   if (unlikely(compile_options.bounds_check))
 389     unpack_bounds (ret, vector, mask, field);
 390
 391   unpack_internal (ret, vector, mask, field,
 392                    vector_length * sizeof (gfc_char4_t),
 393                    field_length * sizeof (gfc_char4_t));
 394 }
 395
 396
 397 extern void unpack0 (gfc_array_char *, const gfc_array_char *,
 398                      const gfc_array_l1 *, char *);
 399 export_proto(unpack0);
 400
 401 void
 402 unpack0 (gfc_array_char *ret, const gfc_array_char *vector,
 403          const gfc_array_l1 *mask, char *field)
 404 {
 405   gfc_array_char tmp;
 406
 407   index_type type_size;
 408   index_type size;
 409
 410   if (unlikely(compile_options.bounds_check))
 411     unpack_bounds (ret, vector, mask, NULL);
 412
 413   type_size = GFC_DTYPE_TYPE_SIZE (vector);
 414   size = GFC_DESCRIPTOR_SIZE (vector);
 415
 416   switch(type_size)
 417     {
 418     case GFC_DTYPE_LOGICAL_1:
 419     case GFC_DTYPE_INTEGER_1:
 420     case GFC_DTYPE_DERIVED_1:
 421       unpack0_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) vector,
 422                   mask, (GFC_INTEGER_1 *) field);
 423       return;
 424
 425     case GFC_DTYPE_LOGICAL_2:
 426     case GFC_DTYPE_INTEGER_2:
 427       unpack0_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector,
 428                   mask, (GFC_INTEGER_2 *) field);
 429       return;
 430
 431     case GFC_DTYPE_LOGICAL_4:
 432     case GFC_DTYPE_INTEGER_4:
 433       unpack0_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector,
 434                   mask, (GFC_INTEGER_4 *) field);
 435       return;
 436
 437     case GFC_DTYPE_LOGICAL_8:
 438     case GFC_DTYPE_INTEGER_8:
 439       unpack0_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector,
 440                   mask, (GFC_INTEGER_8 *) field);
 441       return;
 442
 443 #ifdef HAVE_GFC_INTEGER_16
 444     case GFC_DTYPE_LOGICAL_16:
 445     case GFC_DTYPE_INTEGER_16:
 446       unpack0_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector,
 447                    mask, (GFC_INTEGER_16 *) field);
 448       return;
 449 #endif
 450     case GFC_DTYPE_REAL_4:
 451       unpack0_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) vector,
 452                   mask, (GFC_REAL_4 *) field);
 453       return;
 454
 455     case GFC_DTYPE_REAL_8:
 456       unpack0_r8 ((gfc_array_r8 *) ret, (gfc_array_r8*) vector,
 457                   mask, (GFC_REAL_8  *) field);
 458       return;
 459
 460 #ifdef HAVE_GFC_REAL_10
 461     case GFC_DTYPE_REAL_10:
 462       unpack0_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) vector,
 463                    mask, (GFC_REAL_10 *) field);
 464       return;
 465 #endif
 466
 467 #ifdef HAVE_GFC_REAL_16
 468     case GFC_DTYPE_REAL_16:
 469       unpack0_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) vector,
 470                    mask, (GFC_REAL_16 *) field);
 471       return;
 472 #endif
 473
 474     case GFC_DTYPE_COMPLEX_4:
 475       unpack0_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) vector,
 476                   mask, (GFC_COMPLEX_4 *) field);
 477       return;
 478
 479     case GFC_DTYPE_COMPLEX_8:
 480       unpack0_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) vector,
 481                   mask, (GFC_COMPLEX_8 *) field);
 482       return;
 483
 484 #ifdef HAVE_GFC_COMPLEX_10
 485     case GFC_DTYPE_COMPLEX_10:
 486       unpack0_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) vector,
 487                    mask, (GFC_COMPLEX_10 *) field);
 488       return;
 489 #endif
 490
 491 #ifdef HAVE_GFC_COMPLEX_16
 492     case GFC_DTYPE_COMPLEX_16:
 493       unpack0_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) vector,
 494                    mask, (GFC_COMPLEX_16 *) field);
 495       return;
 496 #endif
 497     case GFC_DTYPE_DERIVED_2:
 498       if (GFC_UNALIGNED_2(ret->data) || GFC_UNALIGNED_2(vector->data)
 499           || GFC_UNALIGNED_2(field))
 500         break;
 501       else
 502         {
 503           unpack0_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector,
 504                       mask, (GFC_INTEGER_2 *) field);
 505           return;
 506         }
 507
 508     case GFC_DTYPE_DERIVED_4:
 509       if (GFC_UNALIGNED_4(ret->data) || GFC_UNALIGNED_4(vector->data)
 510           || GFC_UNALIGNED_4(field))
 511         break;
 512       else
 513         {
 514           unpack0_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector,
 515                       mask, (GFC_INTEGER_4 *) field);
 516           return;
 517         }
 518
 519     case GFC_DTYPE_DERIVED_8:
 520       if (GFC_UNALIGNED_8(ret->data) || GFC_UNALIGNED_8(vector->data)
 521           || GFC_UNALIGNED_8(field))
 522         break;
 523       else
 524         {
 525           unpack0_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector,
 526                       mask, (GFC_INTEGER_8 *) field);
 527           return;
 528         }
 529 #ifdef HAVE_GFC_INTEGER_16
 530     case GFC_DTYPE_DERIVED_16:
 531       if (GFC_UNALIGNED_16(ret->data) || GFC_UNALIGNED_16(vector->data)
 532           || GFC_UNALIGNED_16(field))
 533         break;
 534       else
 535         {
 536           unpack0_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector,
 537                        mask, (GFC_INTEGER_16 *) field);
 538           return;
 539         }
 540 #endif
 541     }
 542
 543   memset (&tmp, 0, sizeof (tmp));
 544   tmp.dtype = 0;
 545   tmp.data = field;
 546   unpack_internal (ret, vector, mask, &tmp, GFC_DESCRIPTOR_SIZE (vector), 0);
 547 }
 548
 549
 550 extern void unpack0_char (gfc_array_char *, GFC_INTEGER_4,
 551                           const gfc_array_char *, const gfc_array_l1 *,
 552                           char *, GFC_INTEGER_4, GFC_INTEGER_4);
 553 export_proto(unpack0_char);
 554
 555 void
 556 unpack0_char (gfc_array_char *ret,
 557               GFC_INTEGER_4 ret_length __attribute__((unused)),
 558               const gfc_array_char *vector, const gfc_array_l1 *mask,
 559               char *field, GFC_INTEGER_4 vector_length,
 560               GFC_INTEGER_4 field_length __attribute__((unused)))
 561 {
 562   gfc_array_char tmp;
 563
 564   if (unlikely(compile_options.bounds_check))
 565     unpack_bounds (ret, vector, mask, NULL);
 566
 567   memset (&tmp, 0, sizeof (tmp));
 568   tmp.dtype = 0;
 569   tmp.data = field;
 570   unpack_internal (ret, vector, mask, &tmp, vector_length, 0);
 571 }
 572
 573
 574 extern void unpack0_char4 (gfc_array_char *, GFC_INTEGER_4,
 575                            const gfc_array_char *, const gfc_array_l1 *,
 576                            char *, GFC_INTEGER_4, GFC_INTEGER_4);
 577 export_proto(unpack0_char4);
 578
 579 void
 580 unpack0_char4 (gfc_array_char *ret,
 581                GFC_INTEGER_4 ret_length __attribute__((unused)),
 582                const gfc_array_char *vector, const gfc_array_l1 *mask,
 583                char *field, GFC_INTEGER_4 vector_length,
 584                GFC_INTEGER_4 field_length __attribute__((unused)))
 585 {
 586   gfc_array_char tmp;
 587
 588   if (unlikely(compile_options.bounds_check))
 589     unpack_bounds (ret, vector, mask, NULL);
 590
 591   memset (&tmp, 0, sizeof (tmp));
 592   tmp.dtype = 0;
 593   tmp.data = field;
 594   unpack_internal (ret, vector, mask, &tmp,
 595                    vector_length * sizeof (gfc_char4_t), 0);
 596 }