Fortran logo abs
Source program demo_abs implicit none integer,parameter :: dp=kind(0.0d0) integer :: i = -1 real :: x = -1.0 complex :: z = (-3.0,-4.0) doubleprecision :: rr = -45.78_dp character(len=*),parameter :: & ! some formats frmt = '(1x,a15,1x," In: ",g0, T51," Out: ",g0)', & frmtc = '(1x,a15,1x," In: (",g0,",",g0,")",T51," Out: ",g0)', & g = '(*(g0,1x))' ! 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) ! You can take the absolute value of any value whose positive value ! is representable with the same type and kind. write(*, *) 'abs range test : ', abs(huge(0)), abs(-huge(0)) write(*, *) 'abs range test : ', abs(huge(0.0)), abs(-huge(0.0)) write(*, *) 'abs range test : ', abs(tiny(0.0)), abs(-tiny(0.0)) ! 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. ! elemental write(*, g) ' abs is elemental:', abs([20, 0, -1, -3, 100]) ! COMPLEX input produces REAL output write(*, g)' complex input produces real output', & & abs(cmplx(30.0_dp,40.0_dp,kind=dp)) ! dusty corner: "kind=dp" is required or the value returned by ! CMPLX() is a default real instead of double precision ! the returned value for complex input can be thought of as the ! distance from the origin <0,0> write(*, g) ' distance of (', z, ') from zero is', abs( z ) write(*, g) ' so beware of overflow with complex values' !write(*, g) abs(cmplx( huge(0.0), huge(0.0) )) write(*, g) ' because the biggest default real is',huge(0.0) end program demo_abs
Fortran logo achar
Source 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(3f): 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
Fortran logo acos
Source program demo_acos use, intrinsic :: iso_fortran_env, only : real_kinds,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 & &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
Fortran logo acosh
Source program demo_acosh use,intrinsic :: iso_fortran_env, only : dp=>real64,sp=>real32 implicit none real(kind=dp), dimension(3) :: x = [ 1.0d0, 2.0d0, 3.0d0 ] if( any(x.lt.1) )then write (*,*) ' warning: values < 1 are present' endif write (*,*) acosh(x) end program demo_acosh
Fortran logo adjustl
Source 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(3f) or len_trim(3f) 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(3f) call. astr=' allocatable string ' write(*,'(a,"[",a,"]")') 'original:',astr astr = adjustl(astr) write(*,'(a,"[",a,"]")') 'adjusted:',astr ! trim(3f) can be used to change the length astr = trim(astr) write(*,'(a,"[",a,"]")') 'trimmed: ',astr end program demo_adjustl
Fortran logo adjustr
Source 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
Fortran logo aimag
Source program demo_aimag use, intrinsic :: iso_fortran_env, only : real_kinds, & & real32, real64, real128 implicit none character(len=*),parameter :: g='(*(1x,g0))' complex :: z4 complex(kind=real64) :: z8 ! basics z4 = cmplx(1.e0, 2.e0) print *, 'value=',z4 print g, 'imaginary part=',aimag(z4),'or', z4%im ! other 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 ! an elemental function can be passed an array print * print *, [z4,z4/2.0,z4+z4,z4**3] print * print *, aimag([z4,z4/2.0,z4+z4,z4**3]) end program demo_aimag
Fortran logo aint
Source 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
Fortran logo all
Source 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
Fortran logo allocated
Source 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
Fortran logo anint
Source 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
Fortran logo any
Source 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
Fortran logo asin
Source 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
Fortran logo asinh
Source 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
Fortran logo associated
Source 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' end program demo_associated
Fortran logo atan2
Source 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
Fortran logo atan
Source program demo_atan use, intrinsic :: iso_fortran_env, only : real_kinds, & & 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
Fortran logo atanh
Source program demo_atanh implicit none real, dimension(3) :: x = [ -1.0, 0.0, 1.0 ] write (*,*) atanh(x) end program demo_atanh
Fortran logo atomic_add
Source 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
Fortran logo atomic_and
Source 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
Fortran logo atomic_cas
Source 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
Fortran logo atomic_define
Source 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
Fortran logo atomic_fetch_add
Source 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
Fortran logo atomic_fetch_and
Source 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
Fortran logo atomic_fetch_or
Source 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
Fortran logo atomic_fetch_xor
Source 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
Fortran logo atomic_or
Source 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
Fortran logo atomic_ref
Source 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
Fortran logo atomic_xor
Source 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
Fortran logo backspace
Source 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
Fortran logo bessel_j0
Source program demo_bessel_j0 use, intrinsic :: iso_fortran_env, only : real_kinds, & & real32, real64, real128 implicit none real(kind=real64) :: x x = 0.0_real64 x = bessel_j0(x) write(*,*)x end program demo_bessel_j0
Fortran logo bessel_j1
Source program demo_bessel_j1 use, intrinsic :: iso_fortran_env, only : real_kinds, & & real32, real64, real128 implicit none real(kind=real64) :: x = 1.0_real64 x = bessel_j1(x) write(*,*)x end program demo_bessel_j1
Fortran logo bessel_jn
Source program demo_bessel_jn use, intrinsic :: iso_fortran_env, only : real_kinds, & & real32, real64, real128 implicit none real(kind=real64) :: x = 1.0_real64 x = bessel_jn(5,x) write(*,*)x end program demo_bessel_jn
Fortran logo bessel_y0
Source program demo_bessel_y0 use, intrinsic :: iso_fortran_env, only : real_kinds, & & real32, real64, real128 implicit none real(kind=real64) :: x = 0.0_real64 x = bessel_y0(x) write(*,*)x end program demo_bessel_y0
Fortran logo bessel_y1
Source program demo_bessel_y1 use, intrinsic :: iso_fortran_env, only : real_kinds, & & real32, real64, real128 implicit none real(kind=real64) :: x = 1.0_real64 write(*,*)x, bessel_y1(x) end program demo_bessel_y1
Fortran logo bessel_yn
Source program demo_bessel_yn use, intrinsic :: iso_fortran_env, only : real_kinds, & & real32, real64, real128 implicit none real(kind=real64) :: x = 1.0_real64 write(*,*) x,bessel_yn(5,x) end program demo_bessel_yn
Fortran logo bge
Source 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
Fortran logo bgt
Source 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
Fortran logo bit_size
Source 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
Fortran logo ble
Source 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
Fortran logo blt
Source 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
Fortran logo btest
Source 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
Fortran logo c_associated
Source 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
Fortran logo ceiling
Source program demo_ceiling implicit none ! just a convenient format for a list of integers character(len=*),parameter :: ints='(*(" > ",5(i0:,",",1x),/))' real :: x real :: y ! basic usage x = 63.29 y = -63.59 print ints, ceiling(x) print ints, ceiling(y) ! note the result was the next integer larger to the right ! real values equal to whole numbers x = 63.0 y = -63.0 print ints, ceiling(x) print ints, ceiling(y) ! elemental (so an array argument is allowed) print ints , & & ceiling([ & & -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_ceiling
Fortran logo c_f_pointer
Source 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
Fortran logo c_f_procpointer
Source 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
Fortran logo c_funloc
Source ! 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
Fortran logo char
Source program demo_char implicit none integer, parameter :: ascii = selected_char_kind ("ascii") character(len=1, kind=ascii ) :: c integer :: i ! basic i=74 c=char(i) write(*,*)'ASCII character ',i,'is ',c ! 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
Fortran logo c_loc
Source
Fortran logo close
Source 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 end-of-file processing on the file connected to unit 10. 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
Fortran logo cmplx
Source 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
Fortran logo co_broadcast
Source 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
Fortran logo co_max
Source 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
Fortran logo co_min
Source 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
Fortran logo command_argument_count
Source program demo_command_argument_count implicit none integer :: count count = command_argument_count() print *, count end program demo_command_argument_count
Fortran logo compiler_options
Source 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
Fortran logo compiler_version
Source 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
Fortran logo conjg
Source program demo_conjg use, intrinsic :: iso_fortran_env, only : real_kinds, & & 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
Fortran logo continue
Source 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
Fortran logo co_reduce
Source 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
Fortran logo cos
Source 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
Fortran logo cosh
Source program demo_cosh use, intrinsic :: iso_fortran_env, only : & & real_kinds, real32, real64, real128 implicit none real(kind=real64) :: x = 1.0_real64 write(*,*)'X=',x,'COSH(X=)',cosh(x) end program demo_cosh
Fortran logo co_sum
Source 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
Fortran logo count
Source 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
Fortran logo cpu_time
Source program demo_cpu_time use, intrinsic :: iso_fortran_env, only : real_kinds,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
Fortran logo cshift
Source 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
Fortran logo c_sizeof
Source 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
Fortran logo date_and_time
Source 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
Fortran logo dble
Source 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
Fortran logo digits
Source program demo_digits implicit none integer :: i = 12345 real :: x = 3.143 doubleprecision :: y = 2.33d0 print *,'default integer:', digits(i) print *,'default real: ', digits(x) print *,'default doubleprecision:', digits(y) end program demo_digits
Fortran logo dim
Source 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
Fortran logo dot_product
Source 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
Fortran logo dprod
Source 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
Fortran logo dshiftl
Source 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
Fortran logo dshiftr
Source 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
Fortran logo eoshift
Source 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
Fortran logo epsilon
Source 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
Fortran logo erfc
Source program demo_erfc use, intrinsic :: iso_fortran_env, only : & & real_kinds, 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
Fortran logo erfc_scaled
Source program demo_erfc_scaled implicit none real(kind(0.0d0)) :: x = 0.17d0 x = erfc_scaled(x) print *, x end program demo_erfc_scaled
Fortran logo erf
Source program demo_erf use, intrinsic :: iso_fortran_env, only : real_kinds, & & real32, real64, real128 implicit none real(kind=real64) :: x = 0.17_real64 write(*,*)x, erf(x) end program demo_erf
Fortran logo event_query
Source 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
Fortran logo execute_command_line
Source program demo_exec implicit none integer :: i call execute_command_line("external_prog.exe", exitstat=i) print *, "Exit status of external_prog.exe was ", i call execute_command_line("reindex_files.exe", wait=.false.) print *, "Now reindexing files in the background" end program demo_exec
Fortran logo exp
Source 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
Fortran logo exponent
Source 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
Fortran logo extends_type_of
Source ! 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
Fortran logo findloc
Source 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
Fortran logo floor
Source 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
Fortran logo flush
Source 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
Fortran logo fraction
Source program demo_fraction implicit none real :: x x = 178.1387e-4 print *, fraction(x), x * radix(x)**(-exponent(x)) end program demo_fraction
Fortran logo gamma
Source 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
Fortran logo get_command_argument
Source 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
Fortran logo get_command
Source 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
Fortran logo get_environment_variable
Source 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 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) print *, name, " is not defined in the environment. Strange..." value='' case (2) print *, & "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
Fortran logo huge
Source 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 end program demo_huge
Fortran logo hypot
Source program demo_hypot use, intrinsic :: iso_fortran_env, only : & & real_kinds, 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
Fortran logo iachar
Source 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
Fortran logo iall
Source 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
Fortran logo iand
Source 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
Fortran logo iany
Source 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
Fortran logo ibclr
Source 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
Fortran logo ibits
Source 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
Fortran logo ibset
Source 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
Fortran logo ichar
Source program demo_ichar implicit none write(*,*)ichar(['a','z','A','Z']) end program demo_ichar
Fortran logo ieor
Source 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
Fortran logo image_index
Source
Fortran logo index
Source 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
Fortran logo inquire
Source
Fortran logo int
Source 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
Fortran logo ior
Source 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
Fortran logo iparity
Source 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
Fortran logo is_contiguous
Source 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
Fortran logo ishftc
Source 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
Fortran logo ishft
Source 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
Fortran logo is_iostat_end
Source program demo_iostat implicit none real :: value integer :: ios character(len=256) :: message write(*,*)'Begin entering numeric values, one per line' do read(*,*,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 end program demo_iostat
Fortran logo is_iostat_eor
Source 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
Fortran logo kind
Source 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
Fortran logo lbound
Source ! 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
Fortran logo lcobound
Source
Fortran logo leadz
Source 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
Fortran logo len
Source 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
Fortran logo len_trim
Source 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
Fortran logo lge
Source 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
Fortran logo lgt
Source 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
Fortran logo lle
Source 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
Fortran logo llt
Source 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
Fortran logo log10
Source program demo_log10 use, intrinsic :: iso_fortran_env, only : real_kinds, & & 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
Fortran logo log
Source 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
Fortran logo log_gamma
Source 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
Fortran logo logical
Source 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
Fortran logo maskl
Source 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
Fortran logo maskr
Source 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
Fortran logo matmul
Source 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
Fortran logo maxexponent
Source 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
Fortran logo max
Source 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 arrays you could use something ! like MAXVAL([arr1, arr2]) or probably better (no 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 arr1 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
Fortran logo maxloc
Source 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
Fortran logo maxval
Source 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]) write(*,*) maxval(ints) write(*,*) maxval(ints,dim=1) write(*,*) maxval(ints,dim=2) ! find biggest number less than 30 with mask write(*,*) maxval(ints,mask=ints.lt.30) end program demo_maxval
Fortran logo merge_bits
Source 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
Fortran logo merge
Source 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
Fortran logo minexponent
Source program demo_minexponent use, intrinsic :: iso_fortran_env, only : & &real_kinds, 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
Fortran logo min
Source program demo_min implicit none write(*,*)min(10.0,11.0,30.0,-100.0) end program demo_min
Fortran logo minloc
Source 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
Fortran logo minval
Source program demo_minval implicit none integer :: i 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.) 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
Fortran logo mod
Source 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
Fortran logo modulo
Source 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
Fortran logo move_alloc
Source 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
Fortran logo mvbits
Source 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
Fortran logo nearest
Source 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
Fortran logo new_line
Source 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
Fortran logo nint
Source 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
Fortran logo norm2
Source 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
Fortran logo not
Source 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
Fortran logo null
Source !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
Fortran logo num_images
Source 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
Fortran logo open
Source 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
Fortran logo out_of_range
Source 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(3f) 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
Fortran logo pack
Source 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' ) end program demo_pack
Fortran logo parity
Source 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
Fortran logo popcnt
Source 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
Fortran logo poppar
Source 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
Fortran logo precision
Source 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
Fortran logo present
Source 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(3f) 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(3f) 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
Fortran logo print
Source
Fortran logo product
Source 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
Fortran logo radix
Source 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
Fortran logo random_init
Source 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" end program demo_random_init
Fortran logo random_number
Source 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
Fortran logo random_seed
Source 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
Fortran logo range
Source 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
Fortran logo rank
Source 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
Fortran logo read
Source
Fortran logo real
Source 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
Fortran logo reduce
Source 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
Fortran logo repeat
Source 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
Fortran logo reshape
Source 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
Fortran logo rrspacing
Source
Fortran logo same_type_as
Source ! 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
Fortran logo scale
Source 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
Fortran logo scan
Source 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
Fortran logo selected_char_kind
Source 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
Fortran logo selected_int_kind
Source 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
Fortran logo selected_real_kind
Source 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
Fortran logo set_exponent
Source 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
Fortran logo shape
Source 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
Fortran logo shifta
Source 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
Fortran logo shiftl
Source 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
Fortran logo shiftr
Source 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
Fortran logo sign
Source 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
Fortran logo sin
Source 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
Fortran logo sinh
Source program demo_sinh use, intrinsic :: iso_fortran_env, only : & & real_kinds, 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
Fortran logo size
Source 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
Fortran logo spacing
Source 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
Fortran logo spread
Source 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
Fortran logo sqrt
Source program demo_sqrt use, intrinsic :: iso_fortran_env, only : real_kinds, & & 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
Fortran logo stop
Source program demo_stop use, intrinsic :: iso_fortran_env, only : stderr=>ERROR_UNIT implicit none integer :: stopcode character(len=:),allocatable :: message character(len=20) :: which INFINITE: do ! Normal terminations write(*,'(a)')'enter a stop type:', & & '{basic, text, zero, nonzero, variable, expression}', & & '{error, errornum, errorstring}' read(*,'(a)')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(*,*)'try again ...' end select enddo INFINITE end program demo_stop
Fortran logo storage_size
Source 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
Fortran logo sum
Source 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
Fortran logo system_clock
Source 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
Fortran logo tan
Source program demo_tan use, intrinsic :: iso_fortran_env, only : real_kinds, & & real32, real64, real128 implicit none real(kind=real64) :: x = 0.165_real64 write(*,*)x, tan(x) end program demo_tan
Fortran logo tanh
Source program demo_tanh use, intrinsic :: iso_fortran_env, only : & & real_kinds, real32, real64, real128 implicit none real(kind=real64) :: x = 2.1_real64 write(*,*)x, tanh(x) end program demo_tanh
Fortran logo this_image
Source 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
Fortran logo tiny
Source 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
Fortran logo trailz
Source 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
Fortran logo transfer
Source 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
Fortran logo transpose
Source 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
Fortran logo trim
Source 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
Fortran logo ubound
Source ! 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
Fortran logo ucobound
Source
Fortran logo unpack
Source 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
Fortran logo verify
Source 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(3f) 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
Fortran logo wait
Source
Fortran logo write
Source