From fb1f429f42570a2d5f5cd8767a7c2a217cc271b0 Mon Sep 17 00:00:00 2001 From: Vincent Vanlaer Date: Sat, 11 Apr 2026 20:11:44 +0200 Subject: [PATCH] refactor inlist reading This commit introduces utils_namelist, which abstracts some of the common aspects of reading inlists in MESA (error message, nested inlists, ...). Previously, various different namelist reading routines were copied and modified around the code base. These have accrued various differences over time, which has been fixed now. The following behaviour has been changed: - pgbinary and pgstar no longer make MESA error when they are missing from inlists - it no longer matters where in the chain of inlist a namelist section is missing. It used to be that for certain section, only the first inline in a chain was allowed to have a missing section. - checks and copying of options only happens once all inlists have been read - failures when reading inlists will no longer dump a stack trace on the user --- astero/public/astero_def.f90 | 137 ++++++------------------ binary/private/binary_ctrls_io.f90 | 79 ++++---------- binary/private/binary_job_ctrls_io.f90 | 83 ++++----------- binary/private/pgbinary_ctrls_io.f90 | 89 +++++----------- colors/private/colors_ctrls_io.f90 | 101 +++++------------- colors/public/colors_lib.f90 | 6 +- eos/private/eos_ctrls_io.f90 | 104 ++++++------------- eos/public/eos_lib.f90 | 4 +- kap/private/kap_ctrls_io.f90 | 96 +++++------------ kap/public/kap_lib.f90 | 4 +- star/job/run_star_support.f90 | 3 +- star/private/ctrls_io.f90 | 85 ++++----------- star/private/pgstar_ctrls_io.f90 | 84 ++++----------- star/private/star_job_ctrls_io.f90 | 84 ++++----------- utils/Makefile | 5 +- utils/private/namelist.f90 | 138 +++++++++++++++++++++++++ 16 files changed, 404 insertions(+), 698 deletions(-) create mode 100644 utils/private/namelist.f90 diff --git a/astero/public/astero_def.f90 b/astero/public/astero_def.f90 index 5bc12e04a..10337c605 100644 --- a/astero/public/astero_def.f90 +++ b/astero/public/astero_def.f90 @@ -839,73 +839,39 @@ end subroutine realloc_integer2_modes subroutine read_astero_search_controls(filename, ierr) + use utils_namelist, only: read_namelist, missing_namelist_error character (len=*), intent(in) :: filename integer, intent(out) :: ierr + ! initialize controls to default values include 'astero_search.defaults' - ierr = 0 - call read1_astero_search_inlist(filename, 1, ierr) - end subroutine read_astero_search_controls + call read_namelist(filename, read_astero_search_file, "astero_search_controls", ierr, missing_namelist_error) + end subroutine read_astero_search_controls - recursive subroutine read1_astero_search_inlist(filename, level, ierr) - character (len=*), intent(in) :: filename - integer, intent(in) :: level - integer, intent(out) :: ierr + subroutine read_astero_search_file(unit, iostat, iomsg, extra_inlists, extra_inlists_mask) + use const_def, only: strlen, max_extra_inlists - logical, dimension(max_extra_inlists) :: read_extra - character (len=strlen) :: message - character (len=strlen), dimension(max_extra_inlists) :: extra - integer :: unit, i + integer, intent(in) :: unit + integer, intent(out) :: iostat + character(len=strlen), intent(out) :: iomsg + character(len=strlen), dimension(max_extra_inlists), intent(out) :: extra_inlists + logical, dimension(max_extra_inlists), intent(out) :: extra_inlists_mask - if (level >= 10) then - write(*,*) 'ERROR: too many levels of nested extra star_job inlist files' - ierr = -1 - return - end if + integer :: i - ierr = 0 - unit=alloc_iounit(ierr) - if (ierr /= 0) return + read(unit, nml=astero_search_controls, iostat=iostat, iomsg=iomsg) - open(unit=unit, file=trim(filename), action='read', delim='quote', iostat=ierr) - if (ierr /= 0) then - write(*, *) 'Failed to open astero search inlist file ', trim(filename) - else - read(unit, nml=astero_search_controls, iostat=ierr) - close(unit) - if (ierr /= 0) then - write(*, *) & - 'Failed while trying to read astero search inlist file ', trim(filename) - write(*, '(a)') trim(message) - write(*, '(a)') & - 'The following runtime error message might help you find the problem' - write(*, *) - open(unit=unit, file=trim(filename), & - action='read', delim='quote', status='old', iostat=ierr) - read(unit, nml=astero_search_controls) - close(unit) - end if + if (iostat /= 0) then + return end if - call free_iounit(unit) - if (ierr /= 0) return - ! recursive calls to read other inlists do i=1, max_extra_inlists - read_extra(i) = read_extra_astero_search_inlist(i) - read_extra_astero_search_inlist(i) = .false. - extra(i) = extra_astero_search_inlist_name(i) - extra_astero_search_inlist_name(i) = 'undefined' - - if (read_extra(i)) then - call read1_astero_search_inlist(extra(i), level+1, ierr) - if (ierr /= 0) return - end if + extra_inlists(i) = extra_astero_search_inlist_name(i) + extra_inlists_mask(i) = read_extra_astero_search_inlist(i) end do - - end subroutine read1_astero_search_inlist - + end subroutine read_astero_search_file subroutine write_astero_search_controls(filename_in, ierr) use utils_lib @@ -938,75 +904,40 @@ subroutine write_astero_search_controls(filename_in, ierr) end subroutine write_astero_search_controls - subroutine read_astero_pgstar_controls(filename, ierr) + use utils_namelist, only: read_namelist, missing_namelist_error character (len=*), intent(in) :: filename integer, intent(out) :: ierr ! initialize controls to default values include 'astero_pgstar.defaults' - ierr = 0 - call read1_astero_pgstar_inlist(filename, 1, ierr) - + call read_namelist(filename, read_astero_pgstar_file, "astero_pgstar_controls", ierr, missing_namelist_error) end subroutine read_astero_pgstar_controls + subroutine read_astero_pgstar_file(unit, iostat, iomsg, extra_inlists, extra_inlists_mask) + use const_def, only: strlen, max_extra_inlists - recursive subroutine read1_astero_pgstar_inlist(filename, level, ierr) - character (len=*), intent(in) :: filename - integer, intent(in) :: level - integer, intent(out) :: ierr + integer, intent(in) :: unit + integer, intent(out) :: iostat + character(len=strlen), intent(out) :: iomsg + character(len=strlen), dimension(max_extra_inlists), intent(out) :: extra_inlists + logical, dimension(max_extra_inlists), intent(out) :: extra_inlists_mask - logical, dimension(max_extra_inlists) :: read_extra - character (len=strlen), dimension(max_extra_inlists) :: extra - integer :: unit, i + integer :: i - if (level >= 10) then - write(*,*) 'ERROR: too many levels of nested extra star_job inlist files' - ierr = -1 - return - end if + read(unit, nml=astero_pgstar_controls, iostat=iostat, iomsg=iomsg) - ierr = 0 - unit=alloc_iounit(ierr) - if (ierr /= 0) return - - open(unit=unit, file=trim(filename), action='read', delim='quote', iostat=ierr) - if (ierr /= 0) then - write(*, *) 'Failed to open astero pgstar inlist file ', trim(filename) - else - read(unit, nml=astero_pgstar_controls, iostat=ierr) - close(unit) - if (ierr /= 0) then - write(*, *) & - 'Failed while trying to read astero pgstar inlist file ', trim(filename) - write(*, '(a)') & - 'The following runtime error message might help you find the problem' - write(*, *) - open(unit=unit, file=trim(filename), & - action='read', delim='quote', status='old', iostat=ierr) - read(unit, nml=astero_pgstar_controls) - close(unit) - end if + if (iostat /= 0) then + return end if - call free_iounit(unit) - if (ierr /= 0) return - ! recursive calls to read other inlists do i=1, max_extra_inlists - read_extra(i) = read_extra_astero_pgstar_inlist(i) - read_extra_astero_pgstar_inlist(i) = .false. - extra(i) = extra_astero_pgstar_inlist_name(i) - extra_astero_pgstar_inlist_name(i) = 'undefined' - - if (read_extra(i)) then - call read1_astero_pgstar_inlist(extra(i), level+1, ierr) - if (ierr /= 0) return - end if + extra_inlists(i) = extra_astero_pgstar_inlist_name(i) + extra_inlists_mask(i) = read_extra_astero_pgstar_inlist(i) end do - end subroutine read1_astero_pgstar_inlist - + end subroutine read_astero_pgstar_file subroutine save_sample_results_to_file(i_total, results_fname, ierr) use utils_lib diff --git a/binary/private/binary_ctrls_io.f90 b/binary/private/binary_ctrls_io.f90 index c63ff7080..9e91c4318 100644 --- a/binary/private/binary_ctrls_io.f90 +++ b/binary/private/binary_ctrls_io.f90 @@ -259,88 +259,51 @@ end subroutine do_one_binary_setup subroutine read_binary_controls(b, filename, ierr) - use utils_lib + use utils_namelist, only: read_namelist, missing_namelist_error type (binary_info), pointer :: b character(*), intent(in) :: filename integer, intent(out) :: ierr - call read_binary_controls_file(b, filename, 1, ierr) + call read_namelist(filename, read_binary_controls_file, "binary_controls", ierr, missing_namelist_error) + + if (ierr /= 0) return + + call store_binary_controls(b) end subroutine read_binary_controls + subroutine read_binary_controls_file(unit, iostat, iomsg, extra_inlists, extra_inlists_mask) + use const_def, only: strlen, max_extra_inlists - recursive subroutine read_binary_controls_file(b, filename, level, ierr) - use utils_lib - character(*), intent(in) :: filename - type (binary_info), pointer :: b - integer, intent(in) :: level - integer, intent(out) :: ierr - logical, dimension(max_extra_inlists) :: read_extra - character (len=strlen), dimension(max_extra_inlists) :: extra - integer :: unit, i + integer, intent(in) :: unit + integer, intent(out) :: iostat + character(len=strlen), intent(out) :: iomsg + character(len=strlen), dimension(max_extra_inlists), intent(out) :: extra_inlists + logical, dimension(max_extra_inlists), intent(out) :: extra_inlists_mask - ierr = 0 + integer :: i - if (level >= 10) then - write(*,*) 'ERROR: too many levels of nested extra binary controls inlist files' - ierr = -1 - return - end if + read(unit, nml=binary_controls, iostat=iostat, iomsg=iomsg) - if (len_trim(filename) > 0) then - open(newunit=unit, file=trim(filename), action='read', delim='quote', status='old', iostat=ierr) - if (ierr /= 0) then - write(*, *) 'Failed to open binary control namelist file ', trim(filename) - return - end if - read(unit, nml=binary_controls, iostat=ierr) - close(unit) - if (ierr /= 0) then - write(*, *) - write(*, *) - write(*, *) - write(*, *) - write(*, '(a)') & - 'Failed while trying to read binary control namelist file: ' // trim(filename) - write(*, '(a)') & - 'Perhaps the following runtime error message will help you find the problem.' - write(*, *) - open(newunit=unit, file=trim(filename), action='read', delim='quote', status='old', iostat=ierr) - read(unit, nml=binary_controls) - close(unit) - return - end if + if (iostat /= 0) then + return end if - call store_binary_controls(b, ierr) - - ! recursive calls to read other inlists do i=1, max_extra_inlists - read_extra(i) = read_extra_binary_controls_inlist(i) - read_extra_binary_controls_inlist(i) = .false. - extra(i) = extra_binary_controls_inlist_name(i) - extra_binary_controls_inlist_name(i) = 'undefined' - - if (read_extra(i)) then - call read_binary_controls_file(b, extra(i), level+1, ierr) - if (ierr /= 0) return - end if + extra_inlists(i) = extra_binary_controls_inlist_name(i) + extra_inlists_mask(i) = read_extra_binary_controls_inlist(i) end do end subroutine read_binary_controls_file - subroutine set_default_binary_controls include 'binary_controls.defaults' end subroutine set_default_binary_controls - subroutine store_binary_controls(b, ierr) + subroutine store_binary_controls(b) use utils_lib, only: mkdir type (binary_info), pointer :: b - integer, intent(out) :: ierr - - ierr = 0 ! specifications for starting model b% m1 = m1 @@ -812,7 +775,7 @@ subroutine set_binary_control(b, name, val, ierr) read(tmp, nml=binary_controls) ! Add to star - call store_binary_controls(b, ierr) + call store_binary_controls(b) if(ierr/=0) return end subroutine set_binary_control diff --git a/binary/private/binary_job_ctrls_io.f90 b/binary/private/binary_job_ctrls_io.f90 index 381c9c1cb..97cc374eb 100644 --- a/binary/private/binary_job_ctrls_io.f90 +++ b/binary/private/binary_job_ctrls_io.f90 @@ -69,84 +69,45 @@ module binary_job_ctrls_io subroutine do_read_binary_job(b, filename, ierr) - use utils_lib + use utils_namelist, only: read_namelist, missing_namelist_error type (binary_info), pointer :: b character(*), intent(in) :: filename integer, intent(out) :: ierr - character (len=strlen) :: binary_job_namelist_name - binary_job_namelist_name = '' - ierr = 0 + call set_default_binary_job_controls - call read_binary_job_file(b, filename, 1, ierr) + call read_namelist(filename, read_binary_job_file, "binary_job", ierr, missing_namelist_error) + + if (ierr /= 0) return + + call store_binary_job_controls(b) end subroutine do_read_binary_job + subroutine read_binary_job_file(unit, iostat, iomsg, extra_inlists, extra_inlists_mask) + use const_def, only: strlen, max_extra_inlists - recursive subroutine read_binary_job_file(b, filename, level, ierr) - use utils_lib - character(*), intent(in) :: filename - type (binary_info), pointer :: b - integer, intent(in) :: level - integer, intent(out) :: ierr - logical, dimension(max_extra_inlists) :: read_extra - character (len=strlen), dimension(max_extra_inlists) :: extra - integer :: unit, i + integer, intent(in) :: unit + integer, intent(out) :: iostat + character(len=strlen), intent(out) :: iomsg + character(len=strlen), dimension(max_extra_inlists), intent(out) :: extra_inlists + logical, dimension(max_extra_inlists), intent(out) :: extra_inlists_mask - ierr = 0 + integer :: i - if (level >= 10) then - write(*,*) 'ERROR: too many levels of nested extra binary_job inlist files' - ierr = -1 - return - end if + read(unit, nml=binary_job, iostat=iostat, iomsg=iomsg) - if (len_trim(filename) > 0) then - open(newunit=unit, file=trim(filename), action='read', delim='quote', status='old', iostat=ierr) - if (ierr /= 0) then - write(*, *) 'Failed to open control namelist file ', trim(filename) - return - end if - read(unit, nml=binary_job, iostat=ierr) - close(unit) - if (ierr /= 0) then - write(*, *) - write(*, *) - write(*, *) - write(*, *) - write(*, '(a)') & - 'Failed while trying to read control namelist file: ' // trim(filename) - write(*, '(a)') & - 'Perhaps the following runtime error message will help you find the problem.' - write(*, *) - open(newunit=unit, file=trim(filename), action='read', delim='quote', status='old', iostat=ierr) - read(unit, nml=binary_job) - close(unit) - return - end if + if (iostat /= 0) then + return end if - call store_binary_job_controls(b, ierr) - - ! recursive calls to read other inlists do i=1, max_extra_inlists - read_extra(i) = read_extra_binary_job_inlist(i) - read_extra_binary_job_inlist(i) = .false. - extra(i) = extra_binary_job_inlist_name(i) - extra_binary_job_inlist_name(i) = 'undefined' - - if (read_extra(i)) then - call read_binary_job_file(b, extra(i), level+1, ierr) - if (ierr /= 0) return - end if + extra_inlists(i) = extra_binary_job_inlist_name(i) + extra_inlists_mask(i) = read_extra_binary_job_inlist(i) end do end subroutine read_binary_job_file - - subroutine store_binary_job_controls(b, ierr) + subroutine store_binary_job_controls(b) type (binary_info), pointer :: b - integer, intent(out) :: ierr - - ierr = 0 b% job% show_binary_log_description_at_start = show_binary_log_description_at_start b% job% binary_history_columns_file = binary_history_columns_file @@ -321,7 +282,7 @@ subroutine set_binary_job(b, name, val, ierr) read(tmp, nml=binary_job) ! Add to star - call store_binary_job_controls(b, ierr) + call store_binary_job_controls(b) if(ierr/=0) return end subroutine set_binary_job diff --git a/binary/private/pgbinary_ctrls_io.f90 b/binary/private/pgbinary_ctrls_io.f90 index b1dfec26c..21ac53291 100644 --- a/binary/private/pgbinary_ctrls_io.f90 +++ b/binary/private/pgbinary_ctrls_io.f90 @@ -1365,85 +1365,50 @@ module pgbinary_ctrls_io subroutine read_pgbinary(b, filename, ierr) - use binary_private_def - use utils_lib - type (binary_info), pointer :: b + use binary_private_def, only: binary_info + use utils_namelist, only: read_namelist, missing_namelist_warning + type (binary_info), intent(inout) :: b character(*), intent(in) :: filename integer, intent(out) :: ierr - ! character (len = strlen) :: pgbinary_namelist_name - ! pgbinary_namelist_name = '' - ierr = 0 + call set_default_pgbinary_controls - call read_pgbinary_file(b, filename, 1, ierr) + call read_namelist(filename, read_pgbinary_file, "pgbinary", ierr, missing_namelist_warning) + + if (ierr /= 0) return + + call store_pgbinary_controls(b) end subroutine read_pgbinary + subroutine read_pgbinary_file(unit, iostat, iomsg, extra_inlists, extra_inlists_mask) + use const_def, only: strlen, max_extra_inlists - recursive subroutine read_pgbinary_file(b, filename, level, ierr) - use binary_private_def - use utils_lib - character(*), intent(in) :: filename - type (binary_info), pointer :: b - integer, intent(in) :: level - integer, intent(out) :: ierr - logical, dimension(max_extra_inlists) :: read_extra - character (len=strlen), dimension(max_extra_inlists) :: extra - integer :: unit, i + integer, intent(in) :: unit + integer, intent(out) :: iostat + character(len=strlen), intent(out) :: iomsg + character(len=strlen), dimension(max_extra_inlists), intent(out) :: extra_inlists + logical, dimension(max_extra_inlists), intent(out) :: extra_inlists_mask - ierr = 0 + integer :: i - if (level >= 10) then - write(*, *) 'ERROR: too many levels of nested extra pgbinary inlist files' - ierr = -1 + read(unit, nml=pgbinary, iostat=iostat, iomsg=iomsg) + + if (iostat /= 0) then return end if - if (len_trim(filename) > 0) then - open(newunit = unit, file = trim(filename), action = 'read', delim = 'quote', status = 'old', iostat = ierr) - if (ierr /= 0) then - write(*, *) 'Failed to open pgbinary namelist file ', trim(filename) - return - end if - read(unit, nml = pgbinary, iostat = ierr) - close(unit) - if (ierr /= 0) then - write(*, *) - write(*, *) - write(*, '(a)') & - 'Failed while trying to read pgbinary namelist file: ' // trim(filename) - write(*, '(a)') & - 'Perhaps the following runtime error message will help you find the problem.' - write(*, *) - open(newunit = unit, file = trim(filename), action = 'read', delim = 'quote', status = 'old', iostat = ierr) - read(unit, nml = pgbinary) - close(unit) - return - end if - end if - - call store_pgbinary_controls(b, ierr) - ! recursive calls to read other inlists - do i=1, max_extra_inlists - read_extra(i) = read_extra_pgbinary_inlist(i) - read_extra_pgbinary_inlist(i) = .false. - extra(i) = extra_pgbinary_inlist_name(i) - extra_pgbinary_inlist_name(i) = 'undefined' - - if (read_extra(i)) then - call read_pgbinary_file(b, extra(i), level+1, ierr) - if (ierr /= 0) return - end if - end do + do i=1, max_extra_inlists + extra_inlists(i) = extra_pgbinary_inlist_name(i) + extra_inlists_mask(i) = read_extra_pgbinary_inlist(i) + end do end subroutine read_pgbinary_file + subroutine store_pgbinary_controls(b) + use binary_private_def, only: binary_info + type (binary_info), intent(inout), target :: b - subroutine store_pgbinary_controls(b, ierr) - use binary_private_def - type (binary_info), pointer :: b type (pgbinary_controls), pointer :: pg - integer, intent(out) :: ierr - ierr = 0 pg => b% pg pg% file_device = file_device diff --git a/colors/private/colors_ctrls_io.f90 b/colors/private/colors_ctrls_io.f90 index dc560be8e..8b043886f 100644 --- a/colors/private/colors_ctrls_io.f90 +++ b/colors/private/colors_ctrls_io.f90 @@ -24,7 +24,7 @@ module colors_ctrls_io implicit none - public :: read_namelist, write_namelist, get_colors_controls, set_colors_controls + public :: read_colors_namelist, write_namelist, get_colors_controls, set_colors_controls private @@ -56,100 +56,57 @@ module colors_ctrls_io contains ! read a "namelist" file and set parameters - subroutine read_namelist(handle, inlist, ierr) + subroutine read_colors_namelist(handle, inlist, ierr) + use utils_namelist, only: read_namelist, missing_namelist_warning integer, intent(in) :: handle character(len=*), intent(in) :: inlist integer, intent(out) :: ierr ! 0 means AOK. type(Colors_General_Info), pointer :: rq - include 'formats' + call get_colors_ptr(handle, rq, ierr) + if (ierr /= 0) return + call set_default_controls - call read_controls_file(rq, inlist, 1, ierr) + call read_namelist(inlist, read_colors_file, "colors", ierr, missing_namelist_warning) + if (ierr /= 0) return - end subroutine read_namelist - recursive subroutine read_controls_file(rq, filename, level, ierr) - use iso_fortran_env, only: iostat_end - character(*), intent(in) :: filename - integer, intent(in) :: level - type(Colors_General_Info), pointer, intent(inout) :: rq - integer, intent(out) :: ierr - logical, dimension(max_extra_inlists) :: read_extra - character(len=strlen), dimension(max_extra_inlists) :: extra - integer :: unit, i + call store_controls(rq) + end subroutine read_colors_namelist - ierr = 0 - if (level >= 10) then - write (*, *) 'ERROR: too many levels of nested extra controls inlist files' - ierr = -1 - return - end if + subroutine read_colors_file(unit, iostat, iomsg, extra_inlists, extra_inlists_mask) + use const_def, only: strlen, max_extra_inlists - if (len_trim(filename) > 0) then - open (newunit=unit, file=trim(filename), & - action='read', delim='quote', status='old', iostat=ierr) - if (ierr /= 0) then - if (level == 1) then - ierr = 0 ! no inlist file so just use defaults - call store_controls(rq, ierr) - else - write (*, *) 'Failed to open colors namelist file ', trim(filename) - end if - return - end if - read (unit, nml=colors, iostat=ierr) - close (unit) - if (ierr == IOSTAT_END) then ! end-of-file means didn't find an &colors namelist - ierr = 0 - write (*, *) 'WARNING: Failed to find colors namelist in file: ', trim(filename) - call store_controls(rq, ierr) - close (unit) - return - else if (ierr /= 0) then - write (*, *) - write (*, *) - write (*, *) - write (*, *) - write (*, '(a)') 'Failed while trying to read colors namelist file: '//trim(filename) - write (*, '(a)') 'Perhaps the following runtime error message will help you find the problem.' - write (*, *) - open (newunit=unit, file=trim(filename), action='read', & - delim='quote', status='old', iostat=ierr) - read (unit, nml=colors) - close (unit) - return - end if - end if + integer, intent(in) :: unit + integer, intent(out) :: iostat + character(len=strlen), intent(out) :: iomsg + character(len=strlen), dimension(max_extra_inlists), intent(out) :: extra_inlists + logical, dimension(max_extra_inlists), intent(out) :: extra_inlists_mask - call store_controls(rq, ierr) + integer :: i - if (len_trim(filename) == 0) return + read(unit, nml=colors, iostat=iostat, iomsg=iomsg) - ! recursive calls to read other inlists - do i = 1, max_extra_inlists - read_extra(i) = read_extra_colors_inlist(i) - read_extra_colors_inlist(i) = .false. - extra(i) = extra_colors_inlist_name(i) - extra_colors_inlist_name(i) = 'undefined' + if (iostat /= 0) then + return + end if - if (read_extra(i)) then - call read_controls_file(rq, extra(i), level + 1, ierr) - if (ierr /= 0) return - end if + do i=1, max_extra_inlists + extra_inlists(i) = extra_colors_inlist_name(i) + extra_inlists_mask(i) = read_extra_colors_inlist(i) end do - end subroutine read_controls_file + end subroutine read_colors_file subroutine set_default_controls include 'colors.defaults' end subroutine set_default_controls - subroutine store_controls(rq, ierr) + subroutine store_controls(rq) type(Colors_General_Info), pointer, intent(inout) :: rq integer :: i - integer, intent(out) :: ierr rq%instrument = instrument rq%vega_sed = vega_sed @@ -260,9 +217,7 @@ subroutine set_colors_controls(rq, name, val, ierr) read (tmp, nml=colors) ! Add to colors - call store_controls(rq, ierr) - if (ierr /= 0) return - + call store_controls(rq) end subroutine set_colors_controls end module colors_ctrls_io diff --git a/colors/public/colors_lib.f90 b/colors/public/colors_lib.f90 index fbc9566d3..1bf7d7952 100644 --- a/colors/public/colors_lib.f90 +++ b/colors/public/colors_lib.f90 @@ -76,7 +76,7 @@ end function alloc_colors_handle integer function alloc_colors_handle_using_inlist(inlist, ierr) result(handle) use colors_def, only: do_alloc_colors, colors_is_initialized - use colors_ctrls_io, only: read_namelist + use colors_ctrls_io, only: read_colors_namelist character(len=*), intent(in) :: inlist ! empty means just use defaults. integer, intent(out) :: ierr ! 0 means AOK. ierr = 0 @@ -86,7 +86,7 @@ integer function alloc_colors_handle_using_inlist(inlist, ierr) result(handle) end if handle = do_alloc_colors(ierr) if (ierr /= 0) return - call read_namelist(handle, inlist, ierr) + call read_colors_namelist(handle, inlist, ierr) if (ierr /= 0) return call colors_setup_tables(handle, ierr) call colors_setup_hooks(handle, ierr) @@ -308,4 +308,4 @@ real(dp) function get_lum_band_by_id(id, log_Teff, log_g, M_div_h, lum, ierr) get_lum_band_by_id = -99.d0 end function get_lum_band_by_id -end module colors_lib \ No newline at end of file +end module colors_lib diff --git a/eos/private/eos_ctrls_io.f90 b/eos/private/eos_ctrls_io.f90 index 3d8cd4b0a..74a938fc6 100644 --- a/eos/private/eos_ctrls_io.f90 +++ b/eos/private/eos_ctrls_io.f90 @@ -26,7 +26,7 @@ module eos_ctrls_io implicit none - public :: read_namelist, write_namelist, get_eos_controls, set_eos_controls + public :: read_eos_namelist, write_namelist, get_eos_controls, set_eos_controls private ! controls for HELM @@ -263,105 +263,62 @@ module eos_ctrls_io contains - ! read a "namelist" file and set parameters - subroutine read_namelist(handle, inlist, ierr) + subroutine read_eos_namelist(handle, inlist, ierr) + use utils_namelist, only: read_namelist, missing_namelist_warning integer, intent(in) :: handle character (len=*), intent(in) :: inlist integer, intent(out) :: ierr ! 0 means AOK. type (EoS_General_Info), pointer :: rq - include 'formats' + call get_eos_ptr(handle,rq,ierr) + if (ierr /= 0) return + call set_default_controls - call read_controls_file(rq, inlist, 1, ierr) + + if (inlist /= '') then + call read_namelist(inlist, read_eos_file, "eos", ierr, missing_namelist_warning) + end if + if (ierr /= 0) return - rq% Gamma_e_all_HELM = exp10(rq% log_Gamma_e_all_HELM) + + call store_controls(rq) + if (FreeEOS_XZ_struct% Zs(num_FreeEOS_Zs) /= 1d0) then write(*,*) 'ERROR: expect FreeEOS_XZ_struct% Zs(num_FreeEOS_Zs) == 1d0' call mesa_error(__FILE__,__LINE__,'init_eos_handle_data') end if - end subroutine read_namelist + end subroutine read_eos_namelist + subroutine read_eos_file(unit, iostat, iomsg, extra_inlists, extra_inlists_mask) + use const_def, only: strlen, max_extra_inlists - recursive subroutine read_controls_file(rq, filename, level, ierr) - use ISO_FORTRAN_ENV, only: IOSTAT_END - character(*), intent(in) :: filename - type (EoS_General_Info), pointer :: rq - integer, intent(in) :: level - integer, intent(out) :: ierr - logical, dimension(max_extra_inlists) :: read_extra - character (len=strlen), dimension(max_extra_inlists) :: extra - integer :: unit, i + integer, intent(in) :: unit + integer, intent(out) :: iostat + character(len=strlen), intent(out) :: iomsg + character(len=strlen), dimension(max_extra_inlists), intent(out) :: extra_inlists + logical, dimension(max_extra_inlists), intent(out) :: extra_inlists_mask - ierr = 0 - if (level >= 10) then - write(*,*) 'ERROR: too many levels of nested extra controls inlist files' - ierr = -1 - return - end if + integer :: i - if (len_trim(filename) > 0) then - open(newunit=unit, file=trim(filename), & - action='read', delim='quote', status='old', iostat=ierr) - if (ierr /= 0) then - if (level == 1) then - ierr = 0 ! no inlist file so just use defaults - call store_controls(rq) - else - write(*, *) 'Failed to open eos namelist file ', trim(filename) - end if - return - end if - read(unit, nml=eos, iostat=ierr) - close(unit) - if (ierr == IOSTAT_END) then ! end-of-file means didn't find an &eos namelist - ierr = 0 - write(*, *) 'WARNING: Failed to find eos namelist in file: ', trim(filename) - call store_controls(rq) - close(unit) - return - else if (ierr /= 0) then - write(*, *) - write(*, *) - write(*, *) - write(*, *) - write(*, '(a)') 'Failed while trying to read eos namelist file: ' // trim(filename) - write(*, '(a)') 'Perhaps the following runtime error message will help you find the problem.' - write(*, *) - open(newunit=unit, file=trim(filename), action='read', delim='quote', status='old', iostat=ierr) - read(unit, nml=eos) - close(unit) - return - end if - end if - - call store_controls(rq) + read(unit, nml=eos, iostat=iostat, iomsg=iomsg) - if (len_trim(filename) == 0) return + if (iostat /= 0) then + return + end if - ! recursive calls to read other inlists do i=1, max_extra_inlists - read_extra(i) = read_extra_eos_inlist(i) - read_extra_eos_inlist(i) = .false. - extra(i) = extra_eos_inlist_name(i) - extra_eos_inlist_name(i) = 'undefined' - - if (read_extra(i)) then - call read_controls_file(rq, extra(i), level+1, ierr) - if (ierr /= 0) return - end if + extra_inlists(i) = extra_eos_inlist_name(i) + extra_inlists_mask(i) = read_extra_eos_inlist(i) end do - - end subroutine read_controls_file - + end subroutine read_eos_file subroutine set_default_controls include 'eos.defaults' end subroutine set_default_controls - subroutine store_controls(rq) type (EoS_General_Info), pointer :: rq ! controls for HELM @@ -434,6 +391,7 @@ subroutine store_controls(rq) rq% logT1_PC_limit = logT1_PC_limit rq% logT2_PC_limit = logT2_PC_limit rq% log_Gamma_e_all_HELM = log_Gamma_e_all_HELM + rq% Gamma_e_all_HELM = exp10(rq% log_Gamma_e_all_HELM) rq% log_Gamma_e_all_PC = log_Gamma_e_all_PC rq% PC_Gamma_start_crystal = PC_Gamma_start_crystal rq% PC_Gamma_full_crystal = PC_Gamma_full_crystal diff --git a/eos/public/eos_lib.f90 b/eos/public/eos_lib.f90 index a8864acba..a3826af4c 100644 --- a/eos/public/eos_lib.f90 +++ b/eos/public/eos_lib.f90 @@ -57,13 +57,13 @@ end function alloc_eos_handle integer function alloc_eos_handle_using_inlist(inlist,ierr) result(handle) use eos_def, only:do_alloc_eos - use eos_ctrls_io, only:read_namelist + use eos_ctrls_io, only:read_eos_namelist character (len=*), intent(in) :: inlist ! empty means just use defaults. integer, intent(out) :: ierr ! 0 means AOK. ierr = 0 handle = do_alloc_eos(ierr) if (ierr /= 0) return - call read_namelist(handle, inlist, ierr) + call read_eos_namelist(handle, inlist, ierr) end function alloc_eos_handle_using_inlist subroutine free_eos_handle(handle) diff --git a/kap/private/kap_ctrls_io.f90 b/kap/private/kap_ctrls_io.f90 index a3e26e16a..adaeeee31 100644 --- a/kap/private/kap_ctrls_io.f90 +++ b/kap/private/kap_ctrls_io.f90 @@ -25,7 +25,7 @@ module kap_ctrls_io implicit none - public :: read_namelist, write_namelist, get_kap_controls, set_kap_controls + public :: read_kap_namelist, write_namelist, get_kap_controls, set_kap_controls private real(dp) :: Zbase @@ -133,91 +133,51 @@ module kap_ctrls_io ! read a "namelist" file and set parameters - subroutine read_namelist(handle, inlist, ierr) + subroutine read_kap_namelist(handle, inlist, ierr) + use utils_namelist, only: read_namelist, missing_namelist_warning integer, intent(in) :: handle character (len=*), intent(in) :: inlist integer, intent(out) :: ierr ! 0 means AOK. type (Kap_General_Info), pointer :: rq - include 'formats' + call get_kap_ptr(handle,rq,ierr) + if (ierr /= 0) return + call set_default_controls - call read_controls_file(rq, inlist, 1, ierr) + + if (inlist /= '') then + call read_namelist(inlist, read_kap_file, "kap", ierr, missing_namelist_warning) + end if + if (ierr /= 0) return - end subroutine read_namelist + call store_controls(rq, ierr) + end subroutine read_kap_namelist - recursive subroutine read_controls_file(rq, filename, level, ierr) - use ISO_FORTRAN_ENV, only: IOSTAT_END - character(*), intent(in) :: filename - type (Kap_General_Info), pointer :: rq - integer, intent(in) :: level - integer, intent(out) :: ierr - logical, dimension(max_extra_inlists) :: read_extra - character (len=strlen), dimension(max_extra_inlists) :: extra - integer :: unit, i + subroutine read_kap_file(unit, iostat, iomsg, extra_inlists, extra_inlists_mask) + use const_def, only: strlen, max_extra_inlists - ierr = 0 - if (level >= 10) then - write(*,*) 'ERROR: too many levels of nested extra controls inlist files' - ierr = -1 - return - end if + integer, intent(in) :: unit + integer, intent(out) :: iostat + character(len=strlen), intent(out) :: iomsg + character(len=strlen), dimension(max_extra_inlists), intent(out) :: extra_inlists + logical, dimension(max_extra_inlists), intent(out) :: extra_inlists_mask - if (len_trim(filename) > 0) then - open(newunit=unit, file=trim(filename), & - action='read', delim='quote', status='old', iostat=ierr) - if (ierr /= 0) then - if (level == 1) then - ierr = 0 ! no inlist file so just use defaults - call store_controls(rq, ierr) - else - write(*, *) 'Failed to open kap namelist file ', trim(filename) - end if - return - end if - read(unit, nml=kap, iostat=ierr) - close(unit) - if (ierr == IOSTAT_END) then ! end-of-file means didn't find an &kap namelist - ierr = 0 - write(*, *) 'WARNING: Failed to find kap namelist in file: ', trim(filename) - call store_controls(rq, ierr) - close(unit) - return - else if (ierr /= 0) then - write(*, *) - write(*, *) - write(*, *) - write(*, *) - write(*, '(a)') 'Failed while trying to read kap namelist file: ' // trim(filename) - write(*, '(a)') 'Perhaps the following runtime error message will help you find the problem.' - write(*, *) - open(newunit=unit, file=trim(filename), action='read', delim='quote', status='old', iostat=ierr) - read(unit, nml=kap) - close(unit) - return - end if - end if + integer :: i - call store_controls(rq, ierr) + read(unit, nml=kap, iostat=iostat, iomsg=iomsg) - if (len_trim(filename) == 0) return + if (iostat /= 0) then + return + end if - ! recursive calls to read other inlists do i=1, max_extra_inlists - read_extra(i) = read_extra_kap_inlist(i) - read_extra_kap_inlist(i) = .false. - extra(i) = extra_kap_inlist_name(i) - extra_kap_inlist_name(i) = 'undefined' - - if (read_extra(i)) then - call read_controls_file(rq, extra(i), level+1, ierr) - if (ierr /= 0) return - end if + extra_inlists(i) = extra_kap_inlist_name(i) + extra_inlists_mask(i) = read_extra_kap_inlist(i) end do - end subroutine read_controls_file - + end subroutine read_kap_file subroutine set_default_controls include 'kap.defaults' diff --git a/kap/public/kap_lib.f90 b/kap/public/kap_lib.f90 index fa3403a20..d5549eca2 100644 --- a/kap/public/kap_lib.f90 +++ b/kap/public/kap_lib.f90 @@ -79,7 +79,7 @@ end function alloc_kap_handle integer function alloc_kap_handle_using_inlist(inlist,ierr) result(handle) use kap_def, only:do_alloc_kap,kap_is_initialized - use kap_ctrls_io, only:read_namelist + use kap_ctrls_io, only:read_kap_namelist character (len=*), intent(in) :: inlist ! empty means just use defaults. integer, intent(out) :: ierr ! 0 means AOK. ierr = 0 @@ -89,7 +89,7 @@ integer function alloc_kap_handle_using_inlist(inlist,ierr) result(handle) end if handle = do_alloc_kap(ierr) if (ierr /= 0) return - call read_namelist(handle, inlist, ierr) + call read_kap_namelist(handle, inlist, ierr) if (ierr /= 0) return call kap_setup_tables(handle, ierr) call kap_setup_hooks(handle, ierr) diff --git a/star/job/run_star_support.f90 b/star/job/run_star_support.f90 index f0870d79f..08dab7ce6 100644 --- a/star/job/run_star_support.f90 +++ b/star/job/run_star_support.f90 @@ -1746,8 +1746,7 @@ subroutine create_merger_model(s, ierr) if (failed('set_star_kap_and_eos_handles',ierr)) return call star_set_colors_handles(id_aux, ierr) if (failed('star_set_colors_handles',ierr)) return - call store_controls(s_aux, ierr) - if (failed('store_controls',ierr)) return + call store_controls(s_aux) call do_star_job_controls_before(id_aux, s_aux, .false., ierr) if (ierr /= 0) return call star_read_model(id_aux, s% job% saved_model_for_merger_2, ierr) diff --git a/star/private/ctrls_io.f90 b/star/private/ctrls_io.f90 index f9cae2aaa..401e9b878 100644 --- a/star/private/ctrls_io.f90 +++ b/star/private/ctrls_io.f90 @@ -614,18 +614,20 @@ end subroutine do_one_setup subroutine read_controls(id, filename, ierr) + use utils_namelist, only: read_namelist, missing_namelist_error use star_private_def - use utils_lib character(*), intent(in) :: filename integer, intent(in) :: id integer, intent(out) :: ierr type (star_info), pointer :: s - ierr = 0 call get_star_ptr(id, s, ierr) if (ierr /= 0) return - call read_controls_file(s, filename, 1, ierr) + call read_namelist(filename, read_controls_file, "controls", ierr, missing_namelist_error) + if (ierr /= 0) return + + call store_controls(s) call check_controls(s, ierr) end subroutine read_controls @@ -649,68 +651,30 @@ subroutine check_controls(s, ierr) end subroutine check_controls - recursive subroutine read_controls_file(s, filename, level, ierr) - use star_private_def - use utils_lib - character(*), intent(in) :: filename - type (star_info), pointer :: s - integer, intent(in) :: level - integer, intent(out) :: ierr - logical, dimension(max_extra_inlists) :: read_extra - character (len=strlen), dimension(max_extra_inlists) :: extra - integer :: unit, i - - ierr = 0 - - if (level >= 10) then - write(*,*) 'ERROR: too many levels of nested extra controls inlist files' - ierr = -1 - return - end if + subroutine read_controls_file(unit, iostat, iomsg, extra_inlists, extra_inlists_mask) + use const_def, only: strlen, max_extra_inlists - if (len_trim(filename) > 0) then - open(newunit=unit, file=trim(filename), action='read', delim='quote', status='old', iostat=ierr) - if (ierr /= 0) then - write(*, *) 'Failed to open control namelist file ', trim(filename) - return - end if - read(unit, nml=controls, iostat=ierr) - close(unit) - if (ierr /= 0) then - write(*, *) - write(*, *) - write(*, *) - write(*, *) - write(*, '(a)') 'Failed while trying to read control namelist file: ' // trim(filename) - write(*, '(a)') 'Perhaps the following runtime error message will help you find the problem.' - write(*, *) - open(newunit=unit, file=trim(filename), action='read', delim='quote', status='old', iostat=ierr) - read(unit, nml=controls) - close(unit) - return - end if - end if + integer, intent(in) :: unit + integer, intent(out) :: iostat + character(len=strlen), intent(out) :: iomsg + character(len=strlen), dimension(max_extra_inlists), intent(out) :: extra_inlists + logical, dimension(max_extra_inlists), intent(out) :: extra_inlists_mask - call store_controls(s, ierr) + integer :: i - ! recursive calls to read other inlists - do i=1, max_extra_inlists - read_extra(i) = read_extra_controls_inlist(i) - read_extra_controls_inlist(i) = .false. - extra(i) = extra_controls_inlist_name(i) - extra_controls_inlist_name(i) = 'undefined' + read(unit, nml=controls, iostat=iostat, iomsg=iomsg) - if (read_extra(i)) then - write(*,*) 'read ' // trim(extra(i)) - call read_controls_file(s, extra(i), level+1, ierr) - if (ierr /= 0) return + if (iostat /= 0) then + return end if - end do + do i=1, max_extra_inlists + extra_inlists(i) = extra_controls_inlist_name(i) + extra_inlists_mask(i) = read_extra_controls_inlist(i) + end do end subroutine read_controls_file - subroutine set_default_controls xa_central_lower_limit_species(:) = '' @@ -764,14 +728,9 @@ subroutine set_default_controls end subroutine set_default_controls - subroutine store_controls(s, ierr) + subroutine store_controls(s) use star_private_def - use chem_def ! categories - use utils_lib, only: mkdir type (star_info), pointer :: s - integer, intent(out) :: ierr - - ierr = 0 ! where to start s% initial_mass = initial_mass @@ -4264,7 +4223,7 @@ subroutine set_control(s, name, val, ierr) read(tmp, nml=controls) ! Add to star - call store_controls(s, ierr) + call store_controls(s) if(ierr/=0) return end subroutine set_control diff --git a/star/private/pgstar_ctrls_io.f90 b/star/private/pgstar_ctrls_io.f90 index dcf53870f..62c316fda 100644 --- a/star/private/pgstar_ctrls_io.f90 +++ b/star/private/pgstar_ctrls_io.f90 @@ -3060,87 +3060,45 @@ module pgstar_ctrls_io contains subroutine read_pgstar(s, filename, ierr) - use star_private_def - use utils_lib + use utils_namelist, only: read_namelist, missing_namelist_warning + use star_private_def, only: star_info type (star_info), pointer :: s character(*), intent(in) :: filename integer, intent(out) :: ierr - character (len=strlen) :: pgstar_namelist_name - pgstar_namelist_name = '' - ierr = 0 + call set_default_pgstar_controls - call read_pgstar_file(s, filename, 1, ierr) + call read_namelist(filename, read_pgstar_file, "pgstar", ierr, missing_namelist_warning) + if (ierr /= 0) return + call store_pgstar_controls(s) end subroutine read_pgstar + subroutine read_pgstar_file(unit, iostat, iomsg, extra_inlists, extra_inlists_mask) + use const_def, only: strlen, max_extra_inlists - recursive subroutine read_pgstar_file(s, filename, level, ierr) - use star_private_def - use utils_lib - character(*), intent(in) :: filename - type (star_info), pointer :: s - integer, intent(in) :: level - integer, intent(out) :: ierr - logical, dimension(max_extra_inlists) :: read_extra - character (len=strlen), dimension(max_extra_inlists) :: extra - integer :: unit, i + integer, intent(in) :: unit + integer, intent(out) :: iostat + character(len=strlen), intent(out) :: iomsg + character(len=strlen), dimension(max_extra_inlists), intent(out) :: extra_inlists + logical, dimension(max_extra_inlists), intent(out) :: extra_inlists_mask - ierr = 0 + integer :: i - if (level >= 10) then - write(*,*) 'ERROR: too many levels of nested extra pgstar inlist files' - ierr = -1 - return - end if + read(unit, nml=pgstar, iostat=iostat, iomsg=iomsg) - if (len_trim(filename) > 0) then - open(newunit=unit, file=trim(filename), action='read', delim='quote', status='old', iostat=ierr) - if (ierr /= 0) then - write(*, *) 'Failed to open pgstar namelist file ', trim(filename) - return - end if - read(unit, nml=pgstar, iostat=ierr) - close(unit) - if (ierr /= 0) then - write(*, *) - write(*, *) - write(*, *) - write(*, *) - write(*, '(a)') & - 'Failed while trying to read pgstar namelist file: ' // trim(filename) - write(*, '(a)') & - 'Perhaps the following runtime error message will help you find the problem.' - write(*, *) - open(newunit=unit, file=trim(filename), action='read', delim='quote', status='old', iostat=ierr) - read(unit, nml=pgstar) - close(unit) - return - end if + if (iostat /= 0) then + return end if - call store_pgstar_controls(s, ierr) - - ! recursive calls to read other inlists do i=1, max_extra_inlists - read_extra(i) = read_extra_pgstar_inlist(i) - read_extra_pgstar_inlist(i) = .false. - extra(i) = extra_pgstar_inlist_name(i) - extra_pgstar_inlist_name(i) = 'undefined' - - if (read_extra(i)) then - call read_pgstar_file(s, extra(i), level+1, ierr) - if (ierr /= 0) return - end if + extra_inlists(i) = extra_pgstar_inlist_name(i) + extra_inlists_mask(i) = read_extra_pgstar_inlist(i) end do end subroutine read_pgstar_file - - subroutine store_pgstar_controls(s, ierr) - use star_private_def + subroutine store_pgstar_controls(s) + use star_private_def, only: star_info type (star_info), pointer :: s - integer, intent(out) :: ierr - - ierr = 0 s% pg% file_device = file_device s% pg% file_digits = file_digits diff --git a/star/private/star_job_ctrls_io.f90 b/star/private/star_job_ctrls_io.f90 index abe42c887..525578cf5 100644 --- a/star/private/star_job_ctrls_io.f90 +++ b/star/private/star_job_ctrls_io.f90 @@ -533,89 +533,47 @@ module star_job_ctrls_io subroutine do_read_star_job(s, filename, ierr) + use utils_namelist, only: read_namelist, missing_namelist_error use star_private_def - use utils_lib type (star_info), pointer :: s character(*), intent(in) :: filename integer, intent(out) :: ierr - character (len=strlen) :: star_job_namelist_name - star_job_namelist_name = '' - ierr = 0 + call set_default_star_job_controls - call read_star_job_file(s, filename, 1, ierr) + call read_namelist(filename, read_star_job_file, "star_job", ierr, missing_namelist_error) + + if (ierr /= 0) return + call store_star_job_controls(s) call check_star_job_controls(s, ierr) end subroutine do_read_star_job + subroutine read_star_job_file(unit, iostat, iomsg, extra_inlists, extra_inlists_mask) + use const_def, only: strlen, max_extra_inlists - recursive subroutine read_star_job_file(s, filename, level, ierr) - use star_private_def - use utils_lib - character(*), intent(in) :: filename - type (star_info), pointer :: s - integer, intent(in) :: level - integer, intent(out) :: ierr - logical, dimension(max_extra_inlists) :: read_extra - character (len=strlen), dimension(max_extra_inlists) :: extra - integer :: unit, i + integer, intent(in) :: unit + integer, intent(out) :: iostat + character(len=strlen), intent(out) :: iomsg + character(len=strlen), dimension(max_extra_inlists), intent(out) :: extra_inlists + logical, dimension(max_extra_inlists), intent(out) :: extra_inlists_mask - ierr = 0 + integer :: i - if (level >= 10) then - write(*,*) 'ERROR: too many levels of nested extra star_job inlist files' - ierr = -1 - return - end if + read(unit, nml=star_job, iostat=iostat, iomsg=iomsg) - if (len_trim(filename) > 0) then - open(newunit=unit, file=trim(filename), action='read', delim='quote', status='old', iostat=ierr) - if (ierr /= 0) then - write(*, *) 'Failed to open control namelist file "'//trim(filename)//'"' - return - end if - read(unit, nml=star_job, iostat=ierr) - close(unit) - if (ierr /= 0) then - write(*, *) - write(*, *) - write(*, *) - write(*, *) - write(*, '(a)') & - 'Failed while trying to read control namelist file: ' // trim(filename) - write(*, '(a)') & - 'Perhaps the following runtime error message will help you find the problem.' - write(*, *) - open(newunit=unit, file=trim(filename), action='read', delim='quote', status='old', iostat=ierr) - read(unit, nml=star_job) - close(unit) - return - end if + if (iostat /= 0) then + return end if - call store_star_job_controls(s, ierr) - - ! recursive calls to read other inlists do i=1, max_extra_inlists - read_extra(i) = read_extra_star_job_inlist(i) - read_extra_star_job_inlist(i) = .false. - extra(i) = extra_star_job_inlist_name(i) - extra_star_job_inlist_name(i) = 'undefined' - - if (read_extra(i)) then - call read_star_job_file(s, extra(i), level+1, ierr) - if (ierr /= 0) return - end if + extra_inlists(i) = extra_star_job_inlist_name(i) + extra_inlists_mask(i) = read_extra_star_job_inlist(i) end do - end subroutine read_star_job_file - - subroutine store_star_job_controls(s, ierr) + subroutine store_star_job_controls(s) use star_private_def type (star_info), pointer :: s - integer, intent(out) :: ierr - - ierr = 0 s% job% mesa_dir = mesa_dir s% job% eosDT_cache_dir = eosDT_cache_dir @@ -1754,7 +1712,7 @@ subroutine set_star_job(s, name, val, ierr) read(tmp, nml=star_job) ! Add to star - call store_star_job_controls(s, ierr) + call store_star_job_controls(s) if(ierr/=0) return end subroutine set_star_job diff --git a/utils/Makefile b/utils/Makefile index 23312d61b..44b4a0bb1 100644 --- a/utils/Makefile +++ b/utils/Makefile @@ -12,7 +12,8 @@ SRCS := public/utils_def.f90 \ private/utils_nan.f90 \ private/utils_nan_qp.f90 \ private/utils_nan_sp.f90 \ - private/utils_system.f90 + private/utils_system.f90 \ + private/namelist.f90 \ ifeq ($(WITH_OPENMP),yes) SRCS += private/utils_openmp.f90 @@ -31,7 +32,7 @@ CHECK_RESULTS_GOLDEN := test/test_output # Install -MODULES := utils_def.mod utils_lib.mod +MODULES := utils_def.mod utils_lib.mod utils_namelist.mod INSTALL_INCLUDES := formats include $(MAKE_DIR)/Makefile diff --git a/utils/private/namelist.f90 b/utils/private/namelist.f90 new file mode 100644 index 000000000..49fbbe130 --- /dev/null +++ b/utils/private/namelist.f90 @@ -0,0 +1,138 @@ +! *********************************************************************** +! +! Copyright (C) 2026 The MESA Team +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU Lesser 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 Lesser General Public License for more details. +! +! You should have received a copy of the GNU Lesser General Public License +! along with this program. If not, see . +! +! *********************************************************************** + +!> Reading nested namelists +module utils_namelist + implicit none + private + + integer, parameter :: max_nested_inlists = 10 + + abstract interface + !> Read a single inlist + !> + !> Implementations of this interface should only read one namelist (with the unit, iostat, and iomsg passed to read) and + !> optionally set the extra_inlists and extra_inlists_mask arguments. Each element of extra_inlists for which + !> extra_inlists_mask is set to true will also be read in by read_namelist. If there is no need to read in extra inlists, + !> just set all elements of extra_inlists_mask to false. + subroutine reader(unit, iostat, iomsg, extra_inlists, extra_inlists_mask) + use const_def, only: max_extra_inlists, strlen + implicit none + integer, intent(in) :: unit + integer, intent(out) :: iostat + character(len=strlen), intent(out) :: iomsg + character(len=strlen), dimension(max_extra_inlists), intent(out) :: extra_inlists + logical, dimension(max_extra_inlists), intent(out) :: extra_inlists_mask + end subroutine reader + end interface + + type missing_namelist + integer, private :: action + end type missing_namelist + + type(missing_namelist), public, parameter :: missing_namelist_error = missing_namelist(0) + type(missing_namelist), public, parameter :: missing_namelist_warning = missing_namelist(1) + type(missing_namelist), public, parameter :: missing_namelist_silent = missing_namelist(2) + + public :: read_namelist, missing_namelist, reader + + contains + !> Read a nested set of namelists starting from a single file. + !> + !> This also handles error reporting to the user. Missing namelist + !> entries are handled based on the value of the `missing` argument. + subroutine read_namelist(file, r, namelist_name, ierr, missing) + character(len=*), intent(in) :: file + procedure(reader) :: r + character(len=*), intent(in) :: namelist_name + integer, intent(out) :: ierr + type(missing_namelist), intent(in) :: missing + + call read_one_namelist(file, r, namelist_name, 1, ierr, missing) + end subroutine read_namelist + + recursive subroutine read_one_namelist(file, r, namelist_name, level, ierr, missing) + use const_def, only: strlen, max_extra_inlists + + character(len=*), intent(in) :: file + procedure(reader) :: r + character(len=*), intent(in) :: namelist_name + integer, intent(in) :: level + integer, intent(out) :: ierr + type(missing_namelist), intent(in) :: missing + + integer :: iostat, unit, i + character(len=strlen) :: iomsg + character(len=strlen), dimension(max_extra_inlists) :: extra_inlists + logical, dimension(max_extra_inlists) :: extra_inlists_mask + + if (level >= max_nested_inlists) then + write(*, *) '[ERROR]: too many levels of nested ', namelist_name, ' inlist files' + ierr = -1 + return + end if + + open(newunit = unit, file = trim(file), action = 'read', & + delim = 'quote', status = 'old', iostat = iostat, iomsg = iomsg) + + if (iostat /= 0) then + write(*, *) '[ERROR]: Failed to open ', namelist_name, & + ' namelist file "', trim(file), '". Error message: "', trim(iomsg), '"' + ierr = -1 + return + end if + + call r(unit, iostat, iomsg, extra_inlists, extra_inlists_mask) + + close(unit) + + if (iostat /= 0) then + if (is_iostat_end(iostat)) then + select case(missing%action) + case(missing_namelist_error%action) + write(*, *) '[ERROR]: Failed to read ', namelist_name, & + ' namelist from "', trim(file), '". Namelist ', namelist_name, ' is not found' + ierr = -1 + case(missing_namelist_warning%action) + write(*, *) '[WARNING]: Failed to read ', namelist_name, & + ' namelist from "', trim(file), '". Namelist ', namelist_name, ' is not found' + case(missing_namelist_silent%action) + ! Do nothing + end select + extra_inlists_mask(:) = .false. + else + write(*, *) '[ERROR]: Failed to read ', namelist_name, & + ' namelist from "', trim(file), '". Error message: "', trim(iomsg), '"' + ierr = -1 + end if + return + end if + + do i=1, max_extra_inlists + if (extra_inlists_mask(i) .and. len_trim(extra_inlists(i)) /= 0) then + call read_one_namelist(extra_inlists(i), r, namelist_name, level + 1, ierr, missing) + + if (ierr /= 0) then + return + end if + end if + end do + + end subroutine read_one_namelist +end module utils_namelist