From 75f7a208e5489edb441bc5d0bec1910f17d14dd3 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 | 139 +++++++----------------- binary/private/binary_ctrls_io.f90 | 82 ++++---------- binary/private/binary_job_ctrls_io.f90 | 86 +++++---------- binary/private/pgbinary_ctrls_io.f90 | 92 +++++----------- colors/private/colors_ctrls_io.f90 | 110 ++++++------------- colors/public/colors_lib.f90 | 4 +- const/public/const_def.f90 | 2 - eos/private/eos_ctrls_io.f90 | 108 ++++++------------ eos/public/eos_lib.f90 | 4 +- kap/private/kap_ctrls_io.f90 | 102 ++++++----------- kap/public/kap_lib.f90 | 4 +- star/job/run_star_support.f90 | 3 +- star/private/ctrls_io.f90 | 86 ++++----------- star/private/pgstar_ctrls_io.f90 | 87 ++++----------- star/private/star_job_ctrls_io.f90 | 87 ++++----------- star_data/public/star_data_def.f90 | 3 +- star_data/public/star_pgstar.f90 | 3 +- utils/Makefile | 5 +- utils/public/namelist.f90 | 145 +++++++++++++++++++++++++ 19 files changed, 450 insertions(+), 702 deletions(-) create mode 100644 utils/public/namelist.f90 diff --git a/astero/public/astero_def.f90 b/astero/public/astero_def.f90 index 5bc12e04a6..ee67fd7b5e 100644 --- a/astero/public/astero_def.f90 +++ b/astero/public/astero_def.f90 @@ -839,73 +839,42 @@ 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) + + call read_namelist(filename, read_astero_search_file, "astero_search_controls", ierr, missing_namelist_error) end subroutine read_astero_search_controls + subroutine read_astero_search_file(unit, iostat, iomsg, extra_inlists, extra_inlists_mask) + use const_def, only: strlen + use utils_namelist, only: max_extra_inlists - recursive subroutine read1_astero_search_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) :: message - 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_extra_astero_search_inlist(:) = .false. - 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 +907,43 @@ 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 + use utils_namelist, only: 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_extra_astero_pgstar_inlist(:) = .false. - ierr = 0 - unit=alloc_iounit(ierr) - if (ierr /= 0) return + read(unit, nml=astero_pgstar_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 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 c63ff7080e..449db506d8 100644 --- a/binary/private/binary_ctrls_io.f90 +++ b/binary/private/binary_ctrls_io.f90 @@ -259,88 +259,54 @@ 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 + use utils_namelist, only: 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_extra_binary_controls_inlist(:) = .false. - 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 - end if + read(unit, nml=binary_controls, iostat=iostat, iomsg=iomsg) - call store_binary_controls(b, ierr) + if (iostat /= 0) then + return + end if - ! 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 +778,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 381c9c1cb3..b26452680a 100644 --- a/binary/private/binary_job_ctrls_io.f90 +++ b/binary/private/binary_job_ctrls_io.f90 @@ -69,84 +69,48 @@ 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 + use utils_namelist, only: 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_extra_binary_job_inlist(:) = .false. - 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 - end if + read(unit, nml=binary_job, iostat=iostat, iomsg=iomsg) - call store_binary_job_controls(b, ierr) + if (iostat /= 0) then + return + end if - ! 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 +285,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 b1dfec26c4..377a6faf51 100644 --- a/binary/private/pgbinary_ctrls_io.f90 +++ b/binary/private/pgbinary_ctrls_io.f90 @@ -1365,85 +1365,53 @@ 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 + use utils_namelist, only: 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 - 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 + read_extra_pgbinary_inlist(:) = .false. - call store_pgbinary_controls(b, ierr) + read(unit, nml=pgbinary, iostat=iostat, iomsg=iomsg) - ! 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 (iostat /= 0) then + return + end if - 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 d1e2f1bd91..93c3235dd6 100644 --- a/colors/private/colors_ctrls_io.f90 +++ b/colors/private/colors_ctrls_io.f90 @@ -19,12 +19,13 @@ module colors_ctrls_io - use const_def, only: dp, strlen, max_extra_inlists + use const_def, only: dp, strlen + use utils_namelist, only: max_extra_inlists use colors_def, only: Colors_General_Info, get_colors_ptr 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 @@ -59,100 +60,59 @@ module colors_ctrls_io contains - 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 + use utils_namelist, only: 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_extra_colors_inlist(:) = .false. - ! 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' + read(unit, nml=colors, iostat=iostat, iomsg=iomsg) - if (read_extra(i)) then - call read_controls_file(rq, extra(i), level + 1, ierr) - if (ierr /= 0) return - end if + if (iostat /= 0) then + 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, intent(out) :: ierr - rq%instrument = instrument rq%vega_sed = vega_sed rq%stellar_atm = stellar_atm @@ -263,9 +223,7 @@ subroutine set_colors_controls(rq, name, val, ierr) read (tmp, nml=colors) - call store_controls(rq, ierr) - if (ierr /= 0) return - + call store_controls(rq) end subroutine set_colors_controls -end module colors_ctrls_io \ No newline at end of file +end module colors_ctrls_io diff --git a/colors/public/colors_lib.f90 b/colors/public/colors_lib.f90 index b245dc5677..a77cb899b8 100644 --- a/colors/public/colors_lib.f90 +++ b/colors/public/colors_lib.f90 @@ -78,7 +78,7 @@ end function alloc_colors_handle integer function alloc_colors_handle_using_inlist(inlist, ierr) result(handle) use colors_def, only: Colors_General_Info, do_alloc_colors, colors_is_initialized, get_colors_ptr - 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. type(Colors_General_Info), pointer :: rq @@ -90,7 +90,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 get_colors_ptr(handle, rq, ierr) if (ierr /= 0) return diff --git a/const/public/const_def.f90 b/const/public/const_def.f90 index e1425ebb83..f5cff50c48 100644 --- a/const/public/const_def.f90 +++ b/const/public/const_def.f90 @@ -36,8 +36,6 @@ module const_def integer, parameter :: strlen = 256 ! for character (len=strlen) - integer, parameter :: max_extra_inlists = 5 ! number of inlists an inlist can depend on - ! ! mathematical and physical constants (in cgs) ! diff --git a/eos/private/eos_ctrls_io.f90 b/eos/private/eos_ctrls_io.f90 index 3d8cd4b0ac..c57a244c7a 100644 --- a/eos/private/eos_ctrls_io.f90 +++ b/eos/private/eos_ctrls_io.f90 @@ -19,14 +19,15 @@ module eos_ctrls_io - use const_def, only: dp, max_extra_inlists + use const_def, only: dp + use utils_namelist, only: max_extra_inlists use eos_def use math_lib use utils_lib, only: mesa_error 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 +264,65 @@ 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 + use utils_namelist, only: 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 + read_extra_eos_inlist(:) = .false. - 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 +395,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 a8864acbac..a3826af4cb 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 a3e26e16a9..811ba6b417 100644 --- a/kap/private/kap_ctrls_io.f90 +++ b/kap/private/kap_ctrls_io.f90 @@ -19,13 +19,14 @@ module kap_ctrls_io - use const_def, only: dp, max_extra_inlists + use const_def, only: dp + use utils_namelist, only: max_extra_inlists use kap_def use math_lib 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 +134,54 @@ 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 + use utils_namelist, only: 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_extra_kap_inlist(:) = .false. + + 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 fa3403a209..d5549eca21 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 fc4264ba2d..1627a44e9b 100644 --- a/star/job/run_star_support.f90 +++ b/star/job/run_star_support.f90 @@ -1718,8 +1718,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 7b6cbff920..5f7e48786e 100644 --- a/star/private/ctrls_io.f90 +++ b/star/private/ctrls_io.f90 @@ -616,18 +616,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 @@ -651,68 +653,33 @@ 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 + subroutine read_controls_file(unit, iostat, iomsg, extra_inlists, extra_inlists_mask) + use const_def, only: strlen + use utils_namelist, only: max_extra_inlists - ierr = 0 + 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 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 - 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 + read_extra_controls_inlist(:) = .false. - call store_controls(s, ierr) + read(unit, nml=controls, iostat=iostat, iomsg=iomsg) - ! 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' - - 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(:) = '' @@ -766,14 +733,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 @@ -4272,7 +4234,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 dcf53870fd..3899a6bf01 100644 --- a/star/private/pgstar_ctrls_io.f90 +++ b/star/private/pgstar_ctrls_io.f90 @@ -3060,87 +3060,48 @@ 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 + use utils_namelist, only: 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_extra_pgstar_inlist(:) = .false. - 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 - end if + read(unit, nml=pgstar, iostat=iostat, iomsg=iomsg) - call store_pgstar_controls(s, ierr) + if (iostat /= 0) then + return + end if - ! 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 ec40d29f5a..a95c209178 100644 --- a/star/private/star_job_ctrls_io.f90 +++ b/star/private/star_job_ctrls_io.f90 @@ -525,89 +525,50 @@ 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 + use utils_namelist, only: 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_extra_star_job_inlist(:) = .false. - 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 - end if + read(unit, nml=star_job, iostat=iostat, iomsg=iomsg) - call store_star_job_controls(s, ierr) + if (iostat /= 0) then + return + end if - ! 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 @@ -1730,7 +1691,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/star_data/public/star_data_def.f90 b/star_data/public/star_data_def.f90 index 6a8ee0ae51..04d10feb6d 100644 --- a/star_data/public/star_data_def.f90 +++ b/star_data/public/star_data_def.f90 @@ -21,8 +21,9 @@ module star_data_def use rates_def, only: rates_reaction_id_max, other_screening_interface, other_rate_get_interface use utils_def, only: integer_dict + use utils_namelist, only: max_extra_inlists use chem_def, only: num_categories, iso_name_length - use const_def, only: sp, dp, qp, i8, strlen, max_extra_inlists + use const_def, only: sp, dp, qp, i8, strlen use rates_def, only: maxlen_reaction_Name use eos_def, only: EoS_General_Info use kap_def, only: Kap_General_Info diff --git a/star_data/public/star_pgstar.f90 b/star_data/public/star_pgstar.f90 index a1b7197a0e..542c1b5540 100644 --- a/star_data/public/star_pgstar.f90 +++ b/star_data/public/star_pgstar.f90 @@ -19,7 +19,8 @@ module star_pgstar - use const_def, only: dp, strlen, max_extra_inlists + use const_def, only: dp, strlen + use utils_namelist, only: max_extra_inlists use chem_def, only: iso_name_length implicit none diff --git a/utils/Makefile b/utils/Makefile index 23312d61b6..fc4ecc1ebe 100644 --- a/utils/Makefile +++ b/utils/Makefile @@ -5,6 +5,7 @@ include ../make/defaults-module.mk MODULE_NAME := utils SRCS := public/utils_def.f90 \ public/utils_lib.f90 \ + public/namelist.f90 \ private/utils_c_system.c \ private/utils_dict.f90 \ private/utils_idict.f90 \ @@ -12,7 +13,7 @@ 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 \ 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/public/namelist.f90 b/utils/public/namelist.f90 new file mode 100644 index 0000000000..90a6dc8468 --- /dev/null +++ b/utils/public/namelist.f90 @@ -0,0 +1,145 @@ +! *********************************************************************** +! +! 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 + integer, parameter :: max_extra_inlists = 5 + + 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: strlen + import max_extra_inlists + 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, max_extra_inlists + + 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 + + if (len_trim(file) == 0) then + ierr = 0 + return + end if + + 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 + + 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