numba TypingError: Cannot unify array(float64, 1d, C) and float64 for 'v_new.2' - global-variables

I'm making value function iteration code for economics study, using python and numba package.
Here's simple description of my problem:
I want to solve maximization problem using brent_max,(similar to scipy.optimization) for kp, given k, v while it converges.
kp is 'next state of k', and it is used for upper bound of maximization problem. so after brent_max calculate the value of kp, I want to save and use it again. That's why I used global option.
Here's my code for the problem and error message.
opt_growth_data = [('α', float64),
('β', float64),
('γ', float64),
('δ', float64),
('grid', float64[:])]
#jitclass(opt_growth_data)
class OptimalGrowth_VI:
def __init__(self, α=0.4, β=0.96, γ=2.0, δ=0.1, grid_max=10, grid_size=500):
self.α, self.β, self.γ, self.δ = α, β, γ, δ
self.grid = np.linspace(0.1, grid_max, grid_size)
def f(self, k):
return k**self.α
def u(self, c):
return c**(1-self.γ) / (1-self.γ)
def objective(self, k, kp, v_array):
f, u, β, δ = self.f, self.u, self.β, self.δ
v = lambda x: interp(self.grid, v_array, x)
return u(f(k) + (1-δ)*k -kp) + β*v(kp)
#njit
def T(v, og_VI):
k0 = og_VI.grid
v_greedy = np.empty_like(v)
v_new = np.empty_like(v)
f, δ = og_VI.f, og_VI.δ
for i in range(len(og_VI.grid)):
if i == 1:
k = k0[i]
else:
k = kp[i]
lower = 1e-10
upper = f(k) + (1-δ)*k
result = brent_max(og_VI.objective, lower, upper, args=(k,v))
v_greedy, v_new = result[0], result[1]
return v_greedy, v_new
def solve_model_VI(og_VI, tol=1e-4, max_iter=1000, print_skip=20):
v = og_VI.grid
i = 0
error = tol + 1
while i < max_iter and error > tol:
v_greedy, v_new = T(v, og_VI)
error = np.max(np.abs(v - v_new))
i += 1
if i % print_skip == 0:
print(f"Error at iteration {i} is {error}.")
global kp
kp = v_greedy
v = v_new
if i == max_iter:
print("Failed to converge!")
if i < max_iter:
print(f"\nConverged in {i} iterations.")
return v_greedy, v_new
og_VI = OptimalGrowth_VI()
k_opt_VI, k_solution = solve_model_VI(og_VI)
TypingError Traceback (most recent call last)
Input In [51], in <module>
1 og_VI = OptimalGrowth_VI()
----> 2 k_opt_VI, k_solution = solve_model_VI(og_VI)
Input In [49], in solve_model_VI(og_VI, tol, max_iter, print_skip)
4 error = tol + 1
6 while i < max_iter and error > tol:
----> 7 v_greedy, v_new = T(v, og_VI)
8 error = np.max(np.abs(v - v_new))
9 i += 1
TypingError: Failed in nopython mode pipeline (step: nopython frontend)
Cannot unify array(float64, 1d, C) and float64 for 'v_new.2', defined at /var/folders/yl/t420gknx17d8ppt9jgws8v700000gn/T/ipykernel_19631/2325054440.py (21)
File "../../../../../var/folders/yl/t420gknx17d8ppt9jgws8v700000gn/T/ipykernel_19631/2325054440.py", line 21:
<source missing, REPL/exec in use?>
During: typing of assignment at /var/folders/yl/t420gknx17d8ppt9jgws8v700000gn/T/ipykernel_19631/2325054440.py (21)
File "../../../../../var/folders/yl/t420gknx17d8ppt9jgws8v700000gn/T/ipykernel_19631/2325054440.py", line 21:
<source missing, REPL/exec in use?>
I don't know what is incorrect in my code. Is it related to numba, or do I made completely incorrect code?
It's related to economic problem, so I made a question to economics stack exchange but could not get an answer. I would be very grateful if you could help even if it bothers you.
I refer to
https://python.quantecon.org/optgrowth.html and
https://python.quantecon.org/optgrowth_fast.html
. thank you for your help.

Related

Julia ERROR: 'Can't Promote to Common Type' for multivariate polynomials in Nemo Library

