Reading integer data from a file using fortran [duplicate] - fortran

I'm stuck in a process where I need to compute the values of a function f[x,y,z] on a grid. Here I put how I wrote the program, only evaluating on a one-dimensional grid.
I wrote the program:
program CHISQUARE_MINIMIZATION_VELOCITY_PROFILES
use distribution
IMPLICIT none
integer, parameter :: kp=1001 ! Parameter which states the number of points on the grid.
integer, parameter :: ndata=13 ! Parameter which states the number of elements of the data file.
integer, parameter :: nconst=3 ! Fixed integer parameter.
integer i, j, n
real*8 rc0, rcf, V00, V0f, d00, d0f, rc, V0, d, z
real*8 rcr(kp), V0r(kp), d0r(kp), chisq(kp)
!Scaling radius range
rc0=0.0d-5 ! kpc
rcf=1.0d2 ! kpc
call linspace(rc0,rcf,kp,rcr)
!**************If I call like this, it works normal*****************
!CHISQUARED(1.3d0, 130.2d0, 0.12d0, 1.0d0, 1.0d0, 2.0d0, 0.0d0, 0.0d0, 1, !ndata, nconst)
! **1.27000000000000 0.745818846396887**
! Press any key to continue
!**************If I call like this, it works normal*****************
!******* Here is where my problem is****************
do j=1, kp
rc=rcr(j)
write(*,*) rc, CHISQUARED(rc, 130.2d0, 0.12d0, 1.0d0, 1.0d0, 2.0d0, 0.0d0, 0.0d0, 1, ndata, nconst)
enddo
!******* Here is where my problem is****************
end program CHISQUARE_MINIMIZATION_VELOCITY_PROFILES
I use the module where I compute the chi^2 distribution, coming from a theoretical model...
MODULE distribution
IMPLICIT NONE
CONTAINS
! I define here the chi^2 function****
real*8 function CHISQUARED(rc, V0, d, alpha, gamma, chi, a, b, n, ndata, nconst)
integer i, n, ndata, nconst
real*8 rc, V0, d
real*8 alpha, gamma, chi, a, b, s
real*8, DIMENSION(ndata,3) :: X
open(unit=1, file="data.txt")
s=0.0d0
do i=1, ndata
Read(1,*) X(i,:)
s=s+((X(i,2)-VELOCITYPROFILE(X(i,1), rc, V0, d, alpha, gamma, chi, a, b, n))/(X(i,3)))**2.0d0
end do
CHISQUARED=s/(ndata-nconst)
end function CHISQUARED
!****Here I define the model function
real*8 function VELOCITYPROFILE(r, rc, V0, d, alpha, gamma, chi, a, b, n)
integer i, n
real*8 r, rc, V0, d, alpha, gamma, chi, a, b, z
if (rc < 0.0d0 .OR. d < 0.0d0 .OR. a <0.0d0 .OR. b <0.0d0 .OR. alpha < 0.0d0 .OR. gamma <0.0d0 .OR. chi < 0.0d0 .OR. n<1 ) then
VELOCITYPROFILE=0.0d0
return
else
z=0.0d0
do i=0,n
z=z+((V0*((r/rc)**(1.5d0))*(1+a+r/rc)**(-gamma*(2*n+0.5d0)))/((a+(r/rc)**alpha)**(chi/2.0d0)))*(((b+r/rc)**gamma)/d)**i
end do
VELOCITYPROFILE=z
end if
end function VELOCITYPROFILE
END MODULE distribution
!*****************END OF THE MODULE******************************
the data.txt file is of the form
0.24 37.31 6.15
0.28 37.92 5.5
0.46 47.12 3.9
0.64 53.48 2.8
0.73 55.14 3.3
0.82 58.47 2.5
1.08 66.15 3.3
1.22 69.39 2.75
1.45 74.55 5.
1.71 77.94 2.93
1.87 81.66 2.5
2.2 86.81 3.02
2.28 90.08 2.1
2.69 94.38 3.92
2.7 95.36 1.8
In order to get several values of the function CHISQUARED, I use the subroutine linspace to generate the partition of the 1-dimensional grid
subroutine linspace(xi,xf,jmax,y)
integer jmax,j
real*8 xi,xf,y(jmax)
y=(/(xi+dble(j-1)*(xf-xi)/(dble(jmax)-1.0d0), j=1, jmax)/)
end subroutine linspace
What happens is that if in the main program, I call the function CHISQUARED like this:
CHISQUARED(1.3d0, 130.2d0, 0.12d0, 1.0d0, 1.0d0, 2.0d0, 0.0d0, 0.0d0, 1, ndata, nconst)
**1.27000000000000 0.745818846396887**
Press any key to continue
I get some finite value, like, I don't know, 0.7 or something like this. (I restricted the data file so the result won't be the one written, I just put 0.7 as an example). However, when I put it inside a loop as it is in the program written above, to get the values on the one dimensional grid, it gives me the error
**0.000000000000000E+000 NaN**
forrtl: severe (24): end-of-file during read, unit 1, file C:\Users\Ernesto Lopez Fune\Desktop\Minimize\newone\chisquarerotationcurve\data.txt
Image PC Routine Line Source
chisquarerotation 0040B889 Unknown Unknown Unknown
Press any key to continue
Can anyone recommend me what to do in this case? How to overcome this barrier?

