Convert a code from FORTRAN to C - c++

I have the following FORTRAN code which I need to convert to C or C++. I already tried using f2c, but it didn't work out. It has something to do with conversion from Lambert Conformal wind vector to a True-North oriented vector.
Is anyone experienced in FORTRAN who could possibly help?
PARAMETER ( ROTCON_P = 0.422618 )
PARAMETER ( LON_XX_P = -95.0 )
PARAMETER ( LAT_TAN_P = 25.0 )
do j=1,ny_p
do i=1,nx_p
angle2 = rotcon_p*(olon(i,j)-lon_xx_p)*0.017453
sinx2 = sin(angle2)
cosx2 = cos(angle2)
do k=1,nzp_p
ut = u(i,j,k)
vt = v(i,j,k)
un(i,j,k) = cosx2*ut+sinx2*vt
vn(i,j,k) =-sinx2*ut+cosx2*vt
end if
end do
end do
Thanks a lot for any help or tip.

This will get you started - I didn't try to compile it, but it's close to what you're going to need. I assumed that the arrays olon, u, v, un, and vn are passed in to your function as pointers.
const double rotcon_p = 0.422618;
const double lon_xx_p = -95.0;
const double lat_tan_p = 25.0;
for (j=0;j<ny_p;++j)
{
for (i=0,i<nx_p;++i)
{
double angle2 = rotcon_p*(olon[i][j]-lon_xx_p)*0.017453;
double sinx2 = sin(angle2);
double cosx2 = cos(angle2);
for (k=0;k<nsp_p;++k)
{
double ut = u[i][j][k]
double vt = v[i][j][k]
un[i][j][k] = cosx2*ut+sinx2*vt
vn[i][j][k] =-sinx2*ut+cosx2*vt
}
}
}
If you're staying completely in c/c++ this will be fine, if you're mixing FORTRAN and c/c++, you need to know that FORTRAN and c/c++ index their arrays backwards, so you may have to swap your indices to make it work
const double rotcon_p = 0.422618;
const double lon_xx_p = -95.0;
const double lat_tan_p = 25.0;
for (j=0;j<ny_p;++j)
{
for (i=0,i<nx_p;++i)
{
double angle2 = rotcon_p*(olon[j][i]-lon_xx_p)*0.017453;
double sinx2 = sin(angle2);
double cosx2 = cos(angle2);
for (k=0;k<nsp_p;++k)
{
double ut = u[k][j][i]
double vt = v[k][j][i]
un[k][j][i] = cosx2*ut+sinx2*vt
vn[k][j][i] =-sinx2*ut+cosx2*vt
}
}
}
But I don't have enough context for your problem to tell you which you need to do.

I speak Fortran as well as Tarzan speaks English, but this should be the gist of it in C:
#include <math.h>
const double ROTCON_P = 0.422618;
const double LON_XX_P = -95.0;
const double LAT_TAN_P = 25.0;
int i, j, k;
double angle2, sinx2, cosx2, ut, vt;
double un[nzp_p][ny_p][nx_p];
double vn[nzp_p][ny_p][nx_p];
for (j=0; j<ny_p; ++j) {
for (i=0; i<nx_p; ++i) {
angle2 = ROTCON_P * (olon[j][i] - LON_XX_P) * 0.017453;
sinx2 = sin(angle2);
cosx2 = cos(angle2);
for (k=0; k<nzp_p; ++k) {
ut = u[k][j][i];
vt = v[k][j][i];
un[k][j][i] = (cosx2 * ut) + (sinx2 * vt);
vn[k][j][i] = (-1 * sinx2 * ut) + (cosx2 * vt);
}
}
}
You will need to declare olon, u, v, nx_p, ny_p, and nzp_p somewhere and assign them a value before running this code. There is not enough context info given for me to know exactly what they are.

