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 = ' sample string'
character(len=:),allocatable :: astr
integer :: length
! basic use
write(*,'(a,"[",a,"]")') 'original: ',str
str=adjustl(str)
write(*,'(a,"[",a,"]")') 'adjusted: ',str
! a fixed-length string can be printed
! trimmed using trim(3) or len_trim(3)
write(*,'(a,"[",a,"]")') 'trimmed: ',trim(str)
length=len_trim(str)
write(*,'(a,"[",a,"]")') 'substring:',str(:length)
! note an allocatable string stays the same length too
! and is not trimmed by just an adjustl(3) call.
astr=' allocatable string '
write(*,'(a,"[",a,"]")') 'original:',astr
astr = adjustl(astr)
write(*,'(a,"[",a,"]")') 'adjusted:',astr
! trim(3) can be used to change the length
astr = trim(astr)
write(*,'(a,"[",a,"]")') '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 :: g='(*(1x,g0))'
integer :: i
complex :: z4
complex :: arr(3)
complex(kind=real64) :: z8
print g, 'basics:'
z4 = cmplx(1.e0, 2.e0)
print *, 'value=',z4
print g, 'imaginary part=',aimag(z4),'or', z4%im
print g, 'kinds other than the default may be supported'
z8 = cmplx(3.e0_real64, 4.e0_real64,kind=real64)
print *, 'value=',z8
print g, 'imaginary part=',aimag(z8),'or', z8%im
print g, 'an elemental function can be passed an array'
print g,'given a complex array:'
arr=[z4,z4/2.0,z4+z4]
print *, (arr(i),new_line('a'),i=1,size(arr))
print g,'the imaginary component is:'
print g, 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 (incidently 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
real :: myreal, x, y, theta, a
x = 0.42
y = 0.35
myreal = 9.1
theta = 1.5
a = 0.4
associate ( z => exp(-(x**2+y**2)) * cos(theta), v => myreal)
print *, a+z, a-z, v
v = v * 4.6
end associate
print *, myreal
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=[ &
( 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)
call cartesian_to_polar(vals(i)%re, vals(i)%im, 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(x,y,radius,inclination)
! return angle in radians in range 0 to 2*PI
implicit none
real,intent(in) :: x,y
real,intent(out) :: radius,inclination
radius=sqrt(x**2+y**2)
if(radius.eq.0)then
inclination=0.0
else
inclination=atan2(y,x)
if(inclination < 0.0)inclination=inclination+2*atan2(0.0d0,-1.0d0)
endif
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) :: atom[*]
call atomic_add (atom[1], this_image())
end program demo_atomic_add
]]>
atomic_and
Source
<![CDATA[
program demo_atomic_and
use iso_fortran_env
implicit none
integer(atomic_int_kind) :: atom[*]
call atomic_and(atom[1], int(b'10100011101'))
end program demo_atomic_and
]]>
atomic_cas
Source
<![CDATA[
program demo_atomic_cas
use iso_fortran_env
implicit none
logical(atomic_logical_kind) :: atom[*], prev
call atomic_cas(atom[1], prev, .false., .true.)
end program demo_atomic_cas
]]>
atomic_define
Source
<![CDATA[
program demo_atomic_define
use iso_fortran_env
implicit none
integer(atomic_int_kind) :: atom[*]
call atomic_define(atom[1], this_image())
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) :: atom[*], old
call atomic_add(atom[1], this_image(), old)
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) :: atom[*], old
call atomic_fetch_and (atom[1], int(b'10100011101'), old)
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) :: atom[*], old
call atomic_fetch_or(atom[1], int(b'10100011101'), old)
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) :: atom[*], old
call atomic_fetch_xor (atom[1], int(b'10100011101'), old)
end program demo_atomic_fetch_xor
]]>
atomic_or
Source
<![CDATA[
program demo_atomic_or
use iso_fortran_env
implicit none
integer(atomic_int_kind) :: atom[*]
call atomic_or(atom[1], int(b'10100011101'))
end program demo_atomic_or
]]>
atomic_ref
Source
<![CDATA[
program demo_atomic_ref
use iso_fortran_env
implicit none
logical(atomic_logical_kind) :: atom[*]
logical :: val
call atomic_ref( val, atom[1] )
if (val) then
print *, "Obtained"
endif
end program demo_atomic_ref
]]>
atomic_xor
Source
<![CDATA[
program demo_atomic_xor
use iso_fortran_env
implicit none
integer(atomic_int_kind) :: atom[*]
call atomic_xor(atom[1], int(b'10100011101'))
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') ! 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 supercedes 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
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 ]
integer :: i
integer :: ierr
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
implicit none
print '(2a)', &
'This file was compiled by ', &
compiler_version()
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' ! forth 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' ! forth 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 to,
! 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
character(len=*),parameter :: g2='(a,t20,g0)'
doubleprecision,parameter :: PI=atan(1.0d0)*4.0d0
write(*,g2)'COS(0.0)=',cos(0.0)
write(*,g2)'COS(PI)=',cos(PI)
write(*,g2)'COS(PI/2.0d0)=',cos(PI/2.0d0),'EPSILON=',epsilon(PI)
write(*,g2)'COS(2*PI)=',cos(2*PI)
write(*,g2)'COS(-2*PI)=',cos(-2*PI)
write(*,g2)'COS(-2000*PI)=',cos(-2000*PI)
write(*,g2)'COS(3000*PI)=',cos(3000*PI)
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,i2,i3
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')
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
a = reshape( [ 1, 2, 3, 4, 5, 6, 7, 8, 9 ], [ 3, 3 ])
print '(3i3)', (a(i,:),i=1,3)
print *
! shift it
a = eoshift(a, SHIFT=[1, 2, 1], BOUNDARY=-5, DIM=2)
print '(3i3)', (a(i,:),i=1,3)
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 unitentionally 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 explicity 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 ! cannott 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
real :: x, re, im
complex :: cx
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
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 * radix(x)**(-exponent(x))
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
character(len=255) :: progname
integer :: count, i, argument_length, istat
character(len=:),allocatable :: arg
! command name assuming it is less than 255 characters in length
call get_command_argument (0, progname, status=istat)
if (istat == 0) then
print *, "The program's name is " // trim (progname)
else
print *, "Could not get the program's name " // trim (progname)
endif
! get number of arguments
count = command_argument_count()
write(*,*)'The number of arguments is ',count
!
! allocate string array big enough to hold command line
! argument strings and related information
!
do i=1,count
call get_command_argument(number=i,length=argument_length)
if(allocated(arg))deallocate(arg)
allocate(character(len=argument_length) :: arg)
call get_command_argument(i, arg,status=istat)
! show the results
write (*,'(i3.3,1x,i0.5,1x,i0.5,1x,"[",a,"]")') &
& i,istat,argument_length,arg
enddo
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
character(len=4096) :: filename
character(len=20) :: mode
integer :: ios
character(len=256) :: message
integer :: lun
call print_inquire(lun,'')
contains
subroutine print_inquire(lun_in,namein_in)
!@(#) print_inquire(3f) INQUIRE a file by name/number and print results
! if unit >= 0 then query by unit number, else by name
integer,intent(in),optional :: lun_in
character(len=*),intent(in),optional :: namein_in
integer :: ios
character(len=256) :: message
character(len=:),allocatable :: namein
integer :: lun
! STATUS=NEW|REPLACE|OLD|SCRATCH|UNKNOWN
! SEQUENTIAL | DIRECT | STREAM
character(len=20) :: access ; namelist/inquire/access
! FORMATTED | UNFORMATTED
character(len=20) :: form ; namelist/inquire/form
! ASIS | REWIND | APPEND
character(len=20) :: position ; namelist/inquire/position
! READ | WRITE | READWRITE
character(len=20) :: action ; namelist/inquire/action
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
character(len=20) :: formatted ; namelist/inquire/formatted
character(len=20) :: name ; namelist/inquire/name
character(len=20) :: pad ; namelist/inquire/pad
character(len=20) :: read ; namelist/inquire/read
character(len=20) :: readwrite ; namelist/inquire/readwrite
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
character(len=20) :: unformatted ; namelist/inquire/unformatted
character(len=20) :: write ; namelist/inquire/write
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(namein_in))then
namein=namein_in
else
namein=''
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.
!!write(*,*)'LUN=',lun,' FILENAME=',namein
name=''
if(namein == ''.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, &
& pending=pending,asynchronous=asynchronous, &
& iostat=ios,err=999,iomsg=message)
elseif(namein /= '')then
write(*,*) '*print_inquire* checking file:'//namein
inquire(file=namein, &
& 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=ios,err=999,iomsg=message)
if(name == '')name=namein
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 ios become undefined.
write(*,*) &
&'*print_inquire* inquire call failed,iostat=',ios,'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 :: ios
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=ios,iomsg=message)value
if(ios.eq.0)then
write(*,*)'VALUE=',value
elseif( is_iostat_end(ios) ) then
stop 'end of file. Goodbye!'
else
write(*,*)'ERROR:',ios,trim(message)
exit
endif
!
enddo
contains
subroutine makefile(lun)
! make a scratch file just for demonstration purposes
integer :: iostat,lun
integer :: i
character(len=80),parameter :: fakefile(*)=[character(len=80) :: &
'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']
open(newunit=lun,status='scratch')
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')
write(lun, '(a)') '10 20 30'
write(lun, '(a)') '40 50 60 70'
write(lun, '(a)') '80 90'
write(lun, '(a)') '100'
rewind(lun)
do
read(lun, *, iostat=ios) inums
write(*,*)'iostat=',ios
if(is_iostat_eor(ios)) then
stop 'end of record'
elseif(is_iostat_end(ios)) then
print *,'end of file'
exit
elseif(ios.ne.0)then
print *,'I/O error',ios
exit
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
! Access array containing the kind type parameter values supported by this
! compiler for entities of logical type
use iso_fortran_env, only : logical_kinds
implicit none
integer :: i
! list kind values supported on this platform, which generally vary
! in storage size as alias declarations
do i =1, size(logical_kinds)
write(*,'(*(g0))')'integer,parameter :: boolean', &
& logical_kinds(i),'=', logical_kinds(i)
enddo
end program demo_logical
]]>
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
! Works with scalars
k=5
write(*,*)merge (1.0, 0.0, k > 0)
k=-2
write(*,*)merge (1.0, 0.0, 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)
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
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(*,*)'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
implicit none
integer,parameter :: k5 = selected_int_kind(5)
integer,parameter :: k15 = selected_int_kind(15)
integer(kind=k5) :: i5
integer(kind=k15) :: i15
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
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
print *, precision(x), range(x)
print *, precision(y), range(y)
print *, precision(z), range(z)
end program demo_selected_real_kind
]]>
set_exponent
Source
<![CDATA[
program demo_setexp
implicit none
real :: x = 178.1387e-4
integer :: i = 17
print *, set_exponent(x, i), fraction(x) * 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,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
! 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 :: i, 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
integer(kind=int32) :: start32, finish32
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,save :: xx(3,5)= reshape([&
1, 2, 3, 4, 5, &
10, 20, 30, 40, 50, &
11, 22, 33, 44, -1055 &
],shape(xx),order=[2,1])
call print_matrix_int('xx array:',xx)
call print_matrix_int('xx array transposed:',transpose(xx))
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
write(*,*)trim(title) ! 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_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 :: vector(2) = [1,1]
! mask and field must conform
integer,parameter :: r=2, c=2
logical :: mask(r,c) = reshape([ T,F,F,T ],[2,2])
integer :: field(r,c) = 0, unity(2,2)
! basic usage
unity = unpack( vector, mask, field )
call print_matrix_int('unity=', unity)
! if FIELD is a scalar it is used to fill all the elements
! not assigned to by the vector and mask.
call print_matrix_int('scalar field', &
& unpack( &
& vector=[ 1, 2, 3, 4 ], &
& mask=reshape([ T,F,T,F,F,F,T,F,T ], [3,3]), &
& field=0) )
contains
subroutine print_matrix_int(title,arr)
! convenience routine:
! just 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, ELSE WHERE, END WHERE
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
else where
c=0.0
iflag=1
end where
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[
]]>