libgfortran/intrinsics/date_and_time.c

   1 /* Implementation of the DATE_AND_TIME intrinsic.
   2    Copyright (C) 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
   3    Contributed by Steven Bosscher.
   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 2 of the License, or (at your option) any later version.
  11
  12 In addition to the permissions in the GNU General Public License, the
  13 Free Software Foundation gives you unlimited permission to link the
  14 compiled version of this file into combinations with other programs,
  15 and to distribute those combinations without any restriction coming
  16 from the use of this file.  (The General Public License restrictions
  17 do apply in other respects; for example, they cover modification of
  18 the file, and distribution when not linked into a combine
  19 executable.)
  20
  21 Libgfortran is distributed in the hope that it will be useful,
  22 but WITHOUT ANY WARRANTY; without even the implied warranty of
  23 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  24 GNU General Public License for more details.
  25
  26 You should have received a copy of the GNU General Public
  27 License along with libgfortran; see the file COPYING.  If not,
  28 write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  29 Boston, MA 02110-1301, USA.  */
  30
  31 #include "config.h"
  32 #include <sys/types.h>
  33 #include <string.h>
  34 #include <assert.h>
  35 #include <stdio.h>
  36 #include <stdlib.h>
  37 #include "libgfortran.h"
  38
  39 #undef HAVE_NO_DATE_TIME
  40 #if TIME_WITH_SYS_TIME
  41 #  include <sys/time.h>
  42 #  include <time.h>
  43 #else
  44 #  if HAVE_SYS_TIME_H
  45 #    include <sys/time.h>
  46 #  else
  47 #    ifdef HAVE_TIME_H
  48 #      include <time.h>
  49 #    else
  50 #      define HAVE_NO_DATE_TIME
  51 #    endif  /* HAVE_TIME_H  */
  52 #  endif  /* HAVE_SYS_TIME_H  */
  53 #endif  /* TIME_WITH_SYS_TIME  */
  54
  55 #ifndef abs
  56 #define abs(x) ((x)>=0 ? (x) : -(x))
  57 #endif
  58
  59 /* DATE_AND_TIME ([DATE, TIME, ZONE, VALUES])
  60
  61    Description: Returns data on the real-time clock and date in a form
  62    compatible with the representations defined in ISO 8601:1988.
  63
  64    Class: Non-elemental subroutine.
  65
  66    Arguments:
  67
  68    DATE (optional) shall be scalar and of type default character, and
  69    shall be of length at least 8 in order to contain the complete
  70    value. It is an INTENT(OUT) argument. Its leftmost 8 characters
  71    are assigned a value of the form CCYYMMDD, where CC is the century,
  72    YY the year within the century, MM the month within the year, and
  73    DD the day within the month. If there is no date available, they
  74    are assigned blanks.
  75
  76    TIME (optional) shall be scalar and of type default character, and
  77    shall be of length at least 10 in order to contain the complete
  78    value. It is an INTENT(OUT) argument. Its leftmost 10 characters
  79    are assigned a value of the form hhmmss.sss, where hh is the hour
  80    of the day, mm is the minutes of the hour, and ss.sss is the
  81    seconds and milliseconds of the minute. If there is no clock
  82    available, they are assigned blanks.
  83
  84    ZONE (optional) shall be scalar and of type default character, and
  85    shall be of length at least 5 in order to contain the complete
  86    value. It is an INTENT(OUT) argument. Its leftmost 5 characters
  87    are assigned a value of the form [+-]hhmm, where hh and mm are the
  88    time difference with respect to Coordinated Universal Time (UTC) in
  89    hours and parts of an hour expressed in minutes, respectively. If
  90    there is no clock available, they are assigned blanks.
  91
  92    VALUES (optional) shall be of type default integer and of rank
  93    one. It is an INTENT(OUT) argument. Its size shall be at least
  94    8. The values returned in VALUES are as follows:
  95
  96       VALUES(1) the year (for example, 2003), or -HUGE(0) if there is
  97       no date available;
  98
  99       VALUES(2) the month of the year, or -HUGE(0) if there
 100       is no date available;
 101
 102       VALUES(3) the day of the month, or -HUGE(0) if there is no date
 103       available;
 104
 105       VALUES(4) the time difference with respect to Coordinated
 106       Universal Time (UTC) in minutes, or -HUGE(0) if this information
 107       is not available;
 108
 109       VALUES(5) the hour of the day, in the range of 0 to 23, or
 110       -HUGE(0) if there is no clock;
 111
 112       VALUES(6) the minutes of the hour, in the range 0 to 59, or
 113       -HUGE(0) if there is no clock;
 114
 115       VALUES(7) the seconds of the minute, in the range 0 to 60, or
 116       -HUGE(0) if there is no clock;
 117
 118       VALUES(8) the milliseconds of the second, in the range 0 to
 119       999, or -HUGE(0) if there is no clock.
 120
 121    NULL pointer represent missing OPTIONAL arguments.  All arguments
 122    have INTENT(OUT).  Because of the -i8 option, we must implement
 123    VALUES for INTEGER(kind=4) and INTEGER(kind=8).
 124
 125    Based on libU77's date_time_.c.
 126
 127    TODO :
 128    - Check year boundaries.
 129 */
 130 #define DATE_LEN 8
 131 #define TIME_LEN 10
 132 #define ZONE_LEN 5
 133 #define VALUES_SIZE 8
 134
 135 extern void date_and_time (char *, char *, char *, gfc_array_i4 *,
 136                            GFC_INTEGER_4, GFC_INTEGER_4, GFC_INTEGER_4);
 137 export_proto(date_and_time);
 138
 139 void
 140 date_and_time (char *__date, char *__time, char *__zone,
 141                gfc_array_i4 *__values, GFC_INTEGER_4 __date_len,
 142                GFC_INTEGER_4 __time_len, GFC_INTEGER_4 __zone_len)
 143 {
 144   int i;
 145   char date[DATE_LEN + 1];
 146   char timec[TIME_LEN + 1];
 147   char zone[ZONE_LEN + 1];
 148   GFC_INTEGER_4 values[VALUES_SIZE];
 149
 150 #ifndef HAVE_NO_DATE_TIME
 151   time_t lt;
 152   struct tm local_time;
 153   struct tm UTC_time;
 154
 155 #if HAVE_GETTIMEOFDAY
 156   {
 157     struct timeval tp;
 158
 159     if (!gettimeofday (&tp, NULL))
 160       {
 161          lt = tp.tv_sec;
 162          values[7] = tp.tv_usec / 1000;
 163       }
 164     else
 165       {
 166          lt = time (NULL);
 167          values[7] = 0;
 168       }
 169   }
 170 #else
 171   lt = time (NULL);
 172   values[7] = 0;
 173 #endif /* HAVE_GETTIMEOFDAY */
 174
 175   if (lt != (time_t) -1)
 176     {
 177       local_time = *localtime (&lt);
 178       UTC_time = *gmtime (&lt);
 179
 180       /* All arguments can be derived from VALUES.  */
 181       values[0] = 1900 + local_time.tm_year;
 182       values[1] = 1 + local_time.tm_mon;
 183       values[2] = local_time.tm_mday;
 184       values[3] = (local_time.tm_min - UTC_time.tm_min +
 185                    60 * (local_time.tm_hour - UTC_time.tm_hour +
 186                      24 * (local_time.tm_yday - UTC_time.tm_yday)));
 187       values[4] = local_time.tm_hour;
 188       values[5] = local_time.tm_min;
 189       values[6] = local_time.tm_sec;
 190
 191 #if HAVE_SNPRINTF
 192       if (__date)
 193         snprintf (date, DATE_LEN + 1, "%04d%02d%02d",
 194                   values[0], values[1], values[2]);
 195       if (__time)
 196         snprintf (timec, TIME_LEN + 1, "%02d%02d%02d.%03d",
 197                   values[4], values[5], values[6], values[7]);
 198
 199       if (__zone)
 200         snprintf (zone, ZONE_LEN + 1, "%+03d%02d",
 201                   values[3] / 60, abs (values[3] % 60));
 202 #else
 203       if (__date)
 204         sprintf (date, "%04d%02d%02d", values[0], values[1], values[2]);
 205
 206       if (__time)
 207         sprintf (timec, "%02d%02d%02d.%03d",
 208                  values[4], values[5], values[6], values[7]);
 209
 210       if (__zone)
 211         sprintf (zone, "%+03d%02d",
 212                  values[3] / 60, abs (values[3] % 60));
 213 #endif
 214     }
 215   else
 216     {
 217       memset (date, ' ', DATE_LEN);
 218       date[DATE_LEN] = '\0';
 219
 220       memset (timec, ' ', TIME_LEN);
 221       timec[TIME_LEN] = '\0';
 222
 223       memset (zone, ' ', ZONE_LEN);
 224       zone[ZONE_LEN] = '\0';
 225
 226       for (i = 0; i < VALUES_SIZE; i++)
 227         values[i] = - GFC_INTEGER_4_HUGE;
 228     }
 229 #else /* if defined HAVE_NO_DATE_TIME  */
 230   /* We really have *nothing* to return, so return blanks and HUGE(0).  */
 231
 232   memset (date, ' ', DATE_LEN);
 233   date[DATE_LEN] = '\0';
 234
 235   memset (timec, ' ', TIME_LEN);
 236   timec[TIME_LEN] = '\0';
 237
 238   memset (zone, ' ', ZONE_LEN);
 239   zone[ZONE_LEN] = '\0';
 240
 241   for (i = 0; i < VALUES_SIZE; i++)
 242     values[i] = - GFC_INTEGER_4_HUGE;
 243 #endif  /* HAVE_NO_DATE_TIME  */
 244
 245   /* Copy the values into the arguments.  */
 246   if (__values)
 247     {
 248       size_t len, delta, elt_size;
 249
 250       elt_size = GFC_DESCRIPTOR_SIZE (__values);
 251       len = __values->dim[0].ubound + 1 - __values->dim[0].lbound;
 252       delta = __values->dim[0].stride;
 253       if (delta == 0)
 254         delta = 1;
 255
 256       assert (len >= VALUES_SIZE);
 257       /* Cope with different type kinds.  */
 258       if (elt_size == 4)
 259         {
 260           GFC_INTEGER_4 *vptr4 = __values->data;
 261
 262           for (i = 0; i < VALUES_SIZE; i++, vptr4 += delta)
 263             *vptr4 = values[i];
 264         }
 265       else if (elt_size == 8)
 266         {
 267           GFC_INTEGER_8 *vptr8 = (GFC_INTEGER_8 *)__values->data;
 268
 269           for (i = 0; i < VALUES_SIZE; i++, vptr8 += delta)
 270             {
 271               if (values[i] == - GFC_INTEGER_4_HUGE)
 272                 *vptr8 = - GFC_INTEGER_8_HUGE;
 273               else
 274                 *vptr8 = values[i];
 275             }
 276         }
 277       else
 278         abort ();
 279     }
 280
 281   if (__zone)
 282     {
 283       assert (__zone_len >= ZONE_LEN);
 284       fstrcpy (__zone, ZONE_LEN, zone, ZONE_LEN);
 285     }
 286
 287   if (__time)
 288     {
 289       assert (__time_len >= TIME_LEN);
 290       fstrcpy (__time, TIME_LEN, timec, TIME_LEN);
 291     }
 292
 293   if (__date)
 294     {
 295       assert (__date_len >= DATE_LEN);
 296       fstrcpy (__date, DATE_LEN, date, DATE_LEN);
 297     }
 298 }
 299
 300
 301 /* SECNDS (X) - Non-standard
 302
 303    Description: Returns the system time of day, or elapsed time, as a GFC_REAL_4
 304    in seconds.
 305
 306    Class: Non-elemental subroutine.
 307
 308    Arguments:
 309
 310    X must be REAL(4) and the result is of the same type.  The accuracy is system
 311    dependent.
 312
 313    Usage:
 314
 315         T = SECNDS (X)
 316
 317    yields the time in elapsed seconds since X.  If X is 0.0, T is the time in
 318    seconds since midnight. Note that a time that spans midnight but is less than
 319    24hours will be calculated correctly.  */
 320
 321 extern GFC_REAL_4 secnds (GFC_REAL_4 *);
 322 export_proto(secnds);
 323
 324 GFC_REAL_4
 325 secnds (GFC_REAL_4 *x)
 326 {
 327   GFC_INTEGER_4 values[VALUES_SIZE];
 328   GFC_REAL_4 temp1, temp2;
 329
 330   /* Make the INTEGER*4 array for passing to date_and_time.  */
 331   gfc_array_i4 *avalues = internal_malloc_size (sizeof (gfc_array_i4));
 332   avalues->data = &values[0];
 333   GFC_DESCRIPTOR_DTYPE (avalues) = ((GFC_DTYPE_REAL << GFC_DTYPE_TYPE_SHIFT)
 334                                         & GFC_DTYPE_TYPE_MASK) +
 335                                     (4 << GFC_DTYPE_SIZE_SHIFT);
 336
 337   avalues->dim[0].ubound = 7;
 338   avalues->dim[0].lbound = 0;
 339   avalues->dim[0].stride = 1;
 340
 341   date_and_time (NULL, NULL, NULL, avalues, 0, 0, 0);
 342
 343   free_mem (avalues);
 344
 345   temp1 = 3600.0 * (GFC_REAL_4)values[4] +
 346             60.0 * (GFC_REAL_4)values[5] +
 347                    (GFC_REAL_4)values[6] +
 348            0.001 * (GFC_REAL_4)values[7];
 349   temp2 = fmod (*x, 86400.0);
 350   temp2 = (temp1 - temp2 >= 0.0) ? temp2 : (temp2 - 86400.0);
 351   return temp1 - temp2;
 352 }
 353
 354
 355
 356 /* ITIME(X) - Non-standard
 357
 358    Description: Returns the current local time hour, minutes, and seconds
 359    in elements 1, 2, and 3 of X, respectively.  */
 360
 361 static void
 362 itime0 (int x[3])
 363 {
 364 #ifndef HAVE_NO_DATE_TIME
 365   time_t lt;
 366   struct tm local_time;
 367
 368   lt = time (NULL);
 369
 370   if (lt != (time_t) -1)
 371     {
 372       local_time = *localtime (&lt);
 373
 374       x[0] = local_time.tm_hour;
 375       x[1] = local_time.tm_min;
 376       x[2] = local_time.tm_sec;
 377     }
 378 #else
 379   x[0] = x[1] = x[2] = -1;
 380 #endif
 381 }
 382
 383 extern void itime_i4 (gfc_array_i4 *);
 384 export_proto(itime_i4);
 385
 386 void
 387 itime_i4 (gfc_array_i4 *__values)
 388 {
 389   int x[3], i;
 390   size_t len, delta;
 391   GFC_INTEGER_4 *vptr;
 392
 393   /* Call helper function.  */
 394   itime0(x);
 395
 396   /* Copy the value into the array.  */
 397   len = __values->dim[0].ubound + 1 - __values->dim[0].lbound;
 398   assert (len >= 3);
 399   delta = __values->dim[0].stride;
 400   if (delta == 0)
 401     delta = 1;
 402
 403   vptr = __values->data;
 404   for (i = 0; i < 3; i++, vptr += delta)
 405     *vptr = x[i];
 406 }
 407
 408
 409 extern void itime_i8 (gfc_array_i8 *);
 410 export_proto(itime_i8);
 411
 412 void
 413 itime_i8 (gfc_array_i8 *__values)
 414 {
 415   int x[3], i;
 416   size_t len, delta;
 417   GFC_INTEGER_8 *vptr;
 418
 419   /* Call helper function.  */
 420   itime0(x);
 421
 422   /* Copy the value into the array.  */
 423   len = __values->dim[0].ubound + 1 - __values->dim[0].lbound;
 424   assert (len >= 3);
 425   delta = __values->dim[0].stride;
 426   if (delta == 0)
 427     delta = 1;
 428
 429   vptr = __values->data;
 430   for (i = 0; i < 3; i++, vptr += delta)
 431     *vptr = x[i];
 432 }
 433
 434
 435
 436 /* IDATE(X) - Non-standard
 437
 438    Description: Fills TArray with the numerical values at the current
 439    local time. The day (in the range 1-31), month (in the range 1-12),
 440    and year appear in elements 1, 2, and 3 of X, respectively.
 441    The year has four significant digits.  */
 442
 443 static void
 444 idate0 (int x[3])
 445 {
 446 #ifndef HAVE_NO_DATE_TIME
 447   time_t lt;
 448   struct tm local_time;
 449
 450   lt = time (NULL);
 451
 452   if (lt != (time_t) -1)
 453     {
 454       local_time = *localtime (&lt);
 455
 456       x[0] = local_time.tm_mday;
 457       x[1] = 1 + local_time.tm_mon;
 458       x[2] = 1900 + local_time.tm_year;
 459     }
 460 #else
 461   x[0] = x[1] = x[2] = -1;
 462 #endif
 463 }
 464
 465 extern void idate_i4 (gfc_array_i4 *);
 466 export_proto(idate_i4);
 467
 468 void
 469 idate_i4 (gfc_array_i4 *__values)
 470 {
 471   int x[3], i;
 472   size_t len, delta;
 473   GFC_INTEGER_4 *vptr;
 474
 475   /* Call helper function.  */
 476   idate0(x);
 477
 478   /* Copy the value into the array.  */
 479   len = __values->dim[0].ubound + 1 - __values->dim[0].lbound;
 480   assert (len >= 3);
 481   delta = __values->dim[0].stride;
 482   if (delta == 0)
 483     delta = 1;
 484
 485   vptr = __values->data;
 486   for (i = 0; i < 3; i++, vptr += delta)
 487     *vptr = x[i];
 488 }
 489
 490
 491 extern void idate_i8 (gfc_array_i8 *);
 492 export_proto(idate_i8);
 493
 494 void
 495 idate_i8 (gfc_array_i8 *__values)
 496 {
 497   int x[3], i;
 498   size_t len, delta;
 499   GFC_INTEGER_8 *vptr;
 500
 501   /* Call helper function.  */
 502   idate0(x);
 503
 504   /* Copy the value into the array.  */
 505   len = __values->dim[0].ubound + 1 - __values->dim[0].lbound;
 506   assert (len >= 3);
 507   delta = __values->dim[0].stride;
 508   if (delta == 0)
 509     delta = 1;
 510
 511   vptr = __values->data;
 512   for (i = 0; i < 3; i++, vptr += delta)
 513     *vptr = x[i];
 514 }
 515
 516
 517
 518 /* GMTIME(STIME, TARRAY) - Non-standard
 519
 520    Description: Given a system time value STime, fills TArray with values
 521    extracted from it appropriate to the GMT time zone using gmtime(3).
 522
 523    The array elements are as follows:
 524
 525       1. Seconds after the minute, range 0-59 or 0-61 to allow for leap seconds
 526       2. Minutes after the hour, range 0-59
 527       3. Hours past midnight, range 0-23
 528       4. Day of month, range 0-31
 529       5. Number of months since January, range 0-11
 530       6. Years since 1900
 531       7. Number of days since Sunday, range 0-6
 532       8. Days since January 1
 533       9. Daylight savings indicator: positive if daylight savings is in effect,
 534          zero if not, and negative if the information isn't available.  */
 535
 536 static void
 537 gmtime_0 (const time_t * t, int x[9])
 538 {
 539   struct tm lt;
 540
 541   lt = *gmtime (t);
 542   x[0] = lt.tm_sec;
 543   x[1] = lt.tm_min;
 544   x[2] = lt.tm_hour;
 545   x[3] = lt.tm_mday;
 546   x[4] = lt.tm_mon;
 547   x[5] = lt.tm_year;
 548   x[6] = lt.tm_wday;
 549   x[7] = lt.tm_yday;
 550   x[8] = lt.tm_isdst;
 551 }
 552
 553 extern void gmtime_i4 (GFC_INTEGER_4 *, gfc_array_i4 *);
 554 export_proto(gmtime_i4);
 555
 556 void
 557 gmtime_i4 (GFC_INTEGER_4 * t, gfc_array_i4 * tarray)
 558 {
 559   int x[9], i;
 560   size_t len, delta;
 561   GFC_INTEGER_4 *vptr;
 562   time_t tt;
 563
 564   /* Call helper function.  */
 565   tt = (time_t) *t;
 566   gmtime_0(&tt, x);
 567
 568   /* Copy the values into the array.  */
 569   len = tarray->dim[0].ubound + 1 - tarray->dim[0].lbound;
 570   assert (len >= 9);
 571   delta = tarray->dim[0].stride;
 572   if (delta == 0)
 573     delta = 1;
 574
 575   vptr = tarray->data;
 576   for (i = 0; i < 9; i++, vptr += delta)
 577     *vptr = x[i];
 578 }
 579
 580 extern void gmtime_i8 (GFC_INTEGER_8 *, gfc_array_i8 *);
 581 export_proto(gmtime_i8);
 582
 583 void
 584 gmtime_i8 (GFC_INTEGER_8 * t, gfc_array_i8 * tarray)
 585 {
 586   int x[9], i;
 587   size_t len, delta;
 588   GFC_INTEGER_8 *vptr;
 589   time_t tt;
 590
 591   /* Call helper function.  */
 592   tt = (time_t) *t;
 593   gmtime_0(&tt, x);
 594
 595   /* Copy the values into the array.  */
 596   len = tarray->dim[0].ubound + 1 - tarray->dim[0].lbound;
 597   assert (len >= 9);
 598   delta = tarray->dim[0].stride;
 599   if (delta == 0)
 600     delta = 1;
 601
 602   vptr = tarray->data;
 603   for (i = 0; i < 9; i++, vptr += delta)
 604     *vptr = x[i];
 605 }
 606
 607
 608
 609
 610 /* LTIME(STIME, TARRAY) - Non-standard
 611
 612    Description: Given a system time value STime, fills TArray with values
 613    extracted from it appropriate to the local time zone using localtime(3).
 614
 615    The array elements are as follows:
 616
 617       1. Seconds after the minute, range 0-59 or 0-61 to allow for leap seconds
 618       2. Minutes after the hour, range 0-59
 619       3. Hours past midnight, range 0-23
 620       4. Day of month, range 0-31
 621       5. Number of months since January, range 0-11
 622       6. Years since 1900
 623       7. Number of days since Sunday, range 0-6
 624       8. Days since January 1
 625       9. Daylight savings indicator: positive if daylight savings is in effect,
 626          zero if not, and negative if the information isn't available.  */
 627
 628 static void
 629 ltime_0 (const time_t * t, int x[9])
 630 {
 631   struct tm lt;
 632
 633   lt = *localtime (t);
 634   x[0] = lt.tm_sec;
 635   x[1] = lt.tm_min;
 636   x[2] = lt.tm_hour;
 637   x[3] = lt.tm_mday;
 638   x[4] = lt.tm_mon;
 639   x[5] = lt.tm_year;
 640   x[6] = lt.tm_wday;
 641   x[7] = lt.tm_yday;
 642   x[8] = lt.tm_isdst;
 643 }
 644
 645 extern void ltime_i4 (GFC_INTEGER_4 *, gfc_array_i4 *);
 646 export_proto(ltime_i4);
 647
 648 void
 649 ltime_i4 (GFC_INTEGER_4 * t, gfc_array_i4 * tarray)
 650 {
 651   int x[9], i;
 652   size_t len, delta;
 653   GFC_INTEGER_4 *vptr;
 654   time_t tt;
 655
 656   /* Call helper function.  */
 657   tt = (time_t) *t;
 658   ltime_0(&tt, x);
 659
 660   /* Copy the values into the array.  */
 661   len = tarray->dim[0].ubound + 1 - tarray->dim[0].lbound;
 662   assert (len >= 9);
 663   delta = tarray->dim[0].stride;
 664   if (delta == 0)
 665     delta = 1;
 666
 667   vptr = tarray->data;
 668   for (i = 0; i < 9; i++, vptr += delta)
 669     *vptr = x[i];
 670 }
 671
 672 extern void ltime_i8 (GFC_INTEGER_8 *, gfc_array_i8 *);
 673 export_proto(ltime_i8);
 674
 675 void
 676 ltime_i8 (GFC_INTEGER_8 * t, gfc_array_i8 * tarray)
 677 {
 678   int x[9], i;
 679   size_t len, delta;
 680   GFC_INTEGER_8 *vptr;
 681   time_t tt;
 682
 683   /* Call helper function.  */
 684   tt = (time_t) * t;
 685   ltime_0(&tt, x);
 686
 687   /* Copy the values into the array.  */
 688   len = tarray->dim[0].ubound + 1 - tarray->dim[0].lbound;
 689   assert (len >= 9);
 690   delta = tarray->dim[0].stride;
 691   if (delta == 0)
 692     delta = 1;
 693
 694   vptr = tarray->data;
 695   for (i = 0; i < 9; i++, vptr += delta)
 696     *vptr = x[i];
 697 }
 698
 699