void FC_FUNC_(oct_dirname, OCT_DIRNAME)
(STR_F_TYPE fnam, STR_F_TYPE dnam STR_ARG2)
{
char *fn=NULL, *dn=NULL;
TO_C_STR1(fnam, fn);
dn = dirname(fn);
if(dn!=NULL){
TO_F_STR2(dn, dnam);
}else{
TO_F_STR2("", dnam);
}
free(fn);
return;
}
void FC_FUNC_(oct_basename, OCT_BASENAME)
(STR_F_TYPE fnam, STR_F_TYPE bnam STR_ARG2)
{
char *fn=NULL, *bn=NULL;
TO_C_STR1(fnam, fn);
bn = basename(fn);
free(fn);
if(bn!=NULL){
TO_F_STR2(bn, bnam);
}else{
TO_F_STR2("", bnam);
}
return;
}
void FC_FUNC_(write_binary,WRITE_BINARY)
(const int * np, void * f, int * type, int * ierr, STR_F_TYPE fname STR_ARG1)
{
header_t * h;
char * filename;
int fd;
ssize_t moved;
h = (header_t *) malloc(sizeof(header_t));
assert(h != NULL);
*ierr = 0;
TO_C_STR1(fname, filename);
fd = open (filename, O_WRONLY | O_CREAT | O_TRUNC,
S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH );
if( fd < 0 ) {
inf_error("octopus.write_binary", ierr);
*ierr = 2;
return;
}
free(filename);
/* create header */
init_header(h);
h->np = *np;
h->type = *type;
/* write header */
moved = write(fd, h, sizeof(header_t));
if(moved < sizeof(header_t)){
inf_error("octopus.write_binary", ierr);
close(fd);
return;
}
/* now write the values */
moved = write(fd, f, (*np)*size_of[(*type)]);
if(moved < (*np)*size_of[(*type)]){
inf_error("octopus.write_binary", ierr);
}
/* close the file */
close(fd);
free(h);
}
void FC_FUNC_(oct_getenv, OCT_GETENV)
(STR_F_TYPE var, STR_F_TYPE value STR_ARG2)
{
char *name_c, *var_c;
TO_C_STR1(var, name_c);
var_c = getenv(name_c);
free(name_c);
if(var_c != NULL){
TO_F_STR2(var_c, value);
}else{
TO_F_STR2("", value);
}
}
void FC_FUNC_(oct_realpath, OCT_REALPATH)
(STR_F_TYPE fnam, STR_F_TYPE rnam STR_ARG2)
{
char *fn=NULL, *rn=NULL;
TO_C_STR1(fnam, fn);
rn = realpath(fn, NULL);
free(fn);
if(rn!=NULL){
TO_F_STR2(rn, rnam);
}else{
TO_F_STR2("", rnam);
}
free(rn);
return;
}
int FC_FUNC_(oct_dir_exists, OCT_DIR_EXISTS)
(STR_F_TYPE name STR_ARG1)
{
int ierr;
char *name_c;
struct stat statbuf;
TO_C_STR1(name, name_c);
ierr = stat(name_c, &statbuf);
free(name_c);
if(ierr == 0)
{
return S_ISDIR(statbuf.st_mode);
}
else
{
return 0;
}
}
void FC_FUNC_(getopt_octopus, GETOPT_OCTOPUS)
(STR_F_TYPE config_str STR_ARG1)
{
int c;
char* config_str_c;
#if defined(HAVE_GETOPT_LONG)
static struct option long_options[] =
{
{"help", no_argument, 0, 'h'},
{"version", no_argument, 0, 'v'},
{"config", no_argument, 0, 'c'},
{0, 0, 0, 0}
};
#endif
while (1) {
int option_index = 0;
#if defined(HAVE_GETOPT_LONG)
c = getopt_long(argc, argv, "hvc", long_options, &option_index);
#else
c = getopt(argc, argv, "hvc");
#endif
if (c == -1) break;
switch (c) {
case 'h':
octopus_help();
break;
case 'v':
printf("octopus %s (svn version %s)\n", PACKAGE_VERSION, LATEST_SVN);
exit(0);
break;
case 'c':
TO_C_STR1(config_str, config_str_c);
printf("%s\n", config_str_c);
exit(0);
break;
}
}
if (optind < argc) octopus_help();
}
void FC_FUNC_(get_info_binary,GET_INFO_BINARY)
(int * np, int * type, int * ierr, STR_F_TYPE fname STR_ARG1)
{
header_t * h;
char * filename;
int fd;
ssize_t moved;
int correct_endianness;
TO_C_STR1(fname, filename);
fd = open(filename, O_RDONLY);
if(fd < 0){
*ierr = 2;
return;
}
free(filename);
h = (header_t *) malloc(sizeof(header_t));
assert(h != NULL);
/* read header */
moved = read(fd, h, sizeof(header_t));
close(fd);
if ( moved != sizeof(header_t) ) {
/* we couldn't read the complete header */
*ierr = 3;
return;
}
*ierr = check_header(h, &correct_endianness);
if( *ierr != 0 ) return;
*np = h->np;
*type = (int) h->type;
free(h);
}
void FC_FUNC_(oct_mkdir, OCT_MKDIR)
(STR_F_TYPE name STR_ARG1)
{
struct stat buf;
char *name_c;
TO_C_STR1(name, name_c);
if(!*name_c) return;
if(stat(name_c, &buf) == 0){
free(name_c);
return;
}
#ifndef _WIN32
mkdir(name_c, 0775);
#else
mkdir(name_c);
#endif
free(name_c);
}
void FC_FUNC_(f90_cl_build_program, F90_CL_BUILD_PROGRAM)
(cl_program * program, cl_context * context, cl_device_id * device, STR_F_TYPE file_name_f STR_ARG1){
FILE * source_file;
size_t szSourceLength;
char* cSourceString;
char * file_name;
cl_int status;
char device_string[2048];
int ext_khr_fp64, ext_amd_fp64;
size_t len;
char buffer[5000];
TO_C_STR1(file_name_f, file_name);
/* open the OpenCL source code file */
source_file = fopen(file_name, "rb");
if(source_file == 0){
fprintf(stderr, "Error: Failed to open file %s\n", file_name);
exit(1);
} else {
printf("Info: compiling OpenCL code %s\n", file_name);
}
/* get the length of the source code */
fseek(source_file, 0, SEEK_END);
szSourceLength = ftell(source_file);
fseek(source_file, 0, SEEK_SET);
/* allocate a buffer for the source code string and read it in */
cSourceString = (char *) malloc((szSourceLength + 1)*sizeof(char));
fread(cSourceString, szSourceLength, 1, source_file);
fclose(source_file);
cSourceString[szSourceLength] = '\0';
clGetDeviceInfo(*device, CL_DEVICE_EXTENSIONS, sizeof(device_string), &device_string, NULL);
ext_khr_fp64 = (strstr(device_string, "cl_khr_fp64") != NULL);
ext_amd_fp64 = (strstr(device_string, "cl_amd_fp64") != NULL);
*program = clCreateProgramWithSource(*context, 1, (const char**)&cSourceString, NULL, &status);
if(ext_khr_fp64){
status = clBuildProgram(*program, 0, NULL, "-DEXT_KHR_FP64 -cl-mad-enable", NULL, NULL);
} else if(ext_amd_fp64) {
status = clBuildProgram(*program, 0, NULL, "-DEXT_AMD_FP64", NULL, NULL);
} else {
fprintf(stderr, "Error: double precision not supported\n");
exit(1);
}
clGetProgramBuildInfo (*program, *device,
CL_PROGRAM_BUILD_LOG, sizeof (buffer), buffer,
&len);
/* Print the compilation log */
if(len > 0) printf("%s\n\n", buffer);
if(status != CL_SUCCESS){
clGetProgramBuildInfo (*program, *device,
CL_PROGRAM_BUILD_LOG, sizeof (buffer), buffer,
&len);
fprintf(stderr, "Error: compilation of file %s failed.\n", file_name);
exit(1);
}
free(file_name);
}
void FC_FUNC_(oct_printrecipe, OCT_PRINTRECIPE)
(STR_F_TYPE _dir, STR_F_TYPE filename STR_ARG2)
{
#if defined(HAVE_SCANDIR) && defined(HAVE_ALPHASORT)
char *lang, *tmp, dir[512];
struct dirent **namelist;
int ii, nn;
gsl_rng *rng;
/* get language */
lang = getenv("LANG");
if(lang == NULL) lang = "en";
/* convert directory from Fortran to C string */
TO_C_STR1(_dir, tmp);
strcpy(dir, tmp);
free(tmp);
strcat(dir, "/recipes");
/* check out if lang dir exists */
nn = scandir(dir, &namelist, 0, alphasort);
if (nn < 0){
printf("Directory does not exist: %s", dir);
return;
}
for(ii=0; ii<nn; ii++)
if(strncmp(lang, namelist[ii]->d_name, 2) == 0){
strcat(dir, "/");
strcat(dir, namelist[ii]->d_name);
break;
}
if(ii == nn)
strcat(dir, "/en"); /* default */
/* clean up */
for(ii=0; ii<nn; ii++)
free(namelist[ii]);
free(namelist);
/* now we read the recipes */
nn = scandir(dir, &namelist, 0, alphasort);
/* initialize random numbers */
gsl_rng_env_setup();
rng = gsl_rng_alloc(gsl_rng_default);
gsl_rng_set(rng, random_seed());
ii = gsl_rng_uniform_int(rng, nn - 2);
gsl_rng_free(rng);
strcat(dir, "/");
strcat(dir, namelist[ii+2]->d_name); /* skip ./ and ../ */
/* clean up again */
for(ii=0; ii<nn; ii++)
free(namelist[ii]);
free(namelist);
TO_F_STR2(dir, filename);
#else
printf("Sorry, recipes cannot be printed unless scandir and alphasort are available with your C compiler.\n");
#endif
}
void FC_FUNC_(set_clarg, SET_CLARG)(int *i, STR_F_TYPE arg STR_ARG1)
{
char *c;
TO_C_STR1(arg, c)
argv[*i] = c;
}
/* --------------------------------------------------------- */
void FC_FUNC_(varinfo_init, VARINFO_INIT)
(STR_F_TYPE const fname STR_ARG1)
{
char line[256], *fname_c;
FILE *in;
var_type *lvar = NULL;
opt_type *lopt;
TO_C_STR1(fname, fname_c);
in = fopen(fname_c, "r");
free(fname_c);
if(!in) {
return;
}
while(fgets(line, 256, in)) {
if(strncasecmp("Variable", line, 8) == 0) {
char *s;
get_token(line+9, &s);
if(s) { /* found a token */
if(!lvar) {
lvar = (var_type *) malloc(sizeof(var_type));
vars = lvar;
} else {
lvar->next = (var_type *) malloc(sizeof(var_type));
lvar = lvar->next;
}
lvar->name = s;
lvar->desc = NULL;
lvar->type = NULL;
lvar->default_str = NULL;
lvar->section = NULL;
lvar->opt = NULL;
lvar->next = NULL;
lopt = NULL;
}
continue;
}
/* if no variable was found continue */
if(!lvar) continue;
if(strncasecmp("Type", line, 4) == 0)
get_token(line+5, &(lvar->type));
if(strncasecmp("Default", line, 7) == 0)
get_token(line+8, &(lvar->default_str));
if(strncasecmp("Section", line, 7) == 0) {
char *s = line+7;
for(; *s!='\0' && isspace(*s); s++);
lvar->section = strdup(s);
}
if(strncasecmp("Description", line, 11) == 0) {
if(lvar->desc) { /* if repeated delete old description */
free(lvar->desc);
lvar->desc = NULL;
}
get_text(in, &(lvar->desc));
}
if(strncasecmp("Option", line, 6) == 0) {
char *name, *value, *s;
s = get_token(line+6, &name);
if(name) get_token(s, &value);
if(name) { /* found an option */
if(!lopt) {
lopt = (opt_type *) malloc(sizeof(opt_type));
lvar->opt = lopt;
} else {
lopt->next = (opt_type *) malloc(sizeof(var_type));
lopt = lopt->next;
}
lopt->name = name;
lopt->value = value;
lopt->desc = NULL;
get_text(in, &(lopt->desc));
lopt->next = NULL;
}
}
}
fclose(in);
}
void FC_FUNC_(read_binary,READ_BINARY)
(const int * np, const int * offset, byte * f, int * output_type, int * ierr, STR_F_TYPE fname STR_ARG1)
{
header_t * h;
char * filename;
int fd, i;
ssize_t moved;
int correct_endianness;
byte * read_f;
TO_C_STR1(fname, filename);
fd = open(filename, O_RDONLY);
free(filename);
if(fd < 0){
*ierr = 2;
return;
}
h = (header_t *) malloc(sizeof(header_t));
assert(h != NULL);
/* read header */
moved = read(fd, h, sizeof(header_t));
if ( moved != sizeof(header_t) ) {
/* we couldn't read the complete header */
*ierr = 3;
return;
}
*ierr = check_header(h, &correct_endianness);
if( *ierr != 0 ) return;
/* check whether the sizes match */
if( h->np < *np + *offset ){ *ierr = 4; return; }
if( h->type == *output_type){
/* format is the same, we just read */
read_f = f;
} else {
/*format is not the same, we store into a temporary array */
read_f =(byte *) malloc((*np)*size_of[h->type]);
}
/* set the start point */
if(*offset != 0) lseek(fd, (*offset)*size_of[h->type], SEEK_CUR);
/* now read the values and close the file */
moved = read(fd, read_f, (*np)*size_of[h->type]);
if ( moved != (*np)*size_of[h->type]) {
/* we couldn't read the whole dataset */
*ierr = 3;
return;
}
close(fd);
/* convert endianness */
if(correct_endianness) {
for(i=0; i < (*np)*size_of[h->type] ; i+=base_size_of[h->type])
endian_convert(base_size_of[h->type], (char *) (read_f + i));
}
/* convert values if it is necessary */
if( h->type != *output_type ){
if(is_integer[h->type] || is_integer[*output_type]){
*ierr = 5;
} else {
for(i=0; i < *np ; i++)
convert( (multi *) (read_f + i*size_of[h->type]),
(multi *) (f + i*size_of[*output_type]),
h->type, *output_type);
free(read_f);
/* set the error code according to the conversion done (see src/out_inc.F90 ) */
if ( h->type == TYPE_FLOAT ) *ierr = -1;
if ( h->type == TYPE_FLOAT_COMPLEX ) *ierr = -2;
if ( h->type == TYPE_DOUBLE ) *ierr = -3;
if ( h->type == TYPE_DOUBLE_COMPLEX ) *ierr = -4;
}
}
free(h);
}