! Module  : utest_photgrid_m
! Purpose : Testing routines for utest_photgrid
!
! 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_photgrid_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 = 6

      type(photgrid_t) :: pg
      integer          :: stat(n)
      integer          :: stat_chk(n)
      real(RD)         :: x_vec(2,n)
      real(RD)         :: mu(n)

      print *, '  exceptions'

      call load_photgrid_from_specgrid('sg-demo.h5', 'pb-Generic-Johnson.V-Vega.h5', pg)
      
      call stat_arrange_()
      call stat_act_()
      call stat_assert_()

      ! Finish

      return

   contains

      subroutine stat_arrange_()

         integer  :: j

         ! Set up default (good) params

         do j = 1, n
            call set_xvec(pg, ['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(pg, ['Teff  ', 'log(g)'], [2000._RD, 4.00_RD], x_vec(:,2))
         stat_chk(2) = STAT_OUT_OF_BOUNDS_AXIS_LO

         !

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

         !

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

         !

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

         !

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

         ! Finish

         return

      end subroutine stat_arrange_

      !****

      subroutine stat_act_()

         integer  :: j
         real(RD) :: I

         do j = 1, n

            call pg%interp_intensity(x_vec(:,j), mu(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(photgrid_t) :: pg

      integer  :: rank
      integer  :: rank_chk
      integer  :: cache_limit
      integer  :: cache_limit_chk
 
      print *, '  attributes'

      call load_photgrid_from_specgrid('sg-demo.h5', 'pb-Generic-Johnson.V-Vega.h5', pg)
      
      call attr_arrange_()
      call attr_act_()
      call attr_assert_()

      ! Finish

      return

   contains

      subroutine attr_arrange_()

         ! Set up the demo grid attributes

         rank_chk = 2

         cache_limit_chk = 128

         ! Finish

      end subroutine attr_arrange_

      !****

      subroutine attr_act_()

         ! Get attributes

         call pg%get_rank(rank)

         call pg%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 (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_()

      type(photgrid_t) :: pg
      real(RD)         :: x_vec(2)
      real(RD)         :: I
      real(RD)         :: I_chk
      real(RD)         :: E
      real(RD)         :: E_chk
      real(RD)         :: D
      real(RD)         :: D_chk
      real(RD)         :: F
      real(RD)         :: F_chk
 
      print *, '  interpolation'

      call load_photgrid_from_specgrid('sg-demo.h5', 'pb-Generic-Johnson.V-Vega.h5', pg)
      
      call interp_arrange_()
      call interp_act_()
      call interp_assert_()

      ! Finish

      return

   contains

      subroutine interp_arrange_()

         ! Set up interpolations

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

         I_chk = 5337442669216122.0_RD
         E_chk = 1437915796284651.0_RD
         D_chk = 870305946838468.75_RD

         F_chk = 18069382808354304._RD

         ! Finish

         return

      end subroutine interp_arrange_

      !****

      subroutine interp_act_()

         ! Perform interoplations

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

         call pg%interp_flux(x_vec, F)
         
         ! Finish

         return

      end subroutine interp_act_

      !****

      subroutine interp_assert_()

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

         real(RD) :: I_err
         real(RD) :: E_err
         real(RD) :: D_err
         real(RD) :: F_err

         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 (ABS(I_err) < tol) then
            print *,'    PASS intensity'
         else
            print *,'    FAIL intensity:', ABS(I_err), '>', tol
         end if
            
         if (ABS(E_err) < tol) then
            print *,'    PASS E_moment'
         else
            print *,'    FAIL E_moment:', ABS(E_err), '>', tol
         end if
            
         if (ABS(D_err) < tol) then
            print *,'    PASS D_moment'
         else
            print *,'    FAIL D_moment:', ABS(D_err), '>', tol
         end if
            
         if (ABS(F_err) < tol) then
            print *,'    PASS flux'
         else
            print *,'    FAIL flux:', ABS(F_err), '>', tol
         end if
            
         ! Finish

         return

      end subroutine interp_assert_

   end subroutine test_interp_

   !****

   subroutine set_xvec(pg, labels, values, x_vec)

      type(photgrid_t), intent(inout) :: pg
      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 pg%get_rank(n)

      @:CHECK_BOUNDS(n, SIZE(labels))

      do j = 1, n

         call pg%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_photgrid_m
