! Copyright (c) 2016 Alex Kramer <kramer.alex.kramer@gmail.com>
! See the LICENSE.txt file in the top-level directory of this distribution

! Methods to verify the stability of the Thomas algorithm for solving
! tridiagonal systems. The Thomas algorithm is stable if the tridiagonal
! system to be solved is diagonally dominant (either row- or column-wise), or
! if the system is positive semidefinite. This module does not diagonalize
! the tridiagonal system or compute its Cholesky factorization, etc., so it
! only tests for diagonal dominance.
!
! This module provides the following subroutines:
!
! tridiag_stable_gen(...) -> general tridiagonal matrix
! tridiag_stable_cnst(...) -> all elements constant, band-wise
! tridiag_stable_cnst_diag(...) -> diagonal elements constant
! tridiag_stable_cnst_odiag(...) -> off_diagonal elements constant, band-wise
!
! tridiag_stable_sym(...) -> symmetric tridiagonal matrix
! tridiag_stable_sym_cnst(...) -> symmetric, all elements constant, band-wise
! tridiag_stable_sym_cnst_diag(..) -> symmetric, diagonal elements constant
! tridag_stable_sym_cnst_odiag(...) -> symmetric, off-diagonal elements
!   constant, band-wise
!
! Note that the methods for symmetric tridiagonal matrices are simply wrappers
! around the methods for the more general asymmetric case. There are currently
! no symemtry-specific numerical approximations.
module tridiag_stable

  ! Numeric precision parameters
  use iso_fortran_env, only: sp=>real32, dp=>real64, ip=>int32

  implicit none
  private

  public :: tridiag_stable_gen
  interface tridiag_stable_gen
     ! General tridiagonal matrix
     module procedure tridiag_stable_gen_real_dp
     module procedure tridiag_stable_gen_cmplx_dp
     module procedure tridiag_stable_gen_real_sp
     module procedure tridiag_stable_gen_cmplx_sp
  end interface tridiag_stable_gen

  public :: tridiag_stable_cnst
  interface tridiag_stable_cnst
     ! Tridiagonal matrix where all elements are equal, band-wise
     module procedure tridiag_stable_cnst_real_dp
     module procedure tridiag_stable_cnst_cmplx_dp
     module procedure tridiag_stable_cnst_real_sp
     module procedure tridiag_stable_cnst_cmplx_sp
  end interface tridiag_stable_cnst

  public :: tridiag_stable_cnst_diag
  interface tridiag_stable_cnst_diag
     ! Tridiagonal matrix where diagonal elements are equal
     module procedure tridiag_stable_cnst_diag_real_dp
     module procedure tridiag_stable_cnst_diag_cmplx_dp
     module procedure tridiag_stable_cnst_diag_real_sp
     module procedure tridiag_stable_cnst_diag_cmplx_sp
  end interface tridiag_stable_cnst_diag

  public :: tridiag_stable_cnst_odiag
  interface tridiag_stable_cnst_odiag
     ! Tridiagonal matrix where off-diagonal elements are equal, band-wise
     module procedure tridiag_stable_cnst_odiag_real_dp
     module procedure tridiag_stable_cnst_odiag_cmplx_dp
     module procedure tridiag_stable_cnst_odiag_real_sp
     module procedure tridiag_stable_cnst_odiag_cmplx_sp
  end interface tridiag_stable_cnst_odiag

  public :: tridiag_stable_sym
  interface tridiag_stable_sym
     ! Symmetric tridiagonal matrix
     module procedure tridiag_stable_sym_real_dp
     module procedure tridiag_stable_sym_cmplx_dp
     module procedure tridiag_stable_sym_real_sp
     module procedure tridiag_stable_sym_cmplx_sp
  end interface tridiag_stable_sym

  public :: tridiag_stable_sym_cnst
  interface tridiag_stable_sym_cnst
     ! Symmetric tridiagonal matrix where all elements are equal, band-wise
     module procedure tridiag_stable_sym_cnst_real_dp
     module procedure tridiag_stable_sym_cnst_cmplx_dp
     module procedure tridiag_stable_sym_cnst_real_sp
     module procedure tridiag_stable_sym_cnst_cmplx_sp
  end interface tridiag_stable_sym_cnst

  public :: tridiag_stable_sym_cnst_diag
  interface tridiag_stable_sym_cnst_diag
     ! Symmetric tridiagonal matrix where diagonal elements are equal
     module procedure tridiag_stable_sym_cnst_diag_real_dp
     module procedure tridiag_stable_sym_cnst_diag_cmplx_dp
     module procedure tridiag_stable_sym_cnst_diag_real_sp
     module procedure tridiag_stable_sym_cnst_diag_cmplx_sp
  end interface tridiag_stable_sym_cnst_diag

  public :: tridiag_stable_sym_cnst_odiag
  interface tridiag_stable_sym_cnst_odiag
     ! Symmetric tridiagonal matrix where off-diagonal elements are equal,
     ! band-wise
     module procedure tridiag_stable_sym_cnst_odiag_real_dp
     module procedure tridiag_stable_sym_cnst_odiag_cmplx_dp
     module procedure tridiag_stable_sym_cnst_odiag_real_sp
     module procedure tridiag_stable_sym_cnst_odiag_cmplx_sp
  end interface tridiag_stable_sym_cnst_odiag

