Getting error, not sure why. Rank mismatch in argument - fortran

Every time I compile this program I get these errors...
(This error occurs every time I try to call the subroutine.)
103 | call ColumnInsert(M(n,n), b, n, col, MatOut(n,n))
| 1
Error: Explicit interface required for ‘columninsert’ at (1): assumed-shape argument
(This error also occurs every time I run the function)
107 | detA = Determinant (MatOut(:,:), n)
| 1
Error: Type mismatch in argument ‘m’ at (1); passed INTEGER(4) to REAL(8)
Here is the main program:
program CramersRule
! System of equations. 2x2, 3x3
implicit none
! Declare varialble
integer :: n, row, col, i
real*8, allocatable :: Matrix1(:,:), b(:), x(:)
real*8 :: detA, detM, determinant
logical :: Success
! Open the input and output files.
open(42,file='Data2.txt')
open(43,file='Data2Out.txt')
! Solve each system in the input files.
do
! Read in size of first system.
read(42,*) n
if (n .eq. 0) exit ! Quit if zero.
! Allocate memory for system, right hand side, and solution vector.
allocate(Matrix1(n,n), b(n), x(n))
! Read in the system. Ask if you do not understand how this works!
do row = 1, n
read(42,*) (Matrix1(row, col), col = 1, n), b(row)
print*, Matrix1
enddo
! Use cramers rule to get solution.
call Cramer(Matrix1, b, n, x, Success)
if (Success) then
! Write solution to file
do row = 1, n
write(43,*) x(row)
enddo
write(43,*)
else ! This happens when there is no unique solution.
write(43,*) 'No Solution'
write(43,*)
endif
! clean up memory and go back up to top for next system.
deallocate(Matrix1, b, x)
enddo
! close files
close(42)
close(43)
end program CramersRule
subroutine Cramer(M, b, n, x, Success)
! This subroutine does Cramer's Rule
implicit none
! Declare and initialize your variables first.
real*8, allocatable :: M(:,:), b(:), x(:)
integer :: n, row, col, i
integer :: MatOut(n,n)
real*8 :: detA, detM, x1, x2, x3, Determinant, solution1, solution2, solution3
logical :: Success
! Find the determinant of M first. print it to screen.
detM = Determinant(M, n)
print*, "The determinant of this matrix is = ", detM
! If it is zero, set the Success logical variable and quit.
if (detM .eq. 0) then
Success = .false.
return
end if
! Allocate memory for a working matrix for column substituion. Then, for each
! column, i, substitute column i with vector b and get that determinant.
! Compute the ith solution.
if (n .eq. 2)then
col = 1
call ColumnInsert(M(n,n), b, n, col, MatOut(n,n))
print*, MatOut(:,:)
detA = Determinant (MatOut(:,:), n)
x1 = detA/detM
solution1 = x1
col = col + 1
call ColumnInsert(M, b, n, col, MatOut)
print*, MatOut(:,:)
detA = Determinant (MatOut(:,:), n)
x2 = detA/detM
solution2 = x2
success = .true.
return
else
col = 1
call ColumnInsert(M, b, n, col, MatOut)
print*, MatOut(:,:)
detA = Determinant (MatOut(:,:), n)
x1 = detA/detM
solution1 = x1
col = col + 1
call ColumnInsert(M, b, n, col, MatOut)
print*, MatOut(:,:)
detA = Determinant (MatOut(:,:), n)
x2 = detA/detM
solution2 = x2
col = col +1
call ColumnInsert(M, b, n, col, MatOut)
print*, MatOut(:,:)
detA = Determinant (MatOut(:,:), n)
x3 = detA/detM
solution3 = x3
success = .true.
return
end if
! deallocate memory for the working matrix.
deallocate(M, b, x)
end subroutine Cramer
subroutine ColumnInsert(M, b, n, col, MatOut)
! This subroutine takes vector b and inserts in into matrix M at column col.
implicit none
integer :: n
integer, intent(out) :: col, MatOut(:,:)
real :: a, b1, c, d, e, f, g, h, j, k, l, m1
double precision :: M(n,n), b(1,n)
if (n .eq. 2)then
a = M(1,1)
b1 = M(1,2)
c = M(2,1)
d = M(2,2)
e = b(1,1)
f = b(1,2)
!the next if statement substitutes based on which column the main program asks for
if (col .eq. 1)then
M(1,1) = e
M(1,2) = f
M(2,1) = c
M(2,2) = d
MatOut(:,:) = M(:,:)
print*, MatOut(:,:)
return
else
M(1,1) = a
M(1,2) = b1
M(2,1) = e
M(2,2) = f
MatOut(:,:) = M(:,:)
print*, MatOut(:,:)
return
endif
!this is for 3x3 matricies
else
a = M(1,1)
b1 = M(1,2)
c = M(1,3)
d = M(2,1)
e = M(2,2)
f = M(2,3)
g = M(3,1)
h = M(3,2)
j = M(3,3)
k = b(1,1)
l = b(1,2)
m1 = b(1,3)
if (col .eq. 1) then
M(1,1) = k
M(1,2) = l
M(1,3) = m1
M(2,1) = d
M(2,2) = e
M(2,3) = f
M(3,1) = g
M(3,2) = h
M(3,3) = j
MatOut(:,:) = M(:,:)
print*, MatOut(:,:)
return
else if (col .eq. 2)then
M(1,1) = a
M(1,2) = b1
M(1,3) = c
M(2,1) = k
M(2,2) = l
M(2,3) = m1
M(3,1) = g
M(3,2) = h
M(3,3) = j
MatOut(:,:) = M(:,:)
print*, MatOut(:,:)
return
else
M(1,1) = a
M(1,2) = b1
M(1,3) = c
M(2,1) = d
M(2,2) = e
M(2,3) = f
M(3,1) = k
M(3,2) = l
M(3,3) = m1
MatOut(:,:) = M(:,:)
print*, MatOut(:,:)
return
endif
endif
end subroutine ColumnInsert
function Determinant(M, n) result(Det)
!pulled straight from lab 2 in week 4
integer :: n
real*8 :: M(n,n), Det, a, b, c, d, e, f, g, h, j
if (n .eq. 2) then
a = M(1,1)
b = M(1,2)
c = M(2,1)
d = M(2,2)
Det = (a*d)-(b*c)
else
a = M(1,1)
b = M(1,2)
c = M(1,3)
d = M(2,1)
e = M(2,2)
f = M(2,3)
g = M(3,1)
h = M(3,2)
j = M(3,3)
Det = (a*e*j)+(b*f*g)+(c*d*h)-(c*e*g)-(b*d*j)-(a*f*h)
endif
end function Determinant
I know this might seem like a dumb question to be asking, but I cannot for the life of me find where I need to change something. Any help or guidance is greatly appreciated. Thanks!