According to your error, you reach the end of your file.
When you call your subroutine once, it's OK but in a loop, your file is read multiple times. After the first iteration, your file is read until the EOF control but for the next iteration, the program can't read anymore because it has already reached the end of the file.
You need to use the REWIND(1) statement before end function CHISQUARED. With this, the cursor will be re-positioned at the beginning of the file. Besides, I think it would be better to OPEN your file in the main program and not in a function or subroutine to avoid multiple OPEN/CLOSE.
Don't forget to CLOSE your file when you are done dealing with it.

Related

How to change my code to produce a rectangulear shape of the atomic layer and how to add additional layers?

I have been working on my thesis on the topic of the generation of Graphene sheet using Fortran in Linux. I have written the code for the graphene sheet but it is forming in the rhombus shape which I wanted in the rectangle shape. I am attaching the image of the sheet I have developed using the below code.
I would like to modify this code to form into a rectangle and also I want to make the layers of the sheet into 4-5 layers.
program test_graphenecoord
Implicit none
real(kind=8) :: a1(3), a2(3)
real(kind=8) :: pos1(3), pos2(3)
real(kind=8) :: pi, a0, c, bohr
real(kind=8), allocatable :: pos(:,:)
integer :: natoms, i, ii, j, jj, k, n, m
parameter(a0=2.461d0, bohr=0.52917720d0, c=15.d0)
n=5
m=5
natoms=2*n*m
allocate(pos(natoms,3))
pi=2*asin(1.d0)
a1(1)= a0*cos(pi/6.d0)
a1(2)= a0*sin(pi/6.d0)
a1(3)=c
a2(1)= a0*cos(pi/6.d0)
a2(2)=-a0*sin(pi/6.d0)
a2(3) =c
pos1(:) =(a1(:)+a2(:))/3.d0
pos2(:) =2.d0*pos1(:)
k=0
do i=1, n
do j=1, m
k=k+1
pos(k,:)= pos1(:)+a1(:)*(i-1)+a2(:)*(j-1)
pos(k,3)=c
k=k+1
pos(k,:)=pos2(:)+a1(:)*(i-1)+a2(:)*(j-1)
pos(k,3)=c
end do
end do
if( k /= natoms) then
write(*,*) 'something is wrong'
stop
end if
write(17,*) natoms
write(17,*)
do i=1,natoms
write(17,*) 'C', pos(i,:)
end do
end program

Intensity using bessel function tending to infinity