contains

  ! subroutine tridiag_stable_gen
  !
  ! General tridiagonal system
  !
  ! diag(n) :: diagonal entries
  ! u_diag(n - 1) :: upper diagonal entries
  ! l_diag(n - 1) :: lower diagonal entries

  ! tridiag_stable_gen definition for double-precision real values
  logical function tridiag_stable_gen_real_dp(diag, u_diag, l_diag) &
       result(val)
    real(dp), intent(in) :: diag(:)
    real(dp), intent(in) :: u_diag(size(diag)), l_diag(size(diag))
    integer(ip), parameter :: fp = dp

    include "./tridiag_stable_src/gen.src"
  end function tridiag_stable_gen_real_dp

  ! tridiag_stable_gen definition for double-precision complex values
  logical function tridiag_stable_gen_cmplx_dp(diag, u_diag, l_diag) &
       result(val)
    complex(dp), intent(in) :: diag(:)
    complex(dp), intent(in) :: u_diag(size(diag)), l_diag(size(diag))
    integer(ip), parameter :: fp = dp

    include "./tridiag_stable_src/gen.src"
  end function tridiag_stable_gen_cmplx_dp

  ! tridiag_stable_gen definition for single-precision real values
  logical function tridiag_stable_gen_real_sp(diag, u_diag, l_diag) &
       result(val)
    real(sp), intent(in) :: diag(:)
    real(sp), intent(in) :: u_diag(size(diag)), l_diag(size(diag))
    integer(ip), parameter :: fp = sp

    include "./tridiag_stable_src/gen.src"
  end function tridiag_stable_gen_real_sp

  ! tridiag_stable_gen definition for single-precision complex values
  logical function tridiag_stable_gen_cmplx_sp(diag, u_diag, l_diag) &
       result(val)
    complex(sp), intent(in) :: diag(:)
    complex(sp), intent(in) :: u_diag(size(diag)), l_diag(size(diag))
    integer(ip), parameter :: fp = sp

    include "./tridiag_stable_src/gen.src"
  end function tridiag_stable_gen_cmplx_sp

  ! subroutine tridiag_stable_cnst
  !
  ! Tridiagonal matrix where all band-elements are equal (band-wise)
  !
  ! diag_cnst :: diagonal entry
  ! u_diag_cnst :: upper diagonal entry
  ! l_diag_cnst :: lower diagonal entry

  ! tridiag_stable_cnst definition for double-precision real values
  logical function tridiag_stable_cnst_real_dp(diag_cnst, u_diag_cnst, &
       l_diag_cnst) result(val)
    real(dp), intent(in) :: diag_cnst, u_diag_cnst, l_diag_cnst

    include "./tridiag_stable_src/cnst.src"
  end function tridiag_stable_cnst_real_dp

  ! tridiag_stable_cnst definition for double-precision complex values
  logical function tridiag_stable_cnst_cmplx_dp(diag_cnst, u_diag_cnst, &
       l_diag_cnst) result(val)
    complex(dp), intent(in) :: diag_cnst, u_diag_cnst, l_diag_cnst

    include "./tridiag_stable_src/cnst.src"
  end function tridiag_stable_cnst_cmplx_dp

  ! tridiag_stable_cnst definition for single-precision real values
  logical function tridiag_stable_cnst_real_sp(diag_cnst, u_diag_cnst, &
       l_diag_cnst) result(val)
    real(sp), intent(in) :: diag_cnst, u_diag_cnst, l_diag_cnst

    include "./tridiag_stable_src/cnst.src"
  end function tridiag_stable_cnst_real_sp

  ! tridiag_stable_cnst definition for single-precision complex values
  logical function tridiag_stable_cnst_cmplx_sp(diag_cnst, u_diag_cnst, &
       l_diag_cnst) result(val)
    complex(sp), intent(in) :: diag_cnst, u_diag_cnst, l_diag_cnst

    include "./tridiag_stable_src/cnst.src"
  end function tridiag_stable_cnst_cmplx_sp

  ! subroutine tridiag_cnst_diag
  !
  ! Tridiagonal system where diagonal elements are constant
  !
  ! diag_cnst :: diagonal entry
  ! u_diag(n - 1) :: upper diagonal entries
  ! l_diag(n - 1) :: lower diagonal entries

  ! tridiag_stable_cnst_diag definition for double-precision real values
  logical function tridiag_stable_cnst_diag_real_dp(diag_cnst, u_diag, &
       l_diag) result(val)
    real(dp), intent(in) :: u_diag(:)
    real(dp), intent(in) :: l_diag(size(u_diag)), diag_cnst
    integer(ip), parameter :: fp = dp

    include "./tridiag_stable_src/cnst_diag.src"
  end function tridiag_stable_cnst_diag_real_dp

  ! tridiag_stable_cnst_diag definition for double-precision complex values
  logical function tridiag_stable_cnst_diag_cmplx_dp(diag_cnst, u_diag, &
       l_diag) result(val)
    complex(dp), intent(in) :: u_diag(:)
    complex(dp), intent(in) :: l_diag(size(u_diag)), diag_cnst
    integer(ip), parameter :: fp = dp

    include "./tridiag_stable_src/cnst_diag.src"
  end function tridiag_stable_cnst_diag_cmplx_dp

  ! tridiag_stable_cnst_diag definition for single-precision real values
  logical function tridiag_stable_cnst_diag_real_sp(diag_cnst, u_diag, &
       l_diag) result(val)
    real(sp), intent(in) :: u_diag(:)
    real(sp), intent(in) :: l_diag(size(u_diag)), diag_cnst
    integer(ip), parameter :: fp = sp

    include "./tridiag_stable_src/cnst_diag.src"
  end function tridiag_stable_cnst_diag_real_sp

  ! tridiag_stable_cnst_diag definition for single-precision complex values
  logical function tridiag_stable_cnst_diag_cmplx_sp(diag_cnst, u_diag, &
       l_diag) result(val)
    complex(sp), intent(in) :: u_diag(:)
    complex(sp), intent(in) :: l_diag(size(u_diag)), diag_cnst
    integer(ip), parameter :: fp = sp

    include "./tridiag_stable_src/cnst_diag.src"
  end function tridiag_stable_cnst_diag_cmplx_sp

  ! subroutine tridiag_cnst_odiag
  !
  ! Tridiagonal system where off-diagonal elements are constant, band-wise
  !
  ! diag(n) :: diagonal entries
  ! u_diag_cnst :: upper diagonal entry
  ! l_diag_cnst :: lower diagonal entry

  ! tridiag_stable_cnst_odiag definition for double-precision real values
  logical function tridiag_stable_cnst_odiag_real_dp(diag, u_diag_cnst, &
       l_diag_cnst) result(val)
    real(dp), intent(in) :: diag(:), u_diag_cnst, l_diag_cnst
    integer(ip), parameter :: fp = dp

    include "./tridiag_stable_src/cnst_odiag.src"
  end function tridiag_stable_cnst_odiag_real_dp

  ! tridiag_stable_cnst_odiag definition for double-precision complex values
  logical function tridiag_stable_cnst_odiag_cmplx_dp(diag, u_diag_cnst, &
       l_diag_cnst) result(val)
    complex(dp), intent(in) :: diag(:), u_diag_cnst, l_diag_cnst
    integer(ip), parameter :: fp = dp

    include "./tridiag_stable_src/cnst_odiag.src"
  end function tridiag_stable_cnst_odiag_cmplx_dp

  ! tridiag_stable_cnst_odiag definition for single-precision real values
  logical function tridiag_stable_cnst_odiag_real_sp(diag, u_diag_cnst, &
       l_diag_cnst) result(val)
    real(sp), intent(in) :: diag(:), u_diag_cnst, l_diag_cnst
    integer(ip), parameter :: fp = sp

    include "./tridiag_stable_src/cnst_odiag.src"
  end function tridiag_stable_cnst_odiag_real_sp

  ! tridiag_stable_cnst_odiag definition for single-precision complex values
  logical function tridiag_stable_cnst_odiag_cmplx_sp(diag, u_diag_cnst, &
       l_diag_cnst) result(val)
    complex(sp), intent(in) :: diag(:), u_diag_cnst, l_diag_cnst
    integer(ip), parameter :: fp = sp

    include "./tridiag_stable_src/cnst_odiag.src"
  end function tridiag_stable_cnst_odiag_cmplx_sp

  ! subroutine tridiag_stable_sym
  !
  ! Symmetric tridiagonal system
  !
  ! diag(n) :: diagonal entries
  ! o_diag(n - 1) :: off-diagonal entries

  ! tridiag_stable_sym definition for double-precision real values
  logical function tridiag_stable_sym_real_dp(diag, o_diag) result(val)
    real(dp), intent(in) :: diag(:)
    real(dp), intent(in) :: o_diag(size(diag))

    include "./tridiag_stable_src/sym.src"
  end function tridiag_stable_sym_real_dp

  ! tridiag_stable_sym definition for double-precision complex values
  logical function tridiag_stable_sym_cmplx_dp(diag, o_diag) result(val)
    complex(dp), intent(in) :: diag(:)
    complex(dp), intent(in) :: o_diag(size(diag))

    include "./tridiag_stable_src/sym.src"
  end function tridiag_stable_sym_cmplx_dp

  ! tridiag_stable_sym definition for single-precision real values
  logical function tridiag_stable_sym_real_sp(diag, o_diag) result(val)
    real(sp), intent(in) :: diag(:)
    real(sp), intent(in) :: o_diag(size(diag))

    include "./tridiag_stable_src/sym.src"
  end function tridiag_stable_sym_real_sp

  ! tridiag_stable_sym definition for single-precision complex values
  logical function tridiag_stable_sym_cmplx_sp(diag, o_diag) result(val)
    complex(sp), intent(in) :: diag(:)
    complex(sp), intent(in) :: o_diag(size(diag))

    include "./tridiag_stable_src/sym.src"
  end function tridiag_stable_sym_cmplx_sp

  ! subroutine tridiag_stable_sym_cnst
  !
  ! Symmetric tridiagonal system where all elements are equal, band-wise
  !
  ! diag_cnst :: diagonal entry
  ! o_diag_cnst :: off-diagonal entries

  ! tridiag_stable_sym_cnst definition for double-precision real values
  logical function tridiag_stable_sym_cnst_real_dp(diag_cnst, &
       o_diag_cnst) result(val)
    real(dp), intent(in) :: diag_cnst, o_diag_cnst

    include "./tridiag_stable_src/sym_cnst.src"
  end function tridiag_stable_sym_cnst_real_dp

  ! tridiag_stable_sym_cnst definition for double-precision complex values
  logical function tridiag_stable_sym_cnst_cmplx_dp(diag_cnst, &
       o_diag_cnst) result(val)
    complex(dp), intent(in) :: diag_cnst, o_diag_cnst

    include "./tridiag_stable_src/sym_cnst.src"
  end function tridiag_stable_sym_cnst_cmplx_dp

  ! tridiag_stable_sym_cnst definition for single-precision real values
  logical function tridiag_stable_sym_cnst_real_sp(diag_cnst, &
       o_diag_cnst) result(val)
    real(sp), intent(in) :: diag_cnst, o_diag_cnst

    include "./tridiag_stable_src/sym_cnst.src"
  end function tridiag_stable_sym_cnst_real_sp

  ! tridiag_stable_sym_cnst definition for single-precision complex values
  logical function tridiag_stable_sym_cnst_cmplx_sp(diag_cnst, &
       o_diag_cnst) result(val)
    complex(sp), intent(in) :: diag_cnst, o_diag_cnst

    include "./tridiag_stable_src/sym_cnst.src"
  end function tridiag_stable_sym_cnst_cmplx_sp

  ! subroutine tridiag_stable_sym_cnst_diag
  !
  ! Symmetric tridiagonal system with constant diagonal entries
  !
  ! diag_cnst :: diagonal entry
  ! o_diag(n - 1) :: off-diagonal entries

  ! tridiag_stable_sym_cnst_diag definition for double-precision real values
  logical function tridiag_stable_sym_cnst_diag_real_dp(diag_cnst, o_diag) &
       result(val)
    real(dp), intent(in) :: diag_cnst, o_diag(:)

    include "./tridiag_stable_src/sym_cnst_diag.src"
  end function tridiag_stable_sym_cnst_diag_real_dp

  ! tridiag_stable_sym_cnst_diag definition for double-precision complex values
  logical function tridiag_stable_sym_cnst_diag_cmplx_dp(diag_cnst, o_diag) &
       result(val)
    complex(dp), intent(in) :: diag_cnst, o_diag(:)

    include "./tridiag_stable_src/sym_cnst_diag.src"
  end function tridiag_stable_sym_cnst_diag_cmplx_dp

  ! tridiag_stable_sym_cnst_diag definition for single-precision real values
  logical function tridiag_stable_sym_cnst_diag_real_sp(diag_cnst, o_diag) &
       result(val)
    real(sp), intent(in) :: diag_cnst, o_diag(:)

    include "./tridiag_stable_src/sym_cnst_diag.src"
  end function tridiag_stable_sym_cnst_diag_real_sp

  ! tridiag_stable_sym_cnst_diag definition for single-precision complex values
  logical function tridiag_stable_sym_cnst_diag_cmplx_sp(diag_cnst, o_diag) &
       result(val)
    complex(sp), intent(in) :: diag_cnst, o_diag(:)

    include "./tridiag_stable_src/sym_cnst_diag.src"
  end function tridiag_stable_sym_cnst_diag_cmplx_sp

  ! subroutine tridiag_stable_sym_cnst_odiag
  !
  ! Symmetric tridiagonal system with constant off-diagonal entries
  !
  ! diag(n) :: diagonal entries
  ! o_diag_cnst :: off-diagonal entry

  ! tridiag_stable_sym_cnst_odiag definition for double-precision real values
  logical function tridiag_stable_sym_cnst_odiag_real_dp(diag, o_diag_cnst) &
       result(val)
    real(dp), intent(in) :: diag(:), o_diag_cnst

    include "./tridiag_stable_src/sym_cnst_odiag.src"
  end function tridiag_stable_sym_cnst_odiag_real_dp

  ! tridiag_stable_sym_cnst_odiag definition for double-precision complex
  ! values
  logical function tridiag_stable_sym_cnst_odiag_cmplx_dp(diag, o_diag_cnst) &
       result(val)
    complex(dp), intent(in) :: diag(:), o_diag_cnst

    include "./tridiag_stable_src/sym_cnst_odiag.src"
  end function tridiag_stable_sym_cnst_odiag_cmplx_dp

  ! tridiag_stable_sym_cnst_odiag definition for single-precision real values
  logical function tridiag_stable_sym_cnst_odiag_real_sp(diag, o_diag_cnst) &
       result(val)
    real(sp), intent(in) :: diag(:), o_diag_cnst

    include "./tridiag_stable_src/sym_cnst_odiag.src"
  end function tridiag_stable_sym_cnst_odiag_real_sp

  ! tridiag_stable_sym_cnst_odiag definition for single-precision complex
  ! values
  logical function tridiag_stable_sym_cnst_odiag_cmplx_sp(diag, o_diag_cnst) &
       result(val)
    complex(sp), intent(in) :: diag(:), o_diag_cnst

    include "./tridiag_stable_src/sym_cnst_odiag.src"
  end function tridiag_stable_sym_cnst_odiag_cmplx_sp