Related

Spline interpolation in Fortran

I'm running a spline interpolation on two small arrays in Fortran, it works but I get numbers that are either a bit off or really off.
Can anybody tell me if I made any mistakes in the logic or the formulas?
SUBROUTINE spline(x, y, n, y1, yn, y2)
! =====================================================
! Input x and y=f(x), n (dimension of x,y), (Ordered)
! y1 and yn are the first derivatives of f in the 1st point and the n-th
! Output: array y2(n) containing second derivatives of f(x_i)
! =====================================================
IMPLICIT NONE
INTEGER:: n, i, j
INTEGER, PARAMETER:: n_max = 500
REAL*8, INTENT(in):: x(n), y(n), y1, yn
REAL*8, INTENT(out):: y2(n)
REAL*8:: p, qn, sig, un, u(n)
IF (y1 > .99e30) THEN ! natural spline conditions
y2(1) = 0
u(1) = 0
ELSE
y2(1) = -0.5
u(1) = (3./(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-y1)
END IF
DO i = 2, n-1 ! tridiag. decomposition
sig = (x(i)-(i-1))/(x(i+1)-x(i-1))
p = sig*y2(i-1)+2.
y2(i) = (sig-1.)/p
u(i)=(6.*((y(i+1)-y(i))/(x(i+1)-x(i))-(y(i)-y(i-1))/(x(i)-x(i-1)))/(x(i+1)-x(i-1))-sig*u(i-1))/p
END DO
IF (yn > .99e30) THEN ! natural spline conditions
qn = 0
un = 0
ELSE
qn = 0.5
un=(3./(x(n)-x(n-1)))*(yn-(y(n)-y(n-1))/(x(n)-x(n-1)))
END IF
y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+1.)
DO j = n-1, 1, -1 ! backwards substitution tri-diagonale
y2(j) = y2(j)*y2(j+1)+u(j)
END DO
RETURN
END SUBROUTINE spline
SUBROUTINE splint(x_in, y_in, spline_res, n, x_0, y_final)
! =====================================================
! Subroutine that does the actual interpolation
! Input arrays of x_in and y_in=f(x), spline_res is the result of
! the 'spline' subroutine, x_0 is the corresponding value we are looking for
! i.e. (time_at_max in hubble), y_final is the output result
! =====================================================
IMPLICIT NONE
INTEGER:: n, k, k_low, k_high
REAL*8, INTENT(in):: x_in(n), y_in(n), spline_res(n), x_0
REAL*8, INTENT(out):: y_final
REAL*8:: a, b, h
k_low = 1
k_high = n
99 IF (k_high - k_low > 1) THEN
k = (k_high + k_low) / 2
IF (x_in(k) > x_0) THEN
k_high = k
ELSE
k_low = k
END IF
GOTO 99
ENDIF
h = x_in(k_high) - x_in(k_low)
IF (h == 0) STOP "Bad x_in input"
a = (x_in(k_high)-x_0)/h
b = (x_0 - x_in(k_low))/h
y_final = a*y_in(k_low)+b*y_in(k_high)+((a**3-a)*spline_res(k_low)+(b**3-b)*spline_res(k_high))*(h**2)/6
RETURN
END SUBROUTINE splint
SUBROUTINE spline_interp(x, y, n, x0, y_out)
! =====================================================
! Simply merging spline and splint in one subroutine
! input x and y and get y_out at x0
! =====================================================
IMPLICIT NONE
INTEGER::n
REAL*8, INTENT(in):: x(n), y(n), x0
REAL*8, INTENT(out):: y_out
REAL*8:: y1, yn, res(n)
! natural conditions attempt, change if not working well
y1 = 0.5
yn = 0.5
CALL spline(x, y, n, y1, yn, res)
CALL splint(x, y, res, n, x0, y_out)
END SUBROUTINE spline_interp
I'm then trying to interpolate the time of maximum brightness of a supernova, having the time of observation and the magnitudes at each moment:
Time (JD):
53682.03732
53683.04882
53684.08633
53687.03535
53689.11806
53690.06398
53694.10385
53695.10682
53698.06705
53699.09681
53702.10265
53706.12631
53716.10135
53721.06836
53726.0874
53730.07961
53738.03101
53746.03825
53755.03675
Mag in b band: 17.117
17.015
16.935
16.838
16.863
16.903
17.167
17.25
17.562
17.664
18.045
18.583
19.37
19.713
19.945
20.141
20.328
20.357
20.547
As you can see from the light curve, the supernova was at peak brightness at 53687.03535, but the interpolation is giving me 53639.43568130193.
Even worse, I also need to interpolate the brightness 15 days after the peak, which looks like should be around 18.5 mag; but instead I'm getting this random number: -5142981.630692291
What's wrong with my spline?
Thank for your help and sorry for the long post guys
<3
The data provided is not indicative of the chart shown
So I am going to answer based on synthetic fake data that I made up for this example.
with the code
Program
The program uses the code from the NR book, and the question above, and put it into a module called mod_splines for usability purposes. This way it can be easily extended.
program FortranConsoleSpline
use mod_splines
implicit none
! Variables
real(wp), allocatable :: xi(:), yi(:), h, x, y, yp
type(spline) :: sp
integer :: i, n
! compile with /fpconstant
xi = [0.0,0.25,0.5,0.75,1.0,1.25,1.5,1.75,2.0]
yi = [18.0,18.4921875,18.9375,19.2890625,19.5,19.5234375,19.3125,18.8203125,18.0]
print *, 'Cubic Spline Interpolation Demo'
n = 11
h = (xi(size(xi))-xi(1))/(n-1)
sp = spline(xi, yi)
print *, ""
print '(1x,a6,1x,a18,1x,a18,1x,a18)', "Index", "x", "y", "yp"
do i=0,n-1
x = xi(1) + i*h
y = sp%value(x)
yp = sp%slope(x)
print '(1x,i6,1x,g18.11,1x,g18.6,1x,g18.6)', i, x, y, yp
end do
print *, ""
x = sp%extrema()
i = sp%indexof(x)
y = sp%value(x)
yp = sp%slope(x)
print *, "Local Extrema"
print '(1x,a6,1x,a18,1x,a18,1x,a18)', "Index", "x", "y", "yp"
print '(1x,i6,1x,g18.11,1x,g18.6,1x,g18.6)', i, x, y, yp
end program FortranConsoleSpline
Output
The code has been extended by using a bisection method to find the local min/max of the cubic spline. I could have used a direct evaluation by solving the quadratic equation, but this is fast enough.
The result below finds the maximum point at x=1.1857554913
Cubic Spline Interpolation Demo
Index x y yp
0 0.0000000000 18.0000 2.06799
1 0.20000000000 18.4009 1.87745
2 0.40000000000 18.7637 1.73300
3 0.60000000000 19.0861 1.47687
4 0.80000000000 19.3398 0.943939
5 1.0000000000 19.5000 0.209478
6 1.2000000000 19.5304 -0.461936E-01
7 1.4000000000 19.4106 -0.938651
8 1.6000000000 19.1328 -1.85224
9 1.8000000000 18.6726 -3.07239
10 2.0000000000 18.0000 -3.50827
Local Extrema
Index x y yp
5 1.1857554913 19.5308 0.738816E-07
As you can see the slope at the maximum point is about 1e-7.
mod_splines
Here is the module I created for this demo. The spline coefficients are calculated using the spline(x,y) interface (for natural spline) or spline(x,y,dy_1,dy_n) for known end slopes.
The spline coefficients are stored together with the input (x,y) nodes in a user-defined type called spline.
Evaluation of the spline, and its derivatives are done with value(x), slope(x) and slope2(x) type bound methods.
Additional auxiliary methods are indexof(x) to find the integer index where x(i) <= x < x(i+1), and extrema() which as mentioned above uses a bisection to find the x value where the slope is nearest zero.
module mod_splines
use, intrinsic :: iso_fortran_env
implicit none
integer, parameter :: wp = real64
real(wp), parameter :: big = 1e30_wp, tiny=1/big
type :: spline
real(wp), allocatable :: x(:), y(:), y2(:)
contains
procedure :: indexof => sp_index_of_x
procedure :: value => sp_interpolate_value
procedure :: slope => sp_interpolate_slope
procedure :: slope2 => sp_interpolate_slope2
procedure :: extrema => sp_find_local_extrema
end type
interface spline
module procedure :: sp_calculate_from_data
end interface
contains
pure function sp_calculate_from_data(x,y,y1_slope,yn_slope) result(sp)
! =====================================================
! Input x and y=f(x), n (dimension of x,y), (Ordered)
! y1 and yn are the first derivatives of f in the 1st point and the n-th
! Output: array y2(n) containing second derivatives of f(x_i)
! =====================================================
type(spline) :: sp
real(wp), intent(in) :: x(:), y(:)
real(wp) :: y2(size(y))
real(wp), optional, intent(in) :: y1_slope, yn_slope
real(wp):: p, qn, sig, un, u(size(y))
INTEGER:: n, i, j
n = size(y)
IF (present(y1_slope)) THEN ! natural spline conditions
y2(1) = -0.5
u(1) = (3./(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-y1_slope)
ELSE
y2(1) = 0
u(1) = 0
END IF
DO i = 2, n-1 ! tridiag. decomposition
sig = (x(i)-(i-1))/(x(i+1)-x(i-1))
p = sig*y2(i-1)+2.
y2(i) = (sig-1.)/p
u(i)=(6.*((y(i+1)-y(i))/(x(i+1)-x(i))-(y(i)-y(i-1))/(x(i)-x(i-1)))/(x(i+1)-x(i-1))-sig*u(i-1))/p
END DO
IF (present(yn_slope)) THEN ! natural spline conditions
qn = 0.5
un=(3./(x(n)-x(n-1)))*(yn_slope-(y(n)-y(n-1))/(x(n)-x(n-1)))
ELSE
qn = 0
un = 0
END IF
y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+1.)
DO j = n-1, 1, -1 ! backwards substitution tri-diagonale
y2(j) = y2(j)*y2(j+1)+u(j)
END DO
sp%x = x
sp%y = y
sp%y2 = y2
RETURN
end function sp_calculate_from_data
elemental function sp_index_of_x(sp,x) result(k_low)
class(spline), intent(in) :: sp
real(wp), intent(in) :: x
integer:: n, k, k_low, k_high
n = size(sp%y)
k_low = 1
k_high = n
if(x<sp%x(k_low)) then
return
elseif (x>sp%x(k_high)) then
k_low = k_high-1
return
end if
do while(k_high - k_low > 1)
k = (k_high + k_low) / 2
IF (sp%x(k) > x) THEN
k_high = k
ELSE
k_low = k
END IF
end do
end function
elemental function sp_interpolate_value(sp,x) result(y)
! =====================================================
! Subroutine that does the actual interpolation
! Input arrays of x_in and y_in=f(x), spline_res is the result of
! the 'spline' subroutine, x is the corresponding value we are looking for
! i.e. (time_at_max in hubble), y is the output result
! =====================================================
class(spline), intent(in) :: sp
real(wp), intent(in) :: x
real(wp) :: y
integer:: n, k
real(wp):: a, b, c, d, h, t
n = size(sp%y)
k= sp%indexof(x)
h = sp%x(k+1) - sp%x(k)
IF (h == 0) error STOP "Bad x input"
t = (x-sp%x(k))/h
a = 1-t
b = t
if( x>=sp%x(k) .and. x<=sp%x(k+1)) then
! Cubic inside the interval
c = (a**3-a)*(h**2)/6
d = (b**3-b)*(h**2)/6
else
! Linear outside the interval
c = 0.0_wp
d = 0.0_wp
end if
y = a*sp%y(k)+b*sp%y(k+1)+c*sp%y2(k)+d*sp%y2(k+1)
RETURN
end function sp_interpolate_value
elemental function sp_interpolate_slope(sp,x) result(yp)
! =====================================================
! Subroutine that does the actual interpolation
! Input arrays of x_in and y_in=f(x), spline_res is the result of
! the 'spline' subroutine, x is the corresponding value we are looking for
! i.e. (time_at_max in hubble), yp is the output result slope
! =====================================================
class(spline), intent(in) :: sp
real(wp), intent(in) :: x
real(wp) :: yp
integer:: n, k
real(wp):: a, b, c, d, h, t
n = size(sp%y)
k= sp%indexof(x)
h = sp%x(k+1) - sp%x(k)
IF (h == 0) error STOP "Bad x input"
t = (x-sp%x(k))/h
a = -1/h
b = 1/h
if( x>=sp%x(k) .and. x<=sp%x(k+1)) then
! Cubic inside the interval
c = (1-3*(1-t)**2)*(h/6)
d = (3*t**2-1)*(h/6)
else
! Linear outside the interval
c = 0.0_wp
d = 0.0_wp
end if
yp = a*sp%y(k)+b*sp%y(k+1)+c*sp%y2(k)+d*sp%y2(k+1)
RETURN
end function sp_interpolate_slope
elemental function sp_interpolate_slope2(sp,x) result(yp2)
! =====================================================
! Subroutine that does the actual interpolation
! Input arrays of x_in and y_in=f(x), spline_res is the result of
! the 'spline' subroutine, x is the corresponding value we are looking for
! i.e. (time_at_max in hubble), yp is the output result 2nd slope
! =====================================================
class(spline), intent(in) :: sp
real(wp), intent(in) :: x
real(wp) :: yp2
integer:: n, k
real(wp):: a, b, c, d, h, t
n = size(sp%y)
k= sp%indexof(x)
h = sp%x(k+1) - sp%x(k)
IF (h == 0) error STOP "Bad x input"
t = (x-sp%x(k))/h
a = 0.0_wp
b = 0.0_wp
if( x>=sp%x(k) .and. x<=sp%x(k+1)) then
! Cubic inside the interval
c = 1-t
d = t
else
! Linear outside the interval
c = 0.0_wp
d = 0.0_wp
end if
yp2 = a*sp%y(k)+b*sp%y(k+1)+c*sp%y2(k)+d*sp%y2(k+1)
RETURN
end function sp_interpolate_slope2
pure function sp_find_local_extrema(sp, x_low, x_high) result(x)
class(spline), intent(in) :: sp
real(wp) :: x
real(wp), intent(in), optional :: x_low, x_high
integer :: n, k1, k2
real(wp) :: x1, x2, yp1, yp2, h, tol, yp
n = size(sp%y)
if(present(x_low)) then
x1 = x_low
else
x1 = sp%x(1)
end if
if(present(x_high)) then
x2 = x_high
else
x2 = sp%x(n)
end if
h = x2 - x1
tol = h/(2**23)
yp1 = sp_interpolate_slope(sp, x1)
yp2 = sp_interpolate_slope(sp, x2)
if( yp1*yp2 > 0 ) then
! no solution
if( yp1>0 ) then
x = big
else
x = tiny
end if
end if
do while (x2-x1>tol)
x = (x1+x2)/2
yp = sp_interpolate_slope(sp, x)
if( yp1*yp > 0) then
x1 = x
yp1 = yp
else
x2 = x
yp2 = yp
end if
end do
end function
end module mod_splines
GitHub repo for the code above: FortranConsoleSpline