This is a fragment of code, which may be why f2c didn't work. Plus, as already pointed out, most likely the "end if" should be "end do".
If you have Fortran subroutines that are tested and do the calculation that you need, you can call them from C. You declare the arguments of the Fortran subroutine using the ISO C Binding of Fortran, then the Fortran compiler will use the C API so that the routine is callable from C. This short code block is easy to translate; something long and complicated might be better to reuse.

Related

C++ boost library to generate negative binomial random variables

I'm new to C++ and I'm using the boost library to generate random variables. I want to generate random variables from a negative binomial distribution.
The first parameter of boost::random::negative_binomial_distribution<int> freq_nb(r, p); has to be an integer. I want to expand that to a real value. Therefore I would like to use a poisson-gamma mixture, but I fail to.
Here's an excerpt from my code:
int nr_sim = 1000000;
double mean = 2.0;
double variance = 15.0;
double r = mean * mean / (variance - mean);
double p = mean / variance;
double beta = (1 - p) / p;
typedef boost::mt19937 RNGType;
RNGType rng(5);
boost::random::gamma_distribution<double> my_gamma(r, beta);
boost::random::poisson_distribution<int> my_poi(my_gamma(rng));
int simulated_mean = 0;
for (int i = 0; i < nr_sim; i++) {
simulated_mean += my_poi(rng);
}
double my_result = (double)simulated_mean / (double)nr_sim;
With my_result == 0.5 there is definitly something wrong. Is it my_poi(my_gamma(rng))? If so, what is the correct way to solve that problem?

GSL ODE solver returns -nan although same ODE with same parameters is being solved in python

I use python to solve ODEs using scipy.integrate.odeint. Currently, I am working on a small project where I am using gsl in C++ to solve ODEs. I am trying to solve an ODE but the solver is returning -nan for each time point. Following is my code:
#include <stdio.h>
#include <math.h>
#include <iostream>
#include <gsl/gsl_vector.h>
#include <gsl/gsl_errno.h>
#include <gsl/gsl_matrix.h>
#include <gsl/gsl_odeiv2.h>
struct param_type {
double k;
double n;
double m;
double s;
};
int func (double t, const double y[], double f[], void *params)
{
(void)(t); /* avoid unused parameter warning */
struct param_type *my_params_pointer = (param_type *)params;
double k = my_params_pointer->k;
double n = my_params_pointer->n;
double m = my_params_pointer->m;
double s = my_params_pointer->s;
f[0] = m*k*pow(s,n)*pow((y[0]/(k*pow(s,n))),(m-1)/m);
return GSL_SUCCESS;
}
int * jac;
int main ()
{
struct param_type mu = {1e-07, 1.5, 0.3, 250};
gsl_odeiv2_system sys = {func, NULL, 1, &mu};
gsl_odeiv2_driver * d = gsl_odeiv2_driver_alloc_y_new (&sys, gsl_odeiv2_step_rk8pd, 1e-6, 1e-6, 0.0);
int i;
double t = 0.0, t1 = 10.0;
double step_size = 0.1;
double y[1] = { 1e-06 };
gsl_vector *time = gsl_vector_alloc ((t1 / step_size) + 1);
gsl_vector *fun_val = gsl_vector_alloc ((t1 / step_size) + 1);
for (i = 1; i <= t1/step_size; i++)
{
double ti = i * t1 / (t1 / step_size);
int status = gsl_odeiv2_driver_apply (d, &t, ti, y);
if (status != GSL_SUCCESS)
{
printf ("error, return value=%d\n", status);
break;
}
printf ("%.5e %.5e\n", t, y[0]);
gsl_vector_set (time, i, t);
gsl_vector_set (fun_val, i, y[0]);
}
gsl_vector_add(time, fun_val);
{
FILE * f = fopen ("test.dat", "w");
gsl_vector_fprintf (f, time, "%.5g");
fclose (f);
}
gsl_odeiv2_driver_free (d);
gsl_vector_free (time);
gsl_vector_free (fun_val);
return 0;
}
As mentioned here, I don't need jacobian for an explicit solver that's why I passed NULL pointer for the jac function.
When I run the above code, I get -nan values at all time points.
To cross-check, I wrote the program in python which has the same function and same parameters, solved using scipy.integrate.odeint. It runs and provides a plausible answer.
Following my python code:
import numpy as np
from scipy.integrate import odeint
def nb(y, t, *args):
k = args[0]
n = args[1]
m = args[2]
s = args[3]
return m*k*s**n*(y/(k*s**n))**((m-1)/m)
t = np.linspace(0,10,int(10/0.1))
y0 = 1e-06
k = 1e-07
n = 1.5
m = 0.3
s = 250
res = odeint(nb, y0, t, args=(k,n,m,s)).flatten()
print(res)
Could anyone please help me figure out, what I am doing wrong in the C++ code using GSL for solving the ODE?
Your problem is here:
f[0] = m*k*pow(s,n)*pow((y[0]/(k*pow(s,n))),(m-1)/m);
As the solver proceeds, it may want to sample negative values of y[0]. In Python this makes no problem, in C++ it produces NANs.
To handle this, you can mimic Python's behavior:
auto sign = (y[0] < 0) ? -1.0 : 1.0;
f[0] = sign*m*k*pow(s,n)*pow((std::abs(y[0])/(k*pow(s,n))),(m-1)/m);
or even set sign effectively to 1:
f[0] = m*k*pow(s,n)*pow((std::abs(y[0])/(k*pow(s,n))),(m-1)/m);
After all, raising negative values to noninteger powers is an error unless one considers complex numbers, which is not the case.
Please notice that y[0] was secured with std::abs.

