Related
Today I'm trying to evaluate this differential equation for internal energy in a gas in Fortran 90:
du / dt = dT / dt = - λ / ρ
Where u is the internal energy and λ is the cooling function (and they are both functions of temperature T only). ρ is the mass density and we can assume it's constant.
I'm using a Runge-Kutta 2nd order method (heun), and I'm sure I wrote the actual solving algorithm correctly, but I'm pretty sure I'm messing up the implementation. I'm also not sure how to efficiently choose an arbitrary energy scale.
I'm implementing the Right Hand Side with this subroutine:
MODULE RHS
! right hand side
IMPLICIT NONE
CONTAINS
SUBROUTINE dydx(neq, y, f)
INTEGER, INTENT(IN) :: neq
REAL*8, DIMENSION(neq), INTENT(IN) :: y
REAL*8, DIMENSION(neq), INTENT(OUT) :: f
f(1) = -y(1)
END SUBROUTINE dydx
END MODULE RHS
And this is the Heun algorithm I'm using:
SUBROUTINE heun(neq, h, yold, ynew)
INTEGER, INTENT(IN) :: neq
REAL*8, INTENT(IN) :: h
REAL*8, DIMENSION(neq), INTENT(IN) ::yold
REAL*8, DIMENSION(neq), INTENT(OUT) :: ynew
REAL*8, DIMENSION(neq) :: f, ftilde
INTEGER :: i
CALL dydx(neq, yold, f)
DO i=1, neq
ynew(i) = yold(i) + h*f(i)
END DO
CALL dydx(neq, ynew, ftilde)
DO i=1, neq
ynew(i) = yold(i) + 0.5d0*h*(f(i) + ftilde(i))
END DO
END SUBROUTINE heun
Considering both lambda and rho are n-dimensional arrays, i'm saving the results in an array called u_tilde, selecting a starting condition at T = 1,000,000 K
h = 1.d0/n
u_tilde(1) = lambda(n)/density(n) ! lambda(3) is at about T=one million
DO i = 2, n
CALL heun(1, h*i, u_tilde(i-1), u_tilde(i))
ENDDO
This gives me this weird plot for temperature over time.
I would like to have a starting temperature of one million kelvin, and then have it cool down to 10.000 K and see how long it takes. How do I implement these boundary conditions?
What am I doing wrong in RHS and in setting up the calculation loop in the program?
Your implementation of dydx only assigns the first element.
Also, there is no need to define loops for each step, as Fortran90 can do vector operations.
For a modular design, I suggest implementing a custom type that holds your model data, like the mass density and the cooling coefficient.
Here is an example simple implementation, that only holds one scalar value, such that y' = -c y
module mod_diffeq
use, intrinsic :: iso_fortran_env, wp => real64
implicit none
type :: model
real(wp) :: coefficient
end type
contains
pure function dxdy(arg, x, y) result(yp)
type(model), intent(in) :: arg
real(wp), intent(in) :: x, y(:)
real(wp) :: yp(size(y))
yp = -arg%coefficient*y
end function
pure function heun(arg, x0, y0, h) result(y)
type(model), intent(in) :: arg
real(wp), intent(in) :: x0, y0(:), h
real(wp) :: y(size(y0)), k0(size(y0)), k1(size(y0))
k0 = dxdy(arg, x0, y0)
k1 = dxdy(arg, x0+h, y0 + h*k0)
y = y0 + h*(k0+k1)/2
end function
end module
and the above module is used for some cooling simulations with
program FortranCoolingConsole1
use mod_diffeq
implicit none
integer, parameter :: neq = 100
integer, parameter :: nsteps = 256
! Variables
type(model):: gas
real(wp) :: x, y(neq), x_end, h
integer :: i
! Body of Console1
gas%coefficient = 1.0_wp
x = 0.0_wp
x_end = 10.0_wp
do i=1, neq
if(i==1) then
y(i) = 1000.0_wp
else
y(i) = 0.0_wp
end if
end do
print '(1x," ",a22," ",a22)', 'x', 'y(1)'
print '(1x," ",g22.15," ",g22.15)', x, y(1)
! Initial Conditions
h = (x_end - x)/nsteps
! Simulation
do while(x<x_end)
x = x + h
y = heun(gas, x, y, h)
print '(1x," ",g22.15," ",g22.15)', x, y(1)
end do
end program
Note that I am only tracking the 1st element of neq components of y.
The sample output shows exponential decay starting from 1000
x y(1)
0.00000000000000 1000.00000000000
0.390625000000000E-01 961.700439453125
0.781250000000000E-01 924.867735244334
0.117187500000000 889.445707420492
0.156250000000000 855.380327695983
0.195312500000000 822.619637044785
0.234375000000000 791.113666448740
0.273437500000000 760.814360681126
0.312500000000000 731.675505009287
0.351562500000000 703.652654704519
0.390625000000000 676.703067251694
0.429687500000000 650.785637155231
0.468750000000000 625.860833241968
0.507812500000000 601.890638365300
0.546875000000000 578.838491418631
0.585937500000000 556.669231569681
...
Also, if you wanted the above to implement runge-kutta 4th order you can include the following in the mod_diffeq module
pure function rk4(arg, x0, y0, h) result(y)
type(model), intent(in) :: arg
real(wp), intent(in) :: x0, y0(:), h
real(wp) :: y(size(y0)), k0(size(y0)), k1(size(y0)), k2(size(y0)), k3(size(y0))
k0 = dxdy(arg, x0, y0)
k1 = dxdy(arg, x0+h/2, y0 + (h/2)*k0)
k2 = dxdy(arg, x0+h/2, y0 + (h/2)*k1)
k3 = dxdy(arg, x0+h, y0 + h*k2)
y = y0 + (h/6)*(k0+2*k1+2*k2+k3)
end function
Thank you guys, all your advices are relevant, but I gave up of Fortran and translated my code to Python. There, with just 1 or 2 little bugs my code worked perfect
I wrote a program to solve a linear system using the Gauss method. I wrote all the algorithms, the forward elimination and the back substitution and I made a lot of others subroutines and I don't know anymore what's wrong, I don't if is something wrong with my code or if some problem programming in Fortran because I'm new in this language. I'll put my code below and the linear system that I should find a solution
PROGRAM metodo_Gauss
IMPLICIT NONE
REAL :: det_a_piv
INTEGER :: n, i, j
REAL, DIMENSION(:,:), ALLOCATABLE :: a, a_piv
INTEGER, DIMENSION(:), ALLOCATABLE :: p
REAL, DIMENSION(:), ALLOCATABLE :: b, x
PRINT*, "Entre com a dimensão n do sistema a ser resolvido"
READ*, n
! allocate memory
ALLOCATE(a(n, n))
ALLOCATE(a_piv(n, n))
ALLOCATE(p(n))
ALLOCATE(b(n))
ALLOCATE(x(n))
CALL matriz_a(n, a)
CALL vetor_b(n, b)
a_piv(1:n, 1:n) = a(1:n, 1:n)
DO i = 1, n
x(i) = 0
END DO
CALL eliminacao(n, a, a_piv, p)
det_a_piv = (-1) ** n
DO j = 1, n
det_a_piv = det_a_piv * a_piv(j, j)
END DO
IF (det_a_piv == 0) THEN
PRINT*, "O sistema linear é indeterminado"
ELSE IF (abs(det_a_piv) <= 1) THEN
PRINT*, "O sistema linear é mal-condicionado"
ELSE
CALL substituicao(n, a_piv, p, b, x)
PRINT*, "A solução do sistema é:"
PRINT*, x
END IF
END PROGRAM metodo_Gauss
SUBROUTINE matriz_a(n, a)
IMPLICIT NONE
INTEGER, INTENT(in) :: n
REAL, DIMENSION(n,n), INTENT(inout) :: a
INTEGER :: i, j !Indícios usados em loops para percorrer os arrays
PRINT*, "Por favor digite os valores do elementos da matriz sistema linear seguindo pela ordem das linhas até o final:"
DO i = 1, n
DO j = 1, n
READ*, a(i,j)
END DO
END DO
END SUBROUTINE matriz_a
SUBROUTINE vetor_b(n, b)
IMPLICIT NONE
INTEGER, INTENT(in) :: n
REAL, DIMENSION(n), INTENT(inout) :: b
INTEGER :: i
PRINT*, "Por favor entre com os elementos do vetor b:"
DO i = 1, n
READ*, b(i)
END DO
END SUBROUTINE vetor_b
SUBROUTINE eliminacao(n, a, a_piv, p)
IMPLICIT NONE
INTEGER, INTENT(in) :: n
REAL, DIMENSION(n, n), INTENT(in) :: a
REAL, DIMENSION(n, n), INTENT(out) :: a_piv
INTEGER, DIMENSION(n), INTENT(out) :: p
INTEGER :: i, j, local, dim
REAL :: mult
DO i = 1, (n - 1)
dim = n - 1
CALL local_pivo(dim, a(i:n, i), local)
a_piv(i, i:n) = a(local, i:n)
a_piv(local, i:n) = a(i, i:n)
p(i) = local
DO j = (i + 1), n
mult = (-1) * (a_piv(j,i) / a_piv(local,i))
a_piv(j,i) = mult
a_piv(j, j:n) = a_piv(j, j:n) + mult * a_piv(i, j:n)
END DO
END DO
END SUBROUTINE eliminacao
SUBROUTINE local_pivo(n, a, local)
IMPLICIT NONE
INTEGER, INTENT(in) :: n
REAL, DIMENSION(n), INTENT(in) :: a
INTEGER, INTENT(inout) :: local
INTEGER :: i
local = 1
DO i = 2, n
IF ((ABS(a(i))) > ABS(a(local))) THEN
local = i
END IF
END DO
END SUBROUTINE local_pivo
SUBROUTINE substituicao(n, a_piv, p, b, x)
IMPLICIT NONE
INTEGER, INTENT(in) :: n
REAL, DIMENSION(n, n), INTENT(in) :: a_piv
REAL, DIMENSION(n), INTENT(out) :: b, x
INTEGER, DIMENSION(n), INTENT(in) :: p
INTEGER :: i, j, k, l, pivo
REAL :: aux
DO i = 1, (n - 1)
pivo = p(i)
IF (pivo /= i) THEN
aux = b(i)
b(i) = b(pivo)
b(pivo) = aux
END IF
DO j = (i + 1), n
b(j) = a_piv(j, i) * b(j) + b(i)
END DO
END DO
DO k = n, 1, -1
IF (k == n) THEN
x(n) = b(n) / a_piv(n, n)
ELSE
x(k) = (b(k) + a_piv(k, n) * x(n)) / a_piv(k, k)
DO l = n, k, -1
x(l) = x(l) + (a_piv(k, l) * x(l)) / a_piv(k, k)
END DO
END IF
END DO
END SUBROUTINE substituicao
Here it is the system that I'm trying to solve
My input is:
4
4
3
2
2
2
1
1
2
2
2
2
4
6
1
1
2
5
8
3
1
My output is:
-40.5000000 -40.2500000 -3.75000000 -37.5000000
But the output should be:
6.500000
-44.000000
72.000000
-16.500000
I am using a known code (CAMB) which generates values like this :
k(h/Mpc) Pk/s8^2(Mpc/h)^3
5.2781500000e-06 1.9477400000e+01
5.5479700000e-06 2.0432300000e+01
5.8315700000e-06 2.1434000000e+01
6.1296700000e-06 2.2484700000e+01
6.4430100000e-06 2.3587000000e+01
6.7723700000e-06 2.4743400000e+01
7.1185600000e-06 2.5956400000e+01
7.4824500000e-06 2.7228900000e+01
7.8649500000e-06 2.8563800000e+01
8.2669900000e-06 2.9964100000e+01
I would like to get more precision on the generated values, like this :
k(h/Mpc) Pk/s8^2(Mpc/h)^3
5.3594794736e-06 1.8529569626e+01
5.6332442000e-06 1.9437295914e+01
5.9209928622e-06 2.0389484405e+01
6.2234403231e-06 2.1388326645e+01
6.5413364609e-06 2.2436098099e+01
6.8754711720e-06 2.3535198212e+01
7.2266739153e-06 2.4688137054e+01
7.5958159869e-06 2.5897554398e+01
7.9838137026e-06 2.7166225433e+01
8.3916311269e-06 2.8497039795e+01
8.8202796178e-06 2.9893053055e+01
9.2708232842e-06 3.1357446670e+01
9.7443817140e-06 3.2893573761e+01
Here the section of code that produces the data :
I tried to do the following modifications in the declarations of variables at the beginning of code above :
1)First try :
!Export files of total matter power spectra in h^{-1} Mpc units, against k/h.
Type(MatterTransferData), intent(in) :: MTrans
Type(CAMBdata) :: State
character(LEN=Ini_max_string_len), intent(IN) :: FileNames(*)
character(LEN=name_tag_len) :: columns(3)
integer itf, i, unit
integer points
! Added : way of declaring double precision
integer, parameter :: wp = selected_real_kind(15,307)
real(wp), dimension(:,:), allocatable :: outpower
but it doesn't compile :
real(wp), dimension(:,:), allocatable :: outpower
1
Error: Symbol ‘wp’ at (1) has no IMPLICIT type
../results.f90:3660:25:
allocate(outpower(points,ncol))
1
Error: Allocate-object at (1) is neither a data pointer nor an allocatable variable
../results.f90:3676:16:
outpower(:,1) = exp(PK_data%matpower(:,1))
1
Error: Unclassifiable statement at (1)
../results.f90:3679:20:
outpower(:,3) = exp(PK_data%vvpower(:,1))
1
Error: Unclassifiable statement at (1)
compilation terminated due to -fmax-errors=4.
make[1]: *** [results.o] Error 1
make: *** [camb] Error 2
2) Also, I tried :
!Export files of total matter power spectra in h^{-1} Mpc units, against k/h.
Type(MatterTransferData), intent(in) :: MTrans
Type(CAMBdata) :: State
character(LEN=Ini_max_string_len), intent(IN) :: FileNames(*)
character(LEN=name_tag_len) :: columns(3)
integer itf, i, unit
integer points
! Added : way of declaring double precision
double precision, dimension(:,:), allocatable :: outpower
but same thing, no compilation succeeded
call Transfer_GetMatterPowerS(State, MTrans, outpower(1,1), itf, minkh,dlnkh, points)
1
Error: Type mismatch in argument ‘outpower’ at (1); passed REAL(8) to REAL(4)
make[1]: *** [results.o] Error 1
make: *** [camb] Error 2
UPDATE 1:
with -fmax-errors=1, I get the following :
call Transfer_GetMatterPowerS(State, MTrans, outpower(1,1), itf, minkh,dlnkh, points)
1
Error: Type mismatch in argument ‘outpower’ at (1); passed REAL(8) to REAL(4)
compilation terminated due to -fmax-errors=1.
Except the solution given by #Steve with compilation option -freal-4-real-8, isn't really there another solution that I could include directly into code, i.e the section that I have given ?
UPDATE 2: here below the 3 relevant subroutines Transfer_GetMatterPowerS , Transfer_GetMatterPowerData and Transfer_SaveMatterPower that produces the error when trying to get double precision :
subroutine Transfer_GetMatterPowerS(State, MTrans, outpower, itf, minkh, dlnkh, npoints, var1, var2)
class(CAMBdata) :: state
Type(MatterTransferData), intent(in) :: MTrans
integer, intent(in) :: itf, npoints
integer, intent(in), optional :: var1, var2
real, intent(out) :: outpower(*)
real, intent(in) :: minkh, dlnkh
real(dl) :: outpowerd(npoints)
real(dl):: minkhd, dlnkhd
minkhd = minkh; dlnkhd = dlnkh
call Transfer_GetMatterPowerD(State, MTrans, outpowerd, itf, minkhd, dlnkhd, npoints,var1, var2)
outpower(1:npoints) = outpowerd(1:npoints)
end subroutine Transfer_GetMatterPowerS
subroutine Transfer_GetMatterPowerData(State, MTrans, PK_data, itf_only, var1, var2)
!Does *NOT* include non-linear corrections
!Get total matter power spectrum in units of (h Mpc^{-1})^3 ready for interpolation.
!Here there definition is < Delta^2(x) > = 1/(2 pi)^3 int d^3k P_k(k)
!We are assuming that Cls are generated so any baryonic wiggles are well sampled and that matter power
!spectrum is generated to beyond the CMB k_max
class(CAMBdata) :: State
Type(MatterTransferData), intent(in) :: MTrans
Type(MatterPowerData) :: PK_data
integer, intent(in), optional :: itf_only
integer, intent(in), optional :: var1, var2
double precision :: h, kh, k, power
integer :: ik, nz, itf, itf_start, itf_end, s1, s2
s1 = PresentDefault (transfer_power_var, var1)
s2 = PresentDefault (transfer_power_var, var2)
if (present(itf_only)) then
itf_start=itf_only
itf_end = itf_only
nz = 1
else
itf_start=1
nz= size(MTrans%TransferData,3)
itf_end = nz
end if
PK_data%num_k = MTrans%num_q_trans
PK_Data%num_z = nz
allocate(PK_data%matpower(PK_data%num_k,nz))
allocate(PK_data%ddmat(PK_data%num_k,nz))
allocate(PK_data%nonlin_ratio(PK_data%num_k,nz))
allocate(PK_data%log_kh(PK_data%num_k))
allocate(PK_data%redshifts(nz))
PK_data%redshifts = State%Transfer_Redshifts(itf_start:itf_end)
h = State%CP%H0/100
do ik=1,MTrans%num_q_trans
kh = MTrans%TransferData(Transfer_kh,ik,1)
k = kh*h
PK_data%log_kh(ik) = log(kh)
power = State%CP%InitPower%ScalarPower(k)
if (global_error_flag/=0) then
call MatterPowerdata_Free(PK_data)
return
end if
do itf = 1, nz
PK_data%matpower(ik,itf) = &
log(MTrans%TransferData(s1,ik,itf_start+itf-1)*&
MTrans%TransferData(s2,ik,itf_start+itf-1)*k &
*const_pi*const_twopi*h**3*power)
end do
end do
call MatterPowerdata_getsplines(PK_data)
end subroutine Transfer_GetMatterPowerData
subroutine Transfer_SaveMatterPower(MTrans, State,FileNames, all21cm)
use constants
!Export files of total matter power spectra in h^{-1} Mpc units, against k/h.
Type(MatterTransferData), intent(in) :: MTrans
Type(CAMBdata) :: State
character(LEN=Ini_max_string_len), intent(IN) :: FileNames(*)
character(LEN=name_tag_len) :: columns(3)
integer itf, i, unit
integer points
! Added : way of declaring double precision
!integer, parameter :: wp = selected_real_kind(15,307)
!real(wp), dimension(:,:), allocatable :: outpower
double precision, dimension(:,:), allocatable :: outpower
real minkh,dlnkh
Type(MatterPowerData) :: PK_data
integer ncol
logical, intent(in), optional :: all21cm
logical all21
!JD 08/13 Changes in here to PK arrays and variables
integer itf_PK
all21 = DefaultFalse(all21cm)
if (all21) then
ncol = 3
else
ncol = 1
end if
do itf=1, State%CP%Transfer%PK_num_redshifts
if (FileNames(itf) /= '') then
if (.not. transfer_interp_matterpower ) then
itf_PK = State%PK_redshifts_index(itf)
points = MTrans%num_q_trans
allocate(outpower(points,ncol))
!Sources
if (all21) then
call Transfer_Get21cmPowerData(MTrans, State, PK_data, itf_PK)
else
call Transfer_GetMatterPowerData(State, MTrans, PK_data, itf_PK)
!JD 08/13 for nonlinear lensing of CMB + LSS compatibility
!Changed (CP%NonLinear/=NonLinear_None) to CP%NonLinear/=NonLinear_none .and. CP%NonLinear/=NonLinear_Lens)
if(State%CP%NonLinear/=NonLinear_none .and. State%CP%NonLinear/=NonLinear_Lens) then
call State%CP%NonLinearModel%GetNonLinRatios(State, PK_data)
PK_data%matpower = PK_data%matpower + 2*log(PK_data%nonlin_ratio)
call MatterPowerdata_getsplines(PK_data)
end if
end if
outpower(:,1) = exp(PK_data%matpower(:,1))
!Sources
if (all21) then
outpower(:,3) = exp(PK_data%vvpower(:,1))
outpower(:,2) = exp(PK_data%vdpower(:,1))
outpower(:,1) = outpower(:,1)/1d10*const_pi*const_twopi/MTrans%TransferData(Transfer_kh,:,1)**3
outpower(:,2) = outpower(:,2)/1d10*const_pi*const_twopi/MTrans%TransferData(Transfer_kh,:,1)**3
outpower(:,3) = outpower(:,3)/1d10*const_pi*const_twopi/MTrans%TransferData(Transfer_kh,:,1)**3
end if
call MatterPowerdata_Free(PK_Data)
columns = ['P ', 'P_vd','P_vv']
unit = open_file_header(FileNames(itf), 'k/h', columns(:ncol), 15)
do i=1,points
write (unit, '(*(E15.6))') MTrans%TransferData(Transfer_kh,i,1),outpower(i,:)
end do
close(unit)
else
if (all21) stop 'Transfer_SaveMatterPower: if output all assume not interpolated'
minkh = 1e-4
dlnkh = 0.02
points = log(MTrans%TransferData(Transfer_kh,MTrans%num_q_trans,itf)/minkh)/dlnkh+1
! dlnkh = log(MTrans%TransferData(Transfer_kh,MTrans%num_q_trans,itf)/minkh)/(points-0.999)
allocate(outpower(points,1))
call Transfer_GetMatterPowerS(State, MTrans, outpower(1,1), itf, minkh,dlnkh, points)
columns(1) = 'P'
unit = open_file_header(FileNames(itf), 'k/h', columns(:1), 15)
do i=1,points
write (unit, '(*(E15.6))') minkh*exp((i-1)*dlnkh),outpower(i,1)
end do
close(unit)
end if
deallocate(outpower)
end if
end do
end subroutine Transfer_SaveMatterPower
With the following program I experience errors.
Program COM
!Input
!No of Atoms
!No of Iterations
!Respective Positions.
!As of now for homogeneous clusters.
Implicit None
Real, Parameter :: R8B=selected_real_kind(10)
Real, Parameter :: R4B=selected_real_kind(4)
Integer, Parameter :: I1B=selected_int_kind(2)
Integer, Parameter :: I2B=selected_int_kind(4)
Integer, Parameter :: I4B=selected_int_kind(9)
Integer, Parameter :: I8B=selected_int_kind(18)
Real (R8B), Dimension (:,:), Allocatable :: Posx, Posy, Posz
Real (R8B), Dimension (:), Allocatable :: Posx_n, Posy_n, Posz_n
Real (R8B), Dimension (:), Allocatable :: dist_com, avj_dist_com
Integer (I4B), Dimension (:), Allocatable :: bin_array
Real (R8B) :: comx, comy, comz
Integer (I8B) :: nIter, nAtom, dist
Integer (I8B) :: I,J,ii,k
Integer (I1B) :: xyz_format, FlagR, FlagM, Flag_com
Integer (I8B) :: bin
Integer (R8B) :: max_dist
Character (50) POS_file, COM_file,Bin_file
Character (2) jj
Read (*,*) POS_file
Read (*,*) COM_file
Read (*,*) Bin_file
Read (*,*) nAtom
Read (*,*) nIter
Read (*,*) xyz_format
Read (*,*) max_dist, bin
! if Flag_com == 1 then compute dist from COM
! if its 0 then specify the atom no and g(r) will be computed..
! i.e. no of atoms from that atom between dist r and r + dr
Allocate (Posx(nAtom,nIter))
Allocate (Posy(nAtom,nIter))
Allocate (Posz(nAtom,nIter))
! xyz_format = 0 ==> old_ks
! xyz_format = 1 ==> xmakemol
! xyz_format = 2 ==> Envision
write(*,*)POS_file
Open (unit=99, file=POS_file)
if (xyz_format == 0 ) then
do i = 1,nIter
read(99,*)
do j = 1,nAtom
read(99,*)ii,Posx(j,i),Posy(j,i),Posz(j,i),ii
enddo
enddo
elseif (xyz_format == 1 ) then
do i = 1,nIter
read(99,*)ii
read(99,*)
do j = 1,nAtom
read(99,*)jj,Posx(j,i),Posy(j,i),Posz(j,i)
enddo
enddo
elseif (xyz_format == 2 ) then
read(99,*)
read(99,*)
read(99,*)
read(99,*)
do i = 1,nIter
do j = 1,nAtom
read(99,*)
read(99,*)Posx(j,i),Posy(j,i),Posz(j,i)
enddo
enddo
endif
Close (99)
Write (*,'(\1x,"Reading Complete")')
allocate (avj_dist_com (nIter))
allocate (dist_com (nAtom))
avj_dist_com = 0.0d0
dist_com = 0.0d0
Allocate (Posx_n(nAtom))
Allocate (Posy_n(nAtom))
Allocate (Posz_n(nAtom))
Allocate (Bin_Array(bin))
Posx_n = 0.0d0
Posy_n = 0.0d0
Posz_n = 0.0d0
bin_array = 0.0d0
Open (unit=2, file=COM_file)
Do I = 1, nIter
comx = 0.0d0
comy = 0.0d0
comz = 0.0d0
Do J = 1, nAtom
comx = comx + Posx(j,i)
comy = comy + Posy(j,i)
comz = comz + Posz(j,i)
Enddo
comx = comx/nAtom
comy = comy/nAtom
comz = comz/nAtom
Write (*,*) i, comx, comy, comz
Do J = 1, nAtom
Posx_n (j) = Posx(j,i) - comx
Posy_n (j) = Posy(j,i) - comy
Posz_n (j) = Posz(j,i) - comz
dist_com (j) = dsqrt ( Posx_n(j)*Posx_n(j) &
+ Posy_n(j)*Posy_n(j) &
+ Posz_n(j)*Posz_n(j) )
avj_dist_com (i) = avj_dist_com(i) + dist_com(j)
Enddo
avj_dist_com(i) = avj_dist_com(i)/nAtom
Do j = 1, nAtom
dist = dist_com (j) * dfloat((bin/max_dist))
bin_array(dist) = bin_array(dist) + 1
Enddo
write (2,'(2x,i6,143(2x,f10.7))') I, avj_dist_com(i),(dist_com(k),k=1,nAtom)
write(*,*) i
Enddo
close (2)
Open (unit=3, file=Bin_file)
do i = 1, bin
write (3,'(2x,i6,4x,i8)') i , bin_array(i)
enddo
close (3)
deAllocate (Posx)
deAllocate (Posy)
deAllocate (Posz)
deAllocate (Posx_n)
deAllocate (Posy_n)
deAllocate (Posz_n)
deallocate (avj_dist_com)
deallocate (dist_com)
deallocate (bin_array)
Stop
End Program COM
The errors look like
Real(KIND=r8b), Dimension (:), Allocatable :: Posx, Posy, Posz
1
Error: Integer expression required at (1)
and there are many more
How can I rectify these?
The kind parameter for a type must be an integer constant expression. You have the latter part down, as you are using named constants R8B and R4B.
However, and this is what the error message says, you have not used an integer constant expression. You should notice that selected_real_kind returns an integer value even as the kind for a selected real type. So, you can correct your code with
Integer, Parameter :: R8B=selected_real_kind(10)
Integer, Parameter :: R4B=selected_real_kind(4)
As we know, more recent versions of Fortran support array operations, which can eliminate many loops. So I was wondering if it would be possible to eliminate even the last remaining loop in following code snippet (as to make it a one-liner):
subroutine test(n,x,lambda)
integer, intent(in) :: n
real, dimension(:), intent(in) :: x
real, dimension(:), intent(out) :: lambda
real :: eps
integer :: i
do i=1,n
lambda(i) = product(x(i)-x, mask=(abs(x(i)-x) > epsilon(eps)))
enddo
end subroutine
Its intention is to calculate n lambda(i) values in which
lambda(i) = (x(i)-x(1))*(x(i)-x(2))*...*(x(i)-x(i-1)*(x(i)-x(i+1))*...*(x(i)-x(n))
OK, try this
lambda = product(max(spread(x, dim=1, ncopies=size(x)) - &
spread(x, dim=2, ncopies=size(x)), eps), dim=2)
That's a one-liner. It's also rather wasteful of memory and much less comprehensible than the original.
Have you tried it with an implied do-loop in the array creation? something like real, dimension(:), intent(out):: lambda =(/product(x(i)-x, mask=(abs(x(i)-x)>epsilon(eps))), i=1, n/) ... I am not sure about the syntax here, but something like that might work.
You might even be able to create the array without calling the subroutine and do it in your main program, if your x-array is available.
Hope it helps.
Yes, you can shorten this, product can use 2D arrays:
You would first need to set up a matrix of the differences:
do i=1,n
mat(:,i) = x(i) - x
enddo
or, as a one-liner:
forall ( i=1:n ) mat(:,i) = x(i) - x
Now you can do the product along the second dimension:
lambda = product(mat, dim=2, mask=(abs(mat) > epsilon(eps)))
Whole program:
program test
integer, parameter :: n = 3
real, dimension(n) :: x
real, dimension(n) :: lambda
real, dimension(n,n) :: mat
real :: eps = 1.
integer :: i
call random_number( x )
do i=1,n
lambda(i) = product(x(i)-x, mask=(abs(x(i)-x) > epsilon(eps)))
enddo
print *,lambda
forall ( i=1:n ) mat(:,i) = x(i) - x
lambda = product(mat, dim=2, mask=(abs(mat) > epsilon(eps)))
print *,lambda
end program