00001
00002
00003
00004
00005
00006
00007
00008
00009
00010
00011
00012
00013
00014
00015
00016
00017
00018
00019
00020
00021
00022
00023
00024
00025
00026
00027
00028
00029
00030
00031
00032
00033
00034
00035
00036
00037
00038
00039
00040
00041 #include <cmplrs/fio.h>
00042 #include <limits.h>
00043 #include "fmt.h"
00044 #include "err.h"
00045 #include "varfmt.h"
00046 #include "iomode.h"
00047 #include "bcompat.h"
00048 #include "uio.h"
00049
00050 #define skip(s) while(*s==' ') s++
00051 #ifdef interdata
00052 #define SYLMX 300
00053 #endif
00054 #ifdef pdp11
00055 #define SYLMX 300
00056 #endif
00057 #ifdef vax
00058 #define SYLMX 300
00059 #endif
00060 #ifndef SYLMX
00061 #define SYLMX 300
00062 #endif
00063 #define MYQUOTE '\2'
00064 #define MYHOLL '\3'
00065 #define MYESC '\7'
00066
00067 extern vfmt_struct f77vfmt_com_;
00068
00069
00070
00071
00072 int _type_f(int);
00073 static char *f_s(unit *, char *, int);
00074 static char *f_list(unit *, char *);
00075 static char *i_tem(unit *, char *);
00076 static char *gt_num(unit *, char *, int *);
00077 static char *gt_wnum(unit *, char *, int *);
00078
00079 int
00080 pars_f (unit *ftnunit, char *s)
00081 {
00082 ftnunit->parenlvl = ftnunit->revloc = ftnunit->pc = 0;
00083 if ((s = f_s (ftnunit, s, 0)) == NULL) {
00084 return (-1);
00085 }
00086 return (0);
00087 }
00088
00089 static char *
00090 f_s(unit *ftnunit, char *s, int curloc)
00091 {
00092 skip (s);
00093 if (*s++ != '(') {
00094 return (NULL);
00095 }
00096 if (ftnunit->parenlvl++ == 1)
00097 ftnunit->revloc = curloc;
00098 if (op_gen (ftnunit, RET, curloc, 0, 0) < 0 ||
00099 (s = f_list (ftnunit, s)) == NULL) {
00100 return (NULL);
00101 }
00102 skip (s);
00103 return (s);
00104 }
00105
00106 static char *
00107 f_list(unit *ftnunit, char *s)
00108 {
00109 for (; *s != 0;) {
00110 skip (s);
00111 if ((s = i_tem (ftnunit, s)) == NULL)
00112 return (NULL);
00113 skip (s);
00114 if (*s == ',')
00115 s++;
00116 else if (*s == ')') {
00117 if (--ftnunit->parenlvl == 0) {
00118 (void) op_gen (ftnunit, REVERT, ftnunit->revloc, 0, 0);
00119 return (++s);
00120 }
00121 (void) op_gen (ftnunit, GOTO, 0, 0, 0);
00122 return (++s);
00123 }
00124 }
00125 return (NULL);
00126 }
00127
00128 static char *
00129 i_tem(unit *ftnunit, char *s)
00130 {
00131 char *t;
00132 int n, curloc;
00133
00134 if (*s == ')')
00135 return (s);
00136 if (ne_d (ftnunit, s, &t))
00137 return (t);
00138 if (e_d (ftnunit, s, &t))
00139 return (t);
00140 s = gt_num (ftnunit, s, &n);
00141 if ((curloc = op_gen (ftnunit, STACK, n, 0, 0)) < 0)
00142 return (NULL);
00143 return (f_s (ftnunit, s, curloc));
00144 }
00145
00146 int
00147 ne_d (unit *ftnunit, char *s, char **p)
00148 {
00149 int n, x, sign = 0;
00150
00151 switch (*s) {
00152 default:
00153 return (0);
00154 case ':':
00155 (void) op_gen (ftnunit, COLON, 0, 0, 0);
00156 break;
00157 case '$':
00158 if (ftnunit->uwrt & WR_OP)
00159 (void) op_gen (ftnunit, NONL, 0, 0, 0);
00160 break;
00161 case 'B':
00162 case 'b':
00163 if (*++s == 'z' || *s == 'Z')
00164 (void) op_gen (ftnunit, BZ, 0, 0, 0);
00165 #ifdef I90
00166 else if (*s == 'n' || *s == 'N')
00167 (void) op_gen (ftnunit, BN, 0, 0, 0);
00168 else {
00169 s--;
00170 return(0);
00171 }
00172 #else
00173 else
00174 (void) op_gen (ftnunit, BN, 0, 0, 0);
00175 #endif
00176 break;
00177 case 'S':
00178 case 's':
00179 if (*(s + 1) == 's' || *(s + 1) == 'S') {
00180 x = SS;
00181 s++;
00182 } else if (*(s + 1) == 'p' || *(s + 1) == 'P') {
00183 x = SP;
00184 s++;
00185 } else
00186 x = S;
00187 (void) op_gen (ftnunit, x, 0, 0, 0);
00188 break;
00189 case '/':
00190 #ifdef I90
00191 (void) op_gen (ftnunit, SLASH, 1, 0, 0);
00192 #else
00193 (void) op_gen (ftnunit, SLASH, 0, 0, 0);
00194 #endif
00195 break;
00196 case '-':
00197 sign = 1;
00198 case '+':
00199 s++;
00200 case '0':
00201 case '1':
00202 case '2':
00203 case '3':
00204 case '4':
00205 case '5':
00206 case '6':
00207 case '7':
00208 case '8':
00209 case '9':
00210 case MYESC:
00211 s = gt_num (ftnunit, s, &n);
00212 switch (*s) {
00213 default:
00214 return (0);
00215 case 'P':
00216 case 'p':
00217 if (sign) n = -n;
00218 (void) op_gen (ftnunit, P, n, 0, 0);
00219 break;
00220 case 'X':
00221 case 'x':
00222 if (sign) return (0);
00223 (void) op_gen (ftnunit, X, n, 0, 0);
00224 break;
00225 case 'H':
00226 case 'h':
00227 if (sign) return (0);
00228 (void) op_gen (ftnunit, H, n, (long) (s + 1), 0);
00229 s += n;
00230 break;
00231 #ifdef I90
00232 case '/':
00233 if (sign) return (0);
00234 (void) op_gen (ftnunit, SLASH, n, 0, 0);
00235 break;
00236 #endif
00237 }
00238 break;
00239 case MYQUOTE:
00240 case MYHOLL:
00241 case '"':
00242 case '\'':
00243 (void) op_gen (ftnunit, APOS, (long) s, 0, 0);
00244 if ((*p = ap_end (ftnunit, s)) == NULL)
00245 return (0);
00246 return (1);
00247 case 'T':
00248 case 't':
00249 if (*(s + 1) == 'l' || *(s + 1) == 'L') {
00250 x = TL;
00251 s++;
00252 } else if (*(s + 1) == 'r' || *(s + 1) == 'R') {
00253 x = TR;
00254 s++;
00255 } else
00256 x = T;
00257 s = gt_num (ftnunit, s + 1, &n);
00258 s--;
00259 (void) op_gen (ftnunit, x, n, 0, 0);
00260 break;
00261 case 'X':
00262 case 'x':
00263 (void) op_gen (ftnunit, X, 1, 0, 0);
00264 break;
00265 case 'P':
00266 case 'p':
00267 (void) op_gen (ftnunit, P, 1, 0, 0);
00268 break;
00269 }
00270 s++;
00271 *p = s;
00272 return (1);
00273 }
00274
00275 int
00276 e_d (unit *ftnunit, char *s, char **p)
00277 {
00278 int n, w, d, e, found = 0, x = 0;
00279 char *sv = s;
00280
00281 s = gt_num (ftnunit, s, &n);
00282 (void) op_gen (ftnunit, STACK, n, 0, 0);
00283 switch (*s++) {
00284 default:
00285 break;
00286 case 'E':
00287 case 'e':
00288 x = 1;
00289 #ifdef I90
00290 if ( ftnunit->f90sw == 1 ) {
00291 if ( *s == 'S' || *s == 's' ) {
00292 x = 2;
00293 s++;
00294 } else if ( *s == 'N' || *s == 'n' ) {
00295 x = 3;
00296 s++;
00297 }
00298 }
00299 #endif
00300 case 'G':
00301 case 'g':
00302 found = 1;
00303 s = gt_wnum (ftnunit, s, &w);
00304 if (*s == '.') {
00305 s++;
00306 s = gt_num (ftnunit, s, &d);
00307 } else
00308 d = 0;
00309 #ifdef I90
00310 if (*s != 'E' && *s != 'e')
00311 (void) op_gen (ftnunit, x == 1 ? E : x == 2 ? ES : x == 3 ? EN : G, w, d, 0);
00312 else {
00313 s++;
00314 s = gt_num (ftnunit, s, &e);
00315 (void) op_gen (ftnunit, x == 1 ? EE : x == 2 ? ESE : x == 3 ? ENE : GE, w, d, e);
00316 }
00317 #else
00318 if (*s != 'E' && *s != 'e')
00319 (void) op_gen (ftnunit, x == 1 ? E : G, w, d, 0);
00320 else {
00321 s++;
00322 s = gt_num (ftnunit, s, &e);
00323 (void) op_gen (ftnunit, x == 1 ? EE : GE, w, d, e);
00324 }
00325 #endif
00326 break;
00327 case 'O':
00328 case 'o':
00329 found = 1;
00330 s = gt_wnum (ftnunit, s, &w);
00331 if (*s != '.') {
00332 (void) op_gen (ftnunit, O, w, 0, 0);
00333 break;
00334 }
00335 s++;
00336 s = gt_num (ftnunit, s, &d);
00337 (void) op_gen (ftnunit, OM, w, d, 0);
00338 break;
00339 case 'Z':
00340 case 'z':
00341 found = 1;
00342 s = gt_wnum (ftnunit, s, &w);
00343 if (*s != '.') {
00344 (void) op_gen (ftnunit, Z, w, 0, 0);
00345 break;
00346 }
00347 s++;
00348 s = gt_num (ftnunit, s, &d);
00349 (void) op_gen (ftnunit, ZM, w, d, 0);
00350 break;
00351 #ifdef I90
00352 case 'B':
00353 case 'b':
00354 if ( ftnunit->f90sw == 1 ) {
00355 if ( *s == 'N' || *s == 'n' || *s == 'L' || *s == 'l' ) break;
00356 found = 1;
00357 s = gt_wnum (ftnunit, s, &w);
00358 if (*s != '.') {
00359 (void) op_gen (ftnunit, B, w, 0, 0);
00360 break;
00361 }
00362 s++;
00363 s = gt_num (ftnunit, s, &d);
00364 (void) op_gen (ftnunit, BM, w, d, 0);
00365 }
00366 break;
00367 #endif
00368 case 'Q':
00369 case 'q':
00370 found = 1;
00371 (void) op_gen (ftnunit, Q, 0, 0, 0);
00372 break;
00373 case 'L':
00374 case 'l':
00375 found = 1;
00376 s = gt_wnum (ftnunit, s, &w);
00377 (void) op_gen (ftnunit, L, w, 0, 0);
00378 break;
00379 case 'A':
00380 case 'a':
00381 found = 1;
00382 s = gt_wnum (ftnunit, s, &w);
00383 if (w)
00384 (void) op_gen (ftnunit, AW, w, 0, 0);
00385 else
00386 (void) op_gen (ftnunit, A, 0, 0, 0);
00387 break;
00388 case 'F':
00389 case 'f':
00390 found = 1;
00391 s = gt_wnum (ftnunit, s, &w);
00392 if (*s == '.') {
00393 s++;
00394 s = gt_num (ftnunit, s, &d);
00395 } else
00396 d = 0;
00397 (void) op_gen (ftnunit, F, w, d, 0);
00398 break;
00399 case 'D':
00400 case 'd':
00401 found = 1;
00402 s = gt_wnum (ftnunit, s, &w);
00403 if (*s == '.') {
00404 s++;
00405 s = gt_num (ftnunit, s, &d);
00406 } else
00407 d = 0;
00408 (void) op_gen (ftnunit, D, w, d, 0);
00409 break;
00410 case 'I':
00411 case 'i':
00412 found = 1;
00413 s = gt_wnum (ftnunit, s, &w);
00414 if (*s != '.') {
00415 (void) op_gen (ftnunit, I, w, 0, 0);
00416 break;
00417 }
00418 s++;
00419 s = gt_num (ftnunit, s, &d);
00420 (void) op_gen (ftnunit, IM, w, d, 0);
00421 break;
00422 }
00423 if (found == 0) {
00424 ftnunit->pc--;
00425 *p = sv;
00426 return (0);
00427 }
00428 *p = s;
00429 return (1);
00430 }
00431
00432 int
00433 op_gen (unit *ftnunit, int a, long b, long c, int d)
00434 {
00435 struct f77syl *p;
00436
00437 if (!ftnunit->f77syl) {
00438 ftnunit->f77syl_size = SYLMX;
00439 ftnunit->f77syl = (struct f77syl *) malloc (ftnunit->f77syl_size * sizeof (struct f77syl));
00440 } else if (ftnunit->f77syl_size <= ftnunit->pc) {
00441 ftnunit->f77syl_size += SYLMX;
00442 ftnunit->f77syl = (struct f77syl *) realloc (ftnunit->f77syl, ftnunit->f77syl_size * sizeof (struct f77syl));
00443 }
00444 p = &ftnunit->f77syl[ftnunit->pc];
00445 p->op = a;
00446 p->p1 = b;
00447 p->p2 = c;
00448 p->p3 = d;
00449 return (ftnunit->pc++);
00450 }
00451
00452 static char *
00453 gt_wnum(unit *ftnunit, char *s, int *n)
00454 {
00455 skip (s);
00456 if (*s != MYESC && (*s < '0' || *s > '9'))
00457 *n = 0;
00458 else
00459 s = gt_num (ftnunit, s, n);
00460 return (s);
00461 }
00462
00463 static char *
00464 gt_num(unit *ftnunit, char *s, int *n)
00465 {
00466 int m = 0, cnt = 0, escape = 0;
00467 char c;
00468
00469 for (c = *s;; c = *s) {
00470 if (c == ' ') {
00471 s++;
00472 continue;
00473 }
00474 if (c == MYESC) {
00475 escape = 1;
00476 s++;
00477 continue;
00478 }
00479 if (c > '9' || c < '0')
00480 break;
00481 m = 10 * m + c - '0';
00482 cnt++;
00483 s++;
00484 }
00485 if (escape)
00486 *n = call_vfmt(&m, ftnunit->vfmt, ftnunit->vfmtfp);
00487 else if (cnt == 0)
00488 *n = 1;
00489 else
00490 *n = m;
00491 return (s);
00492 }
00493
00494
00495 int
00496 en_fio (unit **ftnunit)
00497 {
00498 XINT one = 1;
00499 ftnint type = TYINT;
00500
00501 return (do_fio_SIZE_mp (&type, &one, (char *) NULL, ftnunit, 0L));
00502 }
00503
00504 #if 11
00505 int
00506 do_fio_1dim( ftnint *type, char *ptr,
00507 flex *do_idx, ftnint *lb,
00508 ftnint *ub, ftnint *step,
00509 ftnlen len, ftnlen idxlen)
00510 {
00511 XINT llb = *lb, lub = *ub, lstep = *step;
00512 return( do_fio64_mp_1dim( type, ptr, do_idx, &llb, &lub, &lstep, &f77curunit, len, idxlen ) );
00513 }
00514
00515 int
00516 do_fio64_1dim( ftnint *type, char *ptr,
00517 flex *do_idx, XINT *lb,
00518 XINT *ub, XINT *step,
00519 ftnlen len, ftnlen idxlen)
00520 {
00521 return( do_fio64_mp_1dim( type, ptr, do_idx, lb, ub, step, &f77curunit, len, idxlen) );
00522 }
00523
00524 int
00525 do_fio64_mp_1dim( ftnint *type, char *ptr,
00526 flex *do_idx, XINT *lb,
00527 XINT *ub, XINT *step,
00528 unit **fu,
00529 ftnlen len, ftnlen idxlen)
00530 #else
00531 int
00532 do_fio_1dim( ftnint *type, char *ptr,
00533 flex *do_idx, ftnint *lb,
00534 ftnint *ub, ftnint *step,
00535 ftnlen len, ftnlen idxlen)
00536 {
00537 return( do_fio_mp_1dim( type, ptr, do_idx, lb, ub, step, &f77curunit, len, idxlen) );
00538 }
00539
00540 int
00541 do_fio_mp_1dim( ftnint *type, char *ptr,
00542 flex *do_idx, ftnint *lb,
00543 ftnint *ub, ftnint *step,
00544 unit **fu,
00545 ftnlen len, ftnlen idxlen)
00546 #endif
00547
00548
00549
00550
00551
00552
00553
00554
00555
00556
00557
00558
00559
00560 {
00561 XINT nelem;
00562 int ierr;
00563 char *lastptr, *nptr;
00564 int iolen;
00565 unit *ftnunit = *fu;
00566
00567 lastptr = ptr + (*ub - 1) * len;
00568 ptr += (*lb - 1) * len;
00569 if (*type == TYCOMPLEX || *type == TYDCOMPLEX || *type == TYQUADCOMPLEX) {
00570 iolen = len / 2;
00571 nelem = 2;
00572 } else {
00573 iolen = len;
00574 nelem = 1;
00575 }
00576 if (*step == 1) {
00577
00578 if ((nelem = nelem *(*ub - *lb + 1)) > 0) {
00579 if (ierr = do_fio_SIZE_mp( type, &nelem, ptr, fu, iolen ) ) {
00580 set_do_idx( do_idx, idxlen, (ftnll) (*lb + (*fu)->lcount) / nelem );
00581 (*fu)->lock_unit = 0;
00582 err((*fu)->f77errlist.cierr,ierr,"formatted I/O");
00583 }
00584 set_do_idx( do_idx, idxlen, (ftnll) (*ub + 1) );
00585 }
00586
00587 return( 0 );
00588 }
00589
00590 if (*step > 0) {
00591 for (nptr = ptr; nptr <= lastptr; nptr += *step*len)
00592 if (ierr = do_fio_SIZE_mp( type, &nelem, nptr, fu, iolen ) ) {
00593 set_do_idx( do_idx, idxlen, (ftnll) (*lb + (nptr - ptr)/len) );
00594 (*fu)->lock_unit = 0;
00595 err((*fu)->f77errlist.cierr,ierr,"formatted I/O");
00596 }
00597 }
00598 else
00599 for (nptr = ptr; nptr >= lastptr; nptr += *step*len)
00600 if (ierr = do_fio_SIZE_mp( type, &nelem, nptr, fu, iolen ) ) {
00601 set_do_idx( do_idx, idxlen, (ftnll) (*lb - (ptr - nptr)/len) );
00602 (*fu)->lock_unit = 0;
00603 err((*fu)->f77errlist.cierr,ierr,"formatted I/O");
00604 }
00605 set_do_idx( do_idx, idxlen, (ftnll) (*lb + ((*ub - *lb) / *step + 1) * *step) );
00606 return(0);
00607 }
00608
00609
00610 int
00611 do_fio (ftnint *type, ftnint *number, char *ptr, ftnlen len)
00612 {
00613 return( do_fio_mp( type, number, ptr, &f77curunit, len ) );
00614 }
00615
00616 #define TBUFLEN 80
00617
00618
00619 int
00620 do_fio64 (ftnint *type, XINT *number, char *ptr, ftnlen len)
00621 {
00622 return( do_fio64_mp( type, number, ptr, &f77curunit, len ) );
00623 }
00624
00625 int
00626 do_fio_mp (ftnint *type, ftnint *number, char *ptr, unit **fu, ftnlen len)
00627 {
00628 XINT lnum = *number;
00629 return( do_fio64_mp( type, &lnum, ptr, fu, len ) );
00630 }
00631
00632 int
00633 do_fio64_mp (ftnint *type, XINT *number, char *ptr, unit **fu, ftnlen len)
00634 {
00635 struct f77syl *p;
00636
00637
00638 XINT i, num = *number;
00639 int n;
00640 unit *ftnunit = *fu;
00641
00642 for (i = 0; i < num; i++, ptr += len) {
00643 loop:switch (_type_f ((p = &ftnunit->f77syl[ftnunit->pc])->op)) {
00644 default:
00645
00646
00647
00648
00649 ftnunit->lcount = i;
00650 errret(ftnunit->f77errlist.cierr, 100, "do_fio");
00651 case NED:
00652 if ((n = (*ftnunit->f77doned) (ftnunit, p)) > 0) {
00653 ftnunit->lcount = i;
00654 errret(ftnunit->f77errlist.cierr, n, "fmt");
00655 }
00656 if (n < 0) {
00657 ftnunit->lcount = i;
00658 errret(ftnunit->f77errlist.ciend, (EOF), "fmt");
00659 }
00660 ftnunit->pc++;
00661 goto loop;
00662 case ED:
00663
00664 if (ftnunit->cnt[ftnunit->cp] <= 0) {
00665 ftnunit->cp--;
00666 ftnunit->pc++;
00667 goto loop;
00668 }
00669 if (ptr == NULL) {
00670 if (n = (*ftnunit->f77doend) (ftnunit))
00671 ftnunit->lock_unit = 0;
00672 return( n );
00673 }
00674 ftnunit->cnt[ftnunit->cp]--;
00675 ftnunit->f77workdone = 1;
00676 if ((n = (*ftnunit->f77doed) (ftnunit, p, ptr, len, *type)) > 0) {
00677 ftnunit->lcount = i;
00678 errret(ftnunit->f77errlist.cierr, n, "fmt");
00679 }
00680 if (n < 0) {
00681 ftnunit->lcount = i;
00682 errret(ftnunit->f77errlist.ciend, (EOF), "fmt");
00683 }
00684 continue;
00685 case STACK:
00686 ftnunit->cnt[++ftnunit->cp] = p->p1;
00687 ftnunit->pc++;
00688 goto loop;
00689 case RET:
00690 ftnunit->ret[++ftnunit->rp] = p->p1;
00691 ftnunit->pc++;
00692 goto loop;
00693 case GOTO:
00694 if (--ftnunit->cnt[ftnunit->cp] <= 0) {
00695 ftnunit->cp--;
00696 ftnunit->rp--;
00697 ftnunit->pc++;
00698 goto loop;
00699 }
00700 ftnunit->pc = 1 + ftnunit->ret[ftnunit->rp--];
00701 goto loop;
00702 case REVERT:
00703 ftnunit->rp = ftnunit->cp = 0;
00704 ftnunit->pc = p->p1;
00705
00706 if (ptr == NULL) {
00707 if (n = (*ftnunit->f77doend) (ftnunit))
00708 ftnunit->lock_unit = 0;
00709 return(n);
00710 }
00711 if (!ftnunit->f77workdone)
00712 return (0);
00713 if ((n = (*ftnunit->f77dorevert) (ftnunit)) != 0) {
00714 ftnunit->lock_unit = 0;
00715 return (n);
00716 }
00717 goto loop;
00718 case COLON:
00719 if (ptr == NULL) {
00720 if (n = (*ftnunit->f77doend) (ftnunit))
00721 ftnunit->lock_unit = 0;
00722 return(n);
00723 }
00724 ftnunit->pc++;
00725 goto loop;
00726 case NONL:
00727 ftnunit->f77nonl = 1;
00728 ftnunit->pc++;
00729 goto loop;
00730 case S:
00731 case SS:
00732 ftnunit->f77cplus = 0;
00733 ftnunit->pc++;
00734 goto loop;
00735 case SP:
00736 ftnunit->f77cplus = 1;
00737 ftnunit->pc++;
00738 goto loop;
00739 case P:
00740 ftnunit->f77scale = (short) p->p1;
00741 ftnunit->pc++;
00742 goto loop;
00743 case BN:
00744 ftnunit->f77cblank = 0;
00745 ftnunit->pc++;
00746 goto loop;
00747 case BZ:
00748 ftnunit->f77cblank = 1;
00749 ftnunit->pc++;
00750 goto loop;
00751 }
00752 }
00753 return (0);
00754 }
00755
00756
00757 void
00758 fmt_bg (unit *ftnunit)
00759 {
00760 ftnunit->f77workdone = ftnunit->cp = ftnunit->rp = ftnunit->pc = 0;
00761 #ifndef I90
00762 ftnunit->f77cursor = 0;
00763 #endif
00764 ftnunit->cnt[0] = ftnunit->ret[0] = 0;
00765 }
00766
00767 int
00768 _type_f(int n)
00769 {
00770 switch(n) {
00771 default:
00772 return(n);
00773 case RET:
00774 return (RET);
00775 case REVERT:
00776 return (REVERT);
00777 case GOTO:
00778 return (GOTO);
00779 case STACK:
00780 return (STACK);
00781 case X:
00782 case SLASH:
00783 case APOS:
00784 case H:
00785 case T:
00786 case TL:
00787 case TR:
00788 return (NED);
00789 case F:
00790 case I:
00791 case IM:
00792 case A:
00793 case AW:
00794 case O:
00795 case OM:
00796 case Z:
00797 case ZM:
00798 case L:
00799 case E:
00800 case EE:
00801 case D:
00802 case G:
00803 case GE:
00804 case Q:
00805 #ifdef I90
00806 case ES:
00807 case ESE:
00808 case EN:
00809 case ENE:
00810 case B:
00811 case BM:
00812 #endif
00813 return (ED);
00814 }
00815 }
00816
00817
00818 char *
00819 ap_end(unit *ftnunit, char *s)
00820 {
00821 char quote;
00822
00823 quote = *s++;
00824 for (; *s; s++) {
00825 if (*s != quote)
00826 continue;
00827 if (*++s != quote)
00828 return (s);
00829 }
00830 if (ftnunit->f77errlist.cierr) {
00831 errno = 100;
00832 return (NULL);
00833 }
00834 f77fatal (ftnunit, 100, "bad string");
00835
00836 return(NULL);
00837 }
00838
00839
00840 int
00841 do_fioi4 (unsigned int val)
00842 {
00843 return( do_fioi4_mp( val, f77curunit ) );
00844 }
00845
00846
00847 int
00848 do_fioi4_mp (unsigned int val, unit *f77curunit)
00849 {
00850 ftnint type = TYINT;
00851 return do_f4f8_mp (&type, &val, f77curunit, 4);
00852 }
00853
00854 int
00855 do_fioi8 (long long val)
00856 {
00857 return( do_fioi8_mp( val, f77curunit ) );
00858 }
00859
00860
00861 int
00862 do_fioi8_mp (long long val, unit *f77curunit)
00863 {
00864 ftnint type = TYLONGLONG;
00865 return do_f4f8_mp (&type, &val, f77curunit, 8);
00866 }
00867
00868 int
00869 do_fior4 (float val)
00870 {
00871 return( do_fior4_mp ( val, f77curunit ) );
00872 }
00873
00874
00875 int
00876 do_fior4_mp (float val, unit *f77curunit)
00877 {
00878 ftnint type = TYREAL;
00879 return do_f4f8_mp (&type, &val, f77curunit, 4);
00880 }
00881
00882 int
00883 do_fio8 (double val)
00884 {
00885 return( do_fio8_mp( val, f77curunit ) );
00886 }
00887
00888
00889 int
00890 do_fio8_mp (double val, unit *f77curunit)
00891 {
00892 ftnint type = TYDREAL;
00893 return do_f4f8_mp (&type, &val, f77curunit, 8);
00894 }
00895
00896 int
00897 do_f4f8 (void *inptr, ftnlen len)
00898 {
00899 ftnint type;
00900 type = (len == 4 ? TYREAL : TYDREAL );
00901 return( do_f4f8_mp(&type, inptr, f77curunit, len ) );
00902 }
00903
00904
00905
00906 int
00907 do_f4f8_mp (ftnint *type, void *inptr, unit *ftnunit, ftnlen len)
00908 {
00909 char *ptr = (char *) inptr;
00910 struct f77syl *p;
00911 int n;
00912
00913 loop:switch (_type_f ((p = &ftnunit->f77syl[ftnunit->pc])->op)) {
00914 default:
00915
00916
00917
00918
00919 errret(ftnunit->f77errlist.cierr, 100, "do_fio");
00920 case NED:
00921 if ((n = (*ftnunit->f77doned) (ftnunit, p)) > 0)
00922 errret(ftnunit->f77errlist.cierr, n, "fmt");
00923 if (n < 0)
00924 errret(ftnunit->f77errlist.ciend, (EOF), "fmt");
00925 ftnunit->pc++;
00926 goto loop;
00927 case ED:
00928 if (ftnunit->cnt[ftnunit->cp] <= 0) {
00929 ftnunit->cp--;
00930 ftnunit->pc++;
00931 goto loop;
00932 }
00933 if (ptr == NULL) {
00934 if (n = (*ftnunit->f77doend) (ftnunit))
00935 ftnunit->lock_unit = 0;
00936 return(n);
00937 }
00938 ftnunit->cnt[ftnunit->cp]--;
00939 ftnunit->f77workdone = 1;
00940 if ((n = (*ftnunit->f77doed) (ftnunit, p, ptr, len, *type)) > 0)
00941 errret(ftnunit->f77errlist.cierr, n, "fmt");
00942 if (n < 0)
00943 errret(ftnunit->f77errlist.ciend, (EOF), "fmt");
00944 break;
00945 case STACK:
00946 ftnunit->cnt[++ftnunit->cp] = p->p1;
00947 ftnunit->pc++;
00948 goto loop;
00949 case RET:
00950 ftnunit->ret[++ftnunit->rp] = p->p1;
00951 ftnunit->pc++;
00952 goto loop;
00953 case GOTO:
00954 if (--ftnunit->cnt[ftnunit->cp] <= 0) {
00955 ftnunit->cp--;
00956 ftnunit->rp--;
00957 ftnunit->pc++;
00958 goto loop;
00959 }
00960 ftnunit->pc = 1 + ftnunit->ret[ftnunit->rp--];
00961 goto loop;
00962 case REVERT:
00963 ftnunit->rp = ftnunit->cp = 0;
00964 ftnunit->pc = p->p1;
00965 if (ptr == NULL) {
00966 if (n = (*ftnunit->f77doend) (ftnunit))
00967 ftnunit->lock_unit = 0;
00968 return(n);
00969 }
00970 if (!ftnunit->f77workdone)
00971 return (0);
00972 if ((n = (*ftnunit->f77dorevert) (ftnunit)) != 0) {
00973 ftnunit->lock_unit = 0;
00974 return (n);
00975 }
00976 goto loop;
00977 case COLON:
00978 if (ptr == NULL) {
00979 if (n = (*ftnunit->f77doend) (ftnunit))
00980 ftnunit->lock_unit = 0;
00981 return(n);
00982 }
00983 ftnunit->pc++;
00984 goto loop;
00985 case NONL:
00986 ftnunit->f77nonl = 1;
00987 ftnunit->pc++;
00988 goto loop;
00989 case S:
00990 case SS:
00991 ftnunit->f77cplus = 0;
00992 ftnunit->pc++;
00993 goto loop;
00994 case SP:
00995 ftnunit->f77cplus = 1;
00996 ftnunit->pc++;
00997 goto loop;
00998 case P:
00999 ftnunit->f77scale = (short) p->p1;
01000 ftnunit->pc++;
01001 goto loop;
01002 case BN:
01003 ftnunit->f77cblank = 0;
01004 ftnunit->pc++;
01005 goto loop;
01006 case BZ:
01007 ftnunit->f77cblank = 1;
01008 ftnunit->pc++;
01009 goto loop;
01010 }
01011 return (0);
01012 }
01013
01014 #ifdef I90
01015 int test_type(int op, ftnint type)
01016 {
01017 switch (op) {
01018 case F:
01019 case D:
01020 case E:
01021 case EE:
01022 case EN:
01023 case ENE:
01024 case ES:
01025 case ESE:
01026 switch (type) {
01027 case TYREAL:
01028 case TYDREAL:
01029 case TYCOMPLEX:
01030 case TYDCOMPLEX:
01031 case TYQUAD:
01032 case TYQUADCOMPLEX:
01033 return(0);
01034 default:
01035 return(117);
01036 }
01037 case I:
01038 case IM:
01039 case B:
01040 case BM:
01041 case O:
01042 case OM:
01043 case Z:
01044 case ZM:
01045 switch (type) {
01046 case TYBYTE:
01047 case TYSHORT:
01048 case TYINT:
01049 case TYLONGLONG:
01050 return(0);
01051 default:
01052 return(117);
01053 }
01054 case L:
01055 switch (type) {
01056 case TYLOGICAL1:
01057 case TYLOGICAL2:
01058 case TYLOGICAL4:
01059 case TYLOGICAL8:
01060 return(0);
01061 default:
01062 return(117);
01063 }
01064 case A:
01065 case AW:
01066 switch (type) {
01067 case TYCHAR:
01068 return(0);
01069 default:
01070 return(117);
01071 }
01072 default:
01073 break;
01074 }
01075 return(0);
01076 }
01077 #endif
01078
01079
01080
01081
01082
01083
01084
01085
01086
01087
01088
01089 int
01090 do_fioxa4_mp (char *ptr, XINT num, unit **fu)
01091 {
01092 ftnint type = TYADDR;
01093 XINT number = num;
01094 return( do_fio64_mp( &type, &number, ptr, fu, 4 ) );
01095 }
01096
01097 int
01098 do_fioxa4 (char *ptr, XINT num)
01099 {
01100 ftnint type = TYADDR;
01101 XINT number = num;
01102 return( do_fio64_mp( &type, &number, ptr, &f77curunit, 4 ) );
01103 }
01104
01105 int
01106 do_fioxa8_mp (char *ptr, XINT num, unit **fu)
01107 {
01108 ftnint type = TYADDR;
01109 XINT number = num;
01110 return( do_fio64_mp( &type, &number, ptr, fu, 8 ) );
01111 }
01112
01113 int
01114 do_fioxa8 (char *ptr, XINT num)
01115 {
01116 ftnint type = TYADDR;
01117 XINT number = num;
01118 return( do_fio64_mp( &type, &number, ptr, &f77curunit, 8 ) );
01119 }
01120
01121 int
01122 do_fioxh1_mp (char *ptr, XINT clen, XINT num, unit **fu)
01123 {
01124 ftnint type = TYCHAR;
01125 XINT number = num;
01126 return( do_fio64_mp( &type, &number, ptr, fu, clen ) );
01127 }
01128
01129 int
01130 do_fioxh1 (char *ptr, XINT clen, XINT num)
01131 {
01132 ftnint type = TYCHAR;
01133 XINT number = num;
01134 return( do_fio64_mp( &type, &number, ptr, &f77curunit, clen ) );
01135 }
01136
01137 int
01138 do_fioxi1_mp (char *ptr, XINT num, unit **fu)
01139 {
01140 ftnint type = TYBYTE;
01141 XINT number = num;
01142 return( do_fio64_mp( &type, &number, ptr, fu, 1 ) );
01143 }
01144
01145 int
01146 do_fioxi1 (char *ptr, XINT num)
01147 {
01148 ftnint type = TYBYTE;
01149 XINT number = num;
01150 return( do_fio64_mp( &type, &number, ptr, &f77curunit, 1 ) );
01151 }
01152
01153 int
01154 do_fioxi2_mp (char *ptr, XINT num, unit **fu)
01155 {
01156 ftnint type = TYSHORT;
01157 XINT number = num;
01158 return( do_fio64_mp( &type, &number, ptr, fu, 2 ) );
01159 }
01160
01161 int
01162 do_fioxi2 (char *ptr, XINT num)
01163 {
01164 ftnint type = TYSHORT;
01165 XINT number = num;
01166 return( do_fio64_mp( &type, &number, ptr, &f77curunit, 2 ) );
01167 }
01168
01169 int
01170 do_fioxi4_mp (char *ptr, XINT num, unit **fu)
01171 {
01172 ftnint type = TYINT;
01173 XINT number = num;
01174 return( do_fio64_mp( &type, &number, ptr, fu, 4 ) );
01175 }
01176
01177 int
01178 do_fioxi4 (char *ptr, XINT num)
01179 {
01180 ftnint type = TYINT;
01181 XINT number = num;
01182 return( do_fio64_mp( &type, &number, ptr, &f77curunit, 4 ) );
01183 }
01184
01185 int
01186 do_fioxi8_mp (char *ptr, XINT num, unit **fu)
01187 {
01188 ftnint type = TYLONGLONG;
01189 XINT number = num;
01190 return( do_fio64_mp( &type, &number, ptr, fu, 8 ) );
01191 }
01192
01193 int
01194 do_fioxi8 (char *ptr, XINT num)
01195 {
01196 ftnint type = TYLONGLONG;
01197 XINT number = num;
01198 return( do_fio64_mp( &type, &number, ptr, &f77curunit, 8 ) );
01199 }
01200
01201 int
01202 do_fioxl1_mp (char *ptr, XINT num, unit **fu)
01203 {
01204 ftnint type = TYLOGICAL1;
01205 XINT number = num;
01206 return( do_fio64_mp( &type, &number, ptr, fu, 1 ) );
01207 }
01208
01209 int
01210 do_fioxl1 (char *ptr, XINT num)
01211 {
01212 ftnint type = TYLOGICAL1;
01213 XINT number = num;
01214 return( do_fio64_mp( &type, &number, ptr, &f77curunit, 1 ) );
01215 }
01216
01217 int
01218 do_fioxl2_mp (char *ptr, XINT num, unit **fu)
01219 {
01220 ftnint type = TYLOGICAL2;
01221 XINT number = num;
01222 return( do_fio64_mp( &type, &number, ptr, fu, 2 ) );
01223 }
01224
01225 int
01226 do_fioxl2 (char *ptr, XINT num)
01227 {
01228 ftnint type = TYLOGICAL2;
01229 XINT number = num;
01230 return( do_fio64_mp( &type, &number, ptr, &f77curunit, 2 ) );
01231 }
01232
01233 int
01234 do_fioxl4_mp (char *ptr, XINT num, unit **fu)
01235 {
01236 ftnint type = TYLOGICAL4;
01237 XINT number = num;
01238 return( do_fio64_mp( &type, &number, ptr, fu, 4 ) );
01239 }
01240
01241 int
01242 do_fioxl4 (char *ptr, XINT num)
01243 {
01244 ftnint type = TYLOGICAL4;
01245 XINT number = num;
01246 return( do_fio64_mp( &type, &number, ptr, &f77curunit, 4 ) );
01247 }
01248
01249 int
01250 do_fioxl8_mp (char *ptr, XINT num, unit **fu)
01251 {
01252 ftnint type = TYLOGICAL8;
01253 XINT number = num;
01254 return( do_fio64_mp( &type, &number, ptr, fu, 8 ) );
01255 }
01256
01257 int
01258 do_fioxl8 (char *ptr, XINT num)
01259 {
01260 ftnint type = TYLOGICAL8;
01261 XINT number = num;
01262 return( do_fio64_mp( &type, &number, ptr, &f77curunit, 8 ) );
01263 }
01264
01265 int
01266 do_fioxr4_mp (char *ptr, XINT num, unit **fu)
01267 {
01268 ftnint type = TYREAL;
01269 XINT number = num;
01270 return( do_fio64_mp( &type, &number, ptr, fu, 4 ) );
01271 }
01272
01273 int
01274 do_fioxr4 (char *ptr, XINT num)
01275 {
01276 ftnint type = TYREAL;
01277 XINT number = num;
01278 return( do_fio64_mp( &type, &number, ptr, &f77curunit, 4 ) );
01279 }
01280
01281 int
01282 do_fioxr8_mp (char *ptr, XINT num, unit **fu)
01283 {
01284 ftnint type = TYDREAL;
01285 XINT number = num;
01286 return( do_fio64_mp( &type, &number, ptr, fu, 8 ) );
01287 }
01288
01289 int
01290 do_fioxr8 (char *ptr, XINT num)
01291 {
01292 ftnint type = TYDREAL;
01293 XINT number = num;
01294 return( do_fio64_mp( &type, &number, ptr, &f77curunit, 8 ) );
01295 }
01296
01297 int
01298 do_fioxr16_mp (char *ptr, XINT num, unit **fu)
01299 {
01300 ftnint type = TYQUAD;
01301 XINT number = num;
01302 return( do_fio64_mp( &type, &number, ptr, fu, 16 ) );
01303 }
01304
01305 int
01306 do_fioxr16 (char *ptr, XINT num)
01307 {
01308 ftnint type = TYQUAD;
01309 XINT number = num;
01310 return( do_fio64_mp( &type, &number, ptr, &f77curunit, 16 ) );
01311 }
01312
01313 int
01314 do_fioxc4_mp (char *ptr, XINT num, unit **fu)
01315 {
01316 ftnint type = TYREAL;
01317 XINT number = 1;
01318 char *endptr = ptr + (8 * num);
01319 int status;
01320 for (; ptr<endptr; ptr+=4)
01321 if (status = do_fio64_mp( &type, &number, ptr, fu, 4 )) break;
01322 return( status );
01323 }
01324
01325 int
01326 do_fioxc4 (char *ptr, XINT num)
01327 {
01328 ftnint type = TYREAL;
01329 XINT number = 1;
01330 char *endptr = ptr + (8 * num);
01331 int status;
01332 for (; ptr<endptr; ptr+=4)
01333 if (status = do_fio64_mp( &type, &number, ptr, &f77curunit, 4 )) break;
01334 return( status );
01335 }
01336
01337 int
01338 do_fioxc8_mp (char *ptr, XINT num, unit **fu)
01339 {
01340 ftnint type = TYDREAL;
01341 XINT number = 1;
01342 char *endptr = ptr + (16 * num);
01343 int status;
01344 for (; ptr<endptr; ptr+=8)
01345 if (status = do_fio64_mp( &type, &number, ptr, fu, 8 )) break;
01346 return( status );
01347 }
01348
01349 int
01350 do_fioxc8 (char *ptr, XINT num)
01351 {
01352 ftnint type = TYDREAL;
01353 XINT number = 1;
01354 char *endptr = ptr + (16 * num);
01355 int status;
01356 for (; ptr<endptr; ptr+=8)
01357 if (status = do_fio64_mp( &type, &number, ptr, &f77curunit, 8 )) break;
01358 return( status );
01359 }
01360
01361 int
01362 do_fioxc16_mp (char *ptr, XINT num, unit **fu)
01363 {
01364 ftnint type = TYQUAD;
01365 XINT number = 1;
01366 char *endptr = ptr + (32 * num);
01367 int status;
01368 for (; ptr<endptr; ptr+=16)
01369 if (status = do_fio64_mp( &type, &number, ptr, fu, 16 )) break;
01370 return( status );
01371 }
01372
01373 int
01374 do_fioxc16 (char *ptr, XINT num)
01375 {
01376 ftnint type = TYQUAD;
01377 XINT number = 1;
01378 char *endptr = ptr + (32 * num);
01379 int status;
01380 for (; ptr<endptr; ptr+=16)
01381 if (status = do_fio64_mp( &type, &number, ptr, &f77curunit, 16 )) break;
01382 return( status );
01383 }
01384
01385 int
01386 do_fioxa4v_mp (ftnint val, unit **fu)
01387 {
01388 ftnint value = val;
01389 ftnint type = TYADDR;
01390 XINT number = 1;
01391 return( do_fio64_mp( &type, &number, (char *)&value, fu, 4 ) );
01392 }
01393 int
01394 do_fioxa4v (ftnint val)
01395 {
01396 ftnint value = val;
01397 ftnint type = TYADDR;
01398 XINT number = 1;
01399 return( do_fio64_mp( &type, &number, (char *)&value, &f77curunit, 4 ) );
01400 }
01401
01402 int
01403 do_fioxa8v_mp (ftnll val, unit **fu)
01404 {
01405 ftnll value = val;
01406 ftnint type = TYADDR;
01407 XINT number = 1;
01408 return( do_fio64_mp( &type, &number, (char *)&value, fu, 8 ) );
01409 }
01410
01411 int
01412 do_fioxa8v (ftnll val)
01413 {
01414 ftnll value = val;
01415 ftnint type = TYADDR;
01416 XINT number = 1;
01417 return( do_fio64_mp( &type, &number, (char *)&value, &f77curunit, 8 ) );
01418 }
01419
01420 int
01421 do_fioxh1v_mp (char val, unit **fu)
01422 {
01423 char value = val;
01424 ftnint type = TYCHAR;
01425 XINT number = 1;
01426 return( do_fio64_mp( &type, &number, (char *)&value, fu, 1 ) );
01427 }
01428
01429 int
01430 do_fioxh1v (char val)
01431 {
01432 char value = val;
01433 ftnint type = TYCHAR;
01434 XINT number = 1;
01435 return( do_fio64_mp( &type, &number, (char *)&value, &f77curunit, 1 ) );
01436 }
01437
01438 int
01439 do_fioxi1v_mp (char val, unit **fu)
01440 {
01441 char value = val;
01442 ftnint type = TYBYTE;
01443 XINT number = 1;
01444 return( do_fio64_mp( &type, &number, (char *)&value, fu, 1 ) );
01445 }
01446
01447 int
01448 do_fioxi1v (char val)
01449 {
01450 char value = val;
01451 ftnint type = TYBYTE;
01452 XINT number = 1;
01453 return( do_fio64_mp( &type, &number, (char *)&value, &f77curunit, 1 ) );
01454 }
01455
01456 int
01457 do_fioxi2v_mp (short val, unit **fu)
01458 {
01459 short value = val;
01460 ftnint type = TYSHORT;
01461 XINT number = 1;
01462 return( do_fio64_mp( &type, &number, (char *)&value, fu, 2 ) );
01463 }
01464
01465 int
01466 do_fioxi2v (short val)
01467 {
01468 short value = val;
01469 ftnint type = TYSHORT;
01470 XINT number = 1;
01471 return( do_fio64_mp( &type, &number, (char *)&value, &f77curunit, 2 ) );
01472 }
01473
01474 int
01475 do_fioxi4v_mp (ftnint val, unit **fu)
01476 {
01477 ftnint value = val;
01478 ftnint type = TYINT;
01479 XINT number = 1;
01480 return( do_fio64_mp( &type, &number, (char *)&value, fu, 4 ) );
01481 }
01482
01483 int
01484 do_fioxi4v (ftnint val)
01485 {
01486 ftnint value = val;
01487 ftnint type = TYINT;
01488 XINT number = 1;
01489 return( do_fio64_mp( &type, &number, (char *)&value, &f77curunit, 4 ) );
01490 }
01491
01492 int
01493 do_fioxi8v_mp (ftnll val, unit **fu)
01494 {
01495 ftnll value = val;
01496 ftnint type = TYLONGLONG;
01497 XINT number = 1;
01498 return( do_fio64_mp( &type, &number, (char *)&value, fu, 8 ) );
01499 }
01500
01501 int
01502 do_fioxi8v (ftnll val)
01503 {
01504 ftnll value = val;
01505 ftnint type = TYLONGLONG;
01506 XINT number = 1;
01507 return( do_fio64_mp( &type, &number, (char *)&value, &f77curunit, 8 ) );
01508 }
01509
01510 int
01511 do_fioxl1v_mp (char val, unit **fu)
01512 {
01513 char value = val;
01514 ftnint type = TYLOGICAL1;
01515 XINT number = 1;
01516 return( do_fio64_mp( &type, &number, (char *)&value, fu, 1 ) );
01517 }
01518
01519 int
01520 do_fioxl1v (char val)
01521 {
01522 char value = val;
01523 ftnint type = TYLOGICAL1;
01524 XINT number = 1;
01525 return( do_fio64_mp( &type, &number, (char *)&value, &f77curunit, 1 ) );
01526 }
01527
01528 int
01529 do_fioxl2v_mp (short val, unit **fu)
01530 {
01531 short value = val;
01532 ftnint type = TYLOGICAL2;
01533 XINT number = 1;
01534 return( do_fio64_mp( &type, &number, (char *)&value, fu, 2 ) );
01535 }
01536
01537 int
01538 do_fioxl2v (short val)
01539 {
01540 short value = val;
01541 ftnint type = TYLOGICAL2;
01542 XINT number = 1;
01543 return( do_fio64_mp( &type, &number, (char *)&value, &f77curunit, 2 ) );
01544 }
01545
01546 int
01547 do_fioxl4v_mp (ftnint val, unit **fu)
01548 {
01549 ftnint value = val;
01550 ftnint type = TYLOGICAL4;
01551 XINT number = 1;
01552 return( do_fio64_mp( &type, &number, (char *)&value, fu, 4 ) );
01553 }
01554
01555 int
01556 do_fioxl4v (ftnint val)
01557 {
01558 ftnint value = val;
01559 ftnint type = TYLOGICAL4;
01560 XINT number = 1;
01561 return( do_fio64_mp( &type, &number, (char *)&value, &f77curunit, 4 ) );
01562 }
01563
01564 int
01565 do_fioxl8v_mp (ftnll val, unit **fu)
01566 {
01567 ftnll value = val;
01568 ftnint type = TYLOGICAL8;
01569 XINT number = 1;
01570 return( do_fio64_mp( &type, &number, (char *)&value, fu, 8 ) );
01571 }
01572
01573 int
01574 do_fioxl8v (ftnll val)
01575 {
01576 ftnll value = val;
01577 ftnint type = TYLOGICAL8;
01578 XINT number = 1;
01579 return( do_fio64_mp( &type, &number, (char *)&value, &f77curunit, 8 ) );
01580 }
01581
01582 int
01583 do_fioxr4v_mp (float val, unit **fu)
01584 {
01585 float value = val;
01586 ftnint type = TYREAL;
01587 XINT number = 1;
01588 return( do_fio64_mp( &type, &number, (char *)&value, fu, 4 ) );
01589 }
01590
01591 int
01592 do_fioxr4v (float val)
01593 {
01594 float value = val;
01595 ftnint type = TYREAL;
01596 XINT number = 1;
01597 return( do_fio64_mp( &type, &number, (char *)&value, &f77curunit, 4 ) );
01598 }
01599
01600 int
01601 do_fioxr8v_mp (double val, unit **fu)
01602 {
01603 double value = val;
01604 ftnint type = TYDREAL;
01605 XINT number = 1;
01606 return( do_fio64_mp( &type, &number, (char *)&value, fu, 8 ) );
01607 }
01608
01609 int
01610 do_fioxr8v (double val)
01611 {
01612 double value = val;
01613 ftnint type = TYDREAL;
01614 XINT number = 1;
01615 return( do_fio64_mp( &type, &number, (char *)&value, &f77curunit, 8 ) );
01616 }
01617
01618 int
01619 do_fioxr16v_mp (long double val, unit **fu)
01620 {
01621 long double value = val;
01622 ftnint type = TYQUAD;
01623 XINT number = 1;
01624 return( do_fio64_mp( &type, &number, (char *)&value, fu, 16 ) );
01625 }
01626
01627 int
01628 do_fioxr16v (long double val)
01629 {
01630 long double value = val;
01631 ftnint type = TYQUAD;
01632 XINT number = 1;
01633 return( do_fio64_mp( &type, &number, (char *)&value, &f77curunit, 16 ) );
01634 }
01635
01636 int
01637 do_fioxc4v_mp (float rval, float ival, unit **fu)
01638 {
01639 float rvalue = rval;
01640 float ivalue = ival;
01641 ftnint type = TYREAL;
01642 XINT number = 1;
01643 int status;
01644 if (status = do_fio64_mp( &type, &number, (char *)&rvalue, fu, 4 ))
01645 return( status );
01646 return( do_fio64_mp( &type, &number, (char *)&ivalue, fu, 4 ) );
01647 }
01648
01649 int
01650 do_fioxc4v (float rval, float ival)
01651 {
01652 float rvalue = rval;
01653 float ivalue = ival;
01654 ftnint type = TYREAL;
01655 XINT number = 1;
01656 int status;
01657 if (status = do_fio64_mp( &type, &number, (char *)&rvalue, &f77curunit, 4 ))
01658 return( status );
01659 return( do_fio64_mp( &type, &number, (char *)&ivalue, &f77curunit, 4 ) );
01660 }
01661
01662 int
01663 do_fioxc8v_mp (double rval, double ival, unit **fu)
01664 {
01665 double rvalue = rval;
01666 double ivalue = ival;
01667 ftnint type = TYDREAL;
01668 XINT number = 1;
01669 int status;
01670 if (status = do_fio64_mp( &type, &number, (char *)&rvalue, fu, 8 ))
01671 return( status );
01672 return( do_fio64_mp( &type, &number, (char *)&ivalue, fu, 8 ) );
01673 }
01674
01675 int
01676 do_fioxc8v (double rval, double ival)
01677 {
01678 double rvalue = rval;
01679 double ivalue = ival;
01680 ftnint type = TYDREAL;
01681 XINT number = 1;
01682 int status;
01683 if (status = do_fio64_mp( &type, &number, (char *)&rvalue, &f77curunit, 8 ))
01684 return( status );
01685 return( do_fio64_mp( &type, &number, (char *)&ivalue, &f77curunit, 8 ) );
01686 }
01687
01688 int
01689 do_fioxc16v_mp (long double rval, long double ival, unit **fu)
01690 {
01691 long double rvalue = rval;
01692 long double ivalue = ival;
01693 ftnint type = TYQUAD;
01694 XINT number = 1;
01695 int status;
01696 if (status = do_fio64_mp( &type, &number, (char *)&rvalue, fu, 16 ))
01697 return( status );
01698 return( do_fio64_mp( &type, &number, (char *)&ivalue, fu, 16 ) );
01699 }
01700
01701 int
01702 do_fioxc16v (long double rval, long double ival)
01703 {
01704 long double rvalue = rval;
01705 long double ivalue = ival;
01706 ftnint type = TYQUAD;
01707 XINT number = 1;
01708 int status;
01709 if (status = do_fio64_mp( &type, &number, (char *)&rvalue, &f77curunit, 16 ))
01710 return( status );
01711 return( do_fio64_mp( &type, &number, (char *)&ivalue, &f77curunit, 16 ) );
01712 }
01713
01714
