How to exit from nested Fortran loops? - fortran

I'm trying to write a program (in Fortran 95) that finds the minimal decomposition of natural numbers up to N into a sum of at most 4 positive integers.
I've been trying to add and remove statements for a while to make it stop at only the minimal decomposition but I'm not getting anywhere. How do I make the program stop as soon as it's found the minimal decomposition?
PROGRAM SummeQuadrat
IMPLICIT NONE
real:: start,finish
integer:: a,b,c,d,g,x,y
write(*,*) "Max n"
read (*,*) y
call cpu_time(start)
do x=1,y,1
do a=0,x,1
do b=a,x-a,1
do c=b,x-b,1
do d=c,x-c,1
if (a**2+b**2+c**2+d**2 .eq. x) then
write(*,*) "x=",x,d,c,b,a
end if
end do
end do
end do
end do
end do
call cpu_time(finish)
write(*,*)finish-start
end program SummeQuadrat

As I explained in the comments, I am not sure you are asking only how to break out of the loops or for more.
You can jump out of any loop using the EXIT statement. To exit from a loop which is not the innermost loop you are currently in you use a labeled loop and use the label in the EXIT statement to exit that particular loop.
outer: do x = 1, y
do a = 0, x
do b = a, x-a
do c = b, x-b
do d = c, x-c
if (a**2+b**2+c**2+d**2 == x) then
write(*,*) "x=",x,d,c,b,a
if (minimal(a,b,c,d)) exit outer
end if
end do
end do
end do
end do
end do outer

Old thread, but it's kind of a fun problem so I thought I might post my own interpretation.
First off, if we cheat a little and peek at the solution it can be seen that all 4 squares are only needed when x=4**k*(8*m+7). Thus we can search cheaply for 1 or 2 square solutions and on failure decide by the above criterion whether to search for a 3- or 4-square solution.
Then when we structure our loops, count down from the largest a such that a**2 <= x, then the largest b <= a such that a**2+b**2 <= x and so on. This takes the problem from O(x**4) down to O(x**1.5) so it can go much quicker.
For output format, by judicious use of the colon format we can write a single format that prints out results in perhaps a more readable fashion.
! squares.f90 -- Prints out minimal decomposition x into squares
! for 1 <= x <= y (user input)
program squares
use ISO_FORTRAN_ENV, only: REAL64
implicit none
! Need this constant so we can take the square root of an
! integer.
real(REAL64), parameter :: half = 0.5_REAL64
real start, finish
integer a,b,c
integer amax,bmax,cmax,dmax
integer amin,bmin,cmin
integer x,y
! Format for printing out decomposition into squares
character(40) :: fmt = '(i0," = ",i0"**2":3(" + ",i0,"**2":))'
integer nzero
! Get uper bound from user
write(*,'(a)',advance='no') 'Please enter the max N:> '
read(*,*) y
call cpu_time(start)
! Loop over requested range
outer: do x = 1, y
amax = sqrt(x+half)
! Check for perfect square
if(amax**2 == x) then
write(*,fmt) x,amax
cycle outer
end if
! Check for sum of 2 squares
amin = sqrt(x/2+half)
try2: do a = amax, amin, -1
bmax = sqrt(x-a**2+half)
if(bmax > a) exit try2
if(a**2+bmax**2 == x) then
write(*,fmt) x,a,bmax
cycle outer
end if
end do try2
! If trailz(x) is even, then x = 4**k*z, where z is odd
! If further z = 8*m+7, then 4 squares are required, otherwise
! only 3 should suffice.
nzero = trailz(x)
if(iand(nzero,1)==0 .AND. ibits(x,nzero,3)==7) then
amin = sqrt(x/4+half)
do a = amax, amin, -1
bmax = sqrt(x-a**2+half)
bmin = sqrt((x-a**2)/3+half)
do b = min(bmax,a), bmin, -1
cmax = sqrt(x-a**2-b**2+half)
cmin = sqrt((x-a**2-b**2)/2+half)
do c = min(cmax,b), cmin, -1
dmax = sqrt(x-a**2-b**2-c**2+half)
if(a**2+b**2+c**2+dmax**2 == x) then
write(*,fmt) x,a,b,c,dmax
cycle outer
end if
end do
end do
end do
else
amin = sqrt(x/3+half)
do a = amax, amin, -1
bmax = sqrt(x-a**2+half)
bmin = sqrt((x-a**2)/2+half)
do b = min(bmax,a), bmin, -1
cmax = sqrt(x-a**2-b**2+half)
if(a**2+b**2+cmax**2 == x) then
write(*,fmt) x,a,b,cmax
cycle outer
end if
end do
end do
end if
! We should have a solution by now. If not, print out
! an error message and abort.
write(*,'(*(g0))') 'Failure at x = ',x
stop
end do outer
call cpu_time(finish)
write(*,'(*(g0))') 'CPU time = ',finish-start
end program squares

