From e73ea745a3fc4aba7cce8dd22691aaa46f163beb Mon Sep 17 00:00:00 2001 From: scivision Date: Mon, 29 Jul 2024 22:10:15 -0400 Subject: [PATCH] speedup f03 tests --- cmake/f03abstract.cmake | 9 +++---- cmake/f03charalloc.cmake | 8 +++--- cmake/f03ieee.cmake | 12 ++++----- cmake/f03selectType.cmake | 23 ++++------------ cmake/f03utf8.cmake | 3 +++ cmake/f18assumed_rank.cmake | 9 ++----- src/system/call_python_script.f90 | 16 +++++++---- src/system/os_detect.f90 | 10 +++---- src/system/play_sound.f90 | 22 ++++++++------- test/character/character_allocatable.f90 | 3 +++ test/character/str2int.f90 | 2 +- test/character/test_string.f90 | 10 +++---- test/character/utf8.f90 | 9 ++++--- test/io/devnull.f90 | 34 ++++++++++++------------ 14 files changed, 82 insertions(+), 88 deletions(-) diff --git a/cmake/f03abstract.cmake b/cmake/f03abstract.cmake index 2894607..532dff5 100644 --- a/cmake/f03abstract.cmake +++ b/cmake/f03abstract.cmake @@ -1,8 +1,6 @@ -check_source_compiles(Fortran -"program abst - -implicit none +set(CMAKE_TRY_COMPILE_TARGET_TYPE STATIC_LIBRARY) +check_source_compiles(Fortran "subroutine r() type, abstract :: L1 integer, pointer :: bullseye(:,:) end type L1 @@ -13,7 +11,6 @@ end type L2 class(L2), allocatable :: obj -end program -" +end subroutine" f03abstract ) diff --git a/cmake/f03charalloc.cmake b/cmake/f03charalloc.cmake index 6fbb682..1879928 100644 --- a/cmake/f03charalloc.cmake +++ b/cmake/f03charalloc.cmake @@ -1,11 +1,9 @@ -check_source_compiles(Fortran -"program a -implicit none -character(:), allocatable :: x(:) +set(CMAKE_TRY_COMPILE_TARGET_TYPE STATIC_LIBRARY) +check_source_compiles(Fortran "subroutine r() character(:), allocatable :: flex(:), scalar flex = [character(5) :: 'hi', 'hello'] -end program" +end subroutine" f03charalloc ) diff --git a/cmake/f03ieee.cmake b/cmake/f03ieee.cmake index 830cfd2..40cc24b 100644 --- a/cmake/f03ieee.cmake +++ b/cmake/f03ieee.cmake @@ -1,10 +1,8 @@ -check_source_compiles(Fortran -" -program a +set(CMAKE_TRY_COMPILE_TARGET_TYPE STATIC_LIBRARY) + +check_source_compiles(Fortran "subroutine r() use, intrinsic :: ieee_arithmetic, only : ieee_next_after -implicit none -print *, ieee_next_after(0.,0.) -end program -" +print *, ieee_next_after(0., 0.) +end subroutine" f03ieee ) diff --git a/cmake/f03selectType.cmake b/cmake/f03selectType.cmake index 5626e0b..8c8c5d2 100644 --- a/cmake/f03selectType.cmake +++ b/cmake/f03selectType.cmake @@ -1,29 +1,16 @@ -check_source_compiles(Fortran -" -program selectType -implicit none -real :: r -integer :: i +set(CMAKE_TRY_COMPILE_TARGET_TYPE STATIC_LIBRARY) -call selector(r) -call selector(i) - -contains - -subroutine selector(x) +check_source_compiles(Fortran "subroutine selector(x) class(*), intent(in) :: x select type (x) type is (real) - print *, 'real' + print '(a)', 'real' type is (integer) - print *, 'integer' + print '(a)', 'integer' end select -end subroutine - -end program -" +end subroutine" f03selectType ) diff --git a/cmake/f03utf8.cmake b/cmake/f03utf8.cmake index 7ed1eef..0feb50e 100644 --- a/cmake/f03utf8.cmake +++ b/cmake/f03utf8.cmake @@ -1,5 +1,8 @@ +set(CMAKE_TRY_COMPILE_TARGET_TYPE STATIC_LIBRARY) + check_source_compiles(Fortran "program test +intrinsic :: selected_char_kind character(kind=selected_char_kind('ISO_10646')) :: x end program" f03utf8 diff --git a/cmake/f18assumed_rank.cmake b/cmake/f18assumed_rank.cmake index a9778d0..78c5e00 100644 --- a/cmake/f18assumed_rank.cmake +++ b/cmake/f18assumed_rank.cmake @@ -1,17 +1,12 @@ -check_source_compiles(Fortran -" -program test -implicit none -contains +set(CMAKE_TRY_COMPILE_TARGET_TYPE STATIC_LIBRARY) -subroutine r(A) +check_source_compiles(Fortran "subroutine r(A) integer, intent(inout) :: A(..) select rank(A) rank default error stop end select end subroutine r -end program " f18assumed_rank ) diff --git a/src/system/call_python_script.f90 b/src/system/call_python_script.f90 index fae37e5..4c947c7 100644 --- a/src/system/call_python_script.f90 +++ b/src/system/call_python_script.f90 @@ -5,20 +5,26 @@ program call_python implicit none -character(:), allocatable :: cmd -character(1024) :: buf -integer :: ierr, icerr +character(:), allocatable :: cmd, buf +integer :: ierr, icerr, L + +valgrind : block cmd = "import os; print(f'{os.cpu_count()} CPUs detected by Python')" -call get_command_argument(1, buf, status=ierr) +call get_command_argument(1, length=L, status=ierr) if (ierr /= 0) error stop "please specify Python interpreter as first argument" +allocate(character(L) :: buf) +call get_command_argument(1, value=buf) -buf = trim(buf)//' -c "'//cmd//'"' +buf = trim(buf) // ' -c "' // cmd // '"' print '(a)', trim(buf) call execute_command_line(buf, exitstat=ierr, cmdstat=icerr) if (icerr/=0) error stop "Python interpreter not runnable" if (ierr/=0) error stop "Python script failed" + +end block valgrind + end program diff --git a/src/system/os_detect.f90 b/src/system/os_detect.f90 index f71a4e3..d463d84 100644 --- a/src/system/os_detect.f90 +++ b/src/system/os_detect.f90 @@ -6,14 +6,14 @@ module os_detect function getos() !! heuristic detection of operating system based on de facto environment variables -character(256) :: buf character(:), allocatable :: getos +integer :: L, i -call get_environment_variable("HOME", buf) -if (len_trim(buf) > 0) getos = "unix" +call get_environment_variable("HOME", length=L, status=i) +if (i == 0 .and. L > 0) getos = "unix" -call get_environment_variable("USERPROFILE", buf) -if (len_trim(buf) > 0) getos = "windows" +call get_environment_variable("USERPROFILE", length=L, status=i) +if (i == 0 .and. L > 0) getos = "windows" end function getos diff --git a/src/system/play_sound.f90 b/src/system/play_sound.f90 index 619065d..9bf3619 100644 --- a/src/system/play_sound.f90 +++ b/src/system/play_sound.f90 @@ -9,23 +9,27 @@ program play_sound ! -autoexit clips off the end of the sound slightly, but otherwise thread hangs open even after Fortran program ends. character(*),parameter :: cmdopts='-autoexit -loglevel warning -nodisp' -character(:), allocatable :: fn, pcmd -character(2048) :: argv +character(:), allocatable :: pcmd, buf logical :: fexist -integer :: ierr, istat +integer :: ierr, istat, L -call get_command_argument(1, argv, status=ierr) -if (ierr /= 0) error stop 'please include audio filename in command' -fn = trim(argv) +valgrind : block -inquire(file=fn, exist=fexist) +call get_command_argument(1, length=L, status=ierr) +if (ierr /= 0) error stop "please specify sound file" +allocate(character(L) :: buf) +call get_command_argument(1, value=buf) -if (.not. fexist) error stop 'did not find FILE ' // fn +inquire(file=buf, exist=fexist) -pcmd = playexe//' '//cmdopts//' '//trim(fn) +if (.not. fexist) error stop 'did not find FILE ' // buf + +pcmd = playexe//' '//cmdopts//' '//trim(buf) call execute_command_line(pcmd, cmdstat=ierr, exitstat=istat) if(ierr /= 0) error stop 'could not open player' if(istat /= 0) error stop 'problem playing file' +end block valgrind + end program diff --git a/test/character/character_allocatable.f90 b/test/character/character_allocatable.f90 index 5a02412..ebe62bc 100644 --- a/test/character/character_allocatable.f90 +++ b/test/character/character_allocatable.f90 @@ -5,6 +5,8 @@ program character_alloctable character(:), allocatable :: flex(:), scalar +valgrind : block + scalar = 'hi' if (len(scalar) /= 2) error stop 'auto-alloc char scalar' scalar = 'hello' @@ -35,6 +37,7 @@ program character_alloctable if (flex(1) /= 'hi') error stop "flex: flex(1) /= 'hi'" if (flex(2) /= 'bye') error stop "flex: flex(2) /= 'bye'" +end block valgrind print *, "OK: allocatable character" diff --git a/test/character/str2int.f90 b/test/character/str2int.f90 index 2fb24df..6512126 100644 --- a/test/character/str2int.f90 +++ b/test/character/str2int.f90 @@ -7,7 +7,7 @@ program str2int_demo x = '42' m = str2int(x) -if (m/=42) error stop +if (m /= 42) error stop contains diff --git a/test/character/test_string.f90 b/test/character/test_string.f90 index d60da9b..516fd6c 100644 --- a/test/character/test_string.f90 +++ b/test/character/test_string.f90 @@ -17,10 +17,10 @@ program test_string subroutine test_split() -character(*),parameter :: mystr="hello.txt" -character(:),allocatable :: stem +character(*), parameter :: mystr = "hello.txt" +character(:), allocatable :: stem -stem = split(mystr,'.') +stem = split(mystr, '.') print '(A)', stem if (len(stem) /= 5) error stop 'allocatable character of unexpected length' @@ -33,9 +33,9 @@ subroutine test_lowercase() character(*), parameter :: hello = 'HeLl0 Th3rE !>? ' !! Fortran 2003 allocatable string -if (.not.(toLower(hello)=='hell0 th3re !>? ')) error stop 'error: lowercase conversion' +if (.not.(toLower(hello) == 'hell0 th3re !>? ')) error stop 'error: lowercase conversion' -if (.not.(trim(toLower(hello))=='hell0 th3re !>?')) error stop 'Allocatable lowercase conversion error' +if (.not.(trim(toLower(hello)) == 'hell0 th3re !>?')) error stop 'Allocatable lowercase conversion error' end subroutine test_lowercase diff --git a/test/character/utf8.f90 b/test/character/utf8.f90 index e5202e5..dfdb800 100644 --- a/test/character/utf8.f90 +++ b/test/character/utf8.f90 @@ -9,9 +9,12 @@ program utf8_char character(len=:, kind=selected_char_kind('ISO_10646')), allocatable :: utf8 ascii = '☀ ☁ ☂ ☃ ☄' -utf8 = '☀ ☁ ☂ ☃ ☄' +utf8 = '☀ ☁ ☂ ☃ ☄' -print *, 'ascii', ascii, ' some compilers allow UTF-8 to be packed into ASCII per Fortran 2003 standard (optional)' -print *, 'utf8', utf8, ' this is 4-byte characters.' +print '(a)', 'ASCII:' +print '(a)', ascii + +print '(a)', 'UCS4:' +print '(a)', utf8 end program diff --git a/test/io/devnull.f90 b/test/io/devnull.f90 index 27b4ca4..7be931c 100644 --- a/test/io/devnull.f90 +++ b/test/io/devnull.f90 @@ -19,19 +19,19 @@ program devnull ! making mistakes in doing so. ! ! -character(*),parameter :: fout='out.txt' +character(*), parameter :: fout='out.txt' character(:), allocatable :: nullfile character(2048) :: argv integer,parameter :: Nrun=10000 -integer :: ios,u +integer :: ios,u, L real(wp) :: tnul, tscratch, tfile call get_command_argument(1, argv, status=ios) if (ios == 0) then nullfile = trim(argv) else - call get_environment_variable('userprofile', status=ios) - if (ios==0) then + call get_environment_variable('userprofile', status=ios, length=L) + if (ios==0 .and. L > 0) then nullfile = 'NUL' else nullfile = '/dev/null' @@ -40,38 +40,38 @@ program devnull !--- BENCHMARK NUL ----------- ! do NOT use status='old' as this can fail on various OS -open(newunit=u, file=nullfile,iostat=ios, action='write') +open(newunit=u, file=nullfile, iostat=ios, action='write') if (ios /= 0) error stop 'could not open NULL file: ' // nullfile -tnul = writetime(u,Nrun) -print '(A10,F10.3,A)','nul: ',tnul,' ms' +tnul = writetime(u, Nrun) +print '(A10,F10.3,A)', 'nul: ', tnul, ' ms' !---- BENCHMARK SCRATCH -------------- -open(newunit=u,status='scratch') -tscratch = writetime(u,Nrun) -print '(A10,F10.3,A)','scratch: ',tscratch,' ms' +open(newunit=u, status='scratch') +tscratch = writetime(u, Nrun) +print '(A10,F10.3,A)', 'scratch: ', tscratch, ' ms' !---- BENCHMARK FILE -------- ! note that open() default position=asis, access=sequential -open(newunit=u,status='replace',file=fout) -tfile = writetime(u,Nrun) -print '(A10,F10.3,A)','file: ',tfile,' ms' +open(newunit=u, status='replace', file=fout) +tfile = writetime(u, Nrun) +print '(A10,F10.3,A)','file: ', tfile, ' ms' contains -real(wp) function writetime(u,Nrun) +real(wp) function writetime(u, Nrun) - integer, intent(in) :: u,Nrun + integer, intent(in) :: u, Nrun integer(int64) :: tic,toc,tmin, rate integer, volatile :: i integer j - tmin = huge(0_int64) ! need to avoid SAVE behavior by not assigning at initialization + tmin = huge(0_int64) ! need to avoid SAVE behavior by not assigning at initialization call system_clock(count_rate=rate) do j=1,3 call system_clock(tic) do i=1,Nrun - write(u,*) 'into nothingness I go....',i + write(u, '(a,i0)') 'into nothingness I go....', i flush(u) enddo call system_clock(toc)