« back to all changes in this revision
Viewing changes to src_f/library_f.c
- browse files at revision 8
- compare with another revision
- download diff
- download tarball
- view history from revision 8
- Committer: Bazaar Package Importer
- Author(s): Morten Kjeldgaard
- Date: 2009-11-09 16:41:48 UTC
- mfrom: (1.1.2 upstream)
- Revision ID: james.westby@ubuntu.com-20091109164148-mz0uet32ywxs010d
Tags: 1.2.0-0ubuntu1
* New upstream version 1.2.0.
* New binary packages added to isolate the mmdb dependency in the
Fortran API libraries.
* New binary packages added to isolate the mmdb dependency in the
Fortran API libraries.
added
removed
src_f/library_f.c
1
/*
2
library_f.c: Fortran API to library.c
3
Copyright (C) 2001 CCLRC, Charles Ballard
4
5
This library is free software; you can redistribute it and/or
6
modify it under the terms of the GNU Lesser General Public
7
License as published by the Free Software Foundation; either
8
version 2.1 of the License, or (at your option) any later
9
version.
10
11
This library is distributed in the hope that it will be useful,
12
but WITHOUT ANY WARRANTY; without even the implied warranty of
13
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14
Lesser General Public License for more details.
15
16
You should have received a copy of the GNU Lesser General Public
17
License along with this library; if not, write to the Free
18
Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
19
Boston, MA 02110-1301 USA
20
*/
21
22
/** @file library_f.c
23
@brief FORTRAN API for library.c.
24
@date 2001
25
@author Charles Ballard
26
27
This file contains the wrappers for calling library.c from FORTRAN
28
and some "missing" routines.
29
30
System dependent names are handled in the FORTRAN_SUBR,
31
FORTRAN_FUN, FORTRAN_CALL macros defined in the header file.
32
fpstr is a typedef which masks the intricacies of FORTRAN string
33
passing.
34
35
*/
36
37
#if defined(G95) || defined (GFORTRAN)
38
#include <time.h>
39
#endif
40
41
#include "ccp4_utils.h"
42
#include "ccp4_errno.h"
43
#include "ccp4_fortran.h"
44
45
/** Creates a null-terminated C string from an input
46
* string obtained from a Fortran call. Trailing blanks are
47
* removed. If input string is blank then return string "\0".
48
* Memory assigned by malloc, so can be freed.
49
* @param str1 pointer to string
50
* @param str1_len Fortran length of string
51
*/
52
char *ccp4_FtoCString(fpstr str1, int str1_len)
53
{
54
char *str2;
55
56
size_t length = ccp4_utils_flength(FTN_STR(str1),str1_len);
57
if (length < 0)
58
return NULL;
59
str2 = (char *) ccp4_utils_malloc((length+1)*sizeof(char));
60
if(length) strncpy(str2, FTN_STR(str1), length);
61
str2[length] = '\0';
62
63
return str2;
64
}
65
66
/** Creates a Fortran string from an input C string for passing back to
67
* Fortran call. Characters after null-terminator may be junk, so pad
68
* with spaces. If input cstring is NULL, return blank string.
69
* @param str1 pointer Fortran to string
70
* @param str1_len Fortran length of string
71
* @param cstring input C string
72
*/
73
void ccp4_CtoFString(fpstr str1, int str1_len, const char *cstring)
74
{
75
int i;
76
77
if (!cstring) {
78
for (i = 0; i < str1_len; ++i)
79
str1[i] = ' ';
80
} else if (str1_len > strlen(cstring)) {
81
strcpy(FTN_STR(str1),cstring);
82
for (i = strlen(cstring); i < str1_len; ++i)
83
str1[i] = ' ';
84
} else {
85
strncpy(FTN_STR(str1),cstring,str1_len);
86
}
87
}
88
89
/* \section{Miscellaneous routines} */
90
/* \subsection{{\tt subroutine ustenv(\meta{string}, \meta{result})}} */
91
/* */
92
/* This sets an environment variable \meta{var} to \meta{val}, where the */
93
/* argument \meta{string}[[==']]\meta{var}[['//'='//']]\meta{val}[[']]. */
94
/* This is for use by the `\idx{logical name}' mechanism for specifying */
95
/* file connexions. Note that a \idx{VMS} varsion is supplied in {\tt */
96
/* vms.for} and that there is no standard way of setting and */
97
/* environment variable. In a minimal \ac{posix} system it might be */
98
/* necessary to twiddle the environment strings explicitly. */
99
/* Upon exit result contains [[0]] on Success, [[-1]] on Failure. */
100
/* */
101
/* */
102
/* <miscellaneous routines>= */
103
/* <ustenv code>= */
104
#if ! defined (VMS)
105
FORTRAN_SUBR ( USTENV, ustenv,
106
(fpstr str, int *result, int str_len),
107
(fpstr str, int *result),
108
(fpstr str, int str_len, int *result))
109
{
110
char *temp_name;
111
112
temp_name = ccp4_FtoCString(FTN_STR(str), FTN_LEN(str));
113
114
if (*result = ccp4_utils_setenv (temp_name))
115
ccp4_fatal("USTENV/CCP4_SETENV: Memory allocation failure");
116
free(temp_name);
117
}
118
#endif
119
120
#if ! defined (_MSC_VER)
121
FORTRAN_SUBR ( USTIME, ustime,
122
(int *isec),
123
(int *isec),
124
(int *isec))
125
{
126
*isec = time(NULL);
127
}
128
#endif
129
130
/* \section{Miscellaneous routines} */
131
/* \subsection{{\tt outbuf()}} */
132
/* */
133
/* This sets stdout to line buffering (error not fatal) */
134
/* */
135
/* <miscellaneous routines>= */
136
/* <outbuf code>= */
137
FORTRAN_SUBR ( OUTBUF, outbuf, (), (), ())
138
{
139
#if defined (__APPLE__) && defined (_CALL_SYSV)
140
char *s = "buffering=disable_preconn";
141
int s_len = strlen(s);
142
FORTRAN_CALL (SETRTEOPTS,setrteopts,(s,s_len),(s,s_len),(s,s_len));
143
#endif
144
if(ccp4_utils_outbuf())
145
ccp4_utils_print("OUTBUF:Can't turn off buffering");
146
}
147
148
/* \subsection{{\tt subroutine cunlink (\meta{filename})}} */
149
/* This unlinks \meta{filename} from the directory. It's intended for */
150
/* use with scratch files, so that they can be hidden when opened but */
151
/* still be available as long as they remain connected (see [[CCPOPN]]). */
152
/* This functionality doesn't seem to exist in \idx{VMS}\@. Failure to */
153
/* unlink isn't fatal (it's been observed, apparently spuriously). */
154
/* */
155
/* <miscellaneous routines>= */
156
FORTRAN_SUBR ( CUNLINK, cunlink,
157
(fpstr filename, int filename_len),
158
(fpstr filename),
159
(fpstr filename, int filename_len))
160
{
161
#ifdef VMS
162
return; /* can't do it */
163
#else
164
char *temp_name;
165
166
temp_name = ccp4_FtoCString(FTN_STR(filename), FTN_LEN(filename));
167
168
if( unlink(temp_name) )
169
ccp4_utils_print("CUNLINK: Can't unlink");
170
free(temp_name);
171
#endif /* VMS */
172
}
173
174
/* \section{Dynamic memory allocation} */
175
/* It's nice to be able to determine array sizes at run time to avoid */
176
/* messy recompilation. The only way effectively to get dynamic */
177
/* allocation in Fortran77 reasonably portably is to do the allocation, */
178
/* e.g.\ in C, and invoke the Fortran routine passed as a parameter with */
179
/* pointers to the allocated memory which it will treat as arrays. If we */
180
/* want to allow more than one array, it's more tricky. */
181
/* */
182
/* \subsection{{\tt subroutine ccpal1 (\meta{routne}, \meta{n}. */
183
/* \meta{type}, \meta{length})}} */
184
/* Arranges to call subroutine \meta{routne} with \meta{n} array */
185
/* arguments. Each has a type indicated by \meta{type}$(i)$ and a length */
186
/* given by \meta{length}($i$). \meta{type} is an integer array with */
187
/* values 1, 2, 3, 4 inidcating {\tt */
188
/* INTEGER}, {\tt REAL}, {\tt DOUBLE PRECISION} and {\tt COMPLEX} */
189
/* respectively. */
190
/* It's not immediately clear what all the Fortran/C */
191
/* conventions are for passing [[CHARACTER]] arrays, so we'll arrange a */
192
/* higher-level interface and have [[types]] here just numeric. The */
193
/* Fortran ([[CCPALC]]) will also do argument validation. Also the rules */
194
/* for passing external routines as arguments aren't clear---assume */
195
/* the obvious way. */
196
/* */
197
/* There's a \idx{VMS} Fortran version of this, although the code here */
198
/* does work fine in VMS\@. */
199
/* */
200
/* NB: there's a possibility of a hook here to use memory-mapped files on */
201
/* systems with the capability and insufficient VM\@. */
202
/* */
203
/* Under protest, this now allocates zeroed storage for where programs */
204
/* make bad assumptions. */
205
/* */
206
/* <miscellaneous routines>= */
207
#ifndef VMS /* we'll use the Fortran version in VMS*/
208
#ifndef _MSC_VER
209
FORTRAN_SUBR ( CCPAL1, ccpal1,
210
(void (* routne) (), int *n, int type[], int length[]),
211
(void (* routne) (), int *n, int type[], int length[]),
212
(void (* routne) (), int *n, int type[], int length[]))
213
{
214
static int item_sizes[] = {
215
(int) sizeof (char), /* 0: bytes */
216
(int) sizeof (short int), /* 1: (integer) half words */
217
(int) sizeof (float), /* 2: reals/words */
218
(int) sizeof (int), /* 3: `short complex' (pairs of half words).
219
NB int rather than 2*short since must fit
220
into fortran integer */
221
(int) 2*sizeof (float), /* 4: complex (pairs of words) */
222
(int) sizeof (int), /* 5: not used */
223
(int) sizeof (int) /* 6: integers */
224
};
225
int i, size, *leng[13];
226
void *pointer[13];
227
228
for (i=0; i<*n; i++) {
229
switch (type[i]) {
230
case 1:
231
size = item_sizes[6]; break; /* integer */
232
case 2:
233
size = item_sizes[2]; break; /* real */
234
case 3:
235
size = 2*item_sizes[2]; break; /* double */
236
case 4:
237
size = 2*item_sizes[2]; break; /* complex */
238
case 5:
239
size = item_sizes[1]; break; /* bytes (logical or integer *1) */
240
}
241
pointer[i+1] = calloc ((size_t) length[i], (size_t) size);
242
if (pointer[i+1] == NULL) ccp4_fatal ("CCPALC: can't allocate memory");
243
leng[i+1] = &(length[i]); /* convenience */
244
}
245
switch (*n) {
246
case 1:
247
(* routne) (leng[1], pointer[1]);
248
break;
249
case 2:
250
(* routne) (leng[1], pointer[1], leng[2], pointer[2]);
251
break;
252
case 3:
253
(* routne) (leng[1], pointer[1], leng[2], pointer[2],
254
leng[3], pointer[3]);
255
break;
256
case 4:
257
(* routne) (leng[1], pointer[1], leng[2], pointer[2],
258
leng[3], pointer[3], leng[4], pointer[4]);
259
break;
260
case 5:
261
(* routne) (leng[1], pointer[1], leng[2], pointer[2],
262
leng[3], pointer[3], leng[4], pointer[4],
263
leng[5], pointer[5]);
264
break;
265
case 6:
266
(* routne) (leng[1], pointer[1], leng[2], pointer[2],
267
leng[3], pointer[3], leng[4], pointer[4],
268
leng[5], pointer[5], leng[6], pointer[6]);
269
break;
270
case 7:
271
(* routne) (leng[1], pointer[1], leng[2], pointer[2],
272
leng[3], pointer[3], leng[4], pointer[4],
273
leng[5], pointer[5], leng[6], pointer[6],
274
leng[7], pointer[7]);
275
break;
276
case 8:
277
(* routne) (leng[1], pointer[1], leng[2], pointer[2],
278
leng[3], pointer[3], leng[4], pointer[4],
279
leng[5], pointer[5], leng[6], pointer[6],
280
leng[7], pointer[7], leng[8], pointer[8]);
281
break;
282
case 9:
283
(* routne) (leng[1], pointer[1], leng[2], pointer[2],
284
leng[3], pointer[3], leng[4], pointer[4],
285
leng[5], pointer[5], leng[6], pointer[6],
286
leng[7], pointer[7], leng[8], pointer[8],
287
leng[9], pointer[9]);
288
break;
289
case 10:
290
(* routne) (leng[1], pointer[1], leng[2], pointer[2],
291
leng[3], pointer[3], leng[4], pointer[4],
292
leng[5], pointer[5], leng[6], pointer[6],
293
leng[7], pointer[7], leng[8], pointer[8],
294
leng[9], pointer[9], leng[10], pointer[10]);
295
break;
296
case 11:
297
(* routne) (leng[1], pointer[1], leng[2], pointer[2],
298
leng[3], pointer[3], leng[4], pointer[4],
299
leng[5], pointer[5], leng[6], pointer[6],
300
leng[7], pointer[7], leng[8], pointer[8],
301
leng[9], pointer[9], leng[10], pointer[10],
302
leng[11], pointer[11]);
303
break;
304
case 12:
305
(* routne) (leng[1], pointer[1], leng[2], pointer[2],
306
leng[3], pointer[3], leng[4], pointer[4],
307
leng[5], pointer[5], leng[6], pointer[6],
308
leng[7], pointer[7], leng[8], pointer[8],
309
leng[9], pointer[9], leng[10], pointer[10],
310
leng[11], pointer[11], leng[12], pointer[12]);
311
break;
312
}
313
for (i=0; i<*n; i++)
314
free (pointer[i+1]);
315
}
316
#endif /* VMS */
317
#endif
318
319
/* \section{`Magic' numbers} */
320
/* */
321
/* When, for instance, an $F$ is unobserved in a derivative, we might */
322
/* want to give it a special value---a `\idx{magic number}'---possibly in */
323
/* addition to a special value of the $\sigma$, like a negative one. */
324
/* Using such a number in a calculation (by mistake, through ignoring the */
325
/* value of $\sigma$, say) should not allow one to get half-sensible */
326
/* results as one might if this number was $-9999$ or some such. (There */
327
/* is non-enforced connexion between the $F$ and its $\sigma$ in the MTZ */
328
/* file, although one could think of adding extra columns to the file */
329
/* with bit-encoded flags telling whether the $F$ in a given column was */
330
/* observed.) */
331
/* */
332
/* The obvious tactic with \ac{ieee} arithmetic is to use a \idx{NaN} */
333
/* value in such situations. Things may be set up so that we either get */
334
/* an exception on using it in arithmetic or it silently propagates to all */
335
/* values using it and its presence is indicated by a NaN in the output. */
336
/* On a \idx{VAX} architecture we can't use NaN, but there is the */
337
/* possibility of using a */
338
/* `reserved operand'\index{reserved operand|see{Rop}} */
339
/* (`\idx{Rop}') value, */
340
/* which will cause an exception (by experiment: when used for */
341
/* floating-point arithmetic {\em or\/} printed, but not when assigned). */
342
/* The \idx{Convex} native mode is similar, except that the Rop may be */
343
/* printed (in the form {\tt Rop0x}\meta{fraction part}). */
344
/* */
345
/* On, say, the \idx{IBM 370 architecture}---which we don't currently */
346
/* support---anything's a valid floating point number, and the best ploy */
347
/* is probably to use the largest representable number as the `magic' */
348
/* value. This would stand a good chance of raising an overflow */
349
/* exception if used. Anyhow, if such bad use of an undefined value is */
350
/* made in a program due to insufficient checking by the code, it should */
351
/* be spotted on the \ac{ieee} systems and the bug fixed---it's not */
352
/* strictly necessary that it should cause a fatal error on all */
353
/* architectures. */
354
/* */
355
/* We need to provide a means of setting the magic number and checking */
356
/* whether a given value is such. These are architecture-dependent */
357
/* bit-level operations, hence their presence in the C code. */
358
/* */
359
/* The suite doesn't currently use these routines, but should do soon. */
360
/* \subsection{Setting a value: {\tt subroutine qnan(value)}} */
361
/* */
362
/* [[qnan]] was originally a \ft{} [[real function]] returning the value */
363
/* (and actually done in 2 stages) with a subroutine implementation like */
364
/* this called by the \ft{} function to avoid problems under \idx{VMS} */
365
/* and native \idx{Convex}. However, the \idx{f2c} calling convention */
366
/* for a function loses in that case since it assumes a [[double]] value */
367
/* returned which is cast to [[float]] with a SIGFPE, sigh. */
368
/* */
369
/* <magic numbers>= */
370
FORTRAN_SUBR ( QNAN, qnan,
371
(union float_uint_uchar *realnum),
372
(union float_uint_uchar *realnum),
373
(union float_uint_uchar *realnum))
374
{
375
*realnum = ccp4_nan ();
376
}
377
/* \subsection{Testing a value: {\tt int qisnan(\meta{real})}} */
378
/* */
379
/* We want a \ft{} logical function [[qisnan]] to test whether its argument */
380
/* is a \idx{NaN} or \idx{Rop}. We have to do this by writing a C */
381
/* [[int]]-valued procedure and testing the returned value in the \ft{} */
382
/* so that we don't have to assume how it represents logical values. The */
383
/* {\tt diskio}\index{diskio} library module provides the */
384
/* trivial interface [[QISNAN]]. */
385
/* */
386
/* <magic numbers>= */
387
FORTRAN_FUN (int, QISNAN, qisnan,
388
(union float_uint_uchar *realnum),
389
(union float_uint_uchar *realnum),
390
(union float_uint_uchar *realnum))
391
{
392
return (_BTOLV(ccp4_utils_isnan (realnum)));
393
}
394
395
/* \subsection{Absent data test for {\tt mtzlib}: {\tt subroutine */
396
/* ccpbml (\meta{ncols}, \meta{cols})}} */
397
/* In {\tt mtzlib} there's a fudge for \idx{BIOMOL}-convention absence */
398
/* flags, which are re-written to zeroes. To do the real number */
399
/* comparison, though, it's necessary to do a [[qnan]]-type test first. */
400
/* We don't want to call [[qnan]] (which calls [[cisnan]]) on every */
401
/* number in the data file, so the tests are amortised in this routine */
402
/* which deals with a whole array \meta{cols} of length \meta{ncols}. */
403
/* */
404
/* <magic numbers>= */
405
FORTRAN_SUBR ( CCPBML, ccpbml,
406
(int *ncols, union float_uint_uchar cols[]),
407
(int *ncols, union float_uint_uchar cols[]),
408
(int *ncols, union float_uint_uchar cols[]))
409
{
410
ccp4_utils_bml (*ncols, cols) ;
411
}
412
413
/* \subsection{Updating MTZ column ranges: {\tt subroutine ccpwrg */
414
/* (\meta{ncols}, \meta{rcols}, \meta{wmin}, \meta{wmax})}} */
415
/* This is a similar fudge to [[ccpbml]] to avoid [[QISNAN]] calls in */
416
/* updating the MTZ column ranges in {\tt mtzlib}. Note that [[wminmax]] */
417
/* actually indexes a 3-D Fortran array with the first */
418
/* dimension range of 2, indicating minimum and maximum values respectively. */
419
/* */
420
/* <magic numbers>= */
421
FORTRAN_SUBR ( CCPWRG, ccpwrg,
422
(int *ncols, union float_uint_uchar cols[], float wminmax[]),
423
(int *ncols, union float_uint_uchar cols[], float wminmax[]),
424
(int *ncols, union float_uint_uchar cols[], float wminmax[]))
425
{
426
ccp4_utils_wrg (*ncols, cols, wminmax) ;
427
}
428
429
/* \subsection{Routines for Data Harvesting: {\tt subroutine hgetlimits}} */
430
/* Returns largest int and largest float as defined in <limits.h> and */
431
/* <float.h> */
432
FORTRAN_SUBR ( HGETLIMITS, hgetlimits,
433
(int *IValueNotDet, float *ValueNotDet),
434
(int *IValueNotDet, float *ValueNotDet),
435
(int *IValueNotDet, float *ValueNotDet))
436
{
437
ccp4_utils_hgetlimits (IValueNotDet, ValueNotDet);
438
}
439
440
/* Wrap-around for mkdir function. Returns 0 if successful, 1 if directory */
441
/* already exists, and -1 if other error. */
442
FORTRAN_SUBR ( CMKDIR, cmkdir,
443
(const fpstr path, const fpstr cmode, int *result, int path_len, int cmode_len),
444
(const fpstr path, const fpstr cmode, int *result),
445
(const fpstr path, int path_len, const fpstr cmode, int cmode_len, int *result))
446
{
447
char *temp_path, *temp_cmode;
448
449
temp_path = ccp4_FtoCString(FTN_STR(path), FTN_LEN(path));
450
temp_cmode = ccp4_FtoCString(FTN_STR(cmode), FTN_LEN(cmode));
451
452
*result = ccp4_utils_mkdir (temp_path, temp_cmode);
453
free(temp_path);
454
free(temp_cmode);
455
}
456
457
/* Wrap-around for mkdir function. Returns 0 if successful, 1 if directory */
458
/* already exists, and -1 if other error. */
459
FORTRAN_SUBR ( CCHMOD, cchmod,
460
(const fpstr path, const fpstr cmode, int *result, int path_len, int cmode_len),
461
(const fpstr path, const fpstr cmode, int *result),
462
(const fpstr path, int path_len, const fpstr cmode, int cmode_len, int *result))
463
{
464
char *temp_path, *temp_cmode;
465
466
temp_path = ccp4_FtoCString(FTN_STR(path), FTN_LEN(path));
467
temp_cmode = ccp4_FtoCString(FTN_STR(cmode), FTN_LEN(cmode));
468
469
*result = ccp4_utils_chmod (temp_path, temp_cmode);
470
free(temp_path);
471
free(temp_cmode);
472
}
473
474
/* isatty doesnt seem to be in Mircrosoft Visual Studio so this is a fudge */
475
#if defined (CALL_LIKE_MVS)
476
# if CALL_LIKE_MVS == 1
477
int __stdcall ISATTY (int *lunit)
478
{
479
lunit = 0 ;
480
return lunit;
481
}
482
483
/* erfc doesnt seem to be in Mircrosoft Visual Studdio so this is a fudge */
484
float __stdcall ERFC(float *value)
485
{
486
return (float) ccp4_erfc( (double) *value);
487
}
488
489
#else
490
491
int isatty_ (int *lunit)
492
{
493
lunit = 0 ;
494
return lunit;
495
}
496
497
float erfc_ (float *value)
498
{
499
return (float) ccp4_erfc( (double) *value);
500
}
501
502
# endif
503
#endif
504
505
506
#if defined(F2C)
507
/* <f2c support>= */
508
int exit_ (status)
509
int *status;
510
{
511
f_exit (); /* may or may not be registered with
512
exit, depending on the C libraries
513
capabilities, but is idempotent */
514
exit (*status);
515
}
516
517
int time_ ()
518
{
519
return (int) time (NULL);
520
}
521
522
int getpid_ ()
523
{
524
return (int) getpid ();
525
}
526
527
/* following are from libI77/fio.h */
528
#define MXUNIT 100
529
typedef struct
530
{ FILE *ufd; /*0=unconnected*/
531
char *ufnm;
532
long uinode;
533
int udev;
534
int url; /*0=sequential*/
535
flag useek; /*true=can backspace, use dir, ...*/
536
flag ufmt;
537
flag uprnt;
538
flag ublnk;
539
flag uend;
540
flag uwrt; /*last io was write*/
541
flag uscrtch;
542
} unit;
543
extern unit f__units[];
544
#define TRUE_ (1)
545
#define FALSE_ (0)
546
#define err(f,m,s) {if(f) errno= m; else f__fatal(m,s); return(m);}
547
/* end of fio.h extract */
548
549
int isatty_ (lunit)
550
int *lunit;
551
{
552
if (*lunit>=MXUNIT || *lunit<0)
553
err(1,101,"isatty");
554
/* f__units is a table of descriptions for the unit numbers (defined
555
in io.h) with file descriptors rather than streams */
556
return (isatty(fileno((f__units[*lunit]).ufd)) ? TRUE_ : FALSE_);
557
}
558
559
/* FORTRAN gerror intrinsic */
560
int gerror_ (str, Lstr)
561
char *str;
562
int Lstr;
563
{
564
int i;
565
566
if (errno == 0) { /* Avoid `Error 0' or some such message */
567
for (i=1; Lstr; i++)
568
str[i] = ' ';
569
} else {
570
(void) strncpy (str, strerror (errno), Lstr);
571
for (i = strlen (str); i < Lstr; i++) str[i] = ' '; /* pad with spaces */
572
}
573
return 0;
574
}
575
576
/* FORTRAN IErrNo intrinsic */
577
int ierrno_ () {
578
return errno;
579
}
580
581
int itime_ (array)
582
int array[3];
583
{
584
struct tm *lt;
585
time_t tim;
586
tim = time(NULL);
587
lt = localtime(&tim);
588
array[0] = lt->tm_hour; array[1] = lt->tm_min; array[2] = lt->tm_sec;
589
}
590
/* These ought to be intrinsic, but they should only be applied to */
591
/* [[INTEGER]] arguments. The types [[integer]] and [[logical]] are both */
592
/* assumed to be [[int]]. */
593
/* */
594
/* <f2c support>= */
595
int /* integer */ ibset_ (a, b)
596
int /* integer */ *a, *b;
597
{
598
return (*a) | 1<<(*b);
599
}
600
601
int /* integer */ ibclr_ (a, b)
602
int /* integer */ *a, *b;
603
{
604
return (*a) & ~(1<<(*b));
605
}
606
607
int /* logical */ btest_ (a, b)
608
int /* integer */ *a, *b;
609
{
610
return ((((unsigned long) *a)>>(*b)))&1 ? TRUE_ : FALSE_;
611
}
612
#endif /* F2C support */
613
614
615
#if defined (__hpux) || defined (_AIX)
616
/* <AIX and HPUX support>= */
617
618
#ifdef _AIX
619
int isatty_ (int *fd) {
620
return(isatty(*fd));
621
}
622
#endif
623
624
void gerror (str, Lstr)
625
char *str;
626
int Lstr;
627
{
628
int i;
629
630
if (errno == 0) { /* Avoid `Error 0' or some such message */
631
for (i=1; Lstr; i++)
632
str[i] = ' ';
633
} else {
634
(void) strncpy (str, strerror (errno), Lstr);
635
for (i = strlen (str); i < Lstr; i++) str[i] = ' '; /* pad with spaces */
636
}
637
} /* End of gerror (str, Lstr) */
638
639
int ierrno () {
640
return errno;
641
}
642
643
#endif /* HPUX and AIX support */
644
645
646
647
#if ( defined (__APPLE__) && !defined (__GNUC__) )
648
649
/* apple xlf support */
650
void gerror_ (str, Lstr)
651
char *str;
652
int Lstr;
653
{
654
int i;
655
656
if (errno == 0) { /* Avoid `Error 0' or some such message */
657
for (i=1; Lstr; i++)
658
str[i] = ' ';
659
} else {
660
(void) strncpy (str, strerror (errno), Lstr);
661
for (i = strlen (str); i < Lstr; i++) str[i] = ' '; /* pad with spaces */
662
}
663
} /* End of gerror (str, Lstr) */
664
665
int isatty_(int *iunit)
666
{
667
return isatty(*iunit);
668
}
669
670
#endif /* end of apple xlf support */
671
672
673
674
#if ( defined (__linux__) && defined (_CALL_SYSV) )
675
/* linuxppc xlf support */
676
677
void gerror_ (str, Lstr)
678
char *str;
679
int Lstr;
680
{
681
int i;
682
683
if (errno == 0) { /* Avoid `Error 0' or some such message */
684
for (i=1; Lstr; i++)
685
str[i] = ' ';
686
} else {
687
(void) strncpy (str, strerror (errno), Lstr);
688
for (i = strlen (str); i < Lstr; i++) str[i] = ' '; /* pad with spaces */
689
}
690
} /* End of gerror (str, Lstr) */
691
692
int isatty_(int *iunit)
693
{
694
return isatty(*iunit);
695
}
696
697
698
699
#elif defined(G95) || defined (GFORTRAN)
700
/* G95 and GFORTRAN support */
701
702
int isatty_(int *iunit)
703
{
704
return isatty(*iunit);
705
}
706
707
/* FORTRAN gerror intrinsic */
708
int gerror_(str, Lstr)
709
char *str;
710
int Lstr;
711
{
712
int i;
713
714
if (errno == 0) { /* Avoid `Error 0' or some such message */
715
for (i=1; Lstr; i++)
716
str[i] = ' ';
717
} else {
718
(void) strncpy (str, strerror (errno), Lstr);
719
for (i = strlen (str); i < Lstr; i++) str[i] = ' '; /* pad with spaces */
720
}
721
return 0;
722
}
723
724
#endif
725
726
727
#if defined (sun)
728
729
int isatty_(int *iunit)
730
{
731
return isatty(*iunit);
732
}
733
734
#endif
735
736
#if defined(G95) || defined (GFORTRAN)
737
/* FORTRAN IErrNo intrinsic */
738
int ierrno_() {
739
return errno;
740
}
741
742
void ltime_(int *stime, int tarray[9])
743
{
744
int i;
745
struct tm ldatim;
746
747
if (localtime_r((const time_t *) stime, &ldatim) != NULL) {
748
tarray[0] = ldatim.tm_sec;
749
tarray[1] = ldatim.tm_min;
750
tarray[2] = ldatim.tm_hour;
751
tarray[3] = ldatim.tm_mday;
752
tarray[4] = ldatim.tm_mon;
753
tarray[5] = ldatim.tm_year;
754
tarray[6] = ldatim.tm_wday;
755
tarray[7] = ldatim.tm_yday;
756
tarray[8] = ldatim.tm_isdst;
757
} else {
758
for (i=0; i<9; i++)
759
tarray[i] = 0;
760
}
761
762
}
763
764
void idate_ (int *day, int *month, int *year)
765
{
766
struct tm *lt=NULL;
767
time_t tim;
768
tim = time(NULL);
769
lt = localtime(&tim);
770
*day = lt->tm_mday;
771
*month = lt->tm_mon+1; /* need range 1-12 */
772
*year = lt->tm_year + 1900;
773
}
774
775
void gmtime_(int *stime, int gmarray[9])
776
{
777
int i;
778
struct tm udatim;
779
780
if (gmtime_r((const time_t *) stime, &udatim) != NULL) {
781
gmarray[0] = udatim.tm_sec;
782
gmarray[1] = udatim.tm_min;
783
gmarray[2] = udatim.tm_hour;
784
gmarray[3] = udatim.tm_mday;
785
gmarray[4] = udatim.tm_mon;
786
gmarray[5] = udatim.tm_year;
787
gmarray[6] = udatim.tm_wday;
788
gmarray[7] = udatim.tm_yday;
789
gmarray[8] = udatim.tm_isdst;
790
} else {
791
for (i=0; i<9; i++)
792
gmarray[i] = 0;
793
}
794
795
}
796
797
void system_(int *status, char *cmd, int cmd_len)
798
{
799
char *str = calloc( cmd_len+1, sizeof(char));
800
str = strncpy( str, cmd, cmd_len);
801
802
if ( (*status = system( str)) == -1 )
803
printf(" Forked command %s failed\n",cmd);
804
805
free( str);
806
return;
807
}
808
809
#endif
810
811
#if defined (G95)
812
int time_()
813
{
814
int ltim;
815
time_t t_ltim;
816
817
t_ltim = time(NULL);
818
ltim = (int) t_ltim;
819
820
return ltim;
821
}
822
823
#endif /* G95 support */
824
Loggerhead is a web-based interface for Breezy
Version: 2.0.1