module utilities use :: iso_c_binding implicit none private public :: push public :: pop public :: push_row public :: remove_repeats public :: in_array public :: remove public :: swap public :: FatalErrorKills, FatalErrorFlag, errorStream !! Global scope integer -- determines whether a call to FataErrorMessage kills the program public :: FatalErrorMessage, NonFatalErrorMessage, WarningMessage public :: meps integer, parameter :: dp = c_double integer, parameter :: i4 = c_int integer, parameter :: i8 = c_int64_t integer :: FatalErrorKills = 1 integer :: FatalErrorFlag integer :: errorStream = 0 real(kind=c_double), parameter :: meps = epsilon(1.0_dp) type, public :: varString character(len=:), allocatable :: s contains private procedure, pass(self) :: toInt_i4 procedure, pass(self) :: toInt_i8 generic, public :: to_int => toInt_i4, toInt_i8 procedure, pass(self) :: toListInt_i4 procedure, pass(self) :: toListInt_i8 procedure, pass(self) :: toListCDouble generic, public :: to_list => toListInt_i4, toListInt_i8, toListCDouble procedure, pass(self) :: toCDouble procedure, pass(self) :: toCDouble_fmt procedure, pass(self) :: toCDouble_i4Norm procedure, pass(self) :: toCDouble_i8Norm procedure, pass(self) :: toCDouble_dNorm generic, public :: to_float => toCDouble, toCDouble_fmt, & toCDouble_i4Norm, toCDouble_i8Norm, & toCDouble_dNorm procedure, public, pass(self) :: len => varString_len procedure, pass(self) :: toLower_out procedure, pass(self) :: toLower_inout generic, public :: to_lower => toLower_out, toLower_inout final :: destroy_varString end type varString interface varString module procedure :: init_varString end interface varString interface push module procedure :: push_scalar_logical module procedure :: push_vector_logical module procedure :: push_scalar_i4 module procedure :: push_vector_i4 module procedure :: push_scalar_i8 module procedure :: push_vector_i8 end interface push interface push_row module procedure :: push_row_logical module procedure :: push_row_i4 module procedure :: push_row_i8 module procedure :: push_row_double end interface push_row interface pop module procedure :: pop_i4i4 module procedure :: pop_i4i8 module procedure :: pop_i8i4 module procedure :: pop_i8i8 end interface pop interface remove_repeats module procedure :: remove_repeats_i4 module procedure :: remove_repeats_i8 end interface remove_repeats interface in_array module procedure :: in_array_i4i4 module procedure :: in_array_i4i8 module procedure :: in_array_i8i4 module procedure :: in_array_i8i8 end interface in_array interface remove module procedure :: remove_i4i4_scalar module procedure :: remove_i4i4_vector module procedure :: remove_i4i8_scalar module procedure :: remove_i4i8_vector module procedure :: remove_i8i4_scalar module procedure :: remove_i8i4_vector module procedure :: remove_i8i8_scalar module procedure :: remove_i8i8_vector end interface remove interface swap module procedure :: swap_i4 module procedure :: swap_i8 module procedure :: swap_double end interface swap interface FatalErrorMessage module procedure FatalErrorMessage_b, FatalErrorMessage_m, FatalErrorMessage_r, FatalErrorMessage_rv, FatalErrorMessage_i, FatalErrorMessage_is end interface interface NonFatalErrorMessage module procedure NonFatalErrorMessage_b, NonFatalErrorMessage_m, NonFatalErrorMessage_s, & NonFatalErrorMessage_r, NonFatalErrorMessage_rv, NonFatalErrorMessage_i, NonFatalErrorMessage_is end interface interface WarningMessage module procedure WarningMessage_m, WarningMessage_s, WarningMessage_r, WarningMessage_rv, WarningMessage_i4, WarningMessage_i8 end interface contains function init_varString(str) result(self) type(varString) :: self character(len=*), intent(in) :: str self%s = trim(adjustl(str)) return end function init_varString subroutine toInt_i4(self, val) implicit none integer(kind=c_int), intent(out) :: val class(varString), intent(in) :: self read(self%s,*) val return end subroutine toInt_i4 subroutine toInt_i8(self, val) implicit none integer(kind=c_int64_t), intent(out) :: val class(varString), intent(in) :: self read(self%s,*) val return end subroutine toInt_i8 subroutine toCDouble(self, val) implicit none real(kind=c_double), intent(out) :: val class(varString), intent(in) :: self read(self%s,*) val return end subroutine toCDouble subroutine toListInt_i4(self, val) implicit none integer(kind=c_int), dimension(:), allocatable, intent(out) :: val class(varString), intent(in) :: self integer :: n n = count(transfer(self%s, 'a', len(self%s)) == ',') allocate(val(n+1)) read(self%s,*) val(1:n+1) return end subroutine toListInt_i4 subroutine toListInt_i8(self, val) implicit none integer(kind=c_int64_t), dimension(:), allocatable, intent(out) :: val class(varString), intent(in) :: self integer :: n n = count(transfer(self%s, 'a', len(self%s)) == ',') allocate(val(n+1)) read(self%s,*) val(1:n+1) return end subroutine toListInt_i8 subroutine toListCDouble(self, val) implicit none real(kind=c_double), dimension(:), allocatable, intent(out) :: val class(varString), intent(in) :: self integer :: n n = count(transfer(self%s, 'a', len(self%s)) == ',') allocate(val(n+1)) read(self%s,*) val(1:n+1) return end subroutine toListCDouble subroutine toCDouble_i4Norm(self, val, norm) implicit none real(kind=c_double), intent(out) :: val class(varString), intent(in) :: self integer(kind=c_int), intent(in) :: norm read(self%s,*) val val = val/(real(norm, kind=c_double)) return end subroutine toCDouble_i4Norm subroutine toCDouble_i8Norm(self, val, norm) implicit none real(kind=c_double), intent(out) :: val class(varString), intent(in) :: self integer(kind=c_int64_t), intent(in) :: norm read(self%s,*) val val = val/(real(norm, kind=c_double)) return end subroutine toCDouble_i8Norm subroutine toCDouble_dNorm(self, val, norm) implicit none real(kind=c_double), intent(out) :: val class(varString), intent(in) :: self real(kind=c_double), intent(in) :: norm read(self%s,*) val val = val/norm return end subroutine toCDouble_dNorm subroutine toCDouble_fmt(self, formatStr, val) implicit none real(kind=c_double), intent(out) :: val class(varString), intent(in) :: self character(len=*), intent(in) :: formatStr read(self%s, fmt=formatStr) val return end subroutine toCDouble_fmt function varString_len(self) result(length) implicit none integer :: length class(varString), intent(in) :: self length = len(self%s) return end function varString_len recursive subroutine toLower_out(self, str_out) ! Convert uppercase characters in string to lower case. implicit none class(varString), intent(in) :: self class(varString), intent(out) :: str_out character(len=len(self%s)) :: str_tmp integer :: i do i = 1, self%len() select case(self%s(i:i)) case("A":"Z") str_tmp(i:i) = achar(iachar(self%s(i:i))+32) case default str_tmp(i:i) = self%s(i:i) end select end do str_out%s = str_tmp return end subroutine toLower_out recursive subroutine toLower_inout(self) ! Convert uppercase characters in string to lower case. ! Overwrites input string. implicit none class(varString), intent(inout) :: self integer :: i character(len=len(self%s)) :: str_tmp str_tmp = self%s do i = 1, self%len() select case(self%s(i:i)) case("A":"Z") str_tmp(i:i) = achar(iachar(self%s(i:i))+32) end select end do self%s = str_tmp return end subroutine toLower_inout subroutine destroy_varString(self) implicit none type(varString) :: self if (allocated(self%s)) deallocate(self%s) return end subroutine destroy_varString subroutine push_scalar_logical(list,val) implicit none logical, dimension(:), intent(inout), allocatable :: list logical, intent(in) :: val integer :: N logical, dimension(:), allocatable :: tmp if (allocated(list)) then N = size(list) allocate(tmp(N+1)) tmp(1:N) = list(1:N) tmp(N+1) = val call move_alloc(tmp,list) else allocate(list(1)) list(1) = val end if return end subroutine push_scalar_logical subroutine push_vector_logical(list,val) implicit none logical, dimension(:), intent(inout), allocatable :: list logical, dimension(:), intent(in) :: val integer :: j do j=1,size(val) call push_scalar_logical(list, val(j)) end do return end subroutine push_vector_logical subroutine push_scalar_i4(list,val) implicit none integer(kind=c_int), dimension(:), intent(inout), allocatable :: list integer(kind=c_int), intent(in) :: val integer :: N integer(kind=c_int), dimension(:), allocatable :: tmp if (allocated(list)) then N = size(list) allocate(tmp(N+1)) tmp(1:N) = list(1:N) tmp(N+1) = val call move_alloc(tmp,list) else allocate(list(1)) list(1) = val end if return end subroutine push_scalar_i4 subroutine push_scalar_i8(list,val) implicit none integer(kind=c_int64_t), dimension(:), intent(inout), allocatable :: list integer(kind=c_int64_t), intent(in) :: val integer :: N integer(kind=c_int64_t), dimension(:), allocatable :: tmp if (allocated(list)) then N = size(list) allocate(tmp(N+1)) tmp(1:N) = list(1:N) tmp(N+1) = val call move_alloc(tmp,list) else allocate(list(1)) list(1) = val end if return end subroutine push_scalar_i8 subroutine push_vector_i4(list,val) implicit none integer(kind=c_int), dimension(:), intent(inout), allocatable :: list integer(kind=c_int), dimension(:), intent(in) :: val integer :: j do j=1,size(val) call push_scalar_i4(list, val(j)) end do return end subroutine push_vector_i4 subroutine push_vector_i8(list,val) implicit none integer(kind=c_int64_t), dimension(:), intent(inout), allocatable :: list integer(kind=c_int64_t), dimension(:), intent(in) :: val integer :: j do j=1,size(val) call push_scalar_i8(list, val(j)) end do return end subroutine push_vector_i8 subroutine push_row_logical(array, row) implicit none logical, dimension(:,:), intent(inout), allocatable :: array logical, dimension(:), intent(in) :: row logical, dimension(:,:), allocatable :: tmp integer :: row_size integer :: Nrows row_size = size(array(1,:)) Nrows = size(array(:,1)) if (size(row) .ne. row_size) call FatalErrorMessage('Failed to push_row_logical: row is not the correct size') allocate(tmp(Nrows+1,row_size)) tmp(1:Nrows,:) = array(:,:) tmp(Nrows+1,:) = row(:) call move_alloc(tmp, array) return end subroutine push_row_logical subroutine push_row_i4(array, row) implicit none integer(kind=c_int), dimension(:,:), intent(inout), allocatable :: array integer(kind=c_int), dimension(:), intent(in) :: row integer(kind=c_int), dimension(:,:), allocatable :: tmp integer :: row_size integer :: Nrows row_size = size(array(1,:)) Nrows = size(array(:,1)) if (size(row) .ne. row_size) call FatalErrorMessage('Failed to push_row_i4: row is not the correct size') allocate(tmp(Nrows+1,row_size)) tmp(1:Nrows,:) = array(:,:) tmp(Nrows+1,:) = row(:) call move_alloc(tmp, array) return end subroutine push_row_i4 subroutine push_row_i8(array, row) implicit none integer(kind=c_int64_t), dimension(:,:), intent(inout), allocatable :: array integer(kind=c_int64_t), dimension(:), intent(in) :: row integer(kind=c_int64_t), dimension(:,:), allocatable :: tmp integer :: row_size integer :: Nrows row_size = size(array(1,:)) Nrows = size(array(:,1)) if (size(row) .ne. row_size) call FatalErrorMessage('Failed to push_row_i8: row is not the correct size') allocate(tmp(Nrows+1,row_size)) tmp(1:Nrows,:) = array(:,:) tmp(Nrows+1,:) = row(:) call move_alloc(tmp, array) return end subroutine push_row_i8 subroutine push_row_double(array, row) implicit none real(kind=c_double), dimension(:,:), intent(inout), allocatable :: array real(kind=c_double), dimension(:), intent(in) :: row real(kind=c_double), dimension(:,:), allocatable :: tmp integer :: row_size integer :: Nrows row_size = size(array(1,:)) Nrows = size(array(:,1)) if (size(row) .ne. row_size) call FatalErrorMessage('Failed to push_row_double: row is not the correct size') allocate(tmp(Nrows+1,row_size)) tmp(1:Nrows,:) = array(:,:) tmp(Nrows+1,:) = row(:) call move_alloc(tmp, array) return end subroutine push_row_double subroutine pop_i4i4(list,index) integer(kind=c_int), dimension(:), intent(inout), allocatable :: list integer(kind=c_int), intent(in) :: index integer :: N integer(kind=c_int), dimension(:), allocatable :: tmp N = size(list) allocate(tmp(N-1)) tmp(1:index-1) = list(1:index-1) tmp(index:N-1) = list(index+1:N) call move_alloc(tmp,list) return end subroutine pop_i4i4 subroutine pop_i4i8(list,index) integer(kind=c_int), dimension(:), intent(inout), allocatable :: list integer(kind=c_int64_t), intent(in) :: index integer :: N integer(kind=c_int), dimension(:), allocatable :: tmp N = size(list) allocate(tmp(N-1)) tmp(1:index-1) = list(1:index-1) tmp(index:N-1) = list(index+1:N) call move_alloc(tmp,list) return end subroutine pop_i4i8 subroutine pop_i8i4(list,index) integer(kind=c_int64_t), dimension(:), intent(inout), allocatable :: list integer(kind=c_int), intent(in) :: index integer :: N integer(kind=c_int64_t), dimension(:), allocatable :: tmp N = size(list) allocate(tmp(N-1)) tmp(1:index-1) = list(1:index-1) tmp(index:N-1) = list(index+1:N) call move_alloc(tmp,list) return end subroutine pop_i8i4 subroutine pop_i8i8(list,index) integer(kind=c_int64_t), dimension(:), intent(inout), allocatable :: list integer(kind=c_int64_t), intent(in) :: index integer :: N integer(kind=c_int64_t), dimension(:), allocatable :: tmp N = size(list) allocate(tmp(N-1)) tmp(1:index-1) = list(1:index-1) tmp(index:N-1) = list(index+1:N) call move_alloc(tmp,list) return end subroutine pop_i8i8 subroutine remove_repeats_i4(list) integer(kind=c_int), dimension(:), allocatable, intent(inout) :: list integer(kind=c_int) :: j integer(kind=c_int), dimension(:), allocatable :: tmp if (size(list)==1) then return else allocate(tmp(1)) tmp(1) = list(1) do j=2,size(list) ! if the number already exists in the list check next if (any(tmp == list(j))) cycle ! No match found so add it to tmp call push(tmp, list(j)) end do call move_alloc(tmp, list) return end if end subroutine remove_repeats_i4 subroutine remove_repeats_i8(list) integer(kind=c_int64_t), dimension(:), allocatable, intent(inout) :: list integer(kind=c_int) :: j integer(kind=c_int64_t), dimension(:), allocatable :: tmp if (size(list)==1) then return else allocate(tmp(1)) tmp(1) = list(1) do j=2,size(list) ! if the number already exists in the list check next if (any(tmp == list(j))) cycle ! No match found so add it to tmp call push(tmp, list(j)) end do call move_alloc(tmp, list) return end if end subroutine remove_repeats_i8 pure function in_array_i4i4(arr,val) result(ret) integer(kind=c_int), dimension(:), intent(in) :: arr integer(kind=c_int), intent(in) :: val logical :: ret integer :: j ret = .False. do j=1,size(arr) if (arr(j)==val) then ret = .True. return end if end do return end function in_array_i4i4 pure function in_array_i4i8(arr,val) result(ret) integer(kind=c_int), dimension(:), intent(in) :: arr integer(kind=c_int64_t), intent(in) :: val logical :: ret integer :: j integer(kind=c_int) :: val_i4 val_i4 = int(val, kind=c_int) ret = .False. do j=1,size(arr) if (arr(j)==val) then ret = .True. return end if end do return end function in_array_i4i8 pure function in_array_i8i4(arr,val) result(ret) integer(kind=c_int64_t), dimension(:), intent(in) :: arr integer(kind=c_int), intent(in) :: val logical :: ret integer :: j integer(kind=c_int64_t) :: val_i8 val_i8 = int(val, kind=c_int64_t) ret = .False. do j=1,size(arr) if (arr(j)==val_i8) then ret = .True. return end if end do return end function in_array_i8i4 pure function in_array_i8i8(arr,val) result(ret) integer(kind=c_int64_t), dimension(:), intent(in) :: arr integer(kind=c_int64_t), intent(in) :: val logical :: ret integer :: j ret = .False. do j=1,size(arr) if (arr(j)==val) then ret = .True. return end if end do return end function in_array_i8i8 subroutine remove_i4i4_scalar(list, val) implicit none integer(kind=c_int), dimension(:), intent(inout), allocatable :: list integer(kind=c_int), intent(in) :: val integer, dimension(:) :: indx(1) do while (in_array(list, val)) indx = findloc(list, val) call pop(list, indx(1)) end do return end subroutine remove_i4i4_scalar subroutine remove_i4i4_vector(list, val) implicit none integer(kind=c_int), dimension(:), intent(inout), allocatable :: list integer(kind=c_int), dimension(:), intent(in) :: val integer, dimension(:) :: indx(1) integer :: j do j=1,size(val) do while (in_array(list, val(j))) indx = findloc(list, val(j)) call pop(list, indx(1)) end do end do return end subroutine remove_i4i4_vector subroutine remove_i4i8_scalar(list, val) implicit none integer(kind=c_int), dimension(:), intent(inout), allocatable :: list integer(kind=c_int64_t), intent(in) :: val integer(kind=c_int) :: val_i4 integer, dimension(:) :: indx(1) val_i4 = int(val, kind=c_int) do while (in_array(list, val_i4)) indx = findloc(list, val_i4) call pop(list, indx(1)) end do return end subroutine remove_i4i8_scalar subroutine remove_i4i8_vector(list, val) implicit none integer(kind=c_int), dimension(:), intent(inout), allocatable :: list integer(kind=c_int64_t), dimension(:), intent(in) :: val integer(kind=c_int), dimension(:) :: val_i4(size(val)) integer, dimension(:) :: indx(1) integer :: j val_i4 = int(val, kind=c_int) do j=1,size(val_i4) do while (in_array(list, val_i4(j))) indx = findloc(list, val_i4(j)) call pop(list, indx(1)) end do end do return end subroutine remove_i4i8_vector subroutine remove_i8i4_scalar(list, val) implicit none integer(kind=c_int64_t), dimension(:), intent(inout), allocatable :: list integer(kind=c_int), intent(in) :: val integer(kind=c_int64_t) :: val_i8 integer, dimension(:) :: indx(1) val_i8 = int(val, kind=c_int64_t) do while (in_array(list, val_i8)) indx = findloc(list, val_i8) call pop(list, indx(1)) end do return end subroutine remove_i8i4_scalar subroutine remove_i8i4_vector(list, val) implicit none integer(kind=c_int64_t), dimension(:), intent(inout), allocatable :: list integer(kind=c_int), dimension(:), intent(in) :: val integer(kind=c_int64_t), dimension(:) :: val_i8(size(val)) integer, dimension(:) :: indx(1) integer :: j val_i8 = int(val, kind=c_int64_t) do j=1,size(val_i8) do while (in_array(list, val_i8(j))) indx = findloc(list, val_i8(j)) call pop(list, indx(1)) end do end do return end subroutine remove_i8i4_vector subroutine remove_i8i8_scalar(list, val) implicit none integer(kind=c_int64_t), dimension(:), intent(inout), allocatable :: list integer(kind=c_int64_t), intent(in) :: val integer, dimension(:) :: indx(1) do while (in_array(list, val)) indx = findloc(list, val) call pop(list, indx(1)) end do return end subroutine remove_i8i8_scalar subroutine remove_i8i8_vector(list, val) implicit none integer(kind=c_int64_t), dimension(:), intent(inout), allocatable :: list integer(kind=c_int64_t), dimension(:), intent(in) :: val integer, dimension(:) :: indx(1) integer :: j do j=1,size(val) do while (in_array(list, val(j))) indx = findloc(list, val(j)) call pop(list, indx(1)) end do end do return end subroutine remove_i8i8_vector subroutine swap_i4(a,b) implicit none integer(kind=c_int), intent(inout) :: a integer(kind=c_int), intent(inout) :: b integer(kind=c_int) :: tmp tmp = a a = b b = tmp return end subroutine swap_i4 subroutine swap_i8(a,b) implicit none integer(kind=c_int64_t), intent(inout) :: a integer(kind=c_int64_t), intent(inout) :: b integer(kind=c_int64_t) :: tmp tmp = a a = b b = tmp return end subroutine swap_i8 subroutine swap_double(a,b) implicit none real(kind=c_double), intent(inout) :: a real(kind=c_double), intent(inout) :: b real(kind=c_double) :: tmp tmp = a a = b b = tmp return end subroutine swap_double recursive subroutine FatalErrorMessage_b ! Fatal Error message with no information. ! If FatalErrorKills==1 then program ends immediately. implicit none write(errorStream,*) ' ' write(errorStream,*) '************************************' write(errorStream,*) '************************************' write(errorStream,*) 'FATAL ERROR : ' write(errorStream,*) 'Quitting.' write(errorStream,*) '************************************' write(errorStream,*) '************************************' write(errorStream,*) ' ' if (FatalErrorKills==1) call exit(1) ! Fatal error return with status 1 return end subroutine FatalErrorMessage_b recursive subroutine FatalErrorMessage_m(Message) ! Fatal Error message with information. ! If FatalErrorKills==1 then program ends immediately. ! Input: Message [character string] implicit none character(len=*), intent(in) :: Message write(errorStream,*) ' ' write(errorStream,*) '************************************' write(errorStream,*) '************************************' write(errorStream,*) 'FATAL ERROR : ' write(errorStream,*) trim(Message) write(errorStream,*) 'Quitting.' write(errorStream,*) '************************************' write(errorStream,*) '************************************' write(errorStream,*) ' ' if (FatalErrorKills==1) call exit(1) ! Fatal error return with status 1 return end subroutine FatalErrorMessage_m recursive subroutine FatalErrorMessage_r(Message,val) ! Fatal Error message with information and real value. ! If FatalErrorKills==1 then program ends immediately. ! Input: Message [character string]; val [real] implicit none character(len=*), intent(in) :: Message real(kind=c_double), intent(in) :: val write(errorStream,*) ' ' write(errorStream,*) '************************************' write(errorStream,*) '************************************' write(errorStream,*) 'FATAL ERROR : ' write(errorStream,*) trim(Message), val write(errorStream,*) 'Quitting.' write(errorStream,*) '************************************' write(errorStream,*) '************************************' write(errorStream,*) ' ' if (FatalErrorKills==1) call exit(1) ! Fatal error return with status 1 return end subroutine FatalErrorMessage_r recursive subroutine FatalErrorMessage_i(Message,val) ! Fatal Error message with information and integer value. ! If FatalErrorKills==1 then program ends immediately. ! Input: Message [character string]; val [integer] implicit none character(len=*), intent(in) :: Message integer, intent(in) :: val write(errorStream,*) ' ' write(errorStream,*) '************************************' write(errorStream,*) '************************************' write(errorStream,*) 'FATAL ERROR : ' write(errorStream,*) trim(Message), val write(errorStream,*) 'Quitting.' write(errorStream,*) '************************************' write(errorStream,*) '************************************' write(errorStream,*) ' ' if (FatalErrorKills==1) call exit(1) ! Fatal error return with status 1 return end subroutine FatalErrorMessage_i recursive subroutine FatalErrorMessage_is(Message1,val,Message2) ! Non-Fatal Error message with information. integer value and more information. ! Input: Message1 [character string]; val [integer]; Message2 [character string] implicit none character(len=*), intent(in) :: Message1 integer, intent(in) :: val character(len=*), intent(in) :: Message2 write(errorStream,*) ' ' write(errorStream,*) '************************************' write(errorStream,*) '************************************' write(errorStream,*) 'ERROR : ' write(errorStream,*) trim(Message1), val, trim(Message2) write(errorStream,*) 'Attempting to continue. ' write(errorStream,*) 'Results may be not as expected. ' write(errorStream,*) '************************************' write(errorStream,*) '************************************' write(errorStream,*) ' ' if (FatalErrorKills==1) stop return end subroutine FatalErrorMessage_is recursive subroutine FatalErrorMessage_rv(Message,val) ! Fatal Error message with information and real valued array. ! If FatalErrorKills==1 then program ends immediately. ! Input: Message [character string]; val [real array] implicit none character(len=*), intent(in) :: Message real(kind=c_double), dimension(:), intent(in) :: val write(errorStream,*) ' ' write(errorStream,*) '************************************' write(errorStream,*) '************************************' write(errorStream,*) 'FATAL ERROR : ' write(errorStream,*) trim(Message) write(errorStream,*) val write(errorStream,*) 'Quitting.' write(errorStream,*) '************************************' write(errorStream,*) '************************************' write(errorStream,*) ' ' if (FatalErrorKills==1) call exit(1) ! Fatal error return with status 1 return end subroutine FatalErrorMessage_rv recursive subroutine NonFatalErrorMessage_b ! Non-Fatal Error message with no information. implicit none write(errorStream,*) ' ' write(errorStream,*) '************************************' write(errorStream,*) '************************************' write(errorStream,*) 'ERROR ' write(errorStream,*) 'Attempting to continue. ' write(errorStream,*) 'Results may be not as expected. ' write(errorStream,*) '************************************' write(errorStream,*) '************************************' write(errorStream,*) ' ' return end subroutine NonFatalErrorMessage_b recursive subroutine NonFatalErrorMessage_m(Message) ! Non-Fatal Error message with information. ! Input: Message [character string] implicit none character(len=*), intent(in) :: Message write(errorStream,*) ' ' write(errorStream,*) '************************************' write(errorStream,*) '************************************' write(errorStream,*) 'ERROR : ' write(errorStream,*) Message write(errorStream,*) 'Attempting to continue. ' write(errorStream,*) 'Results may be not as expected. ' write(errorStream,*) '************************************' write(errorStream,*) '************************************' write(errorStream,*) ' ' return end subroutine NonFatalErrorMessage_m recursive subroutine NonFatalErrorMessage_s(Message,str) ! Non-Fatal Error message with information and a string. ! Input: Message [character string]; str [character string] implicit none character(len=*), intent(in) :: Message character(len=*), intent(in) :: str write(errorStream,*) ' ' write(errorStream,*) '************************************' write(errorStream,*) '************************************' write(errorStream,*) 'ERROR : ' write(errorStream,*) trim(Message), str write(errorStream,*) 'Attempting to continue. ' write(errorStream,*) 'Results may be not as expected. ' write(errorStream,*) '************************************' write(errorStream,*) '************************************' write(errorStream,*) ' ' return end subroutine NonFatalErrorMessage_s recursive subroutine NonFatalErrorMessage_r(Message,val) ! Non-Fatal Error message with information and real value. ! Input: Message [character string]; val [real] implicit none character(len=*), intent(in) :: Message real(kind=c_double), intent(in) :: val write(errorStream,*) ' ' write(errorStream,*) '************************************' write(errorStream,*) '************************************' write(errorStream,*) 'ERROR : ' write(errorStream,*) trim(Message), val write(errorStream,*) 'Attempting to continue. ' write(errorStream,*) 'Results may be not as expected. ' write(errorStream,*) '************************************' write(errorStream,*) '************************************' write(errorStream,*) ' ' return end subroutine NonFatalErrorMessage_r recursive subroutine NonFatalErrorMessage_i(Message,val) ! Non-Fatal Error message with information and integer value. ! Input: Message [character string]; val [integer] implicit none character(len=*), intent(in) :: Message integer, intent(in) :: val write(errorStream,*) ' ' write(errorStream,*) '************************************' write(errorStream,*) '************************************' write(errorStream,*) 'ERROR : ' write(errorStream,*) trim(Message), val write(errorStream,*) 'Attempting to continue. ' write(errorStream,*) 'Results may be not as expected. ' write(errorStream,*) '************************************' write(errorStream,*) '************************************' write(errorStream,*) ' ' return end subroutine NonFatalErrorMessage_i recursive subroutine NonFatalErrorMessage_is(Message1,val,Message2) ! Non-Fatal Error message with information. integer value and more information. ! Input: Message1 [character string]; val [integer]; Message2 [character string] implicit none character(len=*), intent(in) :: Message1 integer, intent(in) :: val character(len=*), intent(in) :: Message2 write(errorStream,*) ' ' write(errorStream,*) '************************************' write(errorStream,*) '************************************' write(errorStream,*) 'ERROR : ' write(errorStream,*) trim(Message1), val, trim(Message2) write(errorStream,*) 'Attempting to continue. ' write(errorStream,*) 'Results may be not as expected. ' write(errorStream,*) '************************************' write(errorStream,*) '************************************' write(errorStream,*) ' ' return end subroutine NonFatalErrorMessage_is recursive subroutine NonFatalErrorMessage_rv(Message,val) ! Non-Fatal Error message with information and real valued array. ! Input: Message [character string]; val [real array] implicit none character(len=*), intent(in) :: Message real(kind=c_double), dimension(:), intent(in) :: val write(errorStream,*) ' ' write(errorStream,*) '************************************' write(errorStream,*) '************************************' write(errorStream,*) 'ERROR : ' write(errorStream,*) trim(Message) write(errorStream,*) val write(errorStream,*) 'Attempting to continue. ' write(errorStream,*) 'Results may be not as expected. ' write(errorStream,*) '************************************' write(errorStream,*) '************************************' write(errorStream,*) ' ' return end subroutine NonFatalErrorMessage_rv recursive subroutine WarningMessage_m(Message) ! Warning message with information. ! Input: Message [character string] implicit none character(len=*), intent(in) :: Message write(errorStream,*) ' ' write(errorStream,*) '************************************' write(errorStream,*) 'Warning: ' write(errorStream,*) Message write(errorStream,*) 'Results may be not as expected. ' write(errorStream,*) '************************************' write(errorStream,*) ' ' return end subroutine WarningMessage_m recursive subroutine WarningMessage_s(Message,str) ! Non-Fatal Error message with information and a string. ! Input: Message [character string]; str [character string] implicit none character(len=*), intent(in) :: Message character(len=*), intent(in) :: str write(errorStream,*) ' ' write(errorStream,*) '************************************' write(errorStream,*) 'Warning: ' write(errorStream,*) trim(Message), ' ', str write(errorStream,*) 'Results may be not as expected. ' write(errorStream,*) '************************************' write(errorStream,*) ' ' return end subroutine WarningMessage_s recursive subroutine WarningMessage_r(Message,val) ! Warning message with information and real value. ! Input: Message [character string]; val [real] implicit none character(len=*), intent(in) :: Message real(kind=c_double), intent(in) :: val write(errorStream,*) ' ' write(errorStream,*) '************************************' write(errorStream,*) 'Warning: ' write(errorStream,*) trim(Message), val write(errorStream,*) 'Results may be not as expected. ' write(errorStream,*) '************************************' write(errorStream,*) ' ' return end subroutine WarningMessage_r recursive subroutine WarningMessage_i4(Message,val) ! Warning message with information and integer value. ! Input: Message [character string]; val [integer] implicit none character(len=*), intent(in) :: Message integer(kind=c_int), intent(in) :: val write(errorStream,*) ' ' write(errorStream,*) '************************************' write(errorStream,*) 'Warning: ' write(errorStream,*) trim(Message), val write(errorStream,*) 'Results may be not as expected. ' write(errorStream,*) '************************************' write(errorStream,*) ' ' return end subroutine WarningMessage_i4 recursive subroutine WarningMessage_i8(Message,val) ! Warning message with information and integer value. ! Input: Message [character string]; val [integer] implicit none character(len=*), intent(in) :: Message integer(kind=c_int64_t), intent(in) :: val write(errorStream,*) ' ' write(errorStream,*) '************************************' write(errorStream,*) 'Warning: ' write(errorStream,*) trim(Message), val write(errorStream,*) 'Results may be not as expected. ' write(errorStream,*) '************************************' write(errorStream,*) ' ' return end subroutine WarningMessage_i8 recursive subroutine WarningMessage_rv(Message,val) ! Warning message with information and real valued array. ! Input: Message [character string]; val [real array] implicit none character(len=*), intent(in) :: Message real(kind=c_double), dimension(:), intent(in) :: val write(errorStream,*) ' ' write(errorStream,*) '************************************' write(errorStream,*) 'Warning: ' write(errorStream,*) trim(Message) write(errorStream,*) val write(errorStream,*) 'Results may be not as expected. ' write(errorStream,*) '************************************' write(errorStream,*) ' ' return end subroutine WarningMessage_rv end module utilities