if statement to determine steady-state - fortran

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

Related

How to parallelize the nested loop

A small example serial code, which has the same structure as my code, is shown below.
PROGRAM MAIN
IMPLICIT NONE
INTEGER :: i, j
DOUBLE PRECISION :: en,ei,es
DOUBLE PRECISION :: ki(1000,2000), et(200),kn(2000)
OPEN(UNIT=3, FILE='output.dat', STATUS='UNKNOWN')
DO i = 1, 1000, 1
DO j = 1, 2000, 1
ki(i,j) = DBLE(i) + DBLE(j)
END DO
END DO
DO i = 1, 200, 1
en = 2.0d0/DBLE(200)*(i-1)-1.0d0
et(i) = en
es = 0.0d0
DO j = 1, 1000, 1
kn=ki(j,:)
CALL CAL(en,kn,ei)
es = es + ei
END DO
WRITE (UNIT=3, FMT=*) et(i), es
END DO
CLOSE(UNIT=3)
STOP
END PROGRAM MAIN
SUBROUTINE CAL (en,kn,ei)
IMPLICIT NONE
INTEGER :: i
DOUBLE PRECISION :: en, ei, gf,p
DOUBLE PRECISION :: kn(2000)
p = 3.14d0
ei = 0.0d0
DO i = 1, 2000, 1
gf = 1.0d0 / (en - kn(i) * p)
ei = ei + gf
END DO
RETURN
END SUBROUTINE CAL
I am running my code on the cluster, which has 32 CPUs on one node, and there are totally 250 GB memory shared by 32 CPUs on one node. I can use 32 nodes maximumly.
Every time when the inner Loop is done, there is one data to be collected. After all outer Loops are done, there are totally 200 data to be collected. If only the inner Loop is executed by one CPU, it would take more than 3 days (more than 72 hours).
I want to do the parallelization for both inner Loop and outer Loop respectively? Would anyone please suggest how to parallelize this code?
Can I use MPI technique for both inner Loop and outer Loop respectively? If so, how to differentiate different CPUs that execute different Loops (inner Loop and outer Loop)?
On the other hand, I saw someone mention the parallelization with hybrid MPI and OpenMP method. Can I use MPI technique for the outer Loop and OpenMP technique for the inner Loop? If so, how to collect one data to the CPU after every inner Loop is done each time and collect 200 data in total to CPU after all outer Loops are done. How to differentiate different CPUs that execute inner Loop and outer Loop respectively?
Alternatively, would anyone provide any other suggestion on parallelizing the code and enhance the efficiency? Thank you very much in advance.
As mentioned in the comments, a good answer will require more detailed question. However, at a first sight it seems that parallelizing the internal loop
DO j = 1, 1000, 1
kn=ki(j,:)
CALL CAL(en,kn,ei)
es = es + ei
END DO
should be enough to solve your problem, or at least it will be a good starter. First of all I guess that there is an error on the loop
DO i = 1, 1000, 1
DO j = 1, 2000, 1
ki(j,k) = DBLE(j) + DBLE(k)
END DO
END Do
since the k is set to 0 and and there is no cell with address corresponding to 0 (see your variable declaration). Also ki is declared ki(1000,2000) array while ki(j,i) is (2000,1000) array. Beside these error, I guess that ki should be calculated as
ki(i,j) = DBLE(j) + DBLE(i)
if true, I suggest you the following solution
PROGRAM MAIN
IMPLICIT NONE
INTEGER :: i, j, k,icr,icr0,icr1
DOUBLE PRECISION :: en,ei,es,timerRate
DOUBLE PRECISION :: ki(1000,2000), et(200),kn(2000)
INTEGER,PARAMETER:: nthreads=1
call system_clock(count_rate=icr)
timerRate=real(icr)
call system_clock(icr0)
call omp_set_num_threads(nthreads)
OPEN(UNIT=3, FILE='output.dat', STATUS='UNKNOWN')
DO i = 1, 1000, 1
DO j = 1, 2000, 1
ki(i,j) = DBLE(j) + DBLE(i)
END DO
END DO
DO i = 1, 200, 1
en = 2.0d0/DBLE(200)*(i-1)-1.0d0
et(i) = en
es = 0.0d0
!$OMP PARALLEL DO private(j,kn,ei) firstpribate(en) shared(ki) reduction(+:es)
DO j = 1, 1000, 1
kn=ki(j,:)
CALL CAL(en,kn,ei)
es = es + ei
END DO
!$OMP END PARALLEL DO
WRITE (UNIT=3, FMT=*) et(i), es
END DO
CLOSE(UNIT=3)
call system_clock(icr1)
write (*,*) (icr1-icr0)/timerRate ! return computing time
STOP
END PROGRAM MAIN
SUBROUTINE CAL (en,kn,ei)
IMPLICIT NONE
INTEGER :: i
DOUBLE PRECISION :: en, ei, gf,p
DOUBLE PRECISION :: kn(2000)
p = 3.14d0
ei = 0.0d0
DO i = 1, 2000, 1
gf = 1.0d0 / (en - kn(i) * p)
ei = ei + gf
END DO
RETURN
END SUBROUTINE CAL
I add some variables to check the computing time ;-).
This solution is computed in 5.14 s, for nthreads=1, and in 2.75 s, for nthreads=2. It does not divide the computing time by 2, but it seems to be a good deal for a first shot. Unfortunately, on this machine I have a core i3 proc. So I can't do better than nthreads=2. However, I wonder, how the code will behave with nthreads=16 ???
Please let me know
I hope that this helps you.
Finally, I warn about the choice of variables status (private, firstprivate and shared) that might be consider carefully in the real code.

Newton Raphson iteration - unable to iterate

I am not sure this question is on topic here or elsewhere (or not on topic at all anywhere).
I have inherited Fortran 90 code that does Newton Raphson interpolation where logarithm of temperature is interpolated against logarithm of pressure.
The interpolation is of the type
t = a ln(p) + b
and where a, b are defined as
a = ln(tup/tdwn)/(alogpu - alogpd)
and
b = ln T - a * ln P
Here is the test program. It is shown only for a single iteration. But the actual program runs over three FOR loops over k,j and i. In reality pthta is a 3D array(k,j,i) and thta is a 1D array (k)
program test
implicit none
integer,parameter :: dp = SELECTED_REAL_KIND(12,307)
real(kind=dp) kappa,interc,pres,dltdlp,tup,tdwn
real(kind=dp) pthta,alogp,alogpd,alogpu,thta,f,dfdp,p1
real(kind=dp) t1,resid,potdwn,potup,pdwn,pup,epsln,thta1
integer i,j,kout,n,maxit,nmax,resmax
kappa = 2./7.
epsln = 1.
potdwn = 259.39996337890625
potup = 268.41687198359159
pdwn = 100000.00000000000
pup = 92500.000000000000
alogpu = 11.43496392350051
alogpd = 11.512925464970229
thta = 260.00000000000000
alogp = 11.512925464970229
! known temperature at lower level
tdwn = potdwn * (pdwn/100000.)** kappa
! known temperature at upper level
tup = potup *(pup/100000.)** kappa
! linear change of temperature wrt lnP between different levels
dltdlp = dlog(tup/tdwn)/(alogpu-alogpd)
! ln(T) value(intercept) where Pressure is 1 Pa and assume a linear
! relationship between P and T
interc = dlog(tup) - dltdlp*alogpu
! Initial guess value for pressure
pthta = exp((dlog(thta)-interc-kappa*alogp)/(dltdlp-kappa))
n=0
1900 continue
!First guess of temperature at intermediate level
t1 = exp(dltdlp * dlog(pthta)+interc)
!Residual error when calculating Newton Raphson iteration(Pascal)
resid = pthta - 100000.*(t1/thta)**(1./kappa)
print *, dltdlp,interc,t1,resid,pthta
if (abs(resid) .gt. epsln) then
n=n+1
if (n .le. nmax) then
! First guess of potential temperature given T1 and
! pressure level guess
thta1 = t1 * (100000./pthta)**kappa
f= thta - thta1
dfdp = (kappa-dltdlp)*(100000./pthta)**kappa*exp(interc + (dltdlp -1.)*dlog(pthta))
p1 = pthta - f/dfdp
if (p1 .le. pdwn) then
if (p1 .ge. pup) then
pthta = p1
goto 1900
else
n = nmax
end if
end if
else
if (resid .gt. resmax) resmax = resid
maxit = maxit+1
goto 2100
end if
end if
2100 continue
end program test
When you run this program with real data from a data file the value of resid is the following
2.7648638933897018E-010
and it does not differ much for the entire execution. Most of the values are in the range
1E-10 and 1E-12
So given these values the following IF condition
IF (abs(resid) .gt. epsln)
never gets called and the Newton Raphson iteration never gets executed. So I looked at two ways to get this to work. One is to remove the exponential call in these two steps
pthta = exp((dlog(thta)-interc-kappa*alogp)/(dltdlp-kappa))
t1 = exp(dltdlp * dlog(pthta)+interc)
i.e. keep everything in the logarithmic space and take the exponent after the Newton Raphson iteration completes. That part does converge without a problem.
The other way I tried to make this work is to truncate
t1 = exp(dltdlp * dlog(pthta)+interc)
When I truncate it to an integer the value of resid changes dramatically from
1E-10 to 813. I do not understand how truncating that function call leads to such a large value change. Truncating that result does result to a successful completion.
So I am not sure which is the better way to proceed further.
How can I decide which would be the better way to approach this ?
From a research perspective, I'd say your first solution is likely the more appropriate approach. In a physical simulation, one should always work with the logarithm of the properties that are by-definition always positive. In the above code, these would be temperature and pressure. Strictly positive-definite physical variables often result in overflow and underflow in computation, whether you use Fortran or any other programming language, or any possible variable kind. If something can happen, it will happen.
This is true about other physical quantities as well, for example, energy (the typical energy of a Gamma-Ray-Burst is ~10^54 ergs), volume of objects in arbitrary dimensions (the volume of a 100-dimensional sphere of radius 10meters is ~ 10^100), or even probability (the likelihood function in many statistical problems can take values of ~10^{-1000} or less). Working with log-transform of positive-definite variables would enable your code to handle numbers as big as ~10^10^307 (for a double precision variable).
A few notes also regarding the Fortran syntax used in your code:
The variable RESMAX is used in your code without initialization.
When assigning values to variables, it is important to specify the kind of the literal constants appropriately, otherwise, the program results might be affected. For example, here is the output of your original code compiled with Intel Fortran Compiler 2018 in debug mode:
-0.152581477302743 7.31503025786548 259.608693509165
-3.152934473473579E-002 99474.1999921620
And here is the same code's output, but with all literal constants suffixed with the kind parameter _dp (see the revised version of your code below):
-0.152580456940175 7.31501855886952 259.608692604963
-8.731149137020111E-011 99474.2302854451
The output from the revised code in this answer is slightly different from the output of the original code in the above question.
There is no need to use .gt., .ge., .le., .lt., ..., for comparison. These are legacy FORTRAN syntax, as far as I am aware. Use instead the more attractive symbols ( < , > , <= , >= , == ) for comparison.
There is no necessity to use a GOTO statement in a Fortran program. This is again legacy FORTRAN. Frequently, simple elegant do-loops and if-blocks can replace GOTO statements, just as in the revised code below.
There is no need to use kind-specific intrinsic functions in Fortran anymore (such as dexp, dlog, ... for double precision). Almost all (and perhaps all) of Fortran intrinsic functions have generic names (exp, log, ...) in the current Fortran standard.
The following is a revision of the program in this question, that resolves all of the above obsolete syntax, as well as the problem of dealing with extremely large or small positive-definite variables (I probably went too far in log-transforming some variables that would never cause overflow or underflow, but my purpose here was to just show the logic behind log-transformation of positive-definite variables and how to deal with their arithmetics without potentially causing overflow/underflow/error_in_results).
program test
implicit none
integer,parameter :: dp = SELECTED_REAL_KIND(12,307)
real(kind=dp) kappa,interc,pres,dltdlp,tup,tdwn
real(kind=dp) pthta,alogp,alogpd,alogpu,thta,f,dfdp,p1
real(kind=dp) t1,resid,potdwn,potup,pdwn,pup,epsln,thta1
integer i,j,kout,n,maxit,nmax,resmax
real(kind=dp) :: log_resmax, log_pthta, log_t1, log_dummy, log_residAbsolute, sign_of_f
real(kind=dp) :: log_epsln, log_pdwn, log_pup, log_thta, log_thta1, log_p1, log_dfdp, log_f
logical :: residIsPositive, resmaxIsPositive, residIsBigger
log_resmax = log(log_resmax)
resmaxIsPositive = .true.
kappa = 2._dp/7._dp
epsln = 1._dp
potdwn = 259.39996337890625_dp
potup = 268.41687198359159_dp
pdwn = 100000.00000000000_dp
pup = 92500.000000000000_dp
alogpu = 11.43496392350051_dp
alogpd = 11.512925464970229_dp
thta = 260.00000000000000_dp
alogp = 11.512925464970229_dp
log_epsln = log(epsln)
log_pup = log(pup)
log_pdwn = log(pdwn)
log_thta = log(thta)
! known temperature at lower level
tdwn = potdwn * (pdwn/1.e5_dp)**kappa
! known temperature at upper level
tup = potup *(pup/1.e5_dp)** kappa
! linear change of temperature wrt lnP between different levels
dltdlp = log(tup/tdwn)/(alogpu-alogpd)
! ln(T) value(intercept) where Pressure is 1 Pa and assume a linear
! relationship between P and T
interc = log(tup) - dltdlp*alogpu
! Initial guess value for pressure
!pthta = exp( (log(thta)-interc-kappa*alogp) / (dltdlp-kappa) )
log_pthta = ( log_thta - interc - kappa*alogp ) / ( dltdlp - kappa )
n=0
MyDoLoop: do
!First guess of temperature at intermediate level
!t1 = exp(dltdlp * log(pthta)+interc)
log_t1 = dltdlp * log_pthta + interc
!Residual error when calculating Newton Raphson iteration(Pascal)
!resid = pthta - 1.e5_dp*(t1/thta)**(1._dp/kappa)
log_dummy = log(1.e5_dp) + ( log_t1 - log_thta ) / kappa
if (log_pthta>=log_dummy) then
residIsPositive = .true.
log_residAbsolute = log_pthta + log( 1._dp - exp(log_dummy-log_pthta) )
else
residIsPositive = .false.
log_residAbsolute = log_dummy + log( 1._dp - exp(log_pthta-log_dummy) )
end if
print *, "log-transformed values:"
print *, dltdlp,interc,log_t1,log_residAbsolute,log_pthta
print *, "non-log-transformed values:"
if (residIsPositive) print *, dltdlp,interc,exp(log_t1),exp(log_residAbsolute),exp(log_pthta)
if (.not.residIsPositive) print *, dltdlp,interc,exp(log_t1),-exp(log_residAbsolute),exp(log_pthta)
!if (abs(resid) > epsln) then
if ( log_residAbsolute > log_epsln ) then
n=n+1
if (n <= nmax) then
! First guess of potential temperature given T1 and
! pressure level guess
!thta1 = t1 * (1.e5_dp/pthta)**kappa
log_thta1 = log_t1 + ( log(1.e5_dp)-log_pthta ) * kappa
!f = thta - thta1
if ( log_thta>=thta1 ) then
log_f = log_thta + log( 1._dp - exp( log_thta1 - log_thta ) )
sign_of_f = 1._dp
else
log_f = log_thta + log( 1._dp - exp( log_thta - log_thta1 ) )
sign_of_f = 1._dp
end if
!dfdp = (kappa-dltdlp)*(1.e5_dp/pthta)**kappa*exp(interc + (dltdlp -1._dp)*log(pthta))
! assuming kappa-dltdlp>0 is TRUE always:
log_dfdp = log(kappa-dltdlp) + kappa*(log(1.e5_dp)-log_pthta) + interc + (dltdlp -1._dp)*log_pthta
!p1 = pthta - f/dfdp
! p1 should be, by definition, positive. Therefore:
log_dummy = log_f - log_dfdp
if (log_pthta>=log_dummy) then
log_p1 = log_pthta + log( 1._dp - sign_of_f*exp(log_dummy-log_pthta) )
else
log_p1 = log_dummy + log( 1._dp - sign_of_f*exp(log_pthta-log_dummy) )
end if
!if (p1 <= pdwn) then
if (log_p1 <= log_pdwn) then
!if (p1 >= pup) then
if (log_p1 >= log_pup) then
log_pthta = log_p1
cycle MyDoLoop
else
n = nmax
end if
end if
else
!if (resid > resmax) resmax = resid
residIsBigger = ( residIsPositive .and. resmaxIsPositive .and. log_residAbsolute>log_resmax ) .or. &
( .not.residIsPositive .and. .not.resmaxIsPositive .and. log_residAbsolute<log_resmax ) .or. &
( residIsPositive .and. .not. resmaxIsPositive )
if ( residIsBigger ) then
log_resmax = log_residAbsolute
resmaxIsPositive = residIsPositive
end if
maxit = maxit+1
end if
end if
exit MyDoLoop
end do MyDoLoop
end program test
Here is a sample output of this program, which agrees well with the output of the original code:
log-transformed values:
-0.152580456940175 7.31501855886952 5.55917546888014
-22.4565579499410 11.5076538974964
non-log-transformed values:
-0.152580456940175 7.31501855886952 259.608692604963
-1.767017293116268E-010 99474.2302854451
For comparison, here is the output from the original code:
-0.152580456940175 7.31501855886952 259.608692604963
-8.731149137020111E-011 99474.2302854451

How to exit from nested Fortran loops?

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

How to calculate Pi using Monte Carlo Simulation?

I'm attempting to write a FORTRAN 90 program that calculates Pi using random numbers. These are the steps I know I need to undertake:
Create a randomly placed point on a 2D surface within the range [−1, 1] for x and y, using call random_number(x).
calculate how far away the point is from the origin, i'll need to do both of these steps for N points.
for each N value work out the total amount of points that are less than 1 away from origin. Calculate pi with A=4pir^2
use a do loop to calculate pi as a function of N and output it to a data file. then plot it in a graphing package.
This is what I have:
program pi
implicit none
integer :: count, n, i
real :: r, x, y
count = 0
CALL RANDOM_SEED
DO i = 1, n
CALL RANDOM_NUMBER(x)
CALL RANDOM_NUMBER(y)
IF (x*x + y*Y <1.0) count = count + 1
END DO
r = 4 * REAL(count)/n
print *, r
end program pi
I know i've missed out printing the results to the data file, i'm not sure on how to implement this.
This program gives me a nice value for pi (3.149..), but how can I implement step 4, so that it outputs values for pi as a function of N?
Thanks.
Here is an attempt to further #meowgoesthedog effort...
Program pi
implicit none
integer :: count, n, i
real :: r, x, y
count = 0
Integer, parameter :: Slice_o_Pie = 8
Integer :: Don_McLean
Logical :: Purr = .FALSE.
OPEN(NEWUNIT=Don_McLean, FILE='American.Pie')
CALL RANDOM_SEED
DO i = 1, n
CALL RANDOM_NUMBER(x)
CALL RANDOM_NUMBER(y)
IF (x*x + y*Y <1.0) count = count + 1
Purr = .FALSE.
IF(MODULO(I, Slice_o_Pie) == 0) Purr = .TRUE.
IF (Purr) THEN
r = 4 * REAL(count)/i
print *, i, r
WRITE(LUN,*) 'I=',I,'Pi=',Pi
END IF
END DO
CLOSE(Don_McLean)
end program pi
Simply put the final calculation step inside the outer loop, and replace n with i. Also maybe add a condition to limit the number of results printed, e.g. i % 100 = 0 to print every 100 iterations.
program pi
implicit none
integer :: count, n, i
real :: r, x, y
count = 0
CALL RANDOM_SEED
DO i = 1, n
CALL RANDOM_NUMBER(x)
CALL RANDOM_NUMBER(y)
IF (x*x + y*Y <1.0) count = count + 1
IF ([condition])
r = 4 * REAL(count)/i
print *, i, r
END IF
END DO
end program pi

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.