module athena__tools_infile !! Module containing custom input file reading functions and subroutines !! !! This module contains custom input file reading functions and subroutines !! for reading and assigning values from a file. !! Code copied from ARTEMIS with permission of the authors !! Ned Thaddeus Taylor and Francis Huw Davies !! https://github.com/ExeQuantCode/ARTEMIS use coreutils, only: real32, grep, icount, stop_program implicit none private public :: get_val public :: assign_val, assign_vec, allocate_and_assign_vec public :: getline, rm_comments public :: stop_check public :: move interface assign_val !! Interface for assigning a value to a variable procedure assignI, assignR, assignS, assignL end interface assign_val interface assign_vec !! Interface for assigning a vector to a variable procedure assignIvec, assignRvec end interface assign_vec interface allocate_and_assign_vec !! Interface for allocating and assigning a vector to a variable procedure allocate_and_assignRvec end interface allocate_and_assign_vec contains !############################################################################### function get_val(buffer, fs) result(output) !! Extract the section of buffer that occurs after the field separator fs implicit none ! Arguments character(*), intent(in) :: buffer !! Input buffer character(1), intent(in), optional :: fs !! Field separator ! Local variables character(:), allocatable :: output !! Extracted value character(1) :: fs_ !! Field separator fs_ = '=' if(present(fs)) fs_ = fs output = trim(adjustl(buffer((scan(buffer, fs_) + 1):))) end function get_val !############################################################################### !############################################################################### subroutine getline(unit, pattern, buffer) !! Get the line from a grep and assign it to buffer implicit none ! Arguments integer, intent(in) :: unit !! Unit to read from character(*), intent(in) :: pattern !! Pattern to grep for character(*), intent(out) :: buffer !! Buffer to assign line to ! Local variables integer :: iostat !! I/O status call grep(unit, pattern) backspace(unit) read(unit, '(A)', iostat=iostat) buffer end subroutine getline !############################################################################### !############################################################################### subroutine assignI(buffer, variable, found, keyword, fs) !! Assign an integer to variable implicit none ! Arguments character(*), intent(inout) :: buffer !! Input buffer integer, intent(out) :: variable !! Variable to assign data to integer, intent(inout) :: found !! Count for finding variable character(*), optional, intent(in) :: keyword !! Keyword to start from character(1), optional, intent(in) :: fs !! Field separator ! Local variables character(1024) :: buffer2 !! Temporary buffer character(1) :: fs_ !! Field separator fs_ = '=' if(present(fs)) fs_ = fs if(present(keyword)) buffer = buffer(index(buffer, keyword):) if(scan(buffer, fs_) .ne. 0) buffer2 = get_val(buffer, fs_) if(trim(adjustl(buffer2)) .ne. '')then found = found + 1 read(buffer2, *) variable end if end subroutine assignI !############################################################################### !############################################################################### subroutine assignIvec(buffer, variable, found, keyword, fs) !! Assign an arbitrary length vector of integers to variable implicit none ! Arguments character(*), intent(inout) :: buffer !! Input buffer integer, dimension(:), intent(out) :: variable !! Variable to assign data to integer, intent(inout) :: found !! Count for finding variable character(*), optional, intent(in) :: keyword !! Keyword to start from character(1), optional, intent(in) :: fs !! Field separator ! Local variables integer :: i !! Loop index character(1024) :: buffer2 !! Temporary buffer character(1) :: fs_ !! Field separator fs_ = '=' if(present(fs)) fs_ = fs if(present(keyword)) buffer = buffer(index(buffer, keyword):) if(scan(buffer, fs_) .ne. 0) buffer2 = get_val(buffer, fs_) if(trim(adjustl(buffer2)) .ne. '')then found = found + 1 if(icount(buffer2) .eq. 1 .and. icount(buffer2) .ne. size(variable))then read(buffer2, *) variable(1) variable = variable(1) else read(buffer2, *) (variable(i), i = 1, size(variable)) end if end if end subroutine assignIvec !############################################################################### !############################################################################### subroutine assignR(buffer, variable, found, keyword, fs) !! Assign a real to variable implicit none ! Arguments character(*), intent(inout) :: buffer !! Input buffer real(real32), intent(out) :: variable !! Variable to assign data to integer, intent(inout) :: found !! Count for finding variable character(*), optional, intent(in) :: keyword !! Keyword to start from character(1), optional, intent(in) :: fs !! Field separator ! Local variables character(1024) :: buffer2 !! Temporary buffer character(1) :: fs_ !! Field separator fs_ = '=' if(present(fs)) fs_ = fs if(present(keyword)) buffer = buffer(index(buffer, keyword):) if(scan(buffer, fs_) .ne. 0) buffer2 = get_val(buffer, fs_) if(trim(adjustl(buffer2)) .ne. '')then found = found + 1 read(buffer2, *) variable end if end subroutine assignR !############################################################################### !############################################################################### subroutine assignRvec(buffer, variable, found, keyword, fs) !! Assign an arbitrary length vector of reals to variable implicit none ! Arguments character(*), intent(inout) :: buffer !! Input buffer real(real32), dimension(:), intent(out) :: variable !! Variable to assign data to integer, intent(inout) :: found !! Count for finding variable character(*), optional, intent(in) :: keyword !! Keyword to start from character(1), optional, intent(in) :: fs !! Field separator ! Local variables integer :: i !! Loop index character(1024) :: buffer2 !! Temporary buffer character(1) :: fs_ !! Field separator fs_ = '=' if(present(fs)) fs_ = fs if(present(keyword)) buffer = buffer(index(buffer, keyword):) if(scan(buffer, fs_) .ne. 0) buffer2 = get_val(buffer, fs_) if(trim(adjustl(buffer2)) .ne. '')then found = found + 1 if(icount(buffer2) .eq. 1 .and. icount(buffer2) .ne. size(variable))then read(buffer2, *) variable(1) variable = variable(1) else read(buffer2, *) (variable(i), i = 1, size(variable)) end if end if end subroutine assignRvec !############################################################################### !############################################################################### subroutine allocate_and_assignRvec(buffer, variable, keyword, fs) !! Allocate and assign an arbitrary length vector of reals to variable implicit none ! Arguments character(*), intent(inout) :: buffer !! Input buffer real(real32), dimension(:), allocatable, intent(out) :: variable !! Variable to assign data to character(*), optional, intent(in) :: keyword !! Keyword to start from character(1), optional, intent(in) :: fs !! Field separator ! Local variables integer :: i !! Number of values and loop index character(1024) :: buffer2 !! Temporary buffer character(1) :: fs_ !! Field separator character(1), parameter :: open_brackets(3) = ['[', '(', '{'] character(1), parameter :: close_brackets(3) = [']', ')', '}'] fs_ = '=' if(present(fs)) fs_ = fs if(present(keyword)) buffer = buffer(index(buffer, keyword):) if(scan(buffer, fs_) .ne. 0)then buffer2 = get_val(buffer, fs_) else buffer2 = buffer end if buffer2 = adjustl(buffer2) if(any(index(buffer2,open_brackets).eq.1))then do i = 1, size(open_brackets) if(index(buffer2, open_brackets(i)) .eq. 1)then buffer2 = buffer2(2:) end if end do end if if(any(index(trim(buffer2),close_brackets).eq.len(trim(buffer2))))then do i = 1, size(close_brackets) if(index(trim(buffer2), close_brackets(i)) .eq. len(trim(buffer2)))then buffer2 = buffer2(:len(trim(buffer2))-1) end if end do end if ! count number of values i = icount(buffer2) allocate(variable(i)) read(buffer2, *) (variable(i), i = 1, size(variable)) end subroutine allocate_and_assignRvec !############################################################################### !############################################################################### subroutine assignS(buffer, variable, found, keyword, fs) !! Assign a string to variable implicit none ! Arguments character(*), intent(inout) :: buffer !! Input buffer character(*), intent(out) :: variable !! Variable to assign data to integer, intent(inout) :: found !! Count for finding variable character(*), optional, intent(in) :: keyword !! Keyword to start from character(1), optional, intent(in) :: fs !! Field separator ! Local variables character(1024) :: buffer2 !! Temporary buffer character(1) :: fs_ !! Field separator fs_ = '=' if(present(fs)) fs_ = fs if(present(keyword)) buffer = buffer(index(buffer, keyword):) if(scan(buffer, fs_) .ne. 0) buffer2 = get_val(buffer, fs_) if(trim(adjustl(buffer2)) .ne. '')then found = found + 1 if( & ( & buffer2(1:1) .eq. '"' .and. & buffer2(len(trim(buffer2)):len(trim(buffer2))) .eq. '"' & ) .or. ( & buffer2(1:1) .eq. '''' .and. & buffer2(len(trim(buffer2)):len(trim(buffer2))) .eq. '''' & ) & )then buffer2 = buffer2(2:len(trim(buffer2))-1) end if read(buffer2, '(A)') variable end if end subroutine assignS !############################################################################### !############################################################################### subroutine assignL(buffer, variable, found, keyword, fs) !! Assign a logical to variable (T/t/1 and F/f/0 accepted) implicit none ! Arguments character(*), intent(inout) :: buffer !! Input buffer logical, intent(out) :: variable !! Variable to assign data to integer, intent(inout) :: found !! Count for finding variable character(*), optional, intent(in) :: keyword !! Keyword to start from character(1), optional, intent(in) :: fs !! Field separator ! Local variables character(1024) :: buffer2 !! Temporary buffer character(1) :: fs_ !! Field separator fs_ = '=' if(present(fs)) fs_ = fs if(present(keyword)) buffer = buffer(index(buffer, keyword):) if(scan(buffer, fs_) .ne. 0) buffer2 = get_val(buffer, fs_) if(trim(adjustl(buffer2)) .ne. '')then found = found + 1 if( & index(buffer2, "T") .ne. 0 .or. & index(buffer2, "t") .ne. 0 .or. & index(buffer2, "1") .ne. 0 & )then variable = .TRUE. end if if( & index(buffer2, "F") .ne. 0 .or. & index(buffer2, "f") .ne. 0 .or. & index(buffer2, "0") .ne. 0 & )then variable = .FALSE. end if end if end subroutine assignL !############################################################################### !############################################################################### subroutine rm_comments(buffer, iline) !! Remove comment from a string (anything after ! or #) implicit none ! Arguments character(*), intent(inout) :: buffer !! Input buffer integer, optional, intent(in) :: iline !! Line number ! Local variables integer :: lbracket, rbracket, iline_ !! Bracket positions and line number iline_ = 0 if(present(iline)) iline_ = iline if(scan(buffer, '!') .ne. 0) buffer = buffer(:(scan(buffer, '!') - 1)) if(scan(buffer, '#') .ne. 0) buffer = buffer(:(scan(buffer, '#') - 1)) do while(scan(buffer, '(') .ne. 0 .or. scan(buffer, ')') .ne. 0) lbracket = scan(buffer, '(', back = .true.) rbracket = scan(buffer(lbracket:), ')') if(lbracket .eq. 0 .or. rbracket .eq. 0)then write(6, '(A,I0)') & ' NOTE: a bracketing error was encountered on line ', iline_ buffer = "" return end if rbracket = rbracket + lbracket - 1 buffer = buffer(:(lbracket - 1)) // buffer((rbracket + 1):) end do end subroutine rm_comments !############################################################################### !############################################################################### function stop_check(file) result(output) !! Logical check for stop file implicit none ! Arguments character(*), optional, intent(in) :: file !! File to check for ! Local variables integer :: Reason, itmp1, unit !! I/O status, temporary integer, and unit logical :: lfound, output !! File found flag and output character(248) :: file_ !! File name character(128) :: buffer, tagname !! Buffer and tag name unit = 999 file_ = "STOPCAR" if(present(file)) file_ = file output = .false. !! Check if file exists inquire(file = trim(file_), exist = lfound) if(lfound)then itmp1 = 0 open(unit = unit, file = trim(file_)) !! Read line-by-line do read(unit, '(A)', iostat = Reason) buffer if(Reason .ne. 0) exit call rm_comments(buffer) if(trim(buffer) .eq. "") cycle tagname = trim(adjustl(buffer)) if(scan(buffer, "=") .ne. 0) & tagname = trim(tagname(:scan(tagname, "=") - 1)) select case(trim(tagname)) case("LSTOP") call assignL(buffer, output, itmp1) exit case("LABORT") call assignL(buffer, output, itmp1) if(output)then close(unit, status = 'delete') stop "LABORT ENCOUNTERED IN STOP FILE (" // trim(file_) // ")" end if end select end do close(unit, status = 'delete') end if end function stop_check !############################################################################### !############################################################################### subroutine move(unit, change, iostat, err_msg) !! Move current position in file based on relative change implicit none ! Arguments integer, intent(in) :: unit !! Unit to read from integer, intent(in) :: change !! Relative change in position integer, intent(out), optional :: iostat !! I/O status character(*), intent(out), optional :: err_msg !! Error message ! Local variables integer :: iostat_ !! I/O status integer :: i !! Loop index character(256) :: err_msg_ !! Error message logical :: opened !! File existence check if(present(iostat)) iostat = 0 if(present(err_msg)) err_msg = "" if(change.eq.0) return inquire(unit = unit, iostat = iostat_, opened = opened) if(iostat_ .ne. 0)then write(err_msg_, '(A,I0)') & 'Cannot move in file, unit ', unit if(present(iostat)) iostat = iostat_ if(present(err_msg))then err_msg = err_msg_ else call stop_program(err_msg_) end if return elseif( .not.opened)then write(err_msg_, '(A,I0)') & 'File is not opened, unit ', unit if(present(iostat)) iostat = 44 if(present(err_msg))then err_msg = err_msg_ else call stop_program(err_msg_) end if return end if if(change.gt.0)then do i = 1, change read(unit, '(A)', iostat = iostat_) if(iostat_ .ne. 0)then write(err_msg_, '(A,I0)') & 'Cannot move forward in file, unit ', unit if(present(iostat)) iostat = iostat_ if(present(err_msg))then err_msg = err_msg_ else call stop_program(err_msg_) end if return end if end do else do i = 1, abs(change) backspace(unit) if(iostat .ne. 0)then write(err_msg_, '(A,I0)') & 'Cannot move backward in file, unit ', unit if(present(iostat)) iostat = iostat_ if(present(err_msg))then err_msg = err_msg_ else call stop_program(err_msg_) end if return end if end do end if end subroutine move !############################################################################### end module athena__tools_infile