Making it short, my code is supposed to return a txt with my intensity values, instead, for all rs but 0, my intensity returns a value of +infinity. Don't know where my mistake is. This exercise is supposed to make us practice integration via Simpson's 1/3 method. All Bessels Jx txt values are working fine, the only problem relies within my intensity file. First code block is responsible for creating and filling Bessel Jx values in a txt file. Second part is responsible for creating and filling intensity values through a Bessel function (this is where the error is supposed to be, but i'm not sure). Third and fourth blocks are the Simpson 1/3 method and my Bessel function, respectively.
program intensidade
implicit none
real,parameter::pi=acos(-1.),lambda=500e-9
real::k,r,kr,intensidade1
real,external::bessel,simpson13
real::i
integer::j
open(0,file='besselj0.txt')
open(1,file='besselj1.txt')
open(2,file='besselj2.txt')
open(3,file='intensidade.txt')
do j=0,2
i=0
do while (i<=20)
write(j,*)i,simpson13(bessel,j,i,0.,pi)
i=i+1
enddo
enddo
close(0);
close(1);
close(2);
r=0
k=2*pi/lambda
kr=k*r*10e-6
do while (r<=1)
if(r==0) then
write(3,*)r,(1/2)**2
else
write(3,*)r,(simpson13(bessel,1,kr,0.,pi)/kr)**2
endif
r=r+0.1
enddo
close(3)
pause
end program intensidade
real function simpson13(funcao,m,x,a,b)
implicit none
real,external::funcao
real,intent(in)::a,b,x
integer,intent(in)::m
integer::i
real::h
h=(b-a)/1000
simpson13=funcao(m,x,a)-funcao(m,x,b)
do i=1,499
simpson13=simpson13+4*funcao(m,x,a+h*(2*i-1))+2*funcao(m,x,a+2*h*i)
enddo
simpson13=(h/3)*simpson13
end function simpson13
real function bessel(m,x,teta)
implicit none
real,parameter::pi=acos(-1.)
real,intent(in)::x,teta
integer,intent(in)::m
bessel=cos(m*teta-x*sin(teta))/pi
end function bessel
The main error arises because kr is not redefined in each loop.
Other improvements
style: align and indent your code
use file units provided by the system, i.e. open (newunit=...)
remove the pause command
Furthermore, your line write(..)r,(1/2)**2 uses integer arithmetic s.t. 1/2 yields zero and (1/2)**2 is zero as well.
The following is a possible way to rewrite your program
program intensidade
implicit none
real, parameter :: pi=acos(-1.0), lambda=500e-9
real :: k, r, kr
real, external :: bessel, simpson13
integer :: ir, funit, ix, m
character(128) :: fname
do m = 0, 2
write (fname, "(A7, I1, A4)") 'besselj', m, '.txt'
open (newunit=funit, file=fname)
do ix = 0, 20
write (funit, *) ix, simpson13(bessel, m, real(ix), 0.0, pi)
end do
close (funit)
end do
open (newunit=funit, file='intensidade.txt')
r = 0
k = 2*pi/lambda
write (funit, *) r, (0.5)**2
do ir = 1, 10
r = ir/10.0
kr = k*r*10e-6
write (funit, *) r, (simpson13(bessel, 1, kr, 0.0, pi)/kr)**2
end do
close (funit)
end program

How to calculate several different random numbers from normal dist? using fortran

I have to find 'n' random numbers from a normal distribution given the mean and standard deviation. I have figure out how to get a random number, but when try to loop it to get several different random numbers, it gives me the same number x amount of times?
program prac10
implicit none
real :: mu, sigma
integer :: i
!print*, "mean and stdev?"
!read*, mu, sigma
mu=1.1
sigma=0.1
do i=1, 2 # here is the part I think I am stuck on??
call normal(mu,sigma)
enddo
end program
subroutine normal(mu,sigma)
implicit none
integer :: i
integer :: n
real :: u, v, z, randnum
real :: mu, sigma
real :: pi=3.141593
call RANDOM_SEED()
call RANDOM_NUMBER(u)
call RANDOM_NUMBER(v)
z=sqrt(-2*log(u))*cos(2*pi*v)
randnum=mu+sigma*z
print*, randnum
end subroutine
particularly the part where I should be looping/repeating. I used from 1:2, replacing n with 2 for now so that I wouldn't have to input it every time I try to run it
The most important fact is that you must not call RANOM_SEED repeatedly. It is supposed to be called only once.
It is also good to modify the subroutine to generate the number and pass it further. Notice also the change of formatting to make it more readable and the change in the value of pi.
program prac10
implicit none
real :: mu, sigma, x
integer :: i
call RANDOM_SEED()
mu = 1.1
sigma = 0.1
do i = 1, 2
call normal(x,mu,sigma)
print *, x
end do
end program
subroutine normal(randnum,mu,sigma)
implicit none
integer :: i
integer :: n
real :: u, v, z, randnum
real :: mu, sigma
real :: pi = acos(-1.0)
call RANDOM_NUMBER(u)
call RANDOM_NUMBER(v)
z = sqrt(-2*log(u)) * cos(2*pi*v)
randnum = mu + sigma*z
end subroutine

Prevent changing variables with intent(in)

so reading the following question (Correct use of FORTRAN INTENT() for large arrays) I learned that defining a variable with intent(in) isn't enough, since when the variable is passed to another subroutine/function, it can be changed again. So how can I avoid this? In the original thread they talked about putting the subroutine into a module, but that doesn't help for me. For example I want to calculate the determinant of a matrix with a LU-factorization. Therefore I use the Lapack function zgetrf, but however this function alters my input matrix and the compiler don't displays any warnings. So what can I do?
module matHelper
implicit none
contains
subroutine initMat(AA)
real*8 :: u
double complex, dimension(:,:), intent(inout) :: AA
integer :: row, col, counter
counter = 1
do row=1,size(AA,1)
do col=1,size(AA,2)
AA(row,col)=cmplx(counter ,0)
counter=counter+1
end do
end do
end subroutine initMat
!subroutine to write a Matrix to file
!Input: AA - double complex matrix
! fid - integer file id
! fname - file name
! stat - integer status =replace[0] or old[1]
subroutine writeMat(AA,fid, fname, stat)
integer :: fid, stat
character(len=*) :: fname
double complex, dimension(:,:), intent(in) :: AA
integer :: row, col
character (len=64) :: fmtString
!opening file with given options
if(fid /= 0) then
if(stat == 0) then
open(unit=fid, file=fname, status='replace', &
action='write')
else if(stat ==1) then
open(unit=fid, file=fname, status='old', &
action='write')
else
print*, 'Error while trying to open file with Id', fid
return
end if
end if
!initializing matrix print format
write(fmtString,'(I0)') size(aa,2)
fmtString = '('// trim(fmtString) //'("{",ES10.3, ",", 1X, ES10.3,"}",:,1X))'
!write(*,*) fmtString
!writing matrix to file by iterating through each row
do row=1,size(aa,1)
write(fid,fmt = fmtString) AA(row,:)
enddo
write(fid,*) ''
end subroutine writeMat
!function to calculate the determinant of the input
!Input: AA - double complex matrix
!Output determinantMat - double complex,
! 0 if AA not a square matrix
function determinantMat(AA)
double complex, dimension(:,:), intent(in) :: AA
double complex :: determinantMat
integer, dimension(min(size(AA,1),size(AA,2)))&
:: ipiv
integer :: ii, info
!check if not square matrix, then set determinant to 0
if(size(AA,1)/= size(AA,2)) then
determinantMat = 0
return
end if
!compute LU facotirzation with LAPACK function
call zgetrf(size(AA,1),size(AA,2), AA,size(AA,1), ipiv,info)
if(info /= 0) then
determinantMat = cmplx(0.D0, 0.D0)
return
end if
determinantMat = cmplx(1.D0, 0.D0)
!determinant of triangular matrix is product of diagonal elements
do ii=1,size(AA,1)
if(ipiv(ii) /= ii) then
!a permutation was done, so a factor of -1
determinantMat = -determinantMat *AA(ii,ii)
else
!no permutation, so no -1
determinantMat = determinantMat*AA(ii,ii)
end if
end do
end function determinantMat
end module matHelper
!***********************************************************************
!module which stores matrix elements, dimension, trace, determinant
program test
use matHelper
implicit none
double complex, dimension(:,:), allocatable :: AA, BB
integer :: n, fid
fid = 0;
allocate(AA(3,3))
call initMat(AA)
call writeMat(AA,0,' ', 0)
print*, 'Determinante: ',determinantMat(AA) !changes AA
call writeMat(AA,0, ' ', 0)
end program test
PS: I am using the ifort compiler v15.0.3 20150407
I do not have ifort at home, but you may want to try compiling with '-check interfaces' and maybe with '-ipo'. You may need the path to 'zgetrf' for the '-check interfaces' to work, and if that is not source then it may not help.
If you declare 'function determinantMat' as 'PURE FUNCTION determinantMat' then I am pretty sure it would complain because 'zgetrf' is not known to be PURE nor ELEMENTAL. Try ^this stuff^ first.
If LAPACK has a module, then zgetrf could be known to be, or not be, PURE/ELEMENTAL. https://software.intel.com/en-us/articles/blas-and-lapack-fortran95-mod-files
I would suggest you add to your compile line:
-check interfaces -ipo
During initial build I like (Take it out for speed once it works):
-check all -warn all
Making a temporary array is one way around it. (I have not compiled this, so it is only a conceptual exemplar.)
PURE FUNCTION determinantMat(AA)
USE LAPACK95 !--New Line--!
IMPLICIT NONE !--New Line--!
double complex, dimension(:,:) , intent(IN ) :: AA
double complex :: determinantMat !<- output
!--internals--
integer, dimension(min(size(AA,1),size(AA,2))) :: ipiv
!!--Next line is new--
double complex, dimension(size(AA,1),size(AA,2)) :: AA_Temp !!<- I have no idea if this will work, you may need an allocatable??
integer :: ii, info
!check if not square matrix, then set determinant to 0
if(size(AA,1)/= size(AA,2)) then
determinantMat = 0
return
end if
!compute LU factorization with LAPACK function
!!--Next line is new--
AA_Temp = AA !--Initialise AA_Temp to be the same as AA--!
call zgetrf(size(AA_temp,1),size(AA_Temp,2), AA_Temp,size(AA_Temp,1), ipiv,info)
if(info /= 0) then
determinantMat = cmplx(0.D0, 0.D0)
return
end if
determinantMat = cmplx(1.D0, 0.D0)
!determinant of triangular matrix is product of diagonal elements
do ii=1,size(AA_Temp,1)
if(ipiv(ii) /= ii) then
!a permutation was done, so a factor of -1
determinantMat = -determinantMat *AA_Temp(ii,ii)
else
!no permutation, so no -1
determinantMat = determinantMat*AA_Temp(ii,ii)
end if
end do
end function determinantMat
With the 'USE LAPACK95' you probably do not need PURE, but if you wanted it to be PURE then you want to explicitly say so.

What's wrong with this Fortran 90-95 code for simulating water flow through non-saturated soil? [closed]

Closed. This question needs debugging details. It is not currently accepting answers.
Edit the question to include desired behavior, a specific problem or error, and the shortest code necessary to reproduce the problem. This will help others answer the question.
Closed 8 years ago.
Improve this question
I've been working for many days trying to find out what's wrong with this code. It's used for modelling water flow through non saturated soil. The equations system is in the form of a tridiagonal matrix, which is solved with the Thomas Algorithm. I have the solution, and the code is not representing it. For example, node A should be a curve that goes from the initial condition of aprox -100 cm to aprox -20 cm. It's a long code, but I'd be tremendously thankful if someone helped me in this one.
program EcuacionRichards
implicit none
!Declaring variables
integer, parameter :: nodos = 100
integer :: i, it, max_it, nodo_a, nodo_b, nodo_c, nodo_d, it_bajo, it_alto
double precision, dimension(1:nodos) :: H, H_ant, C, K, theta, theta_ant, aa, bb, cc, dd, rr, th_ant
double precision :: dz, zbot, tfin, dt, rz, Ksup, Kinf, t, th_lisimetro, h_lisimetro
double precision :: q_ent, tol_h, tol_th, cambio_h, cambio_th
double precision :: mult_alto, mult_bajo, maxdt, mindt, qlibre
logical lisimetro
!Hydraulic Parameters
double precision :: theta_sat=0.43 !cm/cm
double precision :: theta_res=0.078 !cm/cm
double precision :: alpha=0.0325 !1/cm
double precision :: n=1.346
double precision :: m
double precision :: K_sat=86.4 !cm/d
!Grid and iteration parameters
lisimetro=.true.
dt=0.01 !days
zbot=160 !depth of the column in cm
dz=zbot/nodos !cm
tfin=30 !days
max_it=500 !max number of Picard iterations
tol_h=0.1 !tolerance for H iteration, cm
tol_th=0.001 !tolerance for theta iteration, 1/1
it_bajo=3 !minimum recommended number of iterations
it_alto=7 !maximum recommended number of iterations
mult_bajo=1.3 !time multiplicator for low iterations
mult_alto=0.7 !time multiplicator for low iterations
maxdt=0.5 !max value for dt
mindt=0.001 !min value for dt
m=1-1/n
!Initializing other variables
th_lisimetro=0.32
h_lisimetro=HfTH(th_lisimetro)
nodo_a=nodos
nodo_b=2*nodos/3
nodo_c=nodos/3
nodo_d=1
!*********Initial Conditions************************************************************
call theta_ini(theta,nodos) !Fill array with initial moisture values
do i=1,nodos
H(i)=HfTH(theta(i))
call actualiza(H(i), theta(i), C(i), K(i))
end do
!************* OPEN WRITING FILES ************************************************
open(unit=1,file='succion2.txt')
open(unit=2,file='humedad2.txt')
open(unit=3,file='conducti2.txt')
open(unit=4,file='parametr2.txt')
write(4,'("dt(días) =",f7.4)') dt
write(4,'("dz(cm) =",f7.4)') dz
write(4,'("nodos =",i5)') nodos
write(4,'("altura(cm) =",f8.3)') zbot
write(4,'("tfin(días) =",f7.2)') tfin
write(4,'("theta_sat =",f7.4)') theta_sat
write(4,'("theta_res =",f7.4)') theta_res
write(4,'("K_saturada =",g11.3)') K_sat
write(4,'("n =",f7.4)') n
write(4,'("m =",f7.5)') m
write(4,'("alpha =",f7.5)') alpha
write(4,'("max_it =",i4)') max_it
close(4)
write(1,*) "T(días) H_a(cm) H_b(cm) H_c(cm) H_d(cm)"
write(2,*) "T(días) th_a(cm) th_b(cm) th_c(cm) th_d(cm)"
write(3,*) "T(días) K_a(cm/d) K_b(cm/d) K_c(cm/d) K_d(cm/d)"
!*************TIME LOOP**********************************************************************************************
t=0.d0
do while ((t.le.tfin).and.(dt.gt.0))
rz=dz/dt
t=t+dt
theta_ant=theta !Previous time
!Water flow that enters at the top (constant)
q_ent=0.1 !cm/dia
!************* PICARD LOOP ******************************************
Picard:do it=1,max_it
if(it.eq.max_it) pause "MAXIMUM ITERATIONS REACHED"
!Interior Nodes
do i=2, nodos-1
Ksup=2*(K(i+1)*K(i))/(K(i+1)+K(i))
Kinf=2*(K(i-1)*K(i))/(K(i-1)+K(i))
aa(i)=-Kinf/dz !K(i-1/2)
cc(i)=-Ksup/dz !K(i+1/2)
bb(i)=rz*C(i)-aa(i)-cc(i)
rr(i)=rz*C(i)*h(i)-rz*(theta(i)-theta_ant(i))+Ksup-Kinf
end do
!Inferior Node
if (lisimetro) then
!Changing inferior node
if (theta(1).lt.th_lisimetro) then
!Water flow 0, Neumann
Ksup=2*(K(1)*K(2))/(K(1)+K(2))
aa(1)=0
cc(1)=-Ksup/dz
bb(1)=-cc(1)
rr(1)=Ksup
else
!H(1)=0 condition, Dirichlet
Ksup=2*(K(1)*K(2))/(K(1)+K(2))
aa(1)=0
bb(1)=1
cc(1)=0
rr(1)=h_lisimetro
aa(2)=0
rr(2)=rr(2)+Ksup/dz*(h_lisimetro)
end if
else
!Inferior node, free drainage, Neumann
Ksup=2*(K(1)*K(2))/(K(1)+K(2))
qlibre=-K(1)
aa(1)=0
cc(1)=-Ksup/dz
bb(1)=-cc(1)
rr(1)=Ksup+qlibre
end if
!Superior node, known water flow
Kinf=2*(K(nodos)*K(nodos-1))/(K(nodos)+K(nodos-1))
aa(nodos)=-Kinf/dz
cc(nodos)=0
bb(nodos)=0.5*rz*C(nodos)-aa(nodos)
rr(nodos)=0.5*rz*C(nodos)*h(nodos)-0.5*rz*(theta(nodos)-theta_ant(nodos))-Kinf-q_ent
call tridiag(aa,bb,cc,rr,dd,nodos)
!Suction modification and H functions actualization
h_ant=h
th_ant=theta !Save iteration
h=dd !Advance to next iteration
do i=1,nodos
call actualiza(H(i),theta(i), C(i), K(i))
end do
!End of iterations condition
cambio_h=maxval(dabs(h-h_ant))
cambio_th=maxval(dabs(theta-th_ant))
if((cambio_h.lt.tol_h).and.(cambio_th.lt.tol_th)) then
if(.true.) then !(t.eq.tprint)
write (1,'(f8.3,f9.3,f9.3,f9.3,f9.3)') t,H(nodo_a),H(nodo_b),H(nodo_c),H(nodo_d)
write (2,'(f8.3,f7.4,f7.4,f7.4,f7.4)') t,theta(nodo_a),theta(nodo_b),theta(nodo_c),theta(nodo_d)
write (3,'(f8.3,g11.4,g11.4,g11.4,g11.4)') t,k(nodo_a),k(nodo_b),k(nodo_c),k(nodo_d)
end if
if (it.lt.it_bajo) dt=min(dt*mult_bajo,maxdt)
if (it.gt.it_alto) dt=max(dt*mult_alto,mindt)
exit Picard
else
cycle Picard
end if
end do Picard !Picard loop end
if ((tfin-t).le.1E-4) t=huge(1.d0)
end do
!Time Loop End***************************************************************
!******** Close files
close(1)
close(2)
close(3)
!********END OF PROGRAM**********************************************************
!******************************************************************************
!Subroutines and functions
contains
!Initial moistures assignment
subroutine theta_ini(theta,nodos)
integer :: nodos
double precision, dimension(1:nodos) :: theta
integer i
do i=1, nodos
theta(i)=0.30
end do
end subroutine theta_ini
!Subroutine that actualizes salues according to pressure
subroutine actualiza(p,theta,c,k)
double precision p, theta, c, k
double precision se, te
if(p.lt.0) then
te=1+(-alpha*p)**n
se=te**(-m)
theta=theta_res+(theta_sat-theta_res)*se
K=K_sat*se**(0.5)*(1-(1-se**(1/m))**m)**2
c=((alpha**n)*(theta_sat-theta_res)*n*m*(-p)**(n-1))/(te**(m+1)) !d(theta)/dh
else
theta=theta_sat
K=K_sat
c=0
end if
return
end subroutine actualiza
!Tridiag(alpha,beta, gamma, Resto, delta, nodos)
subroutine tridiag(a,b,c,d,x,n)
implicit none
! a - sub-diagonal (means it is the diagonal below the main diagonal)
! b - the main diagonal
! c - sup-diagonal (means it is the diagonal above the main diagonal)
! d - right part
! x - the answer
! n - number of equations
integer,intent(in) :: n
double precision,dimension(n),intent(in) :: a,b,c,d
double precision,dimension(n),intent(out) :: x
double precision,dimension(n) :: cp,dp
double precision :: m
integer i
! initialize c-prime and d-prime
cp(1) = c(1)/b(1)
dp(1) = d(1)/b(1)
! solve for vectors c-prime and d-prime
do i = 2,n
m = b(i)-cp(i-1)*a(i)
cp(i) = c(i)/m
dp(i) = (d(i)-dp(i-1)*a(i))/m
enddo
! initialize x
x(n) = dp(n)
! solve for x from the vectors c-prime and d-prime
do i = n-1, 1, -1
x(i) = dp(i)-cp(i)*x(i+1)
end do
end subroutine tridiag
!Head in terms of moisture
Function HfTH(humedad)
double precision HfTH
double precision humedad
if (humedad.lt.theta_sat) then
HfTH=-1/alpha*(((humedad-theta_res)/(theta_sat-theta_res))**(-1/m)-1)**(1/n) !cm
else
HfTH=0
end if
Return
end function HfTH
end program EcuacionRichards
I can see any number of problems with your code but my attention span is limited so here is just the most egregious
You declare a bunch of variables to be double precision, for example, theta_sat, yet you initialise them with literals of default kind. The statement
double precision :: theta_sat=0.43 !cm/cm
does not make 0.43 a double precision real. Well, to be accurate, it might but on most compilers, and whenever the compilation does not set default real variables to kind double precision, it doesn't. It is almost certain that 0.43 is a 4-byte real while theta_sat is an 8-byte real and you cannot rely on the compiler to set theta_sat to be the 8-byte value closest to 0.43.
In modern Fortran double precision is still available for backward compatibility, but deprecated in favour of specifying the kind of a variable with a kind type. SO is replete with suggestions of how to do this. My favourite is to use the constants defined in the intrinsic module iso_fortran_env, like this:
use, intrinsic :: iso_fortran_env
then declare variables like this:
real(real64) :: theta_sat=0.43_real64 !cm/cm
note the appending of the kind specification _real64 to the value.
Whether your algorithm is sensitive enough that this mistake on your part materially affects the results I don't know.
Finally, you tell us that the program is not correct but you are silent on the way(s) in which it is not correct.