Using the GSL Libraries to Make Splines and Using them for Integration

Say I have a set of N data points. I can use the gsl library gsl_splines.h routines to create a spline of this data. What I would like to do is to use this spline and the gsl integration library to find the integral of these data. I'm working in C here.
In my code, I have generated the splines I'd use, and since the splines are smooth, I'm judging by eye, I'd expect this method would be more efficient than evaluating the splines and using an algorithm like the trapezoid rule to find the integral, but I'm having trouble coming up with a way to piece the two things together.
If you can provide any simple examples, I would appreciate it!
If the gsl libraries aren't what you'd use, I'd be glad to hear any other suggestions.
and since the splines are smooth, I'm judging by eye, I'd expect this method would be more efficient than evaluating the splines and using an algorithm like the trapezoid
This is a fallacy. You're assuming that your data is approximated better by a spline of some order than by a step function, but you have nothing to support that. The only thing you have is a bunch of (x, f(x)) pairs. Using midpoint integration is a perfectly respectable way of approximating the integral here. A big plus: You can easily implement it yourself.
I figured out how to make this happen more quickly and with better accuracy that the trapezoidal rule. The key was to use the spline objects as the members of the structure my_f_params, since the GSL integration demands a gsl_function object,
https://www.gnu.org/software/gsl/doc/html/integration.html#c.gsl_integration_qags.
Here's an example code for integrating 1/x from 1 to 1200, which isn't necessarily beautiful code, I'm a physicist not a computer scientist:
// Complie with
// gcc -w -o Spline_Integration_Test Spline_Integration_Test.c -lgsl -lgslcblas -lm
#include <stdio.h>
#include <math.h>
#include <gsl/gsl_spline.h>
#include <gsl/gsl_integration.h>
#include <time.h>
double funk(double x, void *p);
struct my_f_params { gsl_interp_accel *facc; gsl_spline *fspline; };
double funk(double x, void *p)
{
struct my_f_params * params = (struct my_f_params *)p;
gsl_interp_accel *facc = (params->facc);
gsl_spline *fspline = (params->fspline);
double f = gsl_spline_eval (fspline, x, facc);
return f;
}
int main()
{
int i, N = 10000000;
double *x; x = (double *)malloc((size_t)sizeof(double) * N); memset(x,0,(size_t) sizeof(double)*N);
double *f; f = (double *)malloc((size_t)sizeof(double) * N); memset(f,0,(size_t) sizeof(double)*N);
gsl_interp_accel *facc = gsl_interp_accel_alloc();
gsl_spline *fspline = gsl_spline_alloc (gsl_interp_cspline, N);
x[0] = 0.0;
f[0] = x[0]*x[0];
for(i=1; i<N; i++)
{
x[i] = x[i-1] + 0.001;
f[i] = 1/x[i];
}
gsl_spline_init(fspline, x, f, N);
clock_t begin = clock();
gsl_integration_workspace * w = gsl_integration_workspace_alloc (1000);
struct my_f_params params = { facc, fspline };
double result, error;
gsl_function F;
F.function = &funk;
F.params = &params;
// Beginning GSL/spline integration part
gsl_integration_qags (&F, 1, 1200, 0, 1e-7, 1000, w, &result, &error);
clock_t end = clock();
double time_spent = (double)(end - begin) / CLOCKS_PER_SEC;
printf("Time for Spline Integration: = %9f s \n", time_spent);
// Begining trapezoidal integration part
begin = clock();
double a, b = 0.0;
double delta;
for(i=1000; i<1200*1000; i++)
{
delta = 0.001;
if(i==1||i==N) a = 1.0/x[i];
else a = 2.0/x[i];
b += a*(delta)/2.0;
}
end = clock();
time_spent = (double)(end - begin) / CLOCKS_PER_SEC;
printf("Time for Trapezoidal Integration: = %9f s \n\n", time_spent);
printf ("Result for Spline Integration = %.18f\n", result);
printf ("Estimated error = %.18f\n", error);
printf ("Intervals = %zu\n\n", w->size);
printf("Result for Trapezoidal Integration = %f \n", b);
gsl_integration_workspace_free (w);
free(x); free(f);
return 0;
}