How to plot the Poincaré Section? (Duffing Oscillator)

I've written a program that successfully shows a simple limit cycle for the Duffing equation. However, I now need to plot the Poincaré section for this case.
I need to do this by taking snapshots of the Phase-Space diagram at regular time intervals, such that t*omega = 2*pi*n. As I have omega set to 1 for this case, this is just when t = 2*pi*n. I've attempted this, but am not getting the Poincaré section I expect.
Here's my code:
program rungekutta
implicit none
integer, parameter :: dp = selected_real_kind(15,300)
integer :: i, n
real(kind=dp) z, y, t, A, C, D, B, omega, h
open(unit=100, file="rungekutta.dat",status='replace')
n = 0
!constants
omega = 1.0_dp
A = 0.25_dp
B = 1.0_dp
C = 0.1_dp
D = 1.0_dp
y = 0.0_dp
z = 0.0_dp
t = 0.0_dp
do i=1,1000
call rk2(z, y, t, n)
n = n + 1.0_dp
write(100,*) y, z
end do
contains
subroutine rk2(z, y, t, n) !subroutine to implement runge-kutta algorithm
implicit none
integer, parameter :: dp = selected_real_kind(15,300)
integer, intent(inout) :: n
real(kind=dp) :: k1y, k1z, k2y, k2z, y, z, t, pi
pi = 4.0*ATAN(1.0)
h = 0.1_dp
t = n*2*pi
k1y = dydt(y,z,t)*h
k1z = dzdt(y,z,t)*h
k2z = dzdt(y + (0.5_dp*k1y), z + (0.5_dp*k1z), t + (0.5_dp*h))*h
k2y = dydt(y, z +(0.5_dp*k1z), t)*h
y = y + k2y
z = z + k2z
end subroutine
!2nd order ODE split into 2 for coupled Runge-Kutta, useful to define 2
functions
function dzdt(y,z,t)
real(kind=dp) :: y, z, t, dzdt
dzdt = -A*y**3.0_dp + B*y - C*z + D*sin(omega*t)
end function
function dydt(y,z,t)
real(kind=dp) :: z, dydt, y, t
dydt = z
end function
end program
I have also attached an image of what my Poincaré section looks like:
.
This is y on the x axis vs dydt.
And an image of what I'd expect:
In your rk2 routine you perform one step of step length 0.1. Thus the plot is the full trajectory of the solution at that resolution. However the intend seems to be to integrate over a full period length. This would require a loop in that routine.
In other words, what you want is the plot of (y(n*T), z(n*T)) where T is one of the periods of the system, per your code T=2*p. What you actually compute is (y(n*h), z(n*h)) where h=0.1 is the step size of a single step of RK2.
Also the arguments of k2y need to be corrected as per the comment of user5713492
With a corrected integrator you should get something like the following picture:
where the red squares are the points at t=n*2*pi. The indicated step size by the dots on the solution curve is the same h=0.1, the integration is over t=0..300.
def RK2(f,u,times,subdiv = 1):
uout = np.zeros((len(times),)+u.shape)
uout[0] = u;
for k in range(len(times)-1):
t = times[k]
h = (times[k+1]-times[k])/subdiv
for j in range(subdiv):
k1 = f(u,t)*h
k2 = f(u+0.5*k1, t+0.5*h)*h
u, t = u+k2, t+h
uout[k+1]=u
return uout
def plotphase(A,B,C,D):
def derivs(u,t): y,z = u; return np.array([ z, -A*y**3 + B*y - C*z + D*np.sin(t) ])
N=60
u0 = np.array([0.0, 0.0])
t = np.arange(0,300,2*np.pi/N);
u = RK2(derivs, u0, t, subdiv = 10)
plt.plot(u[:-2*N,0],u[:-2*N,1],'.--y', u[-2*N:,0],u[-2*N:,1], '.-b', lw=0.5, ms=2);
plt.plot(u[::N,0],u[::N,1],'rs', ms=4); plt.grid(); plt.show()
plotphase(0.25, 1.0, 0.1, 1.0)

