# include "define.inc" !> Various utilities for working with input and output files, as well as some !> shims/backfills for standard features not present in older compilers. !> !> This module is responsible for setting up the label for the run, !> [[file_utils:run_name]], as well as opening the main input file, the error !> file, and the exit reason file. !> !> Most of the procedures in this module deal with files, and are therefore not !> MPI/thread safe, and you must manually guard any opens/closes. module file_utils use constants, only: run_name_size implicit none private public :: init_file_utils public :: init_job_name public :: initialized public :: finish_file_utils public :: run_name public :: run_name_target public :: list_name public :: input_unit public :: input_unit_exist public :: init_error_unit public :: init_input_unit public :: error_unit public :: exit_reason_unit public :: get_input_unit public :: append_output_file public :: open_output_file public :: close_output_file public :: get_unused_unit public :: get_indexed_namelist_unit public :: num_input_lines public :: stdout_unit public :: replace_all_tabs !> Label for the run. Usually this is the input file without any !> extensions. Set by [[init_run_name]] character(run_name_size), pointer :: run_name !> The full input file name, set by [[get_input_filename]] character(run_name_size), target :: arun_name !> The current job name. See [[job_manage(module)]] character(run_name_size), target :: job_name !> This array replaces the cbuff array in gs2_main. Having the target array in !> the same scope as the pointer is much better practice in general. character(run_name_size), target :: run_name_target !> Label for the list, taken from the command line character(run_name_size) :: list_name !> Unit associated with stdout !> FIXME: Use `iso_fortran_env::output_unit` integer, parameter :: stdout_unit=6 !> Unit number for main input file integer :: input_unit_no !> Unit number for main error file integer :: error_unit_no = stdout_unit !> Unit number for exit reason file integer :: exit_reason_unit_no = stdout_unit !> Number of lines in input file integer :: num_input_lines !> Is module initialized? logical :: initialized = .false. contains !> Read the [[file_utils:run_name]] from the command line (if not given), and determine !> from the extension whether this is a list run (i.e. a list of runs has been !> given). If so or if this is a run with multiple ensembles, open the list !> description. If not, open the error file and call [[init_input_unit]] subroutine init_file_utils (list, input, error, trin_run, name, n_ensembles, input_file) use optionals, only: get_option_with_default implicit none !> True if the input file is a list run file (see [[is_input_file_list]]) logical, intent (out) :: list !> If true, open the input file and strip comments (default: true) logical, intent (in), optional :: input !> If true, open the error output file (default: true) logical, intent (in), optional :: error !> If present, regardless of value, sets `list` to false logical, intent (in), optional :: trin_run !> Set [[file_utils:run_name]] if `input` is false or `trin_run` is present character(len = *), intent (in), optional :: name !> Number of run ensembles. If greater than 1, sets [[file_utils:list_name]] and !> doesn't open any files integer, intent (in), optional :: n_ensembles !> Use given input filename instead of reading from command line character(len = *), intent (in), optional :: input_file logical :: inp, err, is_trin_run integer :: n_ensembles_local inp = get_option_with_default(input, .true.) err = get_option_with_default(error, .true.) is_trin_run = get_option_with_default(trin_run, .false.) arun_name = trim(get_option_with_default(name, "unknown")) n_ensembles_local = get_option_with_default(n_ensembles, 1) if (inp .and. .not. is_trin_run) then ! Note we can't (easily) use get_option_with_default here ! as the default, would be the return of get_input_filename() ! but this function can call mp_abort and this could trigger ! even if input_file is passed and hence we don't need get_input_filename if (present(input_file)) then arun_name = input_file else arun_name = get_input_filename() endif end if list = is_input_file_list(arun_name) if (list .or. (n_ensembles_local > 1)) then list_name = arun_name else call init_run_name call init_error_unit (err) call init_exit_reason_unit (err) call init_input_unit (inp) end if initialized = .true. end subroutine init_file_utils !> Return the input filename as set by the command line function get_input_filename () result(input_filename) use mp, only : mp_abort implicit none character(run_name_size) :: input_filename character(len=50) :: error_message integer :: filename_length, ierr if (command_argument_count() == 0) then call mp_abort("No input file provided", to_screen=.true.) end if call get_command_argument(1, input_filename, filename_length, ierr) if (ierr /= 0) then write(error_message, '(A, I0)') "Couldn't get input file name, error code: ", ierr call mp_abort(error_message, to_screen=.true.) end if end function get_input_filename !> Returns true if [[input_filename]] is a list input: that is, if it ends in `.list` logical function is_input_file_list(input_filename) character(len=*), intent(in) :: input_filename integer :: filename_length filename_length = len_trim(input_filename) if (filename_length > 5) then is_input_file_list = (input_filename(filename_length-4:filename_length) == ".list") else is_input_file_list = .false. endif end function is_input_file_list !> This is called for a non Trinity or list run - it checks that the input !> file name ends in `.in`, chops the extension off and stores it in !> [[file_utils:arun_name]]. It also assigns the pointer !> [[file_utils:run_name]] to [[file_utils:arun_name]]. subroutine init_run_name implicit none integer :: l l = len_trim (arun_name) if (l > 3)then if(arun_name(l-2:l) == ".in") then arun_name = arun_name(1:l-3) endif end if run_name => arun_name end subroutine init_run_name !> Set [[file_utils:run_name]] and [[file_utils:job_name]] to `jobname`. Used !> by [[job_manage(module)]] subroutine init_job_name (jobname) implicit none !> Current job name character(run_name_size), intent (in) :: jobname job_name = trim(jobname) run_name => job_name end subroutine init_job_name !> Get an unused unit number for I/O. !> !> FIXME: remove and replace with `newunit` in `open` subroutine get_unused_unit (unit) implicit none !> A new unit not associated with an open file integer, intent (out) :: unit logical :: od unit = 50 do inquire (unit=unit, opened=od) if (.not.od) return unit = unit + 1 end do end subroutine get_unused_unit !> Open an output file to write (replacing any existing) whose name is !> `<run_name>.<ext>`, and set `unit` to the unit number of that output !> file. If the binary flag is true, a binary file is opened subroutine open_output_file (unit, ext, binary) implicit none !> Unit number of opened file integer, intent (out) :: unit !> File extension to open, appended to [[file_utils:run_name]] character (*), intent (in) :: ext !> If true, then open a binary (unformatted) file logical, intent(in), optional :: binary character(run_name_size) :: hack character(len=11) :: formtxt call get_unused_unit (unit) hack=trim(run_name)//ext formtxt = "formatted" if( present(binary) ) then if( binary ) then formtxt = "unformatted" end if end if open (unit=unit, file=trim(hack), status="replace", action="write", form=trim(formtxt)) end subroutine open_output_file !> Open an output file to write (appending if existing) whose name is !> `<run_name>.<ext>`, and set `unit` to the unit number of that !> output file. If the optional `run_name_in` variable is present, this !> replaces run_name as the root of the output file. subroutine append_output_file (unit, ext, run_name_in) use optionals, only: get_option_with_default implicit none !> Unit number of opened file, in append mode integer, intent (out) :: unit !> File extension to open, appended to [[file_utils:run_name]] character (*), intent (in) :: ext !> Optional root name for the output file. If not specified, !> [[file_utils:run_name]] is used as the root. character (*), intent (in), optional :: run_name_in character(run_name_size) :: file_name logical :: exists call get_unused_unit (unit) file_name = trim(get_option_with_default(run_name_in, run_name)) // ext inquire(file=file_name, exist=exists) if (exists) then open (unit=unit, file=trim(file_name), status="old", position="append", action="write") else open (unit=unit, file=trim(file_name), status="new", action="write") end if end subroutine append_output_file !> Close the file associated with `unit` !> !> FIXME: Remove subroutine close_output_file (unit) implicit none !> Unit of file to close integer, intent (in) :: unit close (unit=unit) end subroutine close_output_file !> Open error file and record associated lun/unit subroutine init_error_unit (open_it) use mp, only : set_default_error_file_unit implicit none !> If true, open the file, otherwise do nothing logical, intent (in) :: open_it error_unit_no = 0 if (run_name /= "unknown" .and. open_it) then call open_output_file (error_unit_no, ".error") ! TT: error_unit_no is overwritten for .error file end if ! Set mp's error file so that we don't have to set it in every ! call to mp_abort call set_default_error_file_unit(error_unit_no) end subroutine init_error_unit !> Open exit_reason file and record associated lun/unit subroutine init_exit_reason_unit (open_it) implicit none !> If true, open the file, otherwise do nothing logical, intent (in) :: open_it exit_reason_unit_no = 0 if (run_name /= "unknown" .and. open_it) then call open_output_file (exit_reason_unit_no, ".exit_reason") ! TT: exit_reason_unit_no is overwritten for .exit_reason file end if end subroutine init_exit_reason_unit !> Replaces each horizontal tab with a single space subroutine replace_all_tabs (line) use iso_c_binding, only: C_HORIZONTAL_TAB implicit none !> Text to modify in-place character(*), intent (in out) :: line integer :: tab_location, length, counter tab_location = scan(line, C_HORIZONTAL_TAB) length = len(line) counter = 1 do while (tab_location > 0 .and. counter <= length) !Replace tab with a single space line(tab_location:tab_location) = ' ' !Update tab_location tab_location = scan(line, C_HORIZONTAL_TAB) counter = counter+1 end do end subroutine replace_all_tabs !> Replaces all leading tabs with space. !> Note we consider any tabs appearing before the first non-space/tab character. subroutine replace_leading_tabs (line) use iso_c_binding, only: C_HORIZONTAL_TAB implicit none !> Text to modify in-place character(*), intent (in out) :: line integer :: tab_location, i, length tab_location = scan(line, C_HORIZONTAL_TAB) ! If there are no tabs in the line then return immediately if (tab_location == 0) return length = len(line) ! Consider each character in turn do i = 1, length if (line(i:i) == ' ') then ! If it is a space then just move to next character cycle else if (line(i:i) == C_HORIZONTAL_TAB) then ! If it is a tab replace with a space and move to next character line(i:i) = ' ' cycle else ! We've reached a non-space/tab character so can stop checking exit end if end do end subroutine replace_leading_tabs !> Remove Fortran comments (`!`) from `line` subroutine strip_comments (line) implicit none !> Text to modify in-place character(*), intent (in out) :: line logical :: in_single_quotes, in_double_quotes integer :: i, length length = len_trim(line) i = 1 in_single_quotes = .false. in_double_quotes = .false. loop: do if (in_single_quotes) then if (line(i:i) == "'") in_single_quotes = .false. else if (in_double_quotes) then if (line(i:i) == '"') in_double_quotes = .false. else select case (line(i:i)) case ("'") in_single_quotes = .true. case ('"') in_double_quotes = .true. case ("!") i = i - 1 exit loop end select end if if (i >= length) exit loop i = i + 1 end do loop line = line(1:i) end subroutine strip_comments !> Opens the input file, strip out any comments and write them into the file !> `.<run_name>.in`. Check for includes, read any lines from the includes, !> strip any comments from them and add them to the same file. subroutine init_input_unit (open_it) implicit none !> If true, open the file, otherwise do nothing logical, intent (in) :: open_it integer :: in_unit, out_unit, iostat character(500) :: line integer :: ind_slash !To hold position of slash in run_name ! for includes integer, parameter :: stack_size = 10 integer, dimension (stack_size) :: stack integer :: stack_ptr logical :: already_opened character(len=75) :: non_end_error_message if (.not. open_it) then input_unit_no = -1 return end if stack_ptr = 0 call get_unused_unit (in_unit) open (unit=in_unit, file=trim(run_name)//".in", status="old", & action="read", iostat=iostat) if (iostat /= 0) then call close_stack_and_abort("Couldn't open input file: " // trim(run_name) // ".in") end if call get_unused_unit (out_unit) !Determine if '/' is in input name and if so what position !in the string is the last one (i.e. split run_name into path_to_file and file) ind_slash=index(run_name,"/",.True.) if (ind_slash.EQ.0) then !No slash in name !Original behaviour open (unit=out_unit, file="."//trim(run_name)//".in") else !General behaviour open (unit=out_unit, file=trim(run_name(1:ind_slash))//"."//trim(run_name(ind_slash+1:))//".in") endif iostat = 0 num_input_lines = 0 do read (unit=in_unit, fmt="(a)", iostat=iostat) line ! It appears that we're using iostat / =0 to identify when ! we've reached the end of the current file. This therefore ! ignores any other possible errors. We should perhaps instead ! first check if iostat_is_end(iostat), if so proceed as we ! have here else if iostat /= 0 we have some other error and ! should consider aborting. Currently we just display an error ! message but carry on as usual. if (iostat /= 0) then if (.not. is_iostat_end(iostat)) then write(non_end_error_message, '(A, I0)') "Error encountered whilst reading input file with code ", iostat call close_stack_and_abort(non_end_error_message) end if if (stack_ptr <= 0) exit close (unit=in_unit) iostat = 0 in_unit = stack(stack_ptr) stack_ptr = stack_ptr - 1 cycle end if if (line(1:9) == "!include ") then if (stack_ptr >= stack_size) then call close_stack_and_abort("!include ignored: nesting too deep: " // trim(line)) end if stack_ptr = stack_ptr + 1 stack(stack_ptr) = in_unit call get_unused_unit (in_unit) ! Check if we've already opened this file, if so assume this ! is a circular dependency and abort inquire(file = trim(line(10:)), opened = already_opened) if (already_opened) then call close_stack_and_abort("Circular dependency with " // trim(line)) end if open (unit=in_unit, file=trim(line(10:)), status="old", & action="read", iostat=iostat) ! Here we assume that any problem with the above open is due ! to the file being "unreadable". This could also end up ! catching circular dependencies in our includes as the ! fortran standard forbids having the same file open with ! different file units (although some compilers may allow ! this as an extension). To help the user we first detect if ! this file has already been opened and if so warn for ! circular dependency. Here we therefore deal with all other ! errors. if (iostat /= 0) then call close_stack_and_abort("!include ignored: file unreadable: " // trim(line)) end if cycle end if call strip_comments (line) call replace_leading_tabs(line) write (unit=out_unit, fmt="(a)") trim(line) num_input_lines = num_input_lines + 1 end do close (unit=in_unit) input_unit_no = out_unit contains !> Close all open files and abort run subroutine close_stack_and_abort(error_message) use mp, only : mp_abort !> Error message to print to screen and log in error file character(len=*), intent(in) :: error_message integer :: i do i = 1, stack_ptr close(i) end do call mp_abort(error_message, to_screen=.true.) end subroutine close_stack_and_abort end subroutine init_input_unit !> Close any files opened by [[init_file_utils]] subroutine finish_file_utils implicit none if (input_unit_no > 0) then close (unit=input_unit_no) input_unit_no = -1 end if if (error_unit_no > 0 .and. error_unit_no /= 6) then close (unit=error_unit_no) error_unit_no = stdout_unit end if if (exit_reason_unit_no > 0 .and. exit_reason_unit_no /= 6) then close (unit=exit_reason_unit_no) exit_reason_unit_no = stdout_unit end if initialized = .false. end subroutine finish_file_utils !> Rewind the input file to start of namelist `nml`, and return the unit of !> the file opened by [[init_input_unit]] function input_unit (nml) implicit none !> Name of namelist to find start of character(*), intent (in) :: nml integer :: input_unit, iostat character(500) :: line intrinsic adjustl, trim input_unit = input_unit_no if (input_unit_no > 0) then rewind (unit=input_unit_no) do read (unit=input_unit_no, fmt="(a)", iostat=iostat) line if (iostat /= 0) then rewind (unit=input_unit_no) exit end if if (trim(adjustl(line)) == "&"//nml) then backspace (unit=input_unit_no) return end if end do end if write (unit=error_unit_no, fmt="('Couldn''t find namelist: ',a)") nml write (unit=*, fmt="('Couldn''t find namelist: ',a)") nml end function input_unit !> Similar to [[input_unit]] but set `exist` to true if `nml` was found in the !> input file, and false otherwise function input_unit_exist (nml,exist) implicit none !> Name of namelist to find start of character(*), intent (in) :: nml !> Was `nml` was found in the input file? logical, intent(out) :: exist integer :: input_unit_exist, iostat character(500) :: line intrinsic adjustl, trim input_unit_exist = input_unit_no exist = .true. if (input_unit_no > 0) then rewind (unit=input_unit_no) do read (unit=input_unit_no, fmt="(a)", iostat=iostat) line if (iostat /= 0) then rewind (unit=input_unit_no) exit end if if (trim(adjustl(line)) == "&"//nml) then backspace (unit=input_unit_no) return end if end do end if exist = .false. end function input_unit_exist !> Returns the file unit number associated with the error file pure integer function error_unit () implicit none error_unit = error_unit_no end function error_unit !> Returns the file unit number associated with the exit_reason file pure integer function exit_reason_unit () implicit none exit_reason_unit = exit_reason_unit_no end function exit_reason_unit !> Returns the file unit number associated with the input file !> !> @note This is a subroutine unlike the functions used for error_unit !> and exit_reason_unit. We should think about making these consistent. subroutine get_input_unit (unit) implicit none integer, intent (out) :: unit unit = input_unit_no end subroutine get_input_unit !> Copy namelist, `<nml>_<index_in>`, from the input file to namelist `NML` in !> a temporary file with unit `unit` subroutine get_indexed_namelist_unit (unit, nml, index_in, exist) implicit none !> Unit of new temporary file containing the indexed namelist integer, intent (out) :: unit !> Name of indexed namelist to copy character (*), intent (in) :: nml !> Index number of namelist to copy integer, intent (in) :: index_in !> Does the indexed namelist exist or not? logical, optional, intent (out) :: exist character(500) :: line integer :: iunit, iostat, in_file integer :: ind_slash logical :: local_exist call get_unused_unit (unit) !Determine if '/' is in input name and if so what position !in the string is the last one (i.e. split run_name into path_to_file and file) ind_slash=index(run_name,"/",.True.) if (ind_slash.EQ.0) then !No slash in name !Original behaviour open (unit=unit, file="."//trim(run_name)//".scratch") else !General behaviour open (unit=unit, file=trim(run_name(1:ind_slash))//"."//trim(run_name(ind_slash+1:))//".scratch") endif write (line, *) index_in line = nml//"_"//trim(adjustl(line)) in_file = input_unit_exist(trim(line), local_exist) if (present(exist)) exist = local_exist if (local_exist) then iunit = input_unit(trim(line)) else write(6,*) "get_indexed_namelist: following namelist not found ",trim(line) return end if read (unit=iunit, fmt="(a)") line write (unit=unit, fmt="('&',a)") nml do read (unit=iunit, fmt="(a)", iostat=iostat) line if (iostat /= 0 .or. trim(adjustl(line)) == "/") exit write (unit=unit, fmt="(a)") trim(line) end do write (unit=unit, fmt="('/')") rewind (unit=unit) end subroutine get_indexed_namelist_unit end module file_utils