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 <mutex.h>
00044 #include "fmt.h"
00045 #include "iomode.h"
00046 #include "lio.h"
00047 #include "iio.h"
00048 #include "idxio.h"
00049 #include "err.h"
00050 #include "open.h"
00051 #include "util.h"
00052 #include "bcompat.h"
00053 #include "sfe.h"
00054 #include <string.h>
00055 #include "wrtfmt.h"
00056 #include "uio.h"
00057 #include "lread.h"
00058
00059
00060
00061 ftnint match_type[NTYPES - 4] =
00062
00063
00064 {
00065 TYUNKNOWN
00066 ,TYADDR
00067 ,TYBYTE
00068 ,TYSHORT
00069 ,TYINT
00070 ,TYREAL
00071 ,TYDREAL
00072 ,TYCOMPLEX
00073 ,TYDCOMPLEX
00074 ,TYLOGICAL1
00075 ,TYLOGICAL2
00076 ,TYLOGICAL4
00077 ,TYCHAR
00078 ,TYSUBR
00079 ,TYSTRUCTURE
00080 ,TYNML
00081 ,TYQUAD
00082 ,TYERROR
00083 };
00084
00085 static int
00086 #if 11
00087 s_wsle_com (cilist64 *a, unit **fu)
00088 #else
00089 s_wsle_com (cilist *a, unit **fu)
00090 #endif
00091 {
00092 int n;
00093 unit *ftnunit;
00094
00095 if (!f77init)
00096 f_init ();
00097 if (n = c_le (a, fu)) {
00098 return (n);
00099 }
00100 ftnunit = *fu;
00101 #ifdef I90
00102 ftnunit->f90sw = 0;
00103 #endif
00104 ftnunit->f77putn = t_putc;
00105
00106 if (ftnunit->uwrt != WR_READY && f77nowwriting (ftnunit))
00107 errret(a->cierr, 160, "startwrt");
00108 if (ftnunit->ualias->ucc == CC_FORTRAN && ftnunit->ualias->ucchar) {
00109 putc (ftnunit->ualias->ucchar, ftnunit->ualias->ufd);
00110 ftnunit->ualias->ucchar = '\0';
00111 }
00112 ftnunit->f77lioproc = l_write;
00113 return (0);
00114 }
00115
00116 int s_wsle (cilist *a)
00117 {
00118 #if 11
00119 cilist64 dst;
00120 get_cilist64(&dst, a);
00121 return s_wsle_com(&dst, &f77curunit);
00122 #else
00123 return( s_wsle_com( a, &f77curunit ) );
00124 #endif
00125 }
00126
00127 int s_wsle_mp (cilist *a, unit **fu)
00128 {
00129 #if 11
00130 cilist64 dst;
00131 get_cilist64(&dst, a);
00132 return s_wsle_com(&dst, fu);
00133 #else
00134 return( s_wsle_com( a, fu ) );
00135 #endif
00136 }
00137
00138 #if 11
00139 int s_wsle64 (cilist64 *a)
00140 {
00141 return( s_wsle_com( a, &f77curunit ) );
00142 }
00143
00144 int s_wsle64_mp (cilist64 *a, unit **fu)
00145 {
00146 return( s_wsle_com( a, fu ) );
00147 }
00148 #endif
00149
00150
00151 static
00152 #if 11
00153 int s_wsli_com (icilist64 *a, unit **fu)
00154 #else
00155 int s_wsli_com (icilist *a, unit **fu)
00156 #endif
00157 {
00158 int n;
00159 unit *ftnunit;
00160
00161 if (!f77init)
00162 f_init ();
00163 *(fu) = ftnunit = Internal_File;
00164 while (fu != &f77curunit && test_and_set( &ftnunit->lock_unit, 1L ))
00165 ;
00166
00167 c_li (a);
00168 #ifdef I90
00169 ftnunit->f90sw = 0;
00170 #endif
00171 ftnunit->uwrt |= WR_OP;
00172 ftnunit->f77lioproc = l_write;
00173 ftnunit->f77putn = z_putc;
00174 return (0);
00175 }
00176
00177 int s_wsli (icilist *a)
00178 {
00179 #if 11
00180 icilist64 dst;
00181 get_icilist64(&dst, a);
00182 return(s_wsli_com(&dst, &f77curunit));
00183 #else
00184 return(s_wsli_com(a, &f77curunit));
00185 #endif
00186 }
00187
00188 int s_wsli_mp (icilist *a, unit **fu)
00189 {
00190 #if 11
00191 icilist64 dst;
00192 get_icilist64(&dst, a);
00193 return(s_wsli_com(&dst, fu));
00194 #else
00195 return(s_wsli_com(a, fu));
00196 #endif
00197 }
00198
00199 #if 11
00200 int s_wsli64 (icilist64 *a)
00201 {
00202 return(s_wsli_com(a, &f77curunit));
00203 }
00204
00205 int s_wsli64_mp (icilist64 *a, unit **fu)
00206 {
00207 return(s_wsli_com(a, fu));
00208 }
00209 #endif
00210
00211
00212 int e_wsle (void)
00213 {
00214 return( e_wsle_mp( &f77curunit ) );
00215 }
00216
00217 int e_wsle_mp (unit **fu)
00218 {
00219 unit *ftnunit = *fu;
00220 int n;
00221
00222 if (ftnunit->ufmt == 2) {
00223 ftnunit->f77recend = ftnunit->f77recpos;
00224 return (e_wsue ());
00225 }
00226 switch (ftnunit->ucc) {
00227 case CC_FORTRAN:
00228 if (ftnunit->f77putn (ftnunit, 1, '\r', NULL))
00229 errret( ftnunit->f77errlist.cierr, errno, "system write error" );
00230 if (ftnunit->ufd == stdout)
00231 fflush (stdout);
00232 ftnunit->ucchar = '\n';
00233 break;
00234 case CC_LIST:
00235 if (ftnunit->f77putn (ftnunit, 1, '\n', NULL))
00236 errret( ftnunit->f77errlist.cierr, errno, "system write error" );
00237 default:
00238 break;
00239 }
00240 ftnunit->f77recpos = 0;
00241
00242
00243
00244
00245 ftnunit->lock_unit = 0;
00246 return (0);
00247 }
00248
00249 int e_xsle (void)
00250 {
00251 return( e_xsle_mp (&f77curunit) );
00252 }
00253
00254 int e_xsle_mp (unit **fu)
00255 {
00256 return( e_wsle_mp (fu) );
00257 }
00258
00259 int e_wsli (void)
00260 {
00261 return(e_wsli_mp());
00262 }
00263
00264 int e_wsli_mp (void)
00265 {
00266 unit *ftnunit = Internal_File;
00267 z_wnew (ftnunit);
00268 ftnunit->lock_unit = 0;
00269 return (0);
00270 }
00271
00272
00273 int
00274 t_putc (unit *ftnunit, register XINT count, register char con, register char *buf)
00275 {
00276 if (ftnunit->ufmt == 2) {
00277 if (ftnunit->f77recpos + count > ftnunit->f77fio_size)
00278 ftnunit->f77fio_buf = realloc (ftnunit->f77fio_buf, ftnunit->f77fio_size += FIO_ALLOC);
00279 if (buf)
00280 memcpy (ftnunit->f77fio_buf + ftnunit->f77recpos, buf, count);
00281 else
00282 memset (ftnunit->f77fio_buf + ftnunit->f77recpos, con ? con : (int) ' ', count);
00283 ftnunit->f77recpos += count;
00284 return (0);
00285 }
00286 ftnunit->f77recpos += count;
00287 if (buf)
00288 while (count--) {
00289 if (putc (*buf++, ftnunit->ufd) == EOF)
00290 return( errno );
00291 }
00292 else {
00293 if (con == 0)
00294 con = ' ';
00295 while (count--) {
00296 if (putc (con, ftnunit->ufd) == EOF)
00297 return( errno );
00298 }
00299 };
00300 return (0);
00301 }
00302
00303 int
00304 lwrt_I (unit *ftnunit, uinteger *ptr, int w, int len, int start)
00305 {
00306 #ifdef I90
00307 int maxrl;
00308
00309 maxrl = (ftnunit->f90sw == 1 && ftnunit->url > 0 ? ftnunit->url : LINE );
00310 if (ftnunit->f77recpos + w >= maxrl)
00311 #else
00312 if (ftnunit->f77recpos + w >= LINE)
00313 #endif
00314 {
00315 if (ftnunit->f77putn (ftnunit, 1, '\n', NULL))
00316 err( ftnunit->f77errlist.cierr, errno, "system write error" );
00317 ftnunit->f77recpos = 0;
00318 if (start) {
00319 t_putc (ftnunit, start, ' ', NULL);
00320 #ifdef I90
00321 if (ftnunit->f90sw == 0 ) t_putc (ftnunit, 4, 0, "\t ");
00322 #else
00323 t_putc (ftnunit, 4, 0, "\t ");
00324 #endif
00325 }
00326 }
00327
00328 #ifdef I90
00329 if ( ftnunit->f90sw == 1 ) {
00330 if(ftnunit->f77recpos==0 && ftnunit->ucc==CC_LIST)
00331 ftnunit->f77putn(ftnunit, 1,' ',NULL);
00332 } else {
00333 if(ftnunit->f77recpos==0 && !ftnunit->f77errlist.iciunit && ftnunit->ucc==CC_LIST)
00334 ftnunit->f77putn(ftnunit, 1,' ',NULL);
00335 }
00336 #else
00337 if(ftnunit->f77recpos==0 && !ftnunit->f77errlist.iciunit && ftnunit->ucc==CC_LIST)
00338 ftnunit->f77putn(ftnunit, 1,' ',NULL);
00339 #endif
00340
00341 (void) wrt_I (ftnunit, ptr, w, len);
00342 return 0;
00343 }
00344
00345 int
00346 lwrt_L (unit *ftnunit, uinteger *ptr, int w, int len, int start)
00347 {
00348 #ifdef I90
00349 int maxrl;
00350 maxrl = (ftnunit->f90sw == 1 && ftnunit->url > 0 ? ftnunit->url : LINE );
00351 if (ftnunit->f77recpos + w >= maxrl)
00352 #else
00353 if (ftnunit->f77recpos + w >= LINE)
00354 #endif
00355 {
00356 ftnunit->f77putn (ftnunit, 1, '\n', NULL);
00357 ftnunit->f77recpos = 0;
00358 if (start) {
00359 t_putc (ftnunit, start, ' ', NULL);
00360 #ifdef I90
00361 if (ftnunit->f90sw == 0 ) t_putc (ftnunit, 4, 0, "\t ");
00362 #else
00363 t_putc (ftnunit, 4, 0, "\t ");
00364 #endif
00365 }
00366 }
00367
00368 #ifdef I90
00369 if ( ftnunit->f90sw == 1 ) {
00370 if(ftnunit->f77recpos==0 && ftnunit->ucc==CC_LIST)
00371 ftnunit->f77putn(ftnunit, 1,' ',NULL);
00372 } else {
00373 if(ftnunit->f77recpos==0 && !ftnunit->f77errlist.iciunit && ftnunit->ucc==CC_LIST)
00374 ftnunit->f77putn(ftnunit, 1,' ',NULL);
00375 }
00376 #else
00377 if(ftnunit->f77recpos==0 && !ftnunit->f77errlist.iciunit && ftnunit->ucc==CC_LIST)
00378 ftnunit->f77putn(ftnunit, 1,' ',NULL);
00379 #endif
00380
00381 (void) wrt_L (ftnunit, ptr, w, len);
00382 return 0;
00383 }
00384
00385 int
00386 lwrt_A (unit *ftnunit, char *p, ftnlen len, int start)
00387 #ifdef I90
00388 {
00389 int i, maxrl;
00390 maxrl = (ftnunit->f90sw == 1 && ftnunit->url > 0 ? ftnunit->url : LINE );
00391
00392 if (ftnunit->udelim==QUOTE) {
00393
00394 if( ( ftnunit->f77recpos > 0) && ( ftnunit->f77recpos+len+4 >= maxrl ) && ( start >= 0 ) ) {
00395 ftnunit->f77putn(ftnunit, 1,'\n',NULL);
00396 ftnunit->f77recpos=0;
00397 if ( start ) {
00398 t_putc(ftnunit, start,' ',NULL);
00399 if (ftnunit->f90sw == 0 ) t_putc (ftnunit, 4, 0, "\t ");
00400 }
00401 }
00402
00403 putc(' ',ftnunit->ufd);
00404 ++ftnunit->f77recpos;
00405 putc('\"',ftnunit->ufd);
00406 ++ftnunit->f77recpos;
00407 if ( p != NULL ) {
00408 for (i=0;i<len;i++) {
00409 if ( ftnunit->f77recpos == maxrl ) {
00410 putc('\n',ftnunit->ufd);
00411 ftnunit->f77recpos = 0;
00412 }
00413 if (*p=='\"') {
00414 if ( ftnunit->f77recpos == maxrl-1 ) {
00415 putc('\n',ftnunit->ufd);
00416 ftnunit->f77recpos = 0;
00417 }
00418 putc('\"',ftnunit->ufd);
00419 ++ftnunit->f77recpos;
00420 }
00421 putc(*p++,ftnunit->ufd);
00422 ++ftnunit->f77recpos;
00423 }
00424 } else {
00425 for (i=0;i<len;i++) {
00426 if ( ftnunit->f77recpos == maxrl ) {
00427 putc('\n',ftnunit->ufd);
00428 ftnunit->f77recpos = 0;
00429 }
00430 putc(' ',ftnunit->ufd);
00431 ++ftnunit->f77recpos;
00432 }
00433 }
00434 if ( ftnunit->f77recpos == maxrl ) {
00435 putc('\n',ftnunit->ufd);
00436 ftnunit->f77recpos = 0;
00437 }
00438 putc('\"',ftnunit->ufd);
00439 ++ftnunit->f77recpos;
00440 if ( ftnunit->f77recpos < maxrl) {
00441 putc(' ',ftnunit->ufd);
00442 ++ftnunit->f77recpos;
00443 }
00444
00445 } else if (ftnunit->udelim==APOSTROPHE) {
00446
00447 if( ( ftnunit->f77recpos > 0) && ( ftnunit->f77recpos+len+4 >= maxrl ) && ( start >= 0 ) ) {
00448 ftnunit->f77putn(ftnunit, 1,'\n',NULL);
00449 ftnunit->f77recpos=0;
00450 if ( start ) {
00451 t_putc(ftnunit, start,' ',NULL);
00452 if (ftnunit->f90sw == 0 ) t_putc (ftnunit, 4, 0, "\t ");
00453 }
00454 }
00455
00456 putc(' ',ftnunit->ufd);
00457 ++ftnunit->f77recpos;
00458 putc('\'',ftnunit->ufd);
00459 ++ftnunit->f77recpos;
00460 if ( p != NULL ) {
00461 for (i=0;i<len;i++) {
00462 if ( ftnunit->f77recpos == maxrl ) {
00463 putc('\n',ftnunit->ufd);
00464 ftnunit->f77recpos = 0;
00465 }
00466 if (*p=='\'') {
00467 if ( ftnunit->f77recpos == maxrl-1 ) {
00468 putc('\n',ftnunit->ufd);
00469 ftnunit->f77recpos = 0;
00470 }
00471 putc('\'',ftnunit->ufd);
00472 ++ftnunit->f77recpos;
00473 }
00474 putc(*p++,ftnunit->ufd);
00475 ++ftnunit->f77recpos;
00476 }
00477 } else {
00478 for (i=0;i<len;i++) {
00479 if ( ftnunit->f77recpos == maxrl ) {
00480 putc('\n',ftnunit->ufd);
00481 ftnunit->f77recpos = 0;
00482 }
00483 putc(' ',ftnunit->ufd);
00484 ++ftnunit->f77recpos;
00485 }
00486 }
00487 if ( ftnunit->f77recpos == maxrl ) {
00488 putc('\n',ftnunit->ufd);
00489 ftnunit->f77recpos = 0;
00490 }
00491 putc('\'',ftnunit->ufd);
00492 ++ftnunit->f77recpos;
00493 if ( ftnunit->f77recpos < maxrl) {
00494 putc(' ',ftnunit->ufd);
00495 ++ftnunit->f77recpos;
00496 }
00497
00498 } else {
00499
00500 if((ftnunit->f77recpos>0)&&(ftnunit->f77recpos+len>=maxrl)) {
00501 ftnunit->f77putn(ftnunit, 1,'\n',NULL);
00502 ftnunit->f77recpos=0;
00503 if ( start ) {
00504 t_putc (ftnunit, start,' ',NULL);
00505 if (ftnunit->f90sw == 0 ) t_putc (ftnunit, 4, 0, "\t ");
00506 }
00507 }
00508
00509 if ( ftnunit->f90sw == 1 ) {
00510 if(ftnunit->f77recpos==0 && ftnunit->ucc==CC_LIST)
00511 ftnunit->f77putn(ftnunit, 1,' ',NULL);
00512 } else {
00513 if(ftnunit->f77recpos==0 && !ftnunit->f77errlist.iciunit && ftnunit->ucc==CC_LIST)
00514 ftnunit->f77putn(ftnunit, 1,' ',NULL);
00515 }
00516
00517 if ( ftnunit->f90sw == 1 && ftnunit->url > 0 && ftnunit->f77recpos + len > maxrl ) {
00518 err( ftnunit->f77errlist.cierr ,110,"lio");
00519 } else {
00520 ftnunit->f77putn(ftnunit, len,0,p);
00521 }
00522
00523 }
00524
00525 return 0;
00526 }
00527 #else
00528 {
00529 if ((ftnunit->f77recpos > 0) && (ftnunit->f77recpos + len >= LINE)) {
00530 ftnunit->f77putn (ftnunit, 1, '\n', NULL);
00531 ftnunit->f77recpos = 0;
00532 if (start) {
00533 t_putc (ftnunit, start, ' ', NULL);
00534 t_putc (ftnunit, 4, 0, "\t ");
00535 }
00536 }
00537 if (ftnunit->f77recpos == 0 && !ftnunit->f77errlist.iciunit && ftnunit->ucc == CC_LIST)
00538 t_putc (ftnunit, 1, ' ', NULL);
00539 ftnunit->f77putn (ftnunit, len, 0, p);
00540 return 0;
00541 }
00542 #endif
00543
00544 int
00545 lwrt_G (unit *ftnunit, ufloat *ptr, int w, int d, int e, int len, int type, int doblank, int start)
00546 {
00547 #ifdef I90
00548 int maxrl;
00549 maxrl = (ftnunit->f90sw == 1 && ftnunit->url > 0 ? ftnunit->url : LINE );
00550 if (ftnunit->f77recpos + w >= maxrl)
00551 #else
00552 if (ftnunit->f77recpos + w >= LINE)
00553 #endif
00554 {
00555 ftnunit->f77putn (ftnunit, 1, '\n', NULL);
00556 ftnunit->f77recpos = 0;
00557 if (start) {
00558 t_putc (ftnunit, start, ' ', NULL);
00559 #ifdef I90
00560 if (ftnunit->f90sw == 0 ) t_putc (ftnunit, 4, 0, "\t ");
00561 #else
00562 t_putc (ftnunit, 4, 0, "\t ");
00563 #endif
00564 };
00565 }
00566
00567 #ifdef I90
00568 if ( ftnunit->f90sw == 1 ) {
00569 if(ftnunit->f77recpos==0 && ftnunit->ucc==CC_LIST)
00570 ftnunit->f77putn(ftnunit, 1,' ',NULL);
00571 } else {
00572 if(ftnunit->f77recpos==0 && !ftnunit->f77errlist.iciunit && ftnunit->ucc==CC_LIST)
00573 ftnunit->f77putn(ftnunit, 1,' ',NULL);
00574 }
00575 #else
00576 if(ftnunit->f77recpos==0 && !ftnunit->f77errlist.iciunit && ftnunit->ucc==CC_LIST)
00577 ftnunit->f77putn(ftnunit, 1,' ',NULL);
00578 #endif
00579
00580 ftnunit->f77scale = 1;
00581 (void) wrt_G (ftnunit, ptr, (int)G, w, d, e, len, type, doblank);
00582 return 0;
00583 }
00584
00585 int
00586 lwrt_C (unit *ftnunit, ufloat *a, ufloat *b, int w, int d, int e, int len, int type, int start)
00587 {
00588 int maxrl;
00589
00590 #ifdef I90
00591 maxrl = (ftnunit->f90sw == 1 && ftnunit->url > 0 ? ftnunit->url : LINE );
00592 if ( ftnunit->f90sw == 1 ) {
00593 if ( ftnunit->f77recpos +w+3 >= maxrl ||
00594 ( ftnunit->f77recpos +w+w+4 >= maxrl && !ftnunit->f77errlist.iciunit ) ) {
00595 ftnunit->f77putn (ftnunit, 1, '\n', NULL);
00596 ftnunit->f77recpos = 0;
00597 if (start) {
00598 t_putc (ftnunit, start, ' ', NULL);
00599 }
00600 }
00601 if(ftnunit->f77recpos==0 && ftnunit->ucc==CC_LIST)
00602 ftnunit->f77putn(ftnunit, 1,' ',NULL);
00603 else if (ftnunit->f77recpos > 0)
00604 ftnunit->f77putn (ftnunit, 1, ' ', NULL);
00605 } else {
00606 if (ftnunit->f77recpos + w+w+4 >= maxrl) {
00607 ftnunit->f77putn (ftnunit, 1, '\n', NULL);
00608 ftnunit->f77recpos = 0;
00609 if (start) {
00610 t_putc (ftnunit, start, ' ', NULL);
00611 t_putc (ftnunit, 4, 0, "\t ");
00612 }
00613 }
00614 if(ftnunit->f77recpos==0 && !ftnunit->f77errlist.iciunit && ftnunit->ucc==CC_LIST)
00615 ftnunit->f77putn(ftnunit, 1,' ',NULL);
00616 else if (ftnunit->f77recpos > 0)
00617 ftnunit->f77putn (ftnunit, 1, ' ', NULL);
00618 }
00619 #else
00620 maxrl = LINE;
00621 if (ftnunit->f77recpos + w+w+4 >= maxrl) {
00622 ftnunit->f77putn (ftnunit, 1, '\n', NULL);
00623 ftnunit->f77recpos = 0;
00624 if (start) {
00625 t_putc (ftnunit, start, ' ', NULL);
00626 t_putc (ftnunit, 4, 0, "\t ");
00627 }
00628 }
00629 if(ftnunit->f77recpos==0 && !ftnunit->f77errlist.iciunit && ftnunit->ucc==CC_LIST)
00630 ftnunit->f77putn(ftnunit, 1,' ',NULL);
00631 else if (ftnunit->f77recpos > 0)
00632 ftnunit->f77putn (ftnunit, 1, ' ', NULL);
00633 #endif
00634
00635 ftnunit->f77putn (ftnunit, 1, '(', NULL);
00636 ftnunit->f77scale = 1;
00637 (void) wrt_G (ftnunit, a, (int)G, w, d, e, len >> 1, type, 0);
00638 ftnunit->f77putn (ftnunit, 1, ',', NULL);
00639
00640 if(ftnunit->f77recpos+w+1>=maxrl) {
00641 ftnunit->f77putn (ftnunit, 1, '\n', NULL);
00642 ftnunit->f77recpos = 0;
00643 }
00644
00645 #ifdef I90
00646 if ( ftnunit->f90sw == 1 ) {
00647 if(ftnunit->f77recpos==0 && ftnunit->ucc==CC_LIST)
00648 ftnunit->f77putn(ftnunit, 1,' ',NULL);
00649 } else {
00650 if(ftnunit->f77recpos==0 && !ftnunit->f77errlist.iciunit && ftnunit->ucc==CC_LIST)
00651 ftnunit->f77putn(ftnunit, 1,' ',NULL);
00652 }
00653 #else
00654 if(ftnunit->f77recpos==0 && !ftnunit->f77errlist.iciunit && ftnunit->ucc==CC_LIST)
00655 ftnunit->f77putn(ftnunit, 1,' ',NULL);
00656 #endif
00657
00658 (void) wrt_G (ftnunit, b, (int)G, w, d, e, len >> 1, type, 0);
00659 ftnunit->f77putn (ftnunit, 1, ')', NULL);
00660 return 0;
00661 }
00662
00663
00664
00665
00666
00667
00668
00669 int l_write (unit *ftnunit, XINT *number, flex *ptr, ftnlen len, ftnint type)
00670 {
00671 XINT i;
00672 int w=0;
00673 int n;
00674
00675 for (i = 0; i < *number; i++) {
00676 switch ((int) type) {
00677 default:
00678 ftnunit->lcount = i;
00679 err( ftnunit->f77errlist.cierr ,249,"unknown type in lio");
00680
00681
00682
00683 case TYBYTE:
00684 case TYSHORT:
00685 case TYINT:
00686 case TYLONGLONG:
00687
00688 case TYADDR:
00689 switch ((int) type) {
00690 case TYLOGICAL1:
00691 case TYBYTE:
00692 w = 5;
00693 break;
00694 case TYSHORT:
00695 w = 7;
00696 break;
00697 case TYINT:
00698 w = 12;
00699 break;
00700
00701 case TYADDR:
00702 #if (_MIPS_SZPTR == 64)
00703 w = 21;
00704 #else
00705 w = 12;
00706 #endif
00707 break;
00708
00709 case TYLONGLONG:
00710 w = 21;
00711 }
00712 if (n = lwrt_I (ftnunit, (uinteger *) ptr, w, len, 0))
00713 return( n );
00714 break;
00715 case TYREAL:
00716 if (n = lwrt_G (ftnunit, (ufloat *) ptr, 15, 7, 2, len, type, 1, 0))
00717 return( n );
00718 break;
00719 case TYDREAL:
00720 if (n = lwrt_G (ftnunit, (ufloat *) ptr, 24, 16, 0, len, type, 1, 0))
00721 return( n );
00722 break;
00723 case TYQUAD:
00724 if (n = lwrt_G (ftnunit, (ufloat *) ptr, 40, 31, 0, len, type, 1, 0))
00725 return( n );
00726 break;
00727 case TYCOMPLEX:
00728 if (n = lwrt_C (ftnunit, (ufloat *) ptr, (ufloat *) ((float *)ptr + 1), 15, 7, 2, len, type, 0))
00729 return( n );
00730 break;
00731 case TYDCOMPLEX:
00732 if (n = lwrt_C (ftnunit, (ufloat *) ptr, (ufloat *) ((double *)ptr + 1), 24, 16, 0, len, type, 0))
00733 return( n );
00734 break;
00735 case TYQUADCOMPLEX:
00736
00737 if (n = lwrt_C (ftnunit, (ufloat *) ptr, (ufloat *) ((long double *)ptr + 1), 40, 31, 0, len, type, 0))
00738 return( n );
00739 break;
00740
00741 case TYLOGICAL1:
00742
00743 case TYLOGICAL2:
00744 case TYLOGICAL4:
00745 case TYLOGICAL8:
00746 if (n = lwrt_L (ftnunit, (uinteger *) ptr, 2, len, 0))
00747 return( n );
00748 break;
00749 case TYCHAR:
00750 if (n = lwrt_A (ftnunit, (char *) ptr, len, 0))
00751 return( n );
00752 break;
00753 }
00754 ptr = (flex *) ((char *) ptr + len);
00755 }
00756 return (0);
00757 }
00758
00759 int
00760 c_le (cilist64 *a, unit **fu)
00761 {
00762 unit *ftnunit;
00763 if ((ftnunit = *fu = map_luno (a->ciunit)) == NULL)
00764 err(a->cierr, 101, "lio");
00765 while (fu != &f77curunit && test_and_set( &ftnunit->lock_unit, 1L ))
00766 ;
00767 if (ftnunit->uconn <= 0 && fk_open (SEQ, FMT, a->ciunit)) {
00768 ftnunit->uconn = 0;
00769 errret(a->cierr, 102, "lio");
00770 }
00771 ftnunit->f77fmtbuf = "list io";
00772 ftnunit->f77recpos = 0;
00773 ftnunit->f77scale = 0;
00774
00775 ftnunit->f77errlist.cierr = a->cierr;
00776 ftnunit->f77errlist.ciend = a->ciend;
00777 ftnunit->f77errlist.cieor = a->cieor;
00778 ftnunit->f77errlist.cisize = a->cisize;
00779 ftnunit->f77errlist.iciunit = 0;
00780 if (ftnunit->uacc == KEYED) {
00781 ftnunit->f77idxlist.cimatch = a->cimatch;
00782 ftnunit->f77idxlist.cikeytype = a->cikeytype;
00783 ftnunit->f77idxlist.cikeyval.cicharval = a->cikeyval.cicharval;
00784 ftnunit->f77idxlist.cikeyid = a->cikeyid;
00785 ftnunit->f77idxlist.cinml = a->cinml;
00786 ftnunit->f77idxlist.cikeyvallen = a->cikeyvallen;
00787 }
00788 if (ftnunit->ufmt != 1)
00789 errret(a->cierr, 102, "lio");
00790 return (0);
00791 }
00792
00793 void
00794 c_li (icilist64 *a)
00795 {
00796 unit *ftnunit = Internal_File;
00797
00798 ftnunit->f77fmtbuf = "list io";
00799 ftnunit->f77errlist.cierr = a->icierr;
00800 ftnunit->f77errlist.ciend = a->iciend;
00801 ftnunit->f77errlist.cieor = 0;
00802 ftnunit->f77errlist.cisize = 0;
00803 ftnunit->f77errlist.iciunit = a->iciunit;
00804 ftnunit->f77errlist.icirlen = ftnunit->url = a->icirlen;
00805 ftnunit->f77errlist.icirnum = a->icirnum;
00806 ftnunit->f77scale = 0;
00807 ftnunit->f77recpos = ftnunit->f77recend = icnum = icpos = 0;
00808 icptr = ftnunit->f77errlist.iciunit;
00809 icend = icptr + ftnunit->f77errlist.icirlen * ftnunit->f77errlist.icirnum;
00810 }
00811
00812 #pragma weak __kai_do_lio = do_Lio
00813 #pragma weak __kai_do_lio_1dim = do_Lio_1dim
00814 #pragma weak __kai_do_lio_mp = do_Lio_mp
00815 #pragma weak do_lio64 = do_Lio64
00816
00817
00818
00819 #pragma weak __kai_do_lio64 = do_Lio64
00820 #pragma weak __kai_do_lio64_1dim = do_Lio64_1dim
00821 #pragma weak __kai_do_lio64_mp = do_Lio64_mp
00822 #pragma weak __kai_do_lio64_mp_1dim = do_Lio64_mp_1dim
00823
00824
00825
00826 static int
00827 do_Lio_com(ftnint *type, XINT *number, flex *ptr, unit **fu, ftnlen len)
00828 {
00829
00830
00831
00832
00833 int n;
00834 if (n = (*(*fu)->f77lioproc) (*fu, number, ptr, len, *type)) {
00835 if ((*fu)->f77lioproc == l_read)
00836
00837
00838 for (; (*fu)->nextch != '\n' && (*fu)->nextch != EOF; (*fu)->nextch = (*(*fu)->f77getn)((*fu)));
00839 (*fu)->lock_unit = 0;
00840 }
00841 return(n);
00842 }
00843
00844 int
00845 do_Lio (ftnint *type, ftnint *number, flex *ptr, ftnlen len)
00846 {
00847 #if 11
00848 XINT xnumber;
00849 xnumber = *number;
00850 return( do_Lio_com( type, &xnumber, ptr, &f77curunit, len ) );
00851 #else
00852 return( do_Lio_com( type, number, ptr, &f77curunit, len ) );
00853 #endif
00854 }
00855
00856 #if 11
00857 int
00858 do_Lio64 (ftnint *type, XINT *number, flex *ptr, ftnlen len)
00859 {
00860 return( do_Lio_com( type, number, ptr, &f77curunit, len ) );
00861 }
00862 #endif
00863
00864 static int
00865 do_Lio_1dim_com( ftnint *type, flex *ptr,
00866 flex *do_idx, XINT *lb,
00867 XINT *ub, XINT *step,
00868 unit **fu,
00869 ftnlen len, ftnlen idxlen)
00870
00871
00872
00873
00874
00875
00876
00877
00878
00879
00880
00881 {
00882 XINT nelem;
00883 int ierr;
00884 char *lastptr, *nptr;
00885
00886 lastptr = (char *) ptr + (*ub - 1) * len;
00887 ptr = (flex *) ((char *) ptr + (*lb - 1) * len);
00888 if (*step == 1) {
00889
00890 if ((nelem = *ub - *lb + 1) > 0) {
00891 if (ierr = do_Lio_com( type, &nelem, ptr, fu, len ) ) {
00892 set_do_idx( do_idx, idxlen, (ftnll) (*lb + (*fu)->lcount) );
00893 return( ierr );
00894 }
00895 set_do_idx( do_idx, idxlen, (ftnll) (*ub + 1) );
00896 }
00897
00898 return( 0 );
00899 }
00900
00901 nelem = 1;
00902 if (*step > 0) {
00903 for (nptr = (char *) ptr;nptr <= lastptr; nptr += *step*len)
00904 if (ierr = do_Lio_com( type, &nelem, (flex *)nptr, fu, len ) ) {
00905 set_do_idx( do_idx, idxlen, (ftnll) (*lb + (nptr - (char *)ptr)/len) );
00906 return( ierr );
00907 }
00908 }
00909 else
00910 for (nptr = (char *) ptr; nptr >= lastptr; nptr += *step*len)
00911 if (ierr = do_Lio_com( type, &nelem, (flex *)nptr, fu, len ) ) {
00912 set_do_idx( do_idx, idxlen, (ftnll) (*lb - ((char *)ptr - nptr)/len) );
00913 return( ierr );
00914 }
00915 set_do_idx( do_idx, idxlen, (ftnll) (*lb + ((*ub - *lb) / *step + 1) * *step) );
00916 return(0);
00917 }
00918
00919 int
00920 do_Lio_1dim( ftnint *type, flex *ptr,
00921 flex *do_idx, ftnint *lb,
00922 ftnint *ub, ftnint *step,
00923 ftnlen len, ftnlen idxlen)
00924 {
00925
00926 XINT xlb, xub, xstep;
00927 xlb = *lb;
00928 xub = *ub;
00929 xstep = *step;
00930 return (do_Lio_1dim_com(type, ptr, do_idx, &xlb, &xub, &xstep, &f77curunit, len, idxlen));
00931 }
00932
00933 int
00934 do_Lio64_1dim(ftnint *type, flex *ptr,
00935 flex *do_idx, XINT *lb,
00936 XINT *ub, XINT *step,
00937 ftnlen len, ftnlen idxlen)
00938 {
00939 return( do_Lio_1dim_com( type, ptr, do_idx, lb, ub, step, &f77curunit, len, idxlen));
00940 }
00941
00942 int
00943 do_Lio64_mp_1dim(ftnint *type, flex *ptr,
00944 flex *do_idx, XINT *lb,
00945 XINT *ub, XINT *step,
00946 unit **fu,
00947 ftnlen len, ftnlen idxlen)
00948 {
00949 return( do_Lio_1dim_com( type, ptr, do_idx, lb, ub, step, fu, len, idxlen));
00950 }
00951
00952
00953 int
00954 do_Lio_mp (ftnint *type, ftnint *number, flex *ptr, unit **fu, ftnlen len)
00955 {
00956 #if 11
00957 XINT xnumber;
00958 xnumber = *number;
00959 return( do_Lio_com( type, &xnumber, ptr, fu, len ) );
00960 #else
00961 return (do_Lio_com(type, number, ptr, fu, len ));
00962 #endif
00963 }
00964
00965 #if 11
00966 int
00967 do_Lio64_mp (ftnint *type, XINT *number, flex *ptr, unit **fu, ftnlen len)
00968 {
00969 return (do_Lio_com(type, number, ptr, fu, len ));
00970 }
00971 #endif
00972
00973
00974 int
00975 do_lio (ftnint *type, ftnint *number, flex *ptr, ftnlen len)
00976 {
00977
00978
00979
00980
00981 XINT numb = *number;
00982 return( do_Lio_com( &match_type[*type], &numb, ptr, &f77curunit, len ) );
00983 }
00984
00985 #if 11
00986 #pragma weak e_wsle64 = e_wsle
00987 #pragma weak e_wsle64_mp = e_wsle_mp
00988 #pragma weak e_xsle64 = e_xsle
00989 #pragma weak e_xsle64_mp = e_xsle_mp
00990 #pragma weak e_wsli64 = e_wsli
00991 #pragma weak e_wsli64_mp = e_wsli_mp
00992 #endif
00993
00994
00995 #pragma weak do_lio90_mp = do_Lio_mp
00996 #pragma weak do_lio90 = do_Lio
00997 #pragma weak do_lio9064 = do_Lio64
00998 #pragma weak do_lio9064_mp = do_Lio64_mp
00999
01000
01001
01002
01003
01004
01005
01006
01007
01008
01009
01010 int
01011 do_lioxa4_mp (char *ptr, XINT num, unit **fu)
01012 {
01013 ftnint type = TYADDR;
01014 XINT number = num;
01015 return( do_Lio_com( &type, &number, (flex *)ptr, fu, 4 ) );
01016 }
01017
01018 int
01019 do_lioxa4 (char *ptr, XINT num)
01020 {
01021 ftnint type = TYADDR;
01022 XINT number = num;
01023 return( do_Lio_com( &type, &number, (flex *)ptr, &f77curunit, 4 ) );
01024 }
01025
01026 int
01027 do_lioxa8_mp (char *ptr, XINT num, unit **fu)
01028 {
01029 ftnint type = TYADDR;
01030 XINT number = num;
01031 return( do_Lio_com( &type, &number, (flex *)ptr, fu, 8 ) );
01032 }
01033
01034 int
01035 do_lioxa8 (char *ptr, XINT num)
01036 {
01037 ftnint type = TYADDR;
01038 XINT number = num;
01039 return( do_Lio_com( &type, &number, (flex *)ptr, &f77curunit, 8 ) );
01040 }
01041
01042 int
01043 do_lioxh1_mp (char *ptr, XINT clen, XINT num, unit **fu)
01044 {
01045 ftnint type = TYCHAR;
01046 XINT number = num;
01047 return( do_Lio_com( &type, &number, (flex *)ptr, fu, clen ) );
01048 }
01049
01050 int
01051 do_lioxh1 (char *ptr, XINT clen, XINT num)
01052 {
01053 ftnint type = TYCHAR;
01054 XINT number = num;
01055 return( do_Lio_com( &type, &number, (flex *)ptr, &f77curunit, clen ) );
01056 }
01057
01058 int
01059 do_lioxi1_mp (char *ptr, XINT num, unit **fu)
01060 {
01061 ftnint type = TYBYTE;
01062 XINT number = num;
01063 return( do_Lio_com( &type, &number, (flex *)ptr, fu, 1 ) );
01064 }
01065
01066 int
01067 do_lioxi1 (char *ptr, XINT num)
01068 {
01069 ftnint type = TYBYTE;
01070 XINT number = num;
01071 return( do_Lio_com( &type, &number, (flex *)ptr, &f77curunit, 1 ) );
01072 }
01073
01074 int
01075 do_lioxi2_mp (char *ptr, XINT num, unit **fu)
01076 {
01077 ftnint type = TYSHORT;
01078 XINT number = num;
01079 return( do_Lio_com( &type, &number, (flex *)ptr, fu, 2 ) );
01080 }
01081
01082 int
01083 do_lioxi2 (char *ptr, XINT num)
01084 {
01085 ftnint type = TYSHORT;
01086 XINT number = num;
01087 return( do_Lio_com( &type, &number, (flex *)ptr, &f77curunit, 2 ) );
01088 }
01089
01090 int
01091 do_lioxi4_mp (char *ptr, XINT num, unit **fu)
01092 {
01093 ftnint type = TYINT;
01094 XINT number = num;
01095 return( do_Lio_com( &type, &number, (flex *)ptr, fu, 4 ) );
01096 }
01097
01098 int
01099 do_lioxi4 (char *ptr, XINT num)
01100 {
01101 ftnint type = TYINT;
01102 XINT number = num;
01103 return( do_Lio_com( &type, &number, (flex *)ptr, &f77curunit, 4 ) );
01104 }
01105
01106 int
01107 do_lioxi8_mp (char *ptr, XINT num, unit **fu)
01108 {
01109 ftnint type = TYLONGLONG;
01110 XINT number = num;
01111 return( do_Lio_com( &type, &number, (flex *)ptr, fu, 8 ) );
01112 }
01113
01114 int
01115 do_lioxi8 (char *ptr, XINT num)
01116 {
01117 ftnint type = TYLONGLONG;
01118 XINT number = num;
01119 return( do_Lio_com( &type, &number, (flex *)ptr, &f77curunit, 8 ) );
01120 }
01121
01122 int
01123 do_lioxl1_mp (char *ptr, XINT num, unit **fu)
01124 {
01125 ftnint type = TYLOGICAL1;
01126 XINT number = num;
01127 return( do_Lio_com( &type, &number, (flex *)ptr, fu, 1 ) );
01128 }
01129
01130 int
01131 do_lioxl1 (char *ptr, XINT num)
01132 {
01133 ftnint type = TYLOGICAL1;
01134 XINT number = num;
01135 return( do_Lio_com( &type, &number, (flex *)ptr, &f77curunit, 1 ) );
01136 }
01137
01138 int
01139 do_lioxl2_mp (char *ptr, XINT num, unit **fu)
01140 {
01141 ftnint type = TYLOGICAL2;
01142 XINT number = num;
01143 return( do_Lio_com( &type, &number, (flex *)ptr, fu, 2 ) );
01144 }
01145
01146 int
01147 do_lioxl2 (char *ptr, XINT num)
01148 {
01149 ftnint type = TYLOGICAL2;
01150 XINT number = num;
01151 return( do_Lio_com( &type, &number, (flex *)ptr, &f77curunit, 2 ) );
01152 }
01153
01154 int
01155 do_lioxl4_mp (char *ptr, XINT num, unit **fu)
01156 {
01157 ftnint type = TYLOGICAL4;
01158 XINT number = num;
01159 return( do_Lio_com( &type, &number, (flex *)ptr, fu, 4 ) );
01160 }
01161
01162 int
01163 do_lioxl4 (char *ptr, XINT num)
01164 {
01165 ftnint type = TYLOGICAL4;
01166 XINT number = num;
01167 return( do_Lio_com( &type, &number, (flex *)ptr, &f77curunit, 4 ) );
01168 }
01169
01170 int
01171 do_lioxl8_mp (char *ptr, XINT num, unit **fu)
01172 {
01173 ftnint type = TYLOGICAL8;
01174 XINT number = num;
01175 return( do_Lio_com( &type, &number, (flex *)ptr, fu, 8 ) );
01176 }
01177
01178 int
01179 do_lioxl8 (char *ptr, XINT num)
01180 {
01181 ftnint type = TYLOGICAL8;
01182 XINT number = num;
01183 return( do_Lio_com( &type, &number, (flex *)ptr, &f77curunit, 8 ) );
01184 }
01185
01186 int
01187 do_lioxr4_mp (char *ptr, XINT num, unit **fu)
01188 {
01189 ftnint type = TYREAL;
01190 XINT number = num;
01191 return( do_Lio_com( &type, &number, (flex *)ptr, fu, 4 ) );
01192 }
01193
01194 int
01195 do_lioxr4 (char *ptr, XINT num)
01196 {
01197 ftnint type = TYREAL;
01198 XINT number = num;
01199 return( do_Lio_com( &type, &number, (flex *)ptr, &f77curunit, 4 ) );
01200 }
01201
01202 int
01203 do_lioxr8_mp (char *ptr, XINT num, unit **fu)
01204 {
01205 ftnint type = TYDREAL;
01206 XINT number = num;
01207 return( do_Lio_com( &type, &number, (flex *)ptr, fu, 8 ) );
01208 }
01209
01210 int
01211 do_lioxr8 (char *ptr, XINT num)
01212 {
01213 ftnint type = TYDREAL;
01214 XINT number = num;
01215 return( do_Lio_com( &type, &number, (flex *)ptr, &f77curunit, 8 ) );
01216 }
01217
01218 int
01219 do_lioxr16_mp (char *ptr, XINT num, unit **fu)
01220 {
01221 ftnint type = TYQUAD;
01222 XINT number = num;
01223 return( do_Lio_com( &type, &number, (flex *)ptr, fu, 16 ) );
01224 }
01225
01226 int
01227 do_lioxr16 (char *ptr, XINT num)
01228 {
01229 ftnint type = TYQUAD;
01230 XINT number = num;
01231 return( do_Lio_com( &type, &number, (flex *)ptr, &f77curunit, 16 ) );
01232 }
01233
01234 int
01235 do_lioxc4_mp (char *ptr, XINT num, unit **fu)
01236 {
01237 ftnint type = TYCOMPLEX;
01238 XINT number = num;
01239 return( do_Lio_com( &type, &number, (flex *)ptr, fu, 8 ) );
01240 }
01241
01242 int
01243 do_lioxc4 (char *ptr, XINT num)
01244 {
01245 ftnint type = TYCOMPLEX;
01246 XINT number = num;
01247 return( do_Lio_com( &type, &number, (flex *)ptr, &f77curunit, 8 ) );
01248 }
01249
01250 int
01251 do_lioxc8_mp (char *ptr, XINT num, unit **fu)
01252 {
01253 ftnint type = TYDCOMPLEX;
01254 XINT number = num;
01255 return( do_Lio_com( &type, &number, (flex *)ptr, fu, 16 ) );
01256 }
01257
01258 int
01259 do_lioxc8 (char *ptr, XINT num)
01260 {
01261 ftnint type = TYDCOMPLEX;
01262 XINT number = num;
01263 return( do_Lio_com( &type, &number, (flex *)ptr, &f77curunit, 16 ) );
01264 }
01265
01266 int
01267 do_lioxc16_mp (char *ptr, XINT num, unit **fu)
01268 {
01269 ftnint type = TYQUADCOMPLEX;
01270 XINT number = num;
01271 return( do_Lio_com( &type, &number, (flex *)ptr, fu, 32 ) );
01272 }
01273
01274 int
01275 do_lioxc16 (char *ptr, XINT num)
01276 {
01277 ftnint type = TYQUADCOMPLEX;
01278 XINT number = num;
01279 return( do_Lio_com( &type, &number, (flex *)ptr, &f77curunit, 32 ) );
01280 }
01281
01282 int
01283 do_lioxa4v_mp (ftnint val, unit **fu)
01284 {
01285 ftnint value = val;
01286 ftnint type = TYADDR;
01287 XINT number = 1;
01288 return( do_Lio_com( &type, &number, (flex *)&value, fu, 4 ) );
01289 }
01290
01291 int
01292 do_lioxa4v (ftnint val)
01293 {
01294 ftnint value = val;
01295 ftnint type = TYADDR;
01296 XINT number = 1;
01297 return( do_Lio_com( &type, &number, (flex *)&value, &f77curunit, 4 ) );
01298 }
01299
01300 int
01301 do_lioxa8v_mp (ftnll val, unit **fu)
01302 {
01303 ftnll value = val;
01304 ftnint type = TYADDR;
01305 XINT number = 1;
01306 return( do_Lio_com( &type, &number, (flex *)&value, fu, 8 ) );
01307 }
01308
01309 int
01310 do_lioxa8v (ftnll val)
01311 {
01312 ftnll value = val;
01313 ftnint type = TYADDR;
01314 XINT number = 1;
01315 return( do_Lio_com( &type, &number, (flex *)&value, &f77curunit, 8 ) );
01316 }
01317
01318 int
01319 do_lioxh1v_mp (char val, unit **fu)
01320 {
01321 char value = val;
01322 ftnint type = TYCHAR;
01323 XINT number = 1;
01324 return( do_Lio_com( &type, &number, (flex *)&value, fu, 1 ) );
01325 }
01326
01327 int
01328 do_lioxh1v (char val)
01329 {
01330 char value = val;
01331 ftnint type = TYCHAR;
01332 XINT number = 1;
01333 return( do_Lio_com( &type, &number, (flex *)&value, &f77curunit, 1 ) );
01334 }
01335
01336 int
01337 do_lioxi1v_mp (char val, unit **fu)
01338 {
01339 char value = val;
01340 ftnint type = TYBYTE;
01341 XINT number = 1;
01342 return( do_Lio_com( &type, &number, (flex *)&value, fu, 1 ) );
01343 }
01344
01345 int
01346 do_lioxi1v (char val)
01347 {
01348 char value = val;
01349 ftnint type = TYBYTE;
01350 XINT number = 1;
01351 return( do_Lio_com( &type, &number, (flex *)&value, &f77curunit, 1 ) );
01352 }
01353
01354 int
01355 do_lioxi2v_mp (short val, unit **fu)
01356 {
01357 short value = val;
01358 ftnint type = TYSHORT;
01359 XINT number = 1;
01360 return( do_Lio_com( &type, &number, (flex *)&value, fu, 2 ) );
01361 }
01362
01363 int
01364 do_lioxi2v (short val)
01365 {
01366 short value = val;
01367 ftnint type = TYSHORT;
01368 XINT number = 1;
01369 return( do_Lio_com( &type, &number, (flex *)&value, &f77curunit, 2 ) );
01370 }
01371
01372 int
01373 do_lioxi4v_mp (ftnint val, unit **fu)
01374 {
01375 ftnint value = val;
01376 ftnint type = TYINT;
01377 XINT number = 1;
01378 return( do_Lio_com( &type, &number, (flex *)&value, fu, 4 ) );
01379 }
01380
01381 int
01382 do_lioxi4v (ftnint val)
01383 {
01384 ftnint value = val;
01385 ftnint type = TYINT;
01386 XINT number = 1;
01387 return( do_Lio_com( &type, &number, (flex *)&value, &f77curunit, 4 ) );
01388 }
01389
01390 int
01391 do_lioxi8v_mp (ftnll val, unit **fu)
01392 {
01393 ftnll value = val;
01394 ftnint type = TYLONGLONG;
01395 XINT number = 1;
01396 return( do_Lio_com( &type, &number, (flex *)&value, fu, 8 ) );
01397 }
01398
01399 int
01400 do_lioxi8v (ftnll val)
01401 {
01402 ftnll value = val;
01403 ftnint type = TYLONGLONG;
01404 XINT number = 1;
01405 return( do_Lio_com( &type, &number, (flex *)&value, &f77curunit, 8 ) );
01406 }
01407
01408 int
01409 do_lioxl1v_mp (char val, unit **fu)
01410 {
01411 char value = val;
01412 ftnint type = TYLOGICAL1;
01413 XINT number = 1;
01414 return( do_Lio_com( &type, &number, (flex *)&value, fu, 1 ) );
01415 }
01416
01417 int
01418 do_lioxl1v (char val)
01419 {
01420 char value = val;
01421 ftnint type = TYLOGICAL1;
01422 XINT number = 1;
01423 return( do_Lio_com( &type, &number, (flex *)&value, &f77curunit, 1 ) );
01424 }
01425
01426 int
01427 do_lioxl2v_mp (short val, unit **fu)
01428 {
01429 short value = val;
01430 ftnint type = TYLOGICAL2;
01431 XINT number = 1;
01432 return( do_Lio_com( &type, &number, (flex *)&value, fu, 2 ) );
01433 }
01434
01435 int
01436 do_lioxl2v (short val)
01437 {
01438 short value = val;
01439 ftnint type = TYLOGICAL2;
01440 XINT number = 1;
01441 return( do_Lio_com( &type, &number, (flex *)&value, &f77curunit, 2 ) );
01442 }
01443
01444 int
01445 do_lioxl4v_mp (ftnint val, unit **fu)
01446 {
01447 ftnint value = val;
01448 ftnint type = TYLOGICAL4;
01449 XINT number = 1;
01450 return( do_Lio_com( &type, &number, (flex *)&value, fu, 4 ) );
01451 }
01452
01453 int
01454 do_lioxl4v (ftnint val)
01455 {
01456 ftnint value = val;
01457 ftnint type = TYLOGICAL4;
01458 XINT number = 1;
01459 return( do_Lio_com( &type, &number, (flex *)&value, &f77curunit, 4 ) );
01460 }
01461
01462 int
01463 do_lioxl8v_mp (ftnll val, unit **fu)
01464 {
01465 ftnll value = val;
01466 ftnint type = TYLOGICAL8;
01467 XINT number = 1;
01468 return( do_Lio_com( &type, &number, (flex *)&value, fu, 8 ) );
01469 }
01470
01471 int
01472 do_lioxl8v (ftnll val)
01473 {
01474 ftnll value = val;
01475 ftnint type = TYLOGICAL8;
01476 XINT number = 1;
01477 return( do_Lio_com( &type, &number, (flex *)&value, &f77curunit, 8 ) );
01478 }
01479
01480 int
01481 do_lioxr4v_mp (float val, unit **fu)
01482 {
01483 float value = val;
01484 ftnint type = TYREAL;
01485 XINT number = 1;
01486 return( do_Lio_com( &type, &number, (flex *)&value, fu, 4 ) );
01487 }
01488
01489 int
01490 do_lioxr4v (float val)
01491 {
01492 float value = val;
01493 ftnint type = TYREAL;
01494 XINT number = 1;
01495 return( do_Lio_com( &type, &number, (flex *)&value, &f77curunit, 4 ) );
01496 }
01497
01498 int
01499 do_lioxr8v_mp (double val, unit **fu)
01500 {
01501 double value = val;
01502 ftnint type = TYDREAL;
01503 XINT number = 1;
01504 return( do_Lio_com( &type, &number, (flex *)&value, fu, 8 ) );
01505 }
01506
01507 int
01508 do_lioxr8v (double val)
01509 {
01510 double value = val;
01511 ftnint type = TYDREAL;
01512 XINT number = 1;
01513 return( do_Lio_com( &type, &number, (flex *)&value, &f77curunit, 8 ) );
01514 }
01515
01516 int
01517 do_lioxr16v_mp (long double val, unit **fu)
01518 {
01519 long double value = val;
01520 ftnint type = TYQUAD;
01521 XINT number = 1;
01522 return( do_Lio_com( &type, &number, (flex *)&value, fu, 16 ) );
01523 }
01524
01525 int
01526 do_lioxr16v (long double val)
01527 {
01528 long double value = val;
01529 ftnint type = TYQUAD;
01530 XINT number = 1;
01531 return( do_Lio_com( &type, &number, (flex *)&value, &f77curunit, 16 ) );
01532 }
01533
01534 int
01535 do_lioxc4v_mp (float rval, float ival, unit **fu)
01536 {
01537 float value[2];
01538 ftnint type = TYCOMPLEX;
01539 XINT number = 1;
01540 value[0] = rval;
01541 value[1] = ival;
01542 return( do_Lio_com( &type, &number, (flex *)&value, fu, 8 ) );
01543 }
01544
01545 int
01546 do_lioxc4v (float rval, float ival)
01547 {
01548 float value[2];
01549 ftnint type = TYCOMPLEX;
01550 XINT number = 1;
01551 value[0] = rval;
01552 value[1] = ival;
01553 return( do_Lio_com( &type, &number, (flex *)&value, &f77curunit, 8 ) );
01554 }
01555
01556 int
01557 do_lioxc8v_mp (double rval, double ival, unit **fu)
01558 {
01559 double value[2];
01560 ftnint type = TYDCOMPLEX;
01561 XINT number = 1;
01562 value[0] = rval;
01563 value[1] = ival;
01564 return( do_Lio_com( &type, &number, (flex *)&value, fu, 16 ) );
01565 }
01566
01567 int
01568 do_lioxc8v (double rval, double ival)
01569 {
01570 double value[2];
01571 ftnint type = TYDCOMPLEX;
01572 XINT number = 1;
01573 value[0] = rval;
01574 value[1] = ival;
01575 return( do_Lio_com( &type, &number, (flex *)&value, &f77curunit, 16 ) );
01576 }
01577
01578 int
01579 do_lioxc16v_mp (long double rval, long double ival, unit **fu)
01580 {
01581 long double value[2];
01582 ftnint type = TYQUADCOMPLEX;
01583 XINT number = 1;
01584 value[0] = rval;
01585 value[1] = ival;
01586 return( do_Lio_com( &type, &number, (flex *)&value, fu, 32 ) );
01587 }
01588
01589 int
01590 do_lioxc16v (long double rval, long double ival)
01591 {
01592 long double value[2];
01593 ftnint type = TYQUADCOMPLEX;
01594 XINT number = 1;
01595 value[0] = rval;
01596 value[1] = ival;
01597 return( do_Lio_com( &type, &number, (flex *)&value, &f77curunit, 32 ) );
01598 }
01599
01600
