From 6847d1c994dd057a956a515b7a24675373577b5b Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Sun, 17 Dec 2023 18:09:12 -0300 Subject: [PATCH 1/3] PARAMETERS: Rewrite module with use of variable strings. Signed-off-by: Grzegorz Kowal --- sources/io.F90 | 10 +- sources/parameters.F90 | 604 ++++++++++++++++------------------------- 2 files changed, 237 insertions(+), 377 deletions(-) diff --git a/sources/io.F90 b/sources/io.F90 index ca3f3ed..b9c6452 100644 --- a/sources/io.F90 +++ b/sources/io.F90 @@ -1751,7 +1751,7 @@ module io use helpers , only : print_message use iso_c_binding, only : c_loc use mpitools , only : nprocs, nproc - use parameters , only : get_parameter_file + use parameters , only : parameter_file use random , only : gentype, nseeds, get_seeds use XML , only : XMLNode, XMLAddElement, & XMLInitTree, XMLFreeTree, XMLSaveTree @@ -1827,8 +1827,7 @@ module io if (nproc == 0) then - call get_parameter_file(str, status) - cmd = "cp -a " // trim(str) // " " // rpath + cmd = "cp -a " // parameter_file // " " // rpath if (status == 0) then call execute_command_line(cmd) else @@ -2194,7 +2193,7 @@ module io use helpers , only : print_message use iso_c_binding, only : c_loc use mpitools , only : nprocs, nproc - use parameters , only : get_parameter_file + use parameters , only : parameter_file use sources , only : viscosity, resistivity use XML , only : XMLNode, XMLAddElement, & XMLInitTree, XMLFreeTree, XMLSaveTree @@ -2252,8 +2251,7 @@ module io if (nproc == 0) then - call get_parameter_file(str, status) - cmd = "cp -a " // trim(str) // " " // rpath + cmd = "cp -a " // parameter_file // " " // rpath if (status == 0) then call execute_command_line(cmd) else diff --git a/sources/parameters.F90 b/sources/parameters.F90 index 91060c8..86fcb2e 100644 --- a/sources/parameters.F90 +++ b/sources/parameters.F90 @@ -1,39 +1,44 @@ -!!****************************************************************************** -!! -!! This file is part of the AMUN source code, a program to perform -!! Newtonian or relativistic magnetohydrodynamical simulations on uniform or -!! adaptive mesh. -!! -!! Copyright (C) 2008-2023 Grzegorz Kowal -!! -!! This program is free software: you can redistribute it and/or modify -!! it under the terms of the GNU General Public License as published by -!! the Free Software Foundation, either version 3 of the License, or -!! (at your option) any later version. -!! -!! This program is distributed in the hope that it will be useful, -!! but WITHOUT ANY WARRANTY; without even the implied warranty of -!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -!! GNU General Public License for more details. -!! -!! You should have received a copy of the GNU General Public License -!! along with this program. If not, see . -!! -!!****************************************************************************** -!! -!! module: PARAMETERS -!! -!! This module handles runtime parameters by reading them from a parameter -!! file and distributing among all processes. -!! -!!****************************************************************************** +!=============================================================================== +! +! This file is part of the source code of AMUN, a magnetohydrodynamic +! (classical and relativistic) plasma modeling software for the study of +! astrophysical phenomena. +! +! Copyright (C) 2008-2023 Grzegorz Kowal +! +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see . +! +!=============================================================================== +! +! Name: PARAMETERS +! +! Description: +! +! This module handles runtime parameters by reading them from a parameter +! file and distributing among all processes. +! +!------------------------------------------------------------------------------- ! module parameters implicit none -! MODULE INTERFACES: -! ================= + private + +! MODULE INTERFACES +! ----------------- ! interface get_parameter module procedure get_parameter_integer @@ -41,62 +46,48 @@ module parameters module procedure get_parameter_string end interface -! MODULE PARAMETERS: -! ================= +! MODULE STRUCTURES +! ----------------- ! -! module parameters determining the name and value field lengths, and the -! maximum string length -! - integer, parameter :: nlen = 64, vlen = 128, mlen = 256 + type item + character(len=:), allocatable :: key, val -! the name of the parameter file -! - character(len=mlen), save :: fname = './params.in' + type(item), pointer :: next + end type -! a file handler to the parameter file +! MODULE VARIABLES +! ---------------- ! - integer(kind=4) , save :: punit = 10 + character(len=:), allocatable :: parameter_file + type(item) , pointer :: parameter_list => null() -! the number of parameters stored in the parameter file -! - integer , save :: nparams = 0 -! allocatable arrays to store parameter names and values -! - character(len=nlen), dimension(:), allocatable, save :: pnames - character(len=vlen), dimension(:), allocatable, save :: pvalues - -! by default everything is private -! - private - -! declare public subroutines +! PUBLIC MEMBERS +! -------------- ! public :: read_parameters, finalize_parameters - public :: get_parameter_file, get_parameter + public :: parameter_file, get_parameter -!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! contains -! + !=============================================================================== ! ! subroutine READ_PARAMETERS: ! -------------------------- ! +! Description: +! ! Subroutine checks if the parameter file exists, checks its length, ! allocates structures to store all parameters provided in the parameters ! file and read parameters into these structures. ! -! Arguments: +! There is a possibility to specify customized input file by adding a +! command line option -i or --input followed by the name of the input file. ! -! verbose - the flag determining if the subroutine should be verbose; -! status - the return flag of the procedure execution status; +! Arguments: ! -! Note: -! -! There is a possibility to specify customized input file by adding a -! command line option -i or --input followed by the name of the input file. +! verbose - the flag determining if the subroutine should be verbose; +! status - the return flag of the procedure execution status; ! !=============================================================================== ! @@ -109,7 +100,7 @@ module parameters logical, intent(in) :: verbose integer, intent(out) :: status - character(len=mlen) :: opt, arg + character(len=4096) :: arg integer :: l logical :: info @@ -117,75 +108,48 @@ module parameters ! status = 0 -! parse the command line to check if a different parameter file has been -! provided + parameter_file = 'params.in' + +! parse the command line to check for the parameter file ! do l = 1, command_argument_count() call get_command_argument(l, arg) if (trim(arg) == '-i' .or. trim(arg) == '--input') then - opt = trim(arg) - call get_command_argument(l + 1, arg) + call get_command_argument(l+1, arg) if (trim(arg) /= '') then - fname = trim(arg) + parameter_file = trim(arg) else - if (verbose) then - write(error_unit,*) "The option '" // trim(opt) // & - "' requires an argument! Exiting..." - end if + if (verbose) & + write(error_unit,*) & + "The option '--input' or '-i' requires an argument. Exiting..." status = 112 return end if + exit end if end do -! check if the file exists -! - inquire(file = fname, exist = info) + inquire(file=parameter_file, exist=info) if (info) then - -! obtain the number of parameters stored in the file -! - call get_parameters_number(status) - - if (status > 0) return - -! if the parameter file is empty, print an error and quit the subroutine -! - if (nparams <= 0) then - write(error_unit,*) "The parameter file '" // trim(fname) & - // "' is empty! Exiting..." - status = 110 - - return - end if - -! allocate arrays to store the parameter names and values as string variables -! - allocate(pnames (nparams)) - allocate(pvalues(nparams)) - -! get the parameter names and values and copy them to the corresponding arrays -! - call get_parameters(status) - + call parse_parameters(status) else - - write(error_unit,*) "The parameter file '" // trim(fname) & - // "' does not exist! Exiting..." + write(error_unit,*) "The parameter file '" // parameter_file // & + "' does not exist. Exiting..." status = 111 - end if !------------------------------------------------------------------------------- ! end subroutine read_parameters -! + !=============================================================================== ! ! subroutine FINALIZE_PARAMETERS: ! ------------------------------ ! +! Description: +! ! Subroutine releases memory used by arrays in this module. ! !=============================================================================== @@ -194,132 +158,42 @@ module parameters implicit none + type(item), pointer :: item_ptr + !------------------------------------------------------------------------------- ! - if (allocated(pnames) ) deallocate(pnames) - if (allocated(pvalues)) deallocate(pvalues) + item_ptr => parameter_list + do while(associated(item_ptr)) + parameter_list => parameter_list%next + + nullify(item_ptr%next) + deallocate(item_ptr%key, item_ptr%val) + deallocate(item_ptr) + + item_ptr => parameter_list + end do !------------------------------------------------------------------------------- ! end subroutine finalize_parameters -! + !=============================================================================== ! -! subroutine GET_PARAMETER_FILE: -! ----------------------------- +! subroutine PARSE_PARAMETERS: +! --------------------------- ! -! Subroutine returns the full path to the parameter file. -! -! Arguments: -! -! pfile - the parameter full file path; -! status - the status value, 0 for success; -! -!=============================================================================== -! - subroutine get_parameter_file(pfile, status) - - use iso_fortran_env, only : error_unit - - implicit none - - character(len=*), intent(out) :: pfile - integer , intent(out) :: status - - character(len=mlen) :: tfile - - character(len=*), parameter :: loc = 'PARAMETERS::get_parameter_file()' - -!------------------------------------------------------------------------------- -! - status = 0 - if (len(pfile) <= mlen) then - write(pfile,"(a)") trim(adjustl(fname)) - else - write(error_unit,"('[',a,']: ',a)") trim(loc) & - , "Parameter file path too long for subroutine argument!" - write(tfile,"(a)") trim(adjustl(fname)) - write(pfile,"(a)") tfile(1:len(pfile)) - status = 1 - end if - -!------------------------------------------------------------------------------- -! - end subroutine get_parameter_file -! -!=============================================================================== -! -! subroutine GET_PARAMETERS_NUMBER: -! -------------------------------- -! -! Subroutine scans the input file and accounts the number of parameters -! stored in it. -! -! Arguments: -! -! status - the status value, 0 for success; -! -!=============================================================================== -! - subroutine get_parameters_number(status) - - use iso_fortran_env, only : error_unit - - implicit none - - integer, intent(out) :: status - - character(len=mlen) :: line - - character(len=*), parameter :: loc = 'PARAMETERS::get_parameters_number()' - -!------------------------------------------------------------------------------- -! - nparams = 0 - - open(newunit = punit, file = fname, err = 30) - -10 read(punit, fmt = "(a)", end = 20) line - -! if the line is empty or it's a comment, skip the counting -! - if ((len_trim(line) == 0) & - .or. index(trim(adjustl(line)), '#') == 1) go to 10 - - nparams = nparams + 1 - - go to 10 - -20 close(punit) - - return - -! print a massage if an error occurred -! -30 write(error_unit,"('[',a,']: ',a)") trim(loc) & - , "Cannot open the parameter file '" // trim(fname) // "'!" - - status = 112 - -!------------------------------------------------------------------------------- -! - end subroutine get_parameters_number -! -!=============================================================================== -! -! subroutine GET_PARAMETERS: -! ------------------------- +! Description: ! ! Subroutine scans the input file, reads parameter names and values, and ! stores them in module arrays. ! -! Arguments: +! Arguments: ! -! status - the status value, 0 for success; +! status - the status value, 0 for success; ! !=============================================================================== ! - subroutine get_parameters(status) + subroutine parse_parameters(status) use iso_fortran_env, only : error_unit @@ -327,269 +201,257 @@ module parameters integer, intent(out) :: status - integer :: np, nl + type(item), pointer :: item_ptr - character(len=256) :: line, name, value + logical :: exists - character(len=*), parameter :: loc = 'PARAMETERS::get_parameters_number()' + integer :: io = 10, n, i, j + + character(len=:), allocatable :: line, key, val + + character(len=*), parameter :: loc = 'PARAMETERS::parse_parameters()' !------------------------------------------------------------------------------- ! - np = 1 - nl = 0 + status = 0 - open(newunit = punit, file = fname, err = 30) -10 read(punit, fmt = "(a)", end = 20) line + n = 0 + j = 1024 - nl = nl + 1 + inquire(file=parameter_file, size=j) -! if the line is empty or it's a comment, skip the counting + allocate(character(len=j) :: line) + + open(newunit=io, file=parameter_file, err=30) + +10 read(io, fmt="(a)", end=20) line + + n = n + 1 + +! remove comments ! - if ((len_trim(line) == 0) & - .or. index(trim(adjustl(line)), '#') == 1) go to 10 + i = index(line, '#') + if (i > 0) write(line,"(a)") trim(adjustl(line(:i-1))) -! parse the line to get parameter name and value +! skip empty lines ! - call parse_line(line, name, value, status) + if (len_trim(line) == 0) go to 10 -! check if the line was parsed successfuly +! process only lines containing '=' ! - if (status > 0) then - write(error_unit,"('[',a,']: ',a)") trim(loc) & - , "Wrong parameter format in '" & - // trim(adjustl(fname)) // "'." - write (error_unit,"('[',a,']: Line',i4,' : ',a)") & - trim(loc), nl, trim(line) - go to 30 + i = index(line, '=') + if (i > 1) then + key = trim(adjustl(line(:i-1))) + + if (len_trim(key) > 0) then + val = trim(adjustl(line(i+1:))) + if (index(val, '"') > 0 .and. index(val, "'") > 0) then + status = 1 + else + i = index(val, '"') + if (i > 0) then + j = index(val, '"', back=.true.) + val = val(i+1:j-1) + end if + i = index(val, "'") + if (i > 0) then + j = index(val, "'", back=.true.) + val = val(i+1:j-1) + end if + end if + if (len_trim(val) == 0) status = 1 + else + status = 1 + end if + else + status = 1 end if -! fill the arrays of parameter names and values -! - pnames (np) = name (1:nlen) - pvalues(np) = value(1:vlen) + if (status > 0) then + write(error_unit,"('[',a,']: ',a)") loc, & + "Wrong parameter format in '" // parameter_file // "'." + write (error_unit,"('[',a,']: ',a,i0,':')") loc, "Verify line ", n + write (error_unit,"('[',a,']: ',a)") loc, trim(adjustl(line)) -! increase the parameter counter -! - np = np + 1 + go to 10 + end if -! go to the next line +! allocate a new item and add it to the parameter list ! + exists = .false. + item_ptr => parameter_list + do while(associated(item_ptr)) + if (key == item_ptr%key) then + exists = .true. + exit + end if + item_ptr => item_ptr%next + end do + if (exists) then + write(error_unit,"('[',a,']: ',a)") loc, "Parameter '" // key // & + "' appears multiple times. " // & + "Only the value of the first occurrence is considered." + else + allocate(item_ptr) + item_ptr%key = key + item_ptr%val = val + item_ptr%next => parameter_list + parameter_list => item_ptr + end if + go to 10 -20 close(punit) +20 close(io) + + deallocate(line) return -30 write(error_unit,"('[',a,']: ',a)") trim(loc) & - , "Cannot open the parameter file '" // trim(fname) // "'!" +30 write(error_unit,"('[',a,']: ',a)") loc, & + "Unable to open the parameter file '" // & + parameter_file // "'!" status = 140 !------------------------------------------------------------------------------- ! - end subroutine get_parameters -! -!=============================================================================== -! -! subroutine PARSE_LINE: -! --------------------- -! -! Subroutine extracts the parameter name and value from the input line. -! -! Arguments: -! -! line - the input line containing the parameter information; -! name - the extracted name of the parameter; -! value - the extracted value of the parameter; -! status - the status value, 0 for success; -! -!=============================================================================== -! - subroutine parse_line(line, name, value, status) + end subroutine parse_parameters - implicit none - - character(len=*), intent(in) :: line - character(len=*), intent(inout) :: name, value - integer , intent(out) :: status - - integer :: l, p, c, i, j = 1 - -!------------------------------------------------------------------------------- -! - status = 0 - - l = len_trim(line) - -! find the indices of '=' and '#' in the line -! - p = index(line, '=') - c = index(line, '#') - i = index(line, '"') - if (i > 0) then - j = index(line, '"', back = .true.) - else - i = index(line, "'") - if (i > 0) then - j = index(line, "'", back = .true.) - end if - end if - -! remove the length of the inline comment from the length of the whole line -! - if (c > 0) l = c - 1 - if (i > 0 .and. j > 0) then - i = i + 1 - j = j - 1 - else - i = p + 1 - j = l - end if - -! limit the indices, so we don't overrun the variable memory -! - p = min(p, nlen) - j = min(j, vlen + i) - - name = trim(adjustl(line(1:p-1))) - value = trim(adjustl(line(i:j))) - -! check possible errors in formatting -! - if (p <= 2 .or. len_trim(name) == 0 .or. len_trim(value) == 0) status = 1 - -!------------------------------------------------------------------------------- -! - end subroutine parse_line -! !=============================================================================== ! ! subroutine GET_PARAMETER_INTEGER: ! -------------------------------- ! +! Description: +! ! Subroutine reads a given parameter name and returns its integer value. ! -! Arguments: +! Arguments: ! -! name - the input parameter name; -! value - the output integer value of parameter; +! key - the input parameter name; +! val - the output integer value of parameter; ! !=============================================================================== ! - subroutine get_parameter_integer(name, value) + subroutine get_parameter_integer(key, val) use iso_fortran_env, only : error_unit implicit none - character(len=*), intent(in) :: name - integer , intent(inout) :: value + character(len=*), intent(in) :: key + integer , intent(inout) :: val - integer :: np + type(item), pointer :: item_ptr character(len=*), parameter :: loc = 'PARAMETERS::get_parameter_integer()' !------------------------------------------------------------------------------- ! - np = 1 - do while (np <= nparams) - if (name == pnames(np)) then - read(pvalues(np), err = 100, fmt = *) value + item_ptr => parameter_list + do while(associated(item_ptr)) + if (item_ptr%key == key) then + read(item_ptr%val, err=10, fmt=*) val + exit end if - np = np + 1 + item_ptr => item_ptr%next end do return -100 write(error_unit,"('[',a,']: ',a)") trim(loc) & - , "Wrong format of the parameter '" // trim(name) // & - "' or the value is too small or too large!" +10 write(error_unit,"('[',a,']: ',a)") loc, & + "Incorrect format for the integer parameter '" // key // & + "', or its value is either too small or too large!" !------------------------------------------------------------------------------- ! end subroutine get_parameter_integer -! + !=============================================================================== ! ! subroutine GET_PARAMETER_REAL: ! ----------------------------- ! +! Description: +! ! Subroutine reads a given parameter name and returns its real value. ! -! Arguments: +! Arguments: ! -! name - the input parameter name; -! value - the output real value of parameter; +! key - the input parameter name; +! val - the output real value of parameter; ! !=============================================================================== ! - subroutine get_parameter_real(name, value) + subroutine get_parameter_real(key, val) use iso_fortran_env, only : error_unit implicit none - character(len=*), intent(in) :: name - real(kind=8) , intent(inout) :: value + character(len=*), intent(in) :: key + real(kind=8) , intent(inout) :: val - integer :: np + type(item), pointer :: item_ptr character(len=*), parameter :: loc = 'PARAMETERS::get_parameter_real()' !------------------------------------------------------------------------------- ! - np = 1 - do while (np <= nparams) - if (name == pnames(np)) then - read(pvalues(np), err = 100, fmt = *) value + item_ptr => parameter_list + do while(associated(item_ptr)) + if (item_ptr%key == key) then + read(item_ptr%val, err=10, fmt=*) val + exit end if - np = np + 1 + item_ptr => item_ptr%next end do return -100 write(error_unit,"('[',a,']: ',a)") trim(loc) & - , "Wrong format of the parameter '" // trim(name) // & - "' or the value is too small or too large!" +10 write(error_unit,"('[',a,']: ',a)") loc, & + "Incorrect format for the float parameter '" // key // & + "', or its value is either too small or too large!" !------------------------------------------------------------------------------- ! end subroutine get_parameter_real -! + !=============================================================================== ! ! subroutine GET_PARAMETER_STRING: ! ------------------------------- ! +! Description: +! ! Subroutine reads a given parameter name and returns its string value. ! -! Arguments: +! Arguments: ! -! name - the input parameter name; -! value - the output string value of parameter; +! key - the input parameter name; +! val - the output string value of parameter; ! !=============================================================================== ! - subroutine get_parameter_string(name, value) + subroutine get_parameter_string(key, val) implicit none - character(len=*), intent(in) :: name - character(len=*), intent(inout) :: value + character(len=*), intent(in) :: key + character(len=*), intent(inout) :: val - integer :: np, nl + type(item), pointer :: item_ptr !------------------------------------------------------------------------------- ! - nl = min(vlen, len(value)) - - np = 1 - do while (np <= nparams) - if (name == pnames(np)) then - value = pvalues(np)(1:nl) + item_ptr => parameter_list + do while(associated(item_ptr)) + if (item_ptr%key == key) then + val = item_ptr%val + exit end if - np = np + 1 + item_ptr => item_ptr%next end do !------------------------------------------------------------------------------- From 66f5fc5c58f30fc4d7e871abfdfc23bdfbbb012f Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Sun, 17 Dec 2023 21:47:38 -0300 Subject: [PATCH 2/3] PARAMETERS: Read parameters on master and distribute them. This commit restores the previous way of processing the parameter file. It is read and processed on the MPI master process, and then the list of parameters is distributed to other MPI processes. This way only one process accesses the parameter file, reducing the number of I/O operations, which can be significant in the case of multiprocess MPI jobs. Signed-off-by: Grzegorz Kowal --- sources/mpitools.F90 | 77 +++++++++++++++++++++++++++++++++++++ sources/parameters.F90 | 87 ++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 164 insertions(+) diff --git a/sources/mpitools.F90 b/sources/mpitools.F90 index e04915e..bf40e3c 100644 --- a/sources/mpitools.F90 +++ b/sources/mpitools.F90 @@ -41,6 +41,10 @@ module mpitools ! subroutine interfaces ! #ifdef MPI + interface broadcast + module procedure broadcast_integer + module procedure broadcast_string + end interface interface reduce_minimum module procedure reduce_minimum_double_array end interface @@ -83,6 +87,7 @@ module mpitools public :: initialize_mpitools, finalize_mpitools public :: check_status #ifdef MPI + public :: broadcast public :: reduce_minimum, reduce_maximum, reduce_sum public :: send_array, receive_array public :: exchange_arrays @@ -353,6 +358,78 @@ module mpitools ! !=============================================================================== ! +! subroutine BROADCAST_INTEGER: +! ---------------------------- +! +! Subroutine broadcasts an integer buffer. +! +!=============================================================================== +! + subroutine broadcast_integer(buf) + + use helpers, only : print_message + + implicit none + + integer, dimension(..), intent(inout) :: buf + + integer :: ierror + + character(len=*), parameter :: loc = 'MPITOOLS::broadcast_integer()' + +!------------------------------------------------------------------------------- +! + call start_timer(imc) + + call mpi_bcast(buf, size(buf), MPI_INTEGER, 0, MPI_COMM_WORLD, ierror) + + if (ierror /= MPI_SUCCESS) & + call print_message(loc, 'Could not broadcast an integer buffer.') + + call stop_timer(imc) + +!------------------------------------------------------------------------------- +! + end subroutine broadcast_integer +! +!=============================================================================== +! +! subroutine BROADCAST_STRING: +! --------------------------- +! +! Subroutine broadcasts a string buffer. +! +!=============================================================================== +! + subroutine broadcast_string(buf) + + use helpers, only : print_message + + implicit none + + character(len=*), intent(inout) :: buf + + integer :: ierror + + character(len=*), parameter :: loc = 'MPITOOLS::broadcast_string()' + +!------------------------------------------------------------------------------- +! + call start_timer(imc) + + call mpi_bcast(buf, len(buf), MPI_CHARACTER, 0, MPI_COMM_WORLD, ierror) + + if (ierror /= MPI_SUCCESS) & + call print_message(loc, 'Could not broadcast a string buffer.') + + call stop_timer(imc) + +!------------------------------------------------------------------------------- +! + end subroutine broadcast_string +! +!=============================================================================== +! ! subroutine SEND_ARRAY: ! --------------------- ! diff --git a/sources/parameters.F90 b/sources/parameters.F90 index 86fcb2e..a64bea8 100644 --- a/sources/parameters.F90 +++ b/sources/parameters.F90 @@ -139,6 +139,10 @@ module parameters status = 111 end if +#ifdef MPI + call distribute_parameters() +#endif /* MPI */ + !------------------------------------------------------------------------------- ! end subroutine read_parameters @@ -196,6 +200,7 @@ module parameters subroutine parse_parameters(status) use iso_fortran_env, only : error_unit + use mpitools , only : master implicit none @@ -215,6 +220,7 @@ module parameters ! status = 0 + if (.not. master) return n = 0 j = 1024 @@ -457,6 +463,87 @@ module parameters !------------------------------------------------------------------------------- ! end subroutine get_parameter_string +#ifdef MPI +!=============================================================================== +! +! subroutine DISTRIBUTE_PARAMETERS: +! -------------------------------- +! +! Description: +! +! Subroutine distributes parameters among the MPI processes. +! +!=============================================================================== +! + subroutine distribute_parameters() + + use mpitools, only : master, broadcast + + implicit none + + type(item), pointer :: item_ptr + + character(len=:), allocatable :: str + + integer, dimension(2) :: counters ! 1: nitems, 2: maxlen + integer :: n, i + +!------------------------------------------------------------------------------- +! + counters = 0 + + if (master) then + item_ptr => parameter_list + do while(associated(item_ptr)) + counters(1) = counters(1) + 1 + counters(2) = max(counters(2), len(item_ptr%key // '|' // item_ptr%val)) + item_ptr => item_ptr%next + end do + end if + +! broadcast the number of items and the maximum item length +! + call broadcast(counters) + +! allocate string buffer +! + allocate(character(len=counters(2)) :: str) + +! iterate over all items in the list and broadcast them +! + if (master) then + item_ptr => parameter_list + do while(associated(item_ptr)) + write(str,"(a)") item_ptr%key // '|' // item_ptr%val + + call broadcast(str) + + item_ptr => item_ptr%next + end do + + else + + do n = 1, counters(1) + + call broadcast(str) + + i = index(str, '|') + + allocate(item_ptr) + item_ptr%key = trim(adjustl(str(:i-1))) + item_ptr%val = trim(adjustl(str(i+1:))) + item_ptr%next => parameter_list + parameter_list => item_ptr + end do + + end if + + deallocate(str) + +!------------------------------------------------------------------------------- +! + end subroutine distribute_parameters +#endif /* MPI */ !=============================================================================== ! From 0c8cab74a2d2123fba247ef4c273ab5b78107f05 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Mon, 18 Dec 2023 09:30:07 -0300 Subject: [PATCH 3/3] IO, PARAMETERS, SYSTEM: Better parameter restoring. This commit implements a better way (less I/O operations) restoring of the parameters during the job restart. Some parameters, such as the size of the block, or the equation system, cannot be changed during the restart. Such parameters need to be restored from the restart snapshots. The new way restores these parameters on the MPI master process only, updates their values if they were changed, and distributes them to other MPI processes. This way the number of I/O operations is kept to the minimum (only one process access one file). Signed-off-by: Grzegorz Kowal --- sources/io.F90 | 635 ++++++++++++++++------------------------- sources/parameters.F90 | 73 ++++- sources/system.F90 | 70 ++--- 3 files changed, 344 insertions(+), 434 deletions(-) diff --git a/sources/io.F90 b/sources/io.F90 index b9c6452..12d0ea1 100644 --- a/sources/io.F90 +++ b/sources/io.F90 @@ -38,17 +38,7 @@ module io implicit none - interface read_snapshot_parameter - module procedure read_snapshot_parameter_string - module procedure read_snapshot_parameter_integer - module procedure read_snapshot_parameter_double - end interface #ifdef HDF5 - interface read_snapshot_parameter_h5 - module procedure read_snapshot_parameter_string_h5 - module procedure read_snapshot_parameter_integer_h5 - module procedure read_snapshot_parameter_double_h5 - end interface interface restore_attribute_h5 module procedure restore_attribute_string_h5 module procedure restore_attribute_number_h5 @@ -153,7 +143,7 @@ module io public :: initialize_io, finalize_io, print_io public :: restart_snapshot_number, restart_from_snapshot - public :: read_snapshot_parameter + public :: restore_snapshot_parameters public :: read_restart_snapshot, write_restart_snapshot, write_snapshot public :: update_dtp @@ -600,6 +590,61 @@ module io ! !=============================================================================== ! +! subroutine RESTORE_SNAPSHOT_PARAMETERS: +! -------------------------------------- +! +! Description: +! +! The subroutine restores parameters from the restart snapshot for +! restarted jobs, ensuring that these parameters remain unchanged during +! the restart process. +! +! Arguments: +! +! status - the subroutine call status; +! +!=============================================================================== +! + subroutine restore_snapshot_parameters(status) + + use helpers , only : print_message +#ifdef MPI + use parameters, only : distribute_parameters +#endif /* MPI */ + + implicit none + + integer, intent(out) :: status + + character(len=*), parameter :: loc = 'IO::restore_snapshot_parameters()' + +!------------------------------------------------------------------------------- +! + call start_timer(iio) + + status = 0 + + select case(restart_format) +#ifdef HDF5 + case(snapshot_hdf5) + call restore_snapshot_parameters_h5(status) +#endif /* HDF5 */ + case default + call restore_snapshot_parameters_xml(status) + end select + +#ifdef MPI + call distribute_parameters() +#endif /* MPI */ + + call stop_timer(iio) + +!------------------------------------------------------------------------------- +! + end subroutine restore_snapshot_parameters +! +!=============================================================================== +! ! subroutine READ_RESTART_SNAPSHOT: ! -------------------------------- ! @@ -808,260 +853,94 @@ module io ! !=============================================================================== ! -! subroutine READ_SNAPSHOT_PARAMETER_STRING: -! ----------------------------------------- +! subroutine RESTORE_SNAPSHOT_PARAMETERS_XML: +! ------------------------------------------ ! -! Subroutine reads a string parameter from the restart snapshot. +! Subroutine restores parameters from the restart snapshot. ! ! Arguments: ! -! pname - the parameter name; -! pvalue - the parameter value; ! status - the status flag (the success is 0, failure otherwise); ! !=============================================================================== ! - subroutine read_snapshot_parameter_string(pname, pvalue, status) + subroutine restore_snapshot_parameters_xml(status) - use helpers, only : print_message + use helpers , only : print_message + use mpitools , only : master + use parameters, only : update_parameter implicit none - character(len=*), intent(in) :: pname - character(len=*), intent(inout) :: pvalue - integer , intent(inout) :: status + integer, intent(inout) :: status logical :: test character(len=255) :: dname, fname, line integer(kind=4) :: lun = 103 - integer :: l, u + integer :: n, l, u - character(len=*), parameter :: loc = 'IO::read_snapshot_parameter_string' + character(len=8), dimension(14) :: keys = & + [ "problem ", "eqsys ", "eos ", & + "ncells ", "last_id ", & + "xblocks ", "yblocks ", "zblocks ", & + "xmin ", "ymin ", "zmin ", & + "xmax ", "ymax ", "zmax " ] + + character(len=*), parameter :: loc = 'IO::restore_snapshot_parameters_xml' !------------------------------------------------------------------------------- ! status = 0 - select case(restart_format) -#ifdef HDF5 - case(snapshot_hdf5) - call read_snapshot_parameter_h5(pname, pvalue, status) -#endif /* HDF5 */ - case default + if (.not. master) return ! check if the snapshot directory and metafile exist ! - write(dname, "(a,'restart-',i5.5)") trim(respath), nrest + write(dname, "(a,'restart-',i5.5)") trim(respath), nrest #ifdef __INTEL_COMPILER - inquire(directory = dname, exist = test) + inquire(directory = dname, exist = test) #else /* __INTEL_COMPILER */ - inquire(file = dname, exist = test) + inquire(file = dname, exist = test) #endif /* __INTEL_COMPILER */ - if (.not. test) then - call print_message(loc, trim(dname) // " does not exist!") - status = 121 - return - end if + if (.not. test) then + call print_message(loc, trim(dname) // " does not exist!") + status = 121 + return + end if - write(fname,"(a,'/metadata.xml')") trim(dname) - inquire(file = fname, exist = test) - if (.not. test) then - call print_message(loc, trim(fname) // " does not exist!") - status = 121 - return - end if + write(fname,"(a,'/metadata.xml')") trim(dname) + inquire(file = fname, exist = test) + if (.not. test) then + call print_message(loc, trim(fname) // " does not exist!") + status = 121 + return + end if ! read requested parameter from the file ! - open(newunit = lun, file = fname, status = 'old') -10 read(lun, fmt = "(a)", end = 20) line - l = index(line, trim(adjustl(pname))) + open(newunit = lun, file = fname, status = 'old') +10 read(lun, fmt = "(a)", end = 20) line + do n = 1, size(keys) + l = index(line, trim(keys(n))) if (l > 0) then l = index(line, '>') + 1 u = index(line, '<', back = .true.) - 1 - pvalue = trim(adjustl(line(l:u))) + if (keys(n) == "eqsys") then + call update_parameter("equation_system", trim(adjustl(line(l:u)))) + else if (keys(n) == "eos") then + call update_parameter("equation_of_state", trim(adjustl(line(l:u)))) + else + call update_parameter(trim(keys(n)), trim(adjustl(line(l:u)))) + end if end if - go to 10 -20 close(lun) - - end select + end do + go to 10 +20 close(lun) !------------------------------------------------------------------------------- ! - end subroutine read_snapshot_parameter_string -! -!=============================================================================== -! -! subroutine READ_SNAPSHOT_PARAMETER_INTEGER: -! ------------------------------------------ -! -! Subroutine reads an integer parameter from the restart snapshot. -! -! Arguments: -! -! pname - the parameter name; -! pvalue - the parameter value; -! status - the status flag (the success is 0, failure otherwise); -! -!=============================================================================== -! - subroutine read_snapshot_parameter_integer(pname, pvalue, status) - - use helpers, only : print_message - - implicit none - - character(len=*), intent(in) :: pname - integer , intent(inout) :: pvalue - integer , intent(inout) :: status - - logical :: test - character(len=255) :: dname, fname, line, svalue - integer(kind=4) :: lun = 103 - integer :: l, u - - character(len=*), parameter :: loc = 'IO::read_snapshot_parameter_integer' - -!------------------------------------------------------------------------------- -! - status = 0 - - select case(restart_format) -#ifdef HDF5 - case(snapshot_hdf5) - call read_snapshot_parameter_h5(pname, pvalue, status) -#endif /* HDF5 */ - case default - -! check if the snapshot directory and metafile exist -! - write(dname, "(a,'restart-',i5.5)") trim(respath), nrest - -#ifdef __INTEL_COMPILER - inquire(directory = dname, exist = test) -#else /* __INTEL_COMPILER */ - inquire(file = dname, exist = test) -#endif /* __INTEL_COMPILER */ - if (.not. test) then - call print_message(loc, trim(dname) // " does not exist!") - status = 121 - return - end if - - write(fname,"(a,'/metadata.xml')") trim(dname) - inquire(file = fname, exist = test) - if (.not. test) then - call print_message(loc, trim(fname) // " does not exist!") - status = 121 - return - end if - -! read parameter from the file -! - open(newunit = lun, file = fname, status = 'old') -10 read(lun, fmt = "(a)", end = 20) line - l = index(line, trim(adjustl(pname))) - if (l > 0) then - l = index(line, '>') + 1 - u = index(line, '<', back = .true.) - 1 - svalue = trim(adjustl(line(l:u))) - read(svalue, fmt = *) pvalue - end if - go to 10 -20 close(lun) - - end select - -!------------------------------------------------------------------------------- -! - end subroutine read_snapshot_parameter_integer -! -!=============================================================================== -! -! subroutine READ_SNAPSHOT_PARAMETER_DOUBLE: -! ----------------------------------------- -! -! Subroutine reads a floating point parameter from the restart snapshot. -! -! Arguments: -! -! pname - the parameter name; -! pvalue - the parameter value; -! status - the status flag (the success is 0, failure otherwise); -! -!=============================================================================== -! - subroutine read_snapshot_parameter_double(pname, pvalue, status) - - use helpers, only : print_message - - implicit none - - character(len=*), intent(in) :: pname - real(kind=8) , intent(inout) :: pvalue - integer , intent(inout) :: status - - logical :: test - character(len=255) :: dname, fname, line, svalue - integer(kind=4) :: lun = 103 - integer :: l, u - - character(len=*), parameter :: loc = 'IO::read_snapshot_parameter_double' - -!------------------------------------------------------------------------------- -! - status = 0 - - select case(restart_format) -#ifdef HDF5 - case(snapshot_hdf5) - call read_snapshot_parameter_h5(pname, pvalue, status) -#endif /* HDF5 */ - case default - -! check if the snapshot directory and metafile exist -! - write(dname, "(a,'restart-',i5.5)") trim(respath), nrest - -#ifdef __INTEL_COMPILER - inquire(directory = dname, exist = test) -#else /* __INTEL_COMPILER */ - inquire(file = dname, exist = test) -#endif /* __INTEL_COMPILER */ - if (.not. test) then - call print_message(loc, trim(dname) // " does not exist!") - status = 121 - return - end if - - write(fname,"(a,'/metadata.xml')") trim(dname) - inquire(file = fname, exist = test) - if (.not. test) then - call print_message(loc, trim(fname) // " does not exist!") - status = 121 - return - end if - -! read parameter from the file -! - open(newunit = lun, file = fname, status = 'old') -10 read(lun, fmt = "(a)", end = 20) line - l = index(line, trim(adjustl(pname))) - if (l > 0) then - l = index(line, '>') + 1 - u = index(line, '<', back = .true.) - 1 - svalue = trim(adjustl(line(l:u))) - read(svalue, fmt = *) pvalue - end if - go to 10 -20 close(lun) - - end select - -!------------------------------------------------------------------------------- -! - end subroutine read_snapshot_parameter_double + end subroutine restore_snapshot_parameters_xml ! !=============================================================================== ! @@ -2783,41 +2662,46 @@ module io ! !=============================================================================== ! -! subroutine READ_SNAPSHOT_PARAMETER_STRING_H5: -! -------------------------------------------- +! subroutine RESTORE_SNAPSHOT_PARAMETERS_H5: +! ----------------------------------------- ! -! Subroutine reads a string parameter from the restart snapshot. +! Subroutine restores parameters from the restart snapshot. ! ! Arguments: ! -! pname - the parameter's name; -! pvalue - the parameter's value; -! status - the subroutine call status; +! status - the status flag (the success is 0, failure otherwise); ! !=============================================================================== ! - subroutine read_snapshot_parameter_string_h5(pname, pvalue, status) + subroutine restore_snapshot_parameters_h5(status) - use helpers, only : print_message + use helpers , only : print_message + use mpitools , only : master + use parameters, only : update_parameter implicit none - character(len=*), intent(in) :: pname - character(len=*), intent(inout) :: pvalue - integer , intent(inout) :: status + integer, intent(inout) :: status character(len=255) :: fname logical :: flag integer(hid_t) :: file_id, grp_id - character(len=*), parameter :: loc = & - 'IO::read_snapshot_parameter_string_h5()' + integer :: ival + real(kind=8) :: rval + character(len=64) :: sval + + character(len=:), allocatable :: pname + + character(len=*), parameter :: loc = 'IO::restore_snapshot_parameters_h5' !------------------------------------------------------------------------------- ! status = 0 + if (.not. master) return + write(fname, "(a,'r',i6.6,'_',i5.5,'.h5')") trim(respath), nrest, 0 inquire(file=fname, exist=flag) if (.not. flag) then @@ -2835,159 +2719,140 @@ module io call h5gopen_f(file_id, 'attributes', grp_id, status) if (status == 0) then - call restore_attribute_h5(grp_id, pname, pvalue, status) + + pname = "problem" + call restore_attribute_h5(grp_id, pname, sval, status) if (status /= 0) & call print_message(loc, "Failed to restore attribute" // & trim(pname) // "!") - call h5gclose_f(grp_id, status) + call update_parameter(pname, trim(adjustl(sval))) + + pname = "eqsys" + call restore_attribute_h5(grp_id, pname, sval, status) if (status /= 0) & - call print_message(loc, "Could not close group 'attributes'!") - else - call print_message(loc, "Could not open group 'attributes'!") - end if + call print_message(loc, "Failed to restore attribute" // & + trim(pname) // "!") + call update_parameter("equation_system", trim(adjustl(sval))) - call h5fclose_f(file_id, status) - if (status /= 0) & - call print_message(loc, "Could not close " // trim(fname) // "!") + pname = "eos" + call restore_attribute_h5(grp_id, pname, sval, status) + if (status /= 0) & + call print_message(loc, "Failed to restore attribute" // & + trim(pname) // "!") + call update_parameter("equation_of_state", trim(adjustl(sval))) -!------------------------------------------------------------------------------- -! - end subroutine read_snapshot_parameter_string_h5 -! -!=============================================================================== -! -! subroutine READ_SNAPSHOT_PARAMETER_INTEGER_H5: -! --------------------------------------------- -! -! Subroutine reads an integer parameter from the restart snapshot. -! -! Arguments: -! -! pname - the parameter's name; -! pvalue - the parameter's value; -! status - the subroutine call status; -! -!=============================================================================== -! - subroutine read_snapshot_parameter_integer_h5(pname, pvalue, status) - - use helpers, only : print_message - - implicit none - - character(len=*), intent(in) :: pname - integer , intent(inout) :: pvalue - integer , intent(inout) :: status - - character(len=255) :: fname - logical :: flag - - integer(hid_t) :: file_id, grp_id - - character(len=*), parameter :: loc = & - 'IO::read_snapshot_parameter_integer_h5()' - -!------------------------------------------------------------------------------- -! - status = 0 - - write(fname, "(a,'r',i6.6,'_',i5.5,'.h5')") trim(respath), nrest, 0 - inquire(file=fname, exist=flag) - if (.not. flag) then - call print_message(loc, "Restart snapshot " // trim(fname) // & - " does not exist!") - status = 1 - return - end if - - call h5fopen_f(fname, H5F_ACC_RDONLY_F, file_id, status) - if (status /= 0) then - call print_message(loc, "Could not open " // trim(fname) // "!") - return - end if - - call h5gopen_f(file_id, 'attributes', grp_id, status) - if (status == 0) then + pname = "nprocs" call restore_attribute_h5(grp_id, pname, & - H5T_NATIVE_INTEGER, 1, pvalue, status) + H5T_NATIVE_INTEGER, 1, ival, status) if (status /= 0) & call print_message(loc, "Failed to restore attribute" // & trim(pname) // "!") - call h5gclose_f(grp_id, status) - if (status /= 0) & - call print_message(loc, "Could not close group 'attributes'!") - else - call print_message(loc, "Could not open group 'attributes'!") - end if + write(sval,"(i0)") ival + call update_parameter("nfiles", trim(adjustl(sval))) - call h5fclose_f(file_id, status) - if (status /= 0) & - call print_message(loc, "Could not close " // trim(fname) // "!") - -!------------------------------------------------------------------------------- -! - end subroutine read_snapshot_parameter_integer_h5 -! -!=============================================================================== -! -! subroutine READ_SNAPSHOT_PARAMETER_DOUBLE_H5: -! -------------------------------------------- -! -! Subroutine reads a double precision real parameter from the restart -! snapshot. -! -! Arguments: -! -! pname - the parameter's name; -! pvalue - the parameter's value; -! status - the subroutine call status; -! -!=============================================================================== -! - subroutine read_snapshot_parameter_double_h5(pname, pvalue, status) - - use helpers, only : print_message - - implicit none - - character(len=*), intent(in) :: pname - real(kind=8) , intent(inout) :: pvalue - integer , intent(inout) :: status - - character(len=255) :: fname - logical :: flag - - integer(hid_t) :: file_id, grp_id - - character(len=*), parameter :: loc = & - 'IO::read_snapshot_parameter_double_h5()' - -!------------------------------------------------------------------------------- -! - status = 0 - - write(fname, "(a,'r',i6.6,'_',i5.5,'.h5')") trim(respath), nrest, 0 - inquire(file=fname, exist=flag) - if (.not. flag) then - call print_message(loc, "Restart snapshot " // trim(fname) // & - " does not exist!") - status = 1 - return - end if - - call h5fopen_f(fname, H5F_ACC_RDONLY_F, file_id, status) - if (status /= 0) then - call print_message(loc, "Could not open " // trim(fname) // "!") - return - end if - - call h5gopen_f(file_id, 'attributes', grp_id, status) - if (status == 0) then + pname = "ncells" call restore_attribute_h5(grp_id, pname, & - H5T_NATIVE_DOUBLE, 1, pvalue, status) + H5T_NATIVE_INTEGER, 1, ival, status) if (status /= 0) & call print_message(loc, "Failed to restore attribute" // & trim(pname) // "!") + write(sval,"(i0)") ival + call update_parameter(pname, trim(adjustl(sval))) + + pname = "xblocks" + call restore_attribute_h5(grp_id, pname, & + H5T_NATIVE_INTEGER, 1, ival, status) + if (status /= 0) & + call print_message(loc, "Failed to restore attribute" // & + trim(pname) // "!") + write(sval,"(i0)") ival + call update_parameter(pname, trim(adjustl(sval))) + + pname = "yblocks" + call restore_attribute_h5(grp_id, pname, & + H5T_NATIVE_INTEGER, 1, ival, status) + if (status /= 0) & + call print_message(loc, "Failed to restore attribute" // & + trim(pname) // "!") + write(sval,"(i0)") ival + call update_parameter(pname, trim(adjustl(sval))) + +#if NDIMS == 3 + pname = "zblocks" + call restore_attribute_h5(grp_id, pname, & + H5T_NATIVE_INTEGER, 1, ival, status) + if (status /= 0) & + call print_message(loc, "Failed to restore attribute" // & + trim(pname) // "!") + write(sval,"(i0)") ival + call update_parameter(pname, trim(adjustl(sval))) +#endif /* NDIMS == 3 */ + + pname = "last_id" + call restore_attribute_h5(grp_id, pname, & + H5T_NATIVE_INTEGER, 1, ival, status) + if (status /= 0) & + call print_message(loc, "Failed to restore attribute" // & + trim(pname) // "!") + write(sval,"(i0)") ival + call update_parameter(pname, trim(adjustl(sval))) + + pname = "xmin" + call restore_attribute_h5(grp_id, pname, & + H5T_NATIVE_DOUBLE, 1, rval, status) + if (status /= 0) & + call print_message(loc, "Failed to restore attribute" // & + trim(pname) // "!") + write(sval,"(1es32.20)") rval + call update_parameter(pname, trim(adjustl(sval))) + + pname = "xmax" + call restore_attribute_h5(grp_id, pname, & + H5T_NATIVE_DOUBLE, 1, rval, status) + if (status /= 0) & + call print_message(loc, "Failed to restore attribute" // & + trim(pname) // "!") + write(sval,"(1es32.20)") rval + call update_parameter(pname, trim(adjustl(sval))) + + pname = "ymin" + call restore_attribute_h5(grp_id, pname, & + H5T_NATIVE_DOUBLE, 1, rval, status) + if (status /= 0) & + call print_message(loc, "Failed to restore attribute" // & + trim(pname) // "!") + write(sval,"(1es32.20)") rval + call update_parameter(pname, trim(adjustl(sval))) + + pname = "ymax" + call restore_attribute_h5(grp_id, pname, & + H5T_NATIVE_DOUBLE, 1, rval, status) + if (status /= 0) & + call print_message(loc, "Failed to restore attribute" // & + trim(pname) // "!") + write(sval,"(1es32.20)") rval + call update_parameter(pname, trim(adjustl(sval))) + +#if NDIMS == 3 + pname = "zmin" + call restore_attribute_h5(grp_id, pname, & + H5T_NATIVE_DOUBLE, 1, rval, status) + if (status /= 0) & + call print_message(loc, "Failed to restore attribute" // & + trim(pname) // "!") + write(sval,"(1es32.20)") rval + call update_parameter(pname, trim(adjustl(sval))) + + pname = "zmax" + call restore_attribute_h5(grp_id, pname, & + H5T_NATIVE_DOUBLE, 1, rval, status) + if (status /= 0) & + call print_message(loc, "Failed to restore attribute" // & + trim(pname) // "!") + write(sval,"(1es32.20)") rval + call update_parameter(pname, trim(adjustl(sval))) +#endif /* NDIMS == 3 */ + call h5gclose_f(grp_id, status) if (status /= 0) & call print_message(loc, "Could not close group 'attributes'!") @@ -3001,7 +2866,7 @@ module io !------------------------------------------------------------------------------- ! - end subroutine read_snapshot_parameter_double_h5 + end subroutine restore_snapshot_parameters_h5 ! !=============================================================================== ! @@ -3020,13 +2885,14 @@ module io ! subroutine read_restart_snapshot_h5(status) - use blocks , only : change_blocks_process - use forcing , only : einj - use helpers , only : print_message + use blocks , only : change_blocks_process + use forcing , only : einj + use helpers , only : print_message #ifdef MPI - use mesh , only : redistribute_blocks + use mesh , only : redistribute_blocks #endif /* MPI */ - use mpitools, only : nprocs, nproc + use mpitools , only : nprocs, nproc + use parameters, only : get_parameter implicit none @@ -3059,8 +2925,9 @@ module io return end if - call read_snapshot_parameter_h5('nprocs' , nfiles , status) - call read_snapshot_parameter_h5('last_id', last_id, status) + call get_parameter("nfiles", nfiles) + call get_parameter("last_id", last_id) + allocate(block_array(last_id)) call restore_attributes_h5(file_id, status) diff --git a/sources/parameters.F90 b/sources/parameters.F90 index a64bea8..67cc7e9 100644 --- a/sources/parameters.F90 +++ b/sources/parameters.F90 @@ -66,7 +66,10 @@ module parameters ! -------------- ! public :: read_parameters, finalize_parameters - public :: parameter_file, get_parameter + public :: parameter_file, update_parameter, get_parameter +#ifdef MPI + public :: distribute_parameters +#endif /* MPI */ contains @@ -324,6 +327,63 @@ module parameters ! end subroutine parse_parameters +!=============================================================================== +! +! subroutine UPDATE_PARAMETER: +! --------------------------- +! +! Description: +! +! Subroutine updates the value of the item by the given key. +! +! Arguments: +! +! key - the parameter name; +! val - the value of parameter; +! +!=============================================================================== +! + subroutine update_parameter(key, val) + + use iso_fortran_env, only : error_unit + + implicit none + + character(len=*), intent(in) :: key, val + + type(item), pointer :: item_ptr + + logical :: exists + + character(len=*), parameter :: loc = 'PARAMETERS::update_parameter()' + +!------------------------------------------------------------------------------- +! + exists = .false. + item_ptr => parameter_list + do while(associated(item_ptr)) + if (key == item_ptr%key) then + if (val /= item_ptr%val) item_ptr%val = val + exists = .true. + exit + end if + item_ptr => item_ptr%next + end do + + if (.not. exists) then + allocate(item_ptr) + item_ptr%key = key + item_ptr%val = val + item_ptr%next => parameter_list + parameter_list => item_ptr + end if + + return + +!------------------------------------------------------------------------------- +! + end subroutine update_parameter + !=============================================================================== ! ! subroutine GET_PARAMETER_INTEGER: @@ -499,6 +559,17 @@ module parameters counters(2) = max(counters(2), len(item_ptr%key // '|' // item_ptr%val)) item_ptr => item_ptr%next end do + else + item_ptr => parameter_list + do while(associated(item_ptr)) + parameter_list => parameter_list%next + + nullify(item_ptr%next) + deallocate(item_ptr%key, item_ptr%val) + deallocate(item_ptr) + + item_ptr => parameter_list + end do end if ! broadcast the number of items and the maximum item length diff --git a/sources/system.F90 b/sources/system.F90 index bf15025..3972834 100644 --- a/sources/system.F90 +++ b/sources/system.F90 @@ -617,7 +617,7 @@ module system subroutine restore_parameters(status) use io , only : restart_from_snapshot, restart_snapshot_number - use io , only : read_snapshot_parameter + use io , only : restore_snapshot_parameters use parameters, only : get_parameter implicit none @@ -636,57 +636,29 @@ module system dbnds(:,2) = 1.0d+00 if (resumed) then - call read_snapshot_parameter("problem", name, status) + call restore_snapshot_parameters(status) if (status /=0) return - call read_snapshot_parameter("eqsys" , eqsys, status) - if (status /=0) return - call read_snapshot_parameter("eos" , eos , status) - if (status /=0) return - call read_snapshot_parameter("ncells" , ncells, status) - if (status /=0) return - call read_snapshot_parameter("maxlev" , maxlev, status) - if (status /=0) return - call read_snapshot_parameter("xblocks", bdims(1), status) - if (status /=0) return - call read_snapshot_parameter("yblocks", bdims(2), status) - if (status /=0) return - call read_snapshot_parameter("zblocks", bdims(3), status) - if (status /=0) return - call read_snapshot_parameter("xmin", dbnds(1,1), status) - if (status /=0) return - call read_snapshot_parameter("xmax", dbnds(1,2), status) - if (status /=0) return - call read_snapshot_parameter("ymin", dbnds(2,1), status) - if (status /=0) return - call read_snapshot_parameter("ymax", dbnds(2,2), status) - if (status /=0) return -#if NDIMS == 3 - call read_snapshot_parameter("zmin", dbnds(3,1), status) - if (status /=0) return - call read_snapshot_parameter("zmax", dbnds(3,2), status) - if (status /=0) return -#endif /* NDIMS == 3 */ - else - call get_parameter("problem", name) - call get_parameter("equation_system" , eqsys) - call get_parameter("equation_of_state", eos) - call get_parameter("ncells", ncells) - call get_parameter("maxlev", maxlev) - call get_parameter("xblocks", bdims(1)) - call get_parameter("yblocks", bdims(2)) -#if NDIMS == 3 - call get_parameter("zblocks", bdims(3)) -#endif /* NDIMS == 3 */ - call get_parameter("xmin", dbnds(1,1)) - call get_parameter("xmax", dbnds(1,2)) - call get_parameter("ymin", dbnds(2,1)) - call get_parameter("ymax", dbnds(2,2)) -#if NDIMS == 3 - call get_parameter("zmin", dbnds(3,1)) - call get_parameter("zmax", dbnds(3,2)) -#endif /* NDIMS == 3 */ end if + call get_parameter("problem", name) + call get_parameter("equation_system" , eqsys) + call get_parameter("equation_of_state", eos) + call get_parameter("ncells", ncells) + call get_parameter("maxlev", maxlev) + call get_parameter("xblocks", bdims(1)) + call get_parameter("yblocks", bdims(2)) +#if NDIMS == 3 + call get_parameter("zblocks", bdims(3)) +#endif /* NDIMS == 3 */ + call get_parameter("xmin", dbnds(1,1)) + call get_parameter("xmax", dbnds(1,2)) + call get_parameter("ymin", dbnds(2,1)) + call get_parameter("ymax", dbnds(2,2)) +#if NDIMS == 3 + call get_parameter("zmin", dbnds(3,1)) + call get_parameter("zmax", dbnds(3,2)) +#endif /* NDIMS == 3 */ + call get_parameter("rngtype", rngtype) call get_parameter("tmax" , tmax) call get_parameter("trun" , trun)