I am new to Julia and have been trying to compute some polynomials using the Nemo library's multivariate polynomials. I have the following code:
R = GF(2); # create finite field
S, (z, x) = PolynomialRing(R, ["z", "x"]); # Multivariate polynomial
# polynomial initialisations
L = x^0;
E_L = x^0;
E = x*0;
a = z;
w = [1 1 a^3 a^2 a^1 0 0];
n = length(w); #input vector, in terms of a
j = 1;
for i = 1:n
if(w[i] != 0)
L = L*(1-(a^i)*x); # equation for the locator polynomial
if(i != j)
E_L = E_L*(1-(a^j)*x);
end
j = j + 1;
E = E + w[i]*(a^i)*E_L; # LINE WITH ERROR
end
end
I am not entirely sure why the line with the expression for E throws an error.
I have tried a similar thing with the declaration for L: L = L + L*(1-(a^i)*x) to see whether it was something to do with the addition of two polynomials, however, this works fine. Therefore, I am confused as to why E's expression throws an error.
Any help would greatly appreciated! Thanks in advance!

Why two styles of executing Juilia programs are giving different results?

If a run a program written in julia as
sachin#localhost:$ julia mettis.jl then it runs sucessfully, without printing anything, though one print statement is in it.
And Secondly If run it as by going in julia:
sachin#localhost:$ julia
julia> include("mettis.jl")
main (generic function with 1 method)`
julia> main()
Then It gives some error.
I am puzzled why two style of executing is giving different result ?
Here is my code:
using ITensors
using Printf
function ITensors.op(::OpName"expτSS", ::SiteType"S=1/2", s1::Index, s2::Index; τ)
h =
1 / 2 * op("S+", s1) * op("S-", s2) +
1 / 2 * op("S-", s1) * op("S+", s2) +
op("Sz", s1) * op("Sz", s2)
return exp(τ * h)
end
function main(; N=10, cutoff=1E-8, δτ=0.1, beta_max=2.0)
# Make an array of 'site' indices
s = siteinds("S=1/2", N; conserve_qns=true)
# #show s
# Make gates (1,2),(2,3),(3,4),...
gates = ops([("expτSS", (n, n + 1), (τ=-δτ / 2,)) for n in 1:(N - 1)], s)
# Include gates in reverse order to complete Trotter formula
append!(gates, reverse(gates))
# Initial state is infinite-temperature mixed state
rho = MPO(s, "Id") ./ √2
#show inner(rho, H)
# Make H for measuring the energy
terms = OpSum()
for j in 1:(N - 1)
terms += 1 / 2, "S+", j, "S-", j + 1
terms += 1 / 2, "S-", j, "S+", j + 1
terms += "Sz", j, "Sz", j + 1
end
H = MPO(terms, s)
# Do the time evolution by applying the gates
# for Nsteps steps
for β in 0:δτ:beta_max
energy = inner(rho, H)
#printf("β = %.2f energy = %.8f\n", β, energy)
rho = apply(gates, rho; cutoff)main
rho = rho / tr(rho)
end
# #show energy
return nothing
end
There is nothing special about a function called main in Julia and defining a function is different from calling it. Consequently a file mettis.jl with the following code:
function main()
println("Hello, World!")
end
will not "do" anything when run (julia mettis.jl). However if you actually call the function at the end:
function main()
println("Hello, World!")
end
main()
you get the expected result
$ julia mettis.jl
Hello, World!

How to only use the lower bounds and upper bounds for quadratic solver qpsolve from Scilab?

I have a simple question. How do I use the command qpsolve from Scilab if I only want to use the lower bounds and upper bounds limit?
ci <= x <= cs
The command can be used as this:
[x [,iact [,iter [,f]]]] = qpsolve(Q,p,C,b,ci,cs,me)
But I want to use it like this:
x = qpsolve(Q,p,[],[],ci,cs,[])
Only ci and cs should explain the limits for vector x. Unfortunately, the command cannot take empty []. Should I take [] as a row vector of ones or zeros?
https://help.scilab.org/docs/6.0.1/en_US/qpsolve.html
In Scilab 5.5.1 , [] works for C and b but not for me. so C = [];b = [];me = 0; should work.
Why
qpsolve is an interface for qp_solve :
function [x, iact, iter, f]=qpsolve(Q,p,C,b,ci,cs,me)
rhs = argn(2);
if rhs <> 7
error(msprintf(gettext("%s: Wrong number of input argument(s): %d expected.\n"), "qpsolve", 7));
end
C(me+1:$, :) = -C(me+1:$, :);
b(me+1:$) = -b(me+1:$);
// replace boundary contraints by linear constraints
Cb = []; bb = [];
if ci <> [] then
Cb = [Cb; speye(Q)]
bb = [bb; ci]
end
if cs <> [] then
Cb = [Cb; -speye(Q)]
bb = [bb; -cs]
end
C = [C; Cb]; b = [b; bb]
[x, iact, iter, f] = qp_solve(Q, -p, C', b, me)
endfunction
It transform every bound constraints into linear constraints. To begin, it swap the sign of the inequality constraints. To do that, it must know me, ie it must be an integer. Since C and b are empty matrices, is value doesn't matter.
Bonus:
if Q is inversible, you could skip the qpsolve macro and write
x = -Q\p
x(x<ci) = ci(x<ci)
x(x>cs) = cs(x>cs)

Script will not run in SciLab 6.0.0

The script below runs fine in SciLab 5.5.2. In 6.0.0 it crashes when the csim() function is executed (line 21).
For this test set x0 = [1 1.5 .25 .125];
The error reads as;
lsode-- caution... t (=r1) and h (=r2) are
such that t + h = t at next step
(h = step). integration continues
where r1 is : 0.0000000000000D+00 and r2 : 0.0000000000000D+00
lsode-- at t (=r1) with step h (=r2),
corrector does not converge
with abs(h) = hmin
where r1 is : 0.0000000000000D+00 and r2 : 0.0000000000000D+00
Repeated convergence failures (perhaps bad jacobian supplied or wrong choice of jacobian type or tolerances).
at line 6 of function optimbase_checkstatus ( C:\Program Files\scilab-6.0.0\modules\optimization\macros\optimbase\optimbase_checkcostfun.sci line 121 )
at line 14 of function optimbase_checkcostfun ( C:\Program Files\scilab-6.0.0\modules\optimization\macros\optimbase\optimbase_checkcostfun.sci line 33 )
at line 7 of function neldermead_startup ( C:\Program Files\scilab-6.0.0\modules\optimization\macros\neldermead\neldermead_search.sci line 951 )
at line 23 of function neldermead_search ( C:\Program Files\scilab-6.0.0\modules\optimization\macros\neldermead\neldermead_search.sci line 65 )
at line 129 of executed file C:\Users\wensrl\Documents\SciLab\Reference Documentation\pidOptimizer.sce
optimbase_checkcostfun: Cannot evaluate cost function with "[f,index]=costf(x0,1)": ode: lsode exit with state -5.
This errors occurs when the csim function is executed.
I searched for changes to the csim() function between versions 5.5.2 and 6.0.0 and did not find any. Is there a solution that I am missing here?
function [J, index] = costf(x0, index)
global J C oL cL itae OS Ms y u t wgts iteration cost
[lhs, rhs] = argn(0)
if rhs < 1 then
error("x0 is required")
end
kc = x0(1);
ti = x0(2);
td = x0(3);
alpha = x0(4);
// stdDeltaV PID formula
pidFormula = kc * (1 + (1/(ti * %s)) + ...
((td * %s)/(alpha * td * %s + 1)))
// pidFormula = pidCTRL(1, pidParam)
C = syslin('c', pidFormula)
oL = Pd * C
cL = oL /. 1
[y] = csim(u', t, cL)
for i = 1:totalTelements
e(i) = abs(y(i) - u(i)) * dt
end
itae = sum(e)
OS = max(y) - 1
[Se, Re, Te] = sensi(Pd, C);
Ms = norm (Se, %inf);
J = wgts(1) * itae + wgts(2) * OS + wgts(3) * Ms;
endfunction

Compiling A Mexfile using R CMD SHLIB

I am trying to import a number of Fortran 90 codes into R for a project. They were initially written with a mex (matlab integration of Fortran routines) type compilation in mind. This is what one of the codes look like:
# include <fintrf.h>
subroutine mexFunction(nlhs, plhs, nrhs, prhs)
!--------------------------------------------------------------
! MEX file for VFI3FCN routine
!
! log M_{t,t+1} = log \beta + gamma (x_t - x_{t+1})
! gamma = gamA + gamB (x_t - xbar)
!
!--------------------------------------------------------------
implicit none
mwPointer plhs(*), prhs(*)
integer nlhs, nrhs
mwPointer mxGetM, mxGetPr, mxCreateDoubleMatrix
mwPointer nk, nkp, nz, nx, nh
mwSize col_hxz, col_hz, col_xz
! check for proper number of arguments.
if(nrhs .ne. 31) then
call mexErrMsgTxt('31 input variables required.')
elseif(nlhs .ne. 4) then
call mexErrMsgTxt('4 output variables required.')
endif
! get the size of the input array.
nk = mxGetM(prhs(5))
nx = mxGetM(prhs(7))
nz = mxGetM(prhs(11))
nh = mxGetM(prhs(14))
nkp = mxGetM(prhs(16))
col_hxz = nx*nz*nh
col_xz = nx*nz
col_hz = nz*nh
! create matrix for the return arguments.
plhs(1) = mxCreateDoubleMatrix(nk, col_hxz, 0)
plhs(2) = mxCreateDoubleMatrix(nk, col_hxz, 0)
plhs(3) = mxCreateDoubleMatrix(nk, col_hxz, 0)
plhs(4) = mxCreateDoubleMatrix(nk, col_hxz, 0)
call vfi3fcnIEccB(%val(mxGetPr(plhs(1))), nkp)
return
end
subroutine vfi3fcnIEccB(optK, V, I, div, & ! output variables
alp1, alp2, alp3, V0, k, nk, x, xbar, nx, Qx, z, nz, Qz, h, nh, kp, &
alpha, beta, delta, f, gamA, gamB, gP, gN, istar, kmin, kmtrx, ksubm, hmtrx, xmtrx, zmtrx, &
nkp, col_hxz, col_xz, col_hz)
use ifwin
implicit none
! specify input and output variables
integer, intent(in) :: nk, nkp, nx, nz, nh, col_hxz, col_xz, col_hz
real*8, intent(out) :: V(nk, col_hxz), optK(nk, col_hxz), I(nk, col_hxz), div(nk, col_hxz)
real*8, intent(in) :: V0(nk, col_hxz), k(nk), kp(nkp), x(nx), z(nz), Qx(nx, nx), Qz(nz, nz), h(nh)
real*8, intent(in) :: alp1, alp2, alp3, xbar, kmin, alpha, gP, gN, beta, delta, gamA, gamB, f, istar
real*8, intent(in) :: kmtrx(nk, col_hxz), ksubm(nk, col_hz), zmtrx(nk, col_hxz), xmtrx(nk, col_hxz), hmtrx(nk, col_hxz)
! specify intermediate variables
real*8 :: Res(nk, col_hxz), Obj(nk, col_hxz), optKold(nk, col_hxz), Vold(nk, col_hxz), tmpEMV(nkp, col_hz), tmpI(nkp), &
tmpObj(nkp, col_hz), tmpA(nk, col_hxz), tmpQ(nx*nh, nh), detM(nx), stoM(nx), g(nkp), tmpInd(nh, nz)
real*8 :: Qh(nh, nh, nx), Qxh(nx*nh, nx*nh), Qzxh(col_hxz, col_hxz)
real*8 :: hp, d(nh), errK, errV, T1, lapse
integer :: ix, ih, iter, optJ(col_hz), ik, iz, ind(nh, col_xz), subindex(nx, col_hz)
logical*4 :: statConsole
! construct the transition matrix for kh --- there are nx number of these transition matrix: 3-d
Qh = 0.0
do ix = 1, nx
do ih = 1, nh
! compute the predicted next period kh
hp = alp1 + alp2*h(ih) + alp3*(x(ix) - xbar)
! construct transition probability vector
d = abs(h - hp) + 1D-32
Qh(:, ih, ix) = (1/d)/sum(1/d)
end do
end do
! construct the compound transition matrix over (z x h) space
! compound the (x h) space
Qxh = 0.0
do ix = 1, nx
call kron(tmpQ, Qx(:, ix), Qh(:, :, ix), nx, 1, nh, nh)
Qxh(:, (ix - 1)*nh + 1 : ix*nh) = tmpQ
end do
! compound the (z x h) space: h changes the faster, followed by x, and z changes the slowest
call kron(Qzxh, Qz, Qxh, nz, nz, nx*nh, nx*nh)
! available funds for the firm
Res = dexp(xmtrx + zmtrx + hmtrx)*(kmtrx**alpha) + (1 - delta)*kmtrx - f
! initializing
Obj = 0.0
optK = 0.0
optKold = optK + 1.0
Vold = V0
! Some Intermediate Variables Used in Stochastic Discount Factor
detM = beta*dexp((gamA - gamB*xbar)*x + gamB*x**2)
stoM = -(gamA - gamB*xbar + gamB*x)
! Intermediate index vector to facilitate submatrix extracting
ind = reshape((/1 : col_hxz : 1/), (/nh, col_xz/))
do ix = 1, nx
tmpInd = ind(:, ix : col_xz : nx)
do iz = 1, nz
subindex(ix, (iz - 1)*nh + 1 : iz*nh) = tmpInd(:, iz)
end do
end do
! start iterations
errK = 1.0
errV = 1.0
iter = 0
T1 = secnds(0.0)
do
if (errV <= 1D-3 .AND. errK <= 1D-8) then
exit
else
iter = iter + 1
do ix = 1, nx
! next period value function by linear interpolation: nkp by nz*nh matrix
call interp1(tmpEMV, k, detM(ix)*(matmul(dexp(stoM(ix)*xmtrx)*Vold, Qzxh(:, subindex(ix, :)))) - ksubm, kp, &
nk, nkp, col_hz)
! maximize the right-hand size of Bellman equation on EACH grid point of capital stock
do ik = 1, nk
! with istar tmpI is no longer investment but a linear transformation of that
tmpI = (kp - (1.0 - delta)*k(ik))/k(ik) - istar
where (tmpI >= 0.0)
g = gP
elsewhere
g = gN
end where
tmpObj = tmpEMV - spread((g/2.0)*(tmpI**2)*k(ik), 2, col_hz)
! direct discrete maximization
Obj(ik, subindex(ix, :)) = maxval(tmpObj, 1)
optJ = maxloc(tmpObj, 1)
optK(ik, subindex(ix, :)) = kp(optJ)
end do
end do
! update value function and impose limited liability condition
V = max(Res + Obj, 1D-16)
! convergence criterion
errK = maxval(abs(optK - optKold))
errV = maxval(abs(V - Vold))
! revise Initial Guess
Vold = V
optKold = optK
! visual
if (modulo(iter, 50) == 0) then
lapse = secnds(T1)
statConsole = AllocConsole()
print "(a, f10.7, a, f10.7, a, f8.1, a)", " errV:", errV, " errK:", errK, " Time:", lapse, "s"
end if
end if
end do
! visual check on errors
lapse = secnds(T1)
statConsole = AllocConsole()
print "(a, f10.7, a, f10.7, a, f8.1, a)", " errV:", errV, " errK:", errK, " Time:", lapse, "s"
! optimal investment and dividend
I = optK - (1.0 - delta)*kmtrx
tmpA = I/kmtrx - istar
where (tmpA >= 0)
div = Res - optK - (gP/2.0)*(tmpA**2)*kmtrx
elsewhere
div = Res - optK - (gN/2.0)*(tmpA**2)*kmtrx
end where
return
end
subroutine interp1(v, x, y, u, m, n, col)
!-------------------------------------------------------------------------------------------------------
! Linear interpolation routine similar to interp1 with 'linear' as method parameter in Matlab
!
! OUTPUT:
! v - function values on non-grid points (n by col matrix)
!
! INPUT:
! x - grid (m by one vector)
! y - function defined on the grid x (m by col matrix)
! u - non-grid points on which y(x) is to be interpolated (n by one vector)
! m - length of x and y vectors
! n - length of u and v vectors
! col - number of columns of v and y matrices
!
! Four ways to pass array arguments:
! 1. Use explicit-shape arrays and pass the dimension as an argument(most efficient)
! 2. Use assumed-shape arrays and use interface to call external subroutine
! 3. Use assumed-shape arrays and make subroutine internal by using "contains"
! 4. Use assumed-shape arrays and put interface in a module then use module
!
! This subroutine is equavilent to the following matlab call
! v = interp1(x, y, u, 'linear', 'extrap') with x (m by 1), y (m by col), u (n by 1), and v (n by col)
!------------------------------------------------------------------------------------------------------
implicit none
integer :: m, n, col, i, j
real*8, intent(out) :: v(n, col)
real*8, intent(in) :: x(m), y(m, col), u(n)
real*8 :: prob
do i = 1, n
if (u(i) < x(1)) then
! extrapolation to the left
v(i, :) = y(1, :) - (y(2, :) - y(1, :)) * ((x(1) - u(i))/(x(2) - x(1)))
else if (u(i) > x(m)) then
! extrapolation to the right
v(i, :) = y(m, :) + (y(m, :) - y(m-1, :)) * ((u(i) - x(m))/(x(m) - x(m-1)))
else
! interpolation
! find the j such that x(j) <= u(i) < x(j+1)
call bisection(x, u(i), m, j)
prob = (u(i) - x(j))/(x(j+1) - x(j))
v(i, :) = y(j, :)*(1 - prob) + y(j+1, :)*prob
end if
end do
end subroutine interp1
subroutine bisection(list, element, m, k)
!--------------------------------------------------------------------------------
! find index k in list such that (list(k) <= element < list(k+1)
!--------------------------------------------------------------------------------
implicit none
integer*4 :: m, k, first, last, half
real*8 :: list(m), element
first = 1
last = m
do
if (first == (last-1)) exit
half = (first + last)/2
if ( element < list(half) ) then
! discard second half
last = half
else
! discard first half
first = half
end if
end do
k = first
end subroutine bisection
subroutine kron(K, A, B, rowA, colA, rowB, colB)
!--------------------------------------------------------------------------------
! Perform K = kron(A, B); translated directly from kron.m
!
! OUTPUT:
! K -- rowA*rowB by colA*colB matrix
!
! INPUT:
! A -- rowA by colA matrix
! B -- rowB by colB matrix
! rowA, colA, rowB, colB -- integers containing shape information
!--------------------------------------------------------------------------------
implicit none
integer, intent(in) :: rowA, colA, rowB, colB
real*8, intent(in) :: A(rowA, colA), B(rowB, colB)
real*8, intent(out) :: K(rowA*rowB, colA*colB)
integer :: t1(rowA*rowB), t2(colA*colB), i, ia(rowA*rowB), ja(colA*colB), ib(rowA*rowB), jb(colA*colB)
t1 = (/ (i, i = 0, (rowA*rowB - 1)) /)
ia = int(t1/rowB) + 1
ib = mod(t1, rowB) + 1
t2 = (/ (i, i = 0, (colA*colB - 1)) /)
ja = int(t2/colB) + 1
jb = mod(t2, colB) + 1
K = A(ia, ja)*B(ib, jb)
end subroutine kron
My initial plan was to remove the mexFunction subroutine and compile the main Fortran subroutines using the R CMD SHLIB command but then I run into the Rtools compiler not knowing where to find the ifwin library even though I have the library in my intel fortran compiler folder.
So my first question is:
1) Is there a way for me to tell rtools where to find the ifwin library and any other library I need to include? Or is there a way to include the dependency libraries in the R CMD SHLIB command so the compiler can find the necessary libraries and compile?
2) If the answer to two is no, can I some how use the compiled version from Matlab in R. I can compile the file as is in matlab using the mex Zhang_4.f90 command with no errors.
3) Is there a way of setting up an environment in Visual Studio 2015 so I can compile Fortran subroutines for use in R using the Intel compiler?
When I take out the mexFunction subroutine and try compiling the rest of the code, I get the following error:
D:\SS_Programming\Fortran>R CMD SHLIB Zhang_4.f90
c:/Rtools/mingw_64/bin/gfortran -O2 -mtune=core2 -c Zhang_4.f90 -o
Zhang_4.o
Zhang_4.f90:6.4:
use ifwin
1
Fatal Error: Can't open module file 'ifwin.mod' for reading at (1): No
such file or directory
make: *** [Zhang_4.o] Error 1
Warning message:
running command 'make -f "C:/PROGRA~1/R/R-34~1.2/etc/x64/Makeconf" -f
"C:/PROGRA~1/R/R-34~1.2/share/make/winshlib.mk"
SHLIB_LDFLAGS='$(SHLIB_FCLDFLAGS)' SHLIB_LD='$(SHLIB_FCLD)'
SHLIB="Zhang_4.dll" SHLIB_LIBADD='$(FCLIBS)' WIN=64 TCLBIN=64
OBJECTS="Zhang_4.o"' had status 2
I don't think there is any other way then rewrite the code to not use IFWIN. Unless you manage to use Intel Fortran for R (that might require recompiling the whole R distribution...). Matlab is tied to Intel Fortran, that's why the code worked there.
You have to adjust the code anyway, you cannot use it as it stands.
Just get rid of the AllocConsole() calls and the print statements. You will need to use the R routines to print to console. See https://cran.r-project.org/doc/manuals/R-exts.html#Printing-from-FORTRAN

Resources