Open64: osprey/libI77/uio.c Source File

00001 /*
00002 
00003   Copyright (C) 2000, 2001 Silicon Graphics, Inc.  All Rights Reserved.
00004 
00005   This program is free software; you can redistribute it and/or modify it
00006   under the terms of version 2.1 of the GNU Lesser General Public License 
00007   as published by the Free Software Foundation.
00008 
00009   This program is distributed in the hope that it would be useful, but
00010   WITHOUT ANY WARRANTY; without even the implied warranty of
00011   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  
00012 
00013   Further, this software is distributed without any warranty that it is
00014   free of the rightful claim of any third person regarding infringement 
00015   or the like.  Any license provided herein, whether implied or 
00016   otherwise, applies only to this software file.  Patent licenses, if
00017   any, provided herein do not apply to combinations of this program with 
00018   other software, or any other product whatsoever.  
00019 
00020   You should have received a copy of the GNU Lesser General Public 
00021   License along with this program; if not, write the Free Software 
00022   Foundation, Inc., 59 Temple Place - Suite 330, Boston MA 02111-1307, 
00023   USA.
00024 
00025   Contact information:  Silicon Graphics, Inc., 1600 Amphitheatre Pky,
00026   Mountain View, CA 94043, or:
00027 
00028   http://www.sgi.com
00029 
00030   For further information regarding this notice, see:
00031 
00032   http://oss.sgi.com/projects/GenInfo/NoticeExplan
00033 
00034 */
00035 
00036 
00037 /* $Header: /proj/osprey/CVS/open64/osprey1.0/libI77/uio.c,v 1.1.1.1 2005/10/21 19:00:00 marcel Exp $ */
00038 /*  3.0 SID # 1.2 */
00039 #include <cmplrs/fio.h>
00040 #include <limits.h>
00041 #include "vmsflags.h"
00042 #include "fmt.h"
00043 #include "iomode.h"
00044 #include "uio.h"
00045 #include "err.h"
00046 #include "fio_direct_io.h"
00047 #include "cmplrs/f_errno.h"
00048 #include <string.h>
00049 int             est_reclen; /* need to change if > 2Gb records CALVIN */
00050 
00051 #define   FORWARD   0
00052 #define   BACKWARD  1
00053 #define MIN(a,b)  (((a) < (b)) ? a : b)
00054 
00055 static int do_uio_com (XINT *number, char *ptr, unit **fu, ftnlen len);
00056 
00057 int
00058 do_us (unit *ftnunit, XINT *number, char *ptr, ftnlen len)
00059 {
00060    if (!(ftnunit->uwrt & WR_OP)) {
00061       XINT             nread = *number * len;
00062 
00063       ftnunit->f77recpos += nread;
00064       if (ftnunit->f77reclen == 1 && f77vms_flag_[VMS_EF]) {
00065    /* VMS endfile record */
00066    (void) fread (ptr, 1, 1, ftnunit->ufd);
00067    if (*ptr == '\032') {
00068       (void) fseek (ftnunit->ufd, sizeof (int), 1);
00069       return( EOF );  /* Endfile record */
00070    } else if (ftnunit->f77recpos > 1)
00071       errret(ftnunit->f77errlist.cierr, 110, "eof/uio");
00072    return (0);
00073       }
00074       if (ftnunit->f77recpos > ftnunit->f77reclen) {
00075    ftnunit->f77recpos -= nread;
00076    (void) fread (ptr, (int) ftnunit->f77reclen - ftnunit->f77recpos, 1, ftnunit->ufd);
00077    errret(ftnunit->f77errlist.cierr, 110, "eof/uio");
00078       }
00079       (void) fread (ptr, (int) nread, 1, ftnunit->ufd);
00080       return (0);
00081    } else {
00082 
00083 /* 7/18/90 MNH  REPLACE FWRITE WITH MEMCPY -- FWRITE BEGAN AT BYTE #5 TO */
00084 /* ALLOW SPACE FOR EVENTUAL FRWITE OF "f77reclen" TO BEGINNING OF FILE */
00085       XINT             n = *number * len;
00086       int             seekdone = 0;
00087 
00088       if (ftnunit->f77recpos + n > ftnunit->f77fio_size || n >= BUFSIZ || est_reclen) {
00089    if (!ftnunit->overflowed) {
00090       ftnunit->overflowed = 1;
00091       if (!est_reclen) {
00092          if (ftnunit->f77recpos == 4) {
00093       fseek (ftnunit->ufd, 4, 1);
00094       seekdone = 1;
00095       ftnunit->f77recpos = 0;
00096          }
00097       } else
00098          *(int *) ftnunit->f77fio_buf = est_reclen;
00099    }
00100    if (ftnunit->f77recpos) {
00101       if (fwrite (ftnunit->f77fio_buf, ftnunit->f77recpos, 1, ftnunit->ufd) != 1)
00102          errret(ftnunit->f77errlist.cierr, errno, "system write error");
00103       ftnunit->f77recpos = 0;
00104    }
00105    if (n >= BUFSIZ) {
00106       /* for large user data it's preferable to flush the
00107        * system buffer to disk so that it won't have to copy
00108        * the user array, which could be several megs, to the
00109        * system buffer before writing it out */
00110       if (!seekdone)
00111          fseek (ftnunit->ufd, 0, 1);
00112       if (fwrite (ptr, n, 1, ftnunit->ufd) != 1)
00113          errret(ftnunit->f77errlist.cierr, errno, "system write error");
00114       ftnunit->f77reclen += n;
00115       return (0);
00116    }
00117       }
00118       if (!est_reclen) {
00119    if (ftnunit->f77recpos + n > ftnunit->f77fio_size)
00120              check_buflen( ftnunit, ftnunit->f77recpos + n );
00121    memcpy (ftnunit->f77fio_buf + ftnunit->f77recpos, ptr, n);
00122    ftnunit->f77recpos += n;
00123       } else if (fwrite (ptr, n, 1, ftnunit->ufd) != 1) {
00124    ftnunit->f77recpos = 0;
00125    errret(ftnunit->f77errlist.cierr, errno, "system write error");
00126       }
00127       ftnunit->f77reclen += n;
00128       return (0);
00129    }
00130 }
00131 
00132 
00133 int
00134 s_usrecsize (int reclen)
00135 {
00136    est_reclen = reclen; /* CALVIN - > 2Gb */
00137    return(0);
00138 }
00139 
00140 
00141 int
00142 do_uio64_mp_1dim( char *ptr, flex *do_idx,
00143      XINT *lb, XINT *ub,
00144      XINT *step, unit **fu,
00145      ftnlen len, ftnlen idxlen)
00146 {
00147    return(do_uio_1dim_work(ptr, do_idx, *lb, *ub, *step, fu, len, idxlen));
00148 }
00149 
00150 
00151 static int
00152 do_uio_1dim_work (  char *ptr, flex *do_idx, 
00153     XINT lb, XINT ub, 
00154     XINT step, unit **fu,
00155     ftnlen len, ftnlen idxlen)
00156 /* 
00157 ** This function carries out the I/O operation on a single-dimension
00158 ** implied-DO loop in the form (ARR(I),I=N,M,L).  It takes these 
00159 ** arguments:
00160 **
00161 **  ptr : address of the first array element involved in the I/O
00162 **      in the example above it is the address of ARR(N)
00163 **  do_idx  : the implied-do variable
00164 **  lb  : the loop lower bound
00165 **  ub  : the loop upper bound
00166 **  step  : the implied-do loop step size which is L in this case.
00167 **  len : length of each array element
00168 **  idxlen  : length of the implied-do variable
00169 */
00170 {
00171    XINT nelem;
00172    int ierr;
00173    char *lastptr, *nptr;
00174    char *f77fio_buf;
00175    static char *f77fio_buf_com;
00176    static int size = FIO_ALLOC*4;
00177    unit *ftnunit = *fu;
00178    int mp_mode = (*fu != f77curunit);
00179       
00180    lastptr = ptr + (ub - 1) * len;
00181    ptr += (lb - 1) * len;
00182    if (step == 1) {
00183    /* consecutive elements */
00184       if ((nelem = ub - lb + 1) > 0) {
00185     if ( ierr = do_uio_com( &nelem, ptr, fu, len ) ) {
00186         set_do_idx( do_idx, idxlen, (ftnll) ((((*fu)->f77reclen - (*fu)->f77recpos) / len) + 1) );
00187         return( ierr );
00188     }
00189     set_do_idx( do_idx, idxlen, (ftnll) (ub + 1) );
00190       }
00191       /* if last element <= first: dothing */
00192       return( 0 );
00193    }
00194    
00195    if (step >= 0) {
00196      if (ftnunit->uwrt & WR_OP) {
00197        if (!mp_mode) {
00198          /* Non MP mode: use a single buffer */
00199          if (!f77fio_buf_com) {
00200            if (!(f77fio_buf_com = malloc( size )))
00201       err(ftnunit->f77errlist.cierr, 113, "malloc");
00202          }
00203          f77fio_buf = f77fio_buf_com;
00204        } else {
00205          if (!(ftnunit->unf_buf = malloc( size )))
00206            err(ftnunit->f77errlist.cierr, 113, "malloc");
00207    f77fio_buf = ftnunit->unf_buf;
00208        }
00209        for (nptr = ptr; nptr <= lastptr; nptr += nelem*len*step) {
00210    nelem = gather_in_f77fio_buf( f77fio_buf, size, nptr, lastptr, step, len, FORWARD );
00211    if (ierr = do_uio_com( &nelem, f77fio_buf, fu, len ) ) {
00212       set_do_idx( do_idx, idxlen, (ftnll) (((ftnunit->f77reclen - ftnunit->f77recpos) / len) + 1) );
00213       return( ierr );
00214    }
00215        }
00216      }
00217      else {
00218        for (nptr = ptr; nptr <= lastptr; nptr += nelem*len*step) {
00219    nelem = MIN( ftnunit->f77fio_size/len, (lastptr-nptr) / (len*step) + 1);
00220    if (ierr = do_uio_com( &nelem, ftnunit->f77fio_buf, fu, len ) ) {
00221       set_do_idx( do_idx, idxlen, (ftnll) (((ftnunit->f77reclen - ftnunit->f77recpos) / len) + 1) );
00222       return( ierr );
00223    }
00224    scatter_from_f77fio_buf( ftnunit, nptr, lastptr, step, len, FORWARD );
00225        }
00226      }
00227    }
00228    else {
00229      if (ftnunit->uwrt & WR_OP) {
00230        if (!mp_mode) {
00231          /* Non MP mode: use a single buffer */
00232          if (!f77fio_buf_com) {
00233            if (!(f77fio_buf_com = malloc( size )))
00234       err(ftnunit->f77errlist.cierr, 113, "malloc");
00235          }
00236          f77fio_buf = f77fio_buf_com;
00237        } else {
00238          if (!(ftnunit->unf_buf = malloc( size )))
00239            err(ftnunit->f77errlist.cierr, 113, "malloc");
00240    f77fio_buf = ftnunit->unf_buf;
00241        }
00242        for (nptr = ptr; nptr >= lastptr; nptr += nelem*step*len) {
00243      nelem = gather_in_f77fio_buf( f77fio_buf, size, nptr, lastptr, step, len, BACKWARD );
00244      if (ierr = do_uio_com( &nelem, f77fio_buf, fu, len ) ) {
00245        set_do_idx( do_idx, idxlen, (ftnll) (((ftnunit->f77reclen - ftnunit->f77recpos) / len) + 1) );
00246        return( ierr );
00247      }
00248        }
00249      } 
00250      else {
00251        for (nptr = ptr; nptr >= lastptr; nptr += nelem*step*len) {
00252          nelem = MIN( ftnunit->f77fio_size/len, (nptr-lastptr) / (len*step) + 1);
00253          if (ierr = do_uio_com( &nelem, ftnunit->f77fio_buf, fu, len ) ) {
00254             set_do_idx( do_idx, idxlen, (ftnll) (((ftnunit->f77reclen - ftnunit->f77recpos) / len) + 1) );
00255             return( ierr );
00256          }
00257          scatter_from_f77fio_buf( ftnunit, nptr, lastptr, step, len, BACKWARD );
00258        }
00259      }
00260    }
00261    set_do_idx( do_idx, idxlen, (ftnll) (lb + ((ub - lb) / step + 1) * step) );
00262    return(0);
00263 }
00264 
00265 int
00266 do_uio_1dim ( char *ptr, flex *do_idx, 
00267     ftnint *lb, ftnint *ub, 
00268     ftnint *step, ftnlen len, 
00269     ftnlen idxlen)
00270 {
00271  return(do_uio_1dim_work(ptr, do_idx, *lb, *ub, *step, &f77curunit, len, idxlen));
00272 }
00273 
00274 /* do_uio64_1dim is identical to do_uio_1dim in 32 bit mode */
00275 #if 11
00276 int
00277 do_uio64_1dim ( char *ptr, flex *do_idx, 
00278     XINT *lb, XINT *ub, 
00279     XINT *step, ftnlen len, 
00280     ftnlen idxlen)
00281 {
00282  return(do_uio_1dim_work(ptr, do_idx, *lb, *ub, *step, &f77curunit, len, idxlen));
00283 }
00284 
00285 #endif
00286 
00287 void
00288 set_do_idx( flex *idx, ftnlen len, ftnll val )
00289 {
00290    switch (len) {
00291       case 1:
00292    idx->flbyte = (char) val;
00293    return;
00294       case 2:
00295    idx->flshort = (short) val;
00296    return;
00297       case 4:
00298    idx->flint = (int) val;
00299    return;
00300       case 8:
00301    idx->flll = val;
00302    return;
00303    }
00304 }
00305 
00306 static int
00307 do_uio_com (XINT *number, char *ptr, unit **fu, ftnlen len)
00308 {
00309    if (*number <= 0)
00310       return (0);
00311 
00312    return (*(*fu)->f77do_unf) (*fu, number, ptr, len);
00313 }
00314 
00315 int
00316 do_uio (ftnint *number, char *ptr, ftnlen len)
00317 {
00318 #if (_MIPS_SIM == _MIPS_SIM_ABI64)
00319     XINT num;
00320     num = *number;
00321     return( do_uio_com(&num, ptr,  &f77curunit, len));
00322 #else
00323     return( do_uio_com( number, ptr,  &f77curunit, len ) );
00324 #endif
00325 }
00326 
00327 int
00328 do_uio_mp (ftnint *number, char *ptr, unit **fu, ftnlen len)
00329 {
00330 #if (_MIPS_SIM == _MIPS_SIM_ABI64)
00331     XINT num;
00332     num = *number;
00333     return( do_uio_com(&num, ptr,  fu, len));
00334 #else
00335     return( do_uio_com( number, ptr,  fu, len ) );
00336 #endif
00337 }
00338 
00339 #if 11
00340 
00341 int
00342 do_uio64 (XINT *number, char *ptr, ftnlen len)
00343 {
00344     return( do_uio_com( number, ptr,  &f77curunit, len ) );
00345 }
00346 
00347 int
00348 do_uio64_mp (XINT *number, char *ptr, unit **fu, ftnlen len)
00349 {
00350     return( do_uio_com( number, ptr,  fu, len ) );
00351 }
00352 
00353 #endif
00354 
00355 int
00356 do_ud (unit *ftnunit, XINT *number, char *ptr, ftnlen len)
00357 {
00358    XINT             nread = *number * len;
00359    XINT64             disk_loc; 
00360      
00361    if (ftnunit->url != 1) {   /* Normal case.          */
00362       disk_loc =(ftnunit->uirec - 1) * ftnunit->url + ftnunit->f77recpos;
00363       ftnunit->f77recpos += nread;
00364       if (ftnunit->f77recpos > ftnunit->url && ftnunit->url != 1)
00365          errret(ftnunit->f77errlist.cierr, 110, "eof/uio");
00366    } else {                      /* Record length of one. */
00367       disk_loc = ftnunit->uirec;
00368       ftnunit->uirec += nread;
00369    }
00370  
00371 
00372    /* 
00373     * Read or write the data. 
00374     */
00375 
00376    if (!(ftnunit->uwrt & WR_OP)) {
00377       if (-1 == _fio_du_read (ftnunit, ptr, nread, disk_loc, (int) ftnunit->ufd))
00378    errret(ftnunit->f77errlist.cierr, errno, "eof/uio");
00379    } else {
00380       if (ftnunit->ureadonly)
00381    errret( ftnunit->f77errlist.cierr, F_ERREADONLY, "direct unformatted write" );
00382       if (-1 == _fio_du_write (ftnunit, ptr, nread, disk_loc, (int) ftnunit->ufd))
00383    errret(ftnunit->f77errlist.cierr, errno, "system write error");
00384    }
00385    return (0);
00386 }
00387 
00388 int
00389 check_buflen (unit *ftnunit, XINT n)
00390 {
00391    if (ftnunit->f77fio_size > n) 
00392       return(0);
00393    if (!ftnunit->f77fio_buf) {
00394       ftnunit->f77fio_size = (n > FIO_ALLOC) ? n : FIO_ALLOC;
00395       ftnunit->f77fio_buf = malloc (ftnunit->f77fio_size);
00396    } else {
00397       ftnunit->f77fio_size = ( n > ftnunit->f77fio_size * 2) ? n : ftnunit->f77fio_size * 2;
00398       ftnunit->f77fio_buf = realloc (ftnunit->f77fio_buf, ftnunit->f77fio_size);
00399    }
00400    if (ftnunit->f77fio_buf == NULL)
00401       err(ftnunit->f77errlist.cierr, 113, "malloc");
00402    return (0);
00403 }
00404 
00405 
00406 /*  ========================================================================  */
00407 /*                        */
00408 /*  The following entries are a minor efficiency improvement in calling       */
00409 /*  the unformatted I/O routines.  In a few cases, they overlap existing      */
00410 /*  entries but are an attempt to clean up the interface.  In truth, the      */
00411 /*  entire I/O interface could use an overhaul.             */
00412 /*                        */
00413 /*  ========================================================================  */
00414 
00415 int
00416 do_uioxa4_mp (char *ptr, XINT num, unit **fu)
00417 {
00418     XINT number = num;
00419     return( do_uio_com( &number, ptr, fu, 4 ) );
00420 }
00421 
00422 int
00423 do_uioxa4 (char *ptr, XINT num)
00424 {
00425     XINT number = num;
00426     return( do_uio_com( &number, ptr, &f77curunit, 4 ) );
00427 }
00428 
00429 int
00430 do_uioxa8_mp (char *ptr, XINT num, unit **fu)
00431 {
00432     XINT number = num;
00433     return( do_uio_com( &number, ptr, fu, 8 ) );
00434 }
00435 
00436 int
00437 do_uioxa8 (char *ptr, XINT num)
00438 {
00439     XINT number = num;
00440     return( do_uio_com( &number, ptr, &f77curunit, 8 ) );
00441 }
00442 
00443 int
00444 do_uioxh1_mp (char *ptr, XINT clen, XINT num, unit **fu)
00445 {
00446     XINT number = num;
00447     return( do_uio_com( &number, ptr, fu, clen ) );
00448 }
00449 
00450 int
00451 do_uioxh1 (char *ptr, XINT clen, XINT num)
00452 {
00453     XINT number = num;
00454     return( do_uio_com( &number, ptr, &f77curunit, clen ) );
00455 }
00456 
00457 int
00458 do_uioxi1_mp (char *ptr, XINT num, unit **fu)
00459 {
00460     XINT number = num;
00461     return( do_uio_com( &number, ptr, fu, 1 ) );
00462 }
00463 
00464 int
00465 do_uioxi1 (char *ptr, XINT num)
00466 {
00467     XINT number = num;
00468     return( do_uio_com( &number, ptr, &f77curunit, 1 ) );
00469 }
00470 
00471 int
00472 do_uioxi2_mp (char *ptr, XINT num, unit **fu)
00473 {
00474     XINT number = num;
00475     return( do_uio_com( &number, ptr, fu, 2 ) );
00476 }
00477 
00478 int
00479 do_uioxi2 (char *ptr, XINT num)
00480 {
00481     XINT number = num;
00482     return( do_uio_com( &number, ptr, &f77curunit, 2 ) );
00483 }
00484 
00485 int
00486 do_uioxi4_mp (char *ptr, XINT num, unit **fu)
00487 {
00488     XINT number = num;
00489     return( do_uio_com( &number, ptr, fu, 4 ) );
00490 }
00491 
00492 int
00493 do_uioxi4 (char *ptr, XINT num)
00494 {
00495     XINT number = num;
00496     return( do_uio_com( &number, ptr, &f77curunit, 4 ) );
00497 }
00498 
00499 int
00500 do_uioxi8_mp (char *ptr, XINT num, unit **fu)
00501 {
00502     XINT number = num;
00503     return( do_uio_com( &number, ptr, fu, 8 ) );
00504 }
00505 
00506 int
00507 do_uioxi8 (char *ptr, XINT num)
00508 {
00509     XINT number = num;
00510     return( do_uio_com( &number, ptr, &f77curunit, 8 ) );
00511 }
00512 
00513 int
00514 do_uioxl1_mp (char *ptr, XINT num, unit **fu)
00515 {
00516     XINT number = num;
00517     return( do_uio_com( &number, ptr, fu, 1 ) );
00518 }
00519 
00520 int
00521 do_uioxl1 (char *ptr, XINT num)
00522 {
00523     XINT number = num;
00524     return( do_uio_com( &number, ptr, &f77curunit, 1 ) );
00525 }
00526 
00527 int
00528 do_uioxl2_mp (char *ptr, XINT num, unit **fu)
00529 {
00530     XINT number = num;
00531     return( do_uio_com( &number, ptr, fu, 2 ) );
00532 }
00533 
00534 int
00535 do_uioxl2 (char *ptr, XINT num)
00536 {
00537     XINT number = num;
00538     return( do_uio_com( &number, ptr, &f77curunit, 2 ) );
00539 }
00540 
00541 int
00542 do_uioxl4_mp (char *ptr, XINT num, unit **fu)
00543 {
00544     XINT number = num;
00545     return( do_uio_com( &number, ptr, fu, 4 ) );
00546 }
00547 
00548 int
00549 do_uioxl4 (char *ptr, XINT num)
00550 {
00551     XINT number = num;
00552     return( do_uio_com( &number, ptr, &f77curunit, 4 ) );
00553 }
00554 
00555 int
00556 do_uioxl8_mp (char *ptr, XINT num, unit **fu)
00557 {
00558     XINT number = num;
00559     return( do_uio_com( &number, ptr, fu, 8 ) );
00560 }
00561 
00562 int
00563 do_uioxl8 (char *ptr, XINT num)
00564 {
00565     XINT number = num;
00566     return( do_uio_com( &number, ptr, &f77curunit, 8 ) );
00567 }
00568 
00569 int
00570 do_uioxr4_mp (char *ptr, XINT num, unit **fu)
00571 {
00572     XINT number = num;
00573     return( do_uio_com( &number, ptr, fu, 4 ) );
00574 }
00575 
00576 int
00577 do_uioxr4 (char *ptr, XINT num)
00578 {
00579     XINT number = num;
00580     return( do_uio_com( &number, ptr, &f77curunit, 4 ) );
00581 }
00582 
00583 int
00584 do_uioxr8_mp (char *ptr, XINT num, unit **fu)
00585 {
00586     XINT number = num;
00587     return( do_uio_com( &number, ptr, fu, 8 ) );
00588 }
00589 
00590 int
00591 do_uioxr8 (char *ptr, XINT num)
00592 {
00593     XINT number = num;
00594     return( do_uio_com( &number, ptr, &f77curunit, 8 ) );
00595 }
00596 
00597 int
00598 do_uioxr16_mp (char *ptr, XINT num, unit **fu)
00599 {
00600     XINT number = num;
00601     return( do_uio_com( &number, ptr, fu, 16 ) );
00602 }
00603 
00604 int
00605 do_uioxr16 (char *ptr, XINT num)
00606 {
00607     XINT number = num;
00608     return( do_uio_com( &number, ptr, &f77curunit, 16 ) );
00609 }
00610 
00611 int
00612 do_uioxc4_mp (char *ptr, XINT num, unit **fu)
00613 {
00614     XINT number = num;
00615     return( do_uio_com( &number, ptr, fu, 8 ) );
00616 }
00617 
00618 int
00619 do_uioxc4 (char *ptr, XINT num)
00620 {
00621     XINT number = num;
00622     return( do_uio_com( &number, ptr, &f77curunit, 8 ) );
00623 }
00624 
00625 int
00626 do_uioxc8_mp (char *ptr, XINT num, unit **fu)
00627 {
00628     XINT number = num;
00629     return( do_uio_com( &number, ptr, fu, 16 ) );
00630 }
00631 
00632 int
00633 do_uioxc8 (char *ptr, XINT num)
00634 {
00635     XINT number = num;
00636     return( do_uio_com( &number, ptr, &f77curunit, 16 ) );
00637 }
00638 
00639 int
00640 do_uioxc16_mp (char *ptr, XINT num, unit **fu)
00641 {
00642     XINT number = num;
00643     return( do_uio_com( &number, ptr, fu, 32 ) );
00644 }
00645 
00646 int
00647 do_uioxc16 (char *ptr, XINT num)
00648 {
00649     XINT number = num;
00650     return( do_uio_com( &number, ptr, &f77curunit, 32 ) );
00651 }
00652 
00653 int
00654 do_uioxa4v_mp (ftnint val, unit **fu)
00655 {
00656     ftnint value = val;
00657     XINT number = 1;
00658     return( do_uio_com( &number, (char *)&value, fu, 4 ) );
00659 }
00660 int
00661 do_uioxa4v (ftnint val)
00662 {
00663     ftnint value = val;
00664     XINT number = 1;
00665     return( do_uio_com( &number, (char *)&value, &f77curunit, 4 ) );
00666 }
00667 
00668 int
00669 do_uioxa8v_mp (ftnll val, unit **fu)
00670 {
00671     ftnll value = val;
00672     XINT number = 1;
00673     return( do_uio_com( &number, (char *)&value, fu, 8 ) );
00674 }
00675 
00676 int
00677 do_uioxa8v (ftnll val)
00678 {
00679     ftnll value = val;
00680     XINT number = 1;
00681     return( do_uio_com( &number, (char *)&value, &f77curunit, 8 ) );
00682 }
00683 
00684 int
00685 do_uioxh1v_mp (char val, unit **fu)
00686 {
00687     char value = val;
00688     XINT number = 1;
00689     return( do_uio_com( &number, (char *)&value, fu, 1 ) );
00690 }
00691 
00692 int
00693 do_uioxh1v (char val)
00694 {
00695     char value = val;
00696     XINT number = 1;
00697     return( do_uio_com( &number, (char *)&value, &f77curunit, 1 ) );
00698 }
00699 
00700 int
00701 do_uioxi1v_mp (char val, unit **fu)
00702 {
00703     char value = val;
00704     XINT number = 1;
00705     return( do_uio_com( &number, (char *)&value, fu, 1 ) );
00706 }
00707 
00708 int
00709 do_uioxi1v (char val)
00710 {
00711     char value = val;
00712     XINT number = 1;
00713     return( do_uio_com( &number, (char *)&value, &f77curunit, 1 ) );
00714 }
00715 
00716 int
00717 do_uioxi2v_mp (short val, unit **fu)
00718 {
00719     short value = val;
00720     XINT number = 1;
00721     return( do_uio_com( &number, (char *)&value, fu, 2 ) );
00722 }
00723 
00724 int
00725 do_uioxi2v (short val)
00726 {
00727     short value = val;
00728     XINT number = 1;
00729     return( do_uio_com( &number, (char *)&value, &f77curunit, 2 ) );
00730 }
00731 
00732 int
00733 do_uioxi4v_mp (ftnint val, unit **fu)
00734 {
00735     ftnint value = val;
00736     XINT number = 1;
00737     return( do_uio_com( &number, (char *)&value, fu, 4 ) );
00738 }
00739 
00740 int
00741 do_uioxi4v (ftnint val)
00742 {
00743     ftnint value = val;
00744     XINT number = 1;
00745     return( do_uio_com( &number, (char *)&value, &f77curunit, 4 ) );
00746 }
00747 
00748 int
00749 do_uioxi8v_mp (ftnll val, unit **fu)
00750 {
00751     ftnll value = val;
00752     XINT number = 1;
00753     return( do_uio_com( &number, (char *)&value, fu, 8 ) );
00754 }
00755 
00756 int
00757 do_uioxi8v (ftnll val)
00758 {
00759     ftnll value = val;
00760     XINT number = 1;
00761     return( do_uio_com( &number, (char *)&value, &f77curunit, 8 ) );
00762 }
00763 
00764 int
00765 do_uioxl1v_mp (char val, unit **fu)
00766 {
00767     char value = val;
00768     XINT number = 1;
00769     return( do_uio_com( &number, (char *)&value, fu, 1 ) );
00770 }
00771 
00772 int
00773 do_uioxl1v (char val)
00774 {
00775     char value = val;
00776     XINT number = 1;
00777     return( do_uio_com( &number, (char *)&value, &f77curunit, 1 ) );
00778 }
00779 
00780 int
00781 do_uioxl2v_mp (short val, unit **fu)
00782 {
00783     short value = val;
00784     XINT number = 1;
00785     return( do_uio_com( &number, (char *)&value, fu, 2 ) );
00786 }
00787 
00788 int
00789 do_uioxl2v (short val)
00790 {
00791     short value = val;
00792     XINT number = 1;
00793     return( do_uio_com( &number, (char *)&value, &f77curunit, 2 ) );
00794 }
00795 
00796 int
00797 do_uioxl4v_mp (ftnint val, unit **fu)
00798 {
00799     ftnint value = val;
00800     XINT number = 1;
00801     return( do_uio_com( &number, (char *)&value, fu, 4 ) );
00802 }
00803 
00804 int
00805 do_uioxl4v (ftnint val)
00806 {
00807     ftnint value = val;
00808     XINT number = 1;
00809     return( do_uio_com( &number, (char *)&value, &f77curunit, 4 ) );
00810 }
00811 
00812 int
00813 do_uioxl8v_mp (ftnll val, unit **fu)
00814 {
00815     ftnll value = val;
00816     XINT number = 1;
00817     return( do_uio_com( &number, (char *)&value, fu, 8 ) );
00818 }
00819 
00820 int
00821 do_uioxl8v (ftnll val)
00822 {
00823     ftnll value = val;
00824     XINT number = 1;
00825     return( do_uio_com( &number, (char *)&value, &f77curunit, 8 ) );
00826 }
00827 
00828 int
00829 do_uioxr4v_mp (float val, unit **fu)
00830 {
00831     float value = val;
00832     XINT number = 1;
00833     return( do_uio_com( &number, (char *)&value, fu, 4 ) );
00834 }
00835 
00836 int
00837 do_uioxr4v (float val)
00838 {
00839     float value = val;
00840     XINT number = 1;
00841     return( do_uio_com( &number, (char *)&value, &f77curunit, 4 ) );
00842 }
00843 
00844 int
00845 do_uioxr8v_mp (double val, unit **fu)
00846 {
00847     double value = val;
00848     XINT number = 1;
00849     return( do_uio_com( &number, (char *)&value, fu, 8 ) );
00850 }
00851 
00852 int
00853 do_uioxr8v (double val)
00854 {
00855     double value = val;
00856     XINT number = 1;
00857     return( do_uio_com( &number, (char *)&value, &f77curunit, 8 ) );
00858 }
00859 
00860 int
00861 do_uioxr16v_mp (long double val, unit **fu)
00862 {
00863     long double value = val;
00864     XINT number = 1;
00865     return( do_uio_com( &number, (char *)&value, fu, 16 ) );
00866 }
00867 
00868 int
00869 do_uioxr16v (long double val)
00870 {
00871     long double value = val;
00872     XINT number = 1;
00873     return( do_uio_com( &number, (char *)&value, &f77curunit, 16 ) );
00874 }
00875 
00876 int
00877 do_uioxc4v_mp (float rval, float ival, unit **fu)
00878 {
00879     float value[2];
00880     XINT number = 1;
00881     value[0] = rval;
00882     value[1] = ival;
00883     return( do_uio_com( &number, (char *)&value, fu, 8 ) );
00884 }
00885 
00886 int
00887 do_uioxc4v (float rval, float ival)
00888 {
00889     float value[2];
00890     XINT number = 1;
00891     value[0] = rval;
00892     value[1] = ival;
00893     return( do_uio_com( &number, (char *)&value, &f77curunit, 8 ) );
00894 }
00895 
00896 int
00897 do_uioxc8v_mp (double rval, double ival, unit **fu)
00898 {
00899     double value[2];
00900     XINT number = 1;
00901     value[0] = rval;
00902     value[1] = ival;
00903     return( do_uio_com( &number, (char *)&value, fu, 16 ) );
00904 }
00905 
00906 int
00907 do_uioxc8v (double rval, double ival)
00908 {
00909     double value[2];
00910     XINT number = 1;
00911     value[0] = rval;
00912     value[1] = ival;
00913     return( do_uio_com( &number, (char *)&value, &f77curunit, 16 ) );
00914 }
00915 
00916 int
00917 do_uioxc16v_mp (long double rval, long double ival, unit **fu)
00918 {
00919     long double value[2];
00920     XINT number = 1;
00921     value[0] = rval;
00922     value[1] = ival;
00923     return( do_uio_com( &number, (char *)&value, fu, 32 ) );
00924 }
00925 
00926 int
00927 do_uioxc16v (long double rval, long double ival)
00928 {
00929     long double value[2];
00930     XINT number = 1;
00931     value[0] = rval;
00932     value[1] = ival;
00933     return( do_uio_com( &number, (char *)&value, &f77curunit, 32 ) );
00934 }
00935 
00936 /*  ========================================================================  */
00937 
00938 
00939 int
00940 gather_in_f77fio_buf( 
00941     char *f77fio_buf, int f77fio_size, 
00942     char *nptr, char *lastptr, XINT step, 
00943     ftnlen len, flag direction)
00944 {
00945    int nelem, i;
00946    int stepsize = step*len;
00947    char *ptr;
00948 
00949    nelem = MIN( f77fio_size/len, (lastptr-nptr) / (len*step) + 1); 
00950    if (len == 4) {
00951      for (i = 0, ptr = f77fio_buf; i < nelem; i++) {
00952   *(int *)ptr = *(int *) nptr;
00953   nptr += stepsize;
00954   ptr += 4;
00955      }
00956    }
00957    else if (len == 8) {
00958       for (i = 0, ptr = f77fio_buf; i < nelem; i++) {
00959   *(double *)ptr = *(double *) nptr;
00960   nptr += stepsize;
00961   ptr += 8;
00962       }
00963    }
00964    else if (len == 16) {
00965       for (i = 0, ptr = f77fio_buf; i < nelem; i++) {
00966         *(double *)ptr = *(double *) nptr;
00967   nptr += stepsize;
00968   ptr += 8;
00969   *(double *)ptr = *(double *) nptr;
00970   nptr += stepsize;
00971   ptr += 8;
00972       }
00973    }
00974    else if (len == 32) {
00975       for (i = 0, ptr = f77fio_buf; i < nelem; i++) {
00976   *(double *)ptr = *(double *) nptr;
00977   nptr += stepsize;
00978   ptr += 8;
00979   *(double *)ptr = *(double *) nptr;
00980   nptr += stepsize;
00981   ptr += 8;
00982   *(double *)ptr = *(double *) nptr;
00983   nptr += stepsize;
00984   ptr += 8;
00985   *(double *)ptr = *(double *) nptr;
00986   nptr += stepsize;
00987   ptr += 8;
00988       }
00989    }
00990    else if (len == 2) {
00991       for (i = 0, ptr = f77fio_buf; i < nelem; i++) {
00992   *(short *)ptr = *(short *) nptr;
00993   nptr += stepsize;
00994   ptr += 2;
00995       }
00996    }
00997    else {
00998       for (i = 0, ptr = f77fio_buf; i < nelem; i++) {
00999   *ptr = *nptr;
01000   nptr += stepsize;
01001   ptr += 1;
01002       }
01003    }
01004    return( nelem );
01005 }
01006 
01007 int
01008 scatter_from_f77fio_buf( 
01009     unit *ftnunit, char *nptr, char *lastptr, 
01010     XINT step, ftnlen len, flag direction)
01011 {
01012    int nelem, i;
01013    int stepsize = step*len;
01014    char *ptr;
01015 
01016    if (direction == FORWARD)
01017       nelem = MIN( ftnunit->f77fio_size/len, (lastptr-nptr) / (len*step) + 1); 
01018    else
01019       nelem = MIN( ftnunit->f77fio_size/len, (nptr-lastptr) / (len*step) + 1);
01020    if (len == 4) {
01021      for (i = 0, ptr = ftnunit->f77fio_buf; i < nelem; i++) {
01022   *(int *)nptr = *(int *)ptr;
01023   nptr += stepsize;
01024   ptr += 4;
01025      }
01026    }
01027    else if (len == 8) {
01028       for (i = 0, ptr = ftnunit->f77fio_buf; i < nelem; i++) {
01029   *(double *)nptr = *(double *)ptr;
01030   nptr += stepsize;
01031   ptr += 8;
01032       }
01033    }
01034    else if (len == 16) {
01035       for (i = 0, ptr = ftnunit->f77fio_buf; i < nelem; i++) {
01036         *(double *)nptr = *(double *)ptr;
01037   nptr += stepsize;
01038   ptr += 8;
01039   *(double *)nptr = *(double *)ptr;
01040   nptr += stepsize;
01041   ptr += 8;
01042      }
01043    }
01044    else if (len == 32) {
01045       for (i = 0, ptr = ftnunit->f77fio_buf; i < nelem; i++) {
01046   *(double *)nptr = *(double *)ptr;
01047   nptr += stepsize;
01048   ptr += 8;
01049   *(double *)nptr = *(double *)ptr;
01050   nptr += stepsize;
01051   ptr += 8;
01052   *(double *)nptr = *(double *)ptr;
01053   nptr += stepsize;
01054   ptr += 8;
01055   *(double *)nptr = *(double *)ptr;
01056   nptr += stepsize;
01057   ptr += 8;
01058       }
01059    }
01060    else if (len == 2) {
01061       for (i = 0, ptr = ftnunit->f77fio_buf; i < nelem; i++) {
01062   *(short *)nptr = *(short *)ptr;
01063   nptr += stepsize;
01064   ptr += 2;
01065       }
01066    }
01067    else {
01068       for (i = 0, ptr = ftnunit->f77fio_buf; i < nelem; i++) {
01069   *nptr = *ptr;
01070   nptr += stepsize;
01071   ptr += 1;
01072       }
01073    }
01074    return( nelem );
01075 }