Related

Using two conditions to write a conditional loop in Fortran

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

if statement to determine steady-state

My code below correctly solves a 1D heat equation for a function u(x,t). I now want to find the steady-state solution, the solution that no longer changes in time so it should satisfy u(t+1)-u(t) = 0. What is the most efficient way to find the steady-state solution? I show three different attempts below, but I'm not sure if either are actually doing what I want. The first and third have correct syntax, the second method has a syntax error due to the if statement. Each method is different due to the change in the if structure.
Method 1 :
program parabolic1
integer, parameter :: n = 10, m = 20
real, parameter :: h = 0.1, k = 0.005 !step sizes
real, dimension (0:n) :: u,v
integer:: i,j
real::pi,pi2
u(0) = 0.0; v(0) = 0.0; u(n) = 0.0; v(n) =0.0
pi = 4.0*atan(1.0)
pi2 = pi*pi
do i=1, n-1
u(i) = sin( pi*real(i)*h)
end do
do j = 1,m
do i = 1, n-1
v(i) = 0.5*(u(i-1)+u(i+1))
end do
t = real(j)*k !increment in time, now check for steady-state
!steady-state check: this checks the solutions at every space point which I don't think is correct.
do i = 1,n-1
if ( v(i) - u(i) .LT. 1.0e-7 ) then
print*, 'steady-state condition reached'
exit
end if
end do
do i = 1, n-1 !updating solution
u(i) = v(i)
end do
end do
end program parabolic1
Method 2 :
program parabolic1
integer, parameter :: n = 10, m = 20
real, parameter :: h = 0.1, k = 0.005 !step sizes
real, dimension (0:n) :: u,v
integer:: i,j
real::pi,pi2
u(0) = 0.0; v(0) = 0.0; u(n) = 0.0; v(n) =0.0
pi = 4.0*atan(1.0)
pi2 = pi*pi
do i=1, n-1
u(i) = sin( pi*real(i)*h)
end do
do j = 1,m
do i = 1, n-1
v(i) = 0.5*(u(i-1)+u(i+1))
end do
t = real(j)*k !increment in time, now check for steady-state
!steady-state check: (This gives an error message since the if statement doesn't have a logical scalar expression, but I want to compare the full arrays v and u as shown.
if ( v - u .LT. 1.0e-7 ) then
print*, 'steady-state condition reached'
exit
end if
do i = 1, n-1 !updating solution
u(i) = v(i)
end do
end do
end program parabolic1
Method 3 :
program parabolic1
integer, parameter :: n = 10, m = 20
real, parameter :: h = 0.1, k = 0.005 !step sizes
real, dimension (0:n) :: u,v
integer:: i,j
real::pi,pi2
u(0) = 0.0; v(0) = 0.0; u(n) = 0.0; v(n) =0.0
pi = 4.0*atan(1.0)
pi2 = pi*pi
do i=1, n-1
u(i) = sin( pi*real(i)*h)
end do
do j = 1,m
do i = 1, n-1
v(i) = 0.5*(u(i-1)+u(i+1))
end do
t = real(j)*k !increment in time, now check for steady-state
!steady-state check: Perhaps this is the correct expression I want to use
if( norm2(v) - norm2(u) .LT. 1.0e-7 ) then
print*, 'steady-state condition reached'
exit
end if
do i = 1, n-1 !updating solution
u(i) = v(i)
end do
end do
end program parabolic1
Without discussing which method to determine "closeness" is best or correct (not really being a programming problem) we can focus on what the Fortran parts of the methods are doing.
Method 1 and Method 2 are similar ideas (but broken in their execution), while Method 3 is different (and broken in another way).
Note also that in general one wants to compare the magnitude of the difference abs(v-u) rather than the (signed) difference v-u. With non-monotonic changes over iterations these are quite different.
Method 3 uses norm2(v) - norm2(u) to test whether the arrays u and v are similar. This isn't correct. Consider
norm2([1.,0.])-norm2([0.,1.])
instead of the more correct
norm2([1.,0.]-[0.,1.])
Method 2's
if ( v - u .LT. 1.0e-7 ) then
has the problem of being an invalid array expression, but the "are all points close?" can be written appropriately as
if ( ALL( v - u .LT. 1.0e-7 )) then
(You'll find other questions around here about such array reductions).
Method 1 tries something similar, but incorrectly:
do i = 1,n-1
if ( v(i) - u(i) .LT. 1.0e-7 ) then
print*, 'steady-state condition reached'
exit
end if
end do
This is incorrect in one big way, and one subtle way.
First, the loop is exited when the condition tests true the first time, with a message saying the steady state is reached. This is incorrect: you need all values close, while this is testing for any value close.
Second, when the condition is met, you exit. But you don't exit the time iteration loop, you exit the closeness testing loop. (exit without a construct name leaves the innermost do construct). You'll be in exactly the same situation, running again immediately after this innermost construct whether the tested condition is ever or never met (if ever met you'll get the message also). You will need to use a construct name on the time loop.
I won't show how to do that (again there are other questions here about that), because you also need to fix the test condition, by which point you'll be better off using if(all(... (corrected Method 2) without that additional do construct.
For Methods 1 and 2 you'll have something like:
if (all(v-u .lt 1e-7)) then
print *, "Converged"
exit
end if
And for Method 3:
if (norm2(v-u) .lt. 1e-7) then
print *, "Converged"
exit
end if

Very small number turns negative in Fortran

I'm doing a program in Fortran90 which do a sum from i=1 to i=n where nis given. The sum is sum_{i=1}^{i=n}1/(i*(i+1)*(i+2)). This sum converges to 0.25. This is the code:
PROGRAM main
INTEGER n(4)
DOUBLE PRECISION s(4)
INTEGER i
OPEN(11,FILE='input')
OPEN(12,FILE='output')
DO i=1,4
READ(11,*) n(i)
END DO
PRINT*,n
CALL suma(n,s)
PRINT*, s
END
SUBROUTINE suma(n,s)
INTEGER n(4),j,k
DOUBLE PRECISION s(4),add
s=0
DO k=1,4
DO j=1,n(k)
add=1./(j*(j+1)*(j+2))
s(k)=s(k)+add
END DO
END DO
END SUBROUTINE
input
178
1586
18232
142705
The output file is now empty, I need to code it. I'm just printing the results, which are:
0.249984481688 0.249999400246 0.248687836759 0.247565846142
The problem comes with the variable add. When j is bigger, add turns negative, and the sum doesn't converge well. How can I fix it?
The problem is an integer overflow. 142705142706142707 is a number that is too large for a 4-byte integer.
What happens then is that the number overflows and loops back to negative numbers.
As #albert said in his comment, one solution is to convert it to double precision every step of the way: ((1.d0/j) / (j+1)) / (j+2). That way, it is calculating with floating point values.
Another option would be to use 8-byte integers:
integer, parameter :: int64 = selected_int_kind(17)
integer(kind=int64) :: j
You should be very careful with your calculations, though. Finer is not always better. I recommend that you look at how floating point arithmetic is performed by a computer, and what issues this can create. See for example here on wikipedia.
This is likely a better way to achieve what you want. I did remove the IO. The output from the program is
% gfortran -o z a.f90 && ./z
178 0.249984481688392
1586 0.249999801599584
18232 0.249999998496064
142705 0.249999999975453
program main
implicit none ! Never write a program without this statement
integer, parameter :: knd = kind(1.d0) ! double precision kind
integer n(4)
real(knd) s(4)
integer i
n = [178, 1586, 18232, 142705]
call suma(n, s)
do i = 1, 4
print '(I6,F18.15)', n(i), s(i)
end do
contains
!
! Recursively, sum a(j+1) = j * a(j) / (j + 1)
!
subroutine suma(n, s)
integer, intent(in) :: n(4)
real(knd), intent(out) :: s(4)
real(knd) aj
integer j, k
s = 0
do k = 1, 4
aj = 1 / real(1 * 2 * 3, knd) ! a(1)
do j = 1, n(k)
s(k) = s(k) + aj
aj = j * aj / (j + 3)
end do
end do
end subroutine
end program main

Accumulator within a DO loop

My goal is to create 10,000 randomly generated numbers between 0 and 1, organize them into ten bins evenly spaced between 0 and 1, and compute a frequency for each bin. This is my code so far.
program listrand
implicit none
integer :: n,p
integer :: a,b,c,d,e,f,g,h,i,j = 0
real :: xran
!real, dimension(10,2) :: bin_and_freq -- list of bins and frequency
do n = 1,10000
call random_number(xran)
if (xran < 0.1) then
a = a + 1
elseif (xran>0.1 .and. xran<0.2) then
b = b + 1
elseif (xran>0.2 .and. xran<0.3) then
c = c+1
elseif (xran>0.3 .and. xran<0.4) then
d = d+1
elseif (xran>0.4 .and. xran<0.5) then
e = e + 1
elseif (xran>0.5 .and. xran<0.6) then
f = f+1
elseif (xran>0.6 .and. xran<0.7) then
g = g+1
elseif (xran>0.7 .and. xran<0.8) then
h=h+1
elseif (xran>0.8 .and. xran<0.9) then
i=i+1
else
j = j+1
endif
enddo
print *, a,b,c,d,e,f,g,h,i,j
end program listrand
I am getting an unexpected output:
988 1036 133225987 1004 934 986 1040 33770 1406729616 1052.
Why are c,h, and i so large? Also, is there a more efficient way of going about this than using the unwieldy IF/ELSEIF block I have?
In your long
integer :: a,b,c,d,e,f,g,h,i,j = 0
You are only initialising j to be 0, all others have random numbers in them. If you add
a = 0
b = 0
c = 0
d = 0
e = 0
f = 0
g = 0
h = 0
i = 0
j = 0
before your loop, everything works well.
As for how to simplify it:
Here is my version of the program:
program listrand
implicit none
integer, parameter :: nbins = 10
integer :: n, bin
integer :: bin_hits(nbins) ! Number of bin hits
real :: xran
real :: bin_lower(nbins) ! Lower edge of bins
! bin_lower(1) == 0.0
bin_hits = 0
! Set up equidistant bins
bin_lower = [ (real(n-1) / nbins, n = 1, size(bin_lower)) ]
do n = 1,10000
call random_number(xran)
bin = count(bin_lower <= xran)
bin_hits(bin) = bin_hits(bin)+1
enddo
do n = 1, nbins-1
print '(2(F6.2), I6)' bin_lower(n), bin_lower(n+1), bin_hits(n)
end do
print '(2(F6.2), I6)' bin_lower(nbins), 1.0, bin_hits(nbins)
end program listrand
For the index of which bin_hits element to increment, I'm counting the number of values in bin_lower that are actually lower than xran.
EDIT
I'd like to also point to the answer from High Performance Mark a bit further down, who instead of calling RANDOM_NUMBER for each value individually uses it to generate a whole array of random numbers.
Additionally, he's using the fact that the bins are fixed and equidistant to calculate the bin number directly from the random value instead of comparing it to each bin as in my version.
Both of these make the program faster.
If speed of execution is one's main concern, and if one is willing to trade space for time, this might appeal:
PROGRAM listrand
IMPLICIT NONE
INTEGER, PARAMETER :: nbins = 10
INTEGER, PARAMETER :: nsamples = 10**4
INTEGER :: bin_hits(0:nbins-1)
REAL :: xran(nsamples)
INTEGER :: binned_rn(nsamples), n
bin_hits = 0
CALL RANDOM_NUMBER(xran)
binned_rn = INT(nbins*xran)
DO n = 1, nsamples
bin_hits(binned_rn(n)) = bin_hits(binned_rn(n)) +1
END DO
WRITE(*,*) bin_hits
END PROGRAM listrand
In a limited number of tests this version is 3 - 4 times as fast as #chw21's version.

Nesting errors in FORTRAN

I'm creating a program that is required to read values from two arrays (ARR and MRK), counting each set of values (I,J) in order to determine their frequency for a third array (X). I've written the following so far, but nesting errors are preventing the program from compiling. Any help is greatly appreciated!
IMPLICIT NONE
REAL, DIMENSION (0:51, 0:51) :: MRK, ALT
INTEGER :: I, J !! FREQUENCY ARRAY ALLELES
INTEGER, PARAMETER :: K = 2
INTEGER :: M, N !! HAPLOTYPE ARRAY POSITIONS
INTEGER :: COUNTER = 0
REAL, DIMENSION(0:1,0:K-1):: X
ALT = 8
MRK = 8
X = 0
MRK(1:50,1:50) = 0 !! HAPLOTYPE ARRAY WITHOUT BUFFER AROUND OUTSIDE
ALT(1:50,1:50) = 0
DO I = 0, 1 !! ALTRUIST ALLELE
DO J = 0, K-1 !! MARKER ALLELE
DO M = 1, 50
DO N = 1, 50 !! READING HAPLOTYPE POSITIONS
IF ALT(M,N) = I .AND. MRK(M,N) = J THEN
COUNTER = COUNTER + 1
ELSE IF ALT(M,N) .NE. I .OR. MRK(M,N) .NE. J THEN
COUNTER = COUNTER + 0
END IF
X(I,J) = COUNTER/2500
COUNTER = 0
END DO
END DO
END DO
END DO
Your if syntax is incorrect. You should enclose the conditional expressions between brackets. Also, I think you should replace single = by a double == in the same expressions and maybe keep the syntax type to either == and /= or .eq. and .neq., but not mix them:
IF (ALT(M,N) == I .AND. MRK(M,N) == J) THEN
COUNTER = COUNTER + 1
ELSE IF (ALT(M,N) /= I .OR. MRK(M,N) /= J) THEN
COUNTER = COUNTER + 0
END IF
I don't know if in your actual program you do it, but you should probably use program program_name and end program program_name at the very beginning and very end of your code, respectively, where program_name is anything you want to call your program (no spaces allowed I think), although a simple end at the end would suffice.