Just to preface this question, I am a couple weeks new to Fortran and I have run into an infinite do loop error when running the actual program.
I am 99% sure that the infinite sequence is coming from the do loop, but I thought I should ask just to be sure. I am not sure what part of the do loop is causing the infinite do loop but any help would be greatly appreciated!
Here is the code:
implicit none
! Declare variables - Add variables as necessary (integer only!)
! M will store the encoding matrix, MInv will store its inverse
! Decoded_message will store the decoded message
integer :: M(2,2), MInv(2,2), Determinant, a, b, c, d, detM, i, v(:,:), ascIIcode(:,:)
allocatable :: v, ascIIcode
character*32 :: Decoded_Message
! open data file and read in the encoding matrix
open(42,file='Data3.txt')
read(42,*) M(1,1), M(1,2)
read(42,*) M(2,1), M(2,2)
! Invert the encoding matrix and store it in MInv
detM = determinant(M)
MInv(1,1) = +detM *M(2,2)
MInv(1,2) = -detM *M(2,1)
MInv(2,1) = -detM *M(1,2)
MInv(2,2) = +detM *M(1,1)
! Processing steps required:
! Read from the file in 2 numbers at a time and store in a vector array
do i = 2, 31
allocate (v(2,1), ascIIcode(2,1))
read(42,*) v(1,1)
read(42,*) v(2,1)
! decode the 2 numbers read in (1) by multiplying Minv by the vector array from (1)
ascIIcode(1,1) = ((MInv(1,1)*v(1,1))+(MInv(1,2)*v(2,1)))
ascIIcode(2,1) = ((MInv(2,1)*v(1,1))+(MInv(2,2)*v(2,1)))
! Insert the result from (2) into the character string Decoded_Message. To concatinate
Decoded_Message = char(ascIIcode(1,1))//char(ascIIcode(2,1))
! Use a loop that advances in steps of 2 and goes to 31
deallocate (v)
deallocate (ascIIcode)
end do
! print results.
print*, Decoded_Message
! close files
close(42)
end program Decode
integer function Determinant(M)
! This function computes the determinant of matices of size 2 or 3
! M is the matrix for which the determinant is calculated (square matrix only)
! n is the number of rows or columns in M
implicit none
integer :: M(2,2), a, b, c, d, e, f, g, h, i, Det
do
a = M(1,1)
b = M(1,2)
c = M(2,1)
d = M(2,2)
Det = (a*d)-(b*c)
end do
end function Determinant
Related
Hoping someone could help me. I was just introduced to Fortran and can't seem to figure out why my code is producing an infinite loop.
I want to write a code that finds the root (c) of a function f(x)= x^3 - 3x - 4 between the intervals [2,3]:
I want the steps to be: initialize a and b.
Then calculate c = (a+b)/2.
Then if f(c) < 0, set b=c and repeat the previous step. If f(c) > 0, then set a=c and repeat the previous step.
The point is to repeat these steps until we get 1e-4 close to the actual root.
This is what I have written so far and is it producing an infinite loop.
I am also confused about whether it is a good idea to use the two condition loop (as in the function has to be greater/less than 0 .AND. absolute value of the function has to be less than 1e-4).
Any help/tips would be greatly appreciated!
MY CODE:
PROGRAM proj
IMPLICIT NONE
REAL :: a=2.0, b=3.0, c, f
INTEGER :: count1
c = (a + b)/2
f = c**3 - 3c - 4
DO
IF (( f .GT. 0.0) .AND. ( ABS(f) .LT. 1e-4)) EXIT
c = (a+c)/2
f = c**3 - 3c - 4
count1 = count1 + 1
PRINT*, f, c,count1
END DO
PRINT*, c, f
END PROGRAM proj
I want to be able to show the iterations and print each step (getting closer to the actual root).
What you have described is the bisection method for localizing a zero
of a function in the interval [a:b]. There are three possibilities.
The interval does not contain a zero.
An endpoint of the interval is a zero.
There are more than one zero in the interval.
This program implements bisection where a number of subintervals
are inspected. There are other, and better, methods but this should
be understandable for you.
!
! use bisection to locate the zeros of a function f(x) in the interval
! [a,b]. There are three possibilities to consider: (1) The interval
! contains no zeros; (2) One (or both) endpoints is a zero; or (3)
! more than one point is a zero.
!
program proj
implicit none
real dx, fl, fr, xl, xr
real, allocatable :: x(:)
integer i
integer, parameter :: n = 1000
xl = 2 ! Left endpoint
xr = 3 ! Right endpoint
dx = (xr - xl) / (n - 1) ! Coarse increment
allocate(x(n))
x = xl + dx * [(i, i=0, n-1)] ! Precompute n x-values
x(n) = xr ! Make sure last point is xr
!
! Check end points for zeros. Comparison of a floating point variable
! against zero is exact.
!
fl = f(xl)
if (fl == 0) then
call prn(xl, fl)
x(1) = x(1) + dx / 10 ! Nudge passed xl
end if
fr = f(xr)
if (fr == 0) then
call prn(xr, fr)
x(n) = x(n) - dx / 10 ! Reduce upper xr
end if
!
! Now do bisection. Assumes at most one zero in a subinterval.
! Make n above larger for smaller intervals.
!
do i = 1, n - 1
call bisect(x(i), x(i+1))
end do
contains
!
! The zero satisfies xl < zero < xr
!
subroutine bisect(xl, xr)
real, intent(in) :: xl, xr
real a, b, c, fa, fb, fc
real, parameter :: eps = 1e-5
a = xl
b = xr
do
c = (a + b) / 2
fa = f(a)
fb = f(b)
fc = f(c)
if (fa * fc <= 0) then ! In left interval
if (fa == 0) then ! Endpoint is a zero.
call prn(a, fa)
return
end if
if (fc == 0) then ! Endpoint is a zero.
call prn(c, fc)
return
end if
!
! Check for convergence. The zero satisfies a < zero < c.
!
if (abs(c - a) < eps) then
c = (a + c) / 2
call prn(c, f(c))
return
end if
!
! Contract interval and try again.
!
b = c
else if (fc * fb <= 0) then ! In right interval
if (fc == 0) then ! Endpoint is a zero.
call prn(c, fc)
return
end if
if (fb == 0) then ! Endpoint is a zero.
call prn(b, fb)
return
end if
!
! Check for convergence. The zero satisfies c < zero < b.
!
if (abs(b - c) < eps) then
c = (b + c) / 2
call prn(c, f(c))
return
end if
!
! Contract interval and try again.
!
a = c
else
return ! No zero in this interval.
end if
end do
end subroutine bisect
elemental function f(x)
real f
real, intent(in) :: x
f = x**3 - 3 * x - 4
end function f
subroutine prn(x, f)
real, intent(in) :: x, f
write(*,*) x, f
end subroutine prn
end program proj
everyone.
I am just playing with the calculation of integral of x^2 from [1, 2] using both midpoint rule and Simpson's rule. And I find it out that with the same number of subintervals midpoint rule approximation seems more accurate than Simpson's rule approximation, which is really weird.
The source code of midpoint rule approximation is :
program midpoint
implicit none ! Turn off implicit typing
Integer, parameter :: n=100 ! Number of subintervals
integer :: i ! Loop index
real :: xlow=1.0, xhi=2.0 ! Bounds of integral
real :: dx ! Variable to hold width of subinterval
real :: sum ! Variable to hold sum
real :: xi ! Variable to hold location of ith subinterval
real :: fi ! Variable to value of function at ith subinterval
dx = (xhi-xlow)/(1.0*n) ! Calculate with of subinterval
sum = 0.0 ! Initialize sum
xi = xlow+0.5*dx ! Initialize value of xi
do i = 1,n,1 ! Initiate loop
! xi = xlow+(0.5+1.0*i)*dx
write(*,*) "i,xi ",i,xi ! Print intermidiate result
fi = xi**2 ! Evaluate function at ith point
sum = sum+fi*dx ! Accumulate sum
xi = xi+dx ! Increment location of ith point
end do ! Terminate loop
write(*,*) "sum =",sum
stop ! Stop execution of the program
end program midpoint
the according execution is:
...... ..... ..................
i,xi 100 1.99499905
sum = 2.33332348
The source code of Simpson's rule approximation is:
program simpson
implicit none ! Turn off implicit typing
integer, parameter :: n=100 ! Number of subintervals
integer :: i=0 ! Loop index
real :: xlow=1.0, xhi=2.0 ! Bounds of integral
real :: h ! Variable to hold width of subinterval
real :: sum ! Variable to hold sum
real :: xi ! Variable to hold location of ith subinterval
real :: fi ! Variable to value of function at ith subinterval
real :: Psimp ! Variable of simpson polynomial of xi interval
h = (xhi-xlow)/(1.0*n) ! Calculate width of subinterval
sum = 0.0 ! Initialize sum
do while (xi<=xhi-h) ! Initiate loop
xi = xlow+i*2.0*h ! Increment of xi
i=i+1
write(*,*) "i,xi ",i,xi ! Print intermidiate result
Psimp=xi**2+4.0*(xi+h)**2+(xi+2.0*h)**2
! Evaluate function at ith point
sum = sum+(h/3.0)*Psimp ! Accumulate sum
end do ! Terminate loop
write(*,*) "sum =",sum
end program simpson
the according execution is:
........ ...... ...................
i,xi 101 2.00000000
sum = 2.37353396
To get the same precision of digits as midpoint result, I have to set the number of subintervals in Simpson's program to 100000, which is 1000 times more than the midpoint program (I initially set both of the number subintervals to 100)
I check the codes in Simpson's program and can't find whats wrong.
Simpson's rule should converge more rapid than midpoint rule if I remembered it correct.
Craig Burley once remarked that a WHILE loop looked like as soon as the premise of the loop was violated, the loop would be exited immediately. Here the premise of the loop is violated when x=xhi but the loop doesn't break at that point, only when a whole nother iteration is completed and the test can be applied at the top of the loop. You could more consistently with Fortran idioms convert the loop into a counted DO loop with something like
DO i = 0, n/2-1
and then comment out the
i=i+1
line. Or simply test the loop premise immediately after modifying xi:
xi = xlow+i*2.0*h ! Increment of xi
if(xi>xhi-h) exit ! Test loop premise
Either way leads to the exact results expected for a polynomial of degree no higher than 3 for Simpson's rule.
I have a long program and the goal is to solve the matrix system ax=b. When I run it, it reveals that "error: size of variable is too large".
program ddm
integer :: i,j,k
integer, parameter :: FN=1,FML=80,FMH=80
integer, parameter :: NBE=1*80*80 !NBE=FN*FML*FMH
double precision, dimension(1:3*NBE,1:3*NBE) :: AA
double precision, dimension(1:3*NBE) :: BB
double precision :: XX(3*NBE)
double precision, dimension(1:NBE) :: DSL,DSH,DNN
double precision, dimension(1:FML,1:FMH) :: DSL1,DSH1,DNN1
! Construct a block matrix
AA(1:NBE,1:NBE) = SLSL
AA(1:NBE,NBE+1:2*NBE) = SLSH
AA(1:NBE,2*NBE+1:3*NBE) = SLNN
AA(NBE+1:2*NBE,1:NBE) = SHSL
AA(NBE+1:2*NBE,NBE+1:2*NBE) = SHSH
AA(NBE+1:2*NBE,2*NBE+1:3*NBE) = SHNN
AA(2*NBE+1:3*NBE,1:NBE) = NNSL
AA(2*NBE+1:3*NBE,NBE+1:2*NBE) = NNSH
AA(2*NBE+1:3*NBE,2*NBE+1:3*NBE) = NNNN
! Construct a block matrix for boundary condition
BB(1:NBE) = SLBC
BB(NBE+1:2*NBE) = SHBC
BB(2*NBE+1:3*NBE) = NNBC
call GE(AA,BB,XX,3*NBE)
DSL = XX(1:NBE)
DSH = XX(NBE+1:2*NBE)
DNN = XX(2*NBE+1:3*NBE)
DSL1 = reshape(DSL,(/FML,FMH/))
DSH1 = reshape(DSH,(/FML,FMH/))
DNN1 = reshape(DNN,(/FML,FMH/))
open(unit=2, file='DNN2.txt', ACTION="write", STATUS="replace")
do i=1,80
write(2,'(*(F14.7))') real(DNN1(i,:))
end do
end program ddm
Note: GE(AA,BB,XX,3*NBE) is the function for solving the matrix system. Below is the GE function.
subroutine GE(a,b,x,n)
!===========================================================
! Solutions to a system of linear equations A*x=b
! Method: Gauss elimination (with scaling and pivoting)
!-----------------------------------------------------------
! input ...
! a(n,n) - array of coefficients for matrix A
! b(n) - array of the right hand coefficients b
! n - number of equations (size of matrix A)
! output ...
! x(n) - solutions
! coments ...
! the original arrays a(n,n) and b(n) will be destroyed
! during the calculation
!===========================================================
implicit none
integer n
double precision a(n,n),b(n),x(n)
double precision s(n)
double precision c, pivot, store
integer i, j, k, l
! step 1: begin forward elimination
do k=1, n-1
! step 2: "scaling"
! s(i) will have the largest element from row i
do i=k,n ! loop over rows
s(i) = 0.0
do j=k,n ! loop over elements of row i
s(i) = max(s(i),abs(a(i,j)))
end do
end do
! step 3: "pivoting 1"
! find a row with the largest pivoting element
pivot = abs(a(k,k)/s(k))
l = k
do j=k+1,n
if(abs(a(j,k)/s(j)) > pivot) then
pivot = abs(a(j,k)/s(j))
l = j
end if
end do
! Check if the system has a sigular matrix
if(pivot == 0.0) then
write(*,*) "The matrix is singular"
return
end if
! step 4: "pivoting 2" interchange rows k and l (if needed)
if (l /= k) then
do j=k,n
store = a(k,j)
a(k,j) = a(l,j)
a(l,j) = store
end do
store = b(k)
b(k) = b(l)
b(l) = store
end if
! step 5: the elimination (after scaling and pivoting)
do i=k+1,n
c=a(i,k)/a(k,k)
a(i,k) = 0.0
b(i)=b(i)- c*b(k)
do j=k+1,n
a(i,j) = a(i,j)-c*a(k,j)
end do
end do
end do
! step 6: back substiturion
x(n) = b(n)/a(n,n)
do i=n-1,1,-1
c=0.0
do j=i+1,n
c= c + a(i,j)*x(j)
end do
x(i) = (b(i)- c)/a(i,i)
end do
end subroutine GE
Turn your arrays (at least AA, BB, XX) into allocatable arrays and allocate them by yourself in the code. You are hitting the memory limit of statically allocated arrays. There is a limit of 2GB on some systems if I remember well (experts will confirm or give the right numbers).
I'm attempting to take the inverse transform of a complex 1D arrays forward transform in Fortran 90 and fftw. However, the output I receive from the inverse transform is at times completely different from the original input, whereas some values possess an incorrect real section but a correct imaginary part and a few match the original values perfectly.
I've noticed that this issue disappears if dx (the spacing between x values) is reduced to 0.01. Increasing n to compensate for this reduction in x's range then results in the issue resurfacing.
At this point, I believe the issue lies in the 1/cosh segment of the input array as I've been able to replace this with other complex inputs with no issues.
This code is adapted from a MATLAB file in which the form of the input only differs due to MATLAB using sech instead of 1/cosh.
Fortran isn't my 'go to' language so I'm wondering if I've made some normally obvious mistake due to my familiarity with python/matlab .
As for more specifics on the outputs,
The matlab version of this code produces the same values for the in array but the operation of the forward transform and the inverse transform produce different results,
Matlab
out2(2) = 5.5511e-17 + 6.9389e-18i
out2(3) = 5.5511e-17 - 1.3878e-17i
out2(4) = 5.5511e-17 + 2.7756e-17i
out2(1024) = 0.9938 + 0.0994i
out2(2048) = 0 - 1.3878e-17i
Fortran
out2(2) = -5.5511151231257827E-017 - 6.9388939039072284E-018i
out2(3) = 0.0000000000000000 + 1.3877787807814457E-017i
out2(4) = 0.0000000000000000 + 0.0000000000000000i
out(1024) = 0.99380163159683255 + 9.9410098890158616E-002i
out2(2048) = -5.5511151231257827E-017 - 6.9388939039072284E-018i
PROGRAM FFTEXAMPLE
implicit none
include 'fftw3.f'
INTEGER :: n, j, nindex, i
REAL :: dx
DOUBLE COMPLEX, ALLOCATABLE :: in(:), out(:), in2(:), out2(:)
REAL(kind = 8), ALLOCATABLE :: x(:)
INTEGER*8 :: plan, plan2
nindex = 11
n = 2 ** nindex
dx = 0.05 ! Spacing between x array values
allocate( in(n), out(n), x(n), in2(n), out2(n) )
CALL dfftw_plan_dft_1d( plan, n, in, out, FFTW_FORWARD, FFTW_ESTIMATE )
CALL dfftw_plan_dft_1d( plan2, n, in2, out2, FFTW_BACKWARD, FFTW_ESTIMATE )
x = (/ (-dx*n/2 + (i-1)*dx, i=1, n) /) ! Seeds x array from -51.2 to 51.15
! Create values for the input array
DO j = 1, n, 1
in(j) = 1/cosh ( x(j)/1.0040 ) * exp( (0.0, -1.0) * 1.9940 * x(j) )
END DO
CALL dfftw_execute_dft( plan, in, out ) ! FWD transform
!DO j = 1, n, 1
! in2(j) = cmplx(REAL(out(j)), AIMAG(out(j)))
!END DO
in2 = out
CALL dfftw_execute_dft( plan2, in2, out2 ) ! Inverse transform
out2 = out2/n ! Divide output by n to normalise
CALL dfftw_destroy_plan( plan )
CALL dfftw_destroy_plan( plan2 )
END PROGRAM
I am trying to write a programme to calculate an absorption band model for seismic waves. The whole calculation is based on 3 equations. If interested, see equations 3, 4, 5 on p.2 here:
http://www.eri.u-tokyo.ac.jp/people/takeuchi/publications/14EPSL-Iritani.pdf
However, I have debugged this programme several times now but I do not seem to get the expected answer. I am specifically trying to calculate Q_1 variable (seismic attenuation) in the following programme, which should be a REAL positive value on the order of 10^-3. However, I am getting negative values. I need a fresh pair of eyes to take a look at the programme and to check where I have done a mistake if any. Could someone please check? Many thanks !
PROGRAM absorp
! Calculate an absorption band model and output
! files for plotting.
! Ref. Iritani et al. (2014), EPSL, 405, 231-243.
! Variable Definition
! Corners - cf1, cf2
! Frequency range - [10^f_strt, 10^(f_end-f_strt)]
! Number of points to be sampled - n
! Angular frequency - w
! Frequency dependent Attenuation 1/Q - Q_1
! Relaxation times - tau1=1/(2*pi*cf1), tau2=1/(2*pi*cf2)
! Reference velocity - V0 (km/s)
! Attenuation (1/Q) at 1 Hz - Q1_1
! Frequency dependent peak Attenuation (1/Qm) - Qm_1
! Frequency dependent velocity - V_w
! D(omega) numerator - Dw1
! D(omega) denominator - Dw2
! D(omega) - D_w
! D(2pi) - D_2pi
IMPLICIT NONE
REAL :: cf1 = 2.0e0, cf2 = 1.0e+5
REAL, PARAMETER :: f_strt=-5, f_end=12
INTEGER :: indx
INTEGER, PARAMETER :: n=1e3
REAL, PARAMETER :: pi=4.0*atan(1.0)
REAL, DIMENSION(1:n) :: w, Q_1
REAL :: tau1, tau2, V0, freq, pow
REAL :: Q1_1=0.003, Qm_1
COMPLEX, DIMENSION(1:n) :: V_w
COMPLEX, PARAMETER :: i=(0.0,1.0)
COMPLEX :: D_2pi, D_w, Dw1, Dw2
! Reference Velocity km/s
V0 = 12.0
print *, "F1=", cf1, "F2=", cf2, "V0=",V0
! Relaxation times from corners
tau1 = 1.0/(2.0*pi*cf1)
tau2 = 1.0/(2.0*pi*cf2)
PRINT*, "tau1=",tau1, "tau2=",tau2
! Populate angular frequency array (non-linear)
DO indx = 1,n+1
pow = f_strt + f_end*REAL(indx-1)/n
freq=10**pow
w(indx) = 2*pi*freq
print *, w(indx)
END DO
! D(2pi) value
D_2pi = LOG((i*2.0*pi + 1/tau1)/(i*2.0*pi + 1/tau2))
! Calculate 1/Q from eq. 3 and 4
DO indx=1,n
!D(omega)
Dw1 = (i*w(indx) + 1.0/tau1)
Dw2 = (i*w(indx) + 1.0/tau2)
D_w = LOG(Dw1/Dw2)
!This is eq. 5 for 1/Qm
Qm_1 = 2.0*pi*Q1_1*IMAG(D_w)/ &
((Q1_1**2-4)*IMAG(D_w)**2 &
+ 4*Q1_1*IMAG(D_w)*REAL(D_w))
!This is eq. 3 for Alpha(omega)
V_w(indx) = V0*(SQRT(1.0 + 2.0/pi*Qm_1*D_w)/ &
REAL(SQRT(1.0 + 2.0/pi*Qm_1*D_2pi)))
!This is eq. 4 for 1/Q
Q_1(indx) = 2*IMAG(V_w(indx))/REAL(V_w(indx))
PRINT *, w(indx)/(2.0*pi), (V_w(indx)), Q_1(indx)
END DO
! write the results out
100 FORMAT(F12.3,3X,F7.3,3X,F8.5)
OPEN(UNIT=1, FILE='absorp.txt', STATUS='replace')
DO indx=1,n
WRITE(UNIT=1,FMT=100), w(indx)/(2.0*pi), REAL(V_w(indx)), Q_1(indx)
END DO
CLOSE(UNIT=1)
END PROGRAM
More of an extended comment with formatting than an answer ...
I haven't checked the equations you refer to, and I'm not going to, but looking at your code makes me suspect misplaced brackets as a likely cause of errors. The code, certainly as you've shown it here, isn't well formatted to reveal its logical structure. Whatever you do next invest in some indents and some longer lines to avoid breaking too frequently.
Personally I'm suspicious in particular of
!This is eq. 5 for 1/Qm
Qm_1 = 2.0*pi*Q1_1*IMAG(D_w)/ &
((Q1_1**2-4)*IMAG(D_w)**2 &
+ 4*Q1_1*IMAG(D_w)*REAL(D_w))