R crashes when calling a Rcpp function in a loop

So I have this Rcpp function in a .cpp file. You'll see that it is calling other custom functions that I don't show for simplicity, but those don't show any problem whatsoever.
// [[Rcpp::export]]
int sim_probability(float present_wealth , int time_left, int n, float mu, float sigma, float r, float gamma, float gu, float gl){
int i;
int count = 0;
float final_wealth;
NumericVector y(time_left);
NumericVector rw(time_left);
for(i=0;i<n;i++){
rw = random_walk(time_left, 0);
y = Y(rw, mu, sigma, r, gamma);
final_wealth = y[time_left-1] - y[0] + present_wealth;
if(final_wealth <= gu && final_wealth >= gl){
count = count + 1;
}
}
return count;
}
Then I can call this function from a .R seamlessly:
library(Rcpp)
sourceCpp("functions.cpp")
sim_probability(present_wealth = 100, time_left = 10, n = 1e3, mu = 0.05, sigma = 0.20, r = 0, gamma = 2, gu = 200, gl = 90)
But, if I call it inside a for loop, no matter how small it is, R crashes without popping any apparent error. The chunk below would make R crash.
for(l in 1:1){
sim_probability(present_wealth = 100, time_left = 10, n = 1e3, mu = 0.05, sigma = 0.20, r = 0, gamma = 2, gu = 200, gl = 90)
}
I've also tried to execute it manually (Ctrl + Enter) many times as fast as I could, and I'm fast enough it also crashes.
I have tried smaller or bigger loops, both out and within the function. It also crashes if it's called from another Rcpp function. I know I shouldn't call Rcpp functions in a R loop. Eventually I intend to call it from another Rcpp function (to generate a matrix of data) but it crashes all the same.
I have followed other cases that I've found googling and tried a few things, as changing to [] brackets for the arrays' index (this question), playing with the gc() garbage collector (as suggested here).
I suspected that something happened with the NumericVector definitions. But as far as I can tell they are declared properly.
It is been fairly pointed out in the comments that this is not a reproducible exaxmple. I'll add down here the missing functions Y() and random_walk():
// [[Rcpp::export]]
NumericVector Y(NumericVector path, float mu, float sigma, float r, float gamma){
int time_step, n, i;
time_step = 1;
float theta, y0, prev, inc_W;
theta = (mu - r) / sigma;
y0 = theta / (sigma*gamma);
n = path.size();
NumericVector output(n);
for(i=0;i<n;i++){
if(i == 0){
prev = y0;
inc_W = path[0];
}else{
prev = output[i-1];
inc_W = path[i] - path[i-1];
}
output[i] = prev + (theta / gamma) * (theta * time_step + inc_W);
}
return output;
}
// [[Rcpp::export]]
NumericVector random_walk(int length, float starting_point){
if(length == 1){return starting_point;}
NumericVector output(length);
output[1] = starting_point;
int i;
for(i=0; i<length; i++){output[i+1] = output[i] + R::rnorm(0,1);}
return output;
}
Edit1: Added more code so it is reproducible.
Edit2: I was assigning local variables when calling the functions. That was dumb from my part, but harmless. The same error still persists. But I've fixed that.
Edit3: As it's been pointed out by Dirk in the comments, I was doing a pointless exercise redefining the rnorm(). Now it's removed and fixed.
The answer has been solved in the comments, by #coatless. I put it here to keep it for future readers. The thing is that the random_walk() function wasn't properly set up correctly.
The problem was that the loop inside the function allowed i to go out of the defined dimension of the vector output. This is just inefficient when called once, yet it works. But it blows up when it's called many times real fast.
So in order to avoid this error and many others, the function should have been defined as
// [[Rcpp::export]]
NumericVector random_walk(int length, float starting_point){
if(length == 0){return starting_point;}
NumericVector output(length);
output[0] = starting_point;
int i;
for(i=0; i<length-1; i++){output[i+1] = output[i] + R::rnorm(0,1);}
return output;
}