Eigenvector discontinuities in hermitian matrix diagonalization

I need to diagonalize a 2x2 Hermitian matrix that depends on a parameter x, which varies continuously. For diagonalization I use EISPACK. When I plot the real and imaginary components of eigenvectors as a function of x, I notice that they have discontinuities. The eigenvalues calculation is OK. When I plot the eigenvectors in Maxima, the solutions appear continuous. I need the continuous eigenvectors since in next step I will need to calculate their derivatives.
Below the f77 code I use as test (compiling with gfortran on mingw).
program Eigenvalue
implicit none
integer n, m
parameter (n=2)
integer ierr, matz, i, j
double precision x, dx, xf, amp, xin
double precision w(n)
double precision Ar(n,n), Ai(n,n)
double precision xr(n,n), xi(n,n)
double precision fm1(2,n) ! f77
double precision fv1(n) ! f77
double precision fv2(n) ! f77
double complex psi1a, psi1b, psi2a, psi2b
m = 51
xf = 10.d0
xin = 0.0d0
amp = 2.d0
dx = (xf - xin)/(m-1)
do i = 1, m
x = dx*(i-m) + xf
Ar(1,1) = dsin(x)**2
Ar(1,2) = amp*dcos(x)
Ar(2,1) = amp*dcos(x)
Ar(2,2) = dcos(x)**2
Ai(1,1) = 0.0d0
Ai(1,2) = amp*dsin(x)
Ai(2,1) = -amp*dsin(x)
Ai(2,2) = 0.0d0
matz = 1
call ch ( n, n, ar, ai, w, matz, xr, xi, fv1, fv2, fm1, ierr ) !f77
write(20,*) x, w(1), w(2)
write(21,*) x, xr(1,1), xi(1,1)
write(22,*) x, xr(2,1), xi(2,1)
write(23,*) x, xr(1,2), xi(1,2)
write(24,*) x, xr(2,2), xi(2,2)
! autovetor 1
psi1a = cmplx(xr(1,1),xi(1,1))
psi1b = cmplx(xr(1,2),xi(1,2))
! autovetor 2
psi2a = cmplx(xr(2,1),xi(2,1))
psi2b = cmplx(xr(2,2),xi(2,2))
end do
end
While not really an answer, what follows is the code I used with LAPACK.
I used the latest versions of LAPACK and BLAS, with the following compiler options:
gfortran -Og -std=f2008 -Wall -Wextra {location_of_lapack}/liblapack.a {location_of_blas}/blas_LINUX.a main.f90 -o main
I'm compiling on Mac OS X with gfortran 6.3.0 from homebrew.
As Ian mentioned above, things like dcos are replaced with cos and I have used the KIND= formulation to ensure the same precision.
Ian also mentioned above about the arbitrary phase.
This problem is answered here; I have translated this solution into my code below.
The "magic" happens after the call to ZHEEV.
With this fix, I see no discontinuities.
program Eigenvalue
!> This can be used with the f2008 call
use, intrinsic :: iso_fortran_env
implicit none
!> dp contains the kind value for double precision.
!> Use below if compiling to f2008
integer, parameter :: dp = REAL64
!> Use below if compiling with f95 up and comment out iso_fortran_env
!>integer, parameter :: dp = SELECTED_REAL_KIND(15, 300)
!> Set wp to the desired precision.
integer, parameter :: wp = dp
integer, parameter :: n = 2
integer :: i, j, k, m
real(kind=wp) x, dx, xf, amp, xin
real(kind=wp), dimension(n) :: w
real(kind=wp), dimension(n, n) :: Ar, Ai
complex(kind=wp), dimension(n, n) :: A
complex(kind=wp), dimension(max(1,2*n-1)) :: WORK
integer, parameter :: lwork = max(1,2*n-1)
real(kind=wp), dimension(max(1, 3*n-2)) :: RWORK
integer :: info
complex(kind=wp) :: psi1a, psi1b, psi2a, psi2b
real(kind=wp) :: mag
m = 51
xf = 10.0_wp
xin = 0.0_wp
amp = 2.0_wp
if (m .eq. 1) then
dx = 0.0_wp
else
dx = (xf - xin)/(m-1)
end if
do i = 1, m
x = dx*(i-m) + xf
Ar(1,1) = sin(x)**2
Ar(1,2) = amp*cos(x)
Ar(2,1) = amp*cos(x)
Ar(2,2) = cos(x)**2
Ai(1,1) = 0.0_wp
Ai(1,2) = amp*sin(x)
Ai(2,1) = -amp*sin(x)
Ai(2,2) = 0.0_wp
do j = 1, n
do k = 1, n
A(j, k) = cmplx(Ar(j, k), Ai(j, k), kind=wp)
end do
end do
call ZHEEV('V', 'U', N, A, N, W, WORK, LWORK, RWORK, INFO)
do j = 1, n
A(:, j) = A(:, j) / A(1, j)
mag = sqrt(real(A(1, j)*conjg(A(1, j)))+ real(A(2, j)*conjg(A(2, j))))
A(:, j) = A(:, j)/mag
end do
psi1a = A(1, 1)
psi1b = A(1, 2)
psi2a = A(2, 1)
psi2b = A(2, 2)
end do
end program Eigenvalue

