static const char *
ncio_ffio_assign(const char *filename) {
static char buffer[BUFLEN];
int istat;
_fcd fnp, fbp;
char *envstr;
char *xtra_assign;
char emptystr='\0';
/* put things into known states */
memset(buffer,'\0',BUFLEN);
errno = ENOERR;
/* set up Fortran character pointers */
fnp = _cptofcd((char *)filename, strlen(filename));
fbp = _cptofcd(buffer, BUFLEN);
/* see if the user has "assigned" to this file */
ASNQFILE(fnp, fbp, &istat);
if (istat == 0) { /* user has already specified an assign */
return buffer;
} else if (istat > 0 || istat < -1) { /* error occured */
errno = EINVAL;
return (const char *) NULL;
} /* istat = -1 -> no assign for file */
envstr = getenv("NETCDF_FFIOSPEC");
if(envstr == (char *) NULL) {
envstr = "bufa:336:2"; /* this should be macroized */
}
/* Insertion by Olaf Heudecker, AWI-Bremerhaven, 12.8.1998
to allow more versatile FFIO-assigns */
/* this is unnecessary and could have been included
* into the NETCDF_FFIOSPEC environment variable */
xtra_assign = getenv("NETCDF_XFFIOSPEC");
if(xtra_assign == (char *) NULL) {
xtra_assign=&emptystr;
}
if (strlen(envstr)+strlen(xtra_assign) + 4 > BUFLEN) {
/* Error: AssignCommand too long */
errno=E2BIG;
return (const char *) NULL;
}
(void) sprintf(buffer,"-F %s %s", envstr,xtra_assign);
fbp = _cptofcd(buffer, strlen(buffer));
ASNFILE(fnp, fbp, &istat);
if (istat == 0) { /* success */
return buffer;
} else { /* error */
errno = EINVAL;
return (const char *) NULL;
}
}
/*
* ASNQFILE - returns the assign attributes for a file name.
*
* Call from Fortran:
*
* CALL ASNQFILE(FNAME, ATTR, ISTAT)
*
* Parameters
*
* FNAME (I) file name
* ATTR (O) receives the assign options for this unit number
* ISTAT (O) 0 if any options were found, -1 if not found,
* >0 error code on error.
*/
void
#ifdef _UNICOS
ASNQFILE(
_fcd fname,
_fcd attrs,
_f_int *istat)
{
#else /* _SOLARIS, __mips, etc. */
asnqfile_(
char *fnamptr,
char *attrptr,
_f_int *istat,
int fnamlen,
int attrlen)
{
_fcd attrs = _cptofcd(attrptr, attrlen);
_fcd fname = _cptofcd(fnamptr, fnamlen);
#endif /* _SOLARIS */
int ret;
char *atstr;
char *cfname;
if ((cfname = _fc_acopy(fname)) == NULL) {
*istat = FENOMEMY;
}
ret = _get_a_options(0, cfname, (unum_t) 0, 0, NULL, &atstr,
_LELVL_RETURN);
free(cfname);
switch (ret) {
case -1: /* an error condition was encountered */
*istat = errno;
break;
case 0: /* attributes were not found */
*istat = NOT_FOUND;
break;
case 1: /* attributes were found */
*istat = FOUND;
if (_c2fcpy(atstr, attrs) == -1)
*istat = ERAS_ATTSPC;
free(atstr);
break;
}
if (*istat != FOUND)
(void)_c2fcpy("", attrs); /* fill with blanks */
return;
}
void Num_symm_zprimme(char *side, char *uplo, int m, int n, Complex_Z alpha,
Complex_Z *a, int lda, Complex_Z *b, int ldb, Complex_Z beta,
Complex_Z *c, int ldc) {
#ifdef NUM_CRAY
_fcd side_fcd, uplo_fcd;
side_fcd = _cptofcd(side, strlen(side));
uplo_fcd = _cptofcd(uplo, strlen(uplo));
ZHEMM(side_fcd, uplo_fcd, &m, &n, &alpha, a, &lda, b, &ldb, &beta, c, &ldc);
#else
ZHEMM(side, uplo, &m, &n, &alpha, a, &lda, b, &ldb, &beta, c, &ldc);
#endif
}
void
pxfexecv_(
char *PATH,
_f_int *LENPATH,
char *ARGV,
_f_int *LENARGV,
_f_int *IARGC,
_f_int *IERROR,
_f_int pathlen,
_f_int argvlen
)
{
_PXFEXECV( _cptofcd(PATH,pathlen), LENPATH, _cptofcd(ARGV,argvlen),
LENARGV, IARGC, IERROR);
}
void Num_gemm_zprimme(char *transa, char *transb, int m, int n, int k,
Complex_Z alpha, Complex_Z *a, int lda, Complex_Z *b, int ldb,
Complex_Z beta, Complex_Z *c, int ldc) {
#ifdef NUM_CRAY
_fcd transa_fcd, transb_fcd;
transa_fcd = _cptofcd(transa, strlen(transa));
transb_fcd = _cptofcd(transb, strlen(transb));
ZGEMM(transa_fcd, transb_fcd, &m, &n, &k, &alpha, a, &lda, b, &ldb, &beta,
c, &ldc);
#else
ZGEMM(transa, transb, &m, &n, &k, &alpha, a, &lda, b, &ldb, &beta, c, &ldc);
#endif
}
void
pxfsetenv_(
char *NAME,
_f_int *LENNAME,
char *VALUE,
_f_int *LENVAL,
_f_int *IOTHERWISE,
_f_int *IERROR,
_f_int namelen,
_f_int valuelen)
{
_PXFSETENV( _cptofcd(NAME, namelen), LENNAME,
_cptofcd(VALUE, valuelen), LENVAL,
IOTHERWISE, IERROR);
return;
}
// - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
void Num_zheev_zprimme(char *jobz, char *uplo, int n, Complex_Z *a, int lda,
double *w, Complex_Z *work, int ldwork, double *rwork, int *info) {
#ifdef NUM_CRAY
_fcd jobz_fcd, uplo_fcd;
jobz_fcd = _cptofcd(jobz, strlen(jobz));
uplo_fcd = _cptofcd(uplo, strlen(uplo));
ZHEEV(jobz_fcd, uplo_fcd, &n, a, &lda, w, work, &ldwork, rwork, info);
#else
ZHEEV(jobz, uplo, &n, a, &lda, w, work, &ldwork, rwork, info);
#endif
}
void
pxfgetcwd_(
char *BUF,
_f_int *ILEN,
_f_int *IERROR,
_f_int buflen)
{
_PXFGETCWD(_cptofcd(BUF, buflen), ILEN, IERROR);
}
void
pxfunlink_ (
char *PATH, /* Character variable containing argument */
_f_int *ILEN, /* Significant length of argument */
_f_int *IERROR, /* Error status */
_f_int pathlen
)
{
_PXFUNLINK(_cptofcd(PATH, pathlen), ILEN, IERROR);
}
void
pxfgetlogin_(
char *S,
_f_int *ILEN,
_f_int *IERROR,
_f_int slen
)
{
_PXFGETLOGIN(_cptofcd(S, slen), ILEN, IERROR);
}
void
rnlcomm_(char *chr, _f_int *mode, _f_int clen)
{
_f_int thechar;
thechar = (_f_int) _getfchar(_cptofcd(chr, (long)clen));
TOGGLE_CHAR(thechar, MRNLCOMM, *mode);
return;
}
/*
* Allow on SPARC systems with its f77 subroutine interface
*/
void
pxfrmdir_(
char *PATH, /* Character ptr to dir path */
_f_int *ILEN, /* Length of pathname */
_f_int *IERROR, /* Error Status */
int lenpath)
{
_PXFRMDIR( _cptofcd(PATH, lenpath), ILEN, IERROR);
return;
}
/* assume default integer */
void
pxfmkfifo_(
char *path,
_f_int *ilen,
_f_int *mode,
_f_int *ierror,
int lenpath)
{
_PXFMKFIFO(_cptofcd(path, lenpath), ilen, mode, ierror);
}
double Num_dlamch_primme(const char *cmach) {
#ifdef NUM_CRAY
_fcd cmach_fcd;
cmach_fcd = _cptofcd(cmach, strlen(cmach));
return (DLAMCH(cmach_fcd));
#else
return (DLAMCH(cmach));
#endif
}
/*
* PXFCHMOD PXF Interface to the chmod(2) system call
* to set file modes for a named file
* Allow on non-UNICOS systems.
*/
void
pxfchmod_(
char *PATH, /* Character variable containing argument */
_f_int *ILEN, /* Significant length of character argument */
_f_int *IAMODE, /* bitwise inclusive OR of file modes */
_f_int *IERROR, /* Error status */
int lenpath
)
{
_PXFCHMOD( _cptofcd(PATH, lenpath), ILEN, IAMODE, IERROR);
}
void
pxfgetpwnam_(
char *NAME,
_f_int *ILEN,
_f_int *JPASSWD,
_f_int *IERROR,
_f_int namelen
)
{
_PXFGETPWNAM(_cptofcd(NAME,namelen),ILEN,JPASSWD,IERROR);
}
void
rnlsep_(char *chr, _f_int *mode, _f_int clen)
{
int thechar;
thechar = (_f_int) _getfchar(_cptofcd(chr, (long)clen));
if (thechar == ' ')
_BLNKSEP = (long) *mode;
TOGGLE_CHAR(thechar, MRNLSEP, *mode);
return;
}
void
pxfcreat_(
char *PATH, /* Character variable containing argument */
_f_int *ILEN, /* Significant length of character argument */
_f_int *IMODE, /* bitwise inclusive OR of file modes */
_f_int *IFILDES, /* integer containing file descriptor */
_f_int *IERROR,
_f_int pathlen
)
{
_PXFCREAT(_cptofcd(PATH,pathlen), ILEN, IMODE, IFILDES, IERROR);
}
/*
* Allow on SPARC systems with its f77 subroutine interface
*/
void
pxfchown_(
char *PATH, /* Character ptr to new dir path */
_f_int *ILEN, /* Length of pathname */
_f_int *IOWNER, /* numeric value of new owner id */
_f_int *IGROUP, /* numeric value of new group id */
_f_int *IERROR, /* Error Status */
int lenpath)
{
_PXFCHOWN(_cptofcd(PATH, lenpath), ILEN, IOWNER, IGROUP, IERROR);
return;
}
void
pxfopendir_(
char *DIRNAME,
_f_int *LENDIRNAME,
_f_int *IOPENDIRID,
_f_int *IERROR,
_f_int dirnamelen
)
{
_PXFOPENDIR(_cptofcd(DIRNAME,dirnamelen),LENDIRNAME,
IOPENDIRID,IERROR);
}
int nw_inp_from_string(Integer rtdb, const char *input)
{
char filename[30];
FILE *file;
#if defined(USE_FCD) || defined(CRAY_T3E) || defined(WIN32)
_fcd fstring;
#else
char fstring[255];
#endif
int status;
const char base[] = "temp";
const char ending[] = ".nw";
int number ;
// This is bad, not 100% sure to be unique, since could be subgroup
if (ga_pgroup_get_world_() != ga_pgroup_get_default_()) {
number = (int) util_sgroup_mygroup_() ;
} else {
number = 0 ;
}
sprintf(filename, "%s%d%s", base,number,ending);
if (ga_nodeid_() == 0) {
if (!(file = fopen(filename,"w"))) {
ga_error("nw_inp_from_string: failed to open temp.nw\n",0);
}
if (fwrite(input, 1, strlen(input), file) != strlen(input)) {
ga_error("nw_inp_from_string: failed to write to temp.nw\n",0);
}
if (fwrite("\n", 1, 1, file) != 1) {
ga_error("nw_inp_from_string: failed to write to temp.nw\n",0);
}
(void) fclose(file);
}
#if defined(CRAY_T3E)
fstring = _cptofcd(filename, strlen(filename));
status = nw_inp_from_file_(&rtdb, fstring);
#elif defined(WIN32)
fstring.string = filename;
fstring.len = strlen(filename);
status = nw_inp_from_file_(&rtdb, fstring);
#elif defined(USE_FCD)
#error Do something about _fcd
#else
status = nw_inp_from_file_(&rtdb, filename, strlen(filename));
#endif
if (ga_nodeid_() == 0) (void) unlink(filename);
return status;
}
int
$DFI(
long *len, /* Address of length (in characters) */
_fcd format, /* Address of format (FCD or hollerith) */
_fcd fwa, /* Address of output character string */
fmt_type **_arg4, /* Unused (old pform arugment) */
long *_arg5, /* Unused */
long *_arg6, /* Unused */
fmt_type **pform, /* Address of address of parsed format */
long *inumelt, /* Address of int. array element count */
long *inumcfe /* Address of number of format elements */
)
#endif
{
long mone = -1L;
_fcd fch;
int nargs;
#ifdef _CRAYMPP
va_list args;
_fcd format; /* Address of format (FCD or hollerith) */
_fcd fwa; /* Address of output character string */
fmt_type **_arg4; /* Unused (old pform arugment) */
long *_arg5; /* Unused */
long *_arg6; /* Unused */
fmt_type **pform; /* Address of address of parsed format */
long *inumelt; /* Address of int. array element count */
long *inumcfe; /* Address of number of format elements */
va_start(args, len);
format = va_arg(args, _fcd);
fwa = va_arg(args, _fcd);
#endif
if (*len <= 0) /* If length is zero or negative */
_ferr(NULL, FEDECDRL); /* Invalid DECODE record length */
/* Insert length in character descriptor */
fch = _cptofcd(_fcdtocp(fwa), *len);
nargs = _numargs();
#ifdef _CRAYMPP
if (nargs >= ARGS_7) {
_arg4 = va_arg(args, fmt_type **);
_arg5 = va_arg(args, long *);
_arg6 = va_arg(args, long *);
pform = va_arg(args, fmt_type **);
if (nargs >= ARGS_9) {
inumelt = va_arg(args, long *);
inumcfe = va_arg(args, long *);
}
void Num_gemv_zprimme(char *transa, int m, int n, Complex_Z alpha, Complex_Z *a,
int lda, Complex_Z *x, int incx, Complex_Z beta, Complex_Z *y, int incy) {
#ifdef NUM_CRAY
_fcd transa_fcd;
transa_fcd = _cptofcd(transa, strlen(transa));
ZGEMV(transa_fcd, &m, &n, &alpha, a, &lda, x, &incx, &beta, y, &incy);
#else
ZGEMV(transa, &m, &n, &alpha, a, &lda, x, &incx, &beta, y, &incy);
#endif
}
EXPORT_MPI_API void FORTRAN_API mpi_init_( MPI_Fint *ierr )
{
#ifdef WIN32
extern void mpir_init_bottom_win32(void*);
mpir_init_bottom_win32(&MPIPRIV);
*ierr = MPI_Init( 0, 0 );
#else
int Argc;
MPI_Fint i, argsize = 1024;
char **Argv, *p;
int ArgcSave; /* Save the argument count */
char **ArgvSave, /* Save the pointer to the argument vector */
**ArgvValSave; /* Save the ENTRIES in the argument vector */
#ifdef MPI_CRAY
_fcd tmparg;
#endif
/* Recover the args with the Fortran routines iargc_ and getarg_ */
ArgcSave = Argc = mpir_iargc_() + 1;
ArgvSave = Argv = (char **)MALLOC( Argc * sizeof(char *) );
ArgvValSave = (char **)MALLOC( Argc * sizeof(char *) );
if (!Argv || !ArgvValSave) {
*ierr = MPIR_ERROR( (struct MPIR_COMMUNICATOR *)0, MPI_ERR_EXHAUSTED,
"MPI_INIT" );
return;
}
for (i=0; i<Argc; i++) {
ArgvValSave[i] = Argv[i] = (char *)MALLOC( argsize + 1 );
if (!Argv[i]) {
*ierr = MPIR_ERROR( (struct MPIR_COMMUNICATOR *)0,
MPI_ERR_EXHAUSTED,
"MPI_INIT" );
return;
}
#ifdef MPI_CRAY
tmparg = _cptofcd( Argv[i], argsize );
mpir_getarg_( &i, tmparg );
#else
mpir_getarg_( &i, Argv[i], argsize );
#endif
DEBUG(MPID_trvalid( "after getarg" ); fflush(stderr););
/* Trim trailing blanks */
p = Argv[i] + argsize - 1;
while (p >= Argv[i]) {
if (*p != ' ' && *p) {
p[1] = '\0';
break;
}
p--;
}
}
void
pxfopen_(
char *PATH, /* Character variable containing argument */
_f_int *ILEN, /* Significant length of argument */
_f_int *IOPENFLAG, /* flag passed to open */
_f_int *IMODE, /* mode passed to open */
_f_int *IFILDES, /* file descriptor returned in this argument */
_f_int *IERROR, /* Error status */
_f_int pathlen
)
{
_PXFOPEN(_cptofcd(PATH,pathlen), ILEN, IOPENFLAG,
IMODE, IFILDES, IERROR);
}
void Num_zhetrs_zprimme(char *uplo, int n, int nrhs, Complex_Z *a, int lda,
int *ipivot, Complex_Z *b, int ldb, int *info) {
#ifdef NUM_CRAY
_fcd uplo_fcd;
uplo_fcd = _cptofcd(uplo, strlen(uplo));
ZHETRS(uplo_fcd, &n, &nrhs, a, &lda, ipivot, b, &ldb, info);
#else
ZHETRS(uplo, &n, &nrhs, a, &lda, ipivot, b, &ldb, info);
#endif
}
void IteratedClassicalGS_bi_old(complex v[], double *vnrm, int n, int m, complex A[],
complex work1[]) {
const double alpha = 0.5;
double vnrm_old;
int i, n2, isorth = 0;
complex CMONE, CONE, CZERO;
#ifdef CRAY
char * cupl_c = "C", *cupl_n = "N";
_fcd fupl_c, fupl_n;
fupl_c = _cptofcd(cupl_c, strlen(cupl_c));
fupl_n = _cptofcd(cupl_n, strlen(cupl_n));
#else
char * fupl_c = "C", *fupl_n = "N";
#endif
n2 = 2*n;
CMONE.re = -1.; CMONE.im=0.;
CONE.re = 1.; CONE.im=0.;
CZERO.re = 0.; CZERO.im=0.;
vnrm_old = _FT(dnrm2)(&n2, (double*) v, &ONE);
for (i = 0; !isorth && i < max_cgs_it_bi; i ++) {
_FT(zgemv)(fupl_c, &n, &m, &CONE, A, &n, v, &ONE, &CZERO, work1, &ONE, 1);
_FT(zgemv)(fupl_n, &n, &m, &CMONE, A, &n, work1, &ONE, &CONE, v, &ONE, 1);
(*vnrm) = _FT(dnrm2)(&n2, (double*) v, &ONE);
isorth=((*vnrm) > alpha*vnrm_old);
vnrm_old = (*vnrm);
}
if (i >= max_cgs_it_bi) {
/* errorhandler(400,""); */
}
}
void Num_zhetrf_zprimme(char *uplo, int n, Complex_Z *a, int lda, int *ipivot,
Complex_Z *work, int ldwork, int *info) {
#ifdef NUM_CRAY
_fcd uplo_fcd;
uplo_fcd = _cptofcd(uplo, strlen(uplo));
ZHETRF(uplo_fcd, &n, a, &lda, ipivot, work, &ldwork, info);
#else
ZHETRF(uplo, &n, a, &lda, ipivot, work, &ldwork, info);
#endif
}
/* assume integer(kind=8) */
void
pxfmkfifo64_(
char *path,
_f_int8 *ilen,
_f_int8 *mode,
_f_int8 *ierror,
int lenpath)
{
_f_int ierror4;
_f_int ilen4;
_f_int mode4;
ilen4 = *ilen;
mode4 = *mode;
_PXFMKFIFO(_cptofcd(path, lenpath), &ilen4, &mode4, &ierror4);
*ierror = ierror4;
}
void
_ADJUSTR_(
_fcd result,
_fcd string)
{
char *rptr, *sptr;
int lenr, lens;
int i, j;
char *tptr;
/* Split fcds for source and result into component parts */
lens = _fcdlen(string);
sptr = _fcdtocp(string);
lenr = _fcdlen(result);
rptr = _fcdtocp(result);
/*
* Set temporary pointer to end of source string. Work backwards
* until a non-blank character is found. This will give the number
* of characters to copy into result. Do not dereference tptr if
* it is a zero-length string.
*/
tptr = (char *) sptr;
tptr += lens - 1;
for (i = lens; i > 0 && *tptr == ' '; tptr--, i--) ;
/*
* Set entire result to ' 's. Then, set temporary pointer to point
* to the first character after the required number of blanks, and
* copy source (without trailing blanks) to this spot.
*/
(void) memset (rptr, ' ', lenr);
tptr = (char *) rptr;
tptr += lenr - i;
(void) strncpy (tptr, sptr, i);
/* convert result to fcd */
result = _cptofcd (rptr, lenr);
return;
}