Returning double * in function argument

Countless GSL functions return their result as a pointer in their first argument. For instance
int gsl_matrix_get_col (gsl_vector * v, const gsl_matrix * m, size_t j)
My programming level is very low, but I was told such things were impossible with local variables (deleted on end of function), but possible with pointers, as long as they were declared and allocated correctly by the caller function. I find it very strange, such fundamental difference should exist between pointers and normal variables, but I tried to use this storing of results in variables for a simple GSL programme, where I want a function (fetch_eigenvalue()) to output two things. And I fail. My programme is the following:
#include <math.h>
#include <gsl/gsl_matrix.h>
#include <gsl/gsl_blas.h>
/* Parameters */
#define N 3
int CREATE_MATRIX_AND_VECTOR(gsl_matrix *m, gsl_vector *v);
double fetch_eigenvalue(gsl_matrix *M, gsl_vector *v, double *rescos);
int main()
{
gsl_matrix *unit_matrix = gsl_matrix_calloc(N, N); //soon to be unity
gsl_vector *v = gsl_vector_calloc(N); //soon to be unit x vector
double *outcos = (double*)malloc(sizeof(double) );
printf("**********************************************\n");
CREATE_MATRIX_AND_VECTOR(unit_matrix, v);
fetch_eigenvalue(unit_matrix, v, outcos);
printf("==IN MAIN: outcos = %e\n", *outcos);
free((void *)outcos);
gsl_vector_free(v);
gsl_matrix_free(unit_matrix);
printf("**********************************************\n");
return(0);
}
int CREATE_MATRIX_AND_VECTOR(gsl_matrix * m, gsl_vector *v)
{
int i;
for (i = 0; i < N; i++)
{
gsl_matrix_set(m, i, i, 1.0);
}
gsl_vector_set(v, 0, 1.0);
return(0);
}
double fetch_eigenvalue(gsl_matrix *M, gsl_vector *v, double *rescos) //fetches eigenvalue, if Mv is parallel to v within accuracy gvaccu
//rescos is the cosine of the angle between Mv and v
{
int i,lv;
double v0, v1, cos;
double result;
double vnorm, pnorm;
double rdot;
lv = v->size;
double gvaccu = 1e-10;
gsl_vector *prod = gsl_vector_calloc(lv);
gsl_matrix_get_row(prod, M, 0);
if(gsl_blas_dnrm2(prod)==0.0)
{
result = 0.0;
}
else
{
gsl_blas_dgemv( CblasNoTrans,1.0, M, v, 0.0, prod);
gsl_blas_ddot(prod, v, &rdot);
pnorm = gsl_blas_dnrm2(prod);
vnorm = gsl_blas_dnrm2(v);
cos = rdot/pnorm/vnorm;
cos = fabs(cos);
rescos = &cos;
if(fabs(cos -1.0) > gvaccu)
{
result = -1.0;
}
else
{
v0 = gsl_vector_get(v,0);
v1 = gsl_vector_get(prod,0);
result = v1/v0;
}
}
printf("==IN FETCH_EV: COS = %e\n", cos);//print cheat!!
printf("==IN FETCH_EV: RESCOS = %e\n", *rescos);//print cheat!!
gsl_vector_free(prod);
return(result);
}
I run it and get the following output:
ludi#ludi-M17xR4:~/Desktop/Healpix_3.20$ g++ -o wrong_output wrong_output.c -L. -L/sw/lib -I/sw/include -lgsl -lblas && ./wrong_output
**********************************************
==IN FETCH_EV: COS = 1.000000e+00
==IN FETCH_EV: RESCOS = 1.000000e+00
==IN MAIN: outcos = 0.000000e+00
**********************************************
ludi#ludi-M17xR4:~/Desktop/Healpix_3.20$
So, the caller main() knows nothing about what happened inside fetch_eigenvalue(), eventhough I used a pointer. What am I doing wrong? I have the feeling, that I have misunderstood something very essential.
I sum up what you do with the parameter rescos in your fetch_eigenvalue function:
double fetch_eigenvalue(gsl_matrix *M, gsl_vector *v, double *rescos)
{
double cos;
// some code
rescos = &cos;
// some code
return(result);
}
Here you're not modifying the double value pointed by rescos, you're modifying the varaible rescos itself, which is a copy of the variable outcos used in your main.
What you want to do in fetch_eigenvalue is copying the value of cos into the variable pointed by rescos:
double fetch_eigenvalue(gsl_matrix *M, gsl_vector *v, double *rescos)
{
double cos;
// some code
*rescos = cos;
// some code
return(result);
}
EDIT: As stated by the other answers, it's better to avoid malloc when you can, and here you can:
double outcos;
fetch_eigenvalue(unit_matrix, v, &outcos);
I suspect that this is because the statement rescos = &cos; saves into rescos the address of the local variable cos. However, the scope of this variable is only local so that you can not then use it in the main(). I guess what you want to do is to:
change rescos = &cos; to *rescos = cos; in the fetch_eigenvalue function so that the value of cos is stored at the address pointed to by rescos
use merely double outcos; in the main() function, i.e., don't use pointer
call fetch_eigenvalue as fetch_eigenvalue(unit_matrix, v, &outcos);
I don't know anything about GSL, but it appears to be a library that uses C-style interface. To set values from a function, they use pointers. You don't seem to know how to use such an API yet, so here's some hints.
The statements
double *outcos = (double*)malloc(sizeof(double) );
...
fetch_eigenvalue(unit_matrix, v, outcos);
is not how you want to use such an API. Instead, you just define a double variable, and use the address of operator in the call:
double outcos;
...
fetch_eigenvalue(unit_matrix, v, &outcos);
Also, in your method, to assign a value, use don't use
cos = fabs(cos);
rescos = &cos;
but
cos = fabs(cos);
*rescos = cos;
to assign the value to the variable pointed to, not to the pointer.
Hope this helps.