Fortran Wiki
M_get_env
The M_get_env module supplements the Fortran intrinsic get_environment_variable(3).
Precisely, the M_get_env module defines a function for reading an environment variable that allows defining a default and casting the return value to the same type and kind as the default; including optionally returning an ISO_10646 variable encoding Unicode data on platforms that support UTF-8 data and the ISO_10646 character kind.
It also provides a convenience function returning the directory name intended for use by scratch files on Unix-Like Environments (ULE).
Building on platform with bash without Unicode
#!/bin/bash
# Using Intel compiler without Unicode:
ifx -UUNICODE M_get_env.F90 demo_get_env.F90 -o demo_get_env
CHARACTER='Hello World!'
REAL='20.34'
export CHARACTER REAL
./demo_get_env
exitExpected output
/home/jost
/home/jost/.local/bin:/bin:/usr/bin:/usr/local/bin
Hello World!
100
20.140000
300.00000000000000
0.0000000000000000
TA platform with Unicode and bash
#!/bin/bash
# Using gfortran compiler with Unicode:
gfortran -DUNICODE M_get_env.F90 demo_get_env.F90 -o demo_get_env
export UCS4="己所不欲，勿施於人"
# (jǐ suǒ bù yù, wù shī yú rén)
# "What you do not want done to yourself, do not do to others"
./demo_get_env
exitExpected output
/home/jost
/home/jost/.local/bin:/bin:/usr/bin:/usr/local/bin
string
100
200.000000
300.00000000000000
0.0000000000000000
T
己所不欲，勿施於人demo_get_env.F90
An example program to exercise the module
!#undef UNICODE
!#define UNICODE
program demo_get_env
use, intrinsic :: iso_fortran_env, only : output_unit
use M_get_env, only : get_env
implicit none
integer, parameter :: dp = kind(0.0d0)
integer :: ierr
character(len=:),allocatable :: HOME
!Basics
HOME=get_env('HOME','UNKNOWN')
write(*,'(a)')HOME
write(*,'(a)') get_env('PATH')
write(*,'(a)') get_env('CHARACTER','string')
write(*,'(i0)')get_env('INTEGER',100)
write(*,'(g0)')get_env('REAL',200.0)
write(*,'(g0)')get_env('DOUBLE',300.0d0)
write(*,'(g0)')get_env('DOUBLE',0.0_dp)
write(*,'(l1)')get_env('LOGICAL',.true.,ierr=ierr)
#ifdef UNICODE
UCS4: BLOCK
! UCS4 values (but not environment variable name) may be KIND=UCS4
integer, parameter :: ucs4 = selected_char_kind ('ISO_10646')
character(len=:,kind=ucs4),allocatable :: SMILEY
SMILEY=char(int(z'1F60E'),kind=ucs4) ! SMILING FACE WITH SUNGLASSES
open (output_unit, encoding='UTF-8')
!
write(*,'(a)')get_env('UCS4',SMILEY,ierr=ierr)
!
! a UCS4 constant string as default requires a kind type parameter
write(*,'(a)')get_env('UCS4',ucs4_'',ierr=ierr)
!
ENDBLOCK UCS4
#endif
end program demo_get_envM_get_env.F90
!#undef UNICODE
!#define UNICODE
MODULE M_get_env
use, intrinsic :: iso_fortran_env, only : stderr=>error_unit
implicit none
private
public get_env
public get_tmp
interface get_env
module procedure get_env_integer
module procedure get_env_real
module procedure get_env_double
module procedure get_env_character
module procedure get_env_logical
#ifdef UNICODE
module procedure get_env_ucs4
#endif
end interface get_env
type :: force_keywd_hack ! force keywords, using @awvwgk method
end type force_keywd_hack
! so then any argument that comes afer "force_keywd" is a compile time error
! if not done with a keyword
CONTAINS
!>
!!##NAME
!! get_env(3f) - [M_get_env] a function returning the value of
!! an environment variable
!! (LICENSE:PD)
!!
!!##SYNTAX
!! function get_env(NAME,DEFAULT,IERR=IERR) result(VALUE)
!!
!! integer, parameter :: ucs4 = selected_char_kind ('ISO_10646')
!! character(len=*),intent(in) :: NAME
!!
!! ! DEFAULT is one of ...
!! o character(len=*),intent(in),optional :: DEFAULT
!! o real,intent(in) :: DEFAULT
!! o integer,intent(in) :: DEFAULT
!! o doubleprecision,intent(in) :: DEFAULT
!! o logical,intent(in) :: DEFAULT
!! o character(len=*,kind=ucs4),intent(in) :: DEFAULT
!!
!! integer,intent(out),optional :: IERR
!!
!! ! VALUE is the type and kind of DEFAULT
!!
!!##DESCRIPTION
!! Get the value of an environment variable or optionally return a
!! default value when the environment variable is not set or is set
!! to a blank string.
!!
!! The type and kind returned is the same as that of the default value.
!!
!!##OPTIONS
!! NAME name of environment variable
!! DEFAULT value to return if environment variable is not set or set
!! to an empty string. May be CHARACTER, REAL, INTEGER,
!! LOGICAL or DOUBLEPRECISION. Defaults to a null CHARACTER value.
!! A KIND of UCS4 is allowed on platforms that support it.
!!##RETURNS
!! VALUE the value of the environment variable or the default.
!! The type is the same as DEFAULT. If an error occurs and DEFAULT
!! is numeric, huge(0|0.0|0.0d0) is returned.
!!
!! For a LOGICAL type, Any environment variable value starting
!! with F,f,N or n is .FALSE. and any value starting with
!! Y,y,T or t is .TRUE. . A leading period (".") is ignored.
!! Anything else returns .FALSE. .
!!
!! IERR return error code. Must be specified with a keyword.
!! It is zero if no error occurred. If not present and an error
!! occurs the program stops.
!!
!!##EXAMPLE
!!
!! Sample program:
!!
!! program demo_get_env
!! use M_get_env, only : get_env
!! character(len=*),parameter :: g='(*(g0))'
!! integer :: ierr
!! character(len=:),allocatable :: HOME
!! !Basics
!!
!! HOME=get_env('HOME','UNKNOWN')
!! write(*,'(a)')HOME
!!
!! write(*,'(a)')get_env('PATH')
!!
!! write(*,g)get_env('CHARACTER','string')
!! write(*,g)get_env('INTEGER',100)
!! write(*,g)get_env('REAL',200.0)
!! write(*,g)get_env('DOUBLE',300.0d0)
!! write(*,g)get_env('LOGICAL',.true.,ierr=ierr)
!!
!! end program demo_get_env
!!
!!##AUTHOR
!! John S. Urban
!!
!!##LICENSE
!! MIT
function get_env_character(NAME,DEFAULT,force_keywd,ierr) result(VALUE)
implicit none
character(len=*),intent(in) :: NAME
character(len=*),intent(in),optional :: DEFAULT
type(force_keywd_hack),optional,intent(in) :: force_keywd
integer,intent(out),optional :: ierr
character(len=:),allocatable :: VALUE
character(len=255) :: errmsg
integer :: howbig
integer :: stat
integer :: length
! get length required to hold value
length=0
errmsg='failed to get environment variable '//trim(NAME)
stat=0
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=''
stat=0
case (2)
!*!print *, "This processor doesn't support environment variables. Boooh!"
VALUE=''
case default
! make string to hold value of sufficient size
allocate(character(len=max(howbig,1)) :: VALUE)
! get value
!call get_environment_variable(NAME,VALUE,status=stat,trim_name=.true.,errmsg=errmsg)
call get_environment_variable(NAME,VALUE,status=stat,trim_name=.true.)
if(stat.ne.0)VALUE=''
end select
else
VALUE=''
endif
if(VALUE.eq.''.and.present(DEFAULT))VALUE=DEFAULT
if(present(ierr))then
ierr=stat
if(stat.ne.0)write(stderr,'(*(g0))')'<WARNING>*get_env*'//trim(errmsg)
elseif(stat.ne.0)then
write(stderr,'(*(g0))')'<ERROR>*get_env*'//trim(errmsg)
stop stat
endif
end function get_env_character
function get_env_real(NAME,DEFAULT,force_keywd,ierr) result(VALUE)
character(len=*),intent(in) :: NAME
real,intent(in) :: DEFAULT
type(force_keywd_hack), optional, intent(in) :: force_keywd
integer,intent(out),optional :: ierr
real :: VALUE
character(len=:),allocatable :: STRING
integer :: iostat
character(len=255) :: iomsg, fmt
STRING=get_env_character(NAME,'')
iostat=0
iomsg=''
if(STRING.eq.'')then
VALUE=DEFAULT
else
write(fmt,'(*(g0))')'(g',max(1,len(string)),'.0)'
string=string//' '
read(STRING,fmt,iostat=iostat,iomsg=iomsg)value
if(iostat.ne.0)then
value=-huge(0.0)
endif
endif
if(present(ierr))then
ierr=iostat
if(iostat.ne.0)write(stderr,'(a)')'<WARNING>*get_env* NAME='//NAME//' STRING='//STRING//':'//trim(iomsg)
elseif(iostat.ne.0)then
write(stderr,'(a)')'<ERROR>*get_env* NAME='//NAME//' STRING='//STRING//':'//trim(iomsg)
stop
endif
end function get_env_real
function get_env_double(NAME,DEFAULT,force_keywd,ierr) result(VALUE)
character(len=*),intent(in) :: NAME
doubleprecision,intent(in) :: DEFAULT
type(force_keywd_hack), optional, intent(in) :: force_keywd
integer,intent(out),optional :: ierr
doubleprecision :: VALUE
character(len=:),allocatable :: STRING
integer :: iostat
character(len=255) :: iomsg, fmt
STRING=get_env_character(NAME,'')
iostat=0
iomsg=''
if(STRING.eq.'')then
VALUE=DEFAULT
else
write(fmt,'(*(g0))')'(g',max(1,len(string)),'.0)'
string=string//' '
read(STRING,fmt,iostat=iostat,iomsg=iomsg)value
if(iostat.ne.0)then
value=-huge(0.0d0)
endif
endif
if(present(ierr))then
ierr=iostat
if(iostat.ne.0)write(stderr,'(a)')'<WARNING>*get_env* NAME='//NAME//' STRING='//STRING//':'//trim(iomsg)
elseif(iostat.ne.0)then
write(stderr,'(a)')'<ERROR>*get_env* NAME='//NAME//' STRING='//STRING//':'//trim(iomsg)
stop iostat
endif
end function get_env_double
function get_env_integer(NAME,DEFAULT,force_keywd,ierr) result(VALUE)
character(len=*),intent(in) :: NAME
integer,intent(in) :: DEFAULT
type(force_keywd_hack), optional, intent(in) :: force_keywd
integer,intent(out),optional :: ierr
integer :: VALUE
character(len=:),allocatable :: STRING
integer :: iostat
character(len=255) :: iomsg, fmt
STRING=get_env_character(NAME,'')
iomsg=''
if(STRING.eq.'')then
VALUE=DEFAULT
iostat=0
else
write(fmt,'(*(g0))')'(i',max(1,len(string)),')'
string=string//' '
read(STRING,fmt,iostat=iostat,iomsg=iomsg)value
if(iostat.ne.0)then
value=-huge(0)
endif
endif
if(present(ierr))then
ierr=iostat
if(iostat.ne.0)write(stderr,'(a)')'<WARNING>*get_env* NAME='//NAME//' STRING='//STRING//':'//trim(iomsg)
elseif(iostat.ne.0)then
write(stderr,'(a)')'<ERROR>*get_env* NAME='//NAME//' STRING='//STRING//':'//trim(iomsg)
stop iostat
endif
end function get_env_integer
function get_env_logical(NAME,DEFAULT,force_keywd,ierr) result(VALUE)
character(len=*),intent(in) :: NAME
logical,intent(in) :: DEFAULT
type(force_keywd_hack), optional, intent(in) :: force_keywd
integer,intent(out),optional :: ierr
logical :: VALUE
character(len=:),allocatable :: STRING
integer :: iostat
character(len=255) :: iomsg, fmt
character(len=1) :: ch
STRING=get_env_character(NAME,'',ierr=iostat)
if(iostat.ne.0)then
VALUE=.false.
elseif(STRING.eq.'')then
VALUE=DEFAULT
iostat=0
else
string=string//' '
ch=string(1:1)
if(ch.eq.'.')ch=string(2:2)
select case(ch)
case('t','T','y','Y')
value=.true.
case('f','F','n','N')
value=.false.
case default
value=.false.
end select
endif
if(present(ierr))then
ierr=iostat
if(iostat.ne.0)write(stderr,'(a)')'<WARNING>*get_env* NAME='//NAME//' STRING='//STRING//':'//trim(iomsg)
elseif(iostat.ne.0)then
write(stderr,'(a)')'<ERROR>*get_env* NAME='//NAME//' STRING='//STRING//':'//trim(iomsg)
stop iostat
endif
end function get_env_logical
#ifdef UNICODE
function get_env_ucs4(NAME,DEFAULT,force_keywd,ierr) result(VALUE)
implicit none
integer, parameter :: ucs4 = selected_char_kind ('ISO_10646')
character(len=*),intent(in) :: NAME
character(len=*,kind=ucs4),intent(in) :: DEFAULT
type(force_keywd_hack),optional,intent(in) :: force_keywd
integer,intent(out),optional :: ierr
character(len=:),allocatable :: AVALUE
character(len=:,kind=ucs4),allocatable :: VALUE
character(len=:),allocatable :: ADEFAULT
integer :: ierr2
ADEFAULT=ucs4_to_utf8_via_io(DEFAULT)
if(present(ierr))then
AVALUE=get_env_character(NAME,ADEFAULT,IERR=IERR)
if(ierr.ne.0)write(stderr,'(a)')'<WARNING>*get_env* NAME='//NAME//': '
else
AVALUE=get_env_character(NAME,ADEFAULT,ierr=ierr2)
if(ierr2.ne.0)then
write(stderr,'(a)')'<ERROR>*get_env* NAME='//NAME//': '
stop
endif
endif
VALUE=utf8_to_ucs4_via_io(AVALUE)
end function get_env_ucs4
function ucs4_to_utf8_via_io(ucs4_str) result(corrected)
integer, parameter :: ucs4 = selected_char_kind ('ISO_10646')
character(len=*,kind=ucs4),intent(in) :: ucs4_str
character(len=:),allocatable :: corrected
character(len=(len(ucs4_str)*4)) :: line
integer :: lun
open(newunit=lun,encoding='UTF-8',status='scratch')
write(lun,'(A)')ucs4_str
rewind(lun)
open(unit=lun,encoding='default')
read(lun,'(A)')line
close(lun)
corrected=trim(line)
end function ucs4_to_utf8_via_io
function utf8_to_ucs4_via_io(string) result(corrected)
integer, parameter :: ucs4 = selected_char_kind ('ISO_10646')
character(len=*),intent(in) :: string
character(len=:,kind=ucs4),allocatable :: corrected
character(len=(len(string)),kind=ucs4) :: line
integer :: lun
open(newunit=lun,encoding='UTF-8',status='scratch')
write(lun,'(A)')string
rewind(lun)
read(lun,'(A)')line
close(lun)
corrected=trim(line)
end function utf8_to_ucs4_via_io
#endif
!>
!!##NAME
!! get_tmp(3f) - [M_get_env:QUERY] Return the name of the scratch directory
!! (LICENSE:PD)
!!##SYNOPSIS
!!
!! function get_tmp() result(tname)
!!
!! character(len=:),allocatable :: tname
!!##DESCRIPTION
!!
!! Return the name of the scratch directory set by the most common
!! environment variables used to designate a scratch directory.
!! $TMPDIR is the canonical environment variable in Unix and POSIX[1]
!! to use to specify a temporary directory for scratch space. If $TMPDIR
!! is not set, $TEMP, $TEMPDIR, and $TMP are examined in that order until
!! one is non-blank.
!!
!! If nothing is set "/tmp/" is returned. The returned value always ends in
!! "/". No test is made that the directory exists or is writable.
!!
!!##EXAMPLE
!!
!!
!! Sample:
!!
!! program demo_get_tmp
!! use M_get_env, only : get_tmp, uniq
!! implicit none
!! character(len=:),allocatable :: answer
!! answer=get_tmp()
!! write(*,*)'result is ',answer
!! answer=get_tmp()//uniq('_scratch',create=.false.)
!! write(*,*)'the file ',answer, &
!! & ' was a good scratch file name, at least a moment ago'
!! end program demo_get_tmp
!!
!! Sample Results:
!!
!! > result is /cygdrive/c/Users/JSU/AppData/Local/Temp/
!! >
!! > the file /cygdrive/c/Users/JSU/AppData/Local/Temp/_scratch
!! > was a good scratch file name, at least a moment ago
!!
!!##AUTHOR
!! John S. Urban
!!##LICENSE
!! MIT
function get_tmp() result(tname)
! ident_13="@(#) M_get_env get_tmp(3f) Return the name of the scratch directory"
character(len=:),allocatable :: tname
integer :: lngth
character(len=10),parameter :: names(*)=["TMPDIR ","TEMP ","TEMPDIR ","TMP "]
integer :: i
character(len=1) :: sep
sep='/'
do i=1,size(names)
tname=get_env_character(names(i))
if(tname /= '')exit
enddo
if(tname == '')then
tname='/tmp'
endif
lngth=len_trim(tname)
if(scan(tname(lngth:lngth),'/\') == 0)then
tname=tname//sep
endif
end function get_tmp
end module M_get_env