Shooting method in fortran (neutron star oscillation)

I have been writing a script in fortran 90 for solving the radial oscillation problem of a neutron star with the use of shooting method. But for unknown reason, my program never works out. Without the shooting method component, the program runs smoothly as it successfully constructed the star. But once the shooting comes in, everything dies.
PROGRAM ROSCILLATION2
USE eos_parameters
IMPLICIT NONE
INTEGER ::i, j, k, l
INTEGER, PARAMETER :: N_ode = 5
REAL, DIMENSION(N_ode) :: y
REAL(8) :: rho0_cgs, rho0, P0, r0, phi0, pi
REAL(8) :: r, rend, mass, P, phi, delta, xi, eta
REAL(8) :: step, omega, omegastep, tiny, rho_print, Radius, B, a2, s0, lamda, E0, E
EXTERNAL :: fcn
!!!! User input
rho0_cgs = 2.D+15 !central density in cgs unit
step = 1.D-4 ! step size dr
omegastep = 1.D-2 ! step size d(omega)
tiny = 1.D-8 ! small number P(R)/P(0) to define star surface
!!!!!!!!!
open(unit=15, file="data.dat", status="new")
pi = ACOS(-1.D0)
a2 =((((1.6022D-13)**4)*(6.674D-11)*((2.997D8)**-7)*((1.0546D-34)**-3)*(1.D6))**(0.5D0))*a2_MeV !convert to code unit (km^-1)
B = ((1.6022D-13)**4)*(6.674D-11)*((2.997D8)**-7)*((1.0546D-34)**-3)*(1.D6)*B_MeV !convert to code unit (km^-2)
s0 = (1.D0/3.D0) - (1/(6*pi**2))*a2*((1/(16*pi**2)*a2**2 + (pi**-2)*a4*(rho0 - B))**-0.5) !square of the spped of sound at r=0
lamda = -0.5D0*log(1-2*y(1)/r)
E0 = (r0**-2)*s0*exp(lamda + 3*phi0)
rho0 = rho0_cgs*6.67D-18 / 9.D0 !convert rho0 to code unit (km^-2)
!! Calculate central pressure P0
P0 = (1.D0/3.D0)*rho0 - (4.D0/3.D0)*B - (1.D0/(a4*(12.D0)*(pi**2)))*a2**2 - &
&(a2/((3.D0)*a4))*(((1.D0/(16.D0*pi**4))*a2**2+(1.D0/(pi**2))*a4*(rho0-B))**0.5D0)
!! initial value for metric function phi
phi0 = 0.1D0 ! arbitrary (needed to be adjusted later)
r0 = 1.D-30 ! integration starting point
!! Set initial conditions
!!!!!!!!!!!!!!!!!
!!Start integration loop
!!!!!!!!!!!!!!!!!
r = r0
y(1) = 0.D0
y(2) = P0
y(3) = phi0
y(4) = 1/(3*E0)
y(5) = 1
omega = 2*pi*1000/(2.997D5) !omega of 1kHz in code unit
DO l = 1, 1000
omega = omega + omegastep !shooting method part
DO i = 1, 1000000000
rend = r0 + REAL(i)*step
call oderk(r,rend,y,N_ode,fcn)
r = rend
mass = y(1)
P = y(2)
phi = y(3)
xi = y(4)
eta = y(5)
IF (P < tiny*P0) THEN
WRITE(*,*) "Central density (10^14 cgs) = ", rho0_cgs/1.D14
WRITE(*,*) " Mass (solar mass) = ", mass/1.477D0
WRITE(*,*) " Radius (km) = ", r
WRITE(*,*) " Compactness M/R ", mass/r
WRITE(15,*) (omega*2.997D5/(2*pi)), y(5)
GOTO 21
ENDIF
ENDDO
ENDDO
21 CONTINUE
END PROGRAM roscillation2
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE fcn(r,y,yprime)
USE eos_parameters
IMPLICIT NONE
REAL(8), DIMENSION(5) :: y, yprime
REAL(8) :: r, m, P, phi, rho, pi, B, a2, xi, eta, W, Q, E, s, lamda, omega
INTEGER :: j
pi = ACOS(-1.D0)
a2 =((((1.6022D-13)**4)*(6.674D-11)*((2.997D8)**-7)*((1.0546D-34)**-3)*(1.D6))**(0.5D0))*a2_MeV !convert to code unit (km^-1)
B = ((1.6022D-13)**4)*(6.674D-11)*((2.997D8)**-7)*((1.0546D-34)**-3)*(1.D6)*B_MeV !convert to code unit (km^-2)
m = y(1)
P = y(2)
phi = y(3)
xi = y(4)
eta = y(5)
rho = 3.D0*P + 4.D0*B +((3.D0)/(4.D0*a4*(pi**2)))*a2**2+(a2/a4)*&
&(((9.D0/((16.D0)*(pi**4)))*a2**2+((3.D0/(pi**2))*a4*(P+B)))**0.5D0)
s = (1.D0/3.D0) - (1/(6*pi**2))*a2*((1/(16*pi**2)*a2**2 + (pi**-2)*a4*(rho - B))**-0.5) !square of speed of sound
W = (r**-2)*(rho + P)*exp(3*lamda + phi)
E = (r**-2)*s*exp(lamda + 3*phi)
Q = (r**-2)*exp(lamda + 3*phi)*(rho + P)*((yprime(3)**2) + 4*(r**-1)*yprime(3)- 8*pi*P*exp(2*lamda))
yprime(1) = 4.D0*pi*rho*r**2
yprime(2) = - (rho + P)*(m + 4.D0*pi*P*r**3)/(r*(r-2.D0*m))
yprime(3) = (m + 4.D0*pi*P*r**3)/(r*(r-2.D0*m))
yprime(4) = y(5)/(3*E)
yprime(5) = -(W*omega**2 + Q)*y(4)
END SUBROUTINE fcn
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!
!! Runge-Kutta method (from Numerical Recipes)
!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine oderk(ri,re,y,n,derivs)
INTEGER, PARAMETER :: NMAX=16
REAL(8) :: ri, re, step
REAL(8), DIMENSION(NMAX) :: y, dydx, yout
EXTERNAL :: derivs,rk4
call derivs(ri,y,dydx)
step=re-ri
CALL rk4(y,dydx,n,ri,step,yout,derivs)
do i=1,n
y(i)=yout(i)
enddo
return
end subroutine oderk
SUBROUTINE RK4(Y,DYDX,N,X,H,YOUT,DERIVS)
INTEGER, PARAMETER :: NMAX=16
REAL(8) :: H,HH,XH,X,H6
REAL(8), DIMENSION(N) :: Y, DYDX, YOUT
REAL(8), DIMENSION(NMAX) :: YT, DYT, DYM
EXTERNAL :: derivs
HH=H*0.5D0
H6=H/6D0
XH=X+HH
DO I=1,N
YT(I)=Y(I)+HH*DYDX(I)
ENDDO
CALL DERIVS(XH,YT,DYT)
DO I=1,N
YT(I)=Y(I)+HH*DYT(I)
ENDDO
CALL DERIVS(XH,YT,DYM)
DO I=1,N
YT(I)=Y(I)+H*DYM(I)
DYM(I)=DYT(I)+DYM(I)
ENDDO
CALL DERIVS(X+H,YT,DYT)
DO I=1,N
YOUT(I)=Y(I)+H6*(DYDX(I)+DYT(I)+2*DYM(I))
ENDDO
END SUBROUTINE RK4
Any reply would be great i am just really depressed for the long debugging.
Your program is blowing up because of this line:
yprime(5) = -(W*omega**2 + Q)*y(4)
in subroutine fcn. In this subroutine, omega is completely independent of the one declared in your main program. This one is uninitialized and used in an expression, which will either contain random values or zero, if your compiler is nice enough (or told) to initialize variables.
If you want the variable omega from your main program to be the same variable you use in fcn then you need to pass that variable to fcn somehow. Due to the way you've architected this program, passing it would require modifying all of your procedures to pass omega so that it can be provided to all of your calls to DERIVS (which is the dummy argument you are associating with fcn).
An alternative would be to put omega into a module and use that module where you need access to omega, e.g. declare it in eos_parameters instead of declaring it in the scoping units of fcn and your main program.

Sum duplicate values when converting from COO to CSR sparse matrix format

How would one sum up duplicate values efficently when converting from COO format to CSR. Does something similar to scipy implementation (http://docs.scipy.org/doc/scipy-0.9.0/reference/sparse.html) exist written in a subroutine for fortran? I am using Intel's MKL auxiliary routines for converting from COO to CSR, but it seems that it doesn't work for duplicate values.
In my codes I am using this subroutine that I wrote:
subroutine csr_sum_duplicates(Ap, Aj, Ax)
! Sum together duplicate column entries in each row of CSR matrix A
! The column indicies within each row must be in sorted order.
! Explicit zeros are retained.
! Ap, Aj, and Ax will be modified *inplace*
integer, intent(inout) :: Ap(:), Aj(:)
real(dp), intent(inout) :: Ax(:)
integer :: nnz, r1, r2, i, j, jj
real(dp) :: x
nnz = 1
r2 = 1
do i = 1, size(Ap) - 1
r1 = r2
r2 = Ap(i+1)
jj = r1
do while (jj < r2)
j = Aj(jj)
x = Ax(jj)
jj = jj + 1
do while (jj < r2)
if (Aj(jj) == j) then
x = x + Ax(jj)
jj = jj + 1
else
exit
end if
end do
Aj(nnz) = j
Ax(nnz) = x
nnz = nnz + 1
end do
Ap(i+1) = nnz
end do
end subroutine
and you can use this subroutine to sort the indices:
subroutine csr_sort_indices(Ap, Aj, Ax)
! Sort CSR column indices inplace
integer, intent(inout) :: Ap(:), Aj(:)
real(dp), intent(inout) :: Ax(:)
integer :: i, r1, r2, l, idx(size(Aj))
do i = 1, size(Ap)-1
r1 = Ap(i)
r2 = Ap(i+1)-1
l = r2-r1+1
idx(:l) = argsort(Aj(r1:r2))
Aj(r1:r2) = Aj(r1+idx(:l)-1)
Ax(r1:r2) = Ax(r1+idx(:l)-1)
end do
end subroutine
where argsort is
function iargsort(a) result(b)
! Returns the indices that would sort an array.
!
! Arguments
! ---------
!
integer, intent(in):: a(:) ! array of numbers
integer :: b(size(a)) ! indices into the array 'a' that sort it
!
! Example
! -------
!
! iargsort([10, 9, 8, 7, 6]) ! Returns [5, 4, 3, 2, 1]
integer :: N ! number of numbers/vectors
integer :: i,imin,relimin(1) ! indices: i, i of smallest, relative imin
integer :: temp ! temporary
integer :: a2(size(a))
a2 = a
N=size(a)
do i = 1, N
b(i) = i
end do
do i = 1, N-1
! find ith smallest in 'a'
relimin = minloc(a2(i:))
imin = relimin(1) + i - 1
! swap to position i in 'a' and 'b', if not already there
if (imin /= i) then
temp = a2(i); a2(i) = a2(imin); a2(imin) = temp
temp = b(i); b(i) = b(imin); b(imin) = temp
end if
end do
end function
That should do what you wanted.