abs
Source
<![CDATA[
program demo_abs
implicit none
integer,parameter :: dp=kind(0.0d0)
! some values to use with ABS(3)
integer :: i = -1
real :: x = -1.0
complex :: z = (-3.0,-4.0)
doubleprecision :: rr = -45.78_dp
! some formats for pretty-printing some information
character(len=*),parameter :: &
frmt = '(1x,a15,1x," In: ",g0, T51," Out: ",g0)', &
frmtc = '(1x,a15,1x," In: (",g0,",",g0,")",T51," Out: ",g0)', &
gen = '(*(g0,1x))'
! the basics
print gen, 'basic usage:'
! any integer, real, or complex type
write(*, frmt) 'integer ', i, abs(i)
write(*, frmt) 'real ', x, abs(x)
write(*, frmt) 'doubleprecision ', rr, abs(rr)
write(*, frmtc) 'complex ', z, abs(z)
! elemental
print gen, 'abs is elemental:', abs([20, 0, -1, -3, 100])
! the returned value for complex input can be thought of as the
! distance from the origin <0,0>
print gen, 'distance of (', z, ') from zero is', abs( z )
call DUSTY_CORNERS_1("beware of abs(-huge(0)-1)")
call DUSTY_CORNERS_2("beware of losing precision using CMPLX(3)")
call DUSTY_CORNERS_3("beware of overflow of complex values")
call DUSTY_CORNERS_4("custom meaning for absolute value of COMPLEX")
contains
subroutine DUSTY_CORNERS_1(message)
character(len=*),intent(in) :: message
! A dusty corner is that abs(-huge(0)-1) of an integer would be
! a representable negative value on most machines but result in a
! positive value out of range.
print gen, message
! By definition:
! You can take the absolute value of any value whose POSITIVE value
! is representable with the same type and kind.
print gen, 'abs range test : ', abs(huge(0)), abs(-huge(0))
print gen, 'abs range test : ', abs(huge(0.0)), abs(-huge(0.0))
print gen, 'abs range test : ', abs(tiny(0.0)), abs(-tiny(0.0))
end subroutine DUSTY_CORNERS_1
subroutine DUSTY_CORNERS_2(message)
character(len=*),intent(in) :: message
! dusty corner: "kind=dp" is required or the value returned by
! CMPLX() is a default real instead of double precision.
! Working with complex values you often encounter the CMPLX(3)
! function. CMPLX(3) defaults to returning a default REAL regardless
! of input type. Not really a direct problem with ABS(2f) per-se,
! but a common error when working with doubleprecision complex values
print gen, message
print gen, 'real result versus doubleprecision result', &
& abs(cmplx(30.0_dp,40.0_dp)), &
& abs(cmplx(30.0_dp,40.0_dp,kind=dp))
end subroutine DUSTY_CORNERS_2
subroutine DUSTY_CORNERS_3(message)
character(len=*),intent(in) :: message
print gen, message
! this will probably cause an overflow error, or
!print gen, abs(cmplx( huge(0.0), huge(0.0) ))
print gen, 'because the biggest default real is',huge(0.0)
print gen, 'because returning magnitude of sqrt(x%re**2,x%im**2)'
end subroutine DUSTY_CORNERS_3
subroutine DUSTY_CORNERS_4(message)
character(len=*),intent(in) :: message
print gen, message
! if you do not want the distance for a complex value you
! might want something like returning a complex value with
! both the imaginary and real parts. One way to do that is
print gen, cmplx(abs(z%re),abs(z%im),kind=kind(z))
end subroutine DUSTY_CORNERS_4
end program demo_abs
]]>
achar
Source
<![CDATA[
program demo_achar
use,intrinsic::iso_fortran_env,only:int8,int16,int32,int64
implicit none
integer :: i
i=65
write(*,'("decimal =",i0)')i
write(*,'("character =",a1)')achar(i)
write(*,'("binary =",b0)')achar(i)
write(*,'("octal =",o0)')achar(i)
write(*,'("hexadecimal =",z0)')achar(i)
write(*,'(8(i3,1x,a,1x))')(i,achar(i), i=32,126)
write(*,'(a)')upper('Mixed Case')
contains
! a classic use of achar(3) is to convert the case of a string
pure elemental function upper(str) result (string)
!
!$@(#) upper(3): function to return a trimmed uppercase-only string
!
! input string to convert to all uppercase
character(*), intent(in) :: str
! output string that contains no miniscule letters
character(len(str)) :: string
integer :: i, iend
integer,parameter :: toupper = iachar('A')-iachar('a')
iend=len_trim(str)
! initialize output string to trimmed input string
string = str(:iend)
! process each letter in the string
do concurrent (i = 1:iend)
select case (str(i:i))
! located miniscule letter
case ('a':'z')
! change miniscule to majuscule letter
string(i:i) = achar(iachar(str(i:i))+toupper)
end select
enddo
end function upper
end program demo_achar
]]>
acosd
Source
<![CDATA[
program demo_acosd
use, intrinsic :: iso_fortran_env, only : real32,real64,real128
implicit none
character(len=*),parameter :: all='(*(g0,1x))'
real(kind=real64) :: x , d2r
! basics
print *,'acosd(-1.0) -->',acosd( -1.0 )
print *,'acosd( 0.0) -->',acosd( -1.0 )
print *,'acosd( 1.0) -->',acosd( 0.0 )
x = 0.866_real64
print all,'acosd(',x,') is ', acosd(x)
! any real kind
write(*,*) acosd(-1.0_real64)
! elemental
print all,'elemental',acosd([-1.0,-0.5,0.0,0.50,1.0])
!
end program demo_acosd
]]>
acos
Source
<![CDATA[
program demo_acos
use, intrinsic :: iso_fortran_env, only : real32,real64,real128
implicit none
character(len=*),parameter :: all='(*(g0,1x))'
real(kind=real64) :: x , d2r
! basics
x = 0.866_real64
print all,'acos(',x,') is ', acos(x)
! acos(-1) should be PI
print all,'for reference', new_line('a'), &
&'PI ~= 3.14159265358979323846264338327950288419716939937510'
write(*,*) acos(-1.0_real64)
d2r=acos(-1.0_real64)/180.0_real64
print all,'90 degrees is ', d2r*90.0_real64, ' radians'
! elemental
print all,'elemental',acos([-1.0,-0.5,0.0,0.50,1.0])
! complex
print *,'complex',acos( (-1.0, 0.0) )
print *,'complex',acos( (-1.0, -1.0) )
print *,'complex',acos( ( 0.0, -0.0) )
print *,'complex',acos( ( 1.0, 0.0) )
end program demo_acos
]]>
acosh
Source
<![CDATA[
program demo_acosh
use,intrinsic :: iso_fortran_env, only : dp=>real64,sp=>real32
implicit none
real(kind=dp), dimension(3) :: x = [ 1.0_dp, 2.0_dp, 3.0_dp ]
if( any(x.lt.1) )then
write (*,*) ' warning: values < 1 are present'
endif
write (*,*) acosh(x)
end program demo_acosh
]]>
acospi
Source
<![CDATA[
program demo_acospi
use, intrinsic :: iso_fortran_env, only : real32,real64,real128
implicit none
character(len=*),parameter :: all='(*(g0,1x))'
real(kind=real64) :: x , d2r
real(kind=real64),parameter :: &
& PI = 3.14159265358979323846264338327950288419716939937510_real64
! basics
x = PI/4.0_real64
print all,'acospi(',x,') is ', acospi(x)
! acospi(-1) should be PI
write(*,*) acospi(-1.0_real64)
d2r=acospi(-1.0_real64)/180.0_real64
print all,'90 degrees is ', d2r*90.0_real64, ' radians'
! elemental
print all,'elemental',acospi([-1.0,-0.5,0.0,0.50,1.0])
!
print *,'-1.0',acospi( -1.0 )
print *,' 0.0',acospi( 0.0 )
print *,' 1.0',acospi( 1.0 )
end program demo_acospi
]]>
adjustl
Source
<![CDATA[
program demo_adjustl
implicit none
character(len=20) :: str
character(len=:),allocatable :: astr
character(len=*),parameter :: au= '(a,"[",a,"]")'
integer :: istart, iend
! basic use
str=' sample string '
write(*,au) 'original: ',str
! note the allocated string stays the same length
! and is not trimmed by just an adjustl(3) call.
astr=adjustl(str)
write(*,au) 'adjusted: ',astr
! a fixed-length string can be printed cropped
! combining adjustl(3) with trim(3)
write(*,au) 'trimmed: ',trim(adjustl(str))
! or even printed without adjusting the string a
! cropped substring can be printed
iend=len_trim(str)
istart= verify(str, ' ') ! first non‐blank character
write(*,au) 'substring:',str(istart:iend)
! to generate an actually trimmed allocated variable
astr = trim(adjustl(str))
write(*,au) 'trimmed: ',astr
end program demo_adjustl
]]>
adjustr
Source
<![CDATA[
program demo_adjustr
implicit none
character(len=20) :: str
! print a short number line
write(*,'(a)')repeat('1234567890',2)
! basic usage
str = ' sample string '
write(*,'(a)') str
str = adjustr(str)
write(*,'(a)') str
!
! elemental
!
write(*,'(a)')repeat('1234567890',5)
write(*,'(a)')adjustr([character(len=50) :: &
' first ', &
' second ', &
' third ' ])
write(*,'(a)')repeat('1234567890',5)
end program demo_adjustr
]]>
aimag
Source
<![CDATA[
program demo_aimag
use, intrinsic :: iso_fortran_env, only : real32, real64, real128
implicit none
character(len=*),parameter :: it='(*(1x,g0))'
integer :: i
complex :: z4
complex :: arr(3)
complex(kind=real64) :: z8
print it, 'basics:'
z4 = cmplx(1.e0, 2.e0)
print *, 'value=',z4
print it, 'imaginary part=',aimag(z4),'or', z4%im
print it, 'kinds other than the default may be supported'
z8 = cmplx(3.e0_real64, 4.e0_real64,kind=real64)
print *, 'value=',z8
print it, 'imaginary part=',aimag(z8),'or', z8%im
print it, 'an elemental function can be passed an array'
print it, 'given a complex array:'
arr=[z4,z4/2.0,z4+z4]
print *, (arr(i),new_line('a'),i=1,size(arr))
print it, 'the imaginary component is:'
print it, aimag( arr )
end program demo_aimag
]]>
aint
Source
<![CDATA[
program demo_aint
use, intrinsic :: iso_fortran_env, only : sp=>real32, dp=>real64
implicit none
real(kind=dp) :: x8
print *,'basics:'
print *,' just chops off the fractional part'
print *, aint(-2.999), aint(-2.1111)
print *,' if |x| < 1 a positive zero is returned'
print *, aint(-0.999), aint( 0.9999)
print *,' input may be of any real kind'
x8 = 4.3210_dp
print *, aint(-x8), aint(x8)
print *,'elemental:'
print *,aint([ &
& -2.7, -2.5, -2.2, -2.0, -1.5, -1.0, -0.5, &
& 0.0, &
& +0.5, +1.0, +1.5, +2.0, +2.2, +2.5, +2.7 ])
end program demo_aint
]]>
all
Source
<![CDATA[
program demo_all
implicit none
logical,parameter :: T=.true., F=.false.
logical bool
! basic usage
! is everything true?
bool = all([ T,T,T ])
print *, 'are all values true?', bool
bool = all([ T,F,T ])
print *, 'are all values true now?', bool
! compare matrices, even by a dimension
ARRAYS: block
integer :: a(2,3), b(2,3)
! set everything to one except one value in b
a = 1
b = 1
b(2,2) = 2
! now compare those two arrays
print *,'entire array :', all(a == b )
print *,'compare columns:', all(a == b, dim=1)
print *,'compare rows:', all(a == b, dim=2)
end block ARRAYS
end program demo_all
]]>
allocated
Source
<![CDATA[
program demo_allocated
use,intrinsic :: iso_fortran_env, only : dp=>real64,sp=>real32
implicit none
real(kind=sp), allocatable :: x(:)
character(len=256) :: message
integer :: istat
! basics
if( allocated(x)) then
write(*,*)'do things if allocated'
else
write(*,*)'do things if not allocated'
endif
! if already allocated, deallocate
if ( allocated(x) ) deallocate(x,STAT=istat, ERRMSG=message )
if(istat.ne.0)then
write(*,*)trim(message)
stop
endif
! only if not allocated, allocate
if ( .not. allocated(x) ) allocate(x(20))
! allocation and intent(out)
call intentout(x)
write(*,*)'note it is deallocated!',allocated(x)
contains
subroutine intentout(arr)
! note that if arr has intent(out) and is allocatable,
! arr is deallocated on entry
real(kind=sp),intent(out),allocatable :: arr(:)
write(*,*)'note it was allocated in calling program',allocated(arr)
end subroutine intentout
end program demo_allocated
]]>
anint
Source
<![CDATA[
program demo_anint
use, intrinsic :: iso_fortran_env, only : real32, real64, real128
implicit none
real,allocatable :: arr(:)
! basics
print *, 'ANINT (2.783) has the value 3.0 =>', anint(2.783)
print *, 'ANINT (-2.783) has the value -3.0 =>', anint(-2.783)
print *, 'by default the kind of the output is the kind of the input'
print *, anint(1234567890.1234567890e0)
print *, anint(1234567890.1234567890d0)
print *, 'sometimes specifying the result kind is useful when passing'
print *, 'results as an argument, for example.'
print *, 'do you know why the results are different?'
print *, anint(1234567890.1234567890,kind=real64)
print *, anint(1234567890.1234567890d0,kind=real64)
! elemental
print *, 'numbers on a cusp are always the most troublesome'
print *, anint([ -2.7, -2.5, -2.2, -2.0, -1.5, -1.0, -0.5, 0.0 ])
print *, 'negative zero is processor dependent'
arr=[ 0.0, 0.1, 0.5, 1.0, 1.5, 2.0, 2.2, 2.5, 2.7 ]
print *, anint(arr)
arr=[ -0.0, -0.1, -0.5, -1.0, -1.5, -2.0, -2.2, -2.5, -2.7 ]
print *, anint(arr)
end program demo_anint
]]>
any
Source
<![CDATA[
program demo_any
implicit none
logical,parameter :: T=.true., F=.false.
integer :: a(2,3), b(2,3)
logical :: bool
! basic usage
bool = any([F,F,T,F])
print *,bool
bool = any([F,F,F,F])
print *,bool
! fill two integer arrays with values for testing
a = 1
b = 1
b(:,2) = 2
b(:,3) = 3
! using any(3) with logical expressions you can compare two arrays
! in a myriad of ways
! first, print where elements of b are bigger than in a
call printl( 'first print b > a ', b > a )
! now use any() to test
call printl( 'any true values? any(b > a) ', any(b > a ) )
call printl( 'again by columns? any(b > a,1)', any(b > a, 1) )
call printl( 'again by rows? any(b > a,2)', any(b > a, 2) )
contains
! CONVENIENCE ROUTINE. this is not specific to ANY()
subroutine printl(title,a)
use, intrinsic :: iso_fortran_env, only : &
& stderr=>ERROR_UNIT,&
& stdin=>INPUT_UNIT,&
& stdout=>OUTPUT_UNIT
implicit none
!@(#) print small 2d logical scalar, vector, or matrix
character(len=*),parameter :: all='(*(g0,1x))'
character(len=*),parameter :: row='(" > [ ",*(l1:,","))'
character(len=*),intent(in) :: title
logical,intent(in) :: a(..)
integer :: i
write(*,*)
write(*,all,advance='no')trim(title),&
& ' : shape=',shape(a),',rank=',rank(a),',size=',size(a)
! get size and shape of input
select rank(a)
rank (0); write(*,'(a)')'(a scalar)'
write(*,fmt=row,advance='no')a
write(*,'(" ]")')
rank (1); write(*,'(a)')'(a vector)'
do i=1,size(a)
write(*,fmt=row,advance='no')a(i)
write(*,'(" ]")')
enddo
rank (2); write(*,'(a)')'(a matrix) '
do i=1,size(a,dim=1)
write(*,fmt=row,advance='no')a(i,:)
write(*,'(" ]")')
enddo
rank default
write(stderr,*)'*printl* did not expect rank=', rank(a), &
& 'shape=', shape(a),'size=',size(a)
stop '*printl* unexpected rank'
end select
end subroutine printl
end program demo_any
]]>
asind
Source
<![CDATA[
program demo_asind
use, intrinsic :: iso_fortran_env, only : dp=>real64
implicit none
! value to convert degrees to radians
real(kind=dp),parameter :: R2D=180.0_dp/acos(-1.0_dp)
real(kind=dp) :: angle, rise, run
character(len=*),parameter :: all='(*(g0,1x))'
! given sine(theta) = 1.25 miles/50 miles (opposite/hypotenuse)
! then taking the arcsine of both sides of the equality yields
! theta = arcsine(1.25 miles/50 miles) ie. arcsine(opposite/hypotenuse)
rise=1.250_dp
run=50.00_dp
angle = asind(rise/run)
print all, 'angle of incline(degrees) = ', angle
angle = angle/R2D
print all, 'angle of incline(radians) = ', angle
print all, 'percent grade=',rise/run*100.0_dp
contains
subroutine sub1()
! notice the (incidentally empty) type is defined below
! the implicit statement
implicit type(nil) (a)
type nil
end type nil
type(nil) :: anull
end subroutine sub1
end program demo_asind
]]>
asin
Source
<![CDATA[
program demo_asin
use, intrinsic :: iso_fortran_env, only : dp=>real64
implicit none
! value to convert degrees to radians
real(kind=dp),parameter :: D2R=acos(-1.0_dp)/180.0_dp
real(kind=dp) :: angle, rise, run
character(len=*),parameter :: all='(*(g0,1x))'
! given sine(theta) = 1.25 miles/50 miles (opposite/hypotenuse)
! then taking the arcsine of both sides of the equality yields
! theta = arcsine(1.25 miles/50 miles) ie. arcsine(opposite/hypotenuse)
rise=1.250_dp
run=50.00_dp
angle = asin(rise/run)
print all, 'angle of incline(radians) = ', angle
angle = angle/D2R
print all, 'angle of incline(degrees) = ', angle
print all, 'percent grade=',rise/run*100.0_dp
end program demo_asin
]]>
asinh
Source
<![CDATA[
program demo_asinh
use,intrinsic :: iso_fortran_env, only : dp=>real64,sp=>real32
implicit none
real(kind=dp), dimension(3) :: x = [ -1.0d0, 0.0d0, 1.0d0 ]
! elemental
write (*,*) asinh(x)
end program demo_asinh
]]>
asinpi
Source
<![CDATA[
program demo_asinpi
use, intrinsic :: iso_fortran_env, only : dp=>real64
implicit none
! value to convert degrees to half-revolutions
real(kind=dp),parameter :: D2HR=1/180.0_dp
real(kind=dp) :: angle, rise, run
character(len=*),parameter :: all='(*(g0,1x))'
! basics
! elemental
print all, asinpi( [0.0d0, 0.5d0, -0.5d0, 1.0d0, -1.0d0 ])
!
! sample application
! given sine(theta) = 1.25 miles/50 miles (opposite/hypotenuse)
! then taking the arcsine of both sides of the equality yields
! theta = arcsine(1.25 miles/50 miles) ie. arcsine(opposite/hypotenuse)
rise=1.250_dp
run=50.00_dp
angle = asinpi(rise/run)
print all, 'angle of incline(half-revolutions) = ', angle
angle = angle/D2HR
print all, 'angle of incline(degrees) = ', angle
print all, 'percent grade=',rise/run*100.0_dp
contains
elemental function asinpi(x)
real(kind=dp),parameter :: PI=acos(-1.0_dp)
real(kind=dp),intent(in) :: x
real(kind=dp) :: asinpi
asinpi=asin(x)/PI
end function asinpi
end program demo_asinpi
]]>
associated
Source
<![CDATA[
program demo_associated
implicit none
real, target :: tgt(2) = [1., 2.]
real, pointer :: ptr(:)
ptr => tgt
if (associated(ptr) .eqv. .false.) &
& stop 'POINTER NOT ASSOCIATED'
if (associated(ptr,tgt) .eqv. .false.) &
& stop 'POINTER NOT ASSOCIATED TO TARGET'
if (associated(ptr) ) &
& print *, 'POINTER ASSOCIATED'
if (associated(ptr,tgt) ) &
& print *, 'POINTER ASSOCIATED TO TARGET'
end program demo_associated
]]>
associate
Source
<![CDATA[
program demo_associate
implicit none
character(len=*),parameter :: g='(*(g0,1x))'
character :: array(-5:5,-5:5) ! custom non-normal bounds
! note the different between queries of ARRAY versus ARRAY(:,:)
write(*,g)'array: ', 'lbound=',lbound(array), &
'ubound=',ubound(array)
write(*,g)'array(:,:): ', 'lbound=',lbound(array(:,:)), &
'ubound=',ubound(array(:,:))
! the bounds assigned to the identifiers are what UBOUND(3f)
! and LBOUND(3f) return given the selector as an argument
associate ( &
alias=> array, & ! keeps the custom bounds
normal=> array(:,:), & ! gets normal bounds
quadI=> array(+1:+5,-5:-1), & ! quad* will have normal bounds
quadII=> array(-5:-1,-5:-1), & !
quadIII=> array(-5:-1,+1:+5), & !
quadIV=> array(+1:+5,+1:+5), & !
xaxis=>array(:,0), &
yaxis=>array(0,:) &
)
array='.' ! selector name is still valid in the block
xaxis='-'
yaxis='|'
alias(0,0)='+' ! uses non-normal bounds, equivalent to array(0,0)='+'
write(*,'(11(g0,1x))') alias
! the quads have normalized dimension bounds (1:5,1:5):
quadI = '1'; quadI(1,1) = 'a'; quadI(5,5) = 'A'
quadII = '2'; quadII(1,1) = 'b'; quadII(5,5) = 'B'
quadIII = '3'; quadIII(1,1) = 'c'; quadIII(5,5) = 'C'
quadIV = '4'; quadIV(1,1) = 'd'; quadIV(5,5) = 'D'
write(*,'(11(g0,1x))') alias
write(*,g)'array: lbound=',lbound(array), 'ubound=',ubound(array)
write(*,g)'alias: lbound=',lbound(alias), 'ubound=',ubound(alias)
write(*,g)'normal: lbound=',lbound(normal),'ubound=',ubound(normal)
write(*,g)'quadI: lbound=',lbound(quadI), 'ubound=',ubound(quadI)
write(*,g)'quadII: lbound=',lbound(quadII),'ubound=',ubound(quadII)
write(*,g)'quadIV: lbound=',lbound(quadIV),'ubound=',ubound(quadIV)
end associate
end program demo_associate
]]>
atan2d
Source
<![CDATA[
program demo_atan2d
implicit none
integer,parameter :: wp=kind(0.0)
real(wp),parameter :: d2r=acos(-1.0_wp)/180.0_wp
real :: z
complex :: c
!
! basic usage
! atan2d (1.5574077, 1.0) has the value 1.0 radian (approximately).
z=atan2d(1.5574077, 1.0)
write(*,*) 'degrees=',z,'radians=',d2r*z
!
! elemental arrays
write(*,*)'elemental',atan2d( [10.0, 20.0], [30.0,40.0] )
!
! elemental arrays and scalars
write(*,*)'elemental',atan2d( [10.0, 20.0], 50.0 )
!
! multi-dimensional returns multi-dimensional
write(*,*) atan2(reshape([1.0,1.0,1.0,1.0],[2,2]),&
& reshape([1.0,1.0,1.0,1.0],[2,2]) )
!
! break complex values into real and imaginary components
c=(0.0,1.0)
write(*,*)'complex value treated as components', &
& c,atan2d( x=c%re, y=c%im )
!
! extended sample
COMPLEX_VALS: block
real :: ang
complex,allocatable :: vals(:)
integer :: i
!
vals=[ &
( 1.0, 0.0 ), & ! 0
( 1.0, 1.0 ), & ! 45
( 0.0, 1.0 ), & ! 90
(-1.0, 1.0 ), & ! 135
(-1.0, 0.0 ), & ! 180
(-1.0,-1.0 ), & ! 225
( 0.0,-1.0 )] ! 270
do i=1,size(vals)
ang=atan2d(vals(i)%im, vals(i)%re)
write(*,101)vals(i),ang,d2r*ang
enddo
101 format( &
& 'X= ',f5.2, &
& ' Y= ',f5.2, &
& ' ANGLE= ',g0, &
& T38,'RADIANS= ',g0.4)
endblock COMPLEX_VALS
!
end program demo_atan2d
]]>
atan2
Source
<![CDATA[
program demo_atan2
real :: z
complex :: c
!
! basic usage
! ATAN2 (1.5574077, 1.0) has the value 1.0 (approximately).
z=atan2(1.5574077, 1.0)
write(*,*) 'radians=',z,'degrees=',r2d(z)
!
! elemental : arrays
write(*,*)'elemental',atan2( [10.0, 20.0], [30.0,40.0] )
!
! elemental : arrays and scalars
write(*,*)'elemental',atan2( [10.0, 20.0], 50.0 )
!
! break complex values into real and imaginary components
! (note TAN2() can take a complex type value )
c=(0.0,1.0)
write(*,*)'complex',c,atan2( x=c%re, y=c%im )
!
! extended sample converting cartesian coordinates to polar
COMPLEX_VALS: block
real :: ang, radius
complex,allocatable :: vals(:)
integer :: i
!
vals=[ &
! 0 45 90 135
( 1.0, 0.0 ), ( 1.0, 1.0 ), ( 0.0, 1.0 ), (-1.0, 1.0 ), &
! 180 225 270
(-1.0, 0.0 ), (-1.0,-1.0 ), ( 0.0,-1.0 ) ]
do i=1,size(vals)
call cartesian_to_polar(vals(i), radius,ang)
write(*,101)vals(i),ang,r2d(ang),radius
enddo
101 format( 'X=',f5.2,' Y=',f5.2,' ANGLE=',g0, &
& T38,'DEGREES=',g0.4, T54,'DISTANCE=',g0)
endblock COMPLEX_VALS
!
contains
!
elemental real function r2d(radians)
! input radians to convert to degrees
doubleprecision,parameter :: DEGREE=0.017453292519943d0 ! radians
real,intent(in) :: radians
r2d=radians / DEGREE ! do the conversion
end function r2d
!
subroutine cartesian_to_polar(xy,radius,inclination)
! return angle in radians in range 0 to 2*PI
implicit none
complex,intent(in) :: xy
real,intent(out) :: radius,inclination
radius=abs( xy )
! arbitrarily set angle to zero when radius is zero
inclination=merge(0.0,atan2(x=xy%re, y=xy%im),radius==0.0)
! bring into range 0 <= inclination < 2*PI
if(inclination < 0.0)inclination=inclination+2*atan2(0.0d0,-1.0d0)
end subroutine cartesian_to_polar
!
end program demo_atan2
]]>
atan2pi
Source
<![CDATA[
program demo_atan2pi
real :: z
complex :: c
real, parameter :: h2d = 180.0
!
! basic usage
! atan2pi (1.5574077, 1.0) has the value 1.0 (approximately).
z=atan2pi(1.5574077, 1.0)
write(*,*) 'half-revolutions=',z,'degrees=',h2d*z
!
! elemental arrays
write(*,*)'elemental',atan2pi( [10.0, 20.0], [30.0,40.0] )
!
! elemental arrays and scalars
write(*,*)'elemental',atan2pi( [10.0, 20.0], 50.0 )
!
! break complex values into real and imaginary components
! (note TAN2() can take a complex type value )
c=(0.0,1.0)
write(*,*)'complex',c,atan2pi( x=c%re, y=c%im )
!
! extended sample converting cartesian coordinates to polar
COMPLEX_VALS: block
real :: ang
complex,allocatable :: vals(:)
integer :: i
!
vals=[ &
( 1.0, 0.0 ), & ! 0
( 1.0, 1.0 ), & ! 45
( 0.0, 1.0 ), & ! 90
(-1.0, 1.0 ), & ! 135
(-1.0, 0.0 ), & ! 180
(-1.0,-1.0 ), & ! 225
( 0.0,-1.0 )] ! 270
write(*,'(a)')repeat('1234567890',8)
do i=1,size(vals)
ang=atan2pi(vals(i)%im,vals(i)%re)
write(*,101)vals(i),ang,h2d*ang
enddo
101 format( &
& 'X= ',f5.2, &
& ' Y= ',f5.2, &
& ' HALF-REVOLUTIONS= ',f7.3, &
& T50,' DEGREES= ',g0.4)
endblock COMPLEX_VALS
!
end program demo_atan2pi
]]>
atand
Source
<![CDATA[
program demo_atand
use, intrinsic :: iso_fortran_env, only : real32, real64, real128
implicit none
character(len=*),parameter :: all='(*(g0,1x))'
real(kind=real64),parameter :: &
Deg_Per_Rad = 57.2957795130823208767981548_real64
real(kind=real64) :: x
x=2.866_real64
print all, atand(x)
print all, atand( 2.0d0, 2.0d0),atand( 2.0d0, 2.0d0)/Deg_Per_Rad
print all, atand( 2.0d0,-2.0d0),atand( 2.0d0,-2.0d0)/Deg_Per_Rad
print all, atand(-2.0d0, 2.0d0),atand(-2.0d0, 2.0d0)/Deg_Per_Rad
print all, atand(-2.0d0,-2.0d0),atand(-2.0d0,-2.0d0)/Deg_Per_Rad
end program demo_atand
]]>
atan
Source
<![CDATA[
program demo_atan
use, intrinsic :: iso_fortran_env, only : real32, real64, real128
implicit none
character(len=*),parameter :: all='(*(g0,1x))'
real(kind=real64),parameter :: &
Deg_Per_Rad = 57.2957795130823208767981548_real64
real(kind=real64) :: x
x=2.866_real64
print all, atan(x)
print all, atan( 2.0d0, 2.0d0),atan( 2.0d0, 2.0d0)*Deg_Per_Rad
print all, atan( 2.0d0,-2.0d0),atan( 2.0d0,-2.0d0)*Deg_Per_Rad
print all, atan(-2.0d0, 2.0d0),atan(-2.0d0, 2.0d0)*Deg_Per_Rad
print all, atan(-2.0d0,-2.0d0),atan(-2.0d0,-2.0d0)*Deg_Per_Rad
end program demo_atan
]]>
atanh
Source
<![CDATA[
program demo_atanh
implicit none
real, dimension(3) :: x = [ -1.0, 0.0, 1.0 ]
write (*,*) atanh(x)
end program demo_atanh
]]>
atanpi
Source
<![CDATA[
program demo_atanpi
use, intrinsic :: iso_fortran_env, only : real32, real64
implicit none
character(len=*),parameter :: all='(*(g0,1x))'
real(kind=real64) :: x, y
x=2.866_real64
print all, atanpi(x)
print all, atanpi( 2.0d0, 2.0d0),atanpi( 2.0d0, 2.0d0)*180
print all, atanpi( 2.0d0,-2.0d0),atanpi( 2.0d0,-2.0d0)*180
print all, atanpi(-2.0d0, 2.0d0),atanpi(-2.0d0, 2.0d0)*180
print all, atanpi(-2.0d0,-2.0d0),atanpi(-2.0d0,-2.0d0)*180
end program demo_atanpi
]]>
atomic_add
Source
<![CDATA[
program demo_atomic_add
use iso_fortran_env
implicit none
integer(atomic_int_kind) :: counter[*]
integer :: stat, me
if (this_image() == 1) counter = 0
sync all
me = this_image()
call atomic_add(counter[1], me, stat)
if (stat /= 0) print *, "Image", me, ": Failed with STAT =", stat
sync all
if (this_image() == 1) print *, "Final counter:", counter
end program demo_atomic_add
]]>
atomic_and
Source
<![CDATA[
program demo_atomic_and
use iso_fortran_env
implicit none
integer(atomic_int_kind) :: counter[*]
integer :: stat, me
if (this_image() == 1) counter = 0
sync all
me = this_image()
call atomic_add(counter[1], me, stat)
if (stat /= 0) print *, "Image", me, ": Failed with STAT =", stat
sync all
if (this_image() == 1) print *, "Final counter:", counter
end program demo_atomic_and
]]>
atomic_cas
Source
<![CDATA[
program demo_atomic_cas_example
use iso_fortran_env
implicit none
integer(atomic_int_kind) :: lock[*]
integer(atomic_int_kind) :: old
integer :: stat, me
if (this_image() == 1) lock = 0
sync all
me = this_image()
call atomic_cas(lock[1], old, 0, me, stat)
if (stat /= 0) then
print *, "Image", me, ": Failed with STAT =", stat
else
print *, "Image", me, ": Old =", old, ", New =", lock[1]
end if
sync all
if (this_image() == 1) print *, "Final lock:", lock
end program demo_atomic_cas_example
]]>
atomic_define
Source
<![CDATA[
program demo_atomic_define
use iso_fortran_env
implicit none
integer(atomic_int_kind) :: counter[*]
integer :: stat, me
if (this_image() == 1) counter = 0
sync all
me = this_image()
if (me == 2) call atomic_define(counter[1], 42, stat)
if (stat /= 0) print *, "Image", me, ": Failed with STAT =", stat
sync all
if (this_image() == 1) print *, "Final counter:", counter
end program demo_atomic_define
]]>
atomic_fetch_add
Source
<![CDATA[
program demo_atomic_fetch_add
use iso_fortran_env
implicit none
integer(atomic_int_kind) :: counter[*] ! Coarray for shared counter
integer(atomic_int_kind) :: old_value ! Stores value before addition
integer :: stat, me, i
! Initialize counter on image 1
if (this_image() == 1) counter = 0
sync all ! Ensure all images see initialized counter
me = this_image() ! Get current image number
! Each image atomically adds its image number to the counter
call atomic_fetch_add(counter[1], me, old_value, stat)
! Check for errors
if (stat /= 0) then
print *, "Image", me, ": Operation failed with STAT =", stat
else
print *, "Image", me, ": Old value =", old_value, ", Added", me
end if
! Synchronize all images before printing final result
sync all
! Image 1 prints the final counter value
if (this_image() == 1) then
print *, "Final counter value:", counter
end if
end program demo_atomic_fetch_add
]]>
atomic_fetch_and
Source
<![CDATA[
program demo_atomic_fetch_and
use iso_fortran_env
implicit none
integer(atomic_int_kind) :: flags[*], old
integer :: stat, me
if (this_image() == 1) flags = int(b'1111', atomic_int_kind)
sync all
me = this_image()
call atomic_fetch_and(flags[1], int(b'1010', atomic_int_kind), old, stat)
if (stat /= 0) print *, "Image", me, ": Failed with STAT =", stat
print *, "Image", me, ": Old =", old
sync all
if (this_image() == 1) print *, "Final flags:", flags
end program demo_atomic_fetch_and
]]>
atomic_fetch_or
Source
<![CDATA[
program demo_atomic_fetch_or
use iso_fortran_env
implicit none
integer(atomic_int_kind) :: flags[*], old
integer :: stat, me
if (this_image() == 1) flags = int(b'1000', atomic_int_kind)
sync all
me = this_image()
call atomic_fetch_or(flags[1], int(b'0011', atomic_int_kind), old, stat)
if (stat /= 0) print *, "Image", me, ": Failed with STAT =", stat
print *, "Image", me, ": Old =", old
sync all
if (this_image() == 1) print *, "Final flags:", flags
end program demo_atomic_fetch_or
]]>
atomic_fetch_xor
Source
<![CDATA[
program demo_atomic_fetch_xor
use iso_fortran_env
implicit none
integer(atomic_int_kind) :: flags[*], old
integer :: stat, me
if (this_image() == 1) flags = int(b'1100', atomic_int_kind)
sync all
me = this_image()
call atomic_fetch_xor(flags[1], int(b'1010', atomic_int_kind), old, stat)
if (stat /= 0) print *, "Image", me, ": Failed with STAT =", stat
print *, "Image", me, ": Old =", old
sync all
if (this_image() == 1) print *, "Final flags:", flags
end program demo_atomic_fetch_xor
]]>
atomic_or
Source
<![CDATA[
program demo_atomic_or
use iso_fortran_env
implicit none
integer(atomic_int_kind) :: flags[*]
integer :: stat, me
if (this_image() == 1) flags = int(b'1000', atomic_int_kind)
sync all
me = this_image()
call atomic_or(flags[1], int(b'0011', atomic_int_kind), stat)
if (stat /= 0) print *, "Image", me, ": Failed with STAT =", stat
sync all
if (this_image() == 1) print *, "Final flags:", flags
end program demo_atomic_or
]]>
atomic_ref
Source
<![CDATA[
program demo_atomic_ref
use iso_fortran_env
implicit none
integer(atomic_int_kind) :: counter[*], value
integer :: stat, me
if (this_image() == 1) counter = 42
sync all
me = this_image()
call atomic_ref(value, counter[1], stat)
if (stat /= 0) then
print *, "Image", me, ": Failed with STAT =", stat
else
print *, "Image", me, ": Retrieved value =", value
end if
end program demo_atomic_ref
]]>
atomic_xor
Source
<![CDATA[
program demo_atomic_xor
use iso_fortran_env
implicit none
integer(atomic_int_kind) :: flags[*]
integer :: stat, me
if (this_image() == 1) flags = int(b'1100', atomic_int_kind)
sync all
me = this_image()
call atomic_xor(flags[1], int(b'1010', atomic_int_kind), stat)
if (stat /= 0) print *, "Image", me, ": Failed with STAT =", stat
sync all
if (this_image() == 1) print *, "Final flags:", flags
end program demo_atomic_xor
]]>
backspace
Source
<![CDATA[
program demo_backspace
implicit none
character(len=256) :: line
character(len=256) :: mssge
integer :: i
integer :: j
integer :: ios
integer,allocatable :: iarr(:)
! create a basic sequential file
open(10,file='dem_backspace.txt',action='readwrite') ! open a file
do i=1,30 ! write lines to it
write(10,'(a,i3,*(i3))') 'line ',i, (j,j=1,i)
enddo
! back up several lines
do i=1,14
backspace(10, iostat=ios,iomsg=mssge)
if(ios.ne.0)then
write(*,'(*(a))') '*dem_backspace* ERROR:',mssge
endif
enddo
read(10,'(a)')line
write(*,*)'back at a previous record !'
! read line as a string
write(*,'("string=",a)')trim(line)
! backspace so can read again as numbers
backspace(10)
! read part of a line numerically to get size of array to read
read(10,'(5x,i3)')i
allocate(iarr(i))
! reread line just reading array
backspace(10)
read(10,'(8x,*(i3))')iarr
write(*,'(*(g0,1x))')'size=',i,'array=',iarr
!! Note: writing a new line will truncate file
!! to current record position
close(10,status='delete')
end program demo_backspace
]]>
bessel_j0
Source
<![CDATA[
program demo_bessel_j0
use, intrinsic :: iso_fortran_env, only : real32, real64, real128
implicit none
real(kind=real64) :: x
x = 0.0_real64
x = bessel_j0(x)
write(*,*)x
end program demo_bessel_j0
]]>
bessel_j1
Source
<![CDATA[
program demo_bessel_j1
use, intrinsic :: iso_fortran_env, only : real32, real64, real128
implicit none
real(kind=real64) :: x = 1.0_real64
x = bessel_j1(x)
write(*,*)x
end program demo_bessel_j1
]]>
bessel_jn
Source
<![CDATA[
program demo_bessel_jn
use, intrinsic :: iso_fortran_env, only : real32, real64, real128
implicit none
real(kind=real64) :: x = 1.0_real64
x = bessel_jn(5,x)
write(*,*)x
end program demo_bessel_jn
]]>
bessel_y0
Source
<![CDATA[
program demo_bessel_y0
use, intrinsic :: iso_fortran_env, only : real32, real64, real128
implicit none
real(kind=real64) :: x = 0.0_real64
x = bessel_y0(x)
write(*,*)x
end program demo_bessel_y0
]]>
bessel_y1
Source
<![CDATA[
program demo_bessel_y1
use, intrinsic :: iso_fortran_env, only : real32, real64, real128
implicit none
real(kind=real64) :: x = 1.0_real64
write(*,*)x, bessel_y1(x)
end program demo_bessel_y1
]]>
bessel_yn
Source
<![CDATA[
program demo_bessel_yn
use, intrinsic :: iso_fortran_env, only : real32, real64, real128
implicit none
real(kind=real64) :: x = 1.0_real64
write(*,*) x,bessel_yn(5,x)
end program demo_bessel_yn
]]>
bge
Source
<![CDATA[
program demo_bge
use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64
implicit none
integer :: i
integer(kind=int8) :: byte
integer(kind=int8),allocatable :: arr1(:), arr2(:)
! BASIC USAGE
write(*,*)'bge(-127,127)=',bge( -127, 127 )
! on (very common) "two's complement" machines that are
! little-endian -127 will be greater than 127
! BOZ constants
! BOZ constants are subject to truncation, so make sure
! your values are valid for the integer kind being compared to
write(*,*)'bge(b"0001",2)=',bge( b"1", 2)
! ELEMENTAL
! an array and scalar
write(*, *)'compare array of values [-128, -0, +0, 127] to 127'
write(*, *)bge(int([-128, -0, +0, 127], kind=int8), 127_int8)
! two arrays
write(*, *)'compare two arrays'
arr1=int( [ -127, -0, +0, 127], kind=int8 )
arr2=int( [ 127, 0, 0, -127], kind=int8 )
write(*,*)'arr1=',arr1
write(*,*)'arr2=',arr2
write(*, *)'bge(arr1,arr2)=',bge( arr1, arr2 )
! SHOW TESTS AND BITS
! actually looking at the bit patterns should clarify what affect
! signs have ...
write(*,*)'Compare some one-byte values to 64.'
write(*,*)'Notice that the values are tested as bits not as integers'
write(*,*)'so the results are as if values are unsigned integers.'
do i=-128,127,32
byte=i
write(*,'(sp,i0.4,*(1x,1l,1x,b0.8))')i,bge(byte,64_int8),byte
enddo
! SIGNED ZERO
! are +0 and -0 the same on your platform? When comparing at the
! bit level this is important
write(*,'("plus zero=",b0)') +0
write(*,'("minus zero=",b0)') -0
end program demo_bge
]]>
bgt
Source
<![CDATA[
program demo_bgt
use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64
implicit none
integer :: i
integer(kind=int8) :: byte
! Compare some one-byte values to 64.
! Notice that the values are tested as bits not as integers
! so sign bits in the integer are treated just like any other
write(*,'(a)') 'we will compare other values to 64'
i=64
byte=i
write(*,'(sp,i0.4,*(1x,1l,1x,b0.8))')i,bgt(byte,64_int8),byte
write(*,'(a)') "comparing at the bit level, not as whole numbers."
write(*,'(a)') "so pay particular attention to the negative"
write(*,'(a)') "values on this two's complement platform ..."
do i=-128,127,32
byte=i
write(*,'(sp,i0.4,*(1x,1l,1x,b0.8))')i,bgt(byte,64_int8),byte
enddo
! see the BGE() description for an extended description
! of related information
end program demo_bgt
]]>
bit_size
Source
<![CDATA[
program demo_bit_size
use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64
use,intrinsic :: iso_fortran_env, only : integer_kinds
implicit none
character(len=*),parameter :: fmt=&
& '(a,": bit size is ",i3," which is kind=",i3," on this platform")'
! default integer bit size on this platform
write(*,fmt) "default", bit_size(0), kind(0)
write(*,fmt) "int8 ", bit_size(0_int8), kind(0_int8)
write(*,fmt) "int16 ", bit_size(0_int16), kind(0_int16)
write(*,fmt) "int32 ", bit_size(0_int32), kind(0_int32)
write(*,fmt) "int64 ", bit_size(0_int64), kind(0_int64)
write(*,'(a,*(i0:,", "))') "The available kinds are ",integer_kinds
end program demo_bit_size
]]>
ble
Source
<![CDATA[
program demo_ble
use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64
implicit none
integer :: i
integer(kind=int8) :: byte
! Compare some one-byte values to 64.
! Notice that the values are tested as bits not as integers
! so sign bits in the integer are treated just like any other
do i=-128,127,32
byte=i
write(*,'(sp,i0.4,*(1x,1l,1x,b0.8))')i,ble(byte,64_int8),byte
write(*,'(sp,i0.4,*(4x,b0.8))')64_int8,64_int8
enddo
! see the BGE() description for an extended description
! of related information
end program demo_ble
]]>
block
Source
<![CDATA[
program demo_block
implicit none
integer,parameter :: arr1(*)=[1,2,3,4,5,6,7]
integer,parameter :: arr2(*)=[0,1,2,3,4,5,6,7]
! so when you want error processing to be skipped
! if you exhaust a series of tries and really hate GOTO ...
DEBUG: block
integer :: icount
do icount=1,100 ! look for answer up to 100 times
if(icount.eq.40)exit DEBUG ! found answer, go on
enddo
! never get here unless exhausted the DO loop
write(*,*)'never found the answer'
stop 3
endblock DEBUG
!
call showme(arr1)
call showme(arr2)
!
contains
!
subroutine showme(a)
integer,intent(in) :: a(:)
integer :: i=-100
integer :: tan
tan=20 ! intentionally cause a conflict with intrinsic
! cannot use tan(3f) right here because using name for a variable
TESTFORZERO: block
integer :: I ! local block variable
intrinsic :: tan ! can use the TAN intrinsic in the block now
! as this definition supersedes the one in the
! parent body
do i=1,size(a)
if(a(i).eq.0) then
write(*,*)'found zero at index',i
exit TESTFORZERO
endif
enddo
write(*,*)'Never found a zero, tried ',i-1,' times'
return
endblock TESTFORZERO
! note the variable I in the block is local to the block
write(*,*)'this is the variable back in the main scope, I=',i
end subroutine showme
end program demo_block
]]>
blt
Source
<![CDATA[
program demo_blt
use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64
implicit none
integer :: i
integer(kind=int8) :: byte
! Compare some one-byte values to 64.
! Notice that the values are tested as bits not as integers
! so sign bits in the integer are treated just like any other
do i=-128,127,32
byte=i
write(*,'(sp,i0.4,*(1x,1l,1x,b0.8))')i,blt(byte,64_int8),byte
enddo
! BOZ literals
write(*,*)blt(z'1000', z'101011010')
! see the BGE() description for an extended description
! of related information
end program demo_blt
]]>
btest
Source
<![CDATA[
program demo_btest
implicit none
integer :: i, j, pos, a(2,2)
logical :: bool
character(len=*),parameter :: g='(*(g0))'
i = 32768 + 1024 + 64
write(*,'(a,i0,"=>",b32.32,/)')'Looking at the integer: ',i
! looking one bit at a time from LOW BIT TO HIGH BIT
write(*,g)'from bit 0 to bit ',bit_size(i),'==>'
do pos=0,bit_size(i)-1
bool = btest(i, pos)
write(*,'(l1)',advance='no')bool
enddo
write(*,*)
! a binary format the hard way.
! Note going from bit_size(i) to zero.
write(*,*)
write(*,g)'so for ',i,' with a bit size of ',bit_size(i)
write(*,'(b32.32)')i
write(*,g)merge('^','_',[(btest(i,j),j=bit_size(i)-1,0,-1)])
write(*,*)
write(*,g)'and for ',-i,' with a bit size of ',bit_size(i)
write(*,'(b32.32)')-i
write(*,g)merge('^','_',[(btest(-i,j),j=bit_size(i)-1,0,-1)])
! elemental:
!
a(1,:)=[ 1, 2 ]
a(2,:)=[ 3, 4 ]
write(*,*)
write(*,'(a,/,*(i2,1x,i2,/))')'given the array a ...',a
! the second bit of all the values in a
write(*,'(a,/,*(l2,1x,l2,/))')'the value of btest (a, 2)',btest(a,2)
! bits 1,2,3,4 of the value 2
write(*,'(a,/,*(l2,1x,l2,/))')'the value of btest (2, a)',btest(2,a)
end program demo_btest
]]>
c_associated
Source
<![CDATA[
program demo_c_associated
contains
subroutine association_test(a,b)
use iso_c_binding, only: c_associated, c_loc, c_ptr
implicit none
real, pointer :: a
type(c_ptr) :: b
if(c_associated(b, c_loc(a))) &
stop 'b and a do not point to same target'
end subroutine association_test
end program demo_c_associated
]]>
ceiling
Source
<![CDATA[
program demo_ceiling
implicit none
! just a convenient format for a list of integers
character(len=*),parameter :: gen='(1x,*(g0:,1x))'
real :: x
real :: y
integer :: ierr
real,parameter :: arr(*)=[ &
& -2.7, -2.5, -2.2, -2.0, -1.5, &
& -1.0, -0.5, 0.0, +0.5, +1.0, &
& +1.5, +2.0, +2.2, +2.5, +2.7 ]
character(len=80) :: message
print *, 'Basic Usage'
x = 63.29
y = -63.59
print gen, ceiling(x), ceiling(y)
! note the result was the next integer larger to the right
print *, 'Whole Numbers' ! real values equal to whole numbers
x = 63.0
y = -63.0
print gen, ceiling(x), ceiling(y)
print *, 'Elemental' ! (so an array argument is allowed)
print gen , ceiling(arr)
print *, 'Advanced Usage' ! Dealing with large magnitude values
print '(a)',[character(len=80):: &
'Limits ',&
'You only care about Limits if you are using values near or above ',&
'the limits of the integer type you are using (see huge(3)). ',&
'',&
'Surprised by some of the following results? ',&
'What do real values clearly out of the range of integers return? ',&
'What do values near the end of the range of integers return? ',&
'The standard only specifies what happens for representable values',&
'in the range of integer values. ',&
'',&
'It is common but not required that if the input is out of range ',&
'and positive the result is -huge(0) and -huge(0)-1 if negative. ',&
'Note you are out of range before you get to real(huge(0)). ',&
'' ]
print gen , 'For reference: huge(0)=',huge(0),'-huge(0)-1=',-huge(0)-1
x=huge(0)
call displayx()
x=2*x
call displayx()
x=-huge(0)-1
call displayx()
x=2*x
call displayx()
print gen , repeat('=',80)
contains
subroutine displayx()
use,intrinsic :: iso_fortran_env, only: int8,int16,int32,int64
print gen , repeat('=',80)
print gen , 'x=',x,' spacing=',spacing(x)
print gen , ' ceiling(x):',ceiling(x)
print gen , ' ceiling(x,kind=int64):',ceiling(x,kind=int64)
print gen , ' ceiling_robust(x):',ceiling_robust(x,ierr,message)
if(ierr.ne.0)then
print gen, ierr,'=>',trim(message)
endif
end subroutine displayx
elemental impure function ceiling_robust(x,ierr,message)
! return the least integer >= x
use,intrinsic :: iso_fortran_env, only: int8,int16,int32,int64
use,intrinsic :: iso_fortran_env, only: real32,real64,real128
real,intent(in) :: x
integer,intent(out),optional :: ierr
character(len=*),intent(out),optional :: message
character(len=80) :: message_local
integer :: ceiling_robust
integer :: ierr_local
ierr_local=0
message_local=''
! allow -huge(0)-1 or not?
if(spacing(x) > 128)then ! bounds checking
if(x.ge.0)then
write(message_local,*)'<ERROR>X=',x,' >=',anint(real(huge(0)))
ierr_local=1
ceiling_robust=huge(0)
else
ierr_local=2
ceiling_robust=-huge(0)-1
write(message_local,*)'<ERROR>X=',x,' <=',anint(real(-huge(0)-1))
endif
else
! used to use a computed goto to do this!
ceiling_robust = int(x)
if (x > 0.0) then
if (real(ceiling_robust) < x)then
ceiling_robust = ceiling_robust + 1
endif
endif
endif
if(present(ierr))then
ierr=ierr_local
elseif(ierr_local.ne.0)then
stop message_local
endif
if(present(message))then
message=message_local
endif
end function ceiling_robust
end program demo_ceiling
]]>
c_f_pointer
Source
<![CDATA[
program demo_c_f_pointer
use iso_c_binding
implicit none
interface
subroutine my_routine(p) bind(c,name='myC_func')
import :: c_ptr
type(c_ptr), intent(out) :: p
end subroutine
end interface
type(c_ptr) :: cptr
real,pointer :: a(:)
call my_routine(cptr)
call c_f_pointer(cptr, a, [12])
end program demo_c_f_pointer
]]>
c_f_procpointer
Source
<![CDATA[
program demo_c_f_procpointer
use iso_c_binding
implicit none
abstract interface
function func(a)
import :: c_float
real(c_float), intent(in) :: a
real(c_float) :: func
end function
end interface
interface
function getIterFunc() bind(c,name="getIterFunc")
import :: c_funptr
type(c_funptr) :: getIterFunc
end function
end interface
type(c_funptr) :: cfunptr
procedure(func), pointer :: myFunc
cfunptr = getIterFunc()
call c_f_procpointer(cfunptr, myFunc)
end program demo_c_f_procpointer
]]>
c_funloc
Source
<![CDATA[
! program demo_c_funloc and module
module x
use iso_c_binding
implicit none
contains
subroutine sub(a) bind(c)
real(c_float) :: a
a = sqrt(a)+5.0
end subroutine sub
end module x
!
program demo_c_funloc
use iso_c_binding
use x
implicit none
interface
subroutine my_routine(p) bind(c,name='myC_func')
import :: c_funptr
type(c_funptr), intent(in) :: p
end subroutine
end interface
call my_routine(c_funloc(sub))
!
end program demo_c_funloc
]]>
char
Source
<![CDATA[
program demo_char
implicit none
integer, parameter :: ascii = selected_char_kind ("ascii")
character(len=1, kind=ascii ) :: c, esc
integer :: i
! basic
i=74
c=char(i)
write(*,*)'ASCII character ',i,'is ',c
write(*,'(*(g0))')'Uppercase ASCII: ',(char(i),i=65,90)
write(*,'(*(g0))')'lowercase ASCII: ',(char(i),i=97,122)
esc=char(27)
write(*,'(*(g0))')'Elemental: ',char([65,97,90,122])
!
print *, 'a selection of ASCII characters (shows hex if not printable)'
do i=0,127,10
c = char(i,kind=ascii)
select case(i)
case(32:126)
write(*,'(i3,1x,a)')i,c
case(0:31,127)
! print hexadecimal value for unprintable characters
write(*,'(i3,1x,z2.2)')i,c
case default
write(*,'(i3,1x,a,1x,a)')i,c,'non-standard ASCII'
end select
enddo
end program demo_char
]]>
c_loc
Source
<![CDATA[
]]>
close
Source
<![CDATA[
program demo_close
implicit none
character(len=256) :: message
integer :: ios
open (10, file='employee.names', action='read', &
& iostat=ios,iomsg=message)
if (ios < 0) then
! perform error processing on the unit 10 file.
close (10, status='keep',iostat=ios,iomsg=message)
if(ios.ne.0)then
write(*,'(*(a))')'*demo_close* close error: ',trim(message)
stop 1
endif
elseif (ios > 0) then
! perform error processing on open
write(*,'(*(a))')'*demo_close* open error: ',trim(message)
stop 2
endif
end program demo_close
]]>
cmplx
Source
<![CDATA[
program demo_aimag
implicit none
integer,parameter :: dp=kind(0.0d0)
real(kind=dp) :: precise
complex(kind=dp) :: z8
complex :: z4, zthree(3)
precise=1.2345678901234567d0
! basic
z4 = cmplx(-3)
print *, 'Z4=',z4
z4 = cmplx(1.23456789, 1.23456789)
print *, 'Z4=',z4
! with a format treat a complex as two real values
print '(1x,g0,1x,g0,1x,g0)','Z4=',z4
! working with higher precision values
! using kind=dp makes it keep DOUBLEPRECISION precision
! otherwise the result would be of default kind
z8 = cmplx(precise, -precise )
print *, 'lost precision Z8=',z8
z8 = cmplx(precise, -precise ,kind=dp)
print *, 'kept precision Z8=',z8
! assignment of constant values does not require cmplx(3)00
! The following is intuitive and works without calling cmplx(3)
! but does not work for variables just constants
z8 = (1.1111111111111111d0, 2.2222222222222222d0 )
print *, 'Z8 defined with constants=',z8
! what happens when you assign a complex to a real?
precise=z8
print *, 'LHS=',precise,'RHS=',z8
! elemental
zthree=cmplx([10,20,30],-1)
print *, 'zthree=',zthree
! descriptors are an alternative
zthree(1:2)%re=[100,200]
print *, 'zthree=',zthree
end program demo_aimag
]]>
co_broadcast
Source
<![CDATA[
program demo_co_broadcast
implicit none
integer :: val(3)
if (this_image() == 1) then
val = [1, 5, 3]
endif
call co_broadcast (val, source_image=1)
print *, this_image(), ":", val
end program demo_co_broadcast
]]>
co_max
Source
<![CDATA[
program demo_co_max
implicit none
integer :: val
val = this_image()
call co_max(val, result_image=1)
if (this_image() == 1) then
write(*,*) "Maximal value", val ! prints num_images()
endif
end program demo_co_max
]]>
co_min
Source
<![CDATA[
program demo_co_min
implicit none
integer :: val
val = this_image()
call co_min(val, result_image=1)
if (this_image() == 1) then
write(*,*) "Minimal value", val ! prints 1
endif
end program demo_co_min
]]>
command_argument_count
Source
<![CDATA[
program demo_command_argument_count
implicit none
integer :: count
count = command_argument_count()
print *, count
end program demo_command_argument_count
]]>
comment
Source
<![CDATA[
program demo_comment
integer :: values(8)
character(len=:),allocatable :: string
character(len=1),parameter :: dash='-',colon=':',dot='.'
real :: x=3.0, y=4.0
! comments may appear on a continued line
! blank lines are comment lines
call date_and_time(values=values)
associate( &
! DATE
YR=>values(1), & ! The year
MO=>values(2), & ! The month
DY=>values(3), & ! The day of the month
! TIME
UTC=>values(4), & ! Time difference with UTC in minutes
HR=>values(5), & ! The hour of the day
MIN=>values(6), & ! The minutes of the hour
SEC=>values(7), & ! The seconds of the minute
MILLI=>values(8) ) ! The milliseconds of the second
write(*,'(*(g0))')YR,dash,MO,dash,DY,'T', &
& HR,colon,MIN,colon,SEC,dot,MILLI
end associate
string='no comment allowed &
&on the end of a continued string &
! keep going ...
& but comment lines are allowed between ' ! but can go on the end
! the next exclamation is part of a literal string, and so has
! nothing to do with comments
print *, 'Hello World! X=',x,'Y=',y
end program demo_comment
]]>
compiler_options
Source
<![CDATA[
program demo_compiler_version
use, intrinsic :: iso_fortran_env, only : compiler_version
use, intrinsic :: iso_fortran_env, only : compiler_options
implicit none
print '(4a)', &
'This file was compiled by ', &
compiler_version(), &
' using the options ', &
compiler_options()
end program demo_compiler_version
]]>
compiler_version
Source
<![CDATA[
program demo_compiler_version
use, intrinsic :: iso_fortran_env, only : compiler_version
use, intrinsic :: iso_fortran_env, only : compiler_options
implicit none
print '(4a)', &
'This file was compiled by ', &
compiler_version(), &
' using the options ', &
compiler_options()
end program demo_compiler_version
]]>
conjg
Source
<![CDATA[
program demo_conjg
use, intrinsic :: iso_fortran_env, only : real32, real64, real128
implicit none
complex :: z = (2.0, 3.0)
complex(kind=real64) :: dz = ( &
& 1.2345678901234567_real64, -1.2345678901234567_real64)
complex :: arr(3,3)
integer :: i
! basics
! notice the sine of the imaginary component changes
print *, z, conjg(z)
! any complex kind is supported. z is of default kind but
! dz is kind=real64.
print *, dz
dz = conjg(dz)
print *, dz
print *
! the function is elemental so it can take arrays
arr(1,:)=[(-1.0, 2.0),( 3.0, 4.0),( 5.0,-6.0)]
arr(2,:)=[( 7.0,-8.0),( 8.0, 9.0),( 9.0, 9.0)]
arr(3,:)=[( 1.0, 9.0),( 2.0, 0.0),(-3.0,-7.0)]
write(*,*)'original'
write(*,'(3("(",g8.2,",",g8.2,")",1x))')(arr(i,:),i=1,3)
arr = conjg(arr)
write(*,*)'conjugate'
write(*,'(3("(",g8.2,",",g8.2,")",1x))')(arr(i,:),i=1,3)
end program demo_conjg
]]>
continuation
Source
<![CDATA[
program demo_continuation
implicit none
integer :: point(3)
character(len=:),allocatable :: string
! one statement using continuation:
integer,save :: xx(3,5)= reshape([& ! define in row-column order
!-------------------------!
1, 2, 3, 4, 5, & ! row 1
10, 20, 30, 40, 50, & ! row 2
11, 22, 33, 44, 55 & ! row 3
!-------------------------!
],shape(xx),order=[2,1])
! print it in row-column order too
call print_matrix_int('xx array:',xx)
xx(3,5)= -1051
call print_matrix_int('xx array:',xx)
! So this is OK:
POINT=[& ! define a Point <X,Y,Z>
& 10, & ! the X component
& 20, & ! the Y component
& 30 ] ! the Z component
! because you can have comments after the ampersand when it is not
! a string.
! But this is not OK:
! STRING='& ! create a sentence
! & This& ! first word
! & is& ! second word
! & sentence& ! third word
! & a' ! fourth word (a comment here is OK)
!Because when continuing a string you cannot have a comment after the "&".
!
! This is OK:
STRING='&
! create a sentence
& This&
! first word
& is&
! second word
& sentence&
! third word
& a' ! fourth word (a comment here is OK)
! because comment LINES can go anywhere in Fortran source files
! Dusty corners
call splitting_a_token()
call longstring()
contains
subroutine splitting_a_token()
! Often denoted by "e" in honor of Euler,
! Napier's constant is the base of the natural logarithm system.
real(kind=kind(0.0d0)),parameter :: &
& Napier_constant = 2.71828182845904523d0
! without continuation
write(*,*)napier_constant
! splitting a token the & is required
write(*,*)napier_&
&constant
! the left-hand ampersand is required when splitting constants too,
! including characters strings
write(*,*)'Expecting &
&the value',2.71828182&
&845904523d0
!NOT ALLOWED <<<<<<
!write(*,*)napier_&
!constant
!>>>>>>>
! splitting a token is not recommended as it complicates identifying
! the use of a token name.
end subroutine splitting_a_token
Subroutine LongString()
! Long strings:
Character (len=200) :: string1, String2
character(len=:), allocatable :: a,b,c, big
string1 = "A very long string that won't fit on a single &
&line can be made through proper continuation."
! alternatives to continuation lines
string2 = "A very long string that won't fit on a single " // &
"line can be made through proper continuation " // &
"and concatenation of multiple strings."
print *, "string1=",string1
print *, "string2=",string2
! append multiple strings together to construct a long line
a=repeat('A',100)
b=repeat('B',100)
big=a//b
c=repeat('C',100)
big=a//c
big=big//"more at end"
print *, "big=",big
End Subroutine LongString
subroutine print_matrix_int(title,arr)
! bonus points -- print an integer array in RC order with bells on.
! ie. It calculates the width needed for the longest variable and
! puts a frame around the array
implicit none
character(len=*),intent(in) :: title
integer,intent(in) :: arr(:,:)
integer :: i
integer :: size_needed
character(len=:),allocatable :: biggest
write(*,*)trim(title)
biggest=' ' ! make buffer to write integer into
! find how many characters to use for integers
size_needed=ceiling(log10(real(maxval(abs(arr)))))+2
write(biggest,'(i0)')size_needed
! use this format to write a row
biggest='(" |",*(i'//trim(biggest)//':," |"))'
! print one row of array at a time
write(*,'(*(g0))')&
&' #',(repeat('-',size_needed),'-#',i=1,size(arr,dim=2))
do i=1,size(arr,dim=1)
write(*,fmt=biggest,advance='no')arr(i,:)
write(*,'(" |")')
enddo
write(*,'(*(g0))')&
&' #',(repeat('-',size_needed),'-#',i=1,size(arr,dim=2))
end subroutine print_matrix_int
end program demo_continuation
]]>
continue
Source
<![CDATA[
program demo_continue
! numbered targets should (almost?) always be a continue statement
! with a unique label for each looping structure
integer :: i,j
j=5
do 100 i=1,20
if(i.lt.5)goto 50
j=3
50 continue
write(*,*)'J=',j
100 continue
end program demo_continue
]]>
co_reduce
Source
<![CDATA[
program demo_co_reduce
implicit none
integer :: val
val = this_image()
call co_reduce(val, myprod, 1)
if (this_image() == 1) then
write(*,*) "Product value", val ! prints num_images() factorial
endif
contains
pure function myprod(a, b)
integer, value :: a, b
integer :: myprod
myprod = a * b
end function myprod
end program demo_co_reduce
]]>
cosd
Source
<![CDATA[
program demo_cosd
implicit none
character(len=*),parameter :: g2='(a,t20,g0)'
write(*,g2)'cosd(0.0)=',cosd(0.0)
write(*,g2)'cosd(180.0)=',cosd(180.0)
write(*,g2)'cosd(90.0d0)=',cosd(90.0d0)
write(*,g2)'cosd(360.0)=',cosd(360.0)
write(*,g2)'cosd(-360.0)=',cosd(-360.0)
write(*,g2)'cosd(-2000*180.0)=',cosd(-2000*180.0)
write(*,g2)'cosd(3000*180.0)=',cosd(3000*180.0)
end program demo_cosd
]]>
cos
Source
<![CDATA[
program demo_cos
implicit none
real,parameter :: PI=atan(1.0d0)*4.0d0
real :: val
character,parameter :: nl=NEW_LINE('A')
write(*,'(*(g0))',advance='no') &
'basics:', nl, &
' COS(0.0) = ', cos(0.0), nl, &
' COS(PI) = ', cos(PI), nl, &
' ', nl, &
'X may be any real value', nl, &
' COS(222*PI) = ', cos(222*PI), nl, &
' COS(-333*PI) = ', cos(-333*PI), nl, &
' ', nl, &
'note: probably not exactly zero ....', nl, &
' COS(PI/2.0)= ', cos(PI/2.0), nl, &
' EPSILON= ', epsilon(PI), nl, &
' ', nl, &
'COS() is elemental', nl, &
' COS([0.0,PI/4,PI/2,PI*3/4,PI]) = ', nl
write(*,'(*(1x,g0,1x))') COS([0.0,PI/4,PI/2,PI*3/4,PI])
write(*,'(*(g0))',advance='no') &
' ', nl, &
'Law of Cosines:', nl, &
' ', nl, &
'right triangle', nl, &
two_sides_and_degrees_between(3.0,4.0,90.0), nl, &
'equilateral', nl, &
two_sides_and_degrees_between(3.3,3.3,60.0), nl, &
' ', nl, &
'Dusty Corners:', nl, &
' ', nl, &
'If very large, representable numbers are far apart', nl, &
'so adding or subtracting a few radians can not even', nl, &
'change the value! Note the expected values here:', nl
val=0.0
call delta( val-2.0, val-1.0 )
write(*,'(a)') 'but look at the same call when the values are huge;'
val=huge(0.0)/1000
call delta( val-2.0, val-1.0 )
contains
subroutine delta(A,B)
real(kind=kind(0.0)),intent(in) :: a,b
print '(a,t30,g0)' , &
' A= ', A, &
' B= ', B, &
' B-A= ', B-A, &
' COS(A*PI)= ', cos(A*PI), &
' COS(B*PI)= ', cos(B*PI), &
' spacing(A)= ', spacing(A), &
' COS((B-A)*PI)= ', cos((B-A)*PI), &
' COS(B*PI)-COS(A*PI)= ', cos(B*PI)-cos(A*PI), &
repeat('=',40)
end subroutine delta
function two_sides_and_degrees_between(a,b,X) result(str)
real,intent(in) :: a,b,X
real :: c
real,parameter :: PI = atan(1.0d0) * 4.0d0
real,parameter :: degrees_to_radians = PI / 180.0
character,parameter :: nl=NEW_LINE('A')
character(len=:),allocatable :: str
! The law of cosines states that for a
! triangle with sides of length a, b, and c
! that if the angle X is formed by sides a and
! b that the length of the third side c is
!
c = sqrt( a**2 + b**2 - 2*a*b*cos(degrees_to_radians*X) )
allocate( character(len=132) :: str )
write(str,'(*(g0))')&
'For sides A=',a,', B=',b,' and X=',x,' degrees,',nl,'side C=',c
str=trim(str)
!
! \
! / \
! / Y \
! / \
! / \
! / \
! b / \ c
! / \
! / \
! / \
! / \
! / X Z \
! -------------------------
! a
end function two_sides_and_degrees_between
end program demo_cos
]]>
cosh
Source
<![CDATA[
program demo_cosh
use, intrinsic :: iso_fortran_env, only : real32, real64, real128
implicit none
real(kind=real64) :: x = 1.0_real64
write(*,*)'X=',x,'COSH(X=)',cosh(x)
end program demo_cosh
]]>
cospi
Source
<![CDATA[
program demo_cos
implicit none
character(len=*),parameter :: g2='(a,t21,*(g0,1x))'
write(*,g2) 'Basics:'
write(*,g2) 'COSpi(0)=', cospi(0.0d0)
write(*,g2) 'COSpi(1)=', cospi(1.0d0)
write(*,g2) 'COSpi(1/2)=', cospi(1.0d0/2.0d0)
write(*,g2) 'COSpi(2)=', cospi(2.0d0)
write(*,g2) 'COSpi(-2)=', cospi(-2.0d0)
write(*,g2) 'COSpi(-2000)=', cospi(-2000.0d0)
write(*,g2) 'COSpi(3000)=', cospi(3000.0d0)
write(*,g2) 'Elemental:'
write(*,g2) 'COSpi([0,1/4,-1/4])=',COSpi([0.0,0.25,-0.25])
end program demo_cos
]]>
co_sum
Source
<![CDATA[
program demo_co_sum
implicit none
integer :: val
val = this_image()
call co_sum(val, result_image=1)
if (this_image() == 1) then
! prints (n**2 + n)/2, with n = num_images()
write(*,*) "The sum is ", val
endif
end program demo_co_sum
]]>
count
Source
<![CDATA[
program demo_count
implicit none
character(len=*),parameter :: ints='(*(i2,1x))'
! two arrays and a mask all with the same shape
integer, dimension(2,3) :: a, b
logical, dimension(2,3) :: mymask
integer :: i
integer :: c(2,3,4)
print *,'the numeric arrays we will compare'
a = reshape( [ 1, 2, 3, 4, 5, 6 ], [ 2, 3 ])
b = reshape( [ 0, 7, 3, 4, 5, 8 ], [ 2, 3 ])
c = reshape( [( i,i=1,24)], [ 2, 3 ,4])
print '(3i3)', a(1,:)
print '(3i3)', a(2,:)
print *
print '(3i3)', b(1,:)
print '(3i3)', b(2,:)
!
! basic calls
print *, 'count a few basic things creating a mask from an expression'
print *, 'count a>b',count(a>b)
print *, 'count b<a',count(a<b)
print *, 'count b==a',count(a==b)
print *, 'check sum = ',count(a>b) + &
& count(a<b) + &
& count(a==b).eq.size(a)
!
! The common usage is just getting a count, but if you want
! to specify the DIM argument and get back reduced arrays
! of counts this is easier to visualize if we look at a mask.
print *, 'make a mask identifying unequal elements ...'
mymask = a.ne.b
print *, 'the mask generated from a.ne.b'
print '(3l3)', mymask(1,:)
print '(3l3)', mymask(2,:)
!
print *,'count total and along rows and columns ...'
!
print '(a)', 'number of elements not equal'
print '(a)', '(ie. total true elements in the mask)'
print '(3i3)', count(mymask)
!
print '(a)', 'count of elements not equal in each column'
print '(a)', '(ie. total true elements in each column)'
print '(3i3)', count(mymask, dim=1)
!
print '(a)', 'count of elements not equal in each row'
print '(a)', '(ie. total true elements in each row)'
print '(3i3)', count(mymask, dim=2)
!
! working with rank=3 ...
print *, 'lets try this with c(2,3,4)'
print *,' taking the result of the modulo '
print *,' z=1 z=2 z=3 z=4 '
print *,' 1 3 0 || 2 4 1 || 3 0 2 || 4 1 3 |'
print *,' 2 4 1 || 3 0 2 || 4 1 3 || 0 2 4 |'
print *,' '
print *,' would result in the mask .. '
print *,' F F T || F F F || F T F || F F F |'
print *,' F F F || F T F || F F F || T F F |'
print *,' '
print *,' the total number of .true.values is'
print ints, count(modulo(c,5).eq.0)
call printi('counting up along a row and removing rows',&
count(modulo(c,5).eq.0,dim=1))
call printi('counting up along a column and removing columns',&
count(modulo(c,5).eq.0,dim=2))
call printi('counting up along a depth and removing depths',&
count(modulo(c,5).eq.0,dim=3))
!
contains
!
! CONVENIENCE ROUTINE FOR PRINTING SMALL INTEGER MATRICES
subroutine printi(title,arr)
implicit none
!
!@(#) print small 2d integer arrays in row-column format
!
character(len=*),parameter :: all='(*(g0,1x))' ! a handy format
character(len=*),intent(in) :: title
integer,intent(in) :: arr(:,:)
integer :: i
character(len=:),allocatable :: biggest
!
print all
print all, trim(title),':(',shape(arr),')' ! print title
biggest=' ' ! make buffer to write integer into
! find how many characters to use for integers
write(biggest,'(i0)')ceiling(log10(max(1.0,real(maxval(abs(arr))))))+2
! use this format to write a row
biggest='(" > [",*(i'//trim(biggest)//':,","))'
! print one row of array at a time
do i=1,size(arr,dim=1)
write(*,fmt=biggest,advance='no')arr(i,:)
write(*,'(" ]")')
enddo
!
end subroutine printi
end program demo_count
]]>
cpu_time
Source
<![CDATA[
program demo_cpu_time
use, intrinsic :: iso_fortran_env, only : real32,real64,real128
implicit none
real :: start, finish
real(kind=real64) :: startd, finishd
!
call cpu_time(start)
call cpu_time(startd)
! put code to time here
call cpu_time(finish)
call cpu_time(finishd)
!
! writes processor time taken by the piece of code.
! the accuracy of the clock and whether it includes system time
! as well as user time is processor dependent. Accuracy up to
! milliseconds is common but not guaranteed, and may be much
! higher or lower
print '("Processor Time = ",f6.3," seconds.")',finish-start
! see your specific compiler documentation for how to measure
! parallel jobs and for the precision of the time returned
print '("Processor Time = ",g0," seconds.")',finish-start
print '("Processor Time = ",g0," seconds.")',finishd-startd
end program demo_cpu_time
]]>
cshift
Source
<![CDATA[
program demo_cshift
implicit none
integer, dimension(5) :: i1
integer, dimension(3,4) :: a, b
!basics
i1=[10,20,30,40,50]
print *,'start with:'
print '(1x,5i3)', i1
print *,'shift -2'
print '(1x,5i3)', cshift(i1,-2)
print *,'shift +2'
print '(1x,5i3)', cshift(i1,+2)
print *,'start with a matrix'
a = reshape( [ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12 ], [ 3, 4 ])
print '(4i3)', a(1,:)
print '(4i3)', a(2,:)
print '(4i3)', a(3,:)
print *,'matrix shifted along rows, each by its own amount [-1,0,1]'
b = cshift(a, SHIFT=[1, 0, -1], DIM=2)
print *
print '(4i3)', b(1,:)
print '(4i3)', b(2,:)
print '(4i3)', b(3,:)
end program demo_cshift
]]>
c_sizeof
Source
<![CDATA[
program demo_c_sizeof
use iso_c_binding
implicit none
real(c_float) :: r, s(5)
print *, (c_sizeof(s)/c_sizeof(r) == 5)
end program demo_c_sizeof
]]>
date_and_time
Source
<![CDATA[
program demo_date_and_time
implicit none
character(len=8) :: date
character(len=10) :: time
character(len=5) :: zone
integer, dimension(8) :: values
call date_and_time(date, time, zone, values)
! using keyword arguments
call date_and_time(DATE=date, TIME=time, ZONE=zone)
print '(*(g0))','DATE="',date,'" TIME="',time,'" ZONE="',zone,'"'
call date_and_time(VALUES=values)
write (*, '(i5,a)') &
& values(1), ' - The year', &
& values(2), ' - The month', &
& values(3), ' - The day of the month', &
& values(4), ' - Time difference with UTC in minutes', &
& values(5), ' - The hour of the day', &
& values(6), ' - The minutes of the hour', &
& values(7), ' - The seconds of the minute', &
& values(8), ' - The milliseconds of the second'
write (*, '(a)') iso_8601()
contains
function iso_8601()
! return date using ISO-8601 format at a resolution of seconds
character(len=8) :: dt
character(len=10) :: tm
character(len=5) :: zone
character(len=25) :: iso_8601
call date_and_time(dt, tm, zone)
ISO_8601 = dt(1:4)//'-'//dt(5:6)//'-'//dt(7:8) &
& //'T'// &
& tm(1:2)//':'//tm(3:4)//':'//tm(5:6) &
& //zone(1:3)//':'//zone(4:5)
end function iso_8601
end program demo_date_and_time
]]>
dble
Source
<![CDATA[
program demo_dble
implicit none
real:: x = 2.18
integer :: i = 5
complex :: z = (2.3,1.14)
print *, dble(x), dble(i), dble(z)
end program demo_dble
]]>
deallocate
Source
<![CDATA[
]]>
digits
Source
<![CDATA[
program demo_digits
implicit none
character(len=*),parameter :: all='(*(g0:,1x))'
integer :: i = 12345
real :: x = 3.143
doubleprecision :: y = 2.33d0
print all, 'default integer: ', digits(i)
print all, 'default real: ', digits(x)
print all, 'default doubleprecision:', digits(y)
end program demo_digits
]]>
dim
Source
<![CDATA[
program demo_dim
use, intrinsic :: iso_fortran_env, only : real64
implicit none
integer :: i
real(kind=real64) :: x
! basic usage
i = dim(4, 15)
x = dim(4.321_real64, 1.111_real64)
print *, i
print *, x
! elemental
print *, dim([1,2,3],2)
print *, dim([1,2,3],[3,2,1])
print *, dim(-10,[0,-10,-20])
end program demo_dim
]]>
dot_product
Source
<![CDATA[
program demo_dot_prod
implicit none
integer, dimension(3) :: a, b
a = [ 1, 2, 3 ]
b = [ 4, 5, 6 ]
print '(3i3)', a
print *
print '(3i3)', b
print *
print *, dot_product(a,b)
end program demo_dot_prod
]]>
dprod
Source
<![CDATA[
program demo_dprod
implicit none
integer,parameter :: dp=kind(0.0d0)
real :: x = 5.2
real :: y = 2.3
doubleprecision :: xx
real(kind=dp) :: dd
print *,'algebraically 5.2 x 2.3 is exactly 11.96'
print *,'as floating point values results may differ slightly:'
! basic usage
dd = dprod(x,y)
print *, 'compare dprod(xy)=',dd, &
& 'to x*y=',x*y, &
& 'to dble(x)*dble(y)=',dble(x)*dble(y)
print *,'test if an expected result is produced'
xx=-6.0d0
write(*,*)DPROD(-3.0, 2.0),xx
write(*,*)merge('PASSED','FAILED',DPROD(-3.0, 2.0) == xx)
print *,'elemental'
print *, dprod( [2.3,3.4,4.5], 10.0 )
print *, dprod( [2.3,3.4,4.5], [9.8,7.6,5.4] )
end program demo_dprod
]]>
dshiftl
Source
<![CDATA[
program demo_dshiftl
use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64
implicit none
integer(kind=int32) :: i, j
integer :: shift
! basic usage
write(*,*) dshiftl (1, 2**30, 2) ! int32 values on little-endian => 5
! print some simple calls as binary to better visual the results
i=-1
j=0
shift=5
call printit()
! the leftmost SHIFT bits of J are copied to the rightmost result bits
j=int(b"11111000000000000000000000000000")
! and the other bits are the rightmost bits of I
i=int(b"00000000000000000000000000000000")
call printit()
j=int(b"11111000000000000000000000000000")
i=int(b"00000111111111111111111111111111")
! result should be all 1s
call printit()
contains
subroutine printit()
! print i,j,shift and then i,j, and the result as binary values
write(*,'(*(g0))')'I=',i,' J=',j,' SHIFT=',shift
write(*,'(b32.32)') i,j, dshiftl (i, j, shift)
end subroutine printit
end program demo_dshiftl
]]>
dshiftr
Source
<![CDATA[
program demo_dshiftr
use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64
implicit none
integer(kind=int32) :: i, j
integer :: shift
! basic usage
write(*,*) dshiftr (1, 2**30, 2)
! print some calls as binary to better visualize the results
i=-1
j=0
shift=5
! print values
write(*,'(*(g0))')'I=',i,' J=',j,' SHIFT=',shift
write(*,'(b32.32)') i,j, dshiftr (i, j, shift)
! visualizing a "combined right shift" ...
i=int(b"00000000000000000000000000011111")
j=int(b"11111111111111111111111111100000")
! appended together ( i//j )
! 0000000000000000000000000001111111111111111111111111111111100000
! shifted right SHIFT values dropping off shifted values
! 00000000000000000000000000011111111111111111111111111111111
! keep enough rightmost bits to fill the kind
! 11111111111111111111111111111111
! so the result should be all 1s bits ...
write(*,'(*(g0))')'I=',i,' J=',j,' SHIFT=',shift
write(*,'(b32.32)') i,j, dshiftr (i, j, shift)
end program demo_dshiftr
]]>
endfile
Source
<![CDATA[
program demo_endfile
implicit none
integer :: lun, i, j, iostat
integer,parameter:: isz=10
!
! create a little scratch file
open(newunit=lun,file='_scr.txt', &
& form='formatted', &
& action='readwrite')
write(lun,'(i0)')(100+i,i=1,isz)
!
! write end of file after reading half of file
rewind(lun)
write(*,*)'rewind and read',isz/2,'lines'
read(lun,*)(j,i=1,isz/2)
endfile lun ! will truncate line at current position
!
! NOTE: backspace before writing any addition lines
! once an ENDFILE(7f) statement is executed
! backspace(lun)
!
! rewind and echo remaining file
rewind(lun)
j=0
do i=1,huge(0)-1
read(lun,*,iostat=iostat)j
if(iostat.ne.0)exit
write(*,*)i,j
enddo
write(*,*)'number of lines in file was ',isz,', is now ',i-1
close(unit=lun,status='delete')
end program demo_endfile
]]>
eoshift
Source
<![CDATA[
program demo_eoshift
implicit none
integer, dimension(3,3) :: a
integer :: i
write(*,*)'original'
a = reshape( [ 1, 2, 3, 4, 5, 6, 7, 8, 9 ], [ 3, 3 ])
call printi(a)
write(*,*)'shift each row differently'
a = eoshift(a, SHIFT=[1, 2, -2], BOUNDARY=-5, DIM=2)
call printi(a)
write(*,*)'shift each column differently'
a = eoshift(a, SHIFT=[1, 2, -2], BOUNDARY=-5, DIM=1)
call printi(a)
write(*,*)'original'
call printi(reshape([(i,i=1,12)],[3,4]))
write(*,'(*(g0))')'shift=+2,dim=1'
call printi(eoshift(reshape([(i,i=1,12)],[3,4]),+2,dim=1))
write(*,'(*(g0))')'shift=+2,dim=2'
call printi(eoshift(reshape([(i,i=1,12)],[3,4]),+2,dim=2))
write(*,'(*(g0))')'shift=-2,dim=1'
call printi(eoshift(reshape([(i,i=1,12)],[3,4]),-2,dim=1))
write(*,'(*(g0))')'shift=-2,dim=2'
call printi(eoshift(reshape([(i,i=1,12)],[3,4]),-2,dim=2))
contains
subroutine printi(arr)
!@(#) print small 2d integer arrays in row-column format
integer,intent(in) :: arr(:,:)
integer :: i
character(len=40) :: biggest
write(biggest,'(*(g0))')'(1x,*(i', &
& ceiling(log10(max(1.0,real(maxval(abs(arr))))))+2, &
& ':,","))'
do i=1,size(arr,dim=1)
write(*,fmt=biggest)arr(i,:)
enddo
end subroutine printi
end program demo_eoshift
]]>
epsilon
Source
<![CDATA[
program demo_epsilon
use,intrinsic :: iso_fortran_env, only : dp=>real64,sp=>real32
implicit none
real(kind=sp) :: x = 3.143
real(kind=dp) :: y = 2.33d0
! so if x is of type real32, epsilon(x) has the value 2**-23
print *, epsilon(x)
! note just the type and kind of x matter, not the value
print *, epsilon(huge(x))
print *, epsilon(tiny(x))
! the value changes with the kind of the real value though
print *, epsilon(y)
! adding and subtracting epsilon(x) changes x
write(*,*)x == x + epsilon(x)
write(*,*)x == x - epsilon(x)
! these next two comparisons will be .true. !
write(*,*)x == x + epsilon(x) * 0.999999
write(*,*)x == x - epsilon(x) * 0.999999
! you can calculate epsilon(1.0d0)
write(*,*)my_dp_eps()
contains
function my_dp_eps()
! calculate the epsilon value of a machine the hard way
real(kind=dp) :: t
real(kind=dp) :: my_dp_eps
! starting with a value of 1, keep dividing the value
! by 2 until no change is detected. Note that with
! infinite precision this would be an infinite loop,
! but floating point values in Fortran have a defined
! and limited precision.
my_dp_eps = 1.0d0
SET_ST: do
my_dp_eps = my_dp_eps/2.0d0
t = 1.0d0 + my_dp_eps
if (t <= 1.0d0) exit
enddo SET_ST
my_dp_eps = 2.0d0*my_dp_eps
end function my_dp_eps
end program demo_epsilon
]]>
erfc
Source
<![CDATA[
program demo_erfc
use, intrinsic :: iso_fortran_env, only : real32, real64, real128
implicit none
real(kind=real64) :: x = 0.17_real64
write(*,'(*(g0))')'X=',x, ' ERFC(X)=',erfc(x)
write(*,'(*(g0))')'equivalently 1-ERF(X)=',1-erf(x)
end program demo_erfc
]]>
erfc_scaled
Source
<![CDATA[
program demo_erfc_scaled
implicit none
real(kind(0.0d0)) :: x = 0.17d0
x = erfc_scaled(x)
print *, x
end program demo_erfc_scaled
]]>
erf
Source
<![CDATA[
program demo_erf
use, intrinsic :: iso_fortran_env, only : real32, real64, real128
implicit none
real(kind=real64) :: x = 0.17_real64
write(*,*)x, erf(x)
end program demo_erf
]]>
event_query
Source
<![CDATA[
program demo_event_query
use iso_fortran_env
implicit none
type(event_type) :: event_value_has_been_set[*]
integer :: cnt
if (this_image() == 1) then
call event_query(event_value_has_been_set, cnt)
if (cnt > 0) write(*,*) "Value has been set"
elseif (this_image() == 2) then
event post(event_value_has_been_set[1])
endif
end program demo_event_query
]]>
execute_command_line
Source
<![CDATA[
program demo_execute_command_line
implicit none
integer :: exitstat, cmdstat
character(len=256) :: cmdmsg
call execute_command_line( &
& command = "external_prog.exe", &
& exitstat = exitstat, &
& cmdstat = cmdstat, &
& cmdmsg = cmdmsg)
print *, "Exit status of external_prog.exe was ", exitstat
if(cmdstat.ne.0)then
print *, '<ERROR>'//trim(cmdmsg)
endif
! if asynchronous exitstat and cmdstat may not be relied on
call execute_command_line("reindex_files.exe", wait=.false.)
print *, "Now hopefully reindexing files in the background"
if(cmd('dir'))then
write(*,*)'OK'
else
stop 4
endif
! might short-circuit or not if a command fails
if(all(cmd([character(len=80) :: 'date','time myprg','date'])))then
write(*,*)'good time'
else
write(*,*)'bad time'
endif
stop 'end of program'
contains
elemental impure function cmd(command)
! a functional interface for calling system commands
use, intrinsic :: iso_fortran_env, only : &
& stderr=>ERROR_UNIT, stdout=>OUTPUT_UNIT
character(len=*),intent(in) :: command
logical :: cmd
logical :: wait
integer :: exitstat
integer :: cmdstat
character(len=256) :: cmdmsg
wait=.false.
exitstat=0
cmdstat=0
call execute_command_line(command=command,wait=wait, &
& exitstat=exitstat,cmdstat=cmdstat,cmdmsg=cmdmsg)
if(cmdstat.ne.0)then
flush(stdout)
write(stderr,'(a)')trim(cmdmsg)
flush(stderr)
endif
if(exitstat.ne.0)then
flush(stdout)
write(stderr,'(*(g0))')'exitstat=',exitstat,':',trim(command)
flush(stderr)
endif
cmd=merge(.true.,.false.,exitstat==0)
end function cmd
end program demo_execute_command_line
]]>
exit
Source
<![CDATA[
program demo_exit
implicit none
integer,parameter :: arbitrary_size=10
integer :: i, j, k, iarr(arbitrary_size)
integer :: iostat, lun
logical :: ok
character(len=80) :: line
character(len=*),parameter :: gen='(*(g0:,1x))'
!
! the basics
!
! Note we will use the function irand(3f) contained in
! the end of the code below to generate random whole numbers
!
!----------------------
! EXIT an infinite loop
!----------------------
i=0
do
i=i+1
! we will test on a random value to simulate an actual criteria
! to meet that indicates the loop should be terminated
if(irand(-100,100).gt.95)exit
enddo
print gen, 'escaped infinite loop after only ',i,'tries'
! a related common use is to read a file of unknown size
! till an error or end-of-file, although READ does have
! the options ERR=numeric-label and EOF=numeric-label.
! INFINITE: do
! read(*,'(a)',iostat=iostat) line
! if(iostat.ne.0)exit INFINITE
! enddo INFINITE
! Some argue that an infinite loop is never a good idea.
! A common practice is to avoid even the possibility of an
! infinite loop by putting a cap on the number of iterations
! that should "never" occur, and then error processing
! if the unexpected number of loops is inadvertently reached.
! This technique can let your code gracefully handle being used with
! problems bigger than it was intended for, or not loop infinitely
! if some unexpected or incorrect input or condition is encountered.
! It might make it stop unintentionally as well.
!
! run a loop but quit as soon as 200 random integers are odd
j=0
! fun facts: What are the odds of not getting 200 in 10000?
do i=1, 10000
k=irand(0,99)
if((k+1)/2 /= k/2)j=j+1 ! cheap integer math trick to tell if odd
if(j .ge. 200) exit
enddo
if(j.lt.200) then
print gen,'Oh no! Not enough odd samples. only found',j
print gen,'That is REALLY unlikely.'
stop '<ERROR> unexpectedly low number of odd values'
else
print gen,'only did I=',i,'passes to get 200 odd samples'
endif
! ---------------------------
! how to EXIT nested do-loops
! ---------------------------
! EXIT with no name only exits an innermost loop
! so in the following k will be 3, as all passes of the
! outer loop still occur
k=0
do i=1,3
do j=1,5
exit
enddo
k=k+1
enddo
! at the end of a completed loop the counter is end_limit+step so
! you can tell if you exhausted the do loop or exited early:
print gen,'I=',i,'so ',&
& merge('completed','exited ',i.gt.3),' outer loop'
print gen,'J=',j,'so ',&
& merge('completed','exited ',j.gt.5),' inner loop'
print gen,'K=',k
! COMMENTARY:
! A labeled exit is less prone to error so generally worth the
! additional verbosity even when just exiting an inner loop.
! Without a label an EXIT is somewhat like saying "EXIT SOMEWHERE".
! It is simple to EXIT nested loops from an inner loop.
! Just use a construct name. Lets start with the nested loop above
! that only repeatedly exited the inner loop and label the outer
! loop "OUTER". Now our exit can explicitly name what loop it wants
! to exit ...
k=0
OUTER: do i=1,3
do j=1,5
exit OUTER
enddo
k=k+1
enddo OUTER
if(i==1.and.j==1.and.k==0)then
print gen,'exited nested loops successfully as expected'
else
print gen,'something went wrong, i=',i,'j=',j,'k=',k
endif
! ---------------------------------------
! exits from non-DO-loop block constructs
! ---------------------------------------
! REMEMBER: non-DO-loop exits are always named
!----------------------------------------------------------------------
! EXIT a BLOCK statement surrounding a loop to avoid the nefarious GOTO
!----------------------------------------------------------------------
! look for a 5 in an array that should always have it
iarr=[(i,i=1,size(iarr))] ! fill array with 1 to N
LOOKFOR: block
do i=1,size(iarr)
! when you find what you are looking for use an EXIT instead
! of a GOTO , which follows much more restricted rules on
! on where you can land, preventing the threat of spaghetti code
if(iarr(i).eq.5) exit LOOKFOR
enddo
write(*,*)'should not get here. iarr=',iarr
stop '<INTERNAL ERROR> should never get here! is array too small?'
endblock LOOKFOR
print gen,'Good Found 5 at position I=',i,'so exited BLOCK construct'
!--------------
! Dusty corners
!--------------
! a block contained completely within a DO CONCURRENT can
! be exited even though the DO CONCURRENT itself or an outer block
! cannot be terminated from within a DO CONCURRENT
do concurrent (i = 1:10)
INCC: block
real :: t
t = 0.0
if (t == 0.0) exit INCC
t= t+1.0
end block INCC
end do
! The following example shows illegal EXIT statements in DO CONCURRENT
! and CRITICAL:
! can t EXIT DO CONCURRENT or outer construct of a DO CONCURRENT
!x!N=4
!x!LOOP_1 : DO CONCURRENT (I = 1:N)
!x! N = N + 1
!x! IF (N > I) EXIT LOOP_1
!x!END DO LOOP_1
!x!LOOP_2 : DO I = 1, 15
!x! CRITICAL
!x! N = N + 1
!x! IF (N > I) EXIT LOOP_2 ! cannot EXIT outer construct from inside
!x! END CRITICAL ! CHANGE TEAM, DO CONCURRENT, or CRITICAL
!x!END DO LOOP_2
! this would fail
! because the same construct name was used in the same scope:
!x! LEVELA block:
!x! exit LEVELA
!x! endblock LEVELA
!x!
!x! LEVELA block:
!x! exit LEVELA
!x! endblock LEVELA
contains
! choose a value from range of integers inclusive randomly
function irand(first,last)
integer, allocatable :: seed(:)
integer,intent(in) :: first,last
real :: rand_val
integer :: irand
call random_number(rand_val)
irand = first + floor((last+1-first)*rand_val)
end function irand
end program demo_exit
]]>
exp
Source
<![CDATA[
program demo_exp
implicit none
integer,parameter :: dp=kind(0.0d0)
real :: x, re, im
complex :: cx
real :: r_array(3), r_array_result(3)
complex :: c_array(2), c_array_result(2)
integer :: i
x = 1.0
write(*,*)"Euler's constant is approximately",exp(x)
!! complex values
! given
re=3.0
im=4.0
cx=cmplx(re,im)
! complex results from complex arguments are Related to Euler's formula
write(*,*)'given the complex value ',cx
write(*,*)'exp(x) is',exp(cx)
write(*,*)'is the same as',exp(re)*cmplx(cos(im),sin(im),kind=kind(cx))
! exp(3) is the inverse function of log(3) so
! the real component of the input must be less than or equal to
write(*,*)'maximum real component',log(huge(0.0))
! or for double precision
write(*,*)'maximum doubleprecision component',log(huge(0.0d0))
! but since the imaginary component is passed to the cos(3) and sin(3)
! functions the imaginary component can be any real value
! Real array example
r_array = [0.0, 1.0, -1.0]
r_array_result = exp(r_array)
do i = 1, size(r_array)
write(*, '(A, I0, A, F15.10)') "exp(r_array(", i, ")) = ", r_array_result(i)
enddo
! Complex array example
c_array = [cmplx(0.0, 0.0, kind=dp), cmplx(1.0, 1.0, kind=dp)]
c_array_result = exp(c_array)
do i = 1, size(c_array)
write(*, '(A, I0, A, F15.10, A, F15.10, A)') "exp(c_array(", i, ")) = (", &
real(c_array_result(i)), ", ", aimag(c_array_result(i)), ")"
enddo
end program demo_exp
]]>
exponent
Source
<![CDATA[
program demo_exponent
implicit none
real :: x = 1.0
integer :: i
i = exponent(x)
print *, i
print *, exponent(0.0)
print *, exponent([10.0,100.0,1000.0,-10000.0])
! beware of overflow, it may occur silently
!print *, 2**[10.0,100.0,1000.0,-10000.0]
print *, exponent(huge(0.0))
print *, exponent(tiny(0.0))
end program demo_exponent
]]>
extends_type_of
Source
<![CDATA[
! program demo_extends_type_of
module M_demo_extends_type_of
implicit none
private
type nothing
end type nothing
type, extends(nothing) :: dot
real :: x=0
real :: y=0
end type dot
type, extends(dot) :: point
real :: z=0
end type point
type something_else
end type something_else
public :: nothing
public :: dot
public :: point
public :: something_else
end module M_demo_extends_type_of
program demo_extends_type_of
use M_demo_extends_type_of, only : nothing, dot, point, something_else
implicit none
type(nothing) :: grandpa
type(dot) :: dad
type(point) :: me
type(something_else) :: alien
write(*,*)'these should all be true'
write(*,*)extends_type_of(me,grandpa),'I am descended from Grandpa'
write(*,*)extends_type_of(dad,grandpa),'Dad is descended from Grandpa'
write(*,*)extends_type_of(me,dad),'Dad is my ancestor'
write(*,*)'is an object an extension of itself?'
write(*,*)extends_type_of(grandpa,grandpa) ,'self-propagating!'
write(*,*)extends_type_of(dad,dad) ,'clone!'
write(*,*)' you did not father your grandfather'
write(*,*)extends_type_of(grandpa,dad),'no paradox here'
write(*,*)extends_type_of(dad,me),'no paradox here'
write(*,*)extends_type_of(grandpa,me),'no relation whatsoever'
write(*,*)extends_type_of(grandpa,alien),'no relation'
write(*,*)extends_type_of(me,alien),'not what everyone thinks'
call pointers()
contains
subroutine pointers()
! Given the declarations and assignments
type t1
real c
end type
type, extends(t1) :: t2
end type
class(t1), pointer :: p, q
allocate (p)
allocate (t2 :: q)
! the result of EXTENDS_TYPE_OF (P, Q) will be false, and the result
! of EXTENDS_TYPE_OF (Q, P) will be true.
write(*,*)'(P,Q)',extends_type_of(p,q),"mind your P's and Q's"
write(*,*)'(Q,P)',extends_type_of(q,p)
end subroutine pointers
end program demo_extends_type_of
]]>
findloc
Source
<![CDATA[
program demo_findloc
logical,parameter :: T=.true., F=.false.
integer,allocatable :: ibox(:,:)
logical,allocatable :: mask(:,:)
! basics
! the first element matching the value is returned AS AN ARRAY
call printi('== 6',findloc ([2, 6, 4, 6], value = 6))
call printi('== 6',findloc ([2, 6, 4, 6], value = 6,back=.true.))
! the first element matching the value is returned AS A SCALAR
call printi('== 6',findloc ([2, 6, 4, 6], value = 6,dim=1))
call printi('== 6',findloc ([2, 6, 4, 6], value = 6,back=.true.,dim=1))
ibox=reshape([ 0,-5, 7, 7, &
3, 4, -1, 2, &
1, 5, 6, 7] ,shape=[3,4],order=[2,1])
mask=reshape([ T, T, F, T, &
T, T, F, T, &
T, T, F, T] ,shape=[3,4],order=[2,1])
call printi('array is', ibox )
call printl('mask is', mask )
print *, 'so for == 7 and back=.false.'
call printi('so for == 7 the address of the element is', &
& findloc (ibox, 7, mask = mask) )
print *, 'so for == 7 and back=.true.'
call printi('so for == 7 the address of the element is', &
& findloc (ibox, 7, mask = mask, back=.true.) )
print *,'This is independent of declared lower bounds for the array'
print *, ' using dim=N'
ibox=reshape([ 1, 2, -9, &
2, 2, 6 ] ,shape=[2,3],order=[2,1])
call printi('array is', ibox )
! has the value [2, 1, 0] and
call printi('',findloc (ibox, value = 2, dim = 1) )
! has the value [2, 1].
call printi('',findloc (ibox, value = 2, dim = 2) )
contains
! GENERIC ROUTINES TO PRINT MATRICES
subroutine printl(title,a)
implicit none
!@(#) print small 2d logical scalar, vector, matrix in row-column format
character(len=*),intent(in) :: title
logical,intent(in) :: a(..)
character(len=*),parameter :: row='(" > [ ",*(l1:,","))'
character(len=*),parameter :: all='(" ",*(g0,1x))'
logical,allocatable :: b(:,:)
integer :: i
write(*,all,advance='no')trim(title)
! copy everything to a matrix to keep code simple
select rank(a)
rank (0); write(*,'(a)')' (a scalar)'; b=reshape([a],[1,1])
rank (1); write(*,'(a)')' (a vector)'; b=reshape(a,[size(a),1])
rank (2); write(*,'(a)')' (a matrix)'; b=a
rank default; stop '*printl* unexpected rank'
end select
do i=1,size(b,dim=1)
write(*,fmt=row,advance='no')b(i,:)
write(*,'(" ]")')
enddo
write(*,all) '>shape=',shape(a),',rank=',rank(a),',size=',size(a)
write(*,*)
end subroutine printl
subroutine printi(title,a)
implicit none
!@(#) print small 2d integer scalar, vector, matrix in row-column format
character(len=*),intent(in) :: title
integer,intent(in) :: a(..)
character(len=*),parameter :: all='(" ",*(g0,1x))'
character(len=20) :: row
integer,allocatable :: b(:,:)
integer :: i
write(*,all,advance='no')trim(title)
! copy everything to a matrix to keep code simple
select rank(a)
rank (0); write(*,'(a)')' (a scalar)'; b=reshape([a],[1,1])
rank (1); write(*,'(a)')' (a vector)'; b=reshape(a,[size(a),1])
rank (2); write(*,'(a)')' (a matrix)'; b=a
rank default; stop '*printi* unexpected rank'
end select
! find how many characters to use for integers
write(row,'(i0)')ceiling(log10(max(1.0,real(maxval(abs(b))))))+2
! use this format to write a row
row='(" > [",*(i'//trim(row)//':,","))'
do i=1,size(b,dim=1)
write(*,fmt=row,advance='no')b(i,:)
write(*,'(" ]")')
enddo
write(*,all) '>shape=',shape(a),',rank=',rank(a),',size=',size(a)
write(*,*)
end subroutine printi
end program demo_findloc
]]>
floor
Source
<![CDATA[
program demo_floor
implicit none
real :: x = 63.29
real :: y = -63.59
print *, x, floor(x)
print *, y, floor(y)
! elemental
print *,floor([ &
& -2.7, -2.5, -2.2, -2.0, -1.5, -1.0, -0.5, &
& 0.0, &
& +0.5, +1.0, +1.5, +2.0, +2.2, +2.5, +2.7 ])
! note even a small deviation from the whole number changes the result
print *, [2.0,2.0-epsilon(0.0),2.0-2*epsilon(0.0)]
print *,floor([2.0,2.0-epsilon(0.0),2.0-2*epsilon(0.0)])
! A=Nan, Infinity or huge(0_KIND)-1 < A > huge(0_KIND) is undefined
end program demo_floor
]]>
flush
Source
<![CDATA[
program demo_flush
use, intrinsic :: iso_fortran_env, only : &
& stderr=>ERROR_UNIT, &
& stdin=>INPUT_UNIT, &
& stdout=>OUTPUT_UNIT
implicit none
integer :: iostat
character(len=255) :: iomsg
flush (stderr, iostat=iostat, iomsg=iomsg)
if(iostat.ne.0)then
write(*,*)'ERROR:'//trim(iomsg)
error stop 1
endif
flush (stdout, err = 999 )
stop
999 continue
stop 10
end program demo_flush
]]>
fraction
Source
<![CDATA[
program demo_fraction
implicit none
real :: x
x = 178.1387e-4
print *, fraction(x), x * real(radix(x))**(-exponent(x))
x = 10.0
print *, fraction(x)
print *, fraction(x) * 2**4
end program demo_fraction
]]>
gamma
Source
<![CDATA[
program demo_gamma
use, intrinsic :: iso_fortran_env, only : wp=>real64, int64
implicit none
real :: x, xa(4)
integer :: i, j
! basic usage
x = gamma(1.0)
write(*,*)'gamma(1.0)=',x
! elemental
xa=gamma([1.0,2.0,3.0,4.0])
write(*,*)xa
write(*,*)
! gamma() is related to the factorial function
do i = 1, 171
! check value is not too big for default integer type
if (factorial(i) <= huge(0)) then
write(*,*) i, nint(factorial(i)), 'integer'
elseif (factorial(i) <= huge(0_int64)) then
write(*,*) i, nint(factorial(i),kind=int64),'integer(kind=int64)'
else
write(*,*) i, factorial(i) , 'user factorial function'
write(*,*) i, product([(real(j, kind=wp), j=1, i)]), 'product'
write(*,*) i, gamma(real(i + 1, kind=wp)), 'gamma directly'
endif
enddo
contains
function factorial(i) result(f)
! GAMMA(X) computes Gamma of X. For positive whole number values of N the
! Gamma function can be used to calculate factorials, as (N-1)! ==
! GAMMA(REAL(N)). That is
!
! n! == gamma(real(n+1))
!
integer, intent(in) :: i
real(kind=wp) :: f
if (i <= 0) then
write(*,'(*(g0))') '<ERROR> gamma(3) function value ', i, ' <= 0'
stop '<STOP> bad value in gamma function'
endif
f = anint(gamma(real(i + 1,kind=wp)))
end function factorial
end program demo_gamma
]]>
get_command_argument
Source
<![CDATA[
program demo_get_command_argument
implicit none
integer :: count, i, istat
character(len=:),allocatable :: arg
! command name
arg=get_arg(0,istat)
if (istat == 0) then
print *, "The program's name is " // trim (arg)
else
print *, "Could not get the program's name " // trim (arg)
endif
! get number of arguments
count = command_argument_count()
write(*,*)'The number of arguments is ',count
! show argument values
do i=1,count
arg=get_arg(i,istat)
! show the results
write (*,'(i3.3,1x,i0.5,1x,i0.5,1x,"[",a,"]")') &
& i,istat,len(arg),arg
enddo
contains
function get_arg(n,status) result(arg)
integer,intent(in) :: n
integer,intent(out),optional :: status
integer :: argument_length, istat
character(len=:),allocatable :: arg
!
! allocate string big enough to hold command line argument
!
call get_command_argument( number=n, length=argument_length )
if(allocated(arg))deallocate( arg )
allocate(character(len=argument_length) :: arg )
call get_command_argument(n, arg, status=istat )
if(present(status)) status=istat
end function get_arg
end program demo_get_command_argument
]]>
get_command
Source
<![CDATA[
program demo_get_command
implicit none
integer :: command_line_length
character(len=:),allocatable :: command_line
! get command line length
call get_command(length=command_line_length)
! allocate string big enough to hold command line
allocate(character(len=command_line_length) :: command_line)
! get command line as a string
call get_command(command=command_line)
! trim leading spaces just in case
command_line=adjustl(command_line)
write(*,'("OUTPUT:",a)')command_line
end program demo_get_command
]]>
get_environment_variable
Source
<![CDATA[
program demo_getenv
implicit none
character(len=:),allocatable :: homedir
character(len=:),allocatable :: var
var='HOME'
homedir=get_env(var)
write (*,'(a,"=""",a,"""")')var,homedir
contains
function get_env(name,default) result(value)
! a function that makes calling get_environment_variable(3) simple
use, intrinsic :: iso_fortran_env, only : stderr=>ERROR_UNIT
implicit none
character(len=*),intent(in) :: name
character(len=*),intent(in),optional :: default
character(len=:),allocatable :: value
integer :: howbig
integer :: stat
integer :: length
length=0
value=''
if(name.ne.'')then
call get_environment_variable( name, &
& length=howbig,status=stat,trim_name=.true.)
select case (stat)
case (1)
write(stderr,*) &
& name, " is not defined in the environment. Strange..."
value=''
case (2)
write(stderr,*) &
& "This processor does not support environment variables. Boooh!"
value=''
case default
! make string of sufficient size to hold value
if(allocated(value))deallocate(value)
allocate(character(len=max(howbig,1)) :: value)
! get value
call get_environment_variable( &
& name,value,status=stat,trim_name=.true.)
if(stat.ne.0)value=''
end select
endif
if(value.eq.''.and.present(default))value=default
end function get_env
end program demo_getenv
]]>
huge
Source
<![CDATA[
program demo_huge
implicit none
character(len=*),parameter :: f='(i2,1x,2(i11,1x),f14.0:,1x,l1,1x,a)'
integer :: i, j, k, biggest
real :: v, w
doubleprecision :: tally
! basic
print *, huge(0), huge(0.0), huge(0.0d0)
print *, tiny(0.0), tiny(0.0d0)
tally=0.0d0
! note subtracting one because counter is the end value+1 on exit
do i=0,huge(0)-1
tally=tally+i
enddo
write(*,*)'tally=',tally
! advanced
biggest=huge(0)
! be careful of overflow when using integers in computation
do i=1,14
j=6**i ! Danger, Danger
w=6**i ! Danger, Danger
v=6.0**i
k=v ! Danger, Danger
if(v.gt.biggest)then
write(*,f) i, j, k, v, v.eq.w, 'wrong j and k and w'
else
write(*,f) i, j, k, v, v.eq.w
endif
enddo
! a simple check of the product of two 32-bit integers
print *,checkprod([2,4,5,8],[10000,20000,3000000,400000000])
contains
impure elemental function checkprod(i,j) result(ij32)
! checkprod(3f) - check for overflow when multiplying 32-bit integers
use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64
integer(kind=int32),intent(in) :: i, j
integer(kind=int64) :: ij64
integer(kind=int32) :: ij32
integer,parameter :: toobig=huge(0_int32)
character(len=80) :: message
ij64=int(i,kind=int64)*int(j,kind=int64)
if(ij64.gt.toobig)then
write(message,'(*(g0))')&
& '<ERROR>checkprod(3f):',i,'*',j,'=',ij64,'>',toobig
stop message
else
ij32=ij64
endif
end function checkprod
end program demo_huge
]]>
hypot
Source
<![CDATA[
program demo_hypot
use, intrinsic :: iso_fortran_env, only : real32, real64, real128
implicit none
real(kind=real32) :: x, y
real(kind=real32),allocatable :: xs(:), ys(:)
integer :: i
character(len=*),parameter :: f='(a,/,SP,*(3x,g0,1x,g0:,/))'
x = 1.e0_real32
y = 0.5e0_real32
write(*,*)
write(*,'(*(g0))')'point <',x,',',y,'> is ',hypot(x,y)
write(*,'(*(g0))')'units away from the origin'
write(*,*)
! elemental
xs=[ x, x**2, x*10.0, x*15.0, -x**2 ]
ys=[ y, y**2, -y*20.0, y**2, -y**2 ]
write(*,f)"the points",(xs(i),ys(i),i=1,size(xs))
write(*,f)"have distances from the origin of ",hypot(xs,ys)
write(*,f)"the closest is",minval(hypot(xs,ys))
end program demo_hypot
]]>
iachar
Source
<![CDATA[
program demo_iachar
implicit none
! basic usage
! just does a string one character long
write(*,*)iachar('A')
! elemental: can do an array of letters
write(*,*)iachar(['A','Z','a','z'])
! convert all characters to lowercase
write(*,'(a)')lower('abcdefg ABCDEFG')
contains
!
pure elemental function lower(str) result (string)
! Changes a string to lowercase
character(*), intent(In) :: str
character(len(str)) :: string
integer :: i
string = str
! step thru each letter in the string in specified range
do i = 1, len(str)
select case (str(i:i))
case ('A':'Z') ! change letter to miniscule
string(i:i) = char(iachar(str(i:i))+32)
case default
end select
end do
end function lower
!
end program demo_iachar
]]>
iall
Source
<![CDATA[
program demo_iall
use, intrinsic :: iso_fortran_env, only : integer_kinds, &
& int8, int16, int32, int64
implicit none
integer(kind=int8) :: a(2)
a(1) = int(b'00100100')
a(2) = int(b'01101010')
print '(b8.8)', iall(a)
end program demo_iall
]]>
iand
Source
<![CDATA[
program demo_iand
implicit none
integer :: a, b
data a / z'f' /, b / z'3' /
write (*,*) 'a=',a,' b=',b,'iand(a,b)=',iand(a, b)
write (*,'(b32.32)') a,b,iand(a,b)
end program demo_iand
]]>
iany
Source
<![CDATA[
program demo_iany
use, intrinsic :: iso_fortran_env, only : integer_kinds, &
& int8, int16, int32, int64
implicit none
logical,parameter :: T=.true., F=.false.
integer(kind=int8) :: a(3)
a(1) = int(b'00100100',int8)
a(2) = int(b'01101010',int8)
a(3) = int(b'10101010',int8)
write(*,*)'A='
print '(1x,b8.8)', a
print *
write(*,*)'IANY(A)='
print '(1x,b8.8)', iany(a)
print *
write(*,*)'IANY(A) with a mask'
print '(1x,b8.8)', iany(a,mask=[T,F,T])
print *
write(*,*)'should match '
print '(1x,b8.8)', iany([a(1),a(3)])
print *
write(*,*)'does it?'
write(*,*)iany(a,[T,F,T]) == iany([a(1),a(3)])
end program demo_iany
]]>
ibclr
Source
<![CDATA[
program demo_ibclr
use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64
implicit none
integer(kind=int16) :: i
! basic usage
print *,ibclr (16, 1), ' ==> ibclr(16,1) has the value 15'
! it is easier to see using binary representation
i=int(b'0000000000111111',kind=int16)
write(*,'(b16.16,1x,i0)') ibclr(i,3), ibclr(i,3)
! elemental
print *,'an array of initial values may be given as well'
print *,ibclr(i=[7,4096,9], pos=2)
print *
print *,'a list of positions results in multiple returned values'
print *,'not multiple bits set in one value, as the routine is '
print *,'a scalar function; calling it elementally essentially '
print *,'calls it multiple times. '
write(*,'(b16.16)') ibclr(i=-1_int16, pos=[1,2,3,4])
! both may be arrays if of the same size
end program demo_ibclr
]]>
ibits
Source
<![CDATA[
program demo_ibits
use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64
implicit none
integer(kind=int16) :: i,j
! basic usage
print *,ibits (14, 1, 3) ! should be seven
print *,ibits(-1,10,3) ! and so is this
! it is easier to see using binary representation
i=int(b'0101010101011101',kind=int16)
write(*,'(b16.16,1x,i0)') ibits(i,3,3), ibits(i,3,3)
! we can illustrate this as
! #-- position 15
! | #-- position 0
! | <-- +len |
! V V
! 5432109876543210
i =int(b'1111111111111111',kind=int16)
! ^^^^
j=ibits(i,10,4) ! start at 10th from left and proceed
! left for a total of 4 characters
write(*,'(a,b16.16)')'j=',j
! lets do something less ambiguous
i =int(b'0010011000000000',kind=int16)
j=ibits(i,9,5)
write(*,'(a,b16.16)')'j=',j
end program demo_ibits
]]>
ibset
Source
<![CDATA[
program demo_ibset
use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64
implicit none
integer(kind=int16) :: i
! basic usage
print *,ibset (12, 1), 'ibset(12,1) has the value 14'
! it is easier to see using binary representation
i=int(b'0000000000000110',kind=int16)
write(*,'(b16.16,1x,i0,1x,i0)') ibset(i,12), ibset(i,12), i
! elemental
print *,'an array of initial values may be given as well'
print *,ibset(i=[0,4096], pos=2)
print *
print *,'a list of positions results in multiple returned values'
print *,'not multiple bits set in one value, as the routine is '
print *,'a scalar function; calling it elementally essentially '
print *,'calls it multiple times. '
write(*,'(b16.16)') ibset(i=0, pos=[1,2,3,4])
! both may be arrays if of the same size
end program demo_ibset
]]>
ichar
Source
<![CDATA[
program demo_ichar
use,intrinsic :: iso_fortran_env, only : b=>int8
implicit none
integer,parameter :: bytes=80
character :: string*(bytes),lets((bytes))*1
integer(kind=b) :: ilets(bytes)
equivalence (string,lets)
equivalence (string,ilets)
write(*,*)ichar(['a','z','A','Z'])
string='Do unto others'
associate (a=>ichar(lets))
ilets=merge(a-32,a,a>=97.and.a<=122) ! uppercase
write(*,*)string
ilets=merge(a+32,a,a>=65.and.a<=90) ! lowercase
write(*,*)string
end associate
end program demo_ichar
]]>
ieor
Source
<![CDATA[
program demo_ieor
use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64
implicit none
integer(kind=int16) :: i,j
! basic usage
print *,ieor (16, 1), ' ==> ieor(16,1) has the value 17'
! it is easier to see using binary representation
i=int(b'0000000000111111',kind=int16)
j=int(b'0000001111110000',kind=int16)
write(*,'(a,b16.16,1x,i0)')'i= ',i, i
write(*,'(a,b16.16,1x,i0)')'j= ',j, j
write(*,'(a,b16.16,1x,i0)')'result=',ieor(i,j), ieor(i,j)
! elemental
print *,'arguments may be arrays. If both are arrays they '
print *,'must have the same shape. '
print *,ieor(i=[7,4096,9], j=2)
! both may be arrays if of the same size
end program demo_ieor
]]>
if
Source
<![CDATA[
program demo_if
implicit none
character(len=:),allocatable :: cvar
logical :: PROP=.false.
real :: a, b, c, d
integer :: case=0
integer :: i, j, k
logical :: nextprop=.true.
!
! basic IF
!
cvar='NO'
if (cvar == 'RESET') then
i = 0; j = 0; k = 0
endif
!
! labeled and nested IF constructs
!
OUTER: if (case.eq.0)then
PROOF_DONE: if (PROP) then
write (3, '(''QED'')')
exit OUTER
else
PROP = nextprop
endif PROOF_DONE
write(*,*)'END OF PROOF_DONE'
else OUTER
write(*,*)'else outer'
endif OUTER
!
! if-elseif-endif
!
if (a > 0) then
b = c/a
if (b > 0) then
d = 1.0
endif
elseif (c > 0) then
b = a/c
d = -1.0
else
b = abs (max (a, c))
d = 0
endif
!
end program demo_if
]]>
image_index
Source
<![CDATA[
]]>
implicit
Source
<![CDATA[
program demo_implicit
! everything accessed via USE already has a type and comes
! before an implicit statement; but implicit rules are not
! inherited from modules
use, intrinsic :: iso_fortran_env, only : stderr=>ERROR_UNIT
!
! the implicit statement must come before other declarations
! in new code using this turns on strong typing (that is,every
! variable has to have its type declared in a statement). This
! is generally highly recommended for new code.
implicit none
! it is still a convention used by many programmers to reserve
! starting letters of I to N for integers.
integer :: i, j, k
type(real) :: x,y,z
intrinsic sin,cos ! intrinsic types are already specified
integer,external :: zzz ! but external functions need declared
! if they do not have an interface
call sub1()
call sub2()
contains
subroutine sub1()
! the implicit none above became the default for contained
! procedures so no reason to repeat it. So only required once
! in main procedure or once in top of a module to change the
! default of all procedures defined after a CONTAINS statement
integer :: i=10,j=20
write(*,*)'I=',i,'J=',j
end subroutine sub1
subroutine sub2()
! a contained subroutine can override the default created in the
! containing scope though
implicit complex(a-z)
A=(10,20)
write(*,*)'A=',a
end subroutine sub2
end
integer function zzz()
zzz=1234
end function zzz
!end program demo_implicit
]]>
include
Source
<![CDATA[
]]>
index
Source
<![CDATA[
program demo_index
implicit none
character(len=*),parameter :: str=&
'Search this string for this expression'
!1234567890123456789012345678901234567890
write(*,*)&
index(str,'this').eq.8, &
! return value is counted from the left end even if BACK=.TRUE.
index(str,'this',back=.true.).eq.24, &
! INDEX is case-sensitive
index(str,'This').eq.0
end program demo_index
]]>
inquire
Source
<![CDATA[
program demo_inquire
implicit none
integer :: lun=40
integer :: iostat
write(*,*)'is it open or predefined?'
call print_inquire(lun,'')
write(*,*)'what are the defaults?'
open(unit=lun)
call print_inquire(lun,'')
close(unit=lun,status='delete',iostat=iostat)
contains
subroutine print_inquire(lun_in,filename)
! @(#) print_inquire(3f) print INQUIRE of file by name/number
integer,intent(in),optional :: lun_in
character(len=*),intent(in),optional :: filename
integer :: iostat
character(len=256) :: message
character(len=:),allocatable :: filename_
integer :: lun
! STATUS=NEW|REPLACE|OLD|SCRATCH|UNKNOWN
! SEQUENTIAL | DIRECT | STREAM | UNDEFINED
character(len=20) :: access ; namelist/inquire/access
character(len=20) :: asynchronous ; namelist/inquire/asynchronous
character(len=20) :: blank ; namelist/inquire/blank
character(len=20) :: decimal ; namelist/inquire/decimal
character(len=20) :: delim ; namelist/inquire/delim
character(len=20) :: direct ; namelist/inquire/direct
character(len=20) :: encoding ; namelist/inquire/encoding
! FORMATTED | UNFORMATTED
character(len=20) :: form ; namelist/inquire/form
character(len=20) :: formatted ; namelist/inquire/formatted
character(len=20) :: unformatted ; namelist/inquire/unformatted
character(len=20) :: name ; namelist/inquire/name
character(len=20) :: pad ; namelist/inquire/pad
! ASIS | REWIND | APPEND
character(len=20) :: position ; namelist/inquire/position
! READ | WRITE | READWRITE
character(len=20) :: action ; namelist/inquire/action
character(len=20) :: read ; namelist/inquire/read
character(len=20) :: readwrite ; namelist/inquire/readwrite
character(len=20) :: write ; namelist/inquire/write
character(len=20) :: round ; namelist/inquire/round
character(len=20) :: sequential ; namelist/inquire/sequential
character(len=20) :: sign ; namelist/inquire/sign
character(len=20) :: stream ; namelist/inquire/stream
integer :: id ; namelist/inquire/id
integer :: nextrec ; namelist/inquire/nextrec
integer :: number ; namelist/inquire/number
integer :: pos ; namelist/inquire/pos
integer :: recl ; namelist/inquire/recl
integer :: size ; namelist/inquire/size
logical :: exist ; namelist/inquire/exist
logical :: named ; namelist/inquire/named
logical :: opened ; namelist/inquire/opened
logical :: pending ; namelist/inquire/pending
if(present(filename))then
filename_ =filename
else
filename_ =''
endif
if(present(lun_in))then
lun=lun_in
else
lun=-1
endif
! exist, opened, and named always become defined
! unless an error condition occurs.
if(filename_ == ''.and.lun /= -1)then
write(*,*)'*print_inquire* checking unit',lun
inquire(unit=lun,recl=recl,nextrec=nextrec,pos=pos,size=size, &
& position=position,name=name,form=form,formatted=formatted, &
& unformatted=unformatted,access=access,sequential=sequential, &
& direct=direct,stream=stream,action=action,read=read,write=write, &
& readwrite=readwrite,sign=sign,round=round,blank=blank, &
& decimal=decimal,delim=delim,encoding=encoding,pad=pad, &
& named=named,opened=opened,exist=exist,number=number, &
!bug & pending=pending, &
& asynchronous=asynchronous, &
& iostat=iostat,err=999,iomsg=message)
elseif(filename_ /= '')then
write(*,*)'*print_inquire* checking file:'//filename_
inquire(file=filename_, &
& recl=recl,nextrec=nextrec,pos=pos, &
& size=size,position=position,name=name, &
& form=form,formatted=formatted,unformatted=unformatted, &
& access=access,sequential=sequential,direct=direct,stream=stream, &
& action=action,read=read,write=write,readwrite=readwrite, &
& sign=sign,round=round,blank=blank,decimal=decimal,delim=delim, &
& encoding=encoding,pad=pad,named=named,opened=opened,exist=exist, &
& number=number,pending=pending,asynchronous=asynchronous, &
& iostat=iostat,err=999,iomsg=message)
else
write(*,*) &
& '*print_inquire* must specify either filename or unit number'
endif
write(*,nml=inquire,delim='none')
return
999 continue
write(*,*)'*print_inquire* bad inquire'
! If an error condition occurs during execution of an INQUIRE statement,
! all of the inquiry identifiers except iostat become undefined.
write(*,*) '*print_inquire* inquire call failed,iostat=',iostat, &
& 'message=',message
end subroutine print_inquire
end program demo_inquire
]]>
int
Source
<![CDATA[
program demo_int
use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64
implicit none
integer :: i = 42
complex :: z = (-3.7, 1.0)
real :: x=-10.5, y=10.5
print *, int(x), int(y)
print *, int(i)
print *, int(z), int(z,8)
! elemental
print *, int([-10.9,-10.5,-10.3,10.3,10.5,10.9])
! note int(3) truncates towards zero
! CAUTION:
! a number bigger than a default integer can represent
! produces an incorrect result and is not required to
! be detected by the program.
x=real(huge(0))+1000.0
print *, int(x),x
! using a larger kind
print *, int(x,kind=int64),x
print *, int(&
& B"111111111111111111111111111111111111111111111111111111111111111",&
& kind=int64)
print *, int(O"777777777777777777777",kind=int64)
print *, int(Z"7FFFFFFFFFFFFFFF",kind=int64)
! elemental
print *
print *,int([ &
& -2.7, -2.5, -2.2, -2.0, -1.5, -1.0, -0.5, &
& 0.0, &
& +0.5, +1.0, +1.5, +2.0, +2.2, +2.5, +2.7 ])
end program demo_int
]]>
ior
Source
<![CDATA[
program demo_ior
implicit none
integer :: i, j, k
i=53 ! i=00110101 binary (lowest order byte)
j=45 ! j=00101101 binary (lowest order byte)
k=ior(i,j) ! k=00111101 binary (lowest order byte), k=61 decimal
write(*,'(i8,1x,b8.8)')i,i,j,j,k,k
end program demo_ior
]]>
iparity
Source
<![CDATA[
program demo_iparity
implicit none
integer, dimension(2) :: a
a(1) = int(b'00100100')
a(2) = int(b'01101010')
print '(b8.8)', iparity(a)
end program demo_iparity
]]>
is_contiguous
Source
<![CDATA[
program demo_is_contiguous
implicit none
intrinsic is_contiguous
real, DIMENSION (1000, 1000), TARGET :: A
real, DIMENSION (:, :), POINTER :: IN, OUT
IN => A ! Associate IN with target A
OUT => A(1:1000:2,:) ! Associate OUT with subset of target A
!
write(*,*)'IN is ',IS_CONTIGUOUS(IN)
write(*,*)'OUT is ',IS_CONTIGUOUS(OUT)
!
end program demo_is_contiguous
]]>
ishftc
Source
<![CDATA[
program demo_ishftc
use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64
implicit none
integer :: i
character(len=*),parameter :: g='(b32.32,1x,i0)'
! basics
write(*,*) ishftc(3, 1),' <== typically should have the value 6'
print *, 'lets start with this:'
write(*,'(b32.32)')huge(0)
print *, 'shift the value by various amounts, negative and positive'
do i= -bit_size(0), bit_size(0), 8
write(*,g) ishftc(huge(0),i), i
enddo
print *,'elemental'
i=huge(0)
write(*,*)ishftc(i,[2,3,4,5])
write(*,*)ishftc([2**1,2**3,-2**7],3)
print *,'note the arrays have to conform when elemental'
write(*,*)ishftc([2**1,2**3,-2**7],[5,20,0])
end program demo_ishftc
]]>
ishft
Source
<![CDATA[
program demo_ishft
use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64
implicit none
integer :: shift
character(len=*),parameter :: g='(b32.32,1x,i0)'
write(*,*) ishft(3, 1),' <== typically should have the value 6'
shift=4
write(*,g) ishft(huge(0),shift), shift
shift=0
write(*,g) ishft(huge(0),shift), shift
shift=-4
write(*,g) ishft(huge(0),shift), shift
end program demo_ishft
]]>
is_iostat_end
Source
<![CDATA[
program demo_iostat
implicit none
integer,parameter :: wp=kind(0.0d0)
real(kind=wp) :: value
integer :: iostat
integer :: lun
character(len=256) :: message
! make a scratch input file for demonstration purposes
call makefile(lun)
write(*,*)'Begin entering numeric values, one per line'
do
read(lun,*,iostat=iostat,iomsg=message)value
if(iostat.eq.0)then
write(*,*)'VALUE=',value
elseif( is_iostat_end(iostat) ) then
stop 'end of file. Goodbye!'
else
write(*,*)'ERROR:',iostat,trim(message)
exit
endif
!
enddo
contains
subroutine makefile(lun)
! make a scratch file just for demonstration purposes
integer :: lun
integer :: i
character(len=255),parameter :: fakefile(*)=[character(len=255) :: &
'3.141592653589793238462643383279502884197169399375105820974944592307 &
&/ pi', &
'0.577215664901532860606512090082402431042 &
&/ The Euler-Mascheroni constant (Gamma)', &
'2.71828182845904523536028747135266249775724709369995 &
&/ Napier''s constant "e"&
& is the base of the natural logarithm system,&
& named in honor of Euler ', &
'1.6180339887498948482045868 &
&/ Golden_Ratio', &
'1 / unity', &
'']
!'/ end of data']
open(newunit=lun,status='replace',file='data.txt',action='readwrite')
write(lun,'(a)')(trim(fakefile(i)),i=1,size(fakefile))
rewind(lun)
end subroutine makefile
end program demo_iostat
]]>
is_iostat_eor
Source
<![CDATA[
program demo_is_iostat_eor
use iso_fortran_env, only : iostat_eor
implicit none
integer :: inums(5), lun, ios
! create a test file to read from
open(newunit=lun, form='formatted',status='scratch',action='readwrite')
write(lun, '(a)') &
'10 20 30', &
'40 50 60 70', &
'80 90', &
'100', &
'110 120 130', &
'140'
rewind(lun)
do
read(lun, *, iostat=ios) inums
write(*,*)'iostat=',ios
if(is_iostat_eor(ios)) then
inums=-huge(0)
print *, 'end of record'
elseif(is_iostat_end(ios)) then
print *,'end of file'
inums=-huge(0)
exit
elseif(ios.ne.0)then
print *,'I/O error',ios
inums=-huge(0)
exit
else
write(*,'(*(g0,1x))')'inums=',inums
endif
enddo
close(lun,iostat=ios,status='delete')
end program demo_is_iostat_eor
]]>
kind
Source
<![CDATA[
program demo_kind
implicit none
integer,parameter :: dc = kind(' ')
integer,parameter :: dl = kind(.true.)
print *, "The default character kind is ", dc
print *, "The default logical kind is ", dl
end program demo_kind
]]>
lbound
Source
<![CDATA[
! program demo_lbound
module m_bounds
implicit none
contains
subroutine msub(arr)
!!integer,intent(in) :: arr(*) ! cannot be assumed-size array
integer,intent(in) :: arr(:)
write(*,*)'MSUB: LOWER=',lbound(arr), &
& 'UPPER=',ubound(arr), &
& 'SIZE=',size(arr)
end subroutine msub
end module m_bounds
program demo_lbound
use m_bounds, only : msub
implicit none
interface
subroutine esub(arr)
integer,intent(in) :: arr(:)
end subroutine esub
end interface
integer :: arr(-10:10)
write(*,*)'MAIN: LOWER=',lbound(arr), &
& 'UPPER=',ubound(arr), &
& 'SIZE=',size(arr)
call csub()
call msub(arr)
call esub(arr)
contains
subroutine csub
write(*,*)'CSUB: LOWER=',lbound(arr), &
& 'UPPER=',ubound(arr), &
& 'SIZE=',size(arr)
end subroutine csub
end
subroutine esub(arr)
implicit none
integer,intent(in) :: arr(:)
! WARNING: IF CALLED WITHOUT AN EXPLICIT INTERFACE
! THIS WILL GIVE UNDEFINED ANSWERS (like 0,0,0)
write(*,*)'ESUB: LOWER=',lbound(arr), &
& 'UPPER=',ubound(arr), &
& 'SIZE=',size(arr)
end subroutine esub
!end program demo_lbound
]]>
lcobound
Source
<![CDATA[
]]>
leadz
Source
<![CDATA[
program demo_leadz
implicit none
integer :: value, i
character(len=80) :: f
! make a format statement for writing a value as a bit string
write(f,'("(b",i0,".",i0,")")')bit_size(value),bit_size(value)
! show output for various integer values
value=0
do i=-150, 150, 50
value=i
write (*,'("LEADING ZERO BITS=",i3)',advance='no') leadz(value)
write (*,'(" OF VALUE ")',advance='no')
write(*,f,advance='no') value
write(*,'(*(1x,g0))') "AKA",value
enddo
! Notes:
! for two's-complements programming environments a negative non-zero
! integer value will always start with a 1 and a positive value with 0
! as the first bit is the sign bit. Such platforms are very common.
end program demo_leadz
]]>
len
Source
<![CDATA[
program demo_len
implicit none
! fixed length
character(len=40) :: string
! allocatable length
character(len=:),allocatable :: astring
character(len=:),allocatable :: many_strings(:)
integer :: ii
! BASIC USAGE
ii=len(string)
write(*,*)'length =',ii
! ALLOCATABLE VARIABLE LENGTH CAN CHANGE
! the allocatable string length will be the length of RHS expression
astring=' How long is this allocatable string? '
write(*,*)astring, ' LEN=', len(astring)
! print underline
write(*,*) repeat('=',len(astring))
! assign new value to astring and length changes
astring='New allocatable string'
write(*,*)astring, ' LEN=', len(astring)
! print underline
write(*,*) repeat('=',len(astring))
! THE STRING LENGTH WILL BE CONSTANT FOR A FIXED-LENGTH VARIABLE
string=' How long is this fixed string? '
write(*,*)string,' LEN=',len(string)
string='New fixed string '
write(*,*)string,' LEN=',len(string)
! ALL STRINGS IN AN ARRAY ARE THE SAME LENGTH
! a scalar is returned for an array, as all values in a Fortran
! character array must be of the same length.
many_strings = [ character(len=7) :: 'Tom', 'Dick', 'Harry' ]
write(*,*)'length of ALL elements of array=',len(many_strings)
! NAME%LEN IS ESSENTIALLY THE SAME AS LEN(NAME)
! you can also query the length (and other attributes) of a string
! using a "type parameter inquiry" (available since fortran 2018)
write(*,*)'length from type parameter inquiry=',string%len
! %len is equivalent to a call to LEN() except the kind of the integer
! value returned is always of default kind.
! LOOK AT HOW A PASSED STRING CAN BE USED ...
call passed(' how long? ')
contains
subroutine passed(str)
character(len=*),intent(in) :: str
! the length of str can be used in the definitions of variables
! you can query the length of the passed variable
write(*,*)'length of passed value is ', LEN(str)
end subroutine passed
end program demo_len
]]>
len_trim
Source
<![CDATA[
program demo_len_trim
implicit none
character(len=:),allocatable :: string
integer :: i
! basic usage
string=" how long is this string? "
write(*,*) string
write(*,*)'UNTRIMMED LENGTH=',len(string)
write(*,*)'TRIMMED LENGTH=',len_trim(string)
! print string, then print substring of string
string='xxxxx '
write(*,*)string,string,string
i=len_trim(string)
write(*,*)string(:i),string(:i),string(:i)
!
! elemental example
ELE:block
! an array of strings may be used
character(len=:),allocatable :: tablet(:)
tablet=[character(len=256) :: &
& ' how long is this string? ',&
& 'and this one?']
write(*,*)'UNTRIMMED LENGTH= ',len(tablet)
write(*,*)'TRIMMED LENGTH= ',len_trim(tablet)
write(*,*)'SUM TRIMMED LENGTH=',sum(len_trim(tablet))
endblock ELE
!
end program demo_len_trim
]]>
lge
Source
<![CDATA[
program demo_lge
implicit none
integer :: i
print *,'the ASCII collating sequence for printable characters'
write(*,'(1x,19a)')(char(i),i=32,126) ! ASCII order
write(*,*) lge('abc','ABC') ! [T] lowercase is > uppercase
write(*,*) lge('abc','abc ') ! [T] trailing spaces
! If both strings are of zero length the result is true
write(*,*) lge('','') ! [T]
write(*,*) lge('','a') ! [F] the null string is padded
write(*,*) lge('a','') ! [T]
! elemental
write(*,*) lge('abc',['abc','123']) ! [T T] scalar and array
write(*,*) lge(['cba', '123'],'abc') ! [T F]
write(*,*) lge(['abc','123'],['cba','123']) ! [F T] both arrays
end program demo_lge
]]>
lgt
Source
<![CDATA[
program demo_lgt
implicit none
integer :: i
print *,'the ASCII collating sequence for printable characters'
write(*,'(1x,19a)')(char(i),i=32,126)
write(*,*) lgt('abc','ABC') ! [T] lowercase is > uppercase
write(*,*) lgt('abc','abc ') ! [F] trailing spaces
! If both strings are of zero length the result is false.
write(*,*) lgt('','') ! [F]
write(*,*) lgt('','a') ! [F] the null string is padded
write(*,*) lgt('a','') ! [T]
write(*,*) lgt('abc',['abc','123']) ! [F T] scalar and array
write(*,*) lgt(['cba', '123'],'abc') ! [T F]
write(*,*) lgt(['abc','123'],['cba','123']) ! [F F] both arrays
end program demo_lgt
]]>
lle
Source
<![CDATA[
program demo_lle
implicit none
integer :: i
print *,'the ASCII collating sequence for printable characters'
write(*,'(1x,19a)')(char(i),i=32,126)
! basics
print *,'case matters'
write(*,*) lle('abc','ABC') ! F lowercase is > uppercase
print *,'a space is the lowest printable character'
write(*,*) lle('abcd','abc') ! F d > space
write(*,*) lle('abc','abcd') ! T space < d
print *,'leading spaces matter, trailing spaces do not'
write(*,*) lle('abc','abc ') ! T trailing spaces
write(*,*) lle('abc',' abc') ! F leading spaces are significant
print *,'even null strings are padded and compared'
! If both strings are of zero length the result is true.
write(*,*) lle('','') ! T
write(*,*) lle('','a') ! T the null string is padded
write(*,*) lle('a','') ! F
print *,'elemental'
write(*,*) lle('abc',['abc','123']) ! [T,F] scalar and array
write(*,*) lle(['cba', '123'],'abc') ! [F,T]
! per the rules for elemental procedures arrays must be the same size
write(*,*) lle(['abc','123'],['cba','123']) ! [T,T] both arrays
end program demo_lle
]]>
llt
Source
<![CDATA[
program demo_llt
implicit none
integer :: i
print *,'the ASCII collating sequence for printable characters'
write(*,'(1x,19a)')(char(i),i=32,126) ! ASCII order
! basics
print *,'case matters'
write(*,*) llt('abc','ABC') ! [F] lowercase is > uppercase
write(*,*) llt('abc','abc ') ! [F] trailing spaces
! If both strings are of zero length the result is false.
write(*,*) llt('','') ! [F]
write(*,*) llt('','a') ! [T] the null string is padded
write(*,*) llt('a','') ! [F]
print *,'elemental'
write(*,*) llt('abc',['abc','123']) ! [F F] scalar and array
write(*,*) llt(['cba', '123'],'abc') ! [F T]
write(*,*) llt(['abc','123'],['cba','123']) ! [T F] both arrays
end program demo_llt
]]>
log10
Source
<![CDATA[
program demo_log10
use, intrinsic :: iso_fortran_env, only : real32, real64, real128
implicit none
real(kind=real64) :: x = 10.0_real64
x = log10(x)
write(*,'(*(g0))')'log10(',x,') is ',log10(x)
! elemental
write(*, *)log10([1.0, 10.0, 100.0, 1000.0, 10000.0, &
& 100000.0, 1000000.0, 10000000.0])
end program demo_log10
]]>
log
Source
<![CDATA[
program demo_log
implicit none
real(kind(0.0d0)) :: x = 2.71828182845904518d0
complex :: z = (1.0, 2.0)
write(*,*)x, log(x) ! will yield (approximately) 1
write(*,*)z, log(z)
end program demo_log
]]>
log_gamma
Source
<![CDATA[
program demo_log_gamma
implicit none
real :: x = 1.0
write(*,*)x,log_gamma(x) ! returns 0.0
write(*,*)x,log_gamma(3.0) ! returns 0.693 (approximately)
end program demo_log_gamma
]]>
logical
Source
<![CDATA[
program demo_logical
use iso_fortran_env, only : logical_kinds
use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64
use,intrinsic :: iso_fortran_env, only : real32, real64, real128
!
! The standard only requires one default logical kind to be supported
! of the same storage size as a default INTEGER and REAL but the
! following kind names are standard. The kind may not be
! supported (in which case the value of the kind name will be a
! negative integer value) and additional kinds may be available as well.
use,intrinsic :: iso_fortran_env, only : &
& LOGICAL8, LOGICAL16, LOGICAL32, LOGICAL64
!
! C_BOOL is a kind compatible with C interfaces
use,intrinsic :: iso_c_binding, only : C_BOOL
!
implicit none
character(len=*),parameter :: all='(*(g0))'
integer :: i, i1, i2
! make T and F abbreviations for .TRUE. and .FALSE.
logical,parameter :: T=.true., F=.false.
logical :: l1, l2
! potentially save space and improve performance by using the
! smallest available kind
logical(kind=selected_logical_kind(1)) :: smallest_storage(10,20)
logical(kind=c_bool) :: boolean=.TRUE.
!
print all, 'list LOGICAL kind values available on this platform'
do i =1, size(logical_kinds)
write(*,all)' integer,parameter :: boolean', &
& logical_kinds(i),'=', logical_kinds(i)
enddo
print all, ' LOGICAL8 ==> KIND=',LOGICAL8
print all, ' LOGICAL16 ==> KIND=',LOGICAL16
print all, ' LOGICAL32 ==> KIND=',LOGICAL32
print all, ' LOGICAL64 ==> KIND=',LOGICAL64
print all, ' C_BOOL ==> KIND=',C_BOOL
print all, 'MERGE() is one method for transposing logical and integer'
! converting a logical to an integer is not done
! with LOGICAL(3f) and INT(3f) or promotion by assignment;
! but can be done with MERGE(3f) with scalars or arrays.
i1=merge(0,1,T)
i2=merge(0,1,F)
write(*,all)' T-->',i1,' F-->',I2
l1=merge(T,F,i1.eq.0)
l2=merge(T,F,i2.eq.0)
write(*,all)' 0-->',l1,' 1-->',l2
!
! Note the standard specifies the default INTEGER, REAL, and LOGICAL
! types have the same storage size, but compiler options often allow
! changing that. STORAGE_SIZE() can be used to confirm that.
!
print all, 'show kind and storage size of default logical'
call showme(.true.)
call showme(l1)
! A method to portably request the smallest storage size is
! logical(kind=selected_logical_kind(1) :: array(1000,1000)
print all, 'storage size of smallest logical kind'
call showme(logical(l1,kind=selected_logical_kind(1)))
! you may have to delete unsupported kinds from this example
print all, 'different kinds are being passed because of LOGICAL() call'
print all,'KIND values are platform-specific'
call showme(logical(l1,kind=1))
call showme(logical(l1,kind=2))
call showme(logical(l1,kind=4))
call showme(logical(l1,kind=8))
print all,'kind=C_BOOL'
call showme(logical(l1,kind=c_bool))
print all,'SELECTED_LOGICAL_KIND() is more portable than KIND values'
! you might want to check the resulting kind
call showme(logical(l1,kind=selected_logical_kind(1))) ! smallest
call showme(logical(l1,kind=kind(.true.))) ! default
call showme(logical(l1,kind=selected_logical_kind(8)))
call showme(logical(l1,kind=selected_logical_kind(16)))
call showme(logical(l1,kind=selected_logical_kind(32)))
call showme(logical(l1,kind=selected_logical_kind(64)))
contains
subroutine showme(val)
! @(#) showme(3f) - display type and kind of intrinsic value
! this is an example of how to accept any logical kind as a parameter,
! but this is often done with a generic procedure.
class(*),intent(in) :: val
select type(val)
type is (logical(kind=logical8))
write(*,'(" logical(kind=1) ",l1,a,i0)') val, &
& ' storage=',storage_size(val)
type is (logical(kind=logical16))
write(*,'(" logical(kind=2) ",l1,a,i0)') val, &
& ' storage=',storage_size(val)
type is (logical(kind=logical32))
write(*,'(" logical(kind=4) ",l1,a,i0)') val, &
& ' storage=',storage_size(val)
type is (logical(kind=logical64))
write(*,'(" logical(kind=8) ",l1,a,i0)') val, &
& ' storage=',storage_size(val)
class default
stop 'crud. showme() does not know about this type'
end select
end subroutine showme
end program demo_logical
]]>
logicals
Source
<![CDATA[
program demo_different_logical_kinds
use iso_fortran_env, only : logical_kinds
use,intrinsic :: iso_fortran_env, only : &
& LOGICAL8, LOGICAL16, LOGICAL32, LOGICAL64
use,intrinsic :: iso_c_binding, only : C_BOOL
implicit none
character(len=*),parameter :: all='(*(g0))'
! potentially save space and improve performance by using the
! smallest available kind
integer,parameter :: lk=selected_logical_kind(1)
logical(lk) :: smallest_storage(10,20)
! C_BOOL is a kind compatible with C interfaces
logical(kind=c_bool) :: boolean=.TRUE.
integer :: i
! The integer array constant LOGICAL_KINDS() contains the kind
! values for supported logical kinds for the current processor
print all, 'list LOGICAL kind values available on this platform'
do i =1, size(logical_kinds)
print all, ' integer,parameter :: boolean', &
& logical_kinds(i),'=', logical_kinds(i)
enddo
print all, ' LOGICAL8 ==> KIND=',LOGICAL8
print all, ' LOGICAL16 ==> KIND=',LOGICAL16
print all, ' LOGICAL32 ==> KIND=',LOGICAL32
print all, ' LOGICAL64 ==> KIND=',LOGICAL64
print all, ' C_BOOL ==> KIND=',C_BOOL
print all, 'storage size of default logical = ', storage_size(.true.)
print all, 'storage size of smallest logical kind = ', &
storage_size(smallest_storage)
print all, 'storage size of C_BOOL= ', storage_size(boolean)
print all, 'kind of default logical = ', kind(.true.)
print all, 'kind of smallest logical kind = ', kind(smallest_storage)
print all, 'kind of C_BOOL= ', kind(.true._c_bool)
end program demo_different_logical_kinds
program demo_random_number use, intrinsic :: iso_fortran_env, only :
dp=>real64 implicit none
integer
:: i, first, last, rand_int, sumup, passes real(kind=kind(0.0d0)) ::
rand_val ! generate a lot of random integers from -10 to 100 and add to
sum ! until upper limit is reached, for no reason first=-10 last=100
sumup=0 passes=0 do while (sumup <= 1000000000) call
random_number(rand_val) rand_int=first+floor((last+1-first)*rand_val)
sumup=sumup+rand_int passes=passes+1 enddo
write(*,*)'sumup=',sumup,'passes=',passes end program demo_random_number
ARRAY MASKING
Logical arrays can be used as masks to selectively apply operations to
elements of other arrays. This is particularly efficient for numerical
computations.
integer,parameter :: isz=10
real, dimension(isz) :: a
logical, dimension(isz) :: mask
mask = (a > 5.0)
! Double elements of 'a' where 'a' is greater than 5.0
a(mask) = a(mask) * 2.0
A WHERE construct allows for multiple masks to be conditionally used.
WHERE(cond1)
...
ELSEWHERE(cond2)
...
ELSEWHERE
END WHERE
Examples of masked array assignment are:
WHERE (TEMP > 100.0) TEMP = TEMP - REDUCE_TEMP
WHERE (PRESSURE <= 1.0)
PRESSURE = PRESSURE + INC_PRESSURE
TEMP = TEMP - 5.0
ELSEWHERE
RAINING = .TRUE.
END WHERE
LOGICAL OPERATIONS
Intrinsic operators like .AND., .OR., .NOT., and .EQV. (equivalent) or
.NEQV. (not equivalent) are used to combine or negate logical expressions,
creating more complex conditions.
LOGICAL :: condition1, condition2, result
condition1 = (value1 == 10)
condition2 = (value2 /= 0)
result = condition1 .OR. condition2
[verify] is very powerful when using expressions as masks for processing
strings. For example, to determine if strings represent valid Fortran symbol
names:
program fortran_symbol_name
implicit none
integer :: i
! some strings to inspect for being valid symbol names
character(len=*),parameter :: symbols(*)=[character(len=10) :: &
'A_ ', &
'10 ', &
'September ', &
'A B', &
'_A ', &
' ']
write(*,'("|",*(g0,"|"))') symbols
write(*,'("|",*(1x,l1,8x,"|"))') fortran_name(symbols)
contains
elemental function fortran_name(line) result (lout)
! determine if a string is a valid Fortran name
! ignoring trailing spaces (but not leading spaces)
character(len=*),parameter :: int='0123456789'
character(len=*),parameter :: lower='abcdefghijklmnopqrstuvwxyz'
character(len=*),parameter :: upper='ABCDEFGHIJKLMNOPQRSTUVWXYZ'
character(len=*),parameter :: allowed=upper//lower//int//'_'
character(len=*),intent(in) :: line
character(len=:),allocatable :: name
logical :: lout
name=trim(line)
if(len(name).ne.0)then
! first character is alphameric
lout = verify(name(1:1), lower//upper) == 0 &
! verify other characters allowed in a symbol name
& .and. verify(name,allowed) == 0 &
! check conforms to allowable length
& .and. len(name) <= 63
else
lout = .false.
endif
end function fortran_name
end program fortran_symbol_name
Results:
> |A_ |10 |September |A B |_A | |
> | T | F | T | F | F | F |
ARRAY REDUCTION FUNCTIONS
Intrinsic functions like ALL() and ANY() are used to check if all or any
elements in a logical array satisfy a condition, often used in conjunction
with array masking.
logical,parameter :: t=.true., f=.false.
logical, dimension(5) :: status = [ t, f, t, t, t ]
if (all(status)) then
print *, "All statuses are true"
endif
if (any(status)) then
print *, "At least one status is true"
endif
BITWISE LOGICAL OPERATIONS
For handling individual bits within integer variables, Fortran offers
intrinsic functions like IAND (bitwise AND), IOR (bitwise OR), IEOR (bitwise
exclusive OR), and NOT (bitwise NOT). These are crucial in low-level
programming and certain numerical algorithms.
integer :: a, b, c
a = int(z'0101')
b = int(z'0011')
c = IAND(a, b) ! c will be 1 (0001)
write(*,'*(g0,z0,1x)'),'a=',a,'b=',b,'c=',c
but these return integer, not logical values and are mentioned only for
reference.
CONDITIONAL EXPRESSIONS
A conditional expression is related to logicals in that it is used to
selectively evaluate a chosen subexpression.
scalar-logical-expr ? expr [ : scalar-logical-expr ? expr ]... : expr )
Each expr of a conditional-expr shall have the same declared type, kind type
parameters, and rank.
Examples of a conditional expression are:
( ABS(RESIDUAL)<=TOLERANCE ? "ok" : "did not converge" )
( I>0 .AND. I<=SIZE(A) ? A (I) : PRESENT(VAL) ? VAL : 0.0 )
Conditional expressions are required to short-circuit (execute only the
selected expression and not the other candidate) unlike the remainder of
Fortran where short-circuiting behavior is typically left up to the
processor.
That is, elsewhere in Fortran it is not necessary for a processor to
evaluate all of the operands of an expression, or to evaluate entirely each
operand -- but the processor is free to evaluate all of the operands. That
is, all of the operands may or may not be evaluated.
This principle is most often applicable to logical expressions, zero-sized
arrays, and zero-length strings, but it applies to all expressions.
For example, in evaluating the expression
X > Y .OR. L(Z)
L(Z) may or may not be evaluated assuming "L" is a procedure name when the
first condition (X > Y) is true.
LOGICALS CANNOT BE USED AS INTEGERS
Logicals are not allowed in numeric expressions, as in common in several
other languages. There is no automatic promotion of LOGICAL to INTEGER
allowed by the standard or vice-versa. That being said, it is a common
extension to cast .FALSE. to zero(0) and .TRUE. to some none-zero number;
but what values are used and how many bits are significant in the values
varies widely between current popular compilers and so the extension should
be avoided.
Sample program:
program logical_integer
implicit none
character(len=*),parameter :: all='(*(g0))'
integer :: i1, i2
! make T and F abbreviations for .TRUE. and .FALSE.
logical,parameter :: T=.true., F=.false.
logical :: l1, l2
print all, 'MERGE() is one method for transposing logical and integer'
! converting a logical to an integer is not done
! with LOGICAL(3f) and INT(3f) or promotion by assignment;
! but can be done with MERGE(3f) with scalars or arrays.
i1=merge(1,0,T)
i2=merge(1,0,F)
write(*,all)' T-->',i1,' F-->',I2
l1=merge(T,F,i1.eq.0)
l2=merge(T,F,i2.eq.0)
write(*,all)' 0-->',l1,' 1-->',l2
end program logical_integer
Results:
> MERGE() is one method for transposing logical and integer
> T-->1 F-->0
> 0-->F 1-->T
LOGICAL EDITING
The Lw edit descriptor indicates that the field occupies w positions. The
input field so specified consists of optional blanks, optionally followed by
a period, followed by a "T" for true or "F" for false. The "T" or "F" may be
followed by additional characters in the field, which are ignored.
So, for example the strings ".TRUE." and ".FALSE." are acceptable input
forms if "w" is sufficiently sized.
A lower-case letter is equivalent to the corresponding upper-case letter in
a logical input field.
The output field consists of w−1 blanks followed by a T or F, depending on
whether the internal value is true or false, respectively.
program logical_formatted
implicit none
character(len=*),parameter :: all='(*(g0))'
character(len=:),allocatable :: line
logical :: array(8), p, q
print all, 'Logicals print as the right-justified string "T" or "F"'
write(*,'("[",l10,"]")') .TRUE.
write(*,'("[",l0,"]")') .FALSE.
print all, 'the first non-blank letter after an optional period'
print all, 'determines the value on input'
print all, repeat('1234567',8)
line='.false. .true. T F TrustyFake!!!tr fffffff'
print all, line
read(line,'(8(L7))') array
print all, array
end program logical_formatted
Results:
> Logicals print as the right-justified string "T" or "F"
> [ T]
> [F]
> the first non-blank letter after an optional period
> determines the value on input
> 12345671234567123456712345671234567123456712345671234567
> .false. .true. T F TrustyFake!!!tr fffffff
> FTTFTFTF
The G edit descriptor also may be used to edit logical data.
SEE ALSO
Bit-level procedures
• ieor(3), ior(3), ishftc(3), ishft(3), iand(3).
• result = iall(array [,mask]) | iall(array ,dim [,mask])
• result = iany(array [,mask]) | iany(array ,dim [,mask])
• result = iparity( array [,mask] ) | iparity( array, dim [,mask] )
• result = maskl( i [,kind] )
• result = maskr( i [,kind] )
• result = merge_bits(i, j, mask) ! Merge bits using a mask
Other
• VERIFY(3) is very powerful when using expressions as masks for processing
strings
• [[iso_fortran_env]] module
• iso_c_binding module
• TRANSFER(3) - Transfer bit patterns
Fortran Tutorials(license: MIT) @urbanjost
December 23, 2025 logicals(7fortran)
]]>
maskl
Source
<![CDATA[
program demo_maskl
implicit none
integer :: i
! basics
i=3
write(*,'(i0,1x,b0)') i, maskl(i)
! elemental
write(*,'(*(i11,1x,b0.32,1x,/))') maskl([(i,i,i=0,bit_size(0),4)])
end program demo_maskl
]]>
maskr
Source
<![CDATA[
program demo_maskr
implicit none
integer :: i
! basics
print *,'basics'
write(*,'(i0,t5,b32.32)') 1, maskr(1)
write(*,'(i0,t5,b32.32)') 5, maskr(5)
write(*,'(i0,t5,b32.32)') 11, maskr(11)
print *,"should be equivalent on two's-complement processors"
write(*,'(i0,t5,b32.32)') 1, shiftr(-1,bit_size(0)-1)
write(*,'(i0,t5,b32.32)') 5, shiftr(-1,bit_size(0)-5)
write(*,'(i0,t5,b32.32)') 11, shiftr(-1,bit_size(0)-11)
! elemental
print *,'elemental '
print *,'(array argument accepted like called with each element)'
write(*,'(*(i11,1x,b0.32,1x,/))') maskr([(i,i,i=0,bit_size(0),4)])
end program demo_maskr
]]>
matmul
Source
<![CDATA[
program demo_matmul
implicit none
integer :: a(2,3), b(3,2), c(2), d(3), e(2,2), f(3), g(2), v1(4),v2(4)
a = reshape([1, 2, 3, 4, 5, 6], [2, 3])
b = reshape([10, 20, 30, 40, 50, 60], [3, 2])
c = [1, 2]
d = [1, 2, 3]
e = matmul(a, b)
f = matmul(c,a)
g = matmul(a,d)
call print_matrix_int('A is ',a)
call print_matrix_int('B is ',b)
call print_vector_int('C is ',c)
call print_vector_int('D is ',d)
call print_matrix_int('E is matmul(A,B)',e)
call print_vector_int('F is matmul(C,A)',f)
call print_vector_int('G is matmul(A,D)',g)
! look at argument shapes when one is a vector
write(*,'(" > shape")')
! at least one argument must be of rank two
! so for two vectors at least one must be reshaped
v1=[11,22,33,44]
v2=[10,20,30,40]
! these return a vector C(1:1)
! treat A(1:n) as A(1:1,1:n)
call print_vector_int('Cd is a vector (not a scalar)',&
& matmul(reshape(v1,[1,size(v1)]),v2))
! or treat B(1:m) as B(1:m,1:1)
call print_vector_int('cD is a vector too',&
& matmul(v1,reshape(v2,[size(v2),1])))
! or treat A(1:n) as A(1:1,1:n) and B(1:m) as B(1:m,1:1)
! but note this returns a matrix C(1:1,1:1) not a vector!
call print_matrix_int('CD is a matrix',matmul(&
& reshape(v1,[1,size(v1)]), &
& reshape(v2,[size(v2),1])))
contains
! CONVENIENCE ROUTINES TO PRINT IN ROW-COLUMN ORDER
subroutine print_vector_int(title,arr)
character(len=*),intent(in) :: title
integer,intent(in) :: arr(:)
call print_matrix_int(title,reshape(arr,[1,shape(arr)]))
end subroutine print_vector_int
subroutine print_matrix_int(title,arr)
!@(#) print small 2d integer arrays in row-column format
character(len=*),parameter :: all='(" > ",*(g0,1x))' ! a handy format
character(len=*),intent(in) :: title
integer,intent(in) :: arr(:,:)
integer :: i
character(len=:),allocatable :: biggest
print all
print all, trim(title)
biggest=' ' ! make buffer to write integer into
! find how many characters to use for integers
write(biggest,'(i0)')ceiling(log10(max(1.0,real(maxval(abs(arr))))))+2
! use this format to write a row
biggest='(" > [",*(i'//trim(biggest)//':,","))'
! print one row of array at a time
do i=1,size(arr,dim=1)
write(*,fmt=biggest,advance='no')arr(i,:)
write(*,'(" ]")')
enddo
end subroutine print_matrix_int
end program demo_matmul
]]>
maxexponent
Source
<![CDATA[
program demo_maxexponent
use, intrinsic :: iso_fortran_env, only : real32,real64,real128
implicit none
character(len=*),parameter :: g='(*(g0,1x))'
print g, minexponent(0.0_real32), maxexponent(0.0_real32)
print g, minexponent(0.0_real64), maxexponent(0.0_real64)
print g, minexponent(0.0_real128), maxexponent(0.0_real128)
end program demo_maxexponent
]]>
max
Source
<![CDATA[
program demo_max
implicit none
real :: arr1(4)= [10.0,11.0,30.0,-100.0]
real :: arr2(5)= [20.0,21.0,32.0,-200.0,2200.0]
integer :: box(3,4)= reshape([-6,-5,-4,-3,-2,-1,1,2,3,4,5,6],shape(box))
! basic usage
! this is simple enough when all arguments are scalar
! the most positive value is returned, not the one with the
! largest magnitude
write(*,*)'scalars:',max(10.0,11.0,30.0,-100.0)
write(*,*)'scalars:',max(-22222.0,-0.0001)
! strings do not need to be of the same length
write(*,*)'characters:',max('the','words','order')
! leading spaces are significant; everyone is padded on the right
! to the length of the longest argument
write(*,*)'characters:',max('c','bb','a')
write(*,*)'characters:',max(' c','b','a')
! elemental
! there must be at least two arguments, so even if A1 is an array
! max(A1) is not valid. See MAXVAL(3) and/or MAXLOC(3) instead.
! strings in a single array do need to be of the same length
! but the different objects can still be of different lengths.
write(*,"(*('""',a,'""':,1x))")MAX(['A','Z'],['BB','Y '])
! note the result is now an array with the max of every element
! position, as can be illustrated numerically as well:
write(*,'(a,*(i3,1x))')'box= ',box
write(*,'(a,*(i3,1x))')'box**2=',sign(1,box)*box**2
write(*,'(a,*(i3,1x))')'max ',max(box,sign(1,box)*box**2)
! Remember if any argument is an array by the definition of an
! elemental function all the array arguments must be the same shape.
! to find the single largest value of multiple arrays you could
! use something like
! MAXVAL([arr1, arr2])
! or probably better (more likely to avoid creating a large temp array)
! max(maxval(arr1),maxval(arr2))
! instead
! so this returns an array of the same shape as any input array
! where each result is the maximum that occurs at that position.
write(*,*)max(arr1,arr2(1:4))
! this returns an array just like BOX except all values less than
! zero are set to zero:
write(*,*)max(box,0)
! When mixing arrays and scalars you can think of the scalars
! as being a copy of one of the arrays with all values set to
! the scalar value.
end program demo_max
]]>
maxloc
Source
<![CDATA[
program demo_maxloc
implicit none
integer :: ii
integer,save :: i(-3:3)=[(abs(abs(ii)-50),ii=-3,3)]
integer,save :: ints(3,5)= reshape([&
1, 2, 3, 4, 5, &
10, 20, 30, 40, 50, &
11, 22, 33, 44, 55 &
],shape(ints),order=[2,1])
write(*,*) maxloc(ints)
write(*,*) maxloc(ints,dim=1)
write(*,*) maxloc(ints,dim=2)
! when array bounds do not start with one remember MAXLOC(3) returns
! the offset relative to the lower bound-1 of the location of the
! maximum value, not the subscript of the maximum value. When the
! lower bound of the array is one, these values are the same. In
! other words, MAXLOC(3) returns the subscript of the value assuming
! the first subscript of the array is one no matter what the lower
! bound of the subscript actually is.
write(*,'(g0,1x,g0)') (ii,i(ii),ii=lbound(i,dim=1),ubound(i,dim=1))
write(*,*)maxloc(i)
end program demo_maxloc
]]>
maxval
Source
<![CDATA[
program demo_maxval
implicit none
integer,save :: ints(3,5)= reshape([&
1, 2, 3, 4, 5, &
10, 20, 30, 40, 50, &
11, 22, 33, 44, 55 &
],shape(ints),order=[2,1])
character(len=:),allocatable :: strs(:)
integer :: i
character(len=*),parameter :: gen='(*(g0,1x))'
character(len=*),parameter :: ind='(3x,*(g0,1x))'
print gen,'Given the array'
write(*,'(1x,*(g4.4,1x))') &
& (ints(i,:),new_line('a'),i=1,size(ints,dim=1))
print gen,'Basics:'
print ind, 'biggest value in array'
print ind, maxval(ints)
print ind, 'biggest value in each column'
print ind, maxval(ints,dim=1)
print ind, 'biggest value in each row'
print ind, maxval(ints,dim=2)
print gen,'With a mask:'
print ind, ' find biggest number less than 30 with mask'
print ind, maxval(ints,mask=ints.lt.30)
print gen,'If zero size considered:'
print ind, 'if zero size numeric array'
print ind, maxval([integer :: ]),'and -huge(0) is',-huge(0),&
& '(often not the same!)'
print ind, 'if zero-size character array all nulls'
strs=[character(len=5)::]
strs=maxval(strs)
print ind, ichar([(strs(i),i=1,len(strs))])
print ind, 'if everything is false,'
print ind, 'same as zero-size array for each subarray'
print ind, maxval(ints,mask=.false.)
print ind, maxval(ints,mask=.false.,dim=1)
end program demo_maxval
]]>
merge_bits
Source
<![CDATA[
program demo_merge_bits
use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64
implicit none
integer(kind=int16) :: if_one,if_zero,msk
character(len=*),parameter :: fmt='(*(g0, 1X))'
! basic usage
print *,'MERGE_BITS( 5,10,41) should be 3.=>',merge_bits(5,10,41)
print *,'MERGE_BITS(13,18,22) should be 4.=>',merge_bits(13,18,22)
! use some values in base2 illustratively:
if_one =int(b'1010101010101010',kind=int16)
if_zero=int(b'0101010101010101',kind=int16)
msk=int(b'0101010101010101',kind=int16)
print '("should get all zero bits =>",b16.16)', &
& merge_bits(if_one,if_zero,msk)
msk=int(b'1010101010101010',kind=int16)
print '("should get all ones bits =>",b16.16)', &
& merge_bits(if_one,if_zero,msk)
! using BOZ values
print fmt, &
& merge_bits(32767_int16, o'12345', 32767_int16), &
& merge_bits(o'12345', 32767_int16, b'0000000000010101'), &
& merge_bits(32767_int16, o'12345', z'1234')
! a do-it-yourself equivalent for comparison and validation
print fmt, &
& ior(iand(32767_int16, 32767_int16), &
& iand(o'12345', not(32767_int16))), &
& ior(iand(o'12345', int(o'12345', kind=int16)), &
& iand(32767_int16, not(int(o'12345', kind=int16)))), &
& ior(iand(32767_int16, z'1234'), &
& iand(o'12345', not(int( z'1234', kind=int16))))
end program demo_merge_bits
]]>
merge
Source
<![CDATA[
program demo_merge
implicit none
integer :: tvals(2,3), fvals(2,3), answer(2,3)
logical :: mask(2,3)
integer :: i
integer :: k
logical :: chooseleft
logical :: maybe
! Works with scalars
k=5
write(*,*)merge (1.0, 0.0, k > 0)
k=-2
write(*,*)merge (1.0, 0.0, k > 0)
! note for scalar logicals calls such as
maybe = merge (.true.,.false., k > 0)
! are simply the same as
if (k > 0)then
maybe=.true.
else
maybe=.false.
endif
! but even more succinctly, and array-compatible, is
maybe = k > 0
! set up some simple arrays that all conform to the
! same shape
tvals(1,:)=[ 10, -60, 50 ]
tvals(2,:)=[ -20, 40, -60 ]
fvals(1,:)=[ 0, 3, 2 ]
fvals(2,:)=[ 7, 4, 8 ]
mask(1,:)=[ .true., .false., .true. ]
mask(2,:)=[ .false., .false., .true. ]
! lets use the mask of specific values
write(*,*)'mask of logicals'
answer=merge( tvals, fvals, mask )
call printme()
! more typically the mask is an expression
write(*, *)'highest values'
answer=merge( tvals, fvals, tvals > fvals )
call printme()
write(*, *)'lowest values'
answer=merge( tvals, fvals, tvals < fvals )
call printme()
write(*, *)'zero out negative values'
answer=merge( 0, tvals, tvals < 0)
call printme()
write(*, *)'binary choice'
chooseleft=.false.
write(*, '(3i4)')merge([1,2,3],[10,20,30],chooseleft)
chooseleft=.true.
write(*, '(3i4)')merge([1,2,3],[10,20,30],chooseleft)
contains
subroutine printme()
write(*, '(3i4)')(answer(i, :), i=1, size(answer, dim=1))
end subroutine printme
end program demo_merge
]]>
minexponent
Source
<![CDATA[
program demo_minexponent
use, intrinsic :: iso_fortran_env, only : real32, real64, real128
implicit none
real(kind=real32) :: x
real(kind=real64) :: y
print *, minexponent(x), maxexponent(x)
print *, minexponent(y), maxexponent(y)
end program demo_minexponent
]]>
min
Source
<![CDATA[
program demo_min
implicit none
integer :: i
integer :: rectangle(3,4)=reshape([(-6+i,i=0,11)],[3,4])
print *, 'basics'
print *, min(10.0,11.0,30.0,-100.0)
print *, min(-200.0,-1.0)
print *, 'elemental'
print *, min(1,[2,3,4])
print *, min(5,[2,3,4])
print *, 'box:'
do i=1,size(rectangle,dim=1)
write(*,'(*(i3,1x))')rectangle(i,:)
enddo
print *, 'make all values 0 or less:'
do i=1,size(rectangle,dim=1)
write(*,'(*(i3,1x))')min(rectangle(i,:),0)
enddo
end program demo_min
]]>
minloc
Source
<![CDATA[
program demo_minloc
implicit none
integer,save :: ints(3,5)= reshape([&
4, 10, 1, 7, 13, &
9, 15, 6, 12, 3, &
14, 5, 11, 2, 8 &
],shape(ints),order=[2,1])
write(*,*) minloc(ints)
write(*,*) minloc(ints,dim=1)
write(*,*) minloc(ints,dim=2)
! where in each column is the smallest number .gt. 10 ?
write(*,*) minloc(ints,dim=2,mask=ints.gt.10)
! a one-dimensional array with dim=1 explicitly listed returns a scalar
write(*,*) minloc(pack(ints,.true.),dim=1) ! scalar
end program demo_minloc
]]>
minval
Source
<![CDATA[
program demo_minval
implicit none
integer :: i
character(len=:),allocatable :: strs(:)
character(len=*),parameter :: g='(3x,*(g0,1x))'
integer,save :: ints(3,5)= reshape([&
1, -2, 3, 4, 5, &
10, 20, -30, 40, 50, &
11, 22, 33, -44, 55 &
],shape(ints),order=[2,1])
integer,save :: box(3,5,2)
box(:,:,1)=ints
box(:,:,2)=-ints
write(*,*)'Given the array'
write(*,'(1x,*(g4.4,1x))') &
& (ints(i,:),new_line('a'),i=1,size(ints,dim=1))
write(*,*)'What is the smallest element in the array?'
write(*,g) minval(ints),'at <',minloc(ints),'>'
write(*,*)'What is the smallest element in each column?'
write(*,g) minval(ints,dim=1)
write(*,*)'What is the smallest element in each row?'
write(*,g) minval(ints,dim=2)
! notice the shape of the output has less columns
! than the input in this case
write(*,*)'What is the smallest element in each column,'
write(*,*)'considering only those elements that are'
write(*,*)'greater than zero?'
write(*,g) minval(ints, dim=1, mask = ints > 0)
write(*,*)&
& 'if everything is false a zero-sized array is NOT returned'
write(*,*) minval(ints, dim=1, mask = .false.)
write(*,*)'even for a zero-sized input'
write(*,g) minval([integer ::], dim=1, mask = .false.)
write(*,*)'a scalar answer for everything false is huge()'
write(*,g) minval(ints, mask = .false.)
write(*,g) minval([integer ::], mask = .false.)
print *, 'if zero-size character array all dels if ASCII'
strs=[character(len=5)::]
strs=minval(strs)
print g, ichar([(strs(i),i=1,len(strs))])
write(*,*)'some calls with three dimensions'
write(*,g) minval(box, mask = .true. )
write(*,g) minval(box, dim=1, mask = .true. )
write(*,g) minval(box, dim=2, mask = .true. )
write(*,g) 'shape of answer is ', &
& shape(minval(box, dim=2, mask = .true. ))
end program demo_minval
]]>
mod
Source
<![CDATA[
program demo_mod
implicit none
! basics
print *, mod( -17, 3 ), modulo( -17, 3 )
print *, mod( 17, -3 ), modulo( 17, -3 )
print *, mod( 17, 3 ), modulo( 17, 3 )
print *, mod( -17, -3 ), modulo( -17, -3 )
print *, mod(-17.5, 5.2), modulo(-17.5, 5.2)
print *, mod( 17.5,-5.2), modulo( 17.5,-5.2)
print *, mod( 17.5, 5.2), modulo( 17.5, 5.2)
print *, mod(-17.5,-5.2), modulo(-17.5,-5.2)
! with a divisor of 1 the fractional part is returned
print *, mod(-17.5, 1.0), modulo(-17.5, 1.0)
print *, mod( 17.5,-1.0), modulo( 17.5,-1.0)
print *, mod( 17.5, 1.0), modulo( 17.5, 1.0)
print *, mod(-17.5,-1.0), modulo(-17.5,-1.0)
end program demo_mod
]]>
modulo
Source
<![CDATA[
program demo_modulo
implicit none
print *, modulo(17,3) ! yields 2
print *, modulo(17.5,5.5) ! yields 1.0
print *, modulo(-17,3) ! yields 1
print *, modulo(-17.5,5.5) ! yields 4.5
print *, modulo(17,-3) ! yields -1
print *, modulo(17.5,-5.5) ! yields -4.5
end program demo_modulo
]]>
move_alloc
Source
<![CDATA[
program demo_move_alloc
implicit none
! Example to allocate a bigger GRID
real, allocatable :: grid(:), tempgrid(:)
integer :: n, i
! initialize small GRID
n = 3
allocate (grid(1:n))
grid = [ (real (i), i=1,n) ]
! initialize TEMPGRID which will be used to replace GRID
allocate (tempgrid(1:2*n)) ! Allocate bigger grid
tempgrid(::2) = grid ! Distribute values to new locations
tempgrid(2::2) = grid + 0.5 ! initialize other values
! move TEMPGRID to GRID
call MOVE_ALLOC (from=tempgrid, to=grid)
! TEMPGRID should no longer be allocated
! and GRID should be the size TEMPGRID was
if (size (grid) /= 2*n .or. allocated (tempgrid)) then
print *, "Failure in move_alloc!"
endif
print *, allocated(grid), allocated(tempgrid)
print '(99f8.3)', grid
end program demo_move_alloc
]]>
mvbits
Source
<![CDATA[
program demo_mvbits
use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64
implicit none
integer(kind=int32) :: intfrom, intto, abcd_int
character(len=*),parameter :: bits= '(g0,t30,b32.32)'
character(len=*),parameter :: fmt= '(g0,t30,a,t40,b32.32)'
intfrom=huge(0) ! all bits are 1 accept the sign bit
intto=0 ! all bits are 0
!! CHANGE BIT 0
! show the value and bit pattern
write(*,bits)intfrom,intfrom
write(*,bits)intto,intto
! copy bit 0 from intfrom to intto to show the rightmost bit changes
! (from, frompos, len, to, topos)
call mvbits(intfrom, 0, 1, intto, 0) ! change bit 0
write(*,bits)intto,intto
!! COPY PART OF A VALUE TO ITSELF
! can copy bit from a value to itself
call mvbits(intfrom,0,1,intfrom,31)
write(*,bits)intfrom,intfrom
!! MOVING BYTES AT A TIME
! make native integer value with bit patterns
! that happen to be the same as the beginning of the alphabet
! to make it easy to see the bytes are reversed
abcd_int=transfer('abcd',0)
! show the value and bit pattern
write(*,*)'native'
write(*,fmt)abcd_int,abcd_int,abcd_int
! change endian of the value
abcd_int=int_swap32(abcd_int)
! show the values and their bit pattern
write(*,*)'non-native'
write(*,fmt)abcd_int,abcd_int,abcd_int
contains
pure elemental function int_swap32(intin) result(intout)
! Convert a 32 bit integer from big Endian to little Endian,
! or conversely from little Endian to big Endian.
!
integer(kind=int32), intent(in) :: intin
integer(kind=int32) :: intout
! copy bytes from input value to new position in output value
! (from, frompos, len, to, topos)
call mvbits(intin, 0, 8, intout, 24) ! byte1 to byte4
call mvbits(intin, 8, 8, intout, 16) ! byte2 to byte3
call mvbits(intin, 16, 8, intout, 8) ! byte3 to byte2
call mvbits(intin, 24, 8, intout, 0) ! byte4 to byte1
end function int_swap32
end program demo_mvbits
]]>
namelist
Source
<![CDATA[
program demo_namelist
implicit none
integer :: lun
! create a namelist and initialize the values
logical :: l=.true.
character(len=10) :: c='XXXXXXXXXX'
real :: r=12.3456
integer :: i=789
complex :: x=(12345.6789,9876.54321)
doubleprecision :: d= 123456789.123456789d0
integer :: a(5)=[1,2,3,4,5]
type point
integer :: x=0
integer :: y=0
character(len=10) :: color='red'
endtype point
type(point) :: dot
namelist /nlist/ l,c,r,i,x,d,a,dot
open(file='_tmp_',newunit=lun,action='readwrite')
write(*,*)'initial nlist'
write(*,nlist)
write(lun,nlist)
write(*,*)'change values and print nlist again'
a=[10,20,30,40,50]
dot%color='orange'
write(lun,nlist)
write(*,*)'read back values. Can have multiple sets in a file'
rewind(lun)
read(lun,nlist)
read(lun,nlist)
write(*,nlist)
end program demo_namelist
]]>
nearest
Source
<![CDATA[
program demo_nearest
implicit none
real :: x, y
x = nearest(42.0, 1.0)
y = nearest(42.0, -1.0)
write (*,"(3(g20.15))") x, y, x - y
! write (*,"(3(g20.15))") &
! nearest(tiny(0.0),1.0), &
! nearest(tiny(0.0),-1.0), &
! nearest(tiny(0.0),1.0) -nearest(tiny(0.0),-1.0)
! write (*,"(3(g20.15))") &
! nearest(huge(0.0),1.0), &
! nearest(huge(0.0),-1.0), &
! nearest(huge(0.0),1.0)- nearest(huge(0.0),-1.0)
end program demo_nearest
]]>
new_line
Source
<![CDATA[
program demo_new_line
implicit none
character,parameter :: nl=new_line('a')
character(len=:),allocatable :: string
real :: r
integer :: i, count
! basics
! print a string with a newline embedded in it
string='This is record 1.'//nl//'This is record 2.'
write(*,'(a)') string
! print a newline character string
write(*,'(*(a))',advance='no') &
nl,'This is record 1.',nl,'This is record 2.',nl
! output a number of words of random length as a paragraph
! by inserting a new_line before line exceeds 70 characters
! simplistic paragraph print using non-advancing I/O
count=0
do i=1,100
! make some fake word of random length
call random_number(r)
string=repeat('x',int(r*10)+1)
count=count+len(string)+1
if(count.gt.70)then
write(*,'(a)',advance='no')nl
count=len(string)+1
endif
write(*,'(1x,a)',advance='no')string
enddo
write(*,'(a)',advance='no')nl
end program demo_new_line
]]>
nint
Source
<![CDATA[
program demo_nint
implicit none
integer,parameter :: dp=kind(0.0d0)
real,allocatable :: in(:)
integer,allocatable :: out(:)
integer :: i
real :: x4
real(kind=dp) :: x8
! basic use
x4 = 1.234E0
x8 = 4.721_dp
print *, nint(x4), nint(-x4)
print *, nint(x8), nint(-x8)
! elemental
in = [ -2.7, -2.5, -2.2, -2.0, -1.5, -1.0, -0.5, -0.4, &
& 0.0, &
& +0.04, +0.5, +1.0, +1.5, +2.0, +2.2, +2.5, +2.7 ]
out = nint(in)
do i=1,size(in)
write(*,*)in(i),out(i)
enddo
! dusty corners
ISSUES: block
use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64
integer :: icheck
! make sure input is in range for the type returned
write(*,*)'Range limits for typical KINDS:'
write(*,'(1x,g0,1x,g0)') &
& int8,huge(0_int8), &
& int16,huge(0_int16), &
& int32,huge(0_int32), &
& int64,huge(0_int64)
! the standard does not require this to be an error ...
x8=12345.67e15 ! too big of a number
icheck=selected_int_kind(ceiling(log10(x8)))
write(*,*)'Any KIND big enough? ICHECK=',icheck
print *, 'These are all wrong answers for ',x8
print *, nint(x8,kind=int8)
print *, nint(x8,kind=int16)
print *, nint(x8,kind=int32)
print *, nint(x8,kind=int64)
endblock ISSUES
end program demo_nint
]]>
norm2
Source
<![CDATA[
program demo_norm2
implicit none
integer :: i
real :: x(2,3) = reshape([ &
1, 2, 3, &
4, 5, 6 &
],shape(x),order=[2,1])
write(*,*) 'input in row-column order'
write(*,*) 'x='
write(*,'(4x,3f4.0)')transpose(x)
write(*,*)
write(*,*) 'norm2(x)=',norm2(x)
write(*,*) 'which is equivalent to'
write(*,*) 'sqrt(sum(x**2))=',sqrt(sum(x**2))
write(*,*)
write(*,*) 'for reference the array squared is'
write(*,*) 'x**2='
write(*,'(4x,3f4.0)')transpose(x**2)
write(*,*)
write(*,*) 'norm2(x,dim=1)=',norm2(x,dim=1)
write(*,*) 'norm2(x,dim=2)=',norm2(x,dim=2)
write(*,*) '(sqrt(sum(x(:,i)**2)),i=1,3)=',(sqrt(sum(x(:,i)**2)),i=1,3)
write(*,*) '(sqrt(sum(x(i,:)**2)),i=1,2)=',(sqrt(sum(x(i,:)**2)),i=1,2)
end program demo_norm2
]]>
not
Source
<![CDATA[
program demo_not
implicit none
integer :: i
! basics
i=-13741
print *,'the input value',i,'represented in bits is'
write(*,'(1x,b32.32,1x,i0)') i, i
i=not(i)
print *,'on output it is',i
write(*,'(1x,b32.32,1x,i0)') i, i
print *, " on a two's complement machine flip the bits and add 1"
print *, " to get the value with the sign changed, for example."
print *, 1234, not(1234)+1
print *, -1234, not(-1234)+1
print *, " of course 'x=-x' works just fine and more generally."
end program demo_not
]]>
null
Source
<![CDATA[
!program demo_null
module showit
implicit none
private
character(len=*),parameter :: g='(*(g0,1x))'
public gen
! a generic interface that only differs in the
! type of the pointer the second argument is
interface gen
module procedure s1
module procedure s2
end interface
contains
subroutine s1 (j, pi)
integer j
integer, pointer :: pi
if(associated(pi))then
write(*,g)'Two integers in S1:,',j,'and',pi
else
write(*,g)'One integer in S1:,',j
endif
end subroutine s1
subroutine s2 (k, pr)
integer k
real, pointer :: pr
if(associated(pr))then
write(*,g)'integer and real in S2:,',k,'and',pr
else
write(*,g)'One integer in S2:,',k
endif
end subroutine s2
end module showit
program demo_null
use showit, only : gen
real,target :: x = 200.0
integer,target :: i = 100
real, pointer :: real_ptr
integer, pointer :: integer_ptr
! so how do we call S1() or S2() with a disassociated pointer?
! the answer is the null() function with a mold value
! since s1() and s2() both have a first integer
! argument the NULL() pointer must be associated
! to a real or integer type via the mold option
! so the following can distinguish whether s1(1)
! or s2() is called, even though the pointers are
! not associated or defined
call gen (1, null (real_ptr) ) ! invokes s2
call gen (2, null (integer_ptr) ) ! invokes s1
real_ptr => x
integer_ptr => i
call gen (3, real_ptr ) ! invokes s2
call gen (4, integer_ptr ) ! invokes s1
end program demo_null
]]>
num_images
Source
<![CDATA[
program demo_num_images
implicit none
integer :: value[*]
real :: p[*]
integer :: i
value = this_image()
sync all
if (this_image() == 1) then
do i = 1, num_images()
write(*,'(2(a,i0))') 'value[', i, '] is ', value[i]
end do
endif
! The following code uses image 1 to read data and
! broadcast it to other images.
if (this_image()==1) then
p=1234.5678
do i = 2, num_images()
p[i] = p
end do
end if
sync all
end program demo_num_images
]]>
open
Source
<![CDATA[
program demo_open
integer :: ios
character(len=256) :: message
integer :: lun
open ( &
& newunit=lun, &
& file='employee.names', &
& action='read', &
& iostat=ios, &
& iomsg=message)
if (ios < 0) then
! Perform end-of-file processing on the file connected to unit
call end_processing()
elseif (ios > 0) then
! Perform error processing
write(*,'(a)')trim(message)
call error_processing()
stop
else
write(*,*)'OPENED FILE'
endif
contains
!
subroutine end_processing()
write(*,*)'END OF FILE:',ios,'MESSAGE=',trim(message)
close(unit=lun,iostat=ios)
stop
end subroutine end_processing
!
subroutine error_processing()
write(*,*)'ERROR:',ios,'MESSAGE=',trim(message)
close(unit=lun,iostat=ios)
stop
end subroutine error_processing
!
end program demo_open
]]>
out_of_range
Source
<![CDATA[
program demo_out_of_range
use, intrinsic :: iso_fortran_env, only : int8, int16, int32, int64
use, intrinsic :: iso_fortran_env, only : real32, real64, real128
implicit none
integer :: i
integer(kind=int8) :: i8, j8
! compilers are not required to produce an error on out of range.
! here storing the default integers into 1-byte integers
! incorrectly can have unexpected results
do i=127,130
i8=i
j8=-i
! OUT_OF_RANGE(3) can let you check if the value will fit
write(*,*)i8,j8,' might have expected',i,-i, &
& out_of_range( i,i8), &
& out_of_range(-i,i8)
enddo
write(*,*) 'RANGE IS ',-1-huge(0_int8),'TO',huge(0_int8)
! the real -128.5 is truncated to -128 and is in range
write(*,*) out_of_range ( -128.5, 0_int8) ! false
! the real -128.5 is rounded to -129 and is not in range
write(*,*) out_of_range ( -128.5, 0_int8, .true.) ! true
end program demo_out_of_range
]]>
pack
Source
<![CDATA[
program demo_pack
implicit none
integer, allocatable :: m(:)
character(len=10) :: c(4)
! gathering nonzero elements from an array:
m = [ 1, 0, 0, 0, 5, 0 ]
write(*, fmt="(*(i0, ' '))") pack(m, m /= 0)
! Gathering nonzero elements from an array and appending elements
! from VECTOR till the size of the mask array (or array size if the
! mask is scalar):
m = [ 1, 0, 0, 2 ]
write(*, fmt="(*(i0, ' '))") pack(m, m /= 0, [ 0, 0, 3, 4 ])
write(*, fmt="(*(i0, ' '))") pack(m, m /= 0 )
! select strings whose second character is "a"
c = [ character(len=10) :: 'ape', 'bat', 'cat', 'dog']
write(*, fmt="(*(g0, ' '))") pack(c, c(:)(2:2) == 'a' )
! creating a quicksort using PACK(3f)
block
intrinsic random_seed, random_number
real :: x(10)
call random_seed()
call random_number(x)
write (*,"(a10,*(1x,f0.3))") "initial",x
write (*,"(a10,*(1x,f0.3))") "sorted",qsort(x)
endblock
contains
!
! concise quicksort from @arjen and @beliavsky shows recursion,
! array sections, and vectorized comparisons.
!
pure recursive function qsort(values) result(sorted)
intrinsic pack, size
real, intent(in) :: values(:)
real :: sorted(size(values))
if (size(values) > 1) then
sorted = &
& [qsort(pack(values(2:),values(2:)<values(1))), values(1), &
& qsort(pack(values(2:),values(2:)>=values(1)))]
else
sorted = values
endif
end function qsort
end program demo_pack
]]>
parity
Source
<![CDATA[
program demo_parity
implicit none
logical, parameter :: T=.true., F=.false.
logical :: x(3,4)
! basics
print *, parity([T,F])
print *, parity([T,F,F])
print *, parity([T,F,F,T])
print *, parity([T,F,F,T,T])
x(1,:)=[T,T,T,T]
x(2,:)=[T,T,T,T]
x(3,:)=[T,T,T,T]
print *, parity(x)
print *, parity(x,dim=1)
print *, parity(x,dim=2)
end program demo_parity
]]>
popcnt
Source
<![CDATA[
program demo_popcnt
use, intrinsic :: iso_fortran_env, only : integer_kinds, &
& int8, int16, int32, int64
implicit none
character(len=*),parameter :: pretty='(b64,1x,i0)'
! basic usage
print pretty, 127, popcnt(127)
print pretty, int(b"01010"), popcnt(int(b"01010"))
! any kind of an integer can be used
print pretty, huge(0_int8), popcnt(huge(0_int8))
print pretty, huge(0_int16), popcnt(huge(0_int16))
print pretty, huge(0_int32), popcnt(huge(0_int32))
print pretty, huge(0_int64), popcnt(huge(0_int64))
end program demo_popcnt
]]>
poppar
Source
<![CDATA[
program demo_poppar
use, intrinsic :: iso_fortran_env, only : integer_kinds, &
& int8, int16, int32, int64
implicit none
character(len=*),parameter :: pretty='(b64,1x,i0)'
! basic usage
print pretty, 127, poppar(127)
print pretty, 128, poppar(128)
print pretty, int(b"01010"), poppar(int(b"01010"))
! any kind of an integer can be used
print pretty, huge(0_int8), poppar(huge(0_int8))
print pretty, huge(0_int16), poppar(huge(0_int16))
print pretty, huge(0_int32), poppar(huge(0_int32))
print pretty, huge(0_int64), poppar(huge(0_int64))
end program demo_poppar
]]>
precision
Source
<![CDATA[
program demo_precision
use,intrinsic :: iso_fortran_env, only : dp=>real64,sp=>real32
implicit none
real(kind=sp) :: x(2)
complex(kind=dp) :: y
print *, precision(x), range(x)
print *, precision(y), range(y)
end program demo_precision
]]>
present
Source
<![CDATA[
program demo_present
implicit none
integer :: answer
! argument to func() is not present
answer=func()
write(*,*) answer
! argument to func() is present
answer=func(1492)
write(*,*) answer
contains
!
integer function func(x)
! the optional characteristic on this definition allows this variable
! to not be specified on a call; and also allows it to subsequently
! be passed to PRESENT(3):
integer, intent(in), optional :: x
integer :: x_local
!
! basic
if(present(x))then
! if present, you can use x like any other variable.
x_local=x
else
! if not, you cannot define or reference x except to
! pass it as an optional parameter to another procedure
! or in a call to present(3)
x_local=0
endif
!
func=x_local**2
!
! passing the argument on to other procedures
! so something like this is a bad idea because x is used
! as the first argument to merge(3) when it might not be
! present
! xlocal=merge(x,0,present(x)) ! NO!!
!
! We can pass it to another procedure if another
! procedure declares the argument as optional as well,
! or we have tested that X is present
call tattle('optional argument x',x)
if(present(x))call not_optional(x)
end function
!
subroutine tattle(label,arg)
character(len=*),intent(in) :: label
integer,intent(in),optional :: arg
if(present(arg))then
write(*,*)label,' is present'
else
write(*,*)label,' is not present'
endif
end subroutine tattle
!
subroutine not_optional(arg)
integer,intent(in) :: arg
write(*,*)'already tested X is defined',arg
end subroutine not_optional
!
end program demo_present
]]>
print
Source
<![CDATA[
program demo_print
implicit none
real :: a=11.11, s=sqrt(12.0)
integer :: j=753210
character(len=*),parameter :: commas='(*(g0:,","))'
! List-directed output is frequently specified
PRINT *, A, S
! a format may be placed on the print(7f) statement
PRINT '(*(g0,1x))', A, S, J
! the format may be in a character variable
print commas, a, s, j
! or may be in a labeled format statement
PRINT 10, A, S, J
10 FORMAT (2E16.3,1x,I0)
end program demo_print
]]>
product
Source
<![CDATA[
program demo_product
implicit none
character(len=*),parameter :: all='(*(g0,1x))' ! a handy format
character(len=1),parameter :: nl=new_line('a')
NO_DIM: block
! If DIM is not specified, the result is the product of all the
! selected array elements.
integer :: i,n, p1, p2
integer,allocatable :: array(:)
! all elements are selected by default
do n=1,10
print all, 'factorial of ',n,' is ', product([(real(i),i=1,n)])
enddo
! using a mask
array=[10,12,13,15,20,25,30]
p1=product(array, mask=mod(array, 2)==1) ! only odd elements
p2=product(array, mask=mod(array, 2)/=1) ! only even elements
print all, nl,'product of all elements',product(array) ! all elements
print all, ' odd * even =',nl,p1,'*',p2,'=',p1*p2
! NOTE: If ARRAY is a zero-sized array, the result is equal to one
print all
print all, 'zero-sized array=>',product([integer :: ])
! NOTE: If nothing in the mask is true, this also results in a null
! array
print all, 'all elements have a false mask=>', &
& product(array,mask=.false.)
endblock NO_DIM
WITH_DIM: block
integer :: rect(2,3)
integer :: box(2,3,4)
! lets fill a few arrays
rect = reshape([ &
1, 2, 3, &
4, 5, 6 &
],shape(rect),order=[2,1])
call print_matrix_int('rect',rect)
! Find the product of each column in RECT.
print all, 'product of columns=',product(rect, dim = 1)
! Find the product of each row in RECT.
print all, 'product of rows=',product(rect, dim = 2)
! now lets try a box
box(:,:,1)=rect
box(:,:,2)=rect*(+10)
box(:,:,3)=rect*(-10)
box(:,:,4)=rect*2
! lets look at the values
call print_matrix_int('box 1',box(:,:,1))
call print_matrix_int('box 2',box(:,:,2))
call print_matrix_int('box 3',box(:,:,3))
call print_matrix_int('box 4',box(:,:,4))
! remember without dim= even a box produces a scalar
print all, 'no dim gives a scalar',product(real(box))
! only one plane has negative values, so note all the "1" values
! for vectors with no elements
call print_matrix_int('negative values', &
& product(box,mask=box < 0,dim=1))
! If DIM is specified and ARRAY has rank greater than one, the
! result is a new array in which dimension DIM has been eliminated.
! pick a dimension to multiply though
call print_matrix_int('dim=1',product(box,dim=1))
call print_matrix_int('dim=2',product(box,dim=2))
call print_matrix_int('dim=3',product(box,dim=3))
endblock WITH_DIM
contains
subroutine print_matrix_int(title,arr)
implicit none
!@(#) print small 2d integer arrays in row-column format
character(len=*),intent(in) :: title
integer,intent(in) :: arr(:,:)
integer :: i
character(len=:),allocatable :: biggest
print all
print all, trim(title),':(',shape(arr),')' ! print title
biggest=' ' ! make buffer to write integer into
! find how many characters to use for integers
write(biggest,'(i0)')ceiling(log10(max(1.0,real(maxval(abs(arr))))))+2
! use this format to write a row
biggest='(" > [",*(i'//trim(biggest)//':,","))'
! print one row of array at a time
do i=1,size(arr,dim=1)
write(*,fmt=biggest,advance='no')arr(i,:)
write(*,'(" ]")')
enddo
end subroutine print_matrix_int
end program demo_product
]]>
program
Source
<![CDATA[
]]>
radix
Source
<![CDATA[
program demo_radix
implicit none
print *, "The radix for the default integer kind is", radix(0)
print *, "The radix for the default real kind is", radix(0.0)
print *, "The radix for the doubleprecision real kind is", radix(0.0d0)
end program demo_radix
]]>
random_init
Source
<![CDATA[
program demo_random_init
implicit none
real x(3), y(3)
call random_init(.true., .true.)
call random_number(x)
call random_init(.true., .true.)
call random_number(y)
! x and y should be the same sequence
if ( any(x /= y) ) stop "x(:) and y(:) are not all equal"
write(*,*)x
write(*,*)y
end program demo_random_init
]]>
random_number
Source
<![CDATA[
program demo_random_number
use, intrinsic :: iso_fortran_env, only : dp=>real64
implicit none
integer, allocatable :: seed(:)
integer :: n
integer :: first,last
integer :: i
integer :: rand_int
integer,allocatable :: count(:)
real(kind=dp) :: rand_val
call random_seed(size = n)
allocate(seed(n))
call random_seed(get=seed)
first=1
last=10
allocate(count(last-first+1))
! To have a discrete uniform distribution on the integers
! [first, first+1, ..., last-1, last] carve the continuous
! distribution up into last+1-first equal sized chunks,
! mapping each chunk to an integer.
!
! One way is:
! call random_number(rand_val)
! choose one from last-first+1 integers
! rand_int = first + FLOOR((last+1-first)*rand_val)
count=0
! generate a lot of random integers from 1 to 10 and count them.
! with a large number of values you should get about the same
! number of each value
do i=1,100000000
call random_number(rand_val)
rand_int=first+floor((last+1-first)*rand_val)
if(rand_int.ge.first.and.rand_int.le.last)then
count(rand_int)=count(rand_int)+1
else
write(*,*)rand_int,' is out of range'
endif
enddo
write(*,'(i0,1x,i0)')(i,count(i),i=1,size(count))
end program demo_random_number
]]>
random_seed
Source
<![CDATA[
program demo_random_seed
implicit none
integer, allocatable :: seed(:)
integer :: n
call random_seed(size = n)
allocate(seed(n))
call random_seed(get=seed)
write (*, *) seed
end program demo_random_seed
]]>
range
Source
<![CDATA[
program demo_range
use,intrinsic :: iso_fortran_env, only : dp=>real64,sp=>real32
implicit none
real(kind=sp) :: x(2)
complex(kind=dp) :: y
print *, precision(x), range(x)
print *, precision(y), range(y)
end program demo_range
]]>
rank
Source
<![CDATA[
program demo_rank
implicit none
! a bunch of data objects to query
integer :: a
real, allocatable :: b(:,:)
real, pointer :: c(:)
complex :: d
! make up a type
type mytype
integer :: int
real :: float
character :: char
end type mytype
type(mytype) :: any_thing(1,2,3,4,5)
! basics
print *, 'rank of scalar a=',rank(a)
! you can query this array even though it is not allocated
print *, 'rank of matrix b=',rank(b)
print *, 'rank of vector pointer c=',rank(c)
print *, 'rank of complex scalar d=',rank(d)
! you can query any type, not just intrinsics
print *, 'rank of any arbitrary type=',rank(any_thing)
! an assumed-rank object may be queried
call query_int(10)
call query_int([20,30])
call query_int( reshape([40,50,60,70],[2,2]) )
! you can even query an unlimited polymorphic entity
call query_anything(10.0)
call query_anything([.true.,.false.])
call query_anything( reshape([40.0,50.0,60.0,70.0],[2,2]) )
contains
subroutine query_int(data_object)
! It is hard to do much with something dimensioned
! name(..) if not calling C except inside of a
! SELECT_RANK construct but one thing you can
! do is call the inquiry functions ...
integer,intent(in) :: data_object(..)
character(len=*),parameter :: all='(*(g0,1x))'
if(rank(data_object).eq.0)then
print all,&
& 'passed a scalar to an assumed rank, &
& rank=',rank(data_object)
else
print all,&
& 'passed an array to an assumed rank, &
& rank=',rank(data_object)
endif
end subroutine query_int
subroutine query_anything(data_object)
class(*),intent(in) ::data_object(..)
character(len=*),parameter :: all='(*(g0,1x))'
if(rank(data_object).eq.0)then
print all,&
&'passed a scalar to an unlimited polymorphic rank=', &
& rank(data_object)
else
print all,&
& 'passed an array to an unlimited polymorphic, rank=', &
& rank(data_object)
endif
end subroutine query_anything
end program demo_rank
]]>
read
Source
<![CDATA[
]]>
real
Source
<![CDATA[
program demo_real
use,intrinsic :: iso_fortran_env, only : dp=>real64
implicit none
complex :: zr = (1.0, 2.0)
doubleprecision :: xd=huge(3.0d0)
complex(kind=dp) :: zd=cmplx(4.0e0_dp,5.0e0_dp,kind=dp)
print *, real(zr), aimag(zr)
print *, dble(zd), aimag(zd)
write(*,*)xd,real(xd,kind=kind(0.0d0)),dble(xd)
end program demo_real
]]>
reduce
Source
<![CDATA[
program demo_reduce
implicit none
character(len=*),parameter :: f='("[",*(g0,",",1x),"]")'
integer,allocatable :: arr(:), b(:,:)
! Basic usage:
! the product of the elements of an array
arr=[1, 2, 3, 4 ]
write(*,*) arr
write(*,*) 'product=', reduce(arr, my_mult)
write(*,*) 'sum=', reduce(arr, my_sum)
! Examples of masking:
! the product of only the positive elements of an array
arr=[1, -1, 2, -2, 3, -3 ]
write(*,*)'positive value product=',reduce(arr, my_mult, mask=arr>0)
! sum values ignoring negative values
write(*,*)'sum positive values=',reduce(arr, my_sum, mask=arr>0)
! a single-valued array returns the single value as the
! calls to the operator stop when only one element remains
arr=[ 1234 ]
write(*,*)'single value sum',reduce(arr, my_sum )
write(*,*)'single value product',reduce(arr, my_mult )
! Example of operations along a dimension:
! If B is the array 1 3 5
! 2 4 6
b=reshape([1,2,3,4,5,6],[2,3])
write(*,f) REDUCE(B, MY_MULT),'should be [720]'
write(*,f) REDUCE(B, MY_MULT, DIM=1),'should be [2,12,30]'
write(*,f) REDUCE(B, MY_MULT, DIM=2),'should be [15, 48]'
contains
pure function my_mult(a,b) result(c)
integer,intent(in) :: a, b
integer :: c
c=a*b
end function my_mult
pure function my_sum(a,b) result(c)
integer,intent(in) :: a, b
integer :: c
c=a+b
end function my_sum
end program demo_reduce
]]>
repeat
Source
<![CDATA[
program demo_repeat
implicit none
write(*,'(a)') repeat("^v", 35) ! line break
write(*,'(a)') repeat("_", 70) ! line break
write(*,'(a)') repeat("1234567890", 7) ! number line
write(*,'(a)') repeat(" |", 7) !
end program demo_repeat
]]>
reshape
Source
<![CDATA[
program demo_reshape
implicit none
! notice the use of "shape(box)" on the RHS
integer :: box(3,4)=reshape([1,2,3,4,5,6,7,8,9,10,11,12],shape(box))
integer,allocatable :: v(:,:)
integer :: rc(2)
! basics0
! what is the current shape of the array?
call printi('shape of box is ',box)
! change the shape
call printi('reshaped ',reshape(box,[2,6]))
call printi('reshaped ',reshape(box,[4,3]))
! fill in row column order using order
v=reshape([1,2,3,4,10,20,30,40,100,200,300,400],[1,12])
call printi('here is some data to shape',v)
call printi('normally fills columns first ',reshape([v],[3,4]))
call printi('fill rows first', reshape([v],[3,4],order=[2,1]))
! if we take the data and put in back in filling
! rows first instead of columns, and flipping the
! height and width of the box we not only fill in
! a vector using row-column order we actually
! transpose it.
rc(2:1:-1)=shape(box)
! copy the data in changing column number fastest
v=reshape(box,rc,order=[2,1])
call printi('reshaped and reordered',v)
! of course we could have just done a transpose
call printi('transposed',transpose(box))
! making the result bigger than source using pad
v=reshape(box,rc*2,pad=[-1,-2,-3],order=[2,1])
call printi('bigger and padded and reordered',v)
contains
subroutine printi(title,arr)
implicit none
!@(#) print small 2d integer arrays in row-column format
character(len=*),parameter :: all='(*(g0,1x))' ! a handy format
character(len=*),intent(in) :: title
integer,intent(in) :: arr(:,:)
integer :: i
character(len=:),allocatable :: biggest
print all
print all, trim(title),':(',shape(arr),')' ! print title
biggest=' ' ! make buffer to write integer into
! find how many characters to use for integers
write(biggest,'(i0)')ceiling(log10(max(1.0,real(maxval(abs(arr))))))+2
! use this format to write a row
biggest='(" > [",*(i'//trim(biggest)//':,","))'
! print one row of array at a time
do i=1,size(arr,dim=1)
write(*,fmt=biggest,advance='no')arr(i,:)
write(*,'(" ]")')
enddo
end subroutine printi
end program demo_reshape
]]>
return
Source
<![CDATA[
program demo_return
call tryreturn(1)
write(*,*)'back at main program:1'
call tryreturn(10)
write(*,*)'back at main program:10'
contains
subroutine tryreturn(i)
integer,intent(in) :: i
select case(i)
case(1)
write(*,*)'*one*'
return
case(2)
write(*,*)'*two*'
return
case default
write(*,*)'*unexpected value*'
end select
write(*,*)'*<ERROR> should not get here*'
end subroutine tryreturn
end program demo_return
]]>
rewind
Source
<![CDATA[
program demo_rewind
implicit none
character(len=256) :: line
character(len=256) :: mssge
integer :: i
integer :: ios
open (10, file='demo_rewind.txt') ! open a file
do i = 1, 100 ! write lines to it
write (10, '(a,i0)') 'line ', i
enddo
rewind (10, iostat=ios, iomsg=mssge)
if (ios .ne. 0) then
write (*, *) '*error* ', trim(mssge)
stop
endif
write (*, *) 'wrote 100 lines, but now at line ...'
read (10, '(a)') line
write (*, '(a)') line
read (10)
read (10)
read (10)
write (*, *) 'skipped a few lines, now at ...'
read (10, '(a)') line
write (*, '(a)') line
close (10, status='delete')
end program demo_rewind
]]>
rrspacing
Source
<![CDATA[
program demo_rrspacing
implicit none
integer, parameter :: sgl = selected_real_kind(p=6, r=37)
integer, parameter :: dbl = selected_real_kind(p=13, r=200)
character(len=*),parameter :: gen='(*(g0))', nl=new_line('A')
real(kind=sgl) :: x
x=-3.0_sgl
print gen, &
'rrspacing(',x,'_sgl)=', rrspacing(x), nl, &
'rrspacing(x)=abs(fraction(x))*float(radix(x))**digits(x)', nl, &
'so this should be the same as rrspacing():', nl, &
abs( fraction(x) ) * float( radix(x) )**digits(x), nl, &
'RRSPACING (-3.0) has the value 0.75x2**24 for reals', nl, &
'on current typical platforms. For reference:', nl, &
' 0.75*2**24=', 0.75*2**24, nl, &
'sign should not matter, so',rrspacing(x)==rrspacing(-x), nl, &
'note the kind of the value is significant', nl, &
rrspacing(-3.0_dbl), nl, &
'for common platforms rrspacing(487923.3d0)=>', nl, &
' 8.382458680573952E+015', nl, &
rrspacing(487923.3d0), nl, &
' '
end program demo_rrspacing
]]>
same_type_as
Source
<![CDATA[
! program demo_same_type_as
module M_ether
implicit none
private
type :: dot
real :: x=0
real :: y=0
end type dot
type, extends(dot) :: point
real :: z=0
end type point
type something_else
end type something_else
public :: dot
public :: point
public :: something_else
end module M_ether
program demo_same_type_as
use M_ether, only : dot, point, something_else
implicit none
type(dot) :: dad, mom
type(point) :: me
type(something_else) :: alien
write(*,*)same_type_as(me,dad),'I am descended from Dad, but equal?'
write(*,*)same_type_as(me,me) ,'I am what I am'
write(*,*)same_type_as(dad,mom) ,'what a pair!'
write(*,*)same_type_as(dad,me),'no paradox here'
write(*,*)same_type_as(dad,alien),'no relation'
call pointers()
contains
subroutine pointers()
! Given the declarations and assignments
type t1
real c
end type
type, extends(t1) :: t2
end type
class(t1), pointer :: p, q, r
allocate (p, q)
allocate (t2 :: r)
! the result of SAME_TYPE_AS (P, Q) will be true, and the result
! of SAME_TYPE_AS (P, R) will be false.
write(*,*)'(P,Q)',same_type_as(p,q),"mind your P's and Q's"
write(*,*)'(P,R)',same_type_as(p,r)
end subroutine pointers
end program demo_same_type_as
]]>
scale
Source
<![CDATA[
program demo_scale
implicit none
real :: x
complex :: c
integer :: i
x = 1.0
print *, (scale(x,i),i=1,5)
x = 3.0
print *, (scale(x,i),i=1,5)
print *, (scale(log(1.0),i),i=1,5)
! on modern machines radix(x) is almost certainly 2
x = 178.1387e-4
i = 5
print *, x, i, scale(x, i), x*radix(x)**i
! x*radix(x)**i is the same except roundoff errors are not restricted
i = 2
print *, x, i, scale(x, i), x*radix(x)**i
! relatively easy to do complex values as well
c=(3.0,4.0)
print *, c, i, scale_complex(c, i)!, c*radix(c)**i
contains
function scale_complex(x, n)
! example supporting complex value for default kinds
complex, intent(in) :: x
integer, intent(in) :: n
complex :: scale_complex
scale_complex=cmplx(scale(x%re, n), scale(x%im, n), kind=kind(x%im))
end function scale_complex
end program demo_scale
]]>
scan
Source
<![CDATA[
program demo_scan
implicit none
write(*,*) scan("fortran", "ao") ! 2, found 'o'
write(*,*) scan("fortran", "ao", .true.) ! 6, found 'a'
write(*,*) scan("fortran", "c++") ! 0, found none
end program demo_scan
]]>
select_case
Source
<![CDATA[
]]>
selected_char_kind
Source
<![CDATA[
program demo_selected_char_kind
use iso_fortran_env, only: output_unit, CHARACTER_KINDS
implicit none
intrinsic date_and_time, selected_char_kind
! set some aliases for common character kinds
! as the numbers can vary from platform to platform
integer, parameter :: default = selected_char_kind ("default")
integer, parameter :: ascii = selected_char_kind ("ascii")
integer, parameter :: ucs4 = selected_char_kind ('ISO_10646')
integer, parameter :: utf8 = selected_char_kind ('utf-8')
! assuming ASCII and UCS4 are supported (ie. not equal to -1)
! define some string variables
character(len=26, kind=ascii ) :: alphabet
character(len=30, kind=ucs4 ) :: hello_world
character(len=30, kind=ucs4 ) :: string
write(*,'(*(g0,1x))')'Available CHARACTER kind values:',CHARACTER_KINDS
write(*,*)'ASCII ',&
& merge('Supported ','Not Supported',ascii /= -1)
write(*,*)'ISO_10646 ',&
& merge('Supported ','Not Supported',ucs4 /= -1)
write(*,*)'UTF-8 ',&
& merge('Supported ','Not Supported',utf8 /= -1)
if(default.eq.ascii)then
write(*,*)'ASCII is the default on this processor'
endif
! for constants the kind precedes the value, somewhat like a
! BOZ constant
alphabet = ascii_"abcdefghijklmnopqrstuvwxyz"
write (*,*) alphabet
hello_world = ucs4_'Hello World and Ni Hao -- ' &
// char (int (z'4F60'), ucs4) &
// char (int (z'597D'), ucs4)
! an encoding option is required on OPEN for non-default I/O
if(ucs4 /= -1 )then
open (output_unit, encoding='UTF-8')
write (*,*) trim (hello_world)
else
write (*,*) 'cannot use utf-8'
endif
call create_date_string(string)
write (*,*) trim (string)
contains
! The following produces a Japanese date stamp.
subroutine create_date_string(string)
intrinsic date_and_time,selected_char_kind
integer,parameter :: ucs4 = selected_char_kind("ISO_10646")
character(len=1,kind=ucs4),parameter :: &
nen = char(int( z'5e74' ),ucs4), & ! year
gatsu = char(int( z'6708' ),ucs4), & ! month
nichi = char(int( z'65e5' ),ucs4) ! day
character(len= *, kind= ucs4) string
integer values(8)
call date_and_time(values=values)
write(string,101) values(1),nen,values(2),gatsu,values(3),nichi
101 format(*(i0,a))
end subroutine create_date_string
end program demo_selected_char_kind
]]>
selected_int_kind
Source
<![CDATA[
program demo_selected_int_kind
use iso_fortran_env, only: output_unit, INTEGER_KINDS
use,intrinsic :: iso_fortran_env, only : compiler_version
implicit none
character(len=*),parameter :: all='(*(g0))'
integer,parameter :: k5 = selected_int_kind(5)
integer,parameter :: k15 = selected_int_kind(15)
integer :: i, ii
integer(kind=k5) :: i5
integer(kind=k15) :: i15
! write a program that can print attributes about each available kind
print all,'program kinds'
print all, &
'! This file was written by ', compiler_version()
do i=1,size(INTEGER_KINDS)
ii=integer_kinds(i)
print all,'integer,parameter :: i',ii,'=',ii
enddo
do i=1,size(INTEGER_KINDS)
ii=integer_kinds(i)
print all, &
'write(*,*)"huge(0_i', &
ii, &
')=",huge(0_i', &
ii, &
')'
enddo
print all,'end program kinds'
print *
print *, huge(i5), huge(i15)
! the following inequalities are always true
print *, huge(i5) >= 10_k5**5-1
print *, huge(i15) >= 10_k15**15-1
end program demo_selected_int_kind
]]>
selected_real_kind
Source
<![CDATA[
program demo_selected_real_kind
use, intrinsic :: iso_fortran_env
implicit none
integer,parameter :: p6 = selected_real_kind(6)
integer,parameter :: p10r100 = selected_real_kind(10,100)
integer,parameter :: r400 = selected_real_kind(r=400)
real(kind=p6) :: x
real(kind=p10r100) :: y
real(kind=r400) :: z
write(*,*) 'real_kinds =', real_kinds(:)
write(*,*) 'real constants=', real16, real32, real64, real128 !, bfloat16
write(*,*) 'integer_kinds=', integer_kinds(:)
write(*,*) 'int constants=', int8, int16, int32, int64 !, int128
print *, precision(x), range(x)
print *, precision(y), range(y)
print *, precision(z), range(z)
end program demo_selected_real_kind
]]>
select
Source
<![CDATA[
]]>
set_exponent
Source
<![CDATA[
program demo_setexp
implicit none
real :: x = 178.1387e-4
integer :: i = 17
print *, set_exponent(x, i), fraction(x) * real(radix(x))**i
end program demo_setexp
]]>
shape
Source
<![CDATA[
program demo_shape
implicit none
character(len=*),parameter :: all='(*(g0,1x))'
integer, dimension(-1:1, -1:2) :: a
print all, 'shape of array=',shape(a)
print all, 'shape of constant=',shape(42)
print all, 'size of shape of constant=',size(shape(42))
print all, 'ubound of array=',ubound(a)
print all, 'lbound of array=',lbound(a)
end program demo_shape
]]>
shifta
Source
<![CDATA[
program demo_shifta
use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64
implicit none
integer(kind=int32) :: ival
integer :: shift
integer(kind=int32) :: oval
integer(kind=int32),allocatable :: ivals(:)
integer :: i
integer(kind=int8) :: arr(2,2)=reshape([2,4,8,16],[2,2])
! basic usage
write(*,*)shifta(100,3)
! loop through some interesting values
shift=5
ivals=[ -1, -0, +0, +1, &
& int(b"01010101010101010101010101010101"), &
& int(b"10101010101010101010101010101010"), &
& int(b"00000000000000000000000000011111") ]
! does your platform distinguish between +0 and -0?
! note the original leftmost bit is used to fill in the vacated bits
write(*,'(/,"SHIFT = ",i0)') shift
do i=1,size(ivals)
ival=ivals(i)
write(*,'( "I = ",b32.32," == ",i0)') ival,ival
oval=shifta(ival,shift)
write(*,'( "RESULT = ",b32.32," == ",i0)') oval,oval
enddo
! elemental
write(*,*)"characteristics of the result are the same as input"
write(*,'(*(g0,1x))') &
& "kind=",kind(shifta(arr,3)), "shape=",shape(shifta(arr,3)), &
& "size=",size(shifta(arr,3)) !, "rank=",rank(shifta(arr,3))
end program demo_shifta
]]>
shiftl
Source
<![CDATA[
program demo_shiftl
use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64
implicit none
integer :: shift
integer(kind=int32) :: oval
integer(kind=int32) :: ival
integer(kind=int32),allocatable :: ivals(:)
integer :: i
print *, ' basic usage'
ival=100
write(*,*)ival, shiftl(ival,3)
! elemental (input values may be conformant arrays)
print *, ' elemental'
! loop through some ivalues
shift=9
ivals=[ &
& int(b"01010101010101010101010101010101"), &
& int(b"10101010101010101010101010101010"), &
& int(b"11111111111111111111111111111111") ]
write(*,'(/,"SHIFT = ",i0)') shift
do i=1,size(ivals)
! print initial value as binary and decimal
write(*,'( "I = ",b32.32," == ",i0)') ivals(i),ivals(i)
! print shifted value as binary and decimal
oval=shiftl(ivals(i),shift)
write(*,'( "RESULT = ",b32.32," == ",i0)') oval,oval
enddo
! more about elemental
ELEM : block
integer(kind=int8) :: arr(2,2)=reshape([2,4,8,16],[2,2])
write(*,*)"characteristics of the result are the same as input"
write(*,'(*(g0,1x))') &
& "kind=",kind(shiftl(arr,3)), "shape=",shape(shiftl(arr,3)), &
& "size=",size(shiftl(arr,3)) !, "rank=",rank(shiftl(arr,3))
endblock ELEM
end program demo_shiftl
]]>
shiftr
Source
<![CDATA[
program demo_shiftr
use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64
implicit none
integer :: shift
integer(kind=int32) :: oval
integer(kind=int32) :: ival
integer(kind=int32),allocatable :: ivals(:)
integer :: i
print *,' basic usage'
ival=100
write(*,*)ival, shiftr(100,3)
! elemental (input values may be conformant arrays)
print *,' elemental'
shift=9
ivals=[ &
& int(b"01010101010101010101010101010101"), &
& int(b"10101010101010101010101010101010"), &
& int(b"11111111111111111111111111111111") ]
write(*,'(/,"SHIFT = ",i0)') shift
do i=1,size(ivals)
! print initial value as binary and decimal
write(*,'( "I = ",b32.32," == ",i0)') ivals(i),ivals(i)
! print shifted value as binary and decimal
oval=shiftr(ivals(i),shift)
write(*,'( "RESULT = ",b32.32," == ",i0,/)') oval,oval
enddo
! more on elemental
ELEM : block
integer(kind=int8) :: arr(2,2)=reshape([2,4,8,16],[2,2])
write(*,*)"characteristics of the result are the same as input"
write(*,'(*(g0,1x))') &
& "kind=",kind(shiftr(arr,3)), "shape=",shape(shiftr(arr,3)), &
& "size=",size(shiftr(arr,3)) !, "rank=",rank(shiftr(arr,3))
endblock ELEM
end program demo_shiftr
]]>
sign
Source
<![CDATA[
program demo_sign
implicit none
! basics
print *, sign( -12, 1 )
print *, sign( -12, 0 )
print *, sign( -12, -1 )
print *, sign( 12, 1 )
print *, sign( 12, 0 )
print *, sign( 12, -1 )
if(sign(1.0,-0.0)== -1.0)then
print *, 'this processor distinguishes +0 from -0'
else
print *, 'this processor does not distinguish +0 from -0'
endif
print *, 'elemental', sign( -12.0, [1.0, 0.0, -1.0] )
end program demo_sign
]]>
sind
Source
<![CDATA[
program demo_sin
implicit none
real :: d
d = haversine(36.12,-86.67, 33.94,-118.40) ! BNA to LAX
print '(A,F9.4,A)', 'distance: ',d,' km'
contains
function haversine(latA,lonA,latB,lonB) result (dist)
!
! calculate great circle distance in kilometers
! given latitude and longitude in degrees
!
real,intent(in) :: latA,lonA,latB,lonB
real :: a,c,dist,delta_lat,delta_lon,lat1,lat2
real,parameter :: radius = 6371 ! mean earth radius in kilometers,
! recommended by the International Union of Geodesy and Geophysics
delta_lat = latB-latA
delta_lon = lonB-lonA
lat1 = latA
lat2 = latB
a = (sind(delta_lat/2))**2 + &
& cosd(lat1)*cosd(lat2)*(sind(delta_lon/2))**2
c = 2*asin(sqrt(a))
dist = radius*c
end function haversine
end program demo_sin
]]>
sin
Source
<![CDATA[
program demo_sin
implicit none
real :: d
d = haversine(36.12,-86.67, 33.94,-118.40) ! BNA to LAX
print '(*(A,1x,F9.4,1x))','distance:',d,'km, or',d*0.62137119,'miles'
contains
function haversine(latA,lonA,latB,lonB) result (dist)
!
! calculate great circle distance in kilometers
! given latitude and longitude in degrees
!
real,intent(in) :: latA,lonA,latB,lonB
real :: a,c,dist,delta_lat,delta_lon,lat1,lat2
real,parameter :: radius = 6371 ! mean earth radius in kilometers,
! recommended by the International Union of Geodesy and Geophysics
! generate constant pi/180
real, parameter :: deg_to_rad = atan(1.0)/45.0
delta_lat = deg_to_rad*(latB-latA)
delta_lon = deg_to_rad*(lonB-lonA)
lat1 = deg_to_rad*(latA)
lat2 = deg_to_rad*(latB)
a = (sin(delta_lat/2))**2 + &
& cos(lat1)*cos(lat2)*(sin(delta_lon/2))**2
c = 2*asin(sqrt(a))
dist = radius*c
end function haversine
end program demo_sin
]]>
sinh
Source
<![CDATA[
program demo_sinh
use, intrinsic :: iso_fortran_env, only : real32, real64, real128
implicit none
real(kind=real64) :: x = - 1.0_real64
real(kind=real64) :: nan, inf
character(len=20) :: line
! basics
print *, sinh(x)
print *, (exp(x)-exp(-x))/2.0
! sinh(3) is elemental and can handle an array
print *, sinh([x,2.0*x,x/3.0])
! a NaN input returns NaN
line='NAN'
read(line,*) nan
print *, sinh(nan)
! a Inf input returns Inf
line='Infinity'
read(line,*) inf
print *, sinh(inf)
! an overflow returns Inf
x=huge(0.0d0)
print *, sinh(x)
end program demo_sinh
]]>
sinpi
Source
<![CDATA[
program demo_sinpi
implicit none
real :: x
integer :: i
real,parameter :: PI=acos(-1.0)
do i=0,8
x=i*0.25
write(*,*)'x=',x,' sinpi(x)=',sinpi(x)
enddo
end program demo_sinpi
]]>
size
Source
<![CDATA[
program demo_size
implicit none
integer :: arr(0:2,-5:5)
write(*,*)'SIZE of simple two-dimensional array'
write(*,*)'SIZE(arr) :total count of elements:',size(arr)
write(*,*)'SIZE(arr,DIM=1) :number of rows :',size(arr,dim=1)
write(*,*)'SIZE(arr,DIM=2) :number of columns :',size(arr,dim=2)
! pass the same array to a procedure that passes the value two
! different ways
call interfaced(arr,arr)
contains
subroutine interfaced(arr1,arr2)
! notice the difference in the array specification
! for arr1 and arr2.
integer,intent(in) :: arr1(:,:)
integer,intent(in) :: arr2(2,*)
!
write(*,*)'interfaced assumed-shape array'
write(*,*)'SIZE(arr1) :',size(arr1)
write(*,*)'SIZE(arr1,DIM=1) :',size(arr1,dim=1)
write(*,*)'SIZE(arr1,DIM=2) :',size(arr1,dim=2)
! write(*,*)'SIZE(arr2) :',size(arr2)
write(*,*)'SIZE(arr2,DIM=1) :',size(arr2,dim=1)
!
! CANNOT DETERMINE SIZE OF ASSUMED SIZE ARRAY LAST DIMENSION
! write(*,*)'SIZE(arr2,DIM=2) :',size(arr2,dim=2)
end subroutine interfaced
end program demo_size
]]>
spacing
Source
<![CDATA[
program demo_spacing
implicit none
integer, parameter :: sgl = selected_real_kind(p=6, r=37)
integer, parameter :: dbl = selected_real_kind(p=13, r=200)
write(*,*) spacing(1.0_sgl)
write(*,*) nearest(1.0_sgl,+1.0),nearest(1.0_sgl,+1.0)-1.0
write(*,*) spacing(1.0_dbl)
end program demo_spacing
]]>
split
Source
<![CDATA[
program demo_split
!use m_strings, only: split=>split2020
implicit none
character (len=:), allocatable :: input
integer :: position, istart, iend
input = "one,last example,,x,, ,,"
position = 0
! write a number line
write(*,'(t3,a)') repeat('1234567890',6)
! display the input line
write(*,'(t3,a)') input
! step through the input string locating the bounds of the
! next token and printing it
do while (position < len(input))
istart = position + 1
call split (input, set=', ', pos=position)
iend = position - 1
if(iend >= istart)then
print '(t3,a,1x,i0,1x,i0)', input (istart:iend),istart,iend
else
! maybe ignore null fields, maybe not ...
write(*,'(t3,*(g0))')'null between ',iend,' and ',istart
endif
end do
end program demo_split
]]>
spread
Source
<![CDATA[
program demo_spread
implicit none
integer a1(4,3), a2(3,4), v(4), s
write(*,'(a)' ) &
'TEST SPREAD(3) ', &
' SPREAD(3) is a FORTRAN90 function which replicates', &
' an array by adding a dimension. ', &
' '
s = 99
call printi('suppose we have a scalar S',s)
write(*,*) 'to add a new dimension (1) of extent 4 call'
call printi('spread( s, dim=1, ncopies=4 )',spread ( s, 1, 4 ))
v = [ 1, 2, 3, 4 ]
call printi(' first we will set V to',v)
write(*,'(a)')' and then do "spread ( v, dim=2, ncopies=3 )"'
a1 = spread ( v, dim=2, ncopies=3 )
call printi('uses v as a column and makes 3 columns',a1)
a2 = spread ( v, 1, 3 )
call printi(' spread(v,1,3) uses v as a row and makes 3 rows',a2)
contains
! CONVENIENCE ROUTINE; NOT DIRECTLY CONNECTED TO SPREAD(3)
subroutine printi(title,a)
use, intrinsic :: iso_fortran_env, only : stderr=>ERROR_UNIT,&
& stdin=>INPUT_UNIT, stdout=>OUTPUT_UNIT
implicit none
!@(#) print small 2d integer scalar, vector, matrix in row-column format
character(len=*),parameter :: all='(" ",*(g0,1x))'
character(len=*),intent(in) :: title
character(len=20) :: row
integer,intent(in) :: a(..)
integer :: i
write(*,all,advance='no')trim(title)
! select rank of input
select rank(a)
rank (0); write(*,'(a)')' (a scalar)'
write(*,'(" > [ ",i0," ]")')a
rank (1); write(*,'(a)')' (a vector)'
! find how many characters to use for integers
write(row,'(i0)')ceiling(log10(max(1.0,real(maxval(abs(a))))))+2
! use this format to write a row
row='(" > [",*(i'//trim(row)//':,","))'
do i=1,size(a)
write(*,fmt=row,advance='no')a(i)
write(*,'(" ]")')
enddo
rank (2); write(*,'(a)')' (a matrix) '
! find how many characters to use for integers
write(row,'(i0)')ceiling(log10(max(1.0,real(maxval(abs(a))))))+2
! use this format to write a row
row='(" > [",*(i'//trim(row)//':,","))'
do i=1,size(a,dim=1)
write(*,fmt=row,advance='no')a(i,:)
write(*,'(" ]")')
enddo
rank default
write(stderr,*)'*printi* did not expect rank=', rank(a), &
& 'shape=', shape(a),'size=',size(a)
stop '*printi* unexpected rank'
end select
write(*,all) '>shape=',shape(a),',rank=',rank(a),',size=',size(a)
write(*,*)
end subroutine printi
end program demo_spread
]]>
sqrt
Source
<![CDATA[
program demo_sqrt
use, intrinsic :: iso_fortran_env, only : real32, real64, real128
implicit none
real(kind=real64) :: x, x2
complex :: z, z2
! basics
x = 2.0_real64
! complex
z = (1.0, 2.0)
write(*,*)'input values ',x,z
x2 = sqrt(x)
z2 = sqrt(z)
write(*,*)'output values ',x2,z2
! elemental
write(*,*)'elemental',sqrt([64.0,121.0,30.0])
! alternatives
x2 = x**0.5
z2 = z**0.5
write(*,*)'alternatively',x2,z2
end program demo_sqrt
]]>
stop
Source
<![CDATA[
program demo_stop
! select which STOP call to make from command line
use, intrinsic :: iso_fortran_env, only : stderr=>ERROR_UNIT
implicit none
integer :: istat, argument_length, stopcode
character(len=:),allocatable :: which, message
! allocate string array big enough to hold command line
call get_command_argument(number=1,length=argument_length)
! argument strings and related information
if(allocated(which))deallocate(which)
allocate(character(len=argument_length) :: which)
call get_command_argument(1, which,status=istat)
if(istat.ne.0)which=''
select case(which)
! normal terminations:
! A STOP with no non-zero numeric parameter is a normal
! termination and generally returns a zero status value if the
! system supports return statuses
case('basic'); stop ! usually displays nothing
case('zero'); stop 0 ! sometimes displays "STOP 0" or "0"
case('text'); stop 'That is all, folks!'
!
! All other stops are generally used to indicate an error or
! special exit type
case('nonzero'); stop 10
case('variable'); stopcode=11; stop stopcode
case('expression'); stopcode=11; stop 110/stopcode
case('string'); message='oops'; stop 'ERROR:['//message//']'
! Error terminations:
! ERROR STOP is always an error stop, even without a stop-code
! ERROR STOP often displays a traceback but that is not required
case('error')
error stop
case('errornum')
stopcode=10
error stop stopcode+3
case('errorstring')
message='That is all, folks!'
error stop 'ERROR:'//message
case default
write(*,'(a)')'enter a stop type:', &
& '{basic, text, zero, nonzero, variable, expression}', &
& '{error, errornum, errorstring}'
write(*,*)'try again ...'
end select
end program demo_stop
]]>
storage_size
Source
<![CDATA[
program demo_storage_size
implicit none
! a default real, integer, and logical are the same storage size
write(*,*)'size of integer ',storage_size(0)
write(*,*)'size of real ',storage_size(0.0)
write(*,*)'size of logical ',storage_size(.true.)
write(*,*)'size of complex ',storage_size((0.0,0.0))
! note the size of an element of the array, not the storage size of
! the entire array is returned for array arguments
write(*,*)'size of integer array ',storage_size([0,1,2,3,4,5,6,7,8,9])
end program demo_storage_size
]]>
sum
Source
<![CDATA[
program demo_sum
implicit none
integer :: vector(5) , matrix(3,4), box(5,6,7)
vector = [ 1, 2, -3, 4, 5 ]
matrix(1,:)=[ -1, 2, -3, 4 ]
matrix(2,:)=[ 10, -20, 30, -40 ]
matrix(3,:)=[ 100, 200, -300, 400 ]
box=11
! basics
print *, 'sum all elements:',sum(vector)
print *, 'real :',sum([11.0,-5.0,20.0])
print *, 'complex :',sum([(1.1,-3.3),(4.0,5.0),(8.0,-6.0)])
! with MASK option
print *, 'sum odd elements:',sum(vector, mask=mod(vector, 2)==1)
print *, 'sum positive values:', sum(vector, mask=vector>0)
call printi('the input array', matrix )
call printi('sum of all elements in matrix', sum(matrix) )
call printi('sum of positive elements', sum(matrix,matrix>=0) )
! along dimensions
call printi('sum along rows', sum(matrix,dim=1) )
call printi('sum along columns', sum(matrix,dim=2) )
call printi('sum of a vector is always a scalar', sum(vector,dim=1) )
call printi('sum of a volume by row', sum(box,dim=1) )
call printi('sum of a volume by column', sum(box,dim=2) )
call printi('sum of a volume by depth', sum(box,dim=3) )
contains
! CONVENIENCE ROUTINE; NOT DIRECTLY CONNECTED TO SPREAD(3)
subroutine printi(title,a)
use, intrinsic :: iso_fortran_env, only : stderr=>ERROR_UNIT,&
& stdin=>INPUT_UNIT, stdout=>OUTPUT_UNIT
implicit none
!@(#) print small 2d integer scalar, vector, matrix in row-column format
character(len=*),intent(in) :: title
integer,intent(in) :: a(..)
character(len=*),parameter :: all='(" ",*(g0,1x))'
character(len=20) :: row
integer,allocatable :: b(:,:)
integer :: i
write(*,all,advance='no')trim(title)
! copy everything to a matrix to keep code simple
select rank(a)
rank (0); write(*,'(a)')' (a scalar)'; b=reshape([a],[1,1])
rank (1); write(*,'(a)')' (a vector)'; b=reshape(a,[size(a),1])
rank (2); write(*,'(a)')' (a matrix)'; b=a
rank default; stop '*printi* unexpected rank'
end select
! find how many characters to use for integers
write(row,'(i0)')ceiling(log10(max(1.0,real(maxval(abs(b))))))+2
! use this format to write a row
row='(" > [",*(i'//trim(row)//':,","))'
do i=1,size(b,dim=1)
write(*,fmt=row,advance='no')b(i,:)
write(*,'(" ]")')
enddo
write(*,all) '>shape=',shape(a),',rank=',rank(a),',size=',size(a)
write(*,*)
end subroutine printi
end program demo_sum
]]>
system_clock
Source
<![CDATA[
program demo_system_clock
use, intrinsic :: iso_fortran_env, only: wp => real64, int32, int64
implicit none
character(len=*), parameter :: g = '(1x,*(g0,1x))'
integer(kind=int64) :: count64, count_rate64, count_max64
integer(kind=int64) :: start64, finish64
integer(kind=int32) :: count32, count_rate32, count_max32
real(kind=wp) :: time_read
real(kind=wp) :: sum
integer :: i
print g, 'accuracy may vary with argument type!'
print g, 'query all arguments'
call system_clock(count64, count_rate64, count_max64)
print g, 'COUNT_MAX(64bit)=', count_max64
print g, 'COUNT_RATE(64bit)=', count_rate64
print g, 'CURRENT COUNT(64bit)=', count64
call system_clock(count32, count_rate32, count_max32)
print g, 'COUNT_MAX(32bit)=', count_max32
print g, 'COUNT_RATE(32bit)=', count_rate32
print g, 'CURRENT COUNT(32bit)=', count32
print g, 'time some computation'
call system_clock(start64)
! some code to time
sum = 0.0_wp
do i = -0, huge(0) - 1
sum = sum + sqrt(real(i))
end do
print g, 'SUM=', sum
call system_clock(finish64)
time_read = (finish64 - start64)/real(count_rate64, wp)
write (*, '(1x,a,1x,g0,1x,a)') 'time : ', time_read, ' seconds'
end program demo_system_clock
]]>
tand
Source
<![CDATA[
program demo_tand
use, intrinsic :: iso_fortran_env, only : real32, real64, real128
implicit none
real(kind=real64) :: x = 0.5_real64
write(*,*)x, tand(x)
end program demo_tand
]]>
tan
Source
<![CDATA[
program demo_tan
use, intrinsic :: iso_fortran_env, only : real32, real64, real128
implicit none
real(kind=real64) :: x = 0.165_real64
write(*,*)x, tan(x)
end program demo_tan
]]>
tanh
Source
<![CDATA[
program demo_tanh
use, intrinsic :: iso_fortran_env, only : real32, real64, real128
implicit none
real(kind=real64) :: x = 2.1_real64
write(*,*)x, tanh(x)
end program demo_tanh
]]>
tanpi
Source
<![CDATA[
program demo_tanpi
use, intrinsic :: iso_fortran_env, only : real64
implicit none
integer :: i
real(kind=real64) :: x
do i=0,8
x=0.250000000d0*i
write(*,101)x, tanpi(x), tanpi(x)*180.0d0
enddo
101 format(g0,t23,g0,t50,g0)
end program demo_tanpi
]]>
this_image
Source
<![CDATA[
program demo_this_image
implicit none
integer :: value[*]
integer :: i
value = this_image()
sync all
if (this_image() == 1) then
do i = 1, num_images()
write(*,'(2(a,i0))') 'value[', i, '] is ', value[i]
end do
endif
end program demo_this_image
]]>
tiny
Source
<![CDATA[
program demo_tiny
implicit none
print *, 'default real is from', tiny(0.0), 'to',huge(0.0)
print *, 'doubleprecision is from ', tiny(0.0d0), 'to',huge(0.0d0)
end program demo_tiny
]]>
tokenize
Source
<![CDATA[
program demo_tokenize
!use M_strings, only : tokenize=>split2020
implicit none
! some useful formats
character(len=*),parameter :: brackets='(*("[",g0,"]":,","))'
character(len=*),parameter :: a_commas='(a,*(g0:,","))'
character(len=*),parameter :: space='(*(g0:,1x))'
character(len=*),parameter :: gen='(*(g0))'
! Execution of TOKEN form (return array of tokens)
block
character (len=:), allocatable :: string
character (len=:), allocatable :: tokens(:)
character (len=:), allocatable :: kludge(:)
integer :: i
string = ' first,second ,third '
call tokenize(string, set=';,', tokens=tokens )
write(*,brackets)tokens
string = ' first , second ,third '
call tokenize(string, set=' ,', tokens=tokens )
write(*,brackets)(trim(tokens(i)),i=1,size(tokens))
! remove blank tokens
! <<<
!tokens=pack(tokens, tokens /= '' )
! gfortran 13.1.0 bug -- concatenate //'' and use scratch
! variable KLUDGE. JSU: 2024-08-18
kludge=pack(tokens//'', tokens /= '' )
! >>>
write(*,brackets)kludge
endblock
! Execution of BOUNDS form (return position of tokens)
block
character (len=:), allocatable :: string
character (len=*),parameter :: set = " ,"
integer, allocatable :: first(:), last(:)
write(*,gen)repeat('1234567890',6)
string = 'first,second,,fourth'
write(*,gen)string
call tokenize (string, set, first, last)
write(*,a_commas)'FIRST=',first
write(*,a_commas)'LAST=',last
write(*,a_commas)'HAS LENGTH=',last-first.gt.0
endblock
end program demo_tokenize
]]>
trailz
Source
<![CDATA[
program demo_trailz
! some common integer kinds
use, intrinsic :: iso_fortran_env, only : &
& integer_kinds, int8, int16, int32, int64
implicit none
! a handy format
character(len=*),parameter :: &
& show = '(1x,"value=",i4,", value(bits)=",b32.32,1x,", trailz=",i3)'
integer(kind=int64) :: bigi
! basics
write(*,*)'Note default integer is',bit_size(0),'bits'
print show, -1, -1, trailz(-1)
print show, 0, 0, trailz(0)
print show, 1, 1, trailz(1)
print show, 96, 96, trailz(96)
! elemental
print *, 'elemental and any integer kind:'
bigi=2**5
write(*,*) trailz( [ bigi, bigi*256, bigi/2 ] )
write(*,'(1x,b64.64)')[ bigi, bigi*256, bigi/2 ]
end program demo_trailz
]]>
transfer
Source
<![CDATA[
program demo_transfer
use,intrinsic :: iso_fortran_env, only : int32, real32
integer(kind=int32) :: i = 2143289344
real(kind=real32) :: x
character(len=10) :: string
character(len=1) :: chars(10)
x=transfer(i, 1.0) ! prints "nan" on i686
! the bit patterns are the same
write(*,'(b0,1x,g0)')x,x ! create a NaN
write(*,'(b0,1x,g0)')i,i
! a string to an array of characters
string='abcdefghij'
chars=transfer(string,chars)
write(*,'(*("[",a,"]":,1x))')string
write(*,'(*("[",a,"]":,1x))')chars
end program demo_transfer
]]>
transpose
Source
<![CDATA[
program demo_transpose
implicit none
integer,allocatable :: array(:,:)
integer,parameter :: values(3,5)= reshape([&
1, 2, 3, 4, 5, &
10, 20, 30, 40, 50, &
11, 22, 33, 44, -1055 &
],shape(values),order=[2,1])
array=values
call print_matrix_int('array:',array)
array=transpose(array)
call print_matrix_int('array transposed:',array)
array=transpose(array)
call print_matrix_int('transposed transpose:',array)
contains
subroutine print_matrix_int(title,arr)
! print small 2d integer arrays in row-column format
implicit none
character(len=*),intent(in) :: title
integer,intent(in) :: arr(:,:)
integer :: i
character(len=:),allocatable :: biggest
! print title
write(*,'(a," shape(",i0,",",i0,")")')trim(title),shape(arr)
biggest=' ' ! make buffer to write integer into
! find how many characters to use for integers
write(biggest,'(i0)')ceiling(log10(max(1.0,real(maxval(abs(arr))))))+2
! use this format to write a row
biggest='(" [",*(i'//trim(biggest)//':,","))'
! print one row of array at a time
do i=1,size(arr,dim=1)
write(*,fmt=biggest,advance='no')arr(i,:)
write(*,'(" ]")')
enddo
end subroutine print_matrix_int
end program demo_transpose
]]>
trim
Source
<![CDATA[
program demo_trim
implicit none
character(len=:), allocatable :: str, strs(:)
character(len=*),parameter :: brackets='( *("[",a,"]":,1x) )'
integer :: i
str=' trailing '
print brackets, str,trim(str) ! trims it
str=' leading'
print brackets, str,trim(str) ! no effect
str=' '
print brackets, str,trim(str) ! becomes zero length
print *, len(str), len(trim(' '))
! array elements are all the same length, so you often
! want to print them
strs=[character(len=10) :: "Z"," a b c","ABC",""]
write(*,*)'untrimmed:'
! everything prints as ten characters; nice for neat columns
print brackets, (strs(i), i=1,size(strs))
print brackets, (strs(i), i=size(strs),1,-1)
write(*,*)'trimmed:'
! everything prints trimmed
print brackets, (trim(strs(i)), i=1,size(strs))
print brackets, (trim(strs(i)), i=size(strs),1,-1)
end program demo_trim
]]>
ubound
Source
<![CDATA[
! program demo_ubound
module m2_bounds
implicit none
contains
subroutine msub(arr)
!!integer,intent(in) :: arr(*) ! cannot be assumed-size array
integer,intent(in) :: arr(:)
write(*,*)'MSUB: LOWER=',lbound(arr),'UPPER=',ubound(arr), &
& 'SIZE=',size(arr)
end subroutine msub
end module m2_bounds
!
program demo_ubound
use m2_bounds, only : msub
implicit none
interface
subroutine esub(arr)
integer,intent(in) :: arr(:)
end subroutine esub
end interface
integer :: arr(-10:10)
write(*,*)'MAIN: LOWER=',lbound(arr),'UPPER=',ubound(arr), &
& 'SIZE=',size(arr)
call csub()
call msub(arr)
call esub(arr)
contains
subroutine csub
write(*,*)'CSUB: LOWER=',lbound(arr),'UPPER=',ubound(arr), &
& 'SIZE=',size(arr)
end subroutine csub
end
subroutine esub(arr)
implicit none
integer,intent(in) :: arr(:)
! WARNING: IF CALLED WITHOUT AN EXPLICIT INTERFACE
! THIS WILL GIVE UNDEFINED ANSWERS (like 0,0,0)
write(*,*)'ESUB: LOWER=',lbound(arr),'UPPER=',ubound(arr), &
& 'SIZE=',size(arr)
end subroutine esub
!end program demo_ubound
]]>
ucobound
Source
<![CDATA[
]]>
unpack
Source
<![CDATA[
program demo_unpack
implicit none
logical,parameter :: T=.true., F=.false.
integer,parameter :: rows=3, cols=3
integer :: i
logical :: mask(rows,cols) = reshape([ &
T, F, F, &
F, T, F, &
F, F, T &
],[3,3])
integer :: field(rows,cols) = reshape([ &
1, 2, 3, &
4, 5, 6, &
7, 8, 9 &
],[3,3])
integer :: result(rows,cols)
! mask and field must conform or field must be a scalar
write(*,*) 'if the logical mask is'
do i=1,size(mask,dim=1)
write(*,*)mask(i,:)
enddo
write(*,*) 'and field is a scalar (in this case, 0)'
write(*,*) 'the result is the shape of the mask'
write(*,*) 'with all values set to the scalar value'
write(*,*) 'except the true elements of the mask are'
write(*,*) 'filled in row-column order with values'
write(*,*) 'from the vector of values [11,22,33]'
result = unpack( [11,22,33], mask, field=0 )
call print_matrix_int('result=', result)
write(*,*) 'if field is an array it must conform'
write(*,*) 'to the shape of the mask'
call print_matrix_int('field=',field)
write(*,*) 'and the combination results in'
result = unpack( [11,22,33], mask, field )
call print_matrix_int('result=', result)
contains
subroutine print_matrix_int(title,arr)
! @(#) convenience routine:
! prints small integer arrays in row-column format
implicit none
character(len=*),intent(in) :: title
integer,intent(in) :: arr(:,:)
integer :: i
character(len=:),allocatable :: biggest
write(*,*)trim(title)
! make buffer to write integer into
biggest=' '
! find how many characters to use for integers
write(biggest,'(i0)')ceiling(log10(max(1.0,real(maxval(abs(arr))))))+2
! use this format to write a row
biggest='(" [",*(i'//trim(biggest)//':,","))'
! print one row of array at a time
do i=1,size(arr,dim=1)
write(*,fmt=biggest,advance='no')arr(i,:)
write(*,'(" ]")')
enddo
end subroutine print_matrix_int
end program demo_unpack
]]>
use
Source
<![CDATA[
! program demo_use and module examples
module example ! example is the namespace name
use,intrinsic :: iso_fortran_env , only : real64
type type1 ! type1 is the class prototype name
contains
procedure, nopass :: static_method1
end type type1
type type2 ! type1 is the class prototype name
contains
procedure, nopass :: static_method2
end type type2
real(kind=real64),parameter :: &
pi = 3.1415926535897932_real64
! Napier's constant is the base of the natural logarithm
! system. It is often denoted by "e" in honor of Euler.
real(kind=real64),parameter :: &
Napier_constant = 2.71828182845904523_real64
contains
subroutine static_method1(arg)
integer :: arg
! code to implement method goes here
end subroutine static_method1
subroutine static_method2(arg)
integer :: arg
! code to implement method goes here
end subroutine static_method2
end module example
program demo_use
use example, only: type1 ! class prototype type1 available,
! but nothing else is made available by this
!
! (additionally) within this scoping unit, type1 is referred to
! as "mytype"
use example, mytype => type1
!
! only: is recommended but for long lists importing everything
! without listing it is supported:
use example ! all public objects in namespace example available
!
! some popular intrinsic entities
!
use,intrinsic :: iso_fortran_env, only : &
stderr=>ERROR_UNIT, stdin=>INPUT_UNIT, stdout=>OUTPUT_UNIT
! specifying INTRINSIC or NON_INTRINSIC is typically optional but
! indicating INTRINSIC when it is so is the norm.
use :: iso_fortran_env, only : integer_kinds,int8,int16,int32,int64
use iso_fortran_env, only : real_kinds,real32,real64,real128
! duplicates are OK
use,intrinsic :: iso_fortran_env, only : sp=>real32,dp=>real64
use,intrinsic :: iso_fortran_env, only : integer_kinds
use,intrinsic :: iso_fortran_env, only : compiler_version
use,intrinsic :: iso_fortran_env, only : compiler_options
use,intrinsic :: iso_fortran_env, only : iostat_eor, iostat_end
end program demo_use
]]>
verify
Source
<![CDATA[
program demo_verify
implicit none
! some useful character sets
character,parameter :: &
& int*(*) = '1234567890', &
& low*(*) = 'abcdefghijklmnopqrstuvwxyz', &
& upp*(*) = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ', &
& punc*(*) = "!""#$%&'()*+,-./:;<=>?@[\]^_`{|}~", &
& blank*(*) = ' ', &
& tab = char(11), &
& prnt*(*) = int//low//upp//blank//punc
character(len=:),allocatable :: string
integer :: i
print *, 'basics:'
print *, VERIFY ('ABBA', 'A') ! has the value 2.
print *, VERIFY ('ABBA', 'A', BACK = .TRUE.) ! has the value 3.
print *, VERIFY ('ABBA', 'AB') ! has the value 0.
print *,'find first non-uppercase letter'
! will produce the location of "d", because there is no match in UPP
write(*,*) 'something unmatched',verify("ABCdEFG", upp)
print *,'if everything is matched return zero'
! will produce 0 as all letters have a match
write(*,*) 'everything matched',verify("ffoorrttrraann", "nartrof")
print *,'easily categorize strings as uppercase, lowercase, ...'
! easy C-like functionality but does entire strings not just characters
write(*,*)'isdigit 123?',verify("123", int) == 0
write(*,*)'islower abc?',verify("abc", low) == 0
write(*,*)'isalpha aBc?',verify("aBc", low//upp) == 0
write(*,*)'isblank aBc dEf?',verify("aBc dEf", blank//tab ) /= 0
! check if all printable characters
string="aB;cde,fgHI!Jklmno PQRSTU vwxyz"
write(*,*)'isprint?',verify(string,prnt) == 0
! this now has a nonprintable tab character in it
string(10:10)=char(11)
write(*,*)'isprint?',verify(string,prnt) == 0
print *,'VERIFY(3) is very powerful using expressions as masks'
! verify(3) is often used in a logical expression
string=" This is NOT all UPPERCASE "
write(*,*)'all uppercase/spaces?',verify(string, blank//upp) == 0
string=" This IS all uppercase "
write(*,*) 'string=['//string//']'
write(*,*)'all uppercase/spaces?',verify(string, blank//upp) == 0
! set and show complex string to be tested
string=' Check this out. Let me know '
! show the string being examined
write(*,*) 'string=['//string//']'
write(*,*) ' '//repeat(int,4) ! number line
! the Fortran functions returns a position just not a logical like C
print *, 'returning a position not just a logical is useful'
! which can be very useful for parsing strings
write(*,*)'first non-blank character',verify(string, blank)
write(*,*)'last non-blank character',verify(string, blank,back=.true.)
write(*,*)'first non-letter non-blank',verify(string,low//upp//blank)
!VERIFY(3) is elemental so you can check an array of strings in one call
print *, 'elemental'
! are strings all letters (or blanks)?
write(*,*) 'array of strings',verify( &
! strings must all be same length, so force to length 10
& [character(len=10) :: "YES","ok","000","good one","Nope!"], &
& low//upp//blank) == 0
! rarer, but the set can be an array, not just the strings to test
! you could do ISPRINT() this (harder) way :>
write(*,*)'isprint?',.not.all(verify("aBc", [(char(i),i=32,126)])==1)
! instead of this way
write(*,*)'isprint?',verify("aBc",prnt) == 0
end program demo_verify
]]>
wait
Source
<![CDATA[
]]>
where
Source
<![CDATA[
program demo_where
! Example of WHERE, ELSEWHERE, ENDWHERE
integer,parameter :: nd=10, ndh=nd/2, nduh=nd-ndh-1
integer :: j
real, dimension(nd):: a=[ (2*j,j=1,nd) ]
real, dimension(nd):: b ! =[ ndh*1.0, 0.0, nduh*2.0 ]
real, dimension(nd):: c ! =[ nd*-77.77 ]
integer iflag(nd)
data b/ndh*1,0.0,nduh*2./,c/nd*-77.77/
where (b.ne.0) c=a/b
write (*,2000) c(1:nd)
!
! The above protects against divide by zero, but doesn't actually
! assign values to elements in c when the corresponding element in
! b is zero The following covers that, and sets a flag when a divide
! by zero is present
!
where (b(1:nd).ne.0.0)
c=a/b
iflag=0
elsewhere
c=0.0
iflag=1
endwhere
write (*,2000) c(1:nd)
write (*,1000) iflag(1:nd)
1000 format ('iflag= ',/,(10i7))
2000 format ('a/b = ',/,(10f7.2))
end program demo_where
]]>
write
Source
<![CDATA[
]]>