SCM

SCM Repository

[matrix] Annotation of /branches/Matrix-mer2/src/iohb.c
ViewVC logotype

Annotation of /branches/Matrix-mer2/src/iohb.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 985 - (view) (download) (as text)

1 : bates 825 /*
2 :     Fri Aug 15 16:29:47 EDT 1997
3 :    
4 :     Harwell-Boeing File I/O in C
5 :     V. 1.0
6 :    
7 :     National Institute of Standards and Technology, MD.
8 :     K.A. Remington
9 :    
10 :     ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
11 :     NOTICE
12 :    
13 :     Permission to use, copy, modify, and distribute this software and
14 :     its documentation for any purpose and without fee is hereby granted
15 :     provided that the above copyright notice appear in all copies and
16 :     that both the copyright notice and this permission notice appear in
17 :     supporting documentation.
18 :    
19 :     Neither the Author nor the Institution (National Institute of Standards
20 :     and Technology) make any representations about the suitability of this
21 :     software for any purpose. This software is provided "as is" without
22 :     expressed or implied warranty.
23 :     ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
24 :    
25 :     ---------------------
26 :     INTERFACE DESCRIPTION
27 :     ---------------------
28 :     ---------------
29 :     QUERY FUNCTIONS
30 :     ---------------
31 :    
32 :     FUNCTION:
33 :    
34 :     int readHB_info(const char *filename, int *M, int *N, int *nz,
35 :     char **Type, int *Nrhs)
36 :    
37 :     DESCRIPTION:
38 :    
39 :     The readHB_info function opens and reads the header information from
40 :     the specified Harwell-Boeing file, and reports back the number of rows
41 :     and columns in the stored matrix (M and N), the number of nonzeros in
42 :     the matrix (nz), the 3-character matrix type(Type), and the number of
43 :     right-hand-sides stored along with the matrix (Nrhs). This function
44 :     is designed to retrieve basic size information which can be used to
45 :     allocate arrays.
46 :    
47 :     FUNCTION:
48 :    
49 :     int readHB_header(FILE* in_file, char* Title, char* Key, char* Type,
50 :     int* Nrow, int* Ncol, int* Nnzero, int* Nrhs,
51 :     char* Ptrfmt, char* Indfmt, char* Valfmt, char* Rhsfmt,
52 :     int* Ptrcrd, int* Indcrd, int* Valcrd, int* Rhscrd,
53 :     char *Rhstype)
54 :    
55 :     DESCRIPTION:
56 :    
57 :     More detailed than the readHB_info function, readHB_header() reads from
58 :     the specified Harwell-Boeing file all of the header information.
59 :    
60 :    
61 :     ------------------------------
62 :     DOUBLE PRECISION I/O FUNCTIONS
63 :     ------------------------------
64 :     FUNCTION:
65 :    
66 :     int readHB_newmat_double(const char *filename, int *M, int *N, *int nz,
67 :     int **colptr, int **rowind, double**val)
68 :    
69 :     int readHB_mat_double(const char *filename, int *colptr, int *rowind,
70 :     double*val)
71 :    
72 :    
73 :     DESCRIPTION:
74 :    
75 :     This function opens and reads the specified file, interpreting its
76 :     contents as a sparse matrix stored in the Harwell/Boeing standard
77 :     format. (See readHB_aux_double to read auxillary vectors.)
78 :     -- Values are interpreted as double precision numbers. --
79 :    
80 :     The "mat" function uses _pre-allocated_ vectors to hold the index and
81 :     nonzero value information.
82 :    
83 :     The "newmat" function allocates vectors to hold the index and nonzero
84 :     value information, and returns pointers to these vectors along with
85 :     matrix dimension and number of nonzeros.
86 :    
87 :     FUNCTION:
88 :    
89 :     int readHB_aux_double(const char* filename, const char AuxType, double b[])
90 :    
91 :     int readHB_newaux_double(const char* filename, const char AuxType, double** b)
92 :    
93 :     DESCRIPTION:
94 :    
95 :     This function opens and reads from the specified file auxillary vector(s).
96 :     The char argument Auxtype determines which type of auxillary vector(s)
97 :     will be read (if present in the file).
98 :    
99 :     AuxType = 'F' right-hand-side
100 :     AuxType = 'G' initial estimate (Guess)
101 :     AuxType = 'X' eXact solution
102 :    
103 :     If Nrhs > 1, all of the Nrhs vectors of the given type are read and
104 :     stored in column-major order in the vector b.
105 :    
106 :     The "newaux" function allocates a vector to hold the values retrieved.
107 :     The "mat" function uses a _pre-allocated_ vector to hold the values.
108 :    
109 :     FUNCTION:
110 :    
111 :     int writeHB_mat_double(const char* filename, int M, int N,
112 :     int nz, const int colptr[], const int rowind[],
113 :     const double val[], int Nrhs, const double rhs[],
114 :     const double guess[], const double exact[],
115 :     const char* Title, const char* Key, const char* Type,
116 :     char* Ptrfmt, char* Indfmt, char* Valfmt, char* Rhsfmt,
117 :     const char* Rhstype)
118 :    
119 :     DESCRIPTION:
120 :    
121 :     The writeHB_mat_double function opens the named file and writes the specified
122 :     matrix and optional auxillary vector(s) to that file in Harwell-Boeing
123 :     format. The format arguments (Ptrfmt,Indfmt,Valfmt, and Rhsfmt) are
124 :     character strings specifying "Fortran-style" output formats -- as they
125 :     would appear in a Harwell-Boeing file. They are used to produce output
126 :     which is as close as possible to what would be produced by Fortran code,
127 :     but note that "D" and "P" edit descriptors are not supported.
128 :     If NULL, the following defaults will be used:
129 :     Ptrfmt = Indfmt = "(8I10)"
130 :     Valfmt = Rhsfmt = "(4E20.13)"
131 :    
132 :     -----------------------
133 :     CHARACTER I/O FUNCTIONS
134 :     -----------------------
135 :     FUNCTION:
136 :    
137 :     int readHB_mat_char(const char* filename, int colptr[], int rowind[],
138 :     char val[], char* Valfmt)
139 :     int readHB_newmat_char(const char* filename, int* M, int* N, int* nonzeros,
140 :     int** colptr, int** rowind, char** val, char** Valfmt)
141 :    
142 :     DESCRIPTION:
143 :    
144 :     This function opens and reads the specified file, interpreting its
145 :     contents as a sparse matrix stored in the Harwell/Boeing standard
146 :     format. (See readHB_aux_char to read auxillary vectors.)
147 :     -- Values are interpreted as char strings. --
148 :     (Used to translate exact values from the file into a new storage format.)
149 :    
150 :     The "mat" function uses _pre-allocated_ arrays to hold the index and
151 :     nonzero value information.
152 :    
153 :     The "newmat" function allocates char arrays to hold the index
154 :     and nonzero value information, and returns pointers to these arrays
155 :     along with matrix dimension and number of nonzeros.
156 :    
157 :     FUNCTION:
158 :    
159 :     int readHB_aux_char(const char* filename, const char AuxType, char b[])
160 :     int readHB_newaux_char(const char* filename, const char AuxType, char** b,
161 :     char** Rhsfmt)
162 :    
163 :     DESCRIPTION:
164 :    
165 :     This function opens and reads from the specified file auxillary vector(s).
166 :     The char argument Auxtype determines which type of auxillary vector(s)
167 :     will be read (if present in the file).
168 :    
169 :     AuxType = 'F' right-hand-side
170 :     AuxType = 'G' initial estimate (Guess)
171 :     AuxType = 'X' eXact solution
172 :    
173 :     If Nrhs > 1, all of the Nrhs vectors of the given type are read and
174 :     stored in column-major order in the vector b.
175 :    
176 :     The "newaux" function allocates a character array to hold the values
177 :     retrieved.
178 :     The "mat" function uses a _pre-allocated_ array to hold the values.
179 :    
180 :     FUNCTION:
181 :    
182 :     int writeHB_mat_char(const char* filename, int M, int N,
183 :     int nz, const int colptr[], const int rowind[],
184 :     const char val[], int Nrhs, const char rhs[],
185 :     const char guess[], const char exact[],
186 :     const char* Title, const char* Key, const char* Type,
187 :     char* Ptrfmt, char* Indfmt, char* Valfmt, char* Rhsfmt,
188 :     const char* Rhstype)
189 :    
190 :     DESCRIPTION:
191 :    
192 :     The writeHB_mat_char function opens the named file and writes the specified
193 :     matrix and optional auxillary vector(s) to that file in Harwell-Boeing
194 :     format. The format arguments (Ptrfmt,Indfmt,Valfmt, and Rhsfmt) are
195 :     character strings specifying "Fortran-style" output formats -- as they
196 :     would appear in a Harwell-Boeing file. Valfmt and Rhsfmt must accurately
197 :     represent the character representation of the values stored in val[]
198 :     and rhs[].
199 :    
200 :     If NULL, the following defaults will be used for the integer vectors:
201 :     Ptrfmt = Indfmt = "(8I10)"
202 :     Valfmt = Rhsfmt = "(4E20.13)"
203 :    
204 :    
205 :     */
206 :    
207 :     /*---------------------------------------------------------------------*/
208 :     /* If zero-based indexing is desired, _SP_base should be set to 0 */
209 :     /* This will cause indices read from H-B files to be decremented by 1 */
210 :     /* and indices written to H-B files to be incremented by 1 */
211 :     /* <<< Standard usage is _SP_base = 1 >>> */
212 :     /* <<< Changed to _SP_base = 0 DMB 2005-08-06 >>> */
213 :     #ifndef _SP_base
214 :     #define _SP_base 0
215 :     #endif
216 :     /*---------------------------------------------------------------------*/
217 :    
218 :     #include "iohb.h"
219 : bates 840 #include <Rinternals.h>
220 : bates 825
221 : bates 840 void
222 :     IOHBTerminate(char* message)
223 :     {
224 :     error(message);
225 :     }
226 :    
227 :     static char*
228 :     substr(const char* S, const int pos, const int len)
229 :     {
230 :     int i;
231 :     char *SubS;
232 :    
233 :     if ( pos+len <= strlen(S)) {
234 :     SubS = (char *)malloc(len+1);
235 :     if ( SubS == NULL ) IOHBTerminate("Insufficient memory for SubS.");
236 :     for (i=0;i<len;i++) SubS[i] = S[pos+i];
237 :     SubS[len] = (char) NULL;
238 :     } else {
239 :     SubS = NULL;
240 :     }
241 :     return SubS;
242 :     }
243 :    
244 :     /**
245 :     * Convert string S to upper case
246 :     *
247 :     * @param S string to be converted
248 :     *
249 :     * @return S, after conversion
250 :     */
251 :     static char*
252 :     upcase(char* S)
253 :     {
254 :     int i, len = strlen(S);
255 :    
256 :     for (i = 0; i < len; i++) S[i] = toupper(S[i]);
257 :     return S;
258 :     }
259 :    
260 : bates 825 int readHB_info(const char* filename, int* M, int* N, int* nz, char** Type,
261 :     int* Nrhs)
262 :     {
263 :     /****************************************************************************/
264 :     /* The readHB_info function opens and reads the header information from */
265 :     /* the specified Harwell-Boeing file, and reports back the number of rows */
266 :     /* and columns in the stored matrix (M and N), the number of nonzeros in */
267 :     /* the matrix (nz), and the number of right-hand-sides stored along with */
268 :     /* the matrix (Nrhs). */
269 :     /* */
270 :     /* For a description of the Harwell Boeing standard, see: */
271 :     /* Duff, et al., ACM TOMS Vol.15, No.1, March 1989 */
272 :     /* */
273 :     /* ---------- */
274 :     /* **CAVEAT** */
275 :     /* ---------- */
276 :     /* ** If the input file does not adhere to the H/B format, the ** */
277 :     /* ** results will be unpredictable. ** */
278 :     /* */
279 :     /****************************************************************************/
280 :     FILE *in_file;
281 :     int Ptrcrd, Indcrd, Valcrd, Rhscrd;
282 :     int Nrow, Ncol, Nnzero;
283 :     char *mat_type;
284 :     char Title[73], Key[9], Rhstype[4];
285 :     char Ptrfmt[17], Indfmt[17], Valfmt[21], Rhsfmt[21];
286 :    
287 :     mat_type = (char *) malloc(4);
288 :     if ( mat_type == NULL ) IOHBTerminate("Insufficient memory for mat_typen");
289 :    
290 :     if ( (in_file = fopen( filename, "r")) == NULL ) {
291 :     fprintf(stderr,"Error: Cannot open file: %s\n",filename);
292 :     return 0;
293 :     }
294 :    
295 :     readHB_header(in_file, Title, Key, mat_type, &Nrow, &Ncol, &Nnzero, Nrhs,
296 :     Ptrfmt, Indfmt, Valfmt, Rhsfmt,
297 :     &Ptrcrd, &Indcrd, &Valcrd, &Rhscrd, Rhstype);
298 :     fclose(in_file);
299 :     *Type = mat_type;
300 :     *(*Type+3) = (char) NULL;
301 :     *M = Nrow;
302 :     *N = Ncol;
303 :     *nz = Nnzero;
304 :     if (Rhscrd == 0) {*Nrhs = 0;}
305 :    
306 :     /* In verbose mode, print some of the header information: */
307 :     /*
308 :     if (verbose == 1)
309 :     {
310 :     printf("Reading from Harwell-Boeing file %s (verbose on)...\n",filename);
311 :     printf(" Title: %s\n",Title);
312 :     printf(" Key: %s\n",Key);
313 :     printf(" The stored matrix is %i by %i with %i nonzeros.\n",
314 :     *M, *N, *nz );
315 :     printf(" %i right-hand--side(s) stored.\n",*Nrhs);
316 :     }
317 :     */
318 :    
319 :     return 1;
320 :    
321 :     }
322 :    
323 :     int readHB_header(FILE* in_file, char* Title, char* Key, char* Type,
324 :     int* Nrow, int* Ncol, int* Nnzero, int* Nrhs,
325 :     char* Ptrfmt, char* Indfmt, char* Valfmt, char* Rhsfmt,
326 :     int* Ptrcrd, int* Indcrd, int* Valcrd, int* Rhscrd,
327 :     char *Rhstype)
328 :     {
329 :     /*************************************************************************/
330 :     /* Read header information from the named H/B file... */
331 :     /*************************************************************************/
332 :     int Totcrd,Neltvl,Nrhsix;
333 :     char line[BUFSIZ];
334 :    
335 :     /* First line: */
336 :     fgets(line, BUFSIZ, in_file);
337 :     if ( sscanf(line,"%*s") < 0 )
338 :     IOHBTerminate("iohb.c: Null (or blank) first line of HB file.\n");
339 :     (void) sscanf(line, "%72c%8[^\n]", Title, Key);
340 :     *(Key+8) = (char) NULL;
341 :     *(Title+72) = (char) NULL;
342 :    
343 :     /* Second line: */
344 :     fgets(line, BUFSIZ, in_file);
345 :     if ( sscanf(line,"%*s") < 0 )
346 :     IOHBTerminate("iohb.c: Null (or blank) second line of HB file.\n");
347 :     if ( sscanf(line,"%i",&Totcrd) != 1) Totcrd = 0;
348 :     if ( sscanf(line,"%*i%i",Ptrcrd) != 1) *Ptrcrd = 0;
349 :     if ( sscanf(line,"%*i%*i%i",Indcrd) != 1) *Indcrd = 0;
350 :     if ( sscanf(line,"%*i%*i%*i%i",Valcrd) != 1) *Valcrd = 0;
351 :     if ( sscanf(line,"%*i%*i%*i%*i%i",Rhscrd) != 1) *Rhscrd = 0;
352 :    
353 :     /* Third line: */
354 :     fgets(line, BUFSIZ, in_file);
355 :     if ( sscanf(line,"%*s") < 0 )
356 :     IOHBTerminate("iohb.c: Null (or blank) third line of HB file.\n");
357 :     if ( sscanf(line, "%3c", Type) != 1)
358 :     IOHBTerminate("iohb.c: Invalid Type info, line 3 of Harwell-Boeing file.\n");
359 :     upcase(Type);
360 :     if ( sscanf(line,"%*3c%i",Nrow) != 1) *Nrow = 0 ;
361 :     if ( sscanf(line,"%*3c%*i%i",Ncol) != 1) *Ncol = 0 ;
362 :     if ( sscanf(line,"%*3c%*i%*i%i",Nnzero) != 1) *Nnzero = 0 ;
363 :     if ( sscanf(line,"%*3c%*i%*i%*i%i",&Neltvl) != 1) Neltvl = 0 ;
364 :    
365 :     /* Fourth line: */
366 :     fgets(line, BUFSIZ, in_file);
367 :     if ( sscanf(line,"%*s") < 0 )
368 :     IOHBTerminate("iohb.c: Null (or blank) fourth line of HB file.\n");
369 :     if ( sscanf(line, "%16c",Ptrfmt) != 1)
370 :     IOHBTerminate("iohb.c: Invalid format info, line 4 of Harwell-Boeing file.\n");
371 :     if ( sscanf(line, "%*16c%16c",Indfmt) != 1)
372 :     IOHBTerminate("iohb.c: Invalid format info, line 4 of Harwell-Boeing file.\n");
373 :     if ( sscanf(line, "%*16c%*16c%20c",Valfmt) != 1)
374 :     IOHBTerminate("iohb.c: Invalid format info, line 4 of Harwell-Boeing file.\n");
375 :     sscanf(line, "%*16c%*16c%*20c%20c",Rhsfmt);
376 :     *(Ptrfmt+16) = (char) NULL;
377 :     *(Indfmt+16) = (char) NULL;
378 :     *(Valfmt+20) = (char) NULL;
379 :     *(Rhsfmt+20) = (char) NULL;
380 :    
381 :     /* (Optional) Fifth line: */
382 :     if (*Rhscrd != 0 )
383 :     {
384 :     fgets(line, BUFSIZ, in_file);
385 :     if ( sscanf(line,"%*s") < 0 )
386 :     IOHBTerminate("iohb.c: Null (or blank) fifth line of HB file.\n");
387 :     if ( sscanf(line, "%3c", Rhstype) != 1)
388 :     IOHBTerminate("iohb.c: Invalid RHS type information, line 5 of Harwell-Boeing file.\n");
389 :     if ( sscanf(line, "%*3c%i", Nrhs) != 1) *Nrhs = 0;
390 :     if ( sscanf(line, "%*3c%*i%i", &Nrhsix) != 1) Nrhsix = 0;
391 :     }
392 :     return 1;
393 :     }
394 :    
395 :    
396 :     int readHB_mat_double(const char* filename, int colptr[], int rowind[],
397 :     double val[])
398 :     {
399 :     /****************************************************************************/
400 :     /* This function opens and reads the specified file, interpreting its */
401 :     /* contents as a sparse matrix stored in the Harwell/Boeing standard */
402 :     /* format and creating compressed column storage scheme vectors to hold */
403 :     /* the index and nonzero value information. */
404 :     /* */
405 :     /* ---------- */
406 :     /* **CAVEAT** */
407 :     /* ---------- */
408 :     /* Parsing real formats from Fortran is tricky, and this file reader */
409 :     /* does not claim to be foolproof. It has been tested for cases when */
410 :     /* the real values are printed consistently and evenly spaced on each */
411 :     /* line, with Fixed (F), and Exponential (E or D) formats. */
412 :     /* */
413 :     /* ** If the input file does not adhere to the H/B format, the ** */
414 :     /* ** results will be unpredictable. ** */
415 :     /* */
416 :     /****************************************************************************/
417 :     FILE *in_file;
418 :     int i,j,ind,col,offset,count,last,Nrhs;
419 :     int Ptrcrd, Indcrd, Valcrd, Rhscrd;
420 :     int Nrow, Ncol, Nnzero, Nentries;
421 :     int Ptrperline, Ptrwidth, Indperline, Indwidth;
422 :     int Valperline, Valwidth, Valprec;
423 :     int Valflag; /* Indicates 'E','D', or 'F' float format */
424 :     char* ThisElement;
425 :     char Title[73], Key[8], Type[4], Rhstype[4];
426 :     char Ptrfmt[17], Indfmt[17], Valfmt[21], Rhsfmt[21];
427 :     char line[BUFSIZ];
428 :    
429 :     if ( (in_file = fopen( filename, "r")) == NULL ) {
430 :     fprintf(stderr,"Error: Cannot open file: %s\n",filename);
431 :     return 0;
432 :     }
433 :    
434 :     readHB_header(in_file, Title, Key, Type, &Nrow, &Ncol, &Nnzero, &Nrhs,
435 :     Ptrfmt, Indfmt, Valfmt, Rhsfmt,
436 :     &Ptrcrd, &Indcrd, &Valcrd, &Rhscrd, Rhstype);
437 :    
438 :     /* Parse the array input formats from Line 3 of HB file */
439 :     ParseIfmt(Ptrfmt,&Ptrperline,&Ptrwidth);
440 :     ParseIfmt(Indfmt,&Indperline,&Indwidth);
441 :     if ( Type[0] != 'P' ) { /* Skip if pattern only */
442 :     ParseRfmt(Valfmt,&Valperline,&Valwidth,&Valprec,&Valflag);
443 :     }
444 :    
445 :     /* Read column pointer array: */
446 :    
447 :     offset = 1-_SP_base; /* if base 0 storage is declared (via macro definition), */
448 :     /* then storage entries are offset by 1 */
449 :    
450 :     ThisElement = (char *) malloc(Ptrwidth+1);
451 :     if ( ThisElement == NULL ) IOHBTerminate("Insufficient memory for ThisElement.");
452 :     *(ThisElement+Ptrwidth) = (char) NULL;
453 :     count=0;
454 :     for (i=0;i<Ptrcrd;i++)
455 :     {
456 :     fgets(line, BUFSIZ, in_file);
457 :     if ( sscanf(line,"%*s") < 0 )
458 :     IOHBTerminate("iohb.c: Null (or blank) line in pointer data region of HB file.\n");
459 :     col = 0;
460 :     for (ind = 0;ind<Ptrperline;ind++)
461 :     {
462 :     if (count > Ncol) break;
463 :     strncpy(ThisElement,line+col,Ptrwidth);
464 :     /* ThisElement = substr(line,col,Ptrwidth); */
465 :     colptr[count] = atoi(ThisElement)-offset;
466 :     count++; col += Ptrwidth;
467 :     }
468 :     }
469 :     free(ThisElement);
470 :    
471 :     /* Read row index array: */
472 :    
473 :     ThisElement = (char *) malloc(Indwidth+1);
474 :     if ( ThisElement == NULL ) IOHBTerminate("Insufficient memory for ThisElement.");
475 :     *(ThisElement+Indwidth) = (char) NULL;
476 :     count = 0;
477 :     for (i=0;i<Indcrd;i++)
478 :     {
479 :     fgets(line, BUFSIZ, in_file);
480 :     if ( sscanf(line,"%*s") < 0 )
481 :     IOHBTerminate("iohb.c: Null (or blank) line in index data region of HB file.\n");
482 :     col = 0;
483 :     for (ind = 0;ind<Indperline;ind++)
484 :     {
485 :     if (count == Nnzero) break;
486 :     strncpy(ThisElement,line+col,Indwidth);
487 :     /* ThisElement = substr(line,col,Indwidth); */
488 :     rowind[count] = atoi(ThisElement)-offset;
489 :     count++; col += Indwidth;
490 :     }
491 :     }
492 :     free(ThisElement);
493 :    
494 :     /* Read array of values: */
495 :    
496 :     if ( Type[0] != 'P' ) { /* Skip if pattern only */
497 :    
498 :     if ( Type[0] == 'C' ) Nentries = 2*Nnzero;
499 :     else Nentries = Nnzero;
500 :    
501 :     ThisElement = (char *) malloc(Valwidth+1);
502 :     if ( ThisElement == NULL ) IOHBTerminate("Insufficient memory for ThisElement.");
503 :     *(ThisElement+Valwidth) = (char) NULL;
504 :     count = 0;
505 :     for (i=0;i<Valcrd;i++)
506 :     {
507 :     fgets(line, BUFSIZ, in_file);
508 :     if ( sscanf(line,"%*s") < 0 )
509 :     IOHBTerminate("iohb.c: Null (or blank) line in value data region of HB file.\n");
510 :     if (Valflag == 'D') {
511 :     while( strchr(line,'D') ) *strchr(line,'D') = 'E';
512 :     /* *strchr(Valfmt,'D') = 'E'; */
513 :     }
514 :     col = 0;
515 :     for (ind = 0;ind<Valperline;ind++)
516 :     {
517 :     if (count == Nentries) break;
518 :     strncpy(ThisElement,line+col,Valwidth);
519 :     /*ThisElement = substr(line,col,Valwidth);*/
520 :     if ( Valflag != 'F' && strchr(ThisElement,'E') == NULL ) {
521 :     /* insert a char prefix for exp */
522 :     last = strlen(ThisElement);
523 :     for (j=last+1;j>=0;j--) {
524 :     ThisElement[j] = ThisElement[j-1];
525 :     if ( ThisElement[j] == '+' || ThisElement[j] == '-' ) {
526 :     ThisElement[j-1] = Valflag;
527 :     break;
528 :     }
529 :     }
530 :     }
531 :     val[count] = atof(ThisElement);
532 :     count++; col += Valwidth;
533 :     }
534 :     }
535 :     free(ThisElement);
536 :     }
537 :    
538 :     fclose(in_file);
539 :     return 1;
540 :     }
541 :    
542 :     int readHB_newmat_double(const char* filename, int* M, int* N, int* nonzeros,
543 :     int** colptr, int** rowind, double** val)
544 :     {
545 :     int Nrhs;
546 :     char *Type;
547 :    
548 :     readHB_info(filename, M, N, nonzeros, &Type, &Nrhs);
549 :    
550 :     *colptr = (int *)malloc((*N+1)*sizeof(int));
551 :     if ( *colptr == NULL ) IOHBTerminate("Insufficient memory for colptr.\n");
552 :     *rowind = (int *)malloc(*nonzeros*sizeof(int));
553 :     if ( *rowind == NULL ) IOHBTerminate("Insufficient memory for rowind.\n");
554 :     if ( Type[0] == 'C' ) {
555 :     /*
556 :     fprintf(stderr, "Warning: Reading complex data from HB file %s.\n",filename);
557 :     fprintf(stderr, " Real and imaginary parts will be interlaced in val[].\n");
558 :     */
559 :     /* Malloc enough space for real AND imaginary parts of val[] */
560 :     *val = (double *)malloc(*nonzeros*sizeof(double)*2);
561 :     if ( *val == NULL ) IOHBTerminate("Insufficient memory for val.\n");
562 :     } else {
563 :     if ( Type[0] != 'P' ) {
564 :     /* Malloc enough space for real array val[] */
565 :     *val = (double *)malloc(*nonzeros*sizeof(double));
566 :     if ( *val == NULL ) IOHBTerminate("Insufficient memory for val.\n");
567 :     }
568 :     } /* No val[] space needed if pattern only */
569 :     return readHB_mat_double(filename, *colptr, *rowind, *val);
570 :    
571 :     }
572 :    
573 :     int readHB_aux_double(const char* filename, const char AuxType, double b[])
574 :     {
575 :     /****************************************************************************/
576 :     /* This function opens and reads the specified file, placing auxillary */
577 :     /* vector(s) of the given type (if available) in b. */
578 :     /* Return value is the number of vectors successfully read. */
579 :     /* */
580 :     /* AuxType = 'F' full right-hand-side vector(s) */
581 :     /* AuxType = 'G' initial Guess vector(s) */
582 :     /* AuxType = 'X' eXact solution vector(s) */
583 :     /* */
584 :     /* ---------- */
585 :     /* **CAVEAT** */
586 :     /* ---------- */
587 :     /* Parsing real formats from Fortran is tricky, and this file reader */
588 :     /* does not claim to be foolproof. It has been tested for cases when */
589 :     /* the real values are printed consistently and evenly spaced on each */
590 :     /* line, with Fixed (F), and Exponential (E or D) formats. */
591 :     /* */
592 :     /* ** If the input file does not adhere to the H/B format, the ** */
593 :     /* ** results will be unpredictable. ** */
594 :     /* */
595 :     /****************************************************************************/
596 :     FILE *in_file;
597 :     int i,j,n,maxcol,start,stride,col,last,linel;
598 :     int Ptrcrd, Indcrd, Valcrd, Rhscrd;
599 :     int Nrow, Ncol, Nnzero, Nentries;
600 :     int Nrhs, nvecs, rhsi;
601 :     int Rhsperline, Rhswidth, Rhsprec;
602 :     int Rhsflag;
603 :     char *ThisElement;
604 :     char Title[73], Key[9], Type[4], Rhstype[4];
605 :     char Ptrfmt[17], Indfmt[17], Valfmt[21], Rhsfmt[21];
606 :     char line[BUFSIZ];
607 :    
608 :     if ((in_file = fopen( filename, "r")) == NULL) {
609 :     fprintf(stderr,"Error: Cannot open file: %s\n",filename);
610 :     return 0;
611 :     }
612 :    
613 :     readHB_header(in_file, Title, Key, Type, &Nrow, &Ncol, &Nnzero, &Nrhs,
614 :     Ptrfmt, Indfmt, Valfmt, Rhsfmt,
615 :     &Ptrcrd, &Indcrd, &Valcrd, &Rhscrd, Rhstype);
616 :    
617 :     if (Nrhs <= 0)
618 :     {
619 :     fprintf(stderr, "Warn: Attempt to read auxillary vector(s) when none are present.\n");
620 :     return 0;
621 :     }
622 :     if (Rhstype[0] != 'F' )
623 :     {
624 :     fprintf(stderr,"Warn: Attempt to read auxillary vector(s) which are not stored in Full form.\n");
625 :     fprintf(stderr," Rhs must be specified as full. \n");
626 :     return 0;
627 :     }
628 :    
629 :     /* If reading complex data, allow for interleaved real and imaginary values. */
630 :     if ( Type[0] == 'C' ) {
631 :     Nentries = 2*Nrow;
632 :     } else {
633 :     Nentries = Nrow;
634 :     }
635 :    
636 :     nvecs = 1;
637 :    
638 :     if ( Rhstype[1] == 'G' ) nvecs++;
639 :     if ( Rhstype[2] == 'X' ) nvecs++;
640 :    
641 :     if ( AuxType == 'G' && Rhstype[1] != 'G' ) {
642 :     fprintf(stderr, "Warn: Attempt to read auxillary Guess vector(s) when none are present.\n");
643 :     return 0;
644 :     }
645 :     if ( AuxType == 'X' && Rhstype[2] != 'X' ) {
646 :     fprintf(stderr, "Warn: Attempt to read auxillary eXact solution vector(s) when none are present.\n");
647 :     return 0;
648 :     }
649 :    
650 :     ParseRfmt(Rhsfmt, &Rhsperline, &Rhswidth, &Rhsprec,&Rhsflag);
651 :     maxcol = Rhsperline*Rhswidth;
652 :    
653 :     /* Lines to skip before starting to read RHS values... */
654 :     n = Ptrcrd + Indcrd + Valcrd;
655 :    
656 :     for (i = 0; i < n; i++)
657 :     fgets(line, BUFSIZ, in_file);
658 :    
659 :     /* start - number of initial aux vector entries to skip */
660 :     /* to reach first vector requested */
661 :     /* stride - number of aux vector entries to skip between */
662 :     /* requested vectors */
663 :     if ( AuxType == 'F' ) start = 0;
664 :     else if ( AuxType == 'G' ) start = Nentries;
665 :     else start = (nvecs-1)*Nentries;
666 :     stride = (nvecs-1)*Nentries;
667 :    
668 :     fgets(line, BUFSIZ, in_file);
669 :     linel= strchr(line,'\n')-line;
670 :     col = 0;
671 :     /* Skip to initial offset */
672 :    
673 :     for (i=0;i<start;i++) {
674 :     if ( col >= ( maxcol<linel?maxcol:linel ) ) {
675 :     fgets(line, BUFSIZ, in_file);
676 :     linel= strchr(line,'\n')-line;
677 :     col = 0;
678 :     }
679 :     col += Rhswidth;
680 :     }
681 :     if (Rhsflag == 'D') {
682 :     while( strchr(line,'D') ) *strchr(line,'D') = 'E';
683 :     }
684 :    
685 :     /* Read a vector of desired type, then skip to next */
686 :     /* repeating to fill Nrhs vectors */
687 :    
688 :     ThisElement = (char *) malloc(Rhswidth+1);
689 :     if ( ThisElement == NULL ) IOHBTerminate("Insufficient memory for ThisElement.");
690 :     *(ThisElement+Rhswidth) = (char) NULL;
691 :     for (rhsi=0;rhsi<Nrhs;rhsi++) {
692 :    
693 :     for (i=0;i<Nentries;i++) {
694 :     if ( col >= ( maxcol<linel?maxcol:linel ) ) {
695 :     fgets(line, BUFSIZ, in_file);
696 :     linel= strchr(line,'\n')-line;
697 :     if (Rhsflag == 'D') {
698 :     while( strchr(line,'D') ) *strchr(line,'D') = 'E';
699 :     }
700 :     col = 0;
701 :     }
702 :     strncpy(ThisElement,line+col,Rhswidth);
703 :     /*ThisElement = substr(line, col, Rhswidth);*/
704 :     if ( Rhsflag != 'F' && strchr(ThisElement,'E') == NULL ) {
705 :     /* insert a char prefix for exp */
706 :     last = strlen(ThisElement);
707 :     for (j=last+1;j>=0;j--) {
708 :     ThisElement[j] = ThisElement[j-1];
709 :     if ( ThisElement[j] == '+' || ThisElement[j] == '-' ) {
710 :     ThisElement[j-1] = Rhsflag;
711 :     break;
712 :     }
713 :     }
714 :     }
715 :     b[i] = atof(ThisElement);
716 :     col += Rhswidth;
717 :     }
718 :    
719 :     /* Skip any interleaved Guess/eXact vectors */
720 :    
721 :     for (i=0;i<stride;i++) {
722 :     if ( col >= ( maxcol<linel?maxcol:linel ) ) {
723 :     fgets(line, BUFSIZ, in_file);
724 :     linel= strchr(line,'\n')-line;
725 :     col = 0;
726 :     }
727 :     col += Rhswidth;
728 :     }
729 :    
730 :     }
731 :     free(ThisElement);
732 :    
733 :    
734 :     fclose(in_file);
735 :     return Nrhs;
736 :     }
737 :    
738 :     int readHB_newaux_double(const char* filename, const char AuxType, double** b)
739 :     {
740 :     int Nrhs,M,N,nonzeros;
741 :     char *Type;
742 :    
743 :     readHB_info(filename, &M, &N, &nonzeros, &Type, &Nrhs);
744 :     if ( Nrhs <= 0 ) {
745 :     fprintf(stderr,"Warn: Requested read of aux vector(s) when none are present.\n");
746 :     return 0;
747 :     } else {
748 :     if ( Type[0] == 'C' ) {
749 :     fprintf(stderr, "Warning: Reading complex aux vector(s) from HB file %s.",filename);
750 :     fprintf(stderr, " Real and imaginary parts will be interlaced in b[].");
751 :     *b = (double *)malloc(M*Nrhs*sizeof(double)*2);
752 :     if ( *b == NULL ) IOHBTerminate("Insufficient memory for rhs.\n");
753 :     return readHB_aux_double(filename, AuxType, *b);
754 :     } else {
755 :     *b = (double *)malloc(M*Nrhs*sizeof(double));
756 :     if ( *b == NULL ) IOHBTerminate("Insufficient memory for rhs.\n");
757 :     return readHB_aux_double(filename, AuxType, *b);
758 :     }
759 :     }
760 :     }
761 :    
762 :     int writeHB_mat_double(const char* filename, int M, int N,
763 :     int nz, const int colptr[], const int rowind[],
764 :     const double val[], int Nrhs, const double rhs[],
765 :     const double guess[], const double exact[],
766 :     const char* Title, const char* Key, const char* Type,
767 :     char* Ptrfmt, char* Indfmt, char* Valfmt, char* Rhsfmt,
768 :     const char* Rhstype)
769 :     {
770 :     /****************************************************************************/
771 :     /* The writeHB function opens the named file and writes the specified */
772 :     /* matrix and optional right-hand-side(s) to that file in Harwell-Boeing */
773 :     /* format. */
774 :     /* */
775 :     /* For a description of the Harwell Boeing standard, see: */
776 :     /* Duff, et al., ACM TOMS Vol.15, No.1, March 1989 */
777 :     /* */
778 :     /****************************************************************************/
779 :     FILE *out_file;
780 :     int i,j,entry,offset,acount,linemod;
781 :     int totcrd, ptrcrd, indcrd, valcrd, rhscrd;
782 :     int nvalentries, nrhsentries;
783 :     int Ptrperline, Ptrwidth, Indperline, Indwidth;
784 :     int Rhsperline, Rhswidth, Rhsprec;
785 :     int Rhsflag;
786 :     int Valperline, Valwidth, Valprec;
787 :     int Valflag; /* Indicates 'E','D', or 'F' float format */
788 :     char pformat[16],iformat[16],vformat[19],rformat[19];
789 : bates 840 char diform[7] = "(8I10)", ddform[10] = "(4E20.13)";
790 : bates 825
791 :     if ( Type[0] == 'C' ) {
792 :     nvalentries = 2*nz;
793 :     nrhsentries = 2*M;
794 :     } else {
795 :     nvalentries = nz;
796 :     nrhsentries = M;
797 :     }
798 :    
799 :     if ( filename != NULL ) {
800 :     if ( (out_file = fopen( filename, "w")) == NULL ) {
801 :     fprintf(stderr,"Error: Cannot open file: %s\n",filename);
802 :     return 0;
803 :     }
804 :     } else out_file = stdout;
805 :    
806 : bates 840 if ( Ptrfmt == NULL ) Ptrfmt = diform;
807 : bates 825 ParseIfmt(Ptrfmt,&Ptrperline,&Ptrwidth);
808 :     sprintf(pformat,"%%%dd",Ptrwidth);
809 :     ptrcrd = (N+1)/Ptrperline;
810 :     if ( (N+1)%Ptrperline != 0) ptrcrd++;
811 :    
812 : bates 840 if ( Indfmt == NULL ) Indfmt = diform;
813 : bates 825 ParseIfmt(Indfmt,&Indperline,&Indwidth);
814 :     sprintf(iformat,"%%%dd",Indwidth);
815 :     indcrd = nz/Indperline;
816 :     if ( nz%Indperline != 0) indcrd++;
817 :    
818 :     if ( Type[0] != 'P' ) { /* Skip if pattern only */
819 : bates 840 if ( Valfmt == NULL ) Valfmt = ddform;
820 : bates 825 ParseRfmt(Valfmt,&Valperline,&Valwidth,&Valprec,&Valflag);
821 :     if (Valflag == 'D') *strchr(Valfmt,'D') = 'E';
822 :     if (Valflag == 'F')
823 :     sprintf(vformat,"%% %d.%df",Valwidth,Valprec);
824 :     else
825 :     sprintf(vformat,"%% %d.%dE",Valwidth,Valprec);
826 :     valcrd = nvalentries/Valperline;
827 :     if ( nvalentries%Valperline != 0) valcrd++;
828 :     } else valcrd = 0;
829 :    
830 :     if ( Nrhs > 0 ) {
831 : bates 840 if ( Rhsfmt == NULL ) Rhsfmt = ddform;
832 : bates 825 ParseRfmt(Rhsfmt,&Rhsperline,&Rhswidth,&Rhsprec, &Rhsflag);
833 :     if (Rhsflag == 'F')
834 :     sprintf(rformat,"%% %d.%df",Rhswidth,Rhsprec);
835 :     else
836 :     sprintf(rformat,"%% %d.%dE",Rhswidth,Rhsprec);
837 :     if (Rhsflag == 'D') *strchr(Rhsfmt,'D') = 'E';
838 :     rhscrd = nrhsentries/Rhsperline;
839 :     if ( nrhsentries%Rhsperline != 0) rhscrd++;
840 :     if ( Rhstype[1] == 'G' ) rhscrd+=rhscrd;
841 :     if ( Rhstype[2] == 'X' ) rhscrd+=rhscrd;
842 :     rhscrd*=Nrhs;
843 :     } else rhscrd = 0;
844 :    
845 :     totcrd = 4+ptrcrd+indcrd+valcrd+rhscrd;
846 :    
847 :    
848 :     /* Print header information: */
849 :    
850 :     fprintf(out_file,"%-72s%-8s\n%14d%14d%14d%14d%14d\n",Title, Key, totcrd,
851 :     ptrcrd, indcrd, valcrd, rhscrd);
852 :     fprintf(out_file,"%3s%11s%14d%14d%14d\n",Type," ", M, N, nz);
853 :     fprintf(out_file,"%-16s%-16s%-20s", Ptrfmt, Indfmt, Valfmt);
854 :     if ( Nrhs != 0 ) {
855 :     /* Print Rhsfmt on fourth line and */
856 :     /* optional fifth header line for auxillary vector information: */
857 :     fprintf(out_file,"%-20s\n%-14s%d\n",Rhsfmt,Rhstype,Nrhs);
858 :     } else fprintf(out_file,"\n");
859 :    
860 :     offset = 1-_SP_base; /* if base 0 storage is declared (via macro definition), */
861 :     /* then storage entries are offset by 1 */
862 :    
863 :     /* Print column pointers: */
864 :     for (i=0;i<N+1;i++)
865 :     {
866 :     entry = colptr[i]+offset;
867 :     fprintf(out_file,pformat,entry);
868 :     if ( (i+1)%Ptrperline == 0 ) fprintf(out_file,"\n");
869 :     }
870 :    
871 :     if ( (N+1) % Ptrperline != 0 ) fprintf(out_file,"\n");
872 :    
873 :     /* Print row indices: */
874 :     for (i=0;i<nz;i++)
875 :     {
876 :     entry = rowind[i]+offset;
877 :     fprintf(out_file,iformat,entry);
878 :     if ( (i+1)%Indperline == 0 ) fprintf(out_file,"\n");
879 :     }
880 :    
881 :     if ( nz % Indperline != 0 ) fprintf(out_file,"\n");
882 :    
883 :     /* Print values: */
884 :    
885 :     if ( Type[0] != 'P' ) { /* Skip if pattern only */
886 :    
887 :     for (i=0;i<nvalentries;i++)
888 :     {
889 :     fprintf(out_file,vformat,val[i]);
890 :     if ( (i+1)%Valperline == 0 ) fprintf(out_file,"\n");
891 :     }
892 :    
893 :     if ( nvalentries % Valperline != 0 ) fprintf(out_file,"\n");
894 :    
895 :     /* If available, print right hand sides,
896 :     guess vectors and exact solution vectors: */
897 :     acount = 1;
898 :     linemod = 0;
899 :     if ( Nrhs > 0 ) {
900 :     for (i=0;i<Nrhs;i++)
901 :     {
902 :     for ( j=0;j<nrhsentries;j++ ) {
903 :     fprintf(out_file,rformat,rhs[j]);
904 :     if ( acount++%Rhsperline == linemod ) fprintf(out_file,"\n");
905 :     }
906 :     if ( acount%Rhsperline != linemod ) {
907 :     fprintf(out_file,"\n");
908 :     linemod = (acount-1)%Rhsperline;
909 :     }
910 :     rhs += nrhsentries;
911 :     if ( Rhstype[1] == 'G' ) {
912 :     for ( j=0;j<nrhsentries;j++ ) {
913 :     fprintf(out_file,rformat,guess[j]);
914 :     if ( acount++%Rhsperline == linemod ) fprintf(out_file,"\n");
915 :     }
916 :     if ( acount%Rhsperline != linemod ) {
917 :     fprintf(out_file,"\n");
918 :     linemod = (acount-1)%Rhsperline;
919 :     }
920 :     guess += nrhsentries;
921 :     }
922 :     if ( Rhstype[2] == 'X' ) {
923 :     for ( j=0;j<nrhsentries;j++ ) {
924 :     fprintf(out_file,rformat,exact[j]);
925 :     if ( acount++%Rhsperline == linemod ) fprintf(out_file,"\n");
926 :     }
927 :     if ( acount%Rhsperline != linemod ) {
928 :     fprintf(out_file,"\n");
929 :     linemod = (acount-1)%Rhsperline;
930 :     }
931 :     exact += nrhsentries;
932 :     }
933 :     }
934 :     }
935 :    
936 :     }
937 :    
938 :     if ( fclose(out_file) != 0){
939 :     fprintf(stderr,"Error closing file in writeHB_mat_double().\n");
940 :     return 0;
941 :     } else return 1;
942 :    
943 :     }
944 :    
945 :     int readHB_mat_char(const char* filename, int colptr[], int rowind[],
946 :     char val[], char* Valfmt)
947 :     {
948 :     /****************************************************************************/
949 :     /* This function opens and reads the specified file, interpreting its */
950 :     /* contents as a sparse matrix stored in the Harwell/Boeing standard */
951 :     /* format and creating compressed column storage scheme vectors to hold */
952 :     /* the index and nonzero value information. */
953 :     /* */
954 :     /* ---------- */
955 :     /* **CAVEAT** */
956 :     /* ---------- */
957 :     /* Parsing real formats from Fortran is tricky, and this file reader */
958 :     /* does not claim to be foolproof. It has been tested for cases when */
959 :     /* the real values are printed consistently and evenly spaced on each */
960 :     /* line, with Fixed (F), and Exponential (E or D) formats. */
961 :     /* */
962 :     /* ** If the input file does not adhere to the H/B format, the ** */
963 :     /* ** results will be unpredictable. ** */
964 :     /* */
965 :     /****************************************************************************/
966 :     FILE *in_file;
967 :     int i,j,ind,col,offset,count,last;
968 :     int Nrow,Ncol,Nnzero,Nentries,Nrhs;
969 :     int Ptrcrd, Indcrd, Valcrd, Rhscrd;
970 :     int Ptrperline, Ptrwidth, Indperline, Indwidth;
971 :     int Valperline, Valwidth, Valprec;
972 :     int Valflag; /* Indicates 'E','D', or 'F' float format */
973 :     char* ThisElement;
974 :     char line[BUFSIZ];
975 :     char Title[73], Key[8], Type[4], Rhstype[4];
976 :     char Ptrfmt[17], Indfmt[17], Rhsfmt[21];
977 :    
978 :     if ( (in_file = fopen( filename, "r")) == NULL ) {
979 :     fprintf(stderr,"Error: Cannot open file: %s\n",filename);
980 :     return 0;
981 :     }
982 :    
983 :     readHB_header(in_file, Title, Key, Type, &Nrow, &Ncol, &Nnzero, &Nrhs,
984 :     Ptrfmt, Indfmt, Valfmt, Rhsfmt,
985 :     &Ptrcrd, &Indcrd, &Valcrd, &Rhscrd, Rhstype);
986 :    
987 :     /* Parse the array input formats from Line 3 of HB file */
988 :     ParseIfmt(Ptrfmt,&Ptrperline,&Ptrwidth);
989 :     ParseIfmt(Indfmt,&Indperline,&Indwidth);
990 :     if ( Type[0] != 'P' ) { /* Skip if pattern only */
991 :     ParseRfmt(Valfmt,&Valperline,&Valwidth,&Valprec,&Valflag);
992 :     if (Valflag == 'D') {
993 :     *strchr(Valfmt,'D') = 'E';
994 :     }
995 :     }
996 :    
997 :     /* Read column pointer array: */
998 :    
999 :     offset = 1-_SP_base; /* if base 0 storage is declared (via macro definition), */
1000 :     /* then storage entries are offset by 1 */
1001 :    
1002 :     ThisElement = (char *) malloc(Ptrwidth+1);
1003 :     if ( ThisElement == NULL ) IOHBTerminate("Insufficient memory for ThisElement.");
1004 :     *(ThisElement+Ptrwidth) = (char) NULL;
1005 :     count=0;
1006 :     for (i=0;i<Ptrcrd;i++)
1007 :     {
1008 :     fgets(line, BUFSIZ, in_file);
1009 :     if ( sscanf(line,"%*s") < 0 )
1010 :     IOHBTerminate("iohb.c: Null (or blank) line in pointer data region of HB file.\n");
1011 :     col = 0;
1012 :     for (ind = 0;ind<Ptrperline;ind++)
1013 :     {
1014 :     if (count > Ncol) break;
1015 :     strncpy(ThisElement,line+col,Ptrwidth);
1016 :     /*ThisElement = substr(line,col,Ptrwidth);*/
1017 :     colptr[count] = atoi(ThisElement)-offset;
1018 :     count++; col += Ptrwidth;
1019 :     }
1020 :     }
1021 :     free(ThisElement);
1022 :    
1023 :     /* Read row index array: */
1024 :    
1025 :     ThisElement = (char *) malloc(Indwidth+1);
1026 :     if ( ThisElement == NULL ) IOHBTerminate("Insufficient memory for ThisElement.");
1027 :     *(ThisElement+Indwidth) = (char) NULL;
1028 :     count = 0;
1029 :     for (i=0;i<Indcrd;i++)
1030 :     {
1031 :     fgets(line, BUFSIZ, in_file);
1032 :     if ( sscanf(line,"%*s") < 0 )
1033 :     IOHBTerminate("iohb.c: Null (or blank) line in index data region of HB file.\n");
1034 :     col = 0;
1035 :     for (ind = 0;ind<Indperline;ind++)
1036 :     {
1037 :     if (count == Nnzero) break;
1038 :     strncpy(ThisElement,line+col,Indwidth);
1039 :     /*ThisElement = substr(line,col,Indwidth);*/
1040 :     rowind[count] = atoi(ThisElement)-offset;
1041 :     count++; col += Indwidth;
1042 :     }
1043 :     }
1044 :     free(ThisElement);
1045 :    
1046 :     /* Read array of values: AS CHARACTERS*/
1047 :    
1048 :     if ( Type[0] != 'P' ) { /* Skip if pattern only */
1049 :    
1050 :     if ( Type[0] == 'C' ) Nentries = 2*Nnzero;
1051 :     else Nentries = Nnzero;
1052 :    
1053 :     ThisElement = (char *) malloc(Valwidth+1);
1054 :     if ( ThisElement == NULL ) IOHBTerminate("Insufficient memory for ThisElement.");
1055 :     *(ThisElement+Valwidth) = (char) NULL;
1056 :     count = 0;
1057 :     for (i=0;i<Valcrd;i++)
1058 :     {
1059 :     fgets(line, BUFSIZ, in_file);
1060 :     if ( sscanf(line,"%*s") < 0 )
1061 :     IOHBTerminate("iohb.c: Null (or blank) line in value data region of HB file.\n");
1062 :     if (Valflag == 'D') {
1063 :     while( strchr(line,'D') ) *strchr(line,'D') = 'E';
1064 :     }
1065 :     col = 0;
1066 :     for (ind = 0;ind<Valperline;ind++)
1067 :     {
1068 :     if (count == Nentries) break;
1069 :     ThisElement = &val[count*Valwidth];
1070 :     strncpy(ThisElement,line+col,Valwidth);
1071 :     /*strncpy(ThisElement,substr(line,col,Valwidth),Valwidth);*/
1072 :     if ( Valflag != 'F' && strchr(ThisElement,'E') == NULL ) {
1073 :     /* insert a char prefix for exp */
1074 :     last = strlen(ThisElement);
1075 :     for (j=last+1;j>=0;j--) {
1076 :     ThisElement[j] = ThisElement[j-1];
1077 :     if ( ThisElement[j] == '+' || ThisElement[j] == '-' ) {
1078 :     ThisElement[j-1] = Valflag;
1079 :     break;
1080 :     }
1081 :     }
1082 :     }
1083 :     count++; col += Valwidth;
1084 :     }
1085 :     }
1086 :     }
1087 :    
1088 :     return 1;
1089 :     }
1090 :    
1091 :     int readHB_newmat_char(const char* filename, int* M, int* N, int* nonzeros, int** colptr,
1092 :     int** rowind, char** val, char** Valfmt)
1093 :     {
1094 :     FILE *in_file;
1095 :     int Nrhs;
1096 :     int Ptrcrd, Indcrd, Valcrd, Rhscrd;
1097 :     int Valperline, Valwidth, Valprec;
1098 :     int Valflag; /* Indicates 'E','D', or 'F' float format */
1099 :     char Title[73], Key[9], Type[4], Rhstype[4];
1100 :     char Ptrfmt[17], Indfmt[17], Rhsfmt[21];
1101 :    
1102 :     if ((in_file = fopen( filename, "r")) == NULL) {
1103 :     fprintf(stderr,"Error: Cannot open file: %s\n",filename);
1104 :     return 0;
1105 :     }
1106 :    
1107 :     *Valfmt = (char *)malloc(21*sizeof(char));
1108 :     if ( *Valfmt == NULL ) IOHBTerminate("Insufficient memory for Valfmt.");
1109 :     readHB_header(in_file, Title, Key, Type, M, N, nonzeros, &Nrhs,
1110 :     Ptrfmt, Indfmt, (*Valfmt), Rhsfmt,
1111 :     &Ptrcrd, &Indcrd, &Valcrd, &Rhscrd, Rhstype);
1112 :     fclose(in_file);
1113 :     ParseRfmt(*Valfmt,&Valperline,&Valwidth,&Valprec,&Valflag);
1114 :    
1115 :     *colptr = (int *)malloc((*N+1)*sizeof(int));
1116 :     if ( *colptr == NULL ) IOHBTerminate("Insufficient memory for colptr.\n");
1117 :     *rowind = (int *)malloc(*nonzeros*sizeof(int));
1118 :     if ( *rowind == NULL ) IOHBTerminate("Insufficient memory for rowind.\n");
1119 :     if ( Type[0] == 'C' ) {
1120 :     /*
1121 :     fprintf(stderr, "Warning: Reading complex data from HB file %s.\n",filename);
1122 :     fprintf(stderr, " Real and imaginary parts will be interlaced in val[].\n");
1123 :     */
1124 :     /* Malloc enough space for real AND imaginary parts of val[] */
1125 :     *val = (char *)malloc(*nonzeros*Valwidth*sizeof(char)*2);
1126 :     if ( *val == NULL ) IOHBTerminate("Insufficient memory for val.\n");
1127 :     } else {
1128 :     if ( Type[0] != 'P' ) {
1129 :     /* Malloc enough space for real array val[] */
1130 :     *val = (char *)malloc(*nonzeros*Valwidth*sizeof(char));
1131 :     if ( *val == NULL ) IOHBTerminate("Insufficient memory for val.\n");
1132 :     }
1133 :     } /* No val[] space needed if pattern only */
1134 :     return readHB_mat_char(filename, *colptr, *rowind, *val, *Valfmt);
1135 :    
1136 :     }
1137 :    
1138 :     int readHB_aux_char(const char* filename, const char AuxType, char b[])
1139 :     {
1140 :     /****************************************************************************/
1141 :     /* This function opens and reads the specified file, placing auxilary */
1142 :     /* vector(s) of the given type (if available) in b : */
1143 :     /* Return value is the number of vectors successfully read. */
1144 :     /* */
1145 :     /* AuxType = 'F' full right-hand-side vector(s) */
1146 :     /* AuxType = 'G' initial Guess vector(s) */
1147 :     /* AuxType = 'X' eXact solution vector(s) */
1148 :     /* */
1149 :     /* ---------- */
1150 :     /* **CAVEAT** */
1151 :     /* ---------- */
1152 :     /* Parsing real formats from Fortran is tricky, and this file reader */
1153 :     /* does not claim to be foolproof. It has been tested for cases when */
1154 :     /* the real values are printed consistently and evenly spaced on each */
1155 :     /* line, with Fixed (F), and Exponential (E or D) formats. */
1156 :     /* */
1157 :     /* ** If the input file does not adhere to the H/B format, the ** */
1158 :     /* ** results will be unpredictable. ** */
1159 :     /* */
1160 :     /****************************************************************************/
1161 :     FILE *in_file;
1162 :     int i,j,n,maxcol,start,stride,col,last,linel,nvecs,rhsi;
1163 :     int Nrow, Ncol, Nnzero, Nentries,Nrhs;
1164 :     int Ptrcrd, Indcrd, Valcrd, Rhscrd;
1165 :     int Rhsperline, Rhswidth, Rhsprec;
1166 :     int Rhsflag;
1167 :     char Title[73], Key[9], Type[4], Rhstype[4];
1168 :     char Ptrfmt[17], Indfmt[17], Valfmt[21], Rhsfmt[21];
1169 :     char line[BUFSIZ];
1170 :     char *ThisElement;
1171 :    
1172 :     if ((in_file = fopen( filename, "r")) == NULL) {
1173 :     fprintf(stderr,"Error: Cannot open file: %s\n",filename);
1174 :     return 0;
1175 :     }
1176 :    
1177 :     readHB_header(in_file, Title, Key, Type, &Nrow, &Ncol, &Nnzero, &Nrhs,
1178 :     Ptrfmt, Indfmt, Valfmt, Rhsfmt,
1179 :     &Ptrcrd, &Indcrd, &Valcrd, &Rhscrd, Rhstype);
1180 :    
1181 :     if (Nrhs <= 0)
1182 :     {
1183 :     fprintf(stderr, "Warn: Attempt to read auxillary vector(s) when none are present.\n");
1184 :     return 0;
1185 :     }
1186 :     if (Rhstype[0] != 'F' )
1187 :     {
1188 :     fprintf(stderr,"Warn: Attempt to read auxillary vector(s) which are not stored in Full form.\n");
1189 :     fprintf(stderr," Rhs must be specified as full. \n");
1190 :     return 0;
1191 :     }
1192 :    
1193 :     /* If reading complex data, allow for interleaved real and imaginary values. */
1194 :     if ( Type[0] == 'C' ) {
1195 :     Nentries = 2*Nrow;
1196 :     } else {
1197 :     Nentries = Nrow;
1198 :     }
1199 :    
1200 :     nvecs = 1;
1201 :    
1202 :     if ( Rhstype[1] == 'G' ) nvecs++;
1203 :     if ( Rhstype[2] == 'X' ) nvecs++;
1204 :    
1205 :     if ( AuxType == 'G' && Rhstype[1] != 'G' ) {
1206 :     fprintf(stderr, "Warn: Attempt to read auxillary Guess vector(s) when none are present.\n");
1207 :     return 0;
1208 :     }
1209 :     if ( AuxType == 'X' && Rhstype[2] != 'X' ) {
1210 :     fprintf(stderr, "Warn: Attempt to read auxillary eXact solution vector(s) when none are present.\n");
1211 :     return 0;
1212 :     }
1213 :    
1214 :     ParseRfmt(Rhsfmt, &Rhsperline, &Rhswidth, &Rhsprec,&Rhsflag);
1215 :     maxcol = Rhsperline*Rhswidth;
1216 :    
1217 :     /* Lines to skip before starting to read RHS values... */
1218 :     n = Ptrcrd + Indcrd + Valcrd;
1219 :    
1220 :     for (i = 0; i < n; i++)
1221 :     fgets(line, BUFSIZ, in_file);
1222 :    
1223 :     /* start - number of initial aux vector entries to skip */
1224 :     /* to reach first vector requested */
1225 :     /* stride - number of aux vector entries to skip between */
1226 :     /* requested vectors */
1227 :     if ( AuxType == 'F' ) start = 0;
1228 :     else if ( AuxType == 'G' ) start = Nentries;
1229 :     else start = (nvecs-1)*Nentries;
1230 :     stride = (nvecs-1)*Nentries;
1231 :    
1232 :     fgets(line, BUFSIZ, in_file);
1233 :     linel= strchr(line,'\n')-line;
1234 :     if ( sscanf(line,"%*s") < 0 )
1235 :     IOHBTerminate("iohb.c: Null (or blank) line in auxillary vector data region of HB file.\n");
1236 :     col = 0;
1237 :     /* Skip to initial offset */
1238 :    
1239 :     for (i=0;i<start;i++) {
1240 :     col += Rhswidth;
1241 :     if ( col >= ( maxcol<linel?maxcol:linel ) ) {
1242 :     fgets(line, BUFSIZ, in_file);
1243 :     linel= strchr(line,'\n')-line;
1244 :     if ( sscanf(line,"%*s") < 0 )
1245 :     IOHBTerminate("iohb.c: Null (or blank) line in auxillary vector data region of HB file.\n");
1246 :     col = 0;
1247 :     }
1248 :     }
1249 :    
1250 :     if (Rhsflag == 'D') {
1251 :     while( strchr(line,'D') ) *strchr(line,'D') = 'E';
1252 :     }
1253 :     /* Read a vector of desired type, then skip to next */
1254 :     /* repeating to fill Nrhs vectors */
1255 :    
1256 :     for (rhsi=0;rhsi<Nrhs;rhsi++) {
1257 :    
1258 :     for (i=0;i<Nentries;i++) {
1259 :     if ( col >= ( maxcol<linel?maxcol:linel ) ) {
1260 :     fgets(line, BUFSIZ, in_file);
1261 :     linel= strchr(line,'\n')-line;
1262 :     if ( sscanf(line,"%*s") < 0 )
1263 :     IOHBTerminate("iohb.c: Null (or blank) line in auxillary vector data region of HB file.\n");
1264 :     if (Rhsflag == 'D') {
1265 :     while( strchr(line,'D') ) *strchr(line,'D') = 'E';
1266 :     }
1267 :     col = 0;
1268 :     }
1269 :     ThisElement = &b[i*Rhswidth];
1270 :     strncpy(ThisElement,line+col,Rhswidth);
1271 :     if ( Rhsflag != 'F' && strchr(ThisElement,'E') == NULL ) {
1272 :     /* insert a char prefix for exp */
1273 :     last = strlen(ThisElement);
1274 :     for (j=last+1;j>=0;j--) {
1275 :     ThisElement[j] = ThisElement[j-1];
1276 :     if ( ThisElement[j] == '+' || ThisElement[j] == '-' ) {
1277 :     ThisElement[j-1] = Rhsflag;
1278 :     break;
1279 :     }
1280 :     }
1281 :     }
1282 :     col += Rhswidth;
1283 :     }
1284 :     b+=Nentries*Rhswidth;
1285 :    
1286 :     /* Skip any interleaved Guess/eXact vectors */
1287 :    
1288 :     for (i=0;i<stride;i++) {
1289 :     col += Rhswidth;
1290 :     if ( col >= ( maxcol<linel?maxcol:linel ) ) {
1291 :     fgets(line, BUFSIZ, in_file);
1292 :     linel= strchr(line,'\n')-line;
1293 :     if ( sscanf(line,"%*s") < 0 )
1294 :     IOHBTerminate("iohb.c: Null (or blank) line in auxillary vector data region of HB file.\n");
1295 :     col = 0;
1296 :     }
1297 :     }
1298 :    
1299 :     }
1300 :    
1301 :    
1302 :     fclose(in_file);
1303 :     return Nrhs;
1304 :     }
1305 :    
1306 :     int readHB_newaux_char(const char* filename, const char AuxType, char** b, char** Rhsfmt)
1307 :     {
1308 :     FILE *in_file;
1309 :     int Ptrcrd, Indcrd, Valcrd, Rhscrd;
1310 :     int Nrow,Ncol,Nnzero,Nrhs;
1311 :     int Rhsperline, Rhswidth, Rhsprec;
1312 :     int Rhsflag;
1313 :     char Title[73], Key[9], Type[4], Rhstype[4];
1314 :     char Ptrfmt[17], Indfmt[17], Valfmt[21];
1315 :    
1316 :     if ((in_file = fopen( filename, "r")) == NULL) {
1317 :     fprintf(stderr,"Error: Cannot open file: %s\n",filename);
1318 :     return 0;
1319 :     }
1320 :    
1321 :     *Rhsfmt = (char *)malloc(21*sizeof(char));
1322 :     if ( *Rhsfmt == NULL ) IOHBTerminate("Insufficient memory for Rhsfmt.");
1323 :     readHB_header(in_file, Title, Key, Type, &Nrow, &Ncol, &Nnzero, &Nrhs,
1324 :     Ptrfmt, Indfmt, Valfmt, (*Rhsfmt),
1325 :     &Ptrcrd, &Indcrd, &Valcrd, &Rhscrd, Rhstype);
1326 :     fclose(in_file);
1327 :     if ( Nrhs == 0 ) {
1328 :     fprintf(stderr,"Warn: Requested read of aux vector(s) when none are present.\n");
1329 :     return 0;
1330 :     } else {
1331 :     ParseRfmt(*Rhsfmt,&Rhsperline,&Rhswidth,&Rhsprec,&Rhsflag);
1332 :     if ( Type[0] == 'C' ) {
1333 :     fprintf(stderr, "Warning: Reading complex aux vector(s) from HB file %s.",filename);
1334 :     fprintf(stderr, " Real and imaginary parts will be interlaced in b[].");
1335 :     *b = (char *)malloc(Nrow*Nrhs*Rhswidth*sizeof(char)*2);
1336 :     if ( *b == NULL ) IOHBTerminate("Insufficient memory for rhs.\n");
1337 :     return readHB_aux_char(filename, AuxType, *b);
1338 :     } else {
1339 :     *b = (char *)malloc(Nrow*Nrhs*Rhswidth*sizeof(char));
1340 :     if ( *b == NULL ) IOHBTerminate("Insufficient memory for rhs.\n");
1341 :     return readHB_aux_char(filename, AuxType, *b);
1342 :     }
1343 :     }
1344 :     }
1345 :    
1346 :     int writeHB_mat_char(const char* filename, int M, int N,
1347 :     int nz, const int colptr[], const int rowind[],
1348 :     const char val[], int Nrhs, const char rhs[],
1349 :     const char guess[], const char exact[],
1350 :     const char* Title, const char* Key, const char* Type,
1351 :     char* Ptrfmt, char* Indfmt, char* Valfmt, char* Rhsfmt,
1352 :     const char* Rhstype)
1353 :     {
1354 :     /****************************************************************************/
1355 :     /* The writeHB function opens the named file and writes the specified */
1356 :     /* matrix and optional right-hand-side(s) to that file in Harwell-Boeing */
1357 :     /* format. */
1358 :     /* */
1359 :     /* For a description of the Harwell Boeing standard, see: */
1360 :     /* Duff, et al., ACM TOMS Vol.15, No.1, March 1989 */
1361 :     /* */
1362 :     /****************************************************************************/
1363 :     FILE *out_file;
1364 :     int i,j,acount,linemod,entry,offset;
1365 :     int totcrd, ptrcrd, indcrd, valcrd, rhscrd;
1366 :     int nvalentries, nrhsentries;
1367 :     int Ptrperline, Ptrwidth, Indperline, Indwidth;
1368 :     int Rhsperline, Rhswidth, Rhsprec;
1369 :     int Rhsflag;
1370 :     int Valperline, Valwidth, Valprec;
1371 :     int Valflag; /* Indicates 'E','D', or 'F' float format */
1372 :     char pformat[16],iformat[16],vformat[19],rformat[19];
1373 :    
1374 :     if ( Type[0] == 'C' ) {
1375 :     nvalentries = 2*nz;
1376 :     nrhsentries = 2*M;
1377 :     } else {
1378 :     nvalentries = nz;
1379 :     nrhsentries = M;
1380 :     }
1381 :    
1382 :     if ( filename != NULL ) {
1383 :     if ( (out_file = fopen( filename, "w")) == NULL ) {
1384 :     fprintf(stderr,"Error: Cannot open file: %s\n",filename);
1385 :     return 0;
1386 :     }
1387 :     } else out_file = stdout;
1388 :    
1389 :     if ( Ptrfmt == NULL ) Ptrfmt = "(8I10)";
1390 :     ParseIfmt(Ptrfmt,&Ptrperline,&Ptrwidth);
1391 :     sprintf(pformat,"%%%dd",Ptrwidth);
1392 :    
1393 :     if ( Indfmt == NULL ) Indfmt = Ptrfmt;
1394 :     ParseIfmt(Indfmt,&Indperline,&Indwidth);
1395 :     sprintf(iformat,"%%%dd",Indwidth);
1396 :    
1397 :     if ( Type[0] != 'P' ) { /* Skip if pattern only */
1398 :     if ( Valfmt == NULL ) Valfmt = "(4E20.13)";
1399 :     ParseRfmt(Valfmt,&Valperline,&Valwidth,&Valprec,&Valflag);
1400 :     sprintf(vformat,"%%%ds",Valwidth);
1401 :     }
1402 :    
1403 :     ptrcrd = (N+1)/Ptrperline;
1404 :     if ( (N+1)%Ptrperline != 0) ptrcrd++;
1405 :    
1406 :     indcrd = nz/Indperline;
1407 :     if ( nz%Indperline != 0) indcrd++;
1408 :    
1409 :     valcrd = nvalentries/Valperline;
1410 :     if ( nvalentries%Valperline != 0) valcrd++;
1411 :    
1412 :     if ( Nrhs > 0 ) {
1413 :     if ( Rhsfmt == NULL ) Rhsfmt = Valfmt;
1414 :     ParseRfmt(Rhsfmt,&Rhsperline,&Rhswidth,&Rhsprec, &Rhsflag);
1415 :     sprintf(rformat,"%%%ds",Rhswidth);
1416 :     rhscrd = nrhsentries/Rhsperline;
1417 :     if ( nrhsentries%Rhsperline != 0) rhscrd++;
1418 :     if ( Rhstype[1] == 'G' ) rhscrd+=rhscrd;
1419 :     if ( Rhstype[2] == 'X' ) rhscrd+=rhscrd;
1420 :     rhscrd*=Nrhs;
1421 :     } else rhscrd = 0;
1422 :    
1423 :     totcrd = 4+ptrcrd+indcrd+valcrd+rhscrd;
1424 :    
1425 :    
1426 :     /* Print header information: */
1427 :    
1428 :     fprintf(out_file,"%-72s%-8s\n%14d%14d%14d%14d%14d\n",Title, Key, totcrd,
1429 :     ptrcrd, indcrd, valcrd, rhscrd);
1430 :     fprintf(out_file,"%3s%11s%14d%14d%14d\n",Type," ", M, N, nz);
1431 :     fprintf(out_file,"%-16s%-16s%-20s", Ptrfmt, Indfmt, Valfmt);
1432 :     if ( Nrhs != 0 ) {
1433 :     /* Print Rhsfmt on fourth line and */
1434 :     /* optional fifth header line for auxillary vector information: */
1435 :     fprintf(out_file,"%-20s\n%-14s%d\n",Rhsfmt,Rhstype,Nrhs);
1436 :     } else fprintf(out_file,"\n");
1437 :    
1438 :     offset = 1-_SP_base; /* if base 0 storage is declared (via macro definition), */
1439 :     /* then storage entries are offset by 1 */
1440 :    
1441 :     /* Print column pointers: */
1442 :     for (i=0;i<N+1;i++)
1443 :     {
1444 :     entry = colptr[i]+offset;
1445 :     fprintf(out_file,pformat,entry);
1446 :     if ( (i+1)%Ptrperline == 0 ) fprintf(out_file,"\n");
1447 :     }
1448 :    
1449 :     if ( (N+1) % Ptrperline != 0 ) fprintf(out_file,"\n");
1450 :    
1451 :     /* Print row indices: */
1452 :     for (i=0;i<nz;i++)
1453 :     {
1454 :     entry = rowind[i]+offset;
1455 :     fprintf(out_file,iformat,entry);
1456 :     if ( (i+1)%Indperline == 0 ) fprintf(out_file,"\n");
1457 :     }
1458 :    
1459 :     if ( nz % Indperline != 0 ) fprintf(out_file,"\n");
1460 :    
1461 :     /* Print values: */
1462 :    
1463 :     if ( Type[0] != 'P' ) { /* Skip if pattern only */
1464 :     for (i=0;i<nvalentries;i++)
1465 :     {
1466 :     fprintf(out_file,vformat,val+i*Valwidth);
1467 :     if ( (i+1)%Valperline == 0 ) fprintf(out_file,"\n");
1468 :     }
1469 :    
1470 :     if ( nvalentries % Valperline != 0 ) fprintf(out_file,"\n");
1471 :    
1472 :     /* Print right hand sides: */
1473 :     acount = 1;
1474 :     linemod=0;
1475 :     if ( Nrhs > 0 ) {
1476 :     for (j=0;j<Nrhs;j++) {
1477 :     for (i=0;i<nrhsentries;i++)
1478 :     {
1479 :     fprintf(out_file,rformat,rhs+i*Rhswidth);
1480 :     if ( acount++%Rhsperline == linemod ) fprintf(out_file,"\n");
1481 :     }
1482 :     if ( acount%Rhsperline != linemod ) {
1483 :     fprintf(out_file,"\n");
1484 :     linemod = (acount-1)%Rhsperline;
1485 :     }
1486 :     if ( Rhstype[1] == 'G' ) {
1487 :     for (i=0;i<nrhsentries;i++)
1488 :     {
1489 :     fprintf(out_file,rformat,guess+i*Rhswidth);
1490 :     if ( acount++%Rhsperline == linemod ) fprintf(out_file,"\n");
1491 :     }
1492 :     if ( acount%Rhsperline != linemod ) {
1493 :     fprintf(out_file,"\n");
1494 :     linemod = (acount-1)%Rhsperline;
1495 :     }
1496 :     }
1497 :     if ( Rhstype[2] == 'X' ) {
1498 :     for (i=0;i<nrhsentries;i++)
1499 :     {
1500 :     fprintf(out_file,rformat,exact+i*Rhswidth);
1501 :     if ( acount++%Rhsperline == linemod ) fprintf(out_file,"\n");
1502 :     }
1503 :     if ( acount%Rhsperline != linemod ) {
1504 :     fprintf(out_file,"\n");
1505 :     linemod = (acount-1)%Rhsperline;
1506 :     }
1507 :     }
1508 :     }
1509 :     }
1510 :    
1511 :     }
1512 :    
1513 :     if ( fclose(out_file) != 0){
1514 :     fprintf(stderr,"Error closing file in writeHB_mat_char().\n");
1515 :     return 0;
1516 :     } else return 1;
1517 :    
1518 :     }
1519 :    
1520 :     int ParseIfmt(char* fmt, int* perline, int* width)
1521 :     {
1522 :     /*************************************************/
1523 :     /* Parse an *integer* format field to determine */
1524 :     /* width and number of elements per line. */
1525 :     /*************************************************/
1526 :     char *tmp;
1527 :     if (fmt == NULL ) {
1528 :     *perline = 0; *width = 0; return 0;
1529 :     }
1530 :     upcase(fmt);
1531 :     tmp = strchr(fmt,'(');
1532 :     tmp = substr(fmt,tmp - fmt + 1, strchr(fmt,'I') - tmp - 1);
1533 :     *perline = atoi(tmp);
1534 :     tmp = strchr(fmt,'I');
1535 :     tmp = substr(fmt,tmp - fmt + 1, strchr(fmt,')') - tmp - 1);
1536 :     return *width = atoi(tmp);
1537 :     }
1538 :    
1539 :     int ParseRfmt(char* fmt, int* perline, int* width, int* prec, int* flag)
1540 :     {
1541 :     /*************************************************/
1542 :     /* Parse a *real* format field to determine */
1543 :     /* width and number of elements per line. */
1544 :     /* Also sets flag indicating 'E' 'F' 'P' or 'D' */
1545 :     /* format. */
1546 :     /*************************************************/
1547 :     char* tmp;
1548 :     char* tmp2;
1549 :     char* tmp3;
1550 :     int len;
1551 :    
1552 :     if (fmt == NULL ) {
1553 :     *perline = 0;
1554 :     *width = 0;
1555 :     flag = NULL;
1556 :     return 0;
1557 :     }
1558 :    
1559 :     upcase(fmt);
1560 :     if (strchr(fmt,'(') != NULL) fmt = strchr(fmt,'(');
1561 :     if (strchr(fmt,')') != NULL) {
1562 :     tmp2 = strchr(fmt,')');
1563 :     while ( strchr(tmp2+1,')') != NULL ) {
1564 :     tmp2 = strchr(tmp2+1,')');
1565 :     }
1566 :     *(tmp2+1) = (int) NULL;
1567 :     }
1568 :     if (strchr(fmt,'P') != NULL) /* Remove any scaling factor, which */
1569 :     { /* affects output only, not input */
1570 :     if (strchr(fmt,'(') != NULL) {
1571 :     tmp = strchr(fmt,'P');
1572 :     if ( *(++tmp) == ',' ) tmp++;
1573 :     tmp3 = strchr(fmt,'(')+1;
1574 :     len = tmp-tmp3;
1575 :     tmp2 = tmp3;
1576 :     while ( *(tmp2+len) != (int) NULL ) {
1577 :     *tmp2=*(tmp2+len);
1578 :     tmp2++;
1579 :     }
1580 :     *(strchr(fmt,')')+1) = (int) NULL;
1581 :     }
1582 :     }
1583 :     if (strchr(fmt,'E') != NULL) {
1584 :     *flag = 'E';
1585 :     } else if (strchr(fmt,'D') != NULL) {
1586 :     *flag = 'D';
1587 :     } else if (strchr(fmt,'F') != NULL) {
1588 :     *flag = 'F';
1589 :     } else {
1590 :     fprintf(stderr,"Real format %s in H/B file not supported.\n",fmt);
1591 :     return 0;
1592 :     }
1593 :     tmp = strchr(fmt,'(');
1594 :     tmp = substr(fmt,tmp - fmt + 1, strchr(fmt,*flag) - tmp - 1);
1595 :     *perline = atoi(tmp);
1596 :     tmp = strchr(fmt,*flag);
1597 :     if ( strchr(fmt,'.') ) {
1598 :     *prec = atoi( substr( fmt, strchr(fmt,'.') - fmt + 1, strchr(fmt,')') - strchr(fmt,'.')-1) );
1599 :     tmp = substr(fmt,tmp - fmt + 1, strchr(fmt,'.') - tmp - 1);
1600 :     } else {
1601 :     tmp = substr(fmt,tmp - fmt + 1, strchr(fmt,')') - tmp - 1);
1602 :     }
1603 :     return *width = atoi(tmp);
1604 :     }
1605 :    

root@r-forge.r-project.org
ViewVC Help
Powered by ViewVC 1.0.0  
Thanks to:
Vienna University of Economics and Business Powered By FusionForge