Open64 (mfef90, whirl2f, and IR tools)
TAG: version-openad; SVN changeset: 916
|
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 00038 #ifndef INLINE 00039 #pragma ident "@(#) libf/fio/dopexfer.c 92.3 06/18/99 10:21:14" 00040 #endif 00041 00042 #include <liberrno.h> 00043 #include <stdlib.h> 00044 #include <string.h> 00045 #include <cray/nassert.h> 00046 #include "fio.h" 00047 #include "f90io.h" 00048 00049 /* 00050 * If compiled with -D_ASSERT_ON, dopexfer will print the I/O list 00051 * items encountered when DEBUG_90IO is set. 00052 */ 00053 00054 static FILE *_df; 00055 static int _ddope_nest = 0; 00056 static int _ddope = -1; 00057 static unit *_ddcup; /* for debug output */ 00058 00059 #ifdef _ASSERT_ON 00060 00061 #define DEBUG_90IO \ 00062 ((_ddope == -1) ? ( \ 00063 (getenv("DEBUG_90IO") != NULL) ? ( \ 00064 (_df = fopen(getenv("DEBUG_90IO"), "w")), \ 00065 (_ddope = (_df != NULL)) \ 00066 ) \ 00067 : (\ 00068 (_df = fopen("/dev/null", "w")), \ 00069 (_ddope = 0) \ 00070 ) \ 00071 ) \ 00072 : \ 00073 _ddope \ 00074 ) 00075 00076 #define DD { \ 00077 if (DEBUG_90IO) { \ 00078 register int ix; \ 00079 fprintf(_df, "unit %lld ", _ddcup->uid); \ 00080 for (ix = 0; ix < _ddope_nest; ix++) \ 00081 putc(' ', _df); \ 00082 } \ 00083 } 00084 00085 #else 00086 #define DEBUG_90IO 0 00087 #define DD 00088 #endif 00089 00090 /* 00091 * The dovarlist structure stores a list of dovariable addresses. 00092 * It is used by _map_to_dv(). 00093 */ 00094 00095 #define MAXDOVAR 7 /* we can't map to dv an implied do deeper than this */ 00096 struct dovarlist { 00097 int nvar; 00098 int *dov[MAXDOVAR]; 00099 }; 00100 00101 00102 static int _stride_dv(FIOSPTR css, unit *cup, DopeVectorType *dv, 00103 int **dovar, xfer_func *func); 00104 00105 int _map_to_dv(ioimplieddo_entry *impdo, DopeVectorType *dvptr, 00106 int **iarr, struct dovarlist *dovlp); 00107 00108 int _strip_mine(FIOSPTR css, unit *cup, xfer_func *func, ioimplieddo_entry *ie, 00109 int *retp); 00110 00111 /* 00112 * _xfer_iolist 00113 * 00114 * Perform I/O on all items in an I/O list. func may be 00115 * _ld_read, _rdfmt, _rdunf, _ld_write, _wrfmt, or _wrunf. 00116 * 00117 * Arguments 00118 * 00119 * iolist - structure which describes I/O list items. 00120 * func - the Fortran 77 I/O interface function to call. 00121 * cup - the unit pointer. 00122 * 00123 * Return Value: 00124 * 00125 * 0 normal return 00126 * FEEORCND if end of record condition (with ADVANCE='NO') 00127 * other <0 if end of file consition 00128 * >0 if error condition 00129 */ 00130 00131 #ifdef INLINE 00132 static int 00133 _inline_xfer_iolist( 00134 #else 00135 int 00136 _xfer_iolist( 00137 #endif 00138 FIOSPTR css, 00139 unit *cup, 00140 iolist_header *iolist, 00141 xfer_func *func) 00142 { 00143 register short termrec; 00144 int ret; 00145 type_packet tip; 00146 register int ioitems; 00147 ioentry_header *nextioh; 00148 void *nexte; 00149 int **indarray; 00150 register int mode; 00151 00152 ioitems = iolist->icount; 00153 nextioh = (ioentry_header *)(iolist + 1); 00154 termrec = 0; 00155 00156 if (DEBUG_90IO) { 00157 _ddcup = cup; /* set this up for debug output */ 00158 _ddope_nest++; 00159 if (_ddope_nest == 1) { 00160 char *fnm = ""; 00161 if (func == _rdfmt) fnm = "_rdfmt"; 00162 else if (func == _wrfmt) fnm = "_wrfmt"; 00163 else if (func == _ld_read) fnm = "_ld_read"; 00164 else if (func == _ld_write) fnm = "_ld_write"; 00165 else if (func == _rdunf) fnm = "_rdunf"; 00166 else if (func == _wrunf) fnm = "_wrunf"; 00167 00168 DD; putc('\n', _df); 00169 DD; fprintf(_df,"----------------------------------\n"); 00170 DD; fprintf(_df, 00171 "Begin iolist for unit %lld func=%s\n", 00172 cup->uid, fnm); 00173 00174 DD; fprintf(_df,"iolist->icount = %ld\n",iolist->icount); 00175 } 00176 } 00177 00178 ret = 0; /* in case 0 entries were passed */ 00179 00180 while (ioitems--) { 00181 00182 if (cup->f_lastiolist) { 00183 if ((void *)((long *)nextioh + nextioh->ioentsize) == cup->f_lastiolist) 00184 termrec = 1; 00185 } 00186 00187 nexte = nextioh + 1; 00188 00189 /* Initialize type information packet */ 00190 00191 tip.type77 = -1; 00192 tip.cnvindx = 0; 00193 tip.count = 1; 00194 tip.stride = 1; 00195 00196 switch (nextioh->valtype) { 00197 00198 case IO_SCALAR: 00199 00200 { 00201 ioscalar_entry *se; 00202 void *vaddr; 00203 00204 se = nexte; 00205 00206 /* Assertion */ 00207 assert ( se->tinfo.type == DVTYPE_ASCII || 00208 se->tinfo.int_len > 0 ); 00209 00210 tip.type90 = se->tinfo.type; 00211 tip.intlen = se->tinfo.int_len; 00212 tip.extlen = tip.intlen; 00213 tip.elsize = tip.intlen >> 3; 00214 00215 if (DEBUG_90IO) { 00216 DD; putc('\n',_df); 00217 DD; fprintf(_df,"IO_SCALAR, type90=%d\n", 00218 tip.type90); 00219 DD; fprintf(_df,"address = 0%lo\n", 00220 (long)se->iovar_address.v); 00221 if (tip.type90 == DVTYPE_ASCII) { 00222 DD; fprintf(_df,"character len = %ld\n", 00223 _fcdlen(se->iovar_address.fcd)); 00224 } 00225 00226 DD; fprintf(_df,"dpflag = %ld\n", 00227 se->tinfo.dpflag); 00228 DD; fprintf(_df,"kind_or_star = %d\n", 00229 se->tinfo.kind_or_star); 00230 DD; fprintf(_df,"int_len = %ld\n", 00231 se->tinfo.int_len); 00232 DD; fprintf(_df,"dec_len = %ld\n", 00233 se->tinfo.dec_len); 00234 } 00235 00236 if (tip.type90 == DVTYPE_ASCII) { 00237 00238 vaddr = _fcdtocp(se->iovar_address.fcd); 00239 tip.elsize = tip.elsize * 00240 _fcdlen(se->iovar_address.fcd); 00241 } 00242 else 00243 vaddr = se->iovar_address.v; 00244 00245 tip.count = 1; 00246 tip.stride = 1; 00247 00248 #if NUMERIC_DATA_CONVERSION_ENABLED 00249 if ( !(cup->ufmt) && /* If unformatted */ 00250 (cup->unumcvrt || cup->ucharset) ) { 00251 00252 ret = _get_dc_param(css, cup, se->tinfo, 00253 &tip); 00254 if (ret != 0) 00255 goto done; 00256 } 00257 #endif 00258 00259 mode = termrec ? FULL : PARTIAL; 00260 ret = func(css, cup, vaddr, &tip, mode); 00261 00262 break; 00263 } 00264 00265 case IO_DOPEVEC: 00266 { 00267 ioarray_entry *ae; 00268 DopeVectorType *dv; 00269 00270 ae = nexte; 00271 dv = ae->dv; 00272 tip.type90 = dv->type_lens.type; 00273 00274 if (DEBUG_90IO) { 00275 DD; putc('\n',_df); 00276 DD; fprintf(_df,"IO_DOPEVEC, type90=%d\n", 00277 tip.type90); 00278 } 00279 00280 /* Assertions */ 00281 assert ( ! (ae->indflag && ae->dovar == NULL) ); 00282 00283 indarray = NULL; 00284 00285 if (ae->indflag) 00286 indarray = ae->dovar; 00287 00288 /* 00289 * Call the xfer_func directly for some special 00290 * cased non-indexed dopevectors. 00291 */ 00292 if (indarray == NULL && tip.type90 != DVTYPE_ASCII) { 00293 00294 register short n_dim = dv->n_dim; 00295 register long extent = dv->dimension[0].extent; 00296 register long inc; 00297 struct DvDimen *dimen = dv->dimension; 00298 00299 tip.intlen = dv->type_lens.int_len; 00300 tip.extlen = tip.intlen; 00301 tip.elsize = tip.intlen >> 3; 00302 00303 /* 00304 * Special case any rank 1 dopevector, or a rank > 1 00305 * dopevector whose storage sequence is strided 00306 * consistently throughout. 00307 */ 00308 if (n_dim != 1) { 00309 register short nc; 00310 00311 if (n_dim == 2) { 00312 if (dimen[0].stride_mult * extent != 00313 dimen[1].stride_mult) 00314 goto general_dv_processing; 00315 extent *= dimen[1].extent; 00316 } 00317 else if (n_dim == 0) { 00318 extent = 1; 00319 } 00320 else { 00321 for (nc = 0; nc < (n_dim-1); nc++) { 00322 register long st = dimen[nc].stride_mult; 00323 register long ex = dimen[nc].extent; 00324 if ( (st * ex) != 00325 dimen[nc+1].stride_mult) 00326 goto general_dv_processing; 00327 extent *= dimen[nc+1].extent; 00328 } 00329 } 00330 } 00331 00332 if (extent > 1) { 00333 register long sm; 00334 00335 sm = dv->dimension[0].stride_mult; 00336 00337 if (DEBUG_90IO) { 00338 DD;fprintf(_df,"elsize=%ld sm=%ld SMSCALE=%d\n", 00339 tip.elsize, sm, SMSCALE(dv)); 00340 DD;fprintf(_df,"int_len=%ld kind_or_star=%d ext_len=%ld\n", 00341 dv->type_lens.int_len, 00342 dv->type_lens.kind_or_star, 00343 dv->type_lens.dec_len); 00344 } 00345 if (sm * (signed)SMSCALE(dv) == tip.elsize) 00346 inc = 1; 00347 else { 00348 register long bpsm; 00349 00350 bpsm = sm * (signed)SMSCALE(dv); 00351 inc = bpsm / tip.elsize; 00352 00353 /* if stride not a multiple of size ...*/ 00354 00355 if (tip.elsize * inc != bpsm) 00356 goto general_dv_processing; 00357 } 00358 } 00359 else 00360 inc = 1; 00361 00362 tip.count = extent; 00363 tip.stride = inc; 00364 00365 #if NUMERIC_DATA_CONVERSION_ENABLED 00366 if ( !(cup->ufmt) && /* If unformatted */ 00367 (cup->unumcvrt || cup->ucharset) ) { 00368 ret = _get_dc_param(css, cup, dv->type_lens, 00369 &tip); 00370 if (ret != 0) 00371 return(ret); 00372 } 00373 #endif 00374 if (DEBUG_90IO) { 00375 DD; fprintf(_df,"Fold DV to 1-dim, extent=%ld inc=%ld\n", 00376 extent, inc); 00377 } 00378 00379 mode = termrec ? FULL : PARTIAL; 00380 ret = func(css, cup, dv->base_addr.a.ptr, 00381 &tip, mode); 00382 } 00383 else { 00384 general_dv_processing: 00385 ret = _stride_dv(css, cup, ae->dv, indarray, 00386 func); 00387 } 00388 00389 break; 00390 } 00391 00392 case IO_LOOP: 00393 { 00394 register long loopinc; 00395 register long begcnt; 00396 register long endcnt; 00397 int *loopvar; 00398 int *locia[MAXDIM]; 00399 DopeVectorType locdv; 00400 ioimplieddo_entry *ie; 00401 struct dovarlist dovl; 00402 00403 ie = nexte; 00404 00405 if (DEBUG_90IO) { 00406 DD; putc('\n',_df); 00407 DD; fprintf(_df, 00408 "IO_LOOP start=%d inc=%d end=%d\n", 00409 *ie->iobegcnt, *ie->ioinccnt, 00410 *ie->ioendcnt); 00411 } 00412 00413 dovl.nvar = 0; 00414 00415 if (_map_to_dv(ie, &locdv, locia, &dovl)) { 00416 if (DEBUG_90IO) { 00417 DD; fprintf(_df,"Mapped to dopevect\n"); 00418 } 00419 ret = _stride_dv(css, cup, &locdv, locia, 00420 func); 00421 break; 00422 } 00423 00424 /* 00425 * If all iolist entries inside an implied do loop 00426 * are the same type, we can strip mine the loop 00427 * as an optimization. 00428 */ 00429 if (_strip_mine(css, cup, func, ie, &ret)) 00430 break; 00431 00432 if (DEBUG_90IO) { 00433 DD; fprintf(_df, 00434 "Could not map to dopevector or strip mine \n"); 00435 } 00436 00437 /* Assertions */ 00438 00439 assert ( ie->ioinccnt != NULL ); 00440 assert ( ie->ioloopvar != NULL ); 00441 assert ( ie->iobegcnt != NULL ); 00442 assert ( ie->ioendcnt != NULL ); 00443 00444 loopinc = *ie->ioinccnt; 00445 loopvar = ie->ioloopvar; 00446 begcnt = *ie->iobegcnt; 00447 endcnt = *ie->ioendcnt; 00448 00449 if (loopinc == 0) { 00450 ret = FEINCZER; 00451 goto done; 00452 } 00453 00454 *loopvar = begcnt; 00455 00456 /* If recursive implied DO LOOP, clear pointer so 00457 * too many records are not written in seq unf IO 00458 */ 00459 if (cup->f_lastiolist != NULL) 00460 cup->f_lastiolist = NULL; 00461 00462 for (;;) { 00463 00464 if (DEBUG_90IO) { 00465 DD; fprintf(_df,"loopvar = %d\n",*loopvar); 00466 } 00467 00468 if (loopinc > 0) { 00469 if (*loopvar > endcnt) break; 00470 } 00471 else { 00472 if (*loopvar < endcnt) break; 00473 } 00474 00475 ret = _xfer_iolist(css, cup, (void *)(ie + 1), func); 00476 00477 if (ret != 0) 00478 goto done; 00479 00480 *loopvar += loopinc; 00481 } 00482 break; 00483 } 00484 00485 default: 00486 _ferr(css, FEINTUNK); 00487 } 00488 00489 if (ret != 0) 00490 goto done; 00491 00492 nextioh = (ioentry_header*)((long *)nextioh + 00493 nextioh->ioentsize); 00494 } 00495 done: 00496 if (DEBUG_90IO) { 00497 if (_ddope_nest == 1) { 00498 DD; fprintf(_df,"End iolist for unit %lld\n",cup->uid); 00499 } 00500 _ddope_nest--; 00501 } 00502 00503 return(ret); 00504 } 00505 00506 /* 00507 * _stride_dv 00508 * 00509 * Call a specified function to transfer a data area defined by 00510 * a dopevector. This corresponds to an array section or a 00511 * sequence of array elements expressible by use of an implied 00512 * do loop in an iolist. 00513 * 00514 * Arguments 00515 * 00516 * dv - dope vector which describes the array section. 00517 * func - the function to call with each segment. 00518 * 00519 * Return Value 00520 * 00521 * 0 normal return 00522 * FEEORCND if end of record condition (with ADVANCE='NO') 00523 * other <0 if end of file consition 00524 * >0 if error condition 00525 */ 00526 00527 static int 00528 _stride_dv( 00529 FIOSPTR css, 00530 unit *cup, 00531 DopeVectorType *dv, 00532 int **dovar, 00533 xfer_func *func) 00534 { 00535 register short element_stride; /* 1 iff elsize divides stride*/ 00536 register short i; 00537 register short nd; 00538 register short newi; 00539 register short nc; 00540 register int id1, id2, id3, id4, id5, id6, id7; 00541 register int ret; 00542 register long badjust; /* offset for collapsed dims */ 00543 register long extent; /* extent of first dimension */ 00544 struct DvDimen *dvdimen; 00545 bcont *addr; /* for numeric data */ 00546 char *baddr; /* for byte-oriented data */ 00547 void *addr2, *addr3, *addr4; 00548 void *addr5, *addr6; 00549 type_packet tip; 00550 struct DvDimen dimen[MAXDIM]; 00551 00552 /* 00553 * Decide whether the f90 or f77 type code will be used. 00554 */ 00555 if (DEBUG_90IO) { 00556 register short itmp; 00557 DD; fprintf(_df,"\n"); 00558 DD; fprintf(_df,"Enter _stride_dv\n"); 00559 DD; fprintf(_df,"dv->base_addr = 0%lo\n", 00560 (long)dv->base_addr.a.ptr); 00561 if (dv->type_lens.type == DVTYPE_ASCII) { 00562 DD; fprintf(_df,"character len = %ld\n", 00563 _fcdlen(dv->base_addr.charptr)); 00564 } 00565 DD; fprintf(_df,"dv->base_addr.a.el_len = %ld\n", 00566 dv->base_addr.a.el_len); 00567 DD; fprintf(_df,"dv->assoc = %ld\n",dv->assoc); 00568 DD; fprintf(_df,"dv->ptr_alloc = %ld\n",dv->ptr_alloc); 00569 DD; fprintf(_df,"dv->p_or_a = %d\n",dv->p_or_a); 00570 DD; fprintf(_df,"dv->n_dim = %ld\n",dv->n_dim); 00571 00572 DD; fprintf(_df,"dv->type_lens.dpflag = %ld\n", 00573 dv->type_lens.dpflag); 00574 DD; fprintf(_df,"dv->type_lens.kind_or_star = %d\n", 00575 dv->type_lens.kind_or_star); 00576 DD; fprintf(_df,"dv->type_lens.int_len = %ld\n", 00577 dv->type_lens.int_len); 00578 DD; fprintf(_df,"dv->type_lens.dec_len = %ld\n", 00579 dv->type_lens.dec_len); 00580 00581 DD; fprintf(_df,"dv->orig_base = 0%lo\n",dv->orig_base); 00582 DD; fprintf(_df,"dv->orig_size = %ld\n",dv->orig_size); 00583 00584 for (itmp = 0; itmp < dv->n_dim; itmp++) { 00585 DD; fprintf(_df," Dim %d ", itmp); 00586 fprintf(_df," low=%2ld extent=%2ld stride_mult=%2ld\n", 00587 dv->dimension[itmp].low_bound, 00588 dv->dimension[itmp].extent, 00589 dv->dimension[itmp].stride_mult); 00590 } 00591 if (dovar != NULL) { 00592 DD; fprintf(_df,"Indexes into dopevector:\n"); 00593 DD; fprintf(_df," Index Addresses: "); 00594 for (itmp = 0; itmp < dv->n_dim; itmp++) { 00595 if (dovar[itmp] == NULL) 00596 fprintf(_df," NULL"); 00597 else 00598 fprintf(_df," 0%lo", (long)dovar[itmp]); 00599 } 00600 fprintf(_df,"\n"); 00601 DD; fprintf(_df," Index Values: "); 00602 for (itmp = 0; itmp < dv->n_dim ; itmp++) { 00603 if (dovar[itmp] == NULL) 00604 fprintf(_df," -"); 00605 else 00606 fprintf(_df," 0%o", *dovar[itmp]); 00607 } 00608 fprintf(_df,"\n"); 00609 } 00610 } /* end if (DEBUG_90IO) */ 00611 00612 /* Assertions */ 00613 00614 assert ( dv != NULL ); 00615 assert ( dv->type_lens.int_len > 0 ); 00616 00617 if (dv->p_or_a && (dv->assoc == 0)) 00618 return(FEPTRNAS); /* pointer not associated */ 00619 00620 tip.type77 = -1; 00621 tip.type90 = dv->type_lens.type; 00622 tip.intlen = dv->type_lens.int_len; 00623 tip.extlen = tip.intlen; 00624 tip.elsize = tip.intlen >> 3; 00625 tip.cnvindx = 0; 00626 tip.count = 1; 00627 tip.stride = 1; 00628 00629 /* 00630 * Set up implicit data conversion parameters. 00631 */ 00632 00633 #if NUMERIC_DATA_CONVERSION_ENABLED 00634 if ( !(cup->ufmt) && /* If unformatted */ 00635 (cup->unumcvrt || cup->ucharset) ) { 00636 00637 ret = _get_dc_param(css, cup, dv->type_lens, &tip); 00638 00639 if (ret != 0) 00640 goto done; 00641 } 00642 #endif 00643 00644 nd = dv->n_dim; 00645 badjust = 0; 00646 00647 /* 00648 * Make a local copy of the dimension information so we may optimize it. 00649 */ 00650 for (i = 0; i < nd; i++) 00651 dimen[i] = dv->dimension[i]; 00652 00653 /* 00654 * Fold any indexes into the new dimension structure. The 00655 * result is that we can ignore the low_bound field in the 00656 * nested loops. 00657 * 00658 * We also collapse (remove) indexed dimensions and 00659 * unindexed dimensions with extents of one. 00660 */ 00661 newi = 0; 00662 dvdimen = dv->dimension; 00663 00664 for (i = 0; i < nd; i++) { 00665 if (dovar == NULL || dovar[i] == NULL) { 00666 00667 /* bail out here if any extent is 0 */ 00668 00669 if (dvdimen[i].extent == 0) 00670 return(0); 00671 00672 /* use this unindexed dimension if extent > 1 */ 00673 00674 if (dvdimen[i].extent > 1) 00675 dimen[newi++] = dvdimen[i]; 00676 } 00677 else /* collapse this indexed dimension */ 00678 badjust += (*dovar[i] - dvdimen[i].low_bound) * 00679 dvdimen[i].stride_mult; 00680 } 00681 00682 if (DEBUG_90IO) { 00683 DD; fprintf(_df, "%d indexed or extent-1 dims collapsed\n", 00684 nd - newi); 00685 } 00686 00687 nd = newi; 00688 00689 if (DEBUG_90IO) { 00690 register int i_dim; 00691 DD; fprintf(_df, "%d dimension(s) are left\n", nd); 00692 for (i_dim = 0; i_dim < nd ; i_dim++) { 00693 DD; fprintf(_df," Dim %d ",i_dim); 00694 fprintf(_df," low=%2ld extent=%2ld stride_mult=%2ld\n", 00695 dimen[i_dim].low_bound, 00696 dimen[i_dim].extent, 00697 dimen[i_dim].stride_mult); 00698 } 00699 } 00700 00701 /* 00702 * When two or more initial dimensions are stored and strided 00703 * contiguously (often the case when an entire array is 00704 * being processed), collapse the adjacent compatible dimensions. 00705 * 00706 * Someday, the compiler might do compile-time and/or run-time checking 00707 * to eliminate the need to optimize this here in the library. 00708 * 00709 * The first loop sets nc to the number of dimensions which could 00710 * be removed by collapsing them into an adjacent dimension 00711 * while preserving constant striding. 00712 */ 00713 for (nc = 0; nc < (nd-1); nc++) { 00714 register long st = dimen[nc].stride_mult; 00715 register long ex = dimen[nc].extent; 00716 if ((st * ex) != dimen[nc+1].stride_mult) 00717 break; 00718 } 00719 00720 if (DEBUG_90IO) { 00721 DD; fprintf(_df, "%d dimensions removed by collapsing compatibile adjacent dimension(s)\n", nc); 00722 } 00723 00724 /* 00725 * Collapse nc adjacent dimensions. These dimensions are 00726 * replaced by one dimension with stride equal to the stride 00727 * of the earliest dimension and extent equal to the product 00728 * of the extents of the dimensions being replaced. 00729 */ 00730 if (nc > 0) { 00731 register short j; 00732 00733 for (j = 1; j <= nc; j++) 00734 dimen[0].extent *= dimen[j].extent; 00735 00736 nd = nd - nc; /* decrease the number of dimensions */ 00737 00738 assert (nd > 0);/* must leave at least one dimension */ 00739 00740 /* 00741 * Move the other dimensions down to delete the 00742 * collapsed dimensions. 00743 */ 00744 00745 for (j = 1; j < nd; j++) 00746 dimen[j] = dimen[j+nc]; 00747 } 00748 00749 if (DEBUG_90IO) { 00750 register int i_dim; 00751 DD; fprintf(_df, "%d dimension(s) are left\n", nd); 00752 for (i_dim = 0; i_dim < nd ; i_dim++) { 00753 DD; fprintf(_df," Dim %d ",i_dim); 00754 fprintf(_df," low=%2ld extent=%2ld stride_mult=%2ld\n", 00755 dimen[i_dim].low_bound, 00756 dimen[i_dim].extent, 00757 dimen[i_dim].stride_mult); 00758 } 00759 } 00760 00761 /* 00762 * Special case a single indexed array element or pointer to scalar as 00763 * a rank 1 array of shape 1. 00764 */ 00765 if (nd == 0) { 00766 nd = 1; 00767 dimen[0].extent = 1; 00768 dimen[0].stride_mult = 0; 00769 } 00770 00771 if (tip.type90 == DVTYPE_ASCII) { 00772 00773 tip.elsize = tip.elsize * _fcdlen(dv->base_addr.charptr); 00774 extent = dimen[0].extent; 00775 element_stride = 1; 00776 00777 if (extent > 1) { 00778 register long stm; 00779 00780 stm = dimen[0].stride_mult; 00781 tip.stride = stm / tip.elsize; 00782 00783 if (tip.stride * tip.elsize != stm) 00784 element_stride = 0; /* it's a section of substrings */ 00785 } 00786 00787 /* For character arrays in an implied DO loop, badjust 00788 * contains the elsize offset from the stridemult: 00789 * badjust += (*dovar[i] - lowbound[i]) * stridemult[i] 00790 */ 00791 baddr = _fcdtocp(dv->base_addr.charptr) + badjust; 00792 00793 switch (nd) { 00794 00795 case 7: 00796 for (id7 = 0; id7 < dimen[6].extent; id7++) { 00797 addr6 = baddr; 00798 case 6: 00799 for (id6 = 0; id6 < dimen[5].extent; id6++) { 00800 addr5 = baddr; 00801 case 5: 00802 for (id5 = 0; id5 < dimen[4].extent; id5++) { 00803 addr4 = baddr; 00804 case 4: 00805 for (id4 = 0; id4 < dimen[3].extent; id4++) { 00806 addr3 = baddr; 00807 case 3: 00808 for (id3 = 0; id3 < dimen[2].extent; id3++) { 00809 addr2 = baddr; 00810 case 2: 00811 for (id2 = 0; id2 < dimen[1].extent; id2++) { 00812 case 1: 00813 if (element_stride) { 00814 tip.count = extent; 00815 ret = func(css, cup, baddr, &tip, PARTIAL); 00816 if (ret != 0) goto done; 00817 } 00818 else { 00819 char *ba; 00820 ba = baddr; 00821 for (id1 = 0; id1 < extent; id1++) { 00822 tip.count = 1; 00823 ret = func(css, cup, ba, &tip, PARTIAL); 00824 if (ret != 0) goto done; 00825 ba = ba + dimen[0].stride_mult; 00826 } 00827 } 00828 00829 if (nd == 1) goto done; 00830 baddr += dimen[1].stride_mult; 00831 } 00832 if (nd == 2) goto done; 00833 baddr = addr2; 00834 baddr += dimen[2].stride_mult; 00835 } 00836 if (nd == 3) goto done; 00837 baddr = addr3; 00838 baddr += dimen[3].stride_mult; 00839 } 00840 if (nd == 4) goto done; 00841 baddr = addr4; 00842 baddr += dimen[4].stride_mult; 00843 } 00844 if (nd == 5) goto done; 00845 baddr = addr5; 00846 baddr += dimen[5].stride_mult; 00847 } 00848 if (nd == 6) goto done; 00849 baddr = addr6; 00850 baddr += dimen[6].stride_mult; 00851 } 00852 } 00853 } 00854 else { /* numeric data */ 00855 00856 register int bshft; /* 0 or 1; shift count for ratio of */ 00857 /* stride_mult units to basic storage */ 00858 /* unit size. */ 00859 /* 00860 * We only support dopevector stride mults with units 00861 * scaled by sizeof(long) or sizeof(bcont). 00862 */ 00863 #if defined(__mips) || defined(_LITTLE_ENDIAN) 00864 assert( SMSCALE(dv) == sizeof(bcont) || 00865 SMSCALE(dv) == sizeof(_f_int2) || 00866 SMSCALE(dv) == sizeof(_f_int4) || 00867 SMSCALE(dv) == sizeof(long) ); 00868 #else 00869 assert( SMSCALE(dv) == sizeof(bcont) || 00870 SMSCALE(dv) == sizeof(long) ); 00871 #endif 00872 00873 /* The -1 should not be possible but check for it */ 00874 00875 assert( SMSHIFT(dv) != -1); 00876 00877 element_stride = 1; 00878 extent = dimen[0].extent; 00879 bshft = SMSHIFT(dv); 00880 00881 if (extent > 1) { 00882 register long bpsm; 00883 00884 bpsm = dimen[0].stride_mult * (signed)SMSCALE(dv); 00885 tip.stride = bpsm / tip.elsize; 00886 00887 if (tip.stride * tip.elsize != bpsm) 00888 element_stride = 0; /* section across derived type */ 00889 } 00890 00891 addr = (bcont *)dv->base_addr.a.ptr + (badjust << bshft); 00892 00893 /* 00894 * Decide if we should copy one or more dimensions 00895 * contiguously before writing (or read a contigous 00896 * chunk before distributing it to one or more possibley 00897 * strided dimensions. 00898 * 00899 */ 00900 00901 if (nd > 1 && element_stride && (extent * tip.elsize) <= CHBUFSIZE){ 00902 00903 if (DEBUG_90IO) { 00904 DD; fprintf(_df, "calling chunk routine\n"); 00905 } 00906 00907 ret = _iochunk(css, cup, func, dimen, &tip, nd, 00908 extent, bshft, addr); 00909 return(ret); 00910 } 00911 00912 switch (nd) { 00913 00914 case 7: 00915 for (id7 = 0; id7 < dimen[6].extent; id7++) { 00916 addr6 = addr; 00917 case 6: 00918 for (id6 = 0; id6 < dimen[5].extent; id6++) { 00919 addr5 = addr; 00920 case 5: 00921 for (id5 = 0; id5 < dimen[4].extent; id5++) { 00922 addr4 = addr; 00923 case 4: 00924 for (id4 = 0; id4 < dimen[3].extent; id4++) { 00925 addr3 = addr; 00926 case 3: 00927 for (id3 = 0; id3 < dimen[2].extent; id3++) { 00928 addr2 = addr; 00929 case 2: 00930 for (id2 = 0; id2 < dimen[1].extent; id2++) { 00931 case 1: 00932 if (element_stride) { 00933 tip.count = extent; 00934 ret = func(css, cup, addr, &tip, PARTIAL); 00935 } 00936 else { 00937 bcont *ad; 00938 ad = addr; 00939 /* 00940 * If derived type foo contains two fields, 00941 * real a and double precision d, then 00942 * foo(1:2)%d generates this type of 00943 * dopevector with a stride which is not 00944 * a multiple of the element size. 00945 */ 00946 for (id1 = 0; id1 < extent; id1++) { 00947 tip.count = 1; 00948 ret = func(css, cup, ad, &tip, PARTIAL); 00949 if (ret != 0) goto done; 00950 ad = ad + dimen[0].stride_mult; 00951 } 00952 } 00953 00954 if (ret != 0) goto done; 00955 00956 if (nd == 1) goto done; 00957 addr += dimen[1].stride_mult << bshft; 00958 } 00959 if (nd == 2) goto done; 00960 addr = addr2; 00961 addr += dimen[2].stride_mult << bshft; 00962 } 00963 if (nd == 3) goto done; 00964 addr = addr3; 00965 addr += dimen[3].stride_mult << bshft; 00966 } 00967 if (nd == 4) goto done; 00968 addr = addr4; 00969 addr += dimen[4].stride_mult << bshft; 00970 } 00971 if (nd == 5) goto done; 00972 addr = addr5; 00973 addr += dimen[5].stride_mult << bshft; 00974 } 00975 if (nd == 6) goto done; 00976 addr = addr6; 00977 addr += dimen[6].stride_mult << bshft; 00978 } 00979 } 00980 } 00981 00982 done: 00983 return(ret); 00984 } 00985 00986 /* 00987 * _map_to_dv 00988 * 00989 * Checks if a (possibly nested) implied do construct may be mapped 00990 * into a dopevector with optional array of dimension indices (one per 00991 * dimension). This function operates recursively. 00992 * 00993 * An implied do construct must meet all of the following criteria 00994 * to be mappable into an indexed dopevector: 00995 * 00996 * 1) It must contain only one nested iolist item which is a 00997 * dopevector or a nested implied do which maps to a 00998 * dopevector. 00999 * 2) A nested dopevector must be indexed by the loop variable 01000 * for the implied do in exactly one dimension. 01001 * 3) All dimensions of the nested dopevector after the 01002 * indexed dimension must be indexed or have an extent <= 1. 01003 * 4) The do variable for this implied do construct is not also 01004 * serving as the beginning count, ending count, or increment 01005 * for any nested implied do construct. 01006 * 01007 * Return Value 01008 * 0 if not successfully mapped to a dopevector. 01009 * 1 if successfully mapped to a dopevector. 01010 */ 01011 int 01012 _map_to_dv( 01013 ioimplieddo_entry *impdo, /* input impled do construct */ 01014 DopeVectorType *dvptr, /* output dopevector */ 01015 int **iarr, /* output list of array indexes */ 01016 struct dovarlist *dovlp) /* lists do variables for any higher */ /* level implied do constructs. */ 01017 { 01018 register short need_to_shift; 01019 register int i; 01020 register int ind_dim; 01021 register int ret; 01022 register long doinc; 01023 register long extent; 01024 register long adjust; 01025 struct DvDimen *dvdimen; 01026 struct DvDimen dvdim_tmp; 01027 iolist_header *nested_iolist; 01028 ioentry_header *nextioh; 01029 ioarray_entry *ae; 01030 01031 long _tripcnt(long beg, long end, long inc); 01032 01033 nested_iolist = (iolist_header *)(impdo + 1); 01034 01035 if (nested_iolist->icount != 1) 01036 return(0); /* must have exactly 1 iolist item */ 01037 01038 for (i = 0; i < dovlp->nvar; i++) { 01039 01040 if (DEBUG_90IO) { 01041 DD; fprintf(_df,"compare loopvar addr %lo to %lo %lo %lo\n", 01042 (long)dovlp->dov[i], (long)impdo->iobegcnt, 01043 (long)impdo->ioendcnt, (long)impdo->ioinccnt); 01044 } 01045 01046 if ( (impdo->iobegcnt == dovlp->dov[i]) || 01047 (impdo->ioendcnt == dovlp->dov[i]) || 01048 (impdo->ioinccnt == dovlp->dov[i]) ) 01049 return(0); /* do var is also a beg, end, or inc */ 01050 } 01051 01052 if (DEBUG_90IO) { 01053 DD; fprintf(_df,"Making recursive _map_to_dv check\n"); 01054 } 01055 01056 nextioh = (ioentry_header *)(nested_iolist + 1); 01057 01058 switch (nextioh->valtype) { 01059 01060 default: 01061 return(0); 01062 01063 case IO_LOOP: 01064 01065 /* 01066 * Store the addr of this nest level's implied do variable 01067 * in the list. The recursive calls will compare the 01068 * begin, end, and increment to this variable to ensure 01069 * that they are not the same. 01070 */ 01071 dovlp->nvar++; 01072 if (dovlp->nvar > MAXDOVAR) 01073 return(0); /* nested too deeply, give up */ 01074 dovlp->dov[ dovlp->nvar-1 ] = impdo->ioloopvar; 01075 01076 /* recursive call to check nested implied do */ 01077 ret = _map_to_dv( (ioimplieddo_entry *)(nextioh + 1), 01078 dvptr, 01079 iarr, 01080 dovlp); 01081 if (ret == 0) 01082 return(0); /* nested implied do not mappable */ 01083 break; 01084 01085 case IO_DOPEVEC: 01086 ae = (ioarray_entry *)(nextioh + 1); 01087 01088 /* copy the dopevector */ 01089 *dvptr = *(ae->dv); 01090 01091 if (ae->indflag == 0) 01092 return(0); /* dopevector is not indexed */ 01093 01094 /* copy the index array */ 01095 for (i = 0; i < dvptr->n_dim; i++) 01096 iarr[i] = ae->dovar[i]; 01097 01098 break; 01099 } 01100 01101 dvdimen = dvptr->dimension; 01102 /* 01103 * Search for dimensions indexed by the do variable. 01104 */ 01105 ind_dim = -1; /* indicate no dimension indexed by do variable */ 01106 01107 for (i = 0; i < dvptr->n_dim; i++) 01108 if (iarr[i] == impdo->ioloopvar) { 01109 ind_dim = i; 01110 break; 01111 } 01112 01113 if (ind_dim == -1) 01114 return(0); /* not indexed by loop variable */ 01115 01116 if (DEBUG_90IO) { 01117 DD; fprintf(_df,"Dim %d indexed by impdo\n", ind_dim); 01118 } 01119 01120 /* 01121 * Check that the dimensions after the indexed dimension satisfy necessary 01122 * condition that the dopevector storage order be the same as the 01123 * implied do storage order. 01124 */ 01125 need_to_shift = 0; 01126 01127 for (i = ind_dim+1; i < dvptr->n_dim; i++) { 01128 /* 01129 * If the do variable indexes more than one dimension, we 01130 * can sometimes handle it by adding together the stride 01131 * mults for all indexed dimensions, essentially merging the 01132 * two dimensions. 01133 */ 01134 if (iarr[i] == impdo->ioloopvar) { 01135 01136 if (DEBUG_90IO) { 01137 DD; fprintf(_df,"Dim %d also indexed by impdo\n",i); 01138 } 01139 01140 if (dvdimen[i].low_bound != dvdimen[ind_dim].low_bound) 01141 return(0); /* cannot fold if low_bound's differ */ 01142 01143 dvdimen[i].stride_mult += dvdimen[ind_dim].stride_mult; 01144 01145 /* 01146 * Setting extent to 1 allows stride_dv to later 01147 * collapse away this dimension. 01148 */ 01149 dvdimen[ind_dim].extent = 1; 01150 iarr[ind_dim] = NULL; 01151 01152 ind_dim = i; /* replace ind_dim */ 01153 need_to_shift = 0; 01154 } 01155 else if (iarr[i] == NULL && dvdimen[i].extent > 1) 01156 need_to_shift = 1; 01157 } 01158 01159 /* 01160 * Ensure that the implied do construct and the dopevector to 01161 * which it is mapped have the same storage order. This is done 01162 * by ensuring that "ind_dim" is after any unindexed dimension of 01163 * size > 1. The indexed dimension must be the slowest moving. 01164 */ 01165 if (need_to_shift) { 01166 dvdim_tmp = dvdimen[ind_dim]; 01167 for (i = ind_dim; i < dvptr->n_dim-1; i++) { 01168 dvdimen[i] = dvdimen[i+1]; 01169 iarr[i] = iarr[i+1]; 01170 } 01171 ind_dim = i; 01172 01173 /* slowest moving dimentsion moves with the implied do */ 01174 dvdimen[ind_dim] = dvdim_tmp; 01175 } 01176 01177 /* 01178 * Remove the indexing of the do-loop-indexed dimension. 01179 */ 01180 iarr[ind_dim] = NULL; 01181 01182 doinc = *impdo->ioinccnt; 01183 01184 adjust = (*impdo->iobegcnt - dvdimen[ind_dim].low_bound) * 01185 dvdimen[ind_dim].stride_mult; 01186 01187 extent = _tripcnt(*impdo->iobegcnt, *impdo->ioendcnt, doinc); 01188 01189 /* 01190 * Fold the do loop info into the corresponding dimension information. 01191 */ 01192 dvdimen[ind_dim].extent = extent; 01193 dvdimen[ind_dim].stride_mult *= doinc; 01194 01195 if (dvptr->type_lens.type == DVTYPE_ASCII) { 01196 _fcd f; 01197 int flen; 01198 01199 f = dvptr->base_addr.charptr; 01200 flen = _fcdlen(f); 01201 dvptr->base_addr.charptr = _cptofcd(_fcdtocp(f) + adjust, flen); 01202 } 01203 else { 01204 01205 /* bshft is 0 iff element size is sizeof(bcont) */ 01206 int bshft = SMSHIFT(dvptr); 01207 dvptr->base_addr.a.ptr = (bcont *)dvptr->base_addr.a.ptr + 01208 (adjust << bshft); 01209 01210 /* The -1 is not be possible but check for it */ 01211 assert( SMSHIFT(dvptr) != -1); 01212 } 01213 01214 /* 01215 * Update the loop variable. 01216 */ 01217 *impdo->ioloopvar = *impdo->iobegcnt + extent * doinc; 01218 01219 return(1); /* indicate that the mapping to dv succeeded */ 01220 } 01221 01222 /* 01223 * _tripcnt 01224 * 01225 * Returns the do loop trip count. 01226 */ 01227 long 01228 _tripcnt(long beg, long end, long inc) 01229 { 01230 register long tc; 01231 01232 if (inc < 0) { /* must negate for ANSI C to divide correctly */ 01233 beg = -beg; 01234 end = -end; 01235 inc = -inc; 01236 } 01237 01238 tc = (end - beg + inc) / inc; 01239 01240 if (tc < 0) 01241 tc = 0; 01242 01243 return(tc); 01244 } 01245 01246 typedef struct strideloop { 01247 01248 void *saddr; /* starting address */ 01249 01250 long binc; /* stride in bytes. This is the stride 01251 * between elements of the current 01252 * array between two iterations of the 01253 * implied do loop. */ 01254 01255 long inc; /* stride in elements (invalid if elstr == 0) */ 01256 01257 int elstr; /* 1 iff (binc % elsize == 0) */ 01258 01259 } strideloop_t; 01260 01261 /* 01262 * _strip_mine 01263 * 01264 * Tries to handle an implied do construct by strip mining. This is done 01265 * only if: 01266 * 01267 * 1) The implied do loop contains MAXITEMS or less. 01268 * 2) Each item in the implied do loop is a scalar or 01269 * a dopevector which represents one array element or 01270 * one contiguous array element. 01271 * 3) Each item is the same noncharacter type and kind. 01272 * 01273 * Return Value 01274 * 0 if we could not strip mine this implied do loop 01275 * 1 if we strip mined it; *retp contains err/end/ok status. 01276 */ 01277 01278 #define MAXITEMS 32 /* max items allowed inside implied do loop */ 01279 01280 int 01281 _strip_mine( 01282 FIOSPTR css, 01283 unit *cup, 01284 xfer_func *func, 01285 ioimplieddo_entry *impdo, 01286 int *retp) 01287 { 01288 register short reading; 01289 register short sametp; 01290 register int bshft; 01291 register int ioitems; 01292 register int item; 01293 register long badjust; 01294 register long begcnt; 01295 register long bytes_per_trip; 01296 register long endcnt; 01297 register long dotrips; 01298 register long ib; 01299 register long loopinc; 01300 register long trips_per_buf; 01301 long stride; 01302 long inc; 01303 int *loopvar; 01304 int **indarray; 01305 void *nexte; 01306 bcont *addr; 01307 long locbuf[CHBUFSIZE/sizeof(long)]; 01308 char *lbptr; /* points into locbuf */ 01309 type_packet tip; /* Type information packet */ 01310 iolist_header *iolist; 01311 strideloop_t slt[MAXITEMS]; 01312 struct DvDimen *dimen; 01313 ioentry_header *nextioh; 01314 f90_type_t ts, curts; 01315 01316 *retp = 0; 01317 reading = !(cup->uwrt); 01318 01319 if (DEBUG_90IO) { 01320 DD; putc('\n',_df); 01321 DD; fprintf(_df,"Enter _strip_mine\n"); 01322 } 01323 01324 /* 01325 * We don't strip mine list-directed reads because they might not 01326 * deliver all the data requested if a record is terminated by a /. 01327 */ 01328 if (func == _ld_read) 01329 return(0); 01330 01331 loopinc = *impdo->ioinccnt; 01332 loopvar = impdo->ioloopvar; 01333 begcnt = *impdo->iobegcnt; 01334 endcnt = *impdo->ioendcnt; 01335 01336 *loopvar = begcnt; 01337 01338 if (loopinc == 0) { 01339 *retp = FEINCZER; /* infinite loop detected */ 01340 return(1); 01341 } 01342 01343 iolist = (iolist_header *) (impdo + 1); 01344 ioitems = iolist->icount; 01345 01346 if (ioitems > MAXITEMS) 01347 return(0); /* exceeds arbitrary limit */ 01348 01349 sametp = 1; 01350 nextioh = (ioentry_header *)(iolist + 1); 01351 01352 tip.type77 = -1; 01353 tip.cnvindx = 0; 01354 tip.count = 1; 01355 tip.stride = 1; 01356 /* 01357 * This loop builds up the "stp" array of structures which record the 01358 * small amount of relevant information (striding, size, address) for 01359 * each iolist item within the implied do loop. 01360 */ 01361 for (item = 0; item < ioitems; item++) { 01362 register int i; 01363 register short n_dim; 01364 ioscalar_entry *se; 01365 ioarray_entry *ae; 01366 DopeVectorType *dv; 01367 01368 nexte = nextioh + 1; 01369 01370 if (nextioh->valtype == IO_SCALAR) { 01371 se = nexte; 01372 curts = se->tinfo; 01373 } 01374 else if (nextioh->valtype == IO_DOPEVEC) { 01375 ae = nexte; 01376 dv = ae->dv; 01377 curts = dv->type_lens; 01378 } 01379 else 01380 return(0); 01381 01382 tip.type90 = curts.type; 01383 01384 if (DEBUG_90IO) { 01385 DD; putc('\n',_df); 01386 DD; fprintf(_df,"%s, type90=%d\n", 01387 ((nextioh->valtype == IO_SCALAR) ? 01388 "IO_SCALAR" : "IO_DOPEVEC"), tip.type90); 01389 } 01390 01391 if (tip.type90 == DVTYPE_ASCII) 01392 return(0); /* We don't strip mine characters */ 01393 01394 if (item == 0) { 01395 ts = curts; 01396 tip.intlen = ts.int_len; 01397 tip.elsize = ts.int_len >> 3; 01398 } 01399 else { 01400 if (curts.int_len != ts.int_len) 01401 return(0); /* not all same size */ 01402 if (memcmp(&curts, &ts, sizeof(ts))) 01403 sametp = 0; /* not all same type */ 01404 } 01405 01406 /* 01407 * Do different stuff for scalars or dopevectors. 01408 */ 01409 switch (nextioh->valtype) { 01410 01411 case IO_SCALAR: 01412 01413 slt[item].saddr = se->iovar_address.v; 01414 slt[item].binc = 0; 01415 slt[item].inc = 0; 01416 slt[item].elstr = 1; 01417 01418 break; 01419 01420 case IO_DOPEVEC: 01421 01422 indarray = NULL; 01423 01424 if (ae->indflag) 01425 indarray = ae->dovar; 01426 01427 n_dim = dv->n_dim; 01428 dimen = dv->dimension; 01429 01430 badjust = 0; 01431 stride = 0; 01432 01433 for (i = 0; i < n_dim; i++) { 01434 if (indarray != NULL && indarray[i] != NULL) { 01435 badjust += (*indarray[i] - dimen[i].low_bound) * 01436 dimen[i].stride_mult; 01437 if (indarray[i] == loopvar) { 01438 stride += loopinc*dimen[i].stride_mult; 01439 } 01440 } 01441 else { 01442 if (dimen[i].extent > 1) 01443 return(0); /* no sections allowed*/ 01444 } 01445 } 01446 01447 stride = stride * (signed)SMSCALE(dv); 01448 01449 /* The -1 should not be possible but check for it */ 01450 01451 assert( SMSHIFT(dv) != -1); 01452 01453 bshft = SMSHIFT(dv); 01454 addr = (bcont *)dv->base_addr.a.ptr + (badjust << bshft); 01455 01456 slt[item].saddr = addr; 01457 slt[item].binc = stride; 01458 slt[item].inc = stride / tip.elsize; 01459 slt[item].elstr = (stride % tip.elsize == 0); 01460 01461 break; 01462 01463 default: 01464 01465 return(0); /* nested impdo's not supported */ 01466 01467 } /* switch */ 01468 01469 nextioh = (ioentry_header *)((long *)nextioh + 01470 nextioh->ioentsize); 01471 } /* for */ 01472 01473 dotrips = _tripcnt(begcnt, endcnt, loopinc); 01474 bytes_per_trip = tip.elsize * ioitems; /* bytes */ 01475 trips_per_buf = CHBUFSIZE/bytes_per_trip; /* trips per buffer */ 01476 01477 if (trips_per_buf > dotrips) 01478 trips_per_buf = dotrips; 01479 01480 if (trips_per_buf == 0) 01481 return(0); /* too many items inside implied do */ 01482 01483 if ( !(cup->ufmt) ) { /* If unformatted */ 01484 #if NUMERIC_DATA_CONVERSION_ENABLED 01485 if (cup->unumcvrt || cup->ucharset) { 01486 01487 /* 01488 * All items must be the same type if doing data 01489 * conversion. 01490 */ 01491 if (!sametp) 01492 return(0); 01493 01494 *retp = _get_dc_param(css, cup, ts, &tip); 01495 01496 if (*retp != 0) 01497 return(1); 01498 } 01499 #endif 01500 } 01501 else { 01502 /* 01503 * All items must be the same type if doing formatted 01504 * or list-directed I/O. 01505 */ 01506 if (!sametp) 01507 return(0); 01508 } 01509 01510 /* 01511 * This loop iterates through the "stp" array of iolist items, transfering 01512 * data between the iolist items and the packing buffer and issuing 01513 * lower level I/O requests with buffers full of contiguous data. 01514 */ 01515 for (ib = 0; ib < dotrips; ib += trips_per_buf) { 01516 register long t; 01517 01518 if (trips_per_buf > dotrips - ib) 01519 trips_per_buf = dotrips - ib; 01520 01521 tip.count = ioitems * trips_per_buf; 01522 01523 if (reading) { /* If reading */ 01524 01525 /* 01526 * Fill up locbuf with data from a call to the func 01527 * read routine. Then distribute the data to all the 01528 * iolist items in the implied do. 01529 */ 01530 01531 *retp = func(css, cup, locbuf, &tip, PARTIAL); 01532 } 01533 01534 /* 01535 * Assume that loopvar is one word on all supported 01536 * architecurs. 01537 */ 01538 assert ( sizeof(*loopvar) == sizeof(_f_int) ); 01539 01540 for (item = 0; item < ioitems; item++) { 01541 01542 if (slt[item].elstr && tip.elsize == sizeof(int)) { 01543 01544 int *wptr; 01545 int *wbuf = (int *)locbuf; 01546 01547 inc = slt[item].inc; 01548 wptr = ((int *)slt[item].saddr) + ib * inc; 01549 01550 if (reading) { /* If reading */ 01551 #ifdef _CRAY1 01552 #pragma _CRI ivdep 01553 #endif 01554 for (t = 0; t < trips_per_buf; t++) 01555 wptr[t * inc] = wbuf[item + t*ioitems]; 01556 } 01557 else { 01558 /* 01559 * Special case when the loop variable is being 01560 * printed (this cannot occur on input). 01561 */ 01562 if (wptr == (int *)loopvar) { 01563 for (t = 0; t < trips_per_buf; t++) { 01564 wbuf[item + t * ioitems] = 01565 *loopvar + loopinc * t; 01566 } 01567 } 01568 else { 01569 #ifdef _CRAY1 01570 #pragma _CRI ivdep 01571 #endif 01572 for (t = 0; t < trips_per_buf; t++) 01573 wbuf[item + t * ioitems] = wptr[t * inc]; 01574 } 01575 } 01576 } 01577 else { 01578 char *dptr; 01579 register long binc; 01580 01581 binc = slt[item].binc; 01582 lbptr = (char *)locbuf + tip.elsize * item; 01583 dptr = ((char *)slt[item].saddr) + ib * slt[item].binc; 01584 01585 for (t = 0; t < trips_per_buf; t++) { 01586 01587 if (reading) 01588 (void) memcpy(dptr, lbptr, tip.elsize); 01589 else 01590 (void) memcpy(lbptr, dptr, tip.elsize); 01591 01592 dptr += binc; 01593 lbptr += ioitems * tip.elsize; 01594 } 01595 } 01596 } 01597 01598 if (!reading) { /* If writing */ 01599 01600 /* 01601 * Now write out the data buffered in locbuf. 01602 */ 01603 01604 *retp = func(css, cup, locbuf, &tip, PARTIAL); 01605 } 01606 01607 *loopvar += loopinc * trips_per_buf; 01608 01609 if (*retp != 0) 01610 return(1); /* error/end/eor condition */ 01611 } 01612 01613 return(1); 01614 }