end module tridiag_stable


      subroutine fclaw2d_clawpatch46_fort_tag4refinement(mx,my,mbc,
     &      meqn, xlower,ylower,dx,dy,blockno,
     &      q, tag_threshold, init_flag, tag_patch)
      implicit none

      integer mx,my, mbc, meqn, tag_patch, init_flag
      integer blockno
      double precision xlower, ylower, dx, dy
      double precision tag_threshold
      double precision q(1-mbc:mx+mbc,1-mbc:my+mbc,meqn)

      integer i,j, mq
      double precision qmin, qmax

      integer exceeds_th, fclaw2d_clawpatch_exceeds_threshold
      integer ii,jj
      double precision xc,yc,quad(-1:1,-1:1), qval

      logical(kind=4) :: is_ghost, fclaw2d_clawpatch46_is_ghost

c     # Assume that we won't refine
      tag_patch = 0

c     # Default : Refinement based only on first variable in system.
c     # Users can modify this by creating a local copy of this routine
c     # and the corresponding tag4coarsening routine.

      mq = 1
      qmin = q(1,1,mq)
      qmax = q(1,1,mq)
      do j = 1-mbc,my+mbc
         do i = 1-mbc,mx+mbc
            xc = xlower + (i-0.5)*dx
            yc = ylower + (j-0.5)*dy
            qmin = min(qmin,q(i,j,mq))
            qmax = max(qmax,q(i,j,mq))
            qval = q(i,j,mq)
            is_ghost = fclaw2d_clawpatch46_is_ghost(i,j,mx,my)
            if (.not. is_ghost) then
               do jj = -1,1
                  do ii = -1,1
                     quad(ii,jj) = q(i+ii,j+jj,mq)
                  end do
               end do
            endif
            exceeds_th = fclaw2d_clawpatch_exceeds_threshold(
     &             blockno, qval,qmin,qmax,quad, dx,dy,xc,yc,
     &             tag_threshold,init_flag, is_ghost)
c           # -1 : Not conclusive (possibly ghost cell); don't tag for refinement
c           # 0  : Does not pass threshold (don't tag for refinement)
c           # 1  : Passes threshold (tag for refinement)
            if (exceeds_th .gt. 0) then
               tag_patch = 1
               return
            endif
         enddo
      enddo

      end

c     # We may want to check ghost cells for tagging.
      logical(kind=4) function fclaw2d_clawpatch46_is_ghost(i,j,mx,my)
         implicit none

         integer i, j, mx, my
         logical(kind=4) :: is_ghost

         is_ghost = .false.
         if (i .lt. 1 .or. j .lt. 1) then
            is_ghost = .true.
         elseif (i .gt. mx .or. j .gt. my) then
            is_ghost = .true.
         end if

         fclaw2d_clawpatch46_is_ghost = is_ghost

         return

      end


! 8. Write a function on_all that applies a function to every element of a list.
! Use it to print the first twenty perfect squares. The perfect squares can be found by multiplying each natural number with itself.
! The first few perfect squares are 1*1= 1, 2*2=4, 3*3=9, 4*4=16. Twelve for example is not a perfect square because there is no
! natural number m so that m*m=12. (This question is tricky if your programming language makes it difficult to pass functions as arguments.)

    program Exercises
        implicit none

        ! Fortran supports function pointers but as far as I know there isn't a way to pass them around without an explicit interface
        ! so we declare that here.
        abstract interface
            function contract(arg)
                integer :: contract
                integer, intent(in) :: arg
            end function contract
        end interface

        integer :: list(20)

        list = (/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20 /)
        call on_all(square, list)

    contains

        function square(arg) result(res)
            integer, intent(in) :: arg
            integer :: res

            res = arg * arg

        end function square

        subroutine on_all(fn, list)
            procedure(contract), pointer, intent(in) :: fn
            integer, dimension(:), intent(in) :: list
            integer :: i
            integer :: elementResult

            do i=1, size(list)
                elementResult = fn(list(i))
                print '(I0)', elementResult
            end do

        end subroutine on_all

    end program Exercises


! { dg-do run }
! Testcase for SIGN() with integer arguments
! Check that:
!   + SIGN() evaluates its arguments only once
!   + SIGN() works on large values
!   + SIGN() works with parameter arguments
! Contributed by FX Coudert <fxcoudert@gmail.com>
program sign1
  implicit none
  integer(kind=1), parameter :: one1 = 1_1, mone1 = -1_1
  integer(kind=2), parameter :: one2 = 1_2, mone2 = -1_2
  integer(kind=4), parameter :: one4 = 1_4, mone4 = -1_4
  integer(kind=8), parameter :: one8 = 1_8, mone8 = -1_8
  integer(kind=1) :: i1, j1
  integer(kind=2) :: i2, j2
  integer(kind=4) :: i4, j4
  integer(kind=8) :: i8, j8
  integer :: i = 1

  i1 = huge(0_1) ; j1 = -huge(0_1)
  if (sign(i1, j1) /= j1) call abort()
  if (sign(j1, i1) /= i1) call abort()
  if (sign(i1,one1) /= i1 .or. sign(j1,one1) /= i1) call abort()
  if (sign(i1,mone1) /= j1 .or. sign(j1,mone1) /= j1) call abort()

  i2 = huge(0_2) ; j2 = -huge(0_2)
  if (sign(i2, j2) /= j2) call abort()
  if (sign(j2, i2) /= i2) call abort()
  if (sign(i2,one2) /= i2 .or. sign(j2,one2) /= i2) call abort()
  if (sign(i2,mone2) /= j2 .or. sign(j2,mone2) /= j2) call abort()

  i4 = huge(0_4) ; j4 = -huge(0_4)
  if (sign(i4, j4) /= j4) call abort()
  if (sign(j4, i4) /= i4) call abort()
  if (sign(i4,one4) /= i4 .or. sign(j4,one4) /= i4) call abort()
  if (sign(i4,mone4) /= j4 .or. sign(j4,mone4) /= j4) call abort()

  i8 = huge(0_8) ; j8 = -huge(0_8)
  if (sign(i8, j8) /= j8) call abort()
  if (sign(j8, i8) /= i8) call abort()
  if (sign(i8,one8) /= i8 .or. sign(j8,one8) /= i8) call abort()
  if (sign(i8,mone8) /= j8 .or. sign(j8,mone8) /= j8) call abort()

  if (sign(foo(i), 1) /= 1) call abort
  if (sign(foo(i), -1) /= -2) call abort
  if (sign(42, foo(i)) /= 42) call abort
  if (sign(42, -foo(i)) /= -42) call abort
  if (i /= 5) call abort

  if (sign(bar(), 1) /= 1) call abort
  if (sign(bar(), -1) /= -2) call abort
  if (sign(17, bar()) /= 17) call abort
  if (sign(17, -bar()) /= -17) call abort
  if (bar() /= 5) call abort

contains

  integer function foo(i)
    integer :: i
    foo = i
    i = i + 1
  end function

  integer function bar()
    integer, save :: i = 0
    i = i + 1
    bar = i
  end function
end


module random_mod
    implicit none
    private
    public :: init_random_seed

contains

    subroutine init_random_seed()
        implicit none
        integer :: seed_dim, clock, i
        integer, dimension(:), allocatable :: seed
        call random_seed(size=seed_dim)
        allocate(seed(seed_dim))
        call system_clock(count=clock)
        seed = clock + 37*[ (i - 1, i = 1, seed_dim) ]
        call random_seed(put=seed)
        deallocate(seed)
    end subroutine init_random_seed

end module random_mod


module hse_bc_module

  use bl_types
  use bl_error_module
  use prob_params_module
  use eos_module, only : eos
  use eos_type_module, only : eos_t, eos_input_rt
  use bl_constants_module, only : ZERO, HALF

  use amrex_fort_module, only : rt => amrex_real
  implicit none

  integer, parameter :: MAX_ITER = 100
  real(rt)        , parameter :: TOL = 1.e-8_rt

contains

  ! this expects a 3-d problem
  subroutine hse_bc_zlo(adv,adv_l1,adv_l2,adv_l3,adv_h1,adv_h2,adv_h3, &
                        domlo,domhi,delta,xlo,time,bc,density_only)

    use probdata_module
    use meth_params_module, only : NVAR, URHO, UMX, UMY, UMZ, UEDEN, UEINT, &
                                   UFS, UTEMP, const_grav
    use network, only: nspec
    use amrex_fort_module, only : rt => amrex_real
    implicit none
    integer :: adv_l1, adv_l2, adv_l3, adv_h1, adv_h2, adv_h3
    integer :: bc(3,2,*)
    integer :: domlo(3), domhi(3)
    real(rt)         :: delta(3), xlo(3), time
    real(rt)         :: adv(adv_l1:adv_h1,adv_l2:adv_h2,adv_l3:adv_h3,NVAR)
    logical, intent(in), optional :: density_only

    integer :: i, j, k, iter
    real(rt)         :: z, z0, slope
    real(rt)         :: pres_above, p_want, pres_zone, A
    real(rt)         :: drho,dpdr, temp_zone, eint, X_zone(nspec), dens_zone

    logical :: just_density

    logical :: converged_hse

    type (eos_t) :: eos_state

    if (present(density_only)) then
       just_density = density_only
    else
       just_density = .false.
    endif

    if (just_density) then
       ! we cannot rely on any of the other state variables being
       ! initialized, so the only thing we can do here is extrapolate
       ! the density from the domain interior
       do j=adv_l2,adv_h2
          do i=adv_l1,adv_h1
             slope = (adv(i,j,domlo(3)+1,URHO) - adv(i,j,domlo(3),URHO))/delta(3)
             z0 = problo(3) + dble(domlo(3) + HALF)*delta(3)

             do k=domlo(3)-1,adv_l3,-1
                z = problo(3) + dble(k + HALF)*delta(3)
                adv(i,j,k,URHO) = adv(i,j,domlo(3),URHO) + slope*(z - z0)
             enddo
          enddo
       enddo
       return
    endif

    ! HSE integration to get density, pressure
    do j = adv_l2, adv_h2
       do i = adv_l1, adv_h1

          ! temperature and species held constant in BCs
          temp_zone = adv(i,j,domlo(3),UTEMP)
          X_zone(:) = adv(i,j,domlo(3),UFS:UFS-1+nspec)/adv(i,j,domlo(3),URHO)

          ! get pressure in zone above
          eos_state%rho = adv(i,j,domlo(3),URHO)
          eos_state%T = temp_zone
          eos_state%xn(:) = X_zone(:)

          call eos(eos_input_rt, eos_state)

          eint = eos_state%e
          pres_above = eos_state%p

          ! this do loop counts backwards since we want to work downward
          do k = domlo(3)-1, adv_l3, -1

             ! initial guesses
             dens_zone = adv(i,j,k+1,URHO)

             converged_hse = .FALSE.

             do iter = 1, MAX_ITER

                ! pressure needed from HSE
                p_want = pres_above - &
                     delta(3)*HALF*(dens_zone + adv(i,j,k+1,URHO))*const_grav

                ! pressure from EOS
                eos_state%rho = dens_zone
                eos_state%T = temp_zone
                eos_state%xn(:) = X_zone(:)

                call eos(eos_input_rt, eos_state)

                pres_zone = eos_state%p
                dpdr = eos_state%dpdr
                eint = eos_state%e

                ! Newton-Raphson - we want to zero A = p_want - p(rho)
                A = p_want - pres_zone
                drho = A/(dpdr + HALF*delta(3)*const_grav)

                dens_zone = max(0.9_rt*dens_zone, &
                                min(dens_zone + drho, 1.1_rt*dens_zone))

                ! convergence?
                if (abs(drho) < TOL*dens_zone) then
                   converged_hse = .TRUE.
                   exit
                endif

             enddo

             if (.not. converged_hse) call bl_error("ERROR: failure to converge in -Z BC")

             ! velocity
             if (zero_vels) then

                ! zero normal momentum causes pi waves to pass through
                adv(i,j,k,UMZ) = ZERO

                ! zero transverse momentum
                adv(i,j,k,UMX) = ZERO
                adv(i,j,k,UMY) = ZERO
             else

                ! zero gradient velocity
                adv(i,j,k,UMX) = dens_zone*(adv(i,j,domlo(3),UMX)/adv(i,j,domlo(3),URHO))
                adv(i,j,k,UMY) = dens_zone*(adv(i,j,domlo(3),UMY)/adv(i,j,domlo(3),URHO))
                adv(i,j,k,UMZ) = dens_zone*(adv(i,j,domlo(3),UMZ)/adv(i,j,domlo(3),URHO))
             endif

             adv(i,j,k,URHO) = dens_zone

             eos_state%rho = dens_zone
             eos_state%T = temp_zone
             eos_state%xn(:) = X_zone

             call eos(eos_input_rt, eos_state)

             pres_zone = eos_state%p
             eint = eos_state%e

             adv(i,j,k,UEINT) = dens_zone*eint
             adv(i,j,k,UEDEN) = dens_zone*eint + HALF*sum(adv(i,j,k,UMX:UMZ)**2)/dens_zone
             adv(i,j,k,UTEMP) = temp_zone
             adv(i,j,k,UFS:UFS-1+nspec) = dens_zone*X_zone(:)

             ! for the next iteration
             pres_above = pres_zone

          end do
       end do
    enddo

  end subroutine hse_bc_zlo

  subroutine hse_bc_zhi(adv,adv_l1,adv_l2,adv_l3,adv_h1,adv_h2,adv_h3, &
                        domlo,domhi,delta,xlo,time,bc, density_only)

    use probdata_module
    use meth_params_module, only : NVAR, URHO, UMX, UMY, UMZ, UEDEN, UEINT, UTEMP
    use interpolate_module
    use network, only: nspec

    use amrex_fort_module, only : rt => amrex_real
    implicit none
    integer adv_l1,adv_l2,adv_l3,adv_h1,adv_h2,adv_h3
    integer bc(3,2,*)
    integer domlo(3), domhi(3)
    real(rt)         delta(3), xlo(3), time
    real(rt)         adv(adv_l1:adv_h1,adv_l2:adv_h2,adv_l3:adv_h3,NVAR)
    logical, intent(in), optional :: density_only

    integer i,j,k

    logical :: just_density

    if (present(density_only)) then
       just_density = density_only
    else
       just_density = .false.
    endif

    if (just_density) then
       ! we cannot rely on any of the other state variables being
       ! initialized, so the only thing we can do here is extrapolate
       ! the density from the domain interior
       do k = domhi(3)+1, adv_h3
          do j = adv_l2, adv_h2
             do i = adv_l1, adv_h1
                adv(i,j,k,URHO) = adv(i,j,domhi(3),URHO)
             enddo
          enddo
       enddo
       return
    endif

    ! outflow, zeroing the normal velocity

    do j = adv_l2, adv_h2
       do i = adv_l1, adv_h1
          do k = domhi(3)+1, adv_h3
             adv(i,j,k,:) = adv(i,j,domhi(3),:)

             adv(i,j,k,UMZ) = max(ZERO, adv(i,j,k,UMZ))

             adv(i,j,k,UEDEN) = adv(i,j,k,UEINT) + HALF*sum(adv(i,j,k,UMX:UMZ)**2)/adv(i,j,k,URHO)
          enddo
       enddo
    enddo
  end subroutine hse_bc_zhi

end module hse_bc_module


PROGRAM PS4
      IMPLICIT NONE
      ! PARAMETERS
      REAL(KIND = 8):: BETA = 0.9932, ALPHA = 1.5  ! DISCOUNT, CAPITAL SHARE
      REAL(KIND = 8):: A_MAX = 5., A_MIN = -2. ! MUST BE INTEGER TO INITIALIZE SEQUENCE
      REAL(KIND = 8):: SPACE  ! SPACING OF AGRID ARRAY
      REAL, DIMENSION(2):: STATES = (/1.0, 0.5/)  ! DEFINE EMPLOYMENT STATES
      INTEGER, PARAMETER:: NA = 700, NZ = SIZE(STATES)  ! LENGTH OF ASSET AND STATES
      REAL(KIND = 8), DIMENSION(:), ALLOCATABLE:: A_GRID
      REAL(KIND = 8), DIMENSION(2, 2):: TRASITION = TRANSPOSE(RESHAPE((/0.97, 0.03, 0.5, 0.5/), (/2, 2/)))  ! MARKOV TRASITION MATRIX OF EMPLOYMENT
      REAL(KIND = 8), DIMENSION(:,:), ALLOCATABLE:: A_CHANGE_MAT
      INTEGER:: AP_IDX

      ! DEF FOR CALCULATION
      REAL(KIND = 8):: ERROR_VFI = 100., ERROR_Q = 100., ERROR_STAT = 100., CRITQ = 1e-3, CRITVFI = 1e-3, CRITSTAT = 1e-3  ! ERRORS AND CRITICAL VALUES
      REAL(KIND = 8):: LOWQ = 0.9932, HIGHQ = 1.0  ! INITIAL VALUES OF LOWER/UPPER BOUND OF PRICE Q
      INTEGER:: I
      REAL(KIND = 8):: Q
      REAL(KIND = 8):: COND_MAX_UTIL
      REAL(KIND = 8):: A, AP
      REAL(KIND = 8):: CONSUM
      REAL(KIND = 8):: CURRENT_STATE
      REAL(KIND = 8):: UTIL
      REAL(KIND = 8):: NET_ASSETS
      REAL(KIND = 8), DIMENSION(:,:), ALLOCATABLE:: VFUNC, VFUNC_NEW
      INTEGER, DIMENSION(:,:), ALLOCATABLE:: PFUNC
      REAL(KIND = 8), DIMENSION(NA):: LORENZ  ! FOR POST CALCULATION
      INTEGER:: STAT_PCHOICE
      REAL(KIND = 8), DIMENSION(:), ALLOCATABLE:: STAT_DIST, STAT_DIST_NEW
      REAL(KIND = 8), DIMENSION(NA, NZ):: CONSUM_ARR
      INTEGER:: SROWIDX, SCOLIDX, TROWIDX, TCOLIDX, CHOICEIDX, QIDX

      ! Initialize ARRAYS FOR VFI
      PRINT*, TRASITION(1, 1), TRASITION(1, 2), TRASITION(2, 1), TRASITION(2, 2)
      ALLOCATE(A_GRID(NA))
      SPACE = 0.01 !*(A_MAX-A_MIN)
      A_GRID = (/(i*SPACE, i = 1, NA)/)+ A_MIN-SPACE  ! CAN CHANGE TO NON INT BY ADDING/SUBSTRATING LATER
      ALLOCATE(VFUNC(NA, NZ))
      ALLOCATE(VFUNC_NEW(NA, NZ))
      VFUNC = 0.
      VFUNC_NEW = 0.
      ! SET STATIONARY DISTRIBUTION TO UNIFORM DISTRIBUTION
      ALLOCATE(STAT_DIST(NA*NZ))
      ! POPULATE THE STAT_DIST ARRAY
      STAT_DIST = 1/(2.*SIZE(A_GRID))
      STAT_DIST_NEW = STAT_DIST
      ! INIT POLICY FUNCTION
      ALLOCATE(PFUNC(NA, NZ))
      PFUNC = 1
      ! INIT ASSET CHANGE MATRIX
      ALLOCATE(A_CHANGE_MAT(NA*NZ, NA*NZ))
      A_CHANGE_MAT = 0.
      ! MAIN LOOP OVER Q
      DO WHILE (ERROR_Q > CRITQ)
      PFUNC = 0  ! PRONE ERROR, IF THIS BIDNING, UTIL > CON UTIL NOT REACHED
      VFUNC = 0.
      VFUNC_NEW = 0.
      Q = (LOWQ+HIGHQ)/2. ! UPDATE
      ERROR_VFI = 100.
      ! VALUE FUNCTION ITERATION
      DO WHILE (ERROR_VFI > CRITVFI)
      ! BELLMAN EQUATION
      DO SROWIDX = 1, NA
      DO SCOLIDX = 1, NZ  ! LOOP THROUGH (CURRENT) ASSET SPACE
      COND_MAX_UTIL = -1e10
      CURRENT_STATE = STATES(SCOLIDX)
      A = A_GRID(SROWIDX)
      ! LOOP FOR CHOICE SPACE
      DO CHOICEIDX = 1, NA
      AP = A_GRID(CHOICEIDX)
      CONSUM = A+CURRENT_STATE-Q*AP
      IF (CONSUM > 0.) THEN
              UTIL = (((CONSUM**(1-ALPHA))-1)/(1-ALPHA))+BETA*SUM(TRASITION(SCOLIDX, :)*VFUNC(CHOICEIDX, :))
              IF (UTIL > COND_MAX_UTIL) THEN  ! UPDATE THE MAX UTILITY GIVEN CURRENT ASSET
                      COND_MAX_UTIL = UTIL
                      PFUNC(SROWIDX, SCOLIDX) = CHOICEIDX  ! UPDATE POLICY FUNCTION
                      VFUNC_NEW(SROWIDX, SCOLIDX) = COND_MAX_UTIL  ! MAX UTILITY ADD INTO VALUE FUNCTION
              ENDIF
      ENDIF
      ENDDO
      ENDDO
      ENDDO  ! FINISH BELLMAN
      ERROR_VFI = MAXVAL(ABS(VFUNC-VFUNC_NEW))
      VFUNC = VFUNC_NEW
      ENDDO  ! FINISH VFI
      ! UPDATE STATIONARY DISTRIBUTION
      ! FIND TRASITION OF ASSET
      A_CHANGE_MAT = 0.
      DO SROWIDX = 1, NA
      DO SCOLIDX = 1, NZ  ! LOOP THROUGH (CURRENT) ASSET SPACE
      TROWIDX = 2*(SROWIDX-1) +SCOLIDX
      STAT_PCHOICE = PFUNC(SROWIDX, SCOLIDX)  ! INDEX OF NEVER PERIOD ASSETS
      DO QIDX = 1, NZ
      TCOLIDX = STAT_PCHOICE*2 -2+QIDX
      A_CHANGE_MAT(TROWIDX, TCOLIDX) = A_CHANGE_MAT(TROWIDX, TCOLIDX)+TRASITION(SCOLIDX, QIDX)  ! POPULATE TRASITION MATRIX
      ENDDO
      ENDDO
      ENDDO
      ! LOOP UNTIL STAT DIST CONVERGE
      ERROR_STAT = 100.
      STAT_DIST = 1/(2.*SIZE(A_GRID))
      DO WHILE (ERROR_STAT > CRITSTAT)
      STAT_DIST_NEW = MATMUL(STAT_DIST, A_CHANGE_MAT)
      ERROR_STAT = MAXVAL(ABS(STAT_DIST_NEW-STAT_DIST))
      STAT_DIST = STAT_DIST_NEW
      ENDDO
      ! COMPUTE ASSET
      NET_ASSETS = 0.
      DO SROWIDX = 1, NA
      DO SCOLIDX = 1, NZ
      AP_IDX = PFUNC(SROWIDX, SCOLIDX)
      TROWIDX = 2*(SROWIDX-1) +SCOLIDX
      NET_ASSETS = NET_ASSETS+A_GRID(AP_IDX)*STAT_DIST(TROWIDX)
      ENDDO
      ENDDO
      ! UPDATE Q USING BISECTION
      IF (NET_ASSETS > 0) THEN
              HIGHQ = Q
      ELSE
              LOWQ = Q
      ENDIF
      ERROR_Q = ABS(HIGHQ-LOWQ)
      PRINT*, Q, "Q"
      ENDDO

      !POST COMPUTATION
      LORENZ(1) = 0.
      DO SROWIDX = 2, NA
      LORENZ(SROWIDX)= LORENZ(SROWIDX-1) + STAT_DIST(SROWIDX) + STAT_DIST(SROWIDX+NA)
      ENDDO

      ! WRITE ARRAY TO FILE
      OPEN(UNIT = 1, FILE='/Users/chek_choi/Downloads/fortran/VFUNC', STATUS='REPLACE')  ! START WITH THE TWO VALUE FUNCTIONS
      DO SROWIDX = 1, NA
      WRITE(UNIT = 1, FMT=*) VFUNC(SROWIDX, :)
      ENDDO
      CLOSE(UNIT = 1)
      OPEN(UNIT = 2, FILE='/Users/chek_choi/Downloads/fortran/PFUNC', STATUS='REPLACE')  ! ALSO SAVE POLICY FUNCTIONS
      DO SROWIDX = 1, NA
      WRITE(UNIT = 2, FMT=*) PFUNC(SROWIDX, :)
      ENDDO
      CLOSE(UNIT = 2)
      OPEN(UNIT = 3, FILE='/Users/chek_choi/Downloads/fortran/STATDIST', STATUS='REPLACE')  ! ALSO SAVE POLICY FUNCTIONS
      DO SROWIDX = 1, NA
      WRITE(UNIT = 3, FMT=*) STAT_DIST([2*(SROWIDX-1) +1, 2*(SROWIDX-1) +2])
      ENDDO
      CLOSE(UNIT = 3)
      OPEN(UNIT = 4, FILE='/Users/chek_choi/Downloads/fortran/AGRID', STATUS='REPLACE')  ! ALSO SAVE POLICY FUNCTIONS
      DO SROWIDX = 1, NA
      WRITE(UNIT = 4, FMT=*) A_GRID(SROWIDX)
      ENDDO
      CLOSE(UNIT = 4)

      OPEN(UNIT = 5, FILE='/Users/chek_choi/Downloads/fortran/LORENZ', STATUS='REPLACE')  ! ALSO SAVE POLICY FUNCTIONS
      DO SROWIDX = 1, NA
      WRITE(UNIT = 5, FMT=*) LORENZ(SROWIDX)
      ENDDO
      CLOSE(UNIT = 5)

      OPEN(UNIT = 6, FILE='/Users/chek_choi/Downloads/fortran/CONSUM', STATUS='REPLACE')  ! ALSO SAVE POLICY FUNCTIONS
      DO SROWIDX = 1, NA
      WRITE(UNIT = 6, FMT=*) CONSUM_ARR(SROWIDX, :)
      ENDDO
      CLOSE(UNIT = 6)

      OPEN(UNIT = 7, FILE='/Users/chek_choi/Downloads/fortran/AMAT', STATUS='REPLACE')  ! ALSO SAVE POLICY FUNCTIONS
      DO SROWIDX = 1, NA*NZ
      WRITE(UNIT = 7, FMT=*) A_CHANGE_MAT(SROWIDX, :)
      ENDDO
      CLOSE(UNIT = 7)
END  PROGRAM PS4


  subroutine ca_ext_src(lo,hi, &
                        old_state,old_state_l1,old_state_h1, &
                        new_state,new_state_l1,new_state_h1, &
                        src,src_l1,src_h1,problo,dx,time,dt)

    use meth_params_module, only : NVAR, URHO, UEDEN, UEINT, UFS
    use probdata_module   , only : xmin, &
                                   heating_time, heating_rad, &
                                   heating_peak, heating_sigma, prob_type
    use prob_params_module, only: center
    use network

    use amrex_fort_module, only : rt => amrex_real
    implicit none
    integer         ,intent(in   ) :: lo(1),hi(1)
    integer         ,intent(in   ) :: old_state_l1,old_state_h1
    integer         ,intent(in   ) :: new_state_l1,new_state_h1
    integer         ,intent(in   ) :: src_l1,src_h1
    real(rt)        ,intent(in   ) :: old_state(old_state_l1:old_state_h1,NVAR)
    real(rt)        ,intent(in   ) :: new_state(new_state_l1:new_state_h1,NVAR)
    real(rt)        ,intent(  out) :: src(src_l1:src_h1,NVAR)
    real(rt)        ,intent(in   ) :: problo(1),dx(1),time,dt

    integer          :: i
    real(rt)         :: x, r_0, H_0, W_0, Hext, t_stop

    integer :: ihe4_p

    r_0 = heating_rad

    H_0 = heating_peak
    W_0 = heating_sigma

    t_stop = heating_time

    if (prob_type == 1) then

       ! For heating at the center
       if (time .le. t_stop) then
          if (lo(1) .eq. 0) print *,'TIME vs TSTOP ',time, t_stop
          do i = lo(1), hi(1)

             x = problo(1) + ((dble(i)+0.5e0_rt)*dx(1) + xmin) - center(1)

             Hext = H_0*exp(-((x-r_0)**2)/W_0**2)

             src(i,UEINT) = old_state(i,URHO)*Hext
             src(i,UEDEN) = old_state(i,URHO)*Hext

          enddo
       else

          src(lo(1):hi(1),UEINT) = 0.e0_rt
          src(lo(1):hi(1),UEDEN) = 0.e0_rt

       end if

    else if (prob_type == 3) then

       ihe4_p = network_species_index("helium-4")

       ! sub-chandra heating -- modulate by He
       if (time .le. t_stop) then
          if (lo(1) .eq. 0) print *,'TIME vs TSTOP ',time, t_stop
          do i = lo(1), hi(1)

             x = problo(1) + ((dble(i)+0.5e0_rt)*dx(1) + xmin) - center(1)

             Hext = H_0*exp(-((x-r_0)**2)/W_0**2)*old_state(i,UFS-1+ihe4_p)/old_state(i,URHO)

             src(i,UEINT) = old_state(i,URHO)*Hext
             src(i,UEDEN) = old_state(i,URHO)*Hext

          enddo
       else

          src(lo(1):hi(1),UEINT) = 0.e0_rt
          src(lo(1):hi(1),UEDEN) = 0.e0_rt

       end if

    endif

  end subroutine ca_ext_src