Greetings,
I’d like to write integer values in array raw to a string hash in hexadecimal format :
write (hash, '(*(z2.2))') (raw(i), i = 1, size(raw))
Is there a way to change the format of the characters to lower case? Format descriptors z and Z both output upper case characters only (at least with GNU Fortran 14).
There is no edit descriptor to print hex values in lowercase. But you appear to be writing into a string, so the simplest solution would appear to be to convert the string to lowercase after you write it.
for example
program testit
character(len=255) :: hash
integer :: i, raw(10)
raw=[(i,i=10,19)]
write (hash, '(*(z2.2))') (raw(i), i = 1, size(raw))
hash=lower(hash)
write(*,*)trim(hash)
contains
elemental pure function lower(str) result (string)
character(*), intent(in) :: str
character(len(str)) :: string
integer :: i
integer,parameter :: diff = iachar('A')-iachar('a')
string = str
do concurrent (i = 1:len_trim(str))
select case (str(i:i))
case ('A':'Z')
string(i:i) = achar(iachar(str(i:i))-diff) ! change letter to miniscule
case default
end select
enddo
end function lower
end program testit
If you are using stdlib, you could use to_lower – Fortran-lang/stdlib to achieve what @urbanjost has proposed.
Well, it seems I have convert to lower case manually. 
Well, if that is an issue another alternative is to convert decimal to hexadecimal (or any other base from 2 to 36 in this case). Everyone always goes with hex. Maybe try base36 instead!
program demo_codebase
implicit none
character(len=1795) :: line
integer :: i, iarr(256)
iarr=[(i,i=0,255)]
write(line,'(*(a))')(codebase(i,16,uc=.false.),i=0,255)
write(*,*)trim(line)
contains
function codebase(inval10,outbase,uc) result(answer)
! @(#) codebase(3f): convert whole number in base 10 to string in base [2-36]
use,intrinsic :: iso_fortran_env, only : stderr=>error_unit, int64,real64
integer,intent(in) :: inval10, outbase
logical,intent(in) :: uc
character(len=:),allocatable :: answer
real(kind=real64) :: inval10_local
integer(kind=int64) :: n, outbase_local, in_sign
answer=''
in_sign=sign(1,inval10)*sign(1,outbase)
inval10_local=abs(inval10)
outbase_local=abs(outbase)
if(outbase_local<2.or.outbase_local>36) then
write(stderr,*) '*codebase* ERROR: base must be between 2 and 36. base was',outbase_local
else
do 55565758595a5b5c5d5e5f5g5h606162636465666768696a6b6c6d6e6f6g6h707172737475767778797a7b7c7d7e7f7g7h80818283848586878889while(inval10_local>0.0 )
n=int(inval10_local-outbase_local*int(inval10_local/outbase_local))
if(n<10) then
answer=achar(iachar('0')+n)//answer
elseif(uc)then
answer=achar(iachar('A')+n-10)//answer
else
answer=achar(iachar('a')+n-10)//answer
endif
inval10_local=int(inval10_local/outbase_local)
enddo
endif
if(in_sign == -1)then
answer='-'//trim(answer)
endif
if(answer == '')then
answer='0'
endif
end function codebase
end program demo_codebase
That’s probably not faster than simply running the following loop over the hex string:
character :: a
integer :: i
do i = 1, len(hash)
a = hash(i:i)
if (a >= 'A' .and. a <= 'Z') hash(i:i) = achar(iachar(a) + 32)
end do
I’ve written interfaces to OpenSSL’s cryptographic hash functions (MD5, RIPEMD-160, SHA-1, SHA-256, …), but still have to convert the digest output to hash strings. Seems to be easier than reimplementing the functions in Fortran.
The function already existed in the more general form where it will generate output from base 2 to base 36 with letters uppercase or lowercase. Cooked down to just doing base16 would make it simpler, but fortran already does BOZ basestw
that you were already using; so this one was more fun. And who knows, maybe base36 hash keys might catch on hex was widely available and two characters can represent any byte value hash keys are almost always multi-byte so a higher base would make them more compact 
lower() and upper() have to be the most re-invented functions in Fortran. I think I have about fifteen of them. Only took seventy years for it to be added as an intrinsic; but probably not in the compiler being used for this. I just grabbed one from my modules that happens to be one I keep around to remind me of the syntax of do-concurrent. It really is fast when given large strings on the right hardware, but the setup time probably makes it slower than several other approaches on some compilers. On the two I use most frequently it is as fast or faster for regular usage though.
And there are many ways to write those subprograms, all with very different performance. The ones that use INDEX() on character strings require the most looping and searching effort. The ones that are implemented as functions require stack and/or heap memory allocations for the return string. The most efficient ones are subroutines that modify the input string in-place (no memory allocation) and use the IACHAR and ACHAR intrinsics to work directly with the integer values (examples are shown above), but the function interface is sometimes more convenient to use within expressions, so there are always compromises and redundancy. And finally, one wonders about the future when character sets are routinely a superset of ascii.
I did not notice this. In f2023?
Well, I spoke too soon. I thought SORT, LOWER, and UPPER made it with TOKENIZE and SPLIT and the others that did make it. Well, it took decades to get DATE_AND_TIME and it still does not define how to set the timezone. If the fpm repository would get a solid site going I do not think I would care much about procedures that did not add to language function possibilities like co_array related ones and so on often do but there is hardly a Fortran repository or compiler that does not have those three so it might be time 
I agree on lower and upper functions. I wrote my first ones back in Hollerith constant days. I’d also like to see Standard sort and grade functions. Not sure why the Fortran Committee has been so stubbornly ignoring them. Seems like a rite of passage for each of us to reinvent these wheels.
DATE_AND_TIME was needed because Y2K efforts were starting to rear their ugly heads. I’m guessing all the programming language committees were being pinged to make sure their respective languages were Y2K compatible.
I’m a late-comer to writing my own upper/lower functions. I only wrote mine about 20 years ago. I’ve stopped trying to make sense of how the committee decides what goes in the standard and what gets left out. To me, SORT, LOWER, and UPPER (based on my experience) have many times more potential users and uses than TOKENIZE and SPLIT. Another thing that puzzles me is why the compiler vendors don’t take it upon themselves to implement these as compiler extensions. I know of no law that says they can’t. After all they spend time supporting non-standard things like UNION etc. Why not a generic SORT?. I would be willing to wager dollars for donuts that the typical Fortran user can come up with several things they would like to see in the language that would get more wide spread usage than a lot of the recent additions in Fortran 2023.
It is a bit bemusing that a few decades ago the biggest complaint about Fortran was that the core standardized features included virtually no system interfaces and that there were way to many extensions locking you into a particular vendor’s hardware. VAX/VMS Fortran could be and was used to write just about any type of program and had so many extensions you might say it had a Fortran-compatible subset but was a language unto it’s own otherwise. I remember several systems where you had machine code and Fortran, often extended. Everyone was clamoring for this type of utility to be standardized into Fortran, but if you already had something written for your Fortran you were giving up an advantage by allowing the feature to be standardized; or allowing for vectorization features might give Cray a big advantage (think F++, which sure looks a lot like coarrays) and so on. So that never happened. So all these other languages evolved, many in a totally different ecosystem like OS; which allows the languages to grow and adapt very rapidly (and with the problems that entails). All those resources spread across so many projects – just think if it was somehow focused on fewer languages all these years.
Now what money is spent on Fortran is to provide for HPC applications to run massively parallel, so there is not the money (nor often the expertise) in the committees for general purpose features and without those languages fail or become niche languages. Even machine code itself has fewer practitioners now than in the past from what I see.
I hope the || development succeeds and that is probably where committee efforts should concentrate (for various reasons, some good some bad). So I think we should all push for the fpm repository package and add as many general packages as the community can support. If that becomes more robust I think that will push de-facto standards to take hold instead of coming and going with individual developers. De-facto standards are a natural for migrating to the standard library; and some of those can be promoted into the true standard, and/or the ideal of general-purpose intrinsics goes away and becomes a part of an OS standard library, accept for those needed to add functionality to the language (versus generality). It seems like the momentum has cooled a bit. Personally, I think having a strong public repository is the key to getting the momentum back myself.
I have used a lot of languages and I still think Fortran is the best one potentially. It just keeps getting hung up on the “potentially” part. But I like Rust and Lua better than Python, so I do not seem to be that good at staying up with the “in” crowd!
PS: Having been around long enough that I laugh aloud when all the new hires always ask why we have any other language than the one they just learned, I wonder how common that is? I can tell someone’s hire date by which language is the only one they think we should have written everything in – Fortran, Lisp, PL/I, Ruby, Pascal, D, Javascript, Java, Python, Julia, Rust, …
Does that happen everywhere? Does it give you a good laugh and accordingly irritate the new guy?
Or when someone wants to do some GUI/graphics and tells you everything should be in IGES/SunView/X11 Athena widgets/GKS/… SVG/Canvas/GTK/Blah/Blah/… or is that just me?
Never underestimate the power of peer pressure. You have to program in Python and/or C++ to be one of the “cool kids”. If you insist on programming in Fortran you are just seen as “one of the olds”.
I am afraid both above solutions are somewhat inconsistent. They both use ASCII-table conversions achar()/iachar() for doing to_lower conversion but at the same time an implementation-dependent case selector 'A':'Z' or if expression a >= 'A' .and. a <= 'Z'. In an implementation based on a non-ASCII character table that will not work. To make it bullet-proof one should probably use
select case (iachar(str(i:i)))
case (iachar('A'):iachar('Z'))
string(i:i) = achar(iachar(str(i:i))-diff)
! or
a = iachar(hash(i:i))
if (a >= iachar('A') .and. a <= iachar('Z')) hash(i:i) = achar(a + 32)
This could be rewritten as lge(a,'A') .and. lle(a,'Z') which uses ASCII lexical ordering.
To give a specific example of the potential problem, the EBCDIC character set, which at one time was used by the majority of computers, has extra characters between ‘A’ and ‘Z’ which would be incorrectly translated with the simple test. If the programmer knew that only alphabetic characters were in the strings, then this detail could be ignored in some situations, such as upper/lower case conversion. In EBCDIC, ‘A’ is z’C1’ and ‘Z’ is z’E9’, so that range includes 41 integer values to cover the 26 characters.
The ASCII upper case letters are all contiguous, so just the iachar(‘A’):iachar(‘Z’) range needs to be selected, as is done in the above code.
Since lower and upper have been re-invented so many times maybe this could
be spun off into a bake-off of all the different versions. Main points for speed and working with EBCDIC and Unicode (where relevant) and using Fortran intrinsic || features?
To start it off I submit this skeleton with five versions and timing built in for starters
Well, at least with default gfortran options the do concurrent
-dependent one I have been using personally got squeezed out by the generic
one that builds a table of all the single-byte characters when running
serially.
case 2 was slow as expected, as the ones based on INDEX() would have a
hard time being fastest.
case 1 did very well for timing, at only slightly faster than a plain
copy but it is ASCII-only and scalar.only; but is probably closest to the classic model people often add to their go-to box.
to_upper and to_lower are from stdlib for plain ASCII, but it has a
STRING type that has arrays with elements of various lengths and is
part of a library with multiple developer support; but there is a
preliminary indication it could be tweeked better for speed.
playing with copying each character versus setting output to input
and then only changing characters that need changed, converting to
integers or arrays of single characters versus working with strings,
allowing for non-ASCII collating character sets (none of these would
still work with ASCII 6/12 though!), different compilers and different
optimization switches, coarrays, running the do_concurrent in parallel,
… could play with this for way to long :>
If you can make your procedure version be a function that returns a
non-allocatable string of the same length just stick them in the M_case
module and then call them from the program and they will get timed.
For subroutines or other return types you would have to work at it but
this is a demonstration as well of
So far with GNU Fortran (GCC) 13.2.1 20240426 with default
parameters case 4 is generic and has good speed. Could not
think of a way to build the table at compile time without
running something to build the code on a per-platform basis.
! BASELINE:Elapsed time (sec) ::.072980200
!
! upper1:Elapsed time (sec) ::.150859800
! upper3:Elapsed time (sec) ::.164521000
! upper4:Elapsed time (sec) ::.172557100
! to_upper:Elapsed time (sec) ::.332142000
! upper2:Elapsed time (sec) ::1.777680100
!
! lower1:Elapsed time (sec) ::.135766700
! lower3:Elapsed time (sec) ::.160704800
! lower4:Elapsed time (sec) ::.204008100
! to_lower:Elapsed time (sec) ::.346519400
! lower2:Elapsed time (sec) ::1.871481100
The terms “uppercase” and “lowercase” date back to the early days of
the mechanical printing press. Individual metal alloy casts of each
needed letter, or punctuation symbol, were meticulously added to a
press block, by hand, before rolling out copies of a page. These
metal casts were stored and organized in wooden cases. The more
often needed miniscule letters were placed closer to hand, in the
lower cases of the work bench. The less often needed, capitalized,
majuscule letters, ended up in the harder to reach upper cases.
module M_case
use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64
implicit none
private
character(len=26), parameter, private :: low = "abcdefghijklmnopqrstuvwxyz"
character(len=26), parameter, private :: high = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
integer(kind=int8), parameter :: ascii_diff = abs(iachar('A',kind=int8) - iachar('a',kind=int8))
integer :: i
character(len=1),save,private :: convtableL(0:255) = [(char(i),i=0,255)]
character(len=1),save,private :: convtableU(0:255) = [(char(i),i=0,255)]
logical, save :: first = .true.
public :: upper1,lower1 ! assumes ASCII collating sequence
public :: upper2,lower2 ! any one-byte collating sequence, (a)
public :: upper3,lower3 ! any one-byte collating sequence, (a)
public :: upper4,lower4 ! assumes ASCII collating sequence
public :: to_upper, to_lower ! sssumes ASCII collating sequence
! (a) avoids issues with EBCDIC not having A-Z as contigious letters
! subroutines are potentially much faster
contains
function upper1(str) result(translated)
character(*), intent(in) :: str
integer :: i
character(len=len(str)) :: translated
translated=str
do i = 1, len(str)
select case(str(i:i))
case("a":"z")
translated(i:i) = achar(iachar(str(i:i))-ascii_diff)
end select
enddo
end function upper1
function lower1(str) result(translated)
character(*), intent(in) :: str
integer :: i
character(len=len(str)) :: translated
translated=str
do i = 1, len(str)
select case(str(i:i))
case("A":"Z")
translated(i:i) = achar(iachar(str(i:i))+ascii_diff)
end select
enddo
end function lower1
function upper2(str) result(translated)
character(len=*),intent(in) :: str
integer :: i,c
character(len=len(str)) :: translated
translated=str
do i = 1,len(str)
c = index(low,str(i:i))
if (c.gt.0) translated(i:i) = high(c:c)
end do
end
function lower2(str) result(translated)
character(len=*),intent(in) :: str
integer :: i,c
character(len=len(str)) :: translated
translated=str
do i = 1,len(str)
c = index(high,str(i:i))
if (c.gt.0) translated(i:i) = low(c:c)
end do
end function lower2
subroutine loadtable()
integer :: i
do i=1,len(low)
convtableL(iachar(low(i:i))) = char(iachar(high(i:i)))
convtableU(iachar(high(i:i))) = char(iachar(low(i:i)))
enddo
first = .false.
end subroutine loadtable
function upper3(str) result(translated)
character(len=*),intent(in) :: str
character(len=len(str)) :: translated
integer :: i
if(first) call loadtable()
translated = str
do i=1,len_trim(str)
translated(i:i) = convtableL(iachar(str(i:i)))
enddo
end function upper3
function lower3(str) result(translated)
character(len=*),intent(in) :: str
character(len=len(str)) :: translated
integer :: i
if(first) call loadtable()
translated = str
do i=1,len_trim(str)
translated(i:i) = convtableU(iachar(str(i:i)))
enddo
end function lower3
pure function upper4(str) result (translated)
character(*), intent(in) :: str ! input string to convert to all uppercase
character(len(str)) :: translated ! output string that contains no miniscule letters
integer :: i ! loop counter
! note using kind=int8 is faster than int32 in gfortran
integer(kind=int8), parameter :: ade_a = iachar('a'), ade_z = iachar('z')
integer(kind=int8) :: ade_char
do concurrent(i=1:len(str)) ! step thru each letter in the string in specified range
ade_char = iachar(str(i:i), int8) ! ASCII Decimal Equivalent
if (ade_char >= ade_a .and. ade_char <= ade_z) ade_char = ade_char - ascii_diff
translated(i:i) = achar(ade_char)
enddo
if(len(str).eq.0)translated = str
end function upper4
pure function lower4(str) result (translated)
character(*), intent(in) :: str
character(len(str)) :: translated
integer :: i
integer(kind=int8), parameter :: ade_a = iachar('A'), ade_z = iachar('Z')
integer(kind=int8) :: ade_char
translated = str
do concurrent (i = 1:len_trim(str))
ade_char = iachar(str(i:i), int8)
if (ade_char >= ade_a .and. ade_char <= ade_z) ade_char = ade_char + ascii_diff
translated(i:i) = achar(ade_char)
enddo
if(len(str).eq.0)translated = str
end function lower4
!> Returns the corresponding lowercase letter, if `c` is an uppercase
!> ASCII character, otherwise `c` itself.
pure function char_to_lower(c) result(t)
character(len=1), intent(in) :: c !! A character.
character(len=1) :: t
integer, parameter :: wp= iachar('a')-iachar('A'), BA=iachar('A'), BZ=iachar('Z')
integer :: k
!Check whether the integer equivalent is between BA=65 and BZ=90
k = ichar(c)
if (k>=BA.and.k<=BZ) k = k + wp
t = char(k)
end function char_to_lower
!> Returns the corresponding uppercase letter, if `c` is a lowercase
!> ASCII character, otherwise `c` itself.
pure function char_to_upper(c) result(t)
character(len=1), intent(in) :: c !! A character.
character(len=1) :: t
integer, parameter :: wp= iachar('a')-iachar('A'), la=iachar('a'), lz=iachar('z')
integer :: k
!Check whether the integer equivalent is between la=97 and lz=122
k = ichar(c)
if (k>=la.and.k<=lz) k = k - wp
t = char(k)
end function char_to_upper
!> Convert character variable to lower case
!> ([Specification](../page/specs/stdlib_ascii.html#to_lower))
!>
!> Version: experimental
pure function to_lower(string) result(lower_string)
character(len=*), intent(in) :: string
character(len=len(string)) :: lower_string
integer :: i
do i = 1, len(string)
lower_string(i:i) = char_to_lower(string(i:i))
end do
end function to_lower
!> Convert character variable to upper case
!> ([Specification](../page/specs/stdlib_ascii.html#to_upper))
!>
!> Version: experimental
pure function to_upper(string) result(upper_string)
character(len=*), intent(in) :: string
character(len=len(string)) :: upper_string
integer :: i
do i = 1, len(string)
upper_string(i:i) = char_to_upper(string(i:i))
end do
end function to_upper
end module M_case
module M_tictoc
use,intrinsic :: iso_fortran_env, only : int32,int64,real32,dp=>real64
use,intrinsic :: iso_fortran_env, only : stdout=>OUTPUT_UNIT
implicit none
private
type timer
real(kind=dp) :: cpu_start
real(kind=dp) :: cpu_end
integer(kind=int64) :: clock_start
integer(kind=int64) :: clock_end
integer :: wall_start(8)
integer :: wall_end(8)
contains
procedure :: tic => clock_tic
procedure :: toc => clock_toc
procedure :: print => clock_print
procedure :: walltime => clock_walltime
procedure :: cputime => clock_cputime
procedure :: dattime => clock_dattime
end type
interface timer
procedure :: clock_new
end interface timer
! type for unix epoch time and julian days
integer,parameter,public :: realtime=dp
public :: timer
public :: say_hello
public :: catstat
character(len=*),parameter :: gen='(*(g0))'
character(len=*),parameter :: all='(*(g0,1x))'
contains
! initialization constructor
type(timer) function clock_new(this)
type(timer),intent(in),optional :: this
call cpu_time(clock_new%cpu_start)
call system_clock(clock_new%clock_start)
call date_and_time(values=clock_new%wall_start)
clock_new%cpu_end= clock_new%cpu_start
clock_new%clock_end= clock_new%clock_start
clock_new%wall_end= clock_new%wall_start
end function clock_new
subroutine clock_tic(this)
class(timer) :: this
call cpu_time(this%cpu_start)
call system_clock(this%clock_start)
call date_and_time(values=this%wall_start)
this%cpu_end = this%cpu_start
this%clock_end = this%clock_start
this%wall_end = this%wall_start
end subroutine clock_tic
subroutine clock_toc(this)
class(timer) :: this
call cpu_time(this%cpu_end)
call system_clock(this%clock_end)
call date_and_time(values=this%wall_end)
end subroutine clock_toc
subroutine clock_print(this,string,lun)
class(timer),intent(in) :: this
character(len=*),intent(in),optional :: string
integer(kind=int32),intent(in),optional :: lun
integer(kind=int32) :: lun_
real(kind=dp) :: elapsed_time
real(kind=realtime) :: elapsed_date_and_time
real(kind=dp) :: cpu_time
character(len=105) :: biggest
integer(kind=int64) :: count_rate
character(len=:),allocatable :: string_
if(present(lun))then
lun_=lun
else
lun_=stdout
endif
elapsed_time = this%walltime()
elapsed_date_and_time = this%dattime()
cpu_time = this%cputime()
string_ = ''; if(present(string)) string_ = string//':'
if(elapsed_date_and_time >= 0)then
write( lun_,'(a,f0.3)') string_//'Elapsed dat (sec) ::',elapsed_date_and_time
else
write( lun_,'(a)') string_//'Elapsed dat (sec) :: N/A'
endif
! try to make a reasonable format for the number of digits of precision
call system_clock(count_rate=count_rate) ! Find the time rate
write(biggest,'("(a,f0.",i0,")")')ceiling(log10(real(count_rate,kind=dp)))
write( lun_,biggest) string_//'Elapsed time (sec) ::',elapsed_time
write( lun_,gen) string_//'CPU time (sec) ::',cpu_time
write( lun_,'(a,1x,f0.2)') string_//'Percentage ::',(cpu_time/elapsed_time)*100
end subroutine clock_print
function clock_walltime(this) result(elapsed_time)
class(timer) :: this
integer(kind=int64) :: count_rate
real(kind=dp) :: elapsed_time
real(kind=dp) :: cpu_time
call system_clock(count_rate=count_rate)
elapsed_time = real(this%clock_end-this%clock_start,kind=dp)/real(count_rate,kind=dp)
end function clock_walltime
function clock_cputime(this) result(cpu_time)
class(timer) :: this
real(kind=dp) :: cpu_time
cpu_time = real(this%cpu_end-this%cpu_start,kind=dp)
end function clock_cputime
function clock_dattime(this) result(cpu_time)
class(timer) :: this
real(kind=dp) :: cpu_time
real(kind=realtime) :: endit,startit
integer :: ierr
call date_to_julian(this%wall_end,endit,ierr)
call date_to_julian(this%wall_start,startit,ierr)
if(ierr == 0)then
cpu_time = real((endit-startit)*86400,kind=dp)
else
cpu_time = -huge(cpu_time)
endif
end function clock_dattime
subroutine date_to_julian(dat,julian,ierr)
! @(#)M_time::date_to_julian(3f): Converts proleptic Gregorian DAT date-time array to Julian Date
! REFERENCE: From Wikipedia, the free encyclopedia 2015-12-19
! correction for time zone should or should not be included?
integer,intent(in) :: dat(8)! array like returned by DATE_AND_TIME(3f)
real(kind=realtime),intent(out) :: julian
integer,intent(out) :: ierr ! 0 =successful, -1=bad year, -4=bad date 29 Feb, non leap-year, -6 negative value -9 bad input
integer :: a , y , m , jdn
integer :: utc
utc=dat(4)*60
julian = -huge(99999) ! this is the date if an error occurs and IERR is < 0
if(any(dat == -huge(dat)))then
ierr=-9
return
endif
associate&
&(year=>dat(1),month=>dat(2),day=>dat(3),utc=>utc,hour=>dat(5),minute=>dat(6),second=>dat(7)-utc+dat(8)/1000.0d0)
if ( year==0 .or. year<-4713 ) then
ierr = -1
else
ierr=0
! You must compute first the number of years (Y) and months (M) since March 1st -4800 (March 1, 4801 BC)
a = (14-month)/12 ! A will be 1 for January or February, and 0 for other months, with integer truncation
y = year + 4800 - a
m = month + 12*a - 3 ! M will be 0 for March and 11 for February
! All years in the BC era must be converted to astronomical years, so that 1BC is year 0, 2 BC is year "-1", etc.
! Convert to a negative number, then increment towards zero
! Staring from a Gregorian calendar date
jdn = day + (153*m+2)/5 + 365*y + y/4 - y/100 + y/400 - 32045 ! with integer truncation
! Finding the Julian Calendar date given the JDN (Julian day number) and time of day
julian = jdn + (hour-12)/24.0_realtime + (minute)/1440.0_realtime + second/86400.0_realtime
ierr=merge(-6,ierr, julian<0.0_realtime ) ! Julian Day must be non-negative
endif
end associate
end subroutine date_to_julian
subroutine say_hello()
use, intrinsic :: iso_fortran_env, only : compiler_version
use, intrinsic :: iso_fortran_env, only : compiler_options
character(len=*),parameter :: all='(*(g0,1x))'
character(len=*),parameter :: chs='(*(g0))'
character(len=2) :: ch, split
integer :: argument_length, istat, posix, dos, i
character(len=:),allocatable :: progname, options
call get_command_argument(number=0,length=argument_length)
if(allocated(progname))deallocate(progname)
allocate(character(len=argument_length) :: progname)
call get_command_argument (0, progname, status=istat)
print all, 'run date.....:',iso_8601()
if (istat == 0) then
print all, "program name.:" // trim (progname)
else
print all, "Could not get the program name " // trim (progname)
endif
print all, 'compiled by..:', compiler_version()
options=' '//compiler_options()
if(options /= '')then
print all, 'using options:'
! guess which one
posix=0
dos=0
do i=2,len(options)
ch=options(i-1:i)
select case(ch)
case(' -'); posix=posix+1
case(' /'); dos=dos+1
end select
enddo
split=merge(' -',' /',posix > 0)
do i=2,len(options)
ch=options(i-1:i)
if(ch == split)then
write(*,chs,advance='no')char(10),ch
else
write(*,chs,advance='no')ch(2:2)
endif
enddo
print all
endif
print all
end subroutine say_hello
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
impure elemental function irand(first,last)
!@(#) a random whole number from FIRST to LAST inclusive
use, intrinsic :: iso_fortran_env, only : dp=>real64
integer,intent(in) :: first,last
real(kind=dp) :: rand_val
integer :: irand
call random_number(rand_val)
irand=first+floor((last+1-first)*rand_val)
end function irand
subroutine catstat()
!@(#) on linux systems show process statistics. System-dependent
integer :: exitstat
integer :: cmdstat
character(len=255) :: cmdmsg
call execute_command_line("cat /proc/$PPID/status", exitstat=exitstat,cmdstat=cmdstat,cmdmsg=cmdmsg)
end subroutine catstat
end module M_tictoc
program doit
use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64
use M_tictoc, only : timer, say_hello, catstat
use M_case
character(len=*),parameter :: original = "abcdxyz ZXYDCBA _!@"
character(len=*),parameter :: originalu = "ABCDXYZ ZXYDCBA _!@"
character(len=*),parameter :: originall = "abcdxyz zxydcba _!@"
character(len=*),parameter :: gen='(*(g0,1x))'
character(len=:),allocatable :: s
type(timer) :: clock
namelist /vals/ clock
!
! To test variants of a procedure change HOW_MANY_TIMES
! and replace the NOSPACE* names with your procedure names and
! change the interface block to describe your procedure name
! the testprocedures module is where to put your variants
! or use some other module with the routines in it.
integer,parameter :: how_many_times=1000000
call say_hello()
! first a little confidence test
print *,"original: ",'[',original,']'
print *,"upper1: ",'[',upper1(original),']', upper1(original).eq.originalu
print *,"lower1: ",'[',lower1(original),']', lower1(original).eq.originall
print *,"upper2: ",'[',upper2(original),']', upper2(original).eq.originalu
print *,"lower2: ",'[',lower2(original),']', lower2(original).eq.originall
print *,"upper3: ",'[',upper3(original),']', upper3(original).eq.originalu
print *,"lower3: ",'[',lower3(original),']', lower3(original).eq.originall
print *,"upper4: ",'[',upper4(original),']', upper4(original).eq.originalu
print *,"lower4: ",'[',lower4(original),']', lower4(original).eq.originall
print *,"to_upper: ",'[',to_upper(original),']', to_upper(original).eq.originalu
print *,"to_lower: ",'[',to_lower(original),']', to_lower(original).eq.originall
! now some timing
clock=timer()
! PONDER: some would be faster the less changes there are
! PONDER: subroutines would potentially be faster than functions
call timeit('BASELINE',baseline)
call timeit('upper1',upper1)
call timeit('upper2',upper2)
call timeit('upper3',upper3)
call timeit('upper4',upper4)
call timeit('to_upper',to_upper)
call timeit('lower1',lower1)
call timeit('lower2',lower2)
call timeit('lower3',lower3)
call timeit('lower4',lower4)
call timeit('to_lower',to_lower)
block
use,intrinsic :: iso_fortran_env, only : int8,int16,int32,int64,real32,real64,real128
use,intrinsic :: iso_fortran_env, only : stderr=>ERROR_UNIT, stdin=>INPUT_UNIT, stdout=>OUTPUT_UNIT
character(len=*),parameter :: g='(*(g0,1x))'
integer(kind=int64) :: icount64, icount_rate64, icount_max64
real(kind=real64) :: frequency
print g,':SYSTEM_CLOCK PRECISION:'
call system_clock(icount64, icount_rate64, icount_max64)
print g,'COUNT_MAX(64bit)=' , icount_max64
print g,'COUNT_RATE(64bit)=' , icount_rate64
frequency=real(icount_max64,kind=int64)/real(icount_rate64,kind=real64)
print g,'FLIP EVERY N(secs)=' , frequency ,' (days)==>',frequency/86400_real64
print g,'CURRENT COUNT(64bit)=' , icount64
print g,'next flip(secs)=',dble(icount_max64-icount64)/icount_rate64,'(days)==>', dble(icount_max64-icount64)/icount_rate64/86400
endblock
call catstat()
contains
subroutine timeit(label,procedure)
! OPTIMIZING LOOP AWAY
! assuming the loop itself is not complex and possibly in need of unrolling and so on
! and that it is so simple the compiler is optimizing it away because nothing in the
! loop is used the loop may be identified as "dead code" and eliminated.
!
! + passing the procedure tends to prevent the loop being optimized away
! + using the volatile property also helps prevent loops from being optimized away
! + a write statement after the loop might also help, as well
! + finally, calling a function, particulary one writing values from a random pass helps
character(len=*),intent(in) :: label
character(len=:),volatile,allocatable :: t
interface
function procedure(string)
character(len=*),intent(in) :: string
character(len=len(string)) :: procedure
end function
end interface
integer :: i
print gen
call clock%tic()
do i=1,how_many_times
t=procedure('This is a TEST ')
enddo
call clock%toc()
call clock%print(label)
write(*,*)t
! write(*,*)clock
! write (*, nml=vals) ! using NAMELIST creates easy-to-postprocess logs
! print gen, label//':CPU TIME = ', clock%cputime()
end subroutine timeit
function baseline(line)
character(len=*),intent(in) :: line
character(len=len(line)) :: baseline
baseline=line
end function baseline
end program doit
Here is an example of one of the subroutines in some code that I use.
elemental subroutine str_low( string )
! change all upper case characters in string to lower case in place.
implicit none
character(len=*), intent(inout) :: string
integer :: i, ic
intrinsic :: len_trim, achar, iachar
do i = 1, len_trim(string)
ic = iachar( string(i:i) )
if ( UA <= ic .and. ic <= UZ ) string(i:i) = achar( ic + ludiff )
enddo
return
end subroutine str_low
This is contained in a module that defines the constants UA, UZ, ludiff, and so on. Hopefully those are all obvious. The other routines in that module follow the same general style. Some of the considerations are:
len_trim() is used instead of len() in the do loop range. This can shorten the loop, but at the expense of the len_trim() reference.