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