! Module  : utest_specgrid_m
! Purpose : Testing routines for utest_specgrid
!
! Copyright 2021-2022 Rich Townsend & The MSG Team
!
! This file is part of MSG. MSG is free software: you can redistribute
! it and/or modify it under the terms of the GNU General Public
! License as published by the Free Software Foundation, version 3.
!
! MSG 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 General Public
! License for more details.
!
! You should have received a copy of the GNU General Public License
! along with this program.  If not, see <http://www.gnu.org/licenses/>.

#:include 'forum.inc'

module utest_specgrid_m

   ! Uses
   
   use forum_m
   use fmsg_m

   use ISO_FORTRAN_ENV

   ! No implicit typing

   implicit none

   ! Access specifiers

   private

   public :: test


contains

   subroutine test ()

      call test_stat_()
      call test_attr_()
      call test_interp_()

   end subroutine test

   !****

   subroutine test_stat_()

      integer, parameter :: n = 8
      integer, parameter :: n_lam = 501

      type(specgrid_t) :: sg
      integer          :: stat(n)
      integer          :: stat_chk(n)
      real(RD)         :: lam(n_lam,n)
      real(RD)         :: x_vec(2,n)
      real(RD)         :: mu(n)

      print *, '  exceptions'

      call load_specgrid('sg-demo.h5', sg)
      
      call stat_arrange_()
      call stat_act_()
      call stat_assert_()

      ! Finish

      return

   contains

      subroutine stat_arrange_()

         integer  :: j
         integer  :: i

         ! Set up default (good) params

         do j = 1, n
            lam(:,j) = [((3000._RD*(n_lam-i) + 7000._RD*(i-1))/(n_lam-1), i=1,n_lam)]
            call set_xvec(sg, ['Teff  ', 'log(g)'], [10000._RD, 4.00_RD], x_vec(:,j))
            mu(j) = 0.5_RD
         end do

         ! Now modify to create exceptional cases

         !

         stat_chk(1) = STAT_OK

         !

         call set_xvec(sg, ['Teff  ', 'log(g)'], [2000._RD, 4.00_RD], x_vec(:,2))
         stat_chk(2) = STAT_OUT_OF_BOUNDS_AXIS_LO

         !

         call set_xvec(sg, ['Teff  ', 'log(g)'], [10000._RD, 6.00_RD], x_vec(:,3))
         stat_chk(3) = STAT_OUT_OF_BOUNDS_AXIS_HI

         !

         lam(1,4) = 2000._RD
         stat_chk(4) = STAT_OUT_OF_BOUNDS_LAM_LO

         !

         lam(n_lam,5) = 10000._RD
         stat_chk(5) = STAT_OUT_OF_BOUNDS_LAM_HI

         !

         mu(6) = -0.1_RD
         stat_chk(6) = STAT_OUT_OF_BOUNDS_MU_LO

         !

         mu(7) = 1.1_RD
         stat_chk(7) = STAT_OUT_OF_BOUNDS_MU_HI

         !

         call set_xvec(sg, ['Teff  ', 'log(g)'], [40000._RD, 2.00_RD], x_vec(:,8))
         stat_chk(8) = STAT_UNAVAILABLE_DATA

         ! Finish

         return

      end subroutine stat_arrange_

      !****

      subroutine stat_act_()

         integer  :: j
         real(RD) :: I(n_lam-1)

         do j = 1, n

            call sg%interp_intensity(x_vec(:,j), mu(j), lam(:,j), I, stat(j))

         end do

         ! Finish

         return

      end subroutine stat_act_

      !****

      subroutine stat_assert_()

         integer :: j

         do j = 1, n
            if (stat(j) /= stat_chk(j)) then
               print *,'    FAIL:', stat(j), '/=', stat_chk(j)
            else
               print *,'    PASS'
            end if
         end do
               
         ! Finish

         return

      end subroutine stat_assert_

   end subroutine test_stat_

   !****

   subroutine test_attr_()

      type(specgrid_t) :: sg
      integer          :: rank
      integer          :: rank_chk
      real(RD)         :: lam_min
      real(RD)         :: lam_max
      real(RD)         :: lam_min_chk
      real(RD)         :: lam_max_chk
      real(RD)         :: cache_lam_min
      real(RD)         :: cache_lam_max
      real(RD)         :: cache_lam_min_chk
      real(RD)         :: cache_lam_max_chk
      integer          :: cache_limit
      integer          :: cache_limit_chk
 
      print *, '  attributes'

      call load_specgrid('sg-demo.h5', sg)
      
      call attr_arrange_()
      call attr_act_()
      call attr_assert_()

      ! Finish

      return

   contains

      subroutine attr_arrange_()

         ! Set up the demo grid attributes

         rank_chk = 2

         lam_min_chk = 2999.9999999999977_RD
         lam_max_chk = 9003.4900785147820_RD

         cache_lam_min_chk = lam_min_chk
         cache_lam_max_chk = lam_max_chk

         cache_limit_chk = 128

         ! Finish

         return

      end subroutine attr_arrange_

      !****

      subroutine attr_act_()

         ! Get attributes

         call sg%get_rank(rank)

         call sg%get_lam_min(lam_min)
         call sg%get_lam_max(lam_max)

         call sg%get_cache_lam_min(cache_lam_min)
         call sg%get_cache_lam_max(cache_lam_max)

         call sg%get_cache_limit(cache_limit)

         ! Finish

         return

      end subroutine attr_act_

      !****

      subroutine attr_assert_()

         if (rank == rank_chk) then
            print *,'    PASS rank'
         else
            print *,'    FAIL rank:', rank, '/=', rank_chk
         end if
            
         if (lam_min == lam_min_chk) then
            print *,'    PASS lam_min'
         else
            print *,'    FAIL lam_min:', lam_min, '/=', lam_min_chk
         end if
            
         if (lam_max == lam_max_chk) then
            print *,'    PASS lam_max'
         else
            print *,'    FAIL lam_max:', lam_max, '/=', lam_max_chk
         end if
            
         if (cache_lam_min == cache_lam_min_chk) then
            print *,'    PASS cache_lam_min'
         else
            print *,'    FAIL cache_lam_min:', cache_lam_min, '/=', cache_lam_min_chk
         end if
            
         if (cache_lam_max == cache_lam_max_chk) then
            print *,'    PASS cache_lam_max'
         else
            print *,'    FAIL cache_lam_max:', cache_lam_max, '/=', cache_lam_max_chk
         end if
            
         if (cache_limit == cache_limit_chk) then
            print *,'    PASS cache_limit'
         else
            print *,'    FAIL cache_limit:', cache_limit, '/=', cache_limit_chk
         end if

         ! Finish

         return

      end subroutine attr_assert_

   end subroutine test_attr_

   !****

   subroutine test_interp_()

      integer, parameter :: n_lam = 3

      type(specgrid_t) :: sg
      real(RD)         :: x_vec(2)
      real(RD)         :: lam(n_lam)
      real(RD)         :: I(n_lam-1)
      real(RD)         :: I_chk(n_lam-1)
      real(RD)         :: E(n_lam-1)
      real(RD)         :: E_chk(n_lam-1)
      real(RD)         :: D(n_lam-1)
      real(RD)         :: D_chk(n_lam-1)
      real(RD)         :: F(n_lam-1)
      real(RD)         :: F_chk(n_lam-1)
 
      print *, '  interpolation'

      call load_specgrid('sg-demo.h5', sg)
      
      call interp_arrange_()
      call interp_act_()
      call interp_assert_()

      ! Finish

      return

   contains

      subroutine interp_arrange_()

         ! Set up interpolations

         call set_xvec(sg, ['Teff  ', 'log(g)'], [10000._RD, 4.00_RD], x_vec)

         lam = [3000._RD, 5000._RD, 7000._RD]

         I_chk = [28030282.999992810_RD, 15241389.849050688_RD]
         E_chk = [7692392.4361349288_RD, 4084491.8724862086_RD]
         D_chk = [4811175.9311023634_RD, 2442872.3012035391_RD]

         F_chk = [96665454.263564929_RD, 51327238.640999608_RD]

         ! Finish

         return

      end subroutine interp_arrange_

      !****

      subroutine interp_act_()

         ! Perform interoplations

         call sg%interp_intensity(x_vec, 0.5_RD, lam, I)
         call sg%interp_E_moment(x_vec, 1, lam, E)
         call sg%interp_D_moment(x_vec, 2, lam, D)

         call sg%interp_flux(x_vec, lam, F)
         
         ! Finish

         return

      end subroutine interp_act_

      !****

      subroutine interp_assert_()

         real(RD), parameter :: tol = 1E-14_RD

         real(RD) :: I_err(n_lam-1)
         real(RD) :: E_err(n_lam-1)
         real(RD) :: D_err(n_lam-1)
         real(RD) :: F_err(n_lam-1)

         I_err = (I - I_chk)/I_chk
         E_err = (E - E_chk)/E_chk
         D_err = (D - D_chk)/D_chk
         F_err = (F - F_chk)/F_chk

         if (ALL(ABS(I_err) < tol)) then
            print *,'    PASS intensity'
         else
            print *,'    FAIL intensity:', MAXVAL(ABS(I_err)), '>', tol
         end if
            
         if (ALL(ABS(E_err) < tol)) then
            print *,'    PASS E_moment'
         else
            print *,'    FAIL E_moment:', MAXVAL(ABS(E_err)), '>', tol
         end if
            
         if (ALL(ABS(D_err) < tol)) then
            print *,'    PASS D_moment'
         else
            print *,'    FAIL D_moment:', MAXVAL(ABS(D_err)), '>', tol
         end if
            
         if (ALL(ABS(F_err) < tol)) then
            print *,'    PASS flux'
         else
            print *,'    FAIL flux:', MAXVAL(ABS(F_err)), '>', tol
         end if
            
         ! Finish

         return

      end subroutine interp_assert_

   end subroutine test_interp_

   !****

   subroutine set_xvec(sg, labels, values, x_vec)

      type(specgrid_t), intent(inout) :: sg
      character(*), intent(in)        :: labels(:)
      real(RD), intent(in)            :: values(:)
      real(RD), intent(out)           :: x_vec(:)

      type(axis_t)         :: ax
      character(LABEL_LEN) :: axis_label
      integer              :: n
      integer              :: j
      integer              :: k

      @:CHECK_BOUNDS(SIZE(values), SIZE(labels))
      @:CHECK_BOUNDS(SIZE(x_vec), SIZE(labels))

      ! Set x_vec based on a set of labels and values

      call sg%get_rank(n)

      @:CHECK_BOUNDS(n, SIZE(labels))

      do j = 1, n

         call sg%get_axis(j, ax)
         call ax%get_label(axis_label)

         do k = 1, n
            if (labels(k) == axis_label) then
               x_vec(j) = values(k)
               exit
            end if
         end do

         @:ASSERT(k <= n, 'no matching axis label found')

      end do

      ! Finish

      return

   end subroutine set_xvec

end module utest_specgrid_m
