I have matrix and array. I need to multiply their value. Then find the line with the maximum sum , and bring its number and value . Help me to understand
real, allocatable, dimension(:,:) :: startArr
real, allocatable:: x(:) , maxArr
do i = 1,4
do k=1,4
startArr(1,i)*x(k)
startArr(2,i)*x(k)
startArr(3,i)*x(k)
startArr(4,i)*x(k)
end do
end do
S = startArr(1,1)+ startArr(1,2) + startArr(1,3) + startArr(1,4)
D = startArr(2,1)+ startArr(2,2) + startArr(2,3) + startArr(2,4)
M = startArr(3,1)+ startArr(3,2) + startArr(3,3) + startArr(3,4)
K = startArr(4,1)+ startArr(4,2) + startArr(4,3) + startArr(4,4)
maxArr = (S,D,M,K)
max = S
do i = 1,4
if(maxArr(i)>max)
max = maxArr(i)
end do
I cannot comment on either your algorithm for multiplication is right or not. you have to check it with your mathematics however some parts of your code is wrong. I tried to correct them. this is my own version in Compaq Fortran.
program matrix_Manipulation
implicit none
real, allocatable, dimension(:,:) :: startArr,MultipliedArray
real, allocatable:: x(:) , sumLine(:)
real:: maxValue
integer::i,k
allocate(startArr(4,4),x(4),sumLine(4),MultipliedArray(4,4))
startArr(1,1)=1
startArr(2,1)=2
startArr(3,1)=3
startArr(4,1)=4
startArr(1,2)=5
startArr(2,2)=6
startArr(3,2)=7
startArr(4,2)=8
startArr(1,3)=9
startArr(2,3)=10
startArr(3,3)=11
startArr(4,3)=12
startArr(1,4)=13
startArr(2,4)=14
startArr(3,4)=15
startArr(4,4)=16
x(1)=2
x(2)=0.5
x(3)=8
x(4)=1
do i = 1,4
do k=1,4
MultipliedArray(1,i)=startArr(1,i)*x(k)
MultipliedArray(1,i)=startArr(2,i)*x(k)
MultipliedArray(1,i)=startArr(3,i)*x(k)
MultipliedArray(1,i)=startArr(4,i)*x(k)
end do
end do
sumLine(1) = sum(MultipliedArray(1,1:4))
sumLine(2) = sum(MultipliedArray(2,1:4))
sumLine(3) = sum(MultipliedArray(3,1:4))
sumLine(4) = sum(MultipliedArray(4,1:4))
maxValue = MAXVAL(sumLine)
end program matrix_Manipulation
the 'MAXVAL' is a built-in function to mind the maximum element of an array or matrix. That is in Comaq Fortran and it might be a different funtion in gFortran or ther compiler.
Related
I'm new to parallel programming and attempting to produce a sparse matrix-vector calculation in Fortran 95. I'm working on a subprogram that only gathers the components of the vector that the sparse matrix will touch (instead of MPI_AllGather), but I keep getting SIGSESV errors. I know this means I've asked the process to touch something it can't/doesn't exist, but I can't for the life of me figure out what it could be.
!Gather the vector matrix in matrix vector multiplication for sparse matrices
subroutine sparsegather(u,BW,myid,nprocs)
use header
include "mpif.h"
type(Vector), intent(inout) :: u
integer,intent(in) :: BW !Bandwidth
integer,intent(in) :: myid !process id
integer,intent(in) :: nprocs !number of processes
integer :: n, i
integer,dimension(BW) :: rlr, rrr, slr, srr !Range of receive left/right, send left/right
real(kind=rk),dimension(BW) :: rl, rr, sl, sr !Arrays of actual values
integer :: ierr
n = u%n !Length of whole vector - used in periodic condition
!Define ranges
do i = 1,BW
rlr(i) = u%ibeg - BW - 1 + i
rrr(i) = u%iend + i
srr(i) = u%iend - i + 1
slr(i) = u%ibeg + i - 1
end do
!Periodic conditions
do i = 1,BW
if (rlr(i) < 1) then
rlr(i) = rlr(i) + n
end if
if ((srr(i) < 1) then
srr(i) = srr(i) + n
end if
if (rrr(i) > n ) then
rrr(i) = rrr(i) - n
end if
if (slr(i) > n ) then
slr(i) = slr(i) - n
end if
end do
!Store the matrix values being sent over
sl = u%xx(slr)
sr = u%xx(srr)
!Pass the value parcels around
if (myid == 0) then
call MPI_Recv(rl,BW,MPI_DOUBLE_PRECISION,nprocs-1,MPI_ANY_TAG,MPI_COMM_WORLD,ierr)
call MPI_Send(sr,BW,MPI_DOUBLE_PRECISION,myid+1,0,MPI_COMM_WORLD,ierr)
call MPI_Recv(rr,BW,MPI_DOUBLE_PRECISION,myid+1,MPI_ANY_TAG,MPI_COMM_WORLD,ierr)
call MPI_Send(sl,BW,MPI_DOUBLE_PRECISION,nprocs-1,0,MPI_COMM_WORLD,ierr)
elseif (myid == nprocs-1) then
call MPI_Send(sr,BW,MPI_DOUBLE_PRECISION,0,0,MPI_COMM_WORLD,ierr)
call MPI_Recv(rl,BW,MPI_DOUBLE_PRECISION,myid-1,MPI_ANY_TAG,MPI_COMM_WORLD,ierr)
call MPI_Send(sl,BW,MPI_DOUBLE_PRECISION,myid-1,0,MPI_COMM_WORLD,ierr)
call MPI_Recv(rr,BW,MPI_DOUBLE_PRECISION,0,MPI_ANY_TAG,MPI_COMM_WORLD,ierr)
elseif (mod(myid,2) == 0) then
call MPI_Recv(rl,BW,MPI_DOUBLE_PRECISION,myid-1,MPI_ANY_TAG,MPI_COMM_WORLD,ierr)
call MPI_Send(sr,BW,MPI_DOUBLE_PRECISION,myid+1,0,MPI_COMM_WORLD,ierr)
call MPI_Recv(rr,BW,MPI_DOUBLE_PRECISION,myid+1,MPI_ANY_TAG,MPI_COMM_WORLD,ierr)
call MPI_Send(sl,BW,MPI_DOUBLE_PRECISION,myid-1,0,MPI_COMM_WORLD,ierr)
else
call MPI_Send(sr,BW,MPI_DOUBLE_PRECISION,myid+1,0,MPI_COMM_WORLD,ierr)
call MPI_Recv(rl,BW,MPI_DOUBLE_PRECISION,myid-1,MPI_ANY_TAG,MPI_COMM_WORLD,ierr)
call MPI_Send(sl,BW,MPI_DOUBLE_PRECISION,myid-1,0,MPI_COMM_WORLD,ierr)
call MPI_Recv(rr,BW,MPI_DOUBLE_PRECISION,myid+1,MPI_ANY_TAG,MPI_COMM_WORLD,ierr)
end if
u%xx(rrr) = rr
u%xx(rlr) = rl
end subroutine sparsegather
u is an object with the vector values stored in %xx and its size in %n. The relevant starting point and end points for each processor are in %ibeg and %iend.
BW is bandwith of the sparse banded matrix. This equation has periodic conditions, so values to the left of the start of the vector wrap around to the right side (and vice versa), which is done in the periodic conditions section.
I wrote the following code, and then tried using OpenMP to parallelise it. However, after I compiled the following OpenMP code using f2py, Python always generates certain errors when I run it. There are no error messages, only that the numbers are a bit off, and whenever I compile it with f2py and run it in Python, it kills the kernel.
I am wondering if this has anything to do with my parallel region. I am always a bit confused about which variables to take private so can anyone observe any errors?
subroutine simulate_omp(m,nt,s0,l,d,a,numthreads,x,y,psi)
!Pedestrian motion model
!input variables:
!n = m^2 = number of students
!nt: number of time steps
!s0: student speed
!l: initial spacing between students
!d: student motion influence by all other students within distance <= d
!a: noise amplitude
!numthreads: number of threads to use in parallel regions
!output variables:
!x,y: all m^2 student paths from i=1 to nt+1
!psi: synchronization parameter, store at all nt+1 times (including initial
condition)
use omp_lib
implicit none
integer, intent(in) :: m,nt,numthreads
real(kind=8), intent(in) :: s0,l,d,a
real(kind=8), dimension(m*m,nt+1), intent(out) :: x,y
real(kind=8), dimension(nt+1), intent(out) :: psi
real(kind=8), dimension(m*m,nt+1) :: xtemp,ytemp,u,v
real(kind=8), dimension(m*m,nt) :: usum,vsum,umean,vmean
real(kind=8) :: r(m*m)
real(kind=8),parameter :: pi = 4*atan(1.0_8)
integer :: i1,j1,k1,i2,j2,k2,count
!$call omp_set_num_threads(numthreads)
! initialize student positions
x = 0.d0
y = 0.d0
k1 = 0
do i1 = 1,m
do j1=1,m
k1 = k1 + 1
x(k1,1) = (j1-1)*l/2 - (m-1)*l/4
y(k1,1) = (i1-1)*l/2 - (m-1)*l/4
end do
end do
x(:,1) = x(:,1)/(m-1)
y(:,1) = y(:,1)/(m-1)
! initialize
xtemp(:,1) = x(:,1)
ytemp(:,1) = y(:,1)
call random_number(r)
u(:,1) = s0*cos(r*2*pi-pi)
v(:,1) = s0*sin(r*2*pi-pi)
psi(1) = sqrt(sum(u(:,1))**2+sum(v(:,1)**2))/dble(m)/dble(m)/s0
do i2 = 1,nt
!$OMP parallel do private(j2,k2,l)
do j2 = 1,m*m
usum(j2,i2) = 0
vsum(j2,i2) = 0
count = 0
!$OMP parallel do reduction(+:usum,vsum,count)
do k2 = 1,m*m
if ((xtemp(k2,i2)-xtemp(j2,i2))**2+(ytemp(k2,i2)-ytemp(j2,i2))**2<=d**2)
then
usum(j2,i2) = usum(j2,i2)+u(k2,i2)
vsum(j2,i2) = vsum(j2,i2)+v(k2,i2)
count = count+1
end if
end do
!$OMP end parallel do
umean(j2,i2) = usum(j2,i2)/dble(count)
vmean(j2,i2) = vsum(j2,i2)/dble(count)
u(j2,i2+1) = s0*cos(atan(vmean(j2,i2)/umean(j2,i2))+a*(r(j2)*2*pi-pi))
v(j2,i2+1) = s0*sin(atan(vmean(j2,i2)/umean(j2,i2))+a*(r(j2)*2*pi-pi))
xtemp(j2,i2+1) = xtemp(j2,i2)+u(j2,i2+1)
ytemp(j2,i2+1) = ytemp(j2,i2)+v(j2,i2+1)
! boundary conditions
if (xtemp(j2,i2+1)>l) then
xtemp(j2,i2+1) = xtemp(j2,i2+1)-2*l
else
if (xtemp(j2,i2+1)<-l) then
xtemp(j2,i2+1) = xtemp(j2,i2+1)+2*l
end if
end if
if (ytemp(j2,i2+1)>l) then
ytemp(j2,i2+1) = ytemp(j2,i2+1)-2*l
else
if (ytemp(j2,i2+1)<-l) then
ytemp(j2,i2+1) = ytemp(j2,i2+1)+2*l
end if
end if
end do
!$OMP end parallel do
psi(i2+1) = sqrt(sum(u(:,i2+1))**2+sum(v(:,i2+1))**2)/dble(m)/dble(m)/s0
end do
x(:,1:nt+1) = xtemp(:,1:nt+1)
y(:,1:nt+1) = ytemp(:,1:nt+1)
end subroutine simulate_omp
The argument l is declared with intent(in) and not modified in the loop so there is no need to declare it private. Below is a suggestion without the outer parallel loop:
subroutine simulate_omp(m,nt,s0,l,d,a,numthreads,x,y,psi)
!Pedestrian motion model
!input variables:
!n = m^2 = number of students
!nt: number of time steps
!s0: student speed
!l: initial spacing between students
!d: student motion influence by all other students within distance <= d
!a: noise amplitude
!numthreads: number of threads to use in parallel regions
!output variables:
!x,y: all m^2 student paths from i=1 to nt+1
!psi: synchronization parameter, store at all nt+1 times (including initial
condition)
use omp_lib
implicit none
integer, intent(in) :: m,nt,numthreads
real(kind=8), intent(in) :: s0,l,d,a
real(kind=8), dimension(m*m,nt+1), intent(out) :: x,y
real(kind=8), dimension(nt+1), intent(out) :: psi
real(kind=8), dimension(m*m,nt+1) :: xtemp,ytemp,u,v
real(kind=8), dimension :: usum,vsum,umean,vmean
real(kind=8) :: r(m*m)
real(kind=8),parameter :: pi = 4*atan(1.0_8)
integer :: i1,j1,k1,i2,j2,k2,count
!$call omp_set_num_threads(numthreads)
! initialize student positions
x = 0.d0
y = 0.d0
k1 = 0
do i1 = 1,m
do j1=1,m
k1 = k1 + 1
x(k1,1) = (j1-1)*l/2 - (m-1)*l/4
y(k1,1) = (i1-1)*l/2 - (m-1)*l/4
end do
end do
x(:,1) = x(:,1)/(m-1)
y(:,1) = y(:,1)/(m-1)
! initialize
xtemp(:,1) = x(:,1)
ytemp(:,1) = y(:,1)
call random_number(r)
u(:,1) = s0*cos(r*2*pi-pi)
v(:,1) = s0*sin(r*2*pi-pi)
psi(1) = sqrt(sum(u(:,1))**2+sum(v(:,1)**2))/dble(m)/dble(m)/s0
do i2 = 1,nt
do j2 = 1,m*m
usum = 0
vsum = 0
count = 0
!$OMP parallel do private(k2), reduction(+:usum,vsum,count)
do k2 = 1,m*m
if ((xtemp(k2,i2)-xtemp(j2,i2))**2+(ytemp(k2,i2)-ytemp(j2,i2))**2<=d**2) then
usum = usum+u(k2,i2)
vsum = vsum+v(k2,i2)
count = count+1
end if
end do
!$OMP end parallel do
umean = usum/dble(count)
vmean = vsum/dble(count)
u(j2,i2+1) = s0*cos(atan(vmean/umean)+a*(r(j2)*2*pi-pi))
v(j2,i2+1) = s0*sin(atan(vmean/umean)+a*(r(j2)*2*pi-pi))
xtemp(j2,i2+1) = xtemp(j2,i2)+u(j2,i2+1)
ytemp(j2,i2+1) = ytemp(j2,i2)+v(j2,i2+1)
! boundary conditions
if (xtemp(j2,i2+1)>l) then
xtemp(j2,i2+1) = xtemp(j2,i2+1)-2*l
else
if (xtemp(j2,i2+1)<-l) then
xtemp(j2,i2+1) = xtemp(j2,i2+1)+2*l
end if
end if
if (ytemp(j2,i2+1)>l) then
ytemp(j2,i2+1) = ytemp(j2,i2+1)-2*l
else
if (ytemp(j2,i2+1)<-l) then
ytemp(j2,i2+1) = ytemp(j2,i2+1)+2*l
end if
end if
end do
psi(i2+1) = sqrt(sum(u(:,i2+1))**2+sum(v(:,i2+1))**2)/dble(m)/dble(m)/s0
end do
x(:,1:nt+1) = xtemp(:,1:nt+1)
y(:,1:nt+1) = ytemp(:,1:nt+1)
end subroutine simulate_omp
You can time it and compare it with the outer loop parallelised using private(j2,k2,umean,vmean,usum,vsum,count), shared(u,v,xtemp,ytemp). Make sure to have OMP_NESTED set to true for the latter tests.
my code below uses the secant method to find the root of an analytic function. The analytic function, f must be specified in the function part of my code. The code below works well and has no compilation errors. However, for the problem I want to solve I do not know the analytic function f.
Instead I calculate the function numerically, and its stored as an array. I want now apply my code to find the roots of this function. So how can I modify my code such that the input is not an analytic function, instead just an array which I have already calculated?
My working code is below, I assume I just need to modify the last part where I call the function f, I just am unsure how to go about doing this. Thanks!
program main
implicit none
real :: a = 1.0, b = -1.0
integer :: m = 8
interface
function f(x)
real, intent(in) :: x
end function
end interface
call secant(f,a,b,m)
end program main
subroutine secant(f,a,b,m)
implicit none
real, intent(in out) :: a,b
integer, intent(in) :: m
real :: fa, fb, temp
integer :: n
interface
function f(x)
real, intent(in) :: x
end function f
end interface
fa = f(a)
fb = f(b)
if (abs(fa) > abs(fb)) then
temp = a
a = b
b = temp
temp = fa
fa = fb
fb = temp
end if
print *," n x(n) f(x(n))"
print *," 0 ", a, fa
print *," 1 ", b, fb
do n = 2,m
if (abs(fa) > abs(fb)) then
temp = a
a = b
b = temp
temp = fa
fa = fb
fb = temp
end if
temp = (b - a)/(fb - fa)
b = a
fb = fa
a = a - fa*temp
fa = f(a)
print *,n,a,fa
end do
end subroutine secant
real function f(x)
implicit none
real, intent(in) :: x
f = x**5 + x**3 + 3.0 !analytic form of a function, I don't actually have this though, I just have the function stored as an array
end function f
What I wanted to say in my comments are something as below.
You can modify your secant subroutine to take an object of an abstract class (FAZ) which is guaranteed to have a function f. For example, as following.
solver.f90
!*****************************************************************
MODULE solver
!*****************************************************************
IMPLICIT NONE
PRIVATE
PUBLIC FAZ
PUBLIC secant
TYPE, ABSTRACT :: FAZ
CONTAINS
PROCEDURE(f), deferred, pass :: f
END TYPE FAZ
ABSTRACT INTERFACE
FUNCTION f(this, x)
IMPORT :: FAZ
REAL :: f
CLASS(FAZ), INTENT(IN) :: this
REAL, INTENT(IN) :: x
END FUNCTION f
END INTERFACE
!=====================================================================
CONTAINS
!=====================================================================
subroutine secant(oFAZ,a,b,m)
CLASS(FAZ) :: oFAZ
real, intent(in out) :: a,b
integer, intent(in) :: m
real :: fa, fb, temp
integer :: n
fa = oFAZ%f(a)
fb = oFAZ%f(b)
if (abs(fa) > abs(fb)) then
temp = a
a = b
b = temp
temp = fa
fa = fb
fb = temp
end if
print *," n x(n) f(x(n))"
print *," 0 ", a, fa
print *," 1 ", b, fb
do n = 2,m
if (abs(fa) > abs(fb)) then
temp = a
a = b
b = temp
temp = fa
fa = fb
fb = temp
end if
temp = (b - a)/(fb - fa)
b = a
fb = fa
a = a - fa*temp
fa = oFAZ%f(a)
print *,n,a,fa
end do
end subroutine secant
END MODULE solver
You can then implement the behavior of the function f in whatever way you like by extending the abstract class FAZ to a concrete class MyFAZ. For example, I wrote it as following.
myfaz.f90
!*******************************************************************
MODULE my_concrete_faz
!*******************************************************************
USE solver, ONLY : FAZ
IMPLICIT NONE
PRIVATE
PUBLIC MyFAZ
PUBLIC MyFAZ_constructor
TYPE, EXTENDS(FAZ) :: MyFAZ
PRIVATE
REAL, DIMENSION(:), ALLOCATABLE :: xdata, fdata
CONTAINS
PROCEDURE :: destructor
PROCEDURE :: f
END TYPE MyFAZ
! ================================================================
CONTAINS
! ================================================================
! ****************************************************************
FUNCTION MyFAZ_constructor(xdata_arg, fdata_arg) RESULT(oMyFAZ)
! ****************************************************************
TYPE(MyFAZ) :: oMyFAZ
REAL, DIMENSION(:), INTENT(IN) :: xdata_arg, fdata_arg
INTEGER :: ndata, jj
ndata = size(xdata_arg)
if (size(fdata_arg) /= ndata) then
stop 'MyFAZ_constructor: array size mismatch .. ndata'
end if
do jj=1,ndata-1
if (xdata_arg(jj)>xdata_arg(jj+1)) then
stop 'MyFAZ_constructor: expecting a sorted xdata. I am lazy.'
end if
end do
allocate(oMyFAZ%xdata(ndata))
allocate(oMyFAZ%fdata(ndata))
oMyFAZ%xdata = xdata_arg
oMyFAZ%fdata = fdata_arg
END FUNCTION MyFAZ_constructor
! ****************************************************************
SUBROUTINE destructor(this)
! ****************************************************************
CLASS(MyFAZ), INTENT(INOUT) :: this
deallocate(this%xdata)
deallocate(this%fdata)
END SUBROUTINE destructor
! ****************************************************************
FUNCTION f(this, x)
! ****************************************************************
! evaluates the function.
! Linear interpolation is used here, but this will not make sense
! in actual application. Everything is written in a very inefficient way.
REAL :: f
CLASS(MyFAZ), INTENT(IN) :: this
REAL, INTENT(IN) :: x
!
INTEGER :: jj
REAL :: rr
do jj=1, size(this%xdata)-1
if (this%xdata(jj)<=x .and. x<=this%xdata(jj+1)) then
exit
end if
end do
rr = (this%fdata(jj+1) - this%fdata(jj))/(this%xdata(jj+1) - this%xdata(jj))
f = rr*(x - this%xdata(jj)) + this%fdata(jj)
END FUNCTION f
END MODULE my_concrete_faz
I used the linear interpolation, just for demonstration. Actually, if f(x) = r x + s, then you know the solution without using the secant method.
You will have your own appropriate method to evaluate f(x) between data points.
You can use the above two modules as following.
main.f90
PROGRAM demo
USE solver, ONLY : secant
USE my_concrete_faz, ONLY : MyFAZ, MyFAZ_constructor
IMPLICIT NONE
REAL, DIMENSION(:), ALLOCATABLE :: xdata, fdata
INTEGER :: ndata
INTEGER :: niter_max
REAL :: xa, xb
TYPE(MyFAZ) :: oMyFAZ
niter_max = 10
xa = -2.0
xb = 3.0
! prepare data
ndata = 4
allocate(xdata(ndata))
allocate(fdata(ndata))
xdata(1) = -3.0
xdata(2) = -1.1
xdata(3) = 1.2
xdata(4) = 3.8
fdata(1) = -1.5
fdata(2) = -0.9
fdata(3) = 0.1
fdata(4) = 0.8
! prepare the function
oMyFAZ = MyFAZ_constructor(xdata, fdata)
deallocate(xdata)
deallocate(fdata)
! solve
call secant(oMyFAZ,xa,xb,niter_max)
write(*,*) '**************'
write(*,*) 'normal end'
write(*,*) '**************'
END PROGRAM demo
I compiled, built, and got output as following.
$ ifort -c solver.f90
$ ifort -c myfaz.f90
$ ifort -c main.f90
$ ifort -o demo *.o
$ ./demo
n x(n) f(x(n))
0 3.000000 0.5846154
1 -2.000000 -1.184211
2 1.347448 0.1396975
3 0.8285716 -6.1490655E-02
4 0.9871597 7.4606538E-03
5 0.9700001 0.0000000E+00
6 0.9700001 0.0000000E+00
7 NaN NaN
8 NaN NaN
9 NaN NaN
10 NaN NaN
**************
normal end
**************
$
The NaNs are there because your secant subroutine reached to the solution before the maximum iteration, but had no way to exit in the middle of the loop.
Here is a plot of the data.
This question already has an answer here:
Random numbers keep coming out the same, despite random seed being used
(1 answer)
Closed last year.
I am attempting to write a Montecarlo algorithm to simulate interaction between agents in a population. This algorithm needs to call two random numbers at each iteration (say, 10^9 iterations).
My issue here is that everytime I change the seed (to obtain different realizations), the RNG is giving me the same output (same Montecarlo events). I have tried different ways of implementing it with to no avail.
I am completely new to Fortran and copying this code from MATLAB. Am I doing something wrong in the way I'm implementing this code?
Below is what I tried:
program Gillespie
implicit none
integer*8, parameter :: n_max = 10.0**8 ! max. number of iterations
integer*8 :: t_ext, I_init, S_init, jump, S_now, I_now, i, u
real*8 :: t, N, a0, tau, st, r1, r2
real, parameter :: beta = 1000
real, parameter :: gammma = 99.98
real, parameter :: mu = 0.02
real, parameter :: R0 = beta/(gammma+mu)
integer :: seed = 11
real, dimension(n_max) :: S_new ! susceptible pop. array
real, dimension(n_max) :: I_new ! infected pop. array
real, dimension(n_max) :: t_new ! time array
real, dimension(5) :: events ! events array
open(unit=3, file='SIS_output.dat')
t = 0 ! initial time
N = 40 ! initial population size
jump = 1 ! time increment (save in uniform increments)
u = 2
t_ext = 0 ! extiction time
I_init = 2 ! initial infected pop.
S_init = N-I_init ! initial susceptible pop.
S_now = S_init
I_now = I_init
S_new(1) = S_init ! initialize susceptibles array
I_new(1) = I_init ! initialize infected array
t_new(1) = t ! initialize time array
write(3,*) t_new(1), S_new(1), I_new(1) ! write i.c. to array
call random_seed(seed)
do i=2, n_max
call random_number(r1)
call random_number(r2)
events(1) = mu*N ! Birth(S)
events(2) = mu*S_now ! Death(S)
events(3) = mu*I_now ! Death(I)
events(4) = (beta*S_now*I_now)/N ! Infection
events(5) = gammma*I_now ! Recovery
a0 = events(1)+events(2)+events(3)+events(4)+events(5)
tau = LOG(1/r1)*(1/a0) ! time increment
t = t + tau ! update time
st = r2*a0 ! stochastic time???
! update the populations
if (st .le. events(1)) then
S_now = S_now + 1
else if (st .gt. events(1) .AND. st .le.
#(events(1) + events(2))) then
S_now = S_now - 1
else if (st .gt. (events(1) + events(2)) .AND. st .le.
#(events(1) + events(2) + events(3))) then
I_now = I_now - 1
else if (st .gt. (events(1) + events(2) + events(3)) .AND.
#st .le. (events(1) + events(2) + events(3) + events(4))) then
S_now = S_now - 1
I_now = I_now + 1
else
S_now = S_now + 1
I_now = I_now - 1
end if
! save time in uniform increments
if(t .ge. jump) then
t_new(u) = floor(t)
S_new(u) = S_now
I_new(u) = I_now
write(3,*) t_new(u), S_new(u), I_new(u)
jump = jump+1
u = u+1
end if
! write(3,*) t_new(i), S_new(i), I_new(i)
!N = S_now + I_now ! update population post event
if(I_now .le. 0) then ! if extinct, terminate
print *, "extinct"
goto 2
end if
end do
2 end program Gillespie
I appreciate all input. Thanks.
Your call
call random_seed(seed)
is strange. I thought it should not be allowed without a keyword argument, but it actually is inquiring for the size of the random seed array.
For a proper way of initializing seed see the example in
https://gcc.gnu.org/onlinedocs/gfortran/RANDOM_005fSEED.html
I have been tried to do the Morris Pratt table and the code is basically this one in C:
void preMp(char *x, int m, int mpNext[]) {
int i, j;
i = 0;
j = mpNext[0] = -1;
while (i < m) {
while (j > -1 && x[i] != x[j])
j = mpNext[j];
mpNext[++i] = ++j;
}
}
and here is where i get so far in Fortran
program MP_ALGORITHM
implicit none
integer, parameter :: m=4
character(LEN=m) :: x='abac'
integer, dimension(4) :: T
integer :: i, j
i=0
T(1)=-1
j=-1
do while(i < m)
do while((j > -1) .AND. (x(i+1:i+1) /= (x(j+i+1:j+i+1))))
j=T(j)
end do
i=i+1
j=j+1
T(i)=j
end do
print *, T(1:)
end program MP_ALGORITHM
and the problem is i think i am having the wrong output.
for x=abac it should be (?):
a b a c
-1 0 1 0
and my code is returning 0 1 1 1
so, what i've done wrong?
The problem here is that C indices start from zero, but Fortran indices start from one. You can try to adjust the index for every array acces by one, but this will get unwieldy.
The Morris-Pratt table itself is an array of indices, so it should look different in C and Fortran: The Fortran array should have one-based indices and it should use zero as invalid index.
Together with the error that chw21 pointed out, your function might look like this:
subroutine kmp_table(x, t)
implicit none
character(*), intent(in) :: x
integer, dimension(:), intent(out) :: t
integer m
integer :: i, j
m = len(x)
i = 1
t(1) = 0
j = 0
do while (i < m)
do while(j > 0 .and. x(i:i) /= x(j:j))
j = t(j)
end do
i = i + 1
j = j + 1
t(i) = j
end do
end subroutine
You can then use it in the Morris-Pratt algorithm as taken straight from the Wikipedia page with adjustment for Fortran indices:
function kmp_index(S, W) result(res)
implicit none
integer :: res
character(*), intent(in) :: S ! text to search
character(*), intent(in) :: W ! word to find
integer :: m ! zero-based offset in S
integer :: i ! one-based offset in W and T
integer, dimension(len(W)) :: T ! KMP table
call kmp_table(W, T)
i = 1
m = 0
do while (m + i <= len(S))
if (W(i:i) == S(m + i:m + i)) then
if (i == len(W)) then
res = m + 1
return
end if
i = i + 1
else
if (T(i) > 0) then
m = m + i - T(i)
i = T(i)
else
i = 1
m = m + 1
end if
end if
end do
res = 0
end function
(The index m is zero-based here, because t is only ever used in conjunction with i in S(m + i:m + i). Adding two one-based indices will yield an offset of one, whereas keeping m zero-based makes this a neutral addition. m is a local variable that isn't exposed to code from the outside.)
Alternatively, you could make your Fortran arrays zero-based by specifying a lower bound of zero for your string and array. That will clash with the useful character(*) notation, though, which always uses one-based indexing. In my opinion, it is better to think about the whole algorithm in the typical one-based indexing scheme of Fortran.
this site isn't really a debugging site. Normally I would suggest you have a look at how to debug code. It didn't take me very long to go through your code with a pen and paper and verify that that is indeed the table it produces.
Still, here are a few pointers:
The C code compares x[i] and x[j], but you compare x[i] and x[i+j] in your Fortran code, more or less.
Integer arrays usually also start at index 1 in Fortran. So just like adding one to the index in the x String, you also need to add 1 every time you access T anywhere.