I am trying to understand how the indexing in the following bit of code works.
i=1
j=NTAB ! setting up for binary search
DO
k=(i+j)/2 ! integer division
IF (h < htab(k)) THEN
j=k
ELSE
i=k
END IF
IF (j <= i+1) EXIT
END DO
I feel like this code snippet above is supposed to be a type of loop, but I don't understand how it works. It starts off with i=1 and j=8, leading to k=4.5, leading to a reference in the 4.5th index in the htab array, but this doesn't make any sense to me. I'm trying to translate this snippet of program into Matlab, but I don't know what to do about that small portion. Can someone tell me what this piece of code is doing or translate that small portion of code into Matlab or Python?
Below is the program that snippet above comes from so that you can see the references in the DO command.
!+
SUBROUTINE Atmosphere(alt, sigma, delta, theta)
! -------------------------------------------------------------------------
! PURPOSE - Compute the properties of the 1976 standard atmosphere to 86 km.
! AUTHOR - Ralph Carmichael, Public Domain Aeronautical Software
! NOTE - If alt > 86, the values returned will not be correct, but they will
! not be too far removed from the correct values for density.
! The reference document does not use the terms pressure and temperature
! above 86 km.
IMPLICIT NONE
!============================================================================
! A R G U M E N T S |
!============================================================================
REAL,INTENT(IN):: alt ! geometric altitude, km.
REAL,INTENT(OUT):: sigma ! density/sea-level standard density
REAL,INTENT(OUT):: delta ! pressure/sea-level standard pressure
REAL,INTENT(OUT):: theta ! temperature/sea-level standard temperature
!============================================================================
! L O C A L C O N S T A N T S |
!============================================================================
REAL,PARAMETER:: REARTH = 6369.0 ! radius of the Earth (km)
REAL,PARAMETER:: GMR = 34.163195 ! hydrostatic constant
INTEGER,PARAMETER:: NTAB=8 ! number of entries in the defining tables
!============================================================================
! L O C A L V A R I A B L E S |
!============================================================================
INTEGER:: i,j,k ! counters
REAL:: h ! geopotential altitude (km)
REAL:: tgrad, tbase ! temperature gradient and base temp of this layer
REAL:: tlocal ! local temperature
REAL:: deltah ! height above base of this layer
!============================================================================
! L O C A L A R R A Y S ( 1 9 7 6 S T D. A T M O S P H E R E ) |
!============================================================================
REAL,DIMENSION(NTAB),PARAMETER:: htab= &
(/0.0, 11.0, 20.0, 32.0, 47.0, 51.0, 71.0, 84.852/)
REAL,DIMENSION(NTAB),PARAMETER:: ttab= &
(/288.15, 216.65, 216.65, 228.65, 270.65, 270.65, 214.65, 186.946/)
REAL,DIMENSION(NTAB),PARAMETER:: ptab= &
(/1.0, 2.233611E-1, 5.403295E-2, 8.5666784E-3, 1.0945601E-3, &
6.6063531E-4, 3.9046834E-5, 3.68501E-6/)
REAL,DIMENSION(NTAB),PARAMETER:: gtab= &
(/-6.5, 0.0, 1.0, 2.8, 0.0, -2.8, -2.0, 0.0/)
!----------------------------------------------------------------------------
h=alt*REARTH/(alt+REARTH) ! convert geometric to geopotential altitude
i=1
j=NTAB ! setting up for binary search
DO
k=(i+j)/2 ! integer division
IF (h < htab(k)) THEN
j=k
ELSE
i=k
END IF
IF (j <= i+1) EXIT
END DO
tgrad=gtab(i) ! i will be in 1...NTAB-1
tbase=ttab(i)
deltah=h-htab(i)
tlocal=tbase+tgrad*deltah
theta=tlocal/ttab(1) ! temperature ratio
IF (tgrad == 0.0) THEN ! pressure ratio
delta=ptab(i)*EXP(-GMR*deltah/tbase)
ELSE
delta=ptab(i)*(tbase/tlocal)**(GMR/tgrad)
END IF
sigma=delta/theta ! density ratio
RETURN
END Subroutine Atmosphere ! -----------------------------------------------
As the comment says, it's doing a binary search. It assumes that the data in htab is sorted, and it is looking for the index of the element that is the same as h. i and j are the lower and upper bounds, and it starts in the middle (i+j)/2. If that element is greater than h, it sets the current index as the upper bound and repeats the loop. Otherwise it sets the lower bound to that index and repeats the loop. The IF test exits the loop when the range is a single element (which may not be h if there is no such element.)
Related
I used function deriv4() to calculate the first-order derivative of the following arrays:
xi = (/ 1., 2., 3./)
yi = (/ -2.457771560159039804e-38, -2.894514456792069804e-39, -1.221311883139507993e-35 /)
However, when I compare the results with the numpy.gradient()of Python, they are very different! How can I fix it?
The code (drive.f90) is attached below and compiled as follows:
ifort -o deriv.x drive.f90
program div
implicit none
integer, parameter :: ni=3 ! initial arrays size for interpolation
integer, parameter :: nc=3 ! number of points where derivatives to be calc.
Integer, Parameter :: SP = Selected_Real_Kind (P=6,R=35)
Integer, Parameter :: DP = Selected_Real_Kind (P=15,R=300)
real(kind=DP) xmin, xmax ! interval
real(kind=DP) xi(ni), yi(ni)
real(kind=DP) x, yx, step, f, deriv3,deriv4
real(kind=DP) fx ,l,fx2
integer i, j
xi = (/ 1., 2., 3./)
yi = (/ -2.457771560159039804e-38_DP, -2.894514456792069804e-39_DP, -1.221311883139507993e-35_DP /)
l=0
do i=1, NC
l=l+1.0
fx = deriv3(xi(i), xi, yi, nc, 1)
write (*,*) xi(i), yi(i), fx!,fx2
end do
stop
end program
function deriv3(xx, xi, yi, ni, m)
!====================================================================
! Evaluate first- or second-order derivatives
! using three-point Lagrange interpolation
! written by: Alex Godunov (October 2009)
!--------------------------------------------------------------------
! input ...
! xx - the abscissa at which the interpolation is to be evaluated
! xi() - the arrays of data abscissas
! yi() - the arrays of data ordinates
! ni - size of the arrays xi() and yi()
! m - order of a derivative (1 or 2)
! output ...
! deriv3 - interpolated value
!============================================================================*/
implicit none
Integer, Parameter :: SP = Selected_Real_Kind (P=6,R=35)
Integer, Parameter :: DP = Selected_Real_Kind (P=15,R=300)
integer, parameter :: n=3
real(kind=DP) deriv3, xx
integer ni, m
real(kind=DP) xi(ni), yi(ni)
real(kind=DP) x(n), f(n)
integer i, j, k, ix
! exit if too high-order derivative was needed,
if (m > 2) then
deriv3 = 0.0
return
end if
! if x is ouside the xi(1)-xi(ni) interval set deriv3=0.0
if (xx < xi(1) .or. xx > xi(ni)) then
deriv3 = 0.0
return
end if
! a binary (bisectional) search to find i so that xi(i-1) < x < xi(i)
i = 1
j = ni
do while (j > i+1)
k = (i+j)/2
if (xx < xi(k)) then
j = k
else
i = k
end if
end do
! shift i that will correspond to n-th order of interpolation
! the search point will be in the middle in x_i, x_i+1, x_i+2 ...
i = i + 1 - n/2
! check boundaries: if i is ouside of the range [1, ... n] -> shift i
if (i < 1) i=1
if (i + n > ni) i=ni-n+1
! old output to test i
! write(*,100) xx, i
! 100 format (f10.5, I5)
! just wanted to use index i
ix = i
! initialization of f(n) and x(n)
do i=1,n
f(i) = yi(ix+i-1)
x(i) = xi(ix+i-1)
end do
! calculate the first-order derivative using Lagrange interpolation
if (m == 1) then
deriv3 = (2.0*xx - (x(2)+x(3)))*f(1)/((x(1)-x(2))*(x(1)-x(3)))
deriv3 = deriv3 + (2.0*xx - (x(1)+x(3)))*f(2)/((x(2)-x(1))*(x(2)-x(3)))
deriv3 = deriv3 + (2.0*xx - (x(1)+x(2)))*f(3)/((x(3)-x(1))*(x(3)-x(2)))
! calculate the second-order derivative using Lagrange interpolation
else
deriv3 = 2.0*f(1)/((x(1)-x(2))*(x(1)-x(3)))
deriv3 = deriv3 + 2.0*f(2)/((x(2)-x(1))*(x(2)-x(3)))
deriv3 = deriv3 + 2.0*f(3)/((x(3)-x(1))*(x(3)-x(2)))
end if
end function deriv3
The output of drive.f90 is as follows:
xi yi derivative
1.00000000000000 -2.457771560159040E-038 6.137636960186341E-036
2.00000000000000 -2.894514456792070E-039 -6.094270557896745E-036
3.00000000000000 -1.221311883139508E-035 -1.832617807597983E-035
The output of Python is as follows:
import numpy as np
f = np.array([-2.457771560159039804e-38, -2.894514456792069804e-39, -1.221311883139507993e-35 ], dtype=float)
print(np.gradient(f))
Compare outputs
Nupmy of python:
[ 2.16832011e-38 -6.09427056e-36 -1.22102243e-35]
Fortran drive.f90 code:
6.137636960186341E-036, -6.094270557896745E-036, -1.832617807597983E-035
There is a fundamental difference between the two cases in the edge cases. The OP demonstrates that the derivatives for the central case are both computed by numpy and deriv3 are identical. The other values are not.
numpy.gradent: This method uses second-order accurate central differences in the interior points and either first or second-order accurate one-sided (forward or backwards) differences at the boundaries (See Documentation numpy.gradient ). In the default calling-convention, this implies that the produced values are:
[ f[1] - f[0], (f[2] - f[0]) * 0.5, f[2] - f[1] ]
deriv3: This method uses a polynomial interpolation method to compute the derivatives. The method constructs a polynomial on the three neighbouring points and computes the derivative of the respective polynomial. The Lagrange three-point interpolation formula is given by:
f(x1+p*h) = 0.5*p*(p-1)*f(x0) + (1-p^2)*f(x1) + 0.5*p*(p+1)*f(x2)
and its derivative to p is given by:
f'(x1+p*h) = (p-0.5)*f(x0) - 2*p*f(x1) + (p+0.5)*f(x2)
For the OP, this gives the following array:
[ 2*f[1] - 1.5*f[0] -0.5*f[2], (f[2] - f[0])*0.5, 1.5*f[2] - 2*f[1] + 0.5*f[1] ]
As you notice, both methods are different at the edge-cases.
There are a plethora of methods to compute derivatives of a discrete set of points, all with its pros and cons. An old, but very nice reference of different methods can be found in Abramowitz and Stegun
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
I want to calculate z value as the coordinate in range of x:-50~50 and y:-50~50 like below code.
program test
implicit none
! --- [local entities]
real*8 :: rrr,th,U0,amp,alp,Ndiv
real*8 :: pi,alpR,NR,Rmin,Rmax,z
integer :: ir, i, j
do i=0, 50
do j=0, 50
th=datan2(i,j)
pi=datan(1.d0)*4.d0
!
Ndiv= 24.d0 !! Number of circumferential division
alp = 90.d0/180.d0*pi !! phase [rad]
U0 = 11.4d0 !! average velocity
amp = 0.5d0 !! amplitude of velocity
Rmin = 10 !! [m]
Rmax = 50 !! [m]
NR = 6.d0 !! Number of radial division
!
rrr=dsqrt(i**2+j**2)
ir=int((rrr-Rmin)/(Rmax-Rmin)*NR)
alpR=2.d0*pi/dble(Ndiv)*dble(mod(ir,2))
z=U0*(1.d0+amp*dsin(0.5d0*Ndiv*th+alp+alpR))
write(*,*) 'i, j, z'
write(*,*) i, j, z
end do
end do
stop
end program test
But I couldn't make it work like below error. I think because i, j are in datan(i,j). How should I change these code?
test.f90:10.16:
th=datan2(i,j)
1
Error: 'y' argument of 'datan2' intrinsic at (1) must be REAL
test.f90:21.16:
rrr=dsqrt(i**2+j**2)
1
Error: 'x' argument of 'dsqrt' intrinsic at (1) must be REAL
Inspired by the comments of #Rodrigo Rodrigues, #Ian Bush, and #Richard, here is a suggested rewrite of the code segment from #SW. Kim
program test
use, intrinsic :: iso_fortran_env, only : real64
implicit none
! --- [local entities]
! Determine the kind of your real variables (select one):
! for specifying a given numerical precision
integer, parameter :: wp = selected_real_kind(15, 307) !15 digits, 10**307 range
! for specifying a given number of bits
! integer, parameter :: wp = real64
real(kind=wp), parameter :: pi = atan(1._wp)*4._wp
real(kind=wp) :: rrr, th, U0, amp, alp, Ndiv
real(kind=wp) :: alpR, NR, Rmin, Rmax, z
integer :: ir, i, j
do i = 0, 50
do j = 0, 50
th = atan2(real(i, kind=wp), real(j, kind=wp))
!
Ndiv= 24._wp !! Number of circumferential division
alp = 90._wp/180._wp*pi !! phase [rad]
U0 = 11.4_wp !! average velocity
amp = 0.5_wp !! amplitude of velocity
Rmin = 10 !! [m]
Rmax = 50 !! [m]
NR = 6._wp !! Number of radial division
!
rrr = sqrt(real(i, kind=wp)**2 + real(j, kind=wp)**2)
ir = int((rrr - Rmin) / (Rmax - Rmin) * NR)
alpR = 2._wp * pi / Ndiv * mod(ir, 2)
z = U0 * (1._wp + amp * sin(0.5_wp * Ndiv * th + alp + alpR))
!
write(*,*) 'i, j, z'
write(*,*) i, j, z
end do
end do
stop
end program test
Specifically, the following changes were made with respect to the original code posted:
Minimum change to answer the question: casting integer variables i and j to real values for using them in the real valued functions datan and dsqrt.
Using generic names for intrinsic procedures, i.e sqrt instead of dsqrt, atan instead of datan, and sin instead of dsin. One benefit of this approach, is that the kind of working precision wp can be changed in one place, without requiring explicit changes elsewhere in the code.
Defining the kind of real variables and calling it wp. Extended discussion of this topic, its implications and consequences can be found on this site, for example here and here. Also #Steve Lionel has an in depth post on his blog, where his general advice is to use selected_real_kind.
Defining pi as a parameter calculating its value once, instead of calculating the same value repeatedly within the nested for loops.
I'm confused about the scope. I downloaded a Fortran file which has 1 main program, 1 subroutine and 1 function in 1 source file. The main program does not contain the subprograms, and the function is called by the subroutine. It works fine, but when I modified the main program to contain those 2 subprograms using "contains", it gives compile error, saying the function is not defined. However, if I create a small function within the same contained section and call from the subroutine, it does not give an error.
What is the difference between those 2 functions? Why do I get the error?
I created a small program with the same structure, 1 main that contains a subroutine and a func and it did not give an error.
My environment is ubuntu 14.04 and using gfortran compiler.
Building target: QRbasic
Invoking: GNU Fortran Linker
gfortran -o "QRbasic" ./main.o
./main.o: In function qrbasic':
/*/QRbasic/Debug/../main.f95:79: undefined reference toajnorm_'
/home/kenji/workspace/QRbasic/Debug/../main.f95:104: undefined reference to `ajnorm_'
collect2: error: ld returned 1 exit status
make: *** [QRbasic] Error 1
Program Main
!====================================================================
! QR basic method to find the eigenvalues
! of matrix A
!====================================================================
implicit none
integer, parameter :: n=3
double precision, parameter:: eps=1.0e-07
double precision :: a(n,n), e(n)
integer i, j, iter
! matrix A
! data (a(1,i), i=1,3) / 8.0, -2.0, -2.0 /
! data (a(2,i), i=1,3) / -2.0, 4.0, -2.0 /
! data (a(3,i), i=1,3) / -2.0, -2.0, 13.0 /
data (a(1,i), i=1,3) / 1.0, 2.0, 3.0 /
data (a(2,i), i=1,3) / 2.0, 2.0, -2.0 /
data (a(3,i), i=1,3) / 3.0, -2.0, 4.0 /
! print a header and the original matrix
write (*,200)
do i=1,n
write (*,201) (a(i,j),j=1,n)
end do
! print: guess vector x(i)
! write (*,204)
! write (*,201) (y(i),i=1,3)
call QRbasic(a,e,eps,n,iter)
! print solutions
write (*,202)
write (*,201) (e(i),i=1,n)
write (*,205) iter
200 format (' QR basic method - eigenvalues for A(n,n)',/, &
' Matrix A')
201 format (6f12.6)
202 format (/,' The eigenvalues')
205 format (/,' iterations = ',i5)
!end program main
contains
subroutine QRbasic(a,e,eps,n,iter)
!==============================================================
! Compute all eigenvalues: real symmetric matrix a(n,n,)
! a*x = lambda*x
! method: the basic QR method
! Alex G. (January 2010)
!--------------------------------------------------------------
! input ...
! a(n,n) - array of coefficients for matrix A
! n - dimension
! eps - convergence tolerance
! output ...
! e(n) - eigenvalues
! iter - number of iterations to achieve the tolerance
! comments ...
! kmax - max number of allowed iterations
!==============================================================
implicit none
integer n, iter
double precision a(n,n), e(n), eps
double precision q(n,n), r(n,n), w(n), an, Ajnorm, sum, e0,e1
integer k, i, j, m
integer, parameter::kmax=1000
! initialization
q = 0.0
r = 0.0
e0 = 0.0
do k=1,kmax ! iterations
! step 1: compute Q(n,n) and R(n,n)
! column 1
an = Ajnorm(a,n,1)
r(1,1) = an
do i=1,n
q(i,1) = a(i,1)/an
end do
! columns 2,...,n
do j=2,n
w = 0.0
do m=1,j-1
! product q^T*a result = scalar
sum = 0.0
do i=1,n
sum = sum + q(i,m)*a(i,j)
end do
r(m,j) = sum
! product (q^T*a)*q result = vector w(n)
do i=1,n
w(i) = w(i) + sum*q(i,m)
end do
end do
! new a'(j)
do i =1,n
a(i,j) = a(i,j) - w(i)
end do
! evaluate the norm for a'(j)
an = Ajnorm(a,n,j)
r(j,j) = an
! vector q(j)
do i=1,n
q(i,j) = a(i,j)/an
end do
end do
! step 2: compute A=R(n,n)*Q(n,n)
a = matmul(r,q)
! egenvalues and the average eigenvale
sum = 0.0
do i=1,n
e(i) = a(i,i)
sum = sum+e(i)*e(i)
end do
e1 = sqrt(sum)
! print here eigenvalues
! write (*,201) (e(i),i=1,n)
!201 format (6f12.6)
! check for convergence
if (abs(e1-e0) < eps) exit
! prepare for the next iteration
e0 = e1
end do
iter = k
if(k == kmax) write (*,*)'The eigenvlue failed to converge'
print *, func1()
end subroutine QRbasic
function Ajnorm(a,n,j)
implicit none
integer n, j, i
double precision a(n,n), Ajnorm
double precision sum
sum = 0.0
do i=1,n
sum = sum + a(i,j)*a(i,j)
end do
Ajnorm = sqrt(sum)
end function Ajnorm
integer function func1()
print *, "dummy"
func1=1
end function
end program
The original program did not contain those 2 programs. This is the version I get an error.
Your main program contains a declaration of the type of function Ajnorm(). As a result, when the compiler finds that name to be used as a function name, it interprets it as an external function. That's quite correct in the original form of the program, with the function defined as an independent unit, but it is wrong for an internal (contained) function. Your program compiles cleanly for me once I remove the unneeded declaration.
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))