gray/src/gray_errors.f90

! This module contains the error codes handled by the gray_main subroutine
!
! An error is actually a 32bit integer bitmask that can encode several
! error cases. The individual errors can be raised using the `raise_error`
! function and combined simply with the intrinsic `ior` function.
module gray_errors

  use logger, only : log_error
  use, intrinsic :: iso_fortran_env, only : int32

  implicit none

  ! The type of a GRAY error is `integer(kind=gray_error)`
  integer, parameter :: gray_error = int32

  ! Specification of a GRAY error
  type error_spec
    integer       :: offset    ! bitmask offset
    integer       :: subcases  ! number of error subcases (max: 10)
    character(32) :: mod       ! module raising the error
    character(32) :: proc      ! procedure raising the error
    character(64) :: msg(0:9)  ! error message (one for each subcase)
  end type

  ! macros used for defining errors
# define _ ,
# define list(x) reshape([character(64) :: x], [10], [character(64) :: ''])
# define after(x) x%offset + x%subcases

  ! All GRAY errors

  type(error_spec), parameter :: large_npl =        &
    error_spec(offset=0, subcases=2,                &
               mod='gray_core', proc='gray_main',   &
               msg=list('N∥ is too large (>0.99)'_
                        'N∥ is too large (>1.05)'))

  type(error_spec), parameter :: dielectric_tensor =  &
    error_spec(offset=after(large_npl), subcases=2,   &
               mod='gray_core', proc='gray_main',     &
               msg=list('ε tensor, overflow in `fsup`'_
                        'ε tensor, integration error in `hermitian_2`'))

  type(error_spec), parameter :: warmdisp_convergence =      &
    error_spec(offset=after(dielectric_tensor), subcases=2,  &
               mod='dispersion', proc='warmdisp',            &
               msg=list('failed to converge, returned fallback value'_
                        'failed to converge, returned last value'))

  type(error_spec), parameter :: warmdisp_result =              &
    error_spec(offset=after(warmdisp_convergence), subcases=2,  &
               mod='dispersion', proc='warmdisp',               &
               msg=list('final N⊥² is NaN or ±Infinity'_
                        'final N⊥² in 3rd quadrant'))

  type(error_spec), parameter :: negative_absorption =     &
    error_spec(offset=after(warmdisp_result), subcases=1,  &
               mod='gray_core', proc='alpha_effj',         &
               msg=list('negative absorption coeff.'))

  type(error_spec), parameter :: fpp_integration =             &
    error_spec(offset=after(negative_absorption), subcases=1,  &
               mod='eccd', proc='eccdeff',                     &
               msg=list('fpp integration error'))

  type(error_spec), parameter :: fcur_integration =        &
    error_spec(offset=after(fpp_integration), subcases=3,  &
               mod='eccd', proc='eccdeff',                 &
               msg=list('fcur integration error (no trapping)'_
                        'fcur integration error (1st trapping region)'_
                        'fcur integration error (2st trapping region)'))

  ! Errors occuring during raytracing
  type(error_spec), parameter :: raytracing_errors(*) = [large_npl]

  ! Errors occuring during absorption and current drive computations
  type(error_spec), parameter :: ecrh_cd_errors(*) = &
    [dielectric_tensor,    &
     warmdisp_convergence, &
     warmdisp_result,      &
     negative_absorption,  &
     fpp_integration,      &
     fcur_integration]

contains

  pure function is_critical(error)
    ! Checks whether critical errors have occurred

    ! subroutines arguments
    integer(kind=gray_error), intent(in) :: error
    logical                              :: is_critical

    is_critical = has_error(error, negative_absorption)
  end function is_critical


  pure function has_error(error, spec)
    ! Checks whether the `error` bitmask contains the error given by `spec`

    ! function arguments
    integer(kind=gray_error), intent(in) :: error
    type(error_spec),         intent(in) :: spec
    logical                              :: has_error

    has_error = ibits(error, spec%offset, spec%subcases) == 1
  end function has_error


  pure function raise_error(error, spec, subcase)
    ! Raise the bits of error `spec` (with optional `subcase` number)
    ! in the `error` bitmask.

    ! function arguments
    integer(kind=gray_error), intent(in) :: error
    type(error_spec),         intent(in) :: spec
    integer,                  intent(in), optional :: subcase
    integer(kind=gray_error)             :: raise_error

    raise_error = ibset(error, spec%offset &
                               + merge(subcase, 0, present(subcase)))
  end function raise_error


  subroutine print_err_raytracing(error, step, Npl)
    ! Pretty prints raytracing errors
    !
    ! The error and some context (integration step, N∥)
    ! is logged to the stderr using the logger module.

    use const_and_precisions, only : wp_

    ! subroutines arguments
    integer,   intent(in) :: error, step
    real(wp_), intent(in) :: Npl

    ! local variables
    integer :: slice        ! a slice of the bitmask
    character(256) :: line  ! formatted log line
    type(error_spec) :: spec
    integer :: i, j

    ! format specifier of the log line
    character(*), parameter :: fmt = &
      '(a,": ","error=",g0," N∥=",g0.3," step=",g0)'

    ! iterate on the known errors
    do i = 1, size(raytracing_errors)
      spec = raytracing_errors(i)
      slice = ibits(error, spec%offset, spec%subcases)
      if (slice == 0) cycle

      ! iterate on the subcases
      do j = 0, spec%subcases - 1
        if (ibits(slice, j, 1) == 0) cycle
        write(line, fmt) trim(spec%msg(j)), slice * 2**j, Npl, step
        call log_error(line, mod=spec%mod, proc=spec%proc)
      end do
    end do
  end subroutine print_err_raytracing


  subroutine print_err_ecrh_cd(error, step, Npr, alpha)
    ! Pretty prints ECRH & CD errors
    !
    ! The error and some context (integration step, N⊥, α)
    ! is logged to the stderr using the logger module.

    use const_and_precisions, only : wp_

    ! subroutines arguments
    integer,       intent(in) :: error, step
    complex(wp_),  intent(in) :: Npr
    real(wp_),     intent(in) :: alpha

    ! local variables
    integer :: slice        ! a slice of the bitmask
    character(256) :: line  ! formatted log line
    type(error_spec) :: spec
    integer :: i, j

    ! format specifier of the log line
    character(*), parameter :: fmt = &
      '(a,": ", "error=",g0, " N⊥=",f0.0,sp,f0.0,"i", " α=",g0, " step=",g0)'

    ! iterate on the known errors
    do i = 1, size(ecrh_cd_errors)
      spec = ecrh_cd_errors(i)
      slice = ibits(error, spec%offset, spec%subcases)
      if (slice == 0) cycle

      ! iterate on the subcases
      do j = 0, spec%subcases - 1
        if (ibits(slice, j, 1) == 0) cycle
        write(line, fmt) trim(spec%msg(j)), slice * 2**j, &
                         Npr%re, Npr%im, alpha, step
        call log_error(line, mod=spec%mod, proc=spec%proc)
      end do
    end do
  end subroutine print_err_ecrh_cd

end module gray_errors