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