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 #pragma ident "@(#) libf/fio/write.c 92.2 06/21/99 10:37:55" 00039 00040 /* 00041 * write words 00042 */ 00043 00044 #include <errno.h> 00045 #include <foreign.h> 00046 #include <fortran.h> 00047 #include <liberrno.h> 00048 #include "fio.h" 00049 00050 #define UBC 4 /* argument number for optional ubc parameter */ 00051 #define STATUS 5 /* argument number for optional status parameter */ 00052 00053 #undef WRITE 00054 00055 static void __WRITE(); 00056 00057 /* 00058 * Write words, full record mode 00059 */ 00060 00061 _f_int 00062 WRITE( 00063 _f_int *unump, 00064 _f_int *uda, 00065 _f_int *wordsp, 00066 _f_int *ubc, 00067 _f_int *status) 00068 { 00069 _f_int locubc, *ubcp; 00070 _f_int *statp; 00071 00072 if (_numargs() < UBC) { 00073 locubc = 0; 00074 ubcp = &locubc; 00075 } 00076 else 00077 ubcp = ubc; 00078 00079 statp = (_numargs() < STATUS) ? NULL : status; 00080 00081 __WRITE(FULL, unump, uda, wordsp, ubcp, statp); 00082 00083 return(0); 00084 } 00085 00086 /* 00087 * Write words, partial record mode 00088 */ 00089 00090 void 00091 WRITEP( 00092 _f_int *unump, 00093 _f_int *uda, 00094 _f_int *wordsp, 00095 _f_int *ubc, 00096 _f_int *status) 00097 { 00098 _f_int locubc, *ubcp; 00099 _f_int *statp; 00100 00101 if (_numargs() < UBC) { 00102 locubc = 0; 00103 ubcp = &locubc; 00104 } 00105 else 00106 ubcp = ubc; 00107 00108 statp = (_numargs() < STATUS) ? NULL : status; 00109 00110 __WRITE(PARTIAL, unump, uda, wordsp, ubcp, statp); 00111 00112 return; 00113 } 00114 00115 static void 00116 __WRITE( 00117 int fulp, 00118 _f_int *unump, 00119 _f_int *uda, 00120 _f_int *wordsp, 00121 _f_int *ubc, 00122 _f_int *status) 00123 { 00124 register int ret; 00125 register int errn; 00126 int wstat; 00127 int wubc; 00128 register unum_t unum; 00129 unit *cup; 00130 type_packet tip; 00131 struct fiostate cfs; 00132 00133 unum = *unump; 00134 wubc = *ubc; 00135 errn = 0; 00136 00137 STMT_BEGIN(unum, 0, T_WSU, NULL, &cfs, cup); 00138 /* 00139 * If not connected, do an implicit open. 00140 */ 00141 if (cup == NULL) { 00142 int ostat; 00143 00144 cup = _imp_open(&cfs, SEQ, UNF, unum, (status != NULL), 00145 &ostat); 00146 00147 if (cup == NULL) { 00148 errn = ostat; 00149 goto done; 00150 } 00151 } 00152 00153 if (!cup->ok_wr_seq_unf) { 00154 errn = _get_mismatch_error(1, T_WSU, cup, &cfs); 00155 goto done; 00156 } 00157 00158 cup->uwrt = 1; 00159 00160 if (cup->uend) { 00161 /* 00162 * If positioned after an endfile, and the file does not 00163 * support multiple endfiles, a write is invalid. 00164 */ 00165 if (!cup->umultfil && !cup->uspcproc) { 00166 errn = FEWRAFEN; 00167 goto done; 00168 } 00169 /* 00170 * If a logical endfile record had just been read, 00171 * replace it with a physical endfile record before 00172 * starting the current data record. 00173 */ 00174 if ((cup->uend == LOGICAL_ENDFILE) && !(cup->uspcproc)) { 00175 if (XRCALL(cup->ufp.fdc, weofrtn)cup->ufp.fdc, 00176 &cup->uffsw) < 0) { 00177 errn = cup->uffsw.sw_error; 00178 goto done; 00179 } 00180 } 00181 cup->uend = BEFORE_ENDFILE; 00182 } 00183 00184 tip.type90 = DVTYPE_TYPELESS; 00185 tip.type77 = -1; 00186 tip.intlen = sizeof(long) << 3; 00187 tip.extlen = tip.intlen; 00188 tip.elsize = sizeof(long); 00189 tip.cnvindx = 0; 00190 tip.count = *wordsp; 00191 tip.stride = 1; 00192 00193 ret = _fwwd(cup, uda, &tip, fulp, &wubc, (long *) NULL, &wstat); 00194 00195 if ( ret == IOERR ) { 00196 errn = errno; 00197 goto done; 00198 } 00199 00200 if (status != NULL) 00201 *status = 0; 00202 00203 done: 00204 if (errn != 0) { 00205 if (status == NULL) 00206 _ferr(&cfs, errn); 00207 else 00208 *status = errn; 00209 } 00210 00211 *ubc = wubc; 00212 00213 STMT_END(cup, TF_WRITE, NULL, &cfs); 00214 00215 return; 00216 }