!>----------------------------------------------------------
!!  Simple open water flux calculations
!!
!!  @author
!!  Ethan Gutmann (gutmann@ucar.edu)
!!
!!----------------------------------------------------------
module module_water_simple
    use data_structures
    implicit none

    real, parameter :: freezing_threshold=273.15

contains

    real function sat_mr(t,p)
    ! Calculate the saturated mixing ratio at a temperature (K), pressure (Pa)
        implicit none
        real,intent(in) :: t,p
        real :: e_s,mr_s,a,b

        ! from :
        !     Lowe, P.R. and J.M. Ficke., 1974: THE COMPUTATION OF SATURATION VAPOR PRESSURE
        !         Environmental Prediction Research Facility, Technical Paper No. 4-74
        !     see: http://www.dtic.mil/dtic/tr/fulltext/u2/778316.pdf
        ! which references:
        !     Murray, F. W., 1967: On the computation of saturation vapor pressure.
        !         Journal of Applied Meteorology, Vol. 6, pp. 203-204.
        ! Also notes a 6th order polynomial and look up table as viable options.
        if (t<freezing_threshold) then
            a=21.8745584
            b=7.66
        else
            a=17.2693882
            b=35.86
        endif
        e_s = 610.78* exp(a*(t-273.16)/(t-b)) !(Pa)

        ! alternate formulations
        ! Polynomial:
        ! e_s = ao + t*(a1+t*(a2+t*(a3+t*(a4+t*(a5+a6*t))))) a0-6 defined separately for water and ice
        ! e_s = 611.2*exp(17.67*(t-273.15)/(t-29.65)) ! (Pa)
        ! from : http://www.srh.noaa.gov/images/epz/wxcalc/vaporPressure.pdf
        ! e_s = 611.0*10.0**(7.5*(t-273.15)/(t-35.45))

        ! enforce e_s < air pressure incase we are out on one edge of a polynomial
        if ((p-e_s)<=0) then
            e_s=p*0.99999
        endif
        ! e_s=min(e_s,p-SMALL_PRESSURE) ! this is harder to cover a reasonable range of pressure in single precision
        !from : http://www.srh.noaa.gov/images/epz/wxcalc/mixingRatio.pdf
        sat_mr=0.6219907*e_s/(p-e_s) !(kg/kg)
    end function sat_mr

    subroutine calc_exchange_coefficient(wind,tskin,airt,z_atm,lnz_atm,base_exchange,exchange_C)
        implicit none
        real, intent(in) :: wind,tskin,airt
        real, intent(in) :: z_atm, lnz_atm, base_exchange
        real, intent(out) :: exchange_C
        real :: Ri

        Ri = gravity/airt * (airt-tskin)*z_atm/wind**2

        if(Ri<0) then
            exchange_C=lnz_atm * (1.0-(15.0*Ri)/(1.0+(base_exchange * sqrt((-1.0)*Ri))))
        else
            exchange_C=lnz_atm * 1.0/((1.0+15.0*Ri)*sqrt(1.0+5.0*Ri))
        endif
    end subroutine calc_exchange_coefficient

    function ocean_roughness(ustar) result(z0)
        implicit none
        real, intent(in) :: ustar
        real :: z0

        ! approximately from Beljaars (1995?) in ECMWF model
        z0 = 8e-6 / max(ustar,1e-7)
    end function ocean_roughness

    subroutine water_simple(sst, psfc, wind, ustar, qv, temperature,  &
                            sensible_heat, latent_heat, &
                            z_atm, Z0, landmask, &
                            qv_surf, evap_flux, tskin)
        implicit none
        real,    dimension(:,:,:),intent(in)    :: qv, temperature
        real,    dimension(:,:),  intent(inout) :: sensible_heat, latent_heat, Z0, qv_surf, evap_flux, tskin
        real,    dimension(:,:),  intent(in)    :: sst, psfc, wind, ustar, z_atm
        integer, dimension(:,:),  intent(in)    :: landmask

        integer :: nx, ny, i, j
        real :: base_exchange_term, lnz_atm_term, exchange_C, z

        nx=size(sst,1)
        ny=size(sst,2)

        do j=2,ny-1
            do i=2,nx-1
                if (landmask(i,j)==kLC_WATER) then
                    qv_surf(i,j) = 0.98 * sat_mr(sst(i,j),psfc(i,j)) ! multiply by 0.98 to account for salinity

                    Z0(i,j) = ocean_roughness(ustar(i,j))
                    z=z_atm(i,j)
                    lnz_atm_term = log((z+Z0(i,j))/Z0(i,j))
                    base_exchange_term=(75*karman**2 * sqrt((z+Z0(i,j))/Z0(i,j))) / (lnz_atm_term**2)
                    lnz_atm_term=(karman/lnz_atm_term)**2

                    call calc_exchange_coefficient(wind(i,j),sst(i,j),temperature(i,1,j),&
                                                   z,lnz_atm_term,base_exchange_term,exchange_C)

                    sensible_heat(i,j) = exchange_C * wind(i,j) * (sst(i,j)-temperature(i,1,j))
                    evap_flux(i,j)     = exchange_C * wind(i,j) * (qv_surf(i,j)-qv(i,1,j))
                    latent_heat(i,j)   = evap_flux(i,j) * LH_vaporization
                    tskin(i,j)   = sst(i,j)

                endif
            end do
        end do

    end subroutine water_simple

end module module_water_simple


      subroutine ru_allo

      use basin_module
      use time_module
      use ru_module
      use hydrograph_module, only : sp_ob

      implicit none

      integer :: isb        !none        |counter
      real :: ql            !            |
      real :: sumq          !            |
      real :: tb            !            |
      real :: tp            !none        !time to peak flow
      integer :: i          !none        |counter
      integer :: int        !            |
      real :: xi            !            |
      real :: q             !            |
      integer :: max        !            |maximum
      real :: uhalpha       !none        !alpha coeff for est unit hydrograph using gamma func

      if (time%step > 0) then
!!    compute unit hydrograph for computing subbasin hydrograph from direct runoff
      do isb = 1, sp_ob%ru
        ql = 0.
        sumq = 0.
        tb = .5 + .6 * ru_tc(isb) + bsn_prm%tb_adj  !baseflow time, hr
        if (tb > 48.) tb = 48.			   !maximum 48hrs
        tp = .375 * tb                       ! time to peak flow
	  !! convert to time step (from hr), J.Jeong March 2009
	  tb = ceiling(tb * 60./ real(time%dtm))
	  tp = int(tp * 60./ real(time%dtm))

	  if(tp==0) tp = 1
	  if(tb==tp) tb = tb + 1
	  itsb(isb) = int(tb)

	  ! Triangular Unit Hydrograph
	  if (bsn_cc%uhyd == 0) then
	    do i = 1, itsb(isb)
            xi = float(i)
 	      if (xi < tp) then           !! rising limb of hydrograph
              q = xi / tp
            else                        !! falling limb of hydrograph
              q = (tb - xi) / (tb - tp)
            end if
            q = Max(0.,q)
            uhs(isb,i) = (q + ql) / 2.
            ql = q
            sumq = sumq + uhs(isb,i)
          end do

		do i = 1, itsb(isb)
            uhs(isb,i) = uhs(isb,i) / sumq
          end do

	  ! Gamma Function Unit Hydrograph
	  elseif (bsn_cc%uhyd == 2) then
          i = 1; q=1.
		do while (q>0.0001)
            xi = float(i)
            q = (xi / tp) ** bsn_prm%uhalpha * exp((1.- xi / tp) *      &
                             uhalpha)
            q = Max(0.,q)
            uhs(isb,i) = (q + ql) / 2.
            ql = q
            sumq = sumq + uhs(isb,i)
	      i = i + 1
	      if (i>3.*time%step) exit
	    end do
	    itsb(isb) = i - 1
          do i = 1, itsb(isb)
            uhs(isb,i) = uhs(isb,i) / sumq
          end do
	  endif
      end do
      end if

      return
      end subroutine ru_allo


module mod_correc
  use mod_types
  implicit none
  private
  public correc
  contains
  subroutine correc(lo,hi,dxc,dyc,dzc,dt,p,up,vp,wp,u,v,w)
    !
    ! corrects the velocity so that it is divergence free
    !
    implicit none
    integer , intent(in ), dimension(3) :: lo,hi
    real(rp), intent(in ), dimension(lo(1)-1:) :: dxc
    real(rp), intent(in ), dimension(lo(2)-1:) :: dyc
    real(rp), intent(in ), dimension(lo(3)-1:) :: dzc
    real(rp), intent(in ) :: dt
    real(rp), intent(in ), dimension(lo(1)-1:,lo(2)-1:,lo(3)-1:) :: p,up,vp,wp
    real(rp), intent(out), dimension(lo(1)-1:,lo(2)-1:,lo(3)-1:) :: u,v,w
    integer :: i,j,k
    !
    !$OMP PARALLEL DO DEFAULT(none) &
    !$OMP SHARED(lo,hi,dt,dxc,u,up,p) &
    !$OMP PRIVATE(i,j,k)
    do k=lo(3)-1,hi(3)+1
      do j=lo(2)-1,hi(2)+1
        do i=lo(1)-1,hi(1)
          u(i,j,k) = up(i,j,k) - dt*(p(i+1,j,k)-p(i,j,k))/dxc(i)
        enddo
      enddo
    enddo
    !$OMP END PARALLEL DO
    !$OMP PARALLEL DO DEFAULT(none) &
    !$OMP SHARED(lo,hi,dt,dyc,v,vp,p) &
    !$OMP PRIVATE(i,j,k)
    do k=lo(3)-1,hi(3)+1
      do j=lo(2)-1,hi(2)
        do i=lo(1)-1,hi(1)+1
          v(i,j,k) = vp(i,j,k) - dt*(p(i,j+1,k)-p(i,j,k))/dyc(j)
        enddo
      enddo
    enddo
    !$OMP END PARALLEL DO
    !$OMP PARALLEL DO DEFAULT(none) &
    !$OMP SHARED(lo,hi,dt,dzc,w,wp,p) &
    !$OMP PRIVATE(i,j,k)
    do k=lo(3)-1,hi(3)
      do j=lo(2)-1,hi(2)+1
        do i=lo(1)-1,hi(1)+1
          w(i,j,k) = wp(i,j,k) - dt*(p(i,j,k+1)-p(i,j,k))/dzc(k)
        enddo
      enddo
    enddo
    !$OMP END PARALLEL DO
  end subroutine correc
end module mod_correc


! MIT License
!
! Copyright (c) 2020 SHEMAT-Suite
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.

!>    @brief calculate the covariances a posteriori
!>    @param[in] tmp temporary space, normal [g_p_,ndata] (now enough space for [g_p_,g_p_] too)
!>    @param[in] g_p_ number of independent parameters
!>    @param[in] ismpl local sample index
!>    @details
!>    calculate the covariances a posteriori\n
!>    and the resolution martrix\n
      SUBROUTINE calc_covares(g_p_,tmp,ismpl)
        use arrays
        use mod_genrl
        use mod_genrlc
        use mod_inverse
        use mod_data
        use mod_linfos
        IMPLICIT NONE
        integer :: ismpl
        integer :: i, j, k

        INTEGER ii, g_p_
!     "g_p_" should be "mpara"
        DOUBLE PRECISION wp2_ps, wd2_ps
        EXTERNAL wp2_ps, wd2_ps

!     normal [g_p_,ndata] : now enough space for [g_p_,g_p_] too
        DOUBLE PRECISION tmp(g_p_,max(ndata,g_p_),3)

        IF (covar==0 .AND. resmat==0) RETURN

        IF (linfos(2)>=1) WRITE(*,*) ' .... calculate covariances'

!     setup normal equation lhs to temporary loCation
! i:  tmp2 = Stwd2_ps = jac^T * wd2_ps
!            [g_p__ x ndata]
        DO j = 1, ndata
          DO i = 1, g_p_
            tmp(i,j,2) = 0.0D0
            DO k = 1, ndata
              tmp(i,j,2) = tmp(i,j,2) + jac(k,i)*wd2_ps(k,j &
                ,ismpl)
            END DO
          END DO
        END DO

! i:  tmp3 = tmp2 *jac
!            [g_p_^2]
        DO j = 1, g_p_
          DO i = 1, g_p_
            tmp(i,j,3) = 0.0D0
            DO k = 1, ndata
              tmp(i,j,3) = tmp(i,j,3) + tmp(i,k,2)*jac(k,j)
            END DO
          END DO
        END DO

!-------------------------------------------------
!     need for covariance & resolution matrix

!     i:  tmp_mat = tmp3 +wp2_ps
!     M = [jac^T * wd2_ps *jac]
!     [g_p_^2]
        DO j = 1, g_p_
          DO i = 1, g_p_
            tmp_mat(i,j) = tmp(i,j,3) + wp2_ps(i,j,ismpl)
          END DO
        END DO

!     prepare right side
        DO j = 1, g_p_
          DO i = 1, g_p_
            tmp(i,j,1) = 0.0D0
            covar_p(i,j) = 0.0D0
          END DO
        END DO

!     Warning: need "g_p_" =< "ndata" !!!
!     [tmp1] = [I]
        DO j = 1, g_p_
          tmp(j,j,1) = 1.0D0
        END DO

!     solve for parameter CovarianCe a posteriori
!     [covar_p] = [J*] = [M^-1] : [g_p_]x[g_p_]
        CALL dense_solve(g_p_,g_p_,tmp_mat,tmp(1,1,1),covar_p)

!     now covar_p is the inverse of the matrix M
!-------------------------------------------------

!     CalCulate errors
        DO i = 1, g_p_
          IF (covar_p(i,i)<0.0D0) WRITE(*,'(A,I6)') &
            'warning: Covar-P(i,i) < zero at i=', i
          CALL set_optie(i,dsqrt(covar_p(i,i)),ismpl)
        END DO

        IF (resmat/=0) THEN
          DO j = 1, g_p_
            DO i = 1, g_p_
              resmat_p(i,j) = 0.0D0
              DO k = 1, g_p_
!                 [resmat_p] = [J*]x[wp2_ps] : [g_p_]x[g_p_]
                resmat_p(i,j) = resmat_p(i,j) + &
                  covar_p(i,k)*wp2_ps(k,j,ismpl)
              END DO
            END DO
!           [resmat_p] = [I] -[J*]x[wp2_ps] = [I] -[M^-1]x[wp2_ps]
!           matlab: CT= eye(size(U))-U*CI; U=A^-1=M^-1=J*; CI=CIp=wp2_ps
            resmat_p(j,j) = 1.0D0 - resmat_p(j,j)
          END DO
        END IF

        RETURN
      END


!  *********************************************************************
!  *                                                                   *
!  *                         subroutine las3i                          *
!  *                                                                   *
!  *********************************************************************
!  Single Precision Version 3.2
!  Written by Gordon A. Fenton, TUNS, Aug. 26, 1992
!  Latest Update: Feb. 22, 1994
!
!  PURPOSE   initializes parameters for LAS3G
!
!  This routine sets up the matrices required by LAS3G to construct
!  realizations of the random field. The covariances between local averages
!  at each subdivision stage are computed in double precision for accuracy,
!  but the final construction matrices are stored in single precision and
!  returned to the calling routine via the argument list. The general
!  recursive field construction follows the relationship
!
!         {Z^j} = [A^T]{Z^(j-1)} + [C]{U}
!
!  where {Z^j} is a vector of length 8 representing the values assigned to
!  the 2 x 2 x 2 cell subdivision and {Z^(j-1)} are the parent cell values in
!  some neighbourhood. The following figure illustrates the cell subdivision,
!  the neighbourhood, and the numbering scheme for an interior cell (special
!  subsets of the neighbourhood are used for the corners, edges, and sides).
!  Only one plane is shown for simplicity, however the top and side views are
!  similar, although the numbering will change (there being 27 parent elements
!  and 8 subdivided elements).
!
!                ----------------------------------------
!                |            |            |            |
!                |            |            |            |
!                |     7      |     8      |      9     |
!                |            |            |            |
!                |            |            |            |
!                |------------|------------|------------|
!                |            | 3   |    4 |            |
!                |            |     |      |            |
!                |     4      |-----5------|      6     |
!                |            |     |      |            |
!                |            | 1   |    2 |            |
!                |------------|------------|------------|
!                |            |            |            |
!                |            |            |            |
!                |     1      |     2      |     3      |
!                |            |            |            |
!                |            |            |            |
!                ----------------------------------------
!
!  The first stage of the simulation involves the direct generation of a
!  k1 x k2 x k3 cell array, where k1, k2, and k3 are integers which satisfy
!  the decomposition N1 = k1*2**m, N2 = k2*2**m, and N3 = k3*2**m for a
!  common factor 2**m. The integers k1, k2, and k3 are chosen to be as large
!  as possible while requiring the product k1*k2*k3 to be less than or equal
!  to MXK. Note that the direct simulation involves the Cholesky Decomp. of a
!  MXK x MXK matrix (at the upper limit) and so MXK should not be overly large.
!  This formulation is somewhat less restrictive than simply requiring
!  N1, N2, and N3 to be powers of 2. Also N1, N2, and N3 do not have to be
!  equal. However N1, N2, and N3 cannot still be chosen arbitrarily, for
!  example the set (N1,N2,N3) = (144,256,256) results in k1 = 9, k2 = 16,
!  k3 = 16, m = 4 which is not acceptable here (since k1*k2*k3 > MXK for
!  MXK = 1000), while the set (N1,N2) = (160,256,256) is acceptable since
!  k1 = 5, k2 = 8, k3 = 8, m = 5. In general it may be easier to choose k1,
!  k2, k3, and m before specifying N1, N2, and N3. In the event that an
!  unacceptable (k1,k2,k3,m) combination is selected, IERR is set to -1 and
!  control returned to the calling routine.
!  The maximum value of m is set by the calling routine in the argument MXM.
!
!  Arguments to this routine are as follows;
!
!  dvfn   external real*8 function which returns the variance of the random
!         process averaged over a given volume. dvfn is referenced as follows
!
!                var = dvfn( V1, V2, V3 )
!
!         where (V1,V2,V3) are the side dimensions of the rectangular averaging
!         domain. Any other parameters to the function may be passed by
!         common block from the calling routine. Note that the variance of
!         the random process averaged over the volume (V1 x V2 x V3) is the
!         product of the point variance and the traditionally defined
!         "variance" function, as discussed by Vanmarcke (pg 186).
!
!  N1     number of cells to discretize the field in the x, y, and z directions
!  N2     respectively (corresponding to the first, second, and third indices
!  N3     of Z respectively). N1, N2, and N3 must have the form
!            N_i = k_i * 2**m
!         where m is common to N1, N2, and N3 and k1, k2, and k3 are
!         positive integers satisfying k1*k2*k3 <= MXK. Generally k1, k2 and k3
!         are chosen to be as large as possible and still satisfy the above
!         requirements so the the first stage involves directly simulating
!         a k1 x k2 x k3 field by inversion of a covariance matrix. (input)
!
!  XL     physical dimensions of the field in the x-direction. (input)
!  YL     physical dimensions of the field in the y-direction. (input)
!  ZL     physical dimensions of the field in the z-direction. (input)
!
!  KSEED  integer seed to be used for the pseudo-random number generator.
!         If KSEED = 0, then a random seed will be used (based on the
!         clock time when this routine is called for the first time).
!         On output, KSEED is set to the value of the actual seed used.
!
!  MXM    integer giving the largest value that M can take. An error is
!         generated if the process size is such that M > MXM. (input)
!
!  C0     real vector containing the lower triangular values of the Cholesky
!         decomposition of the covariance matrix for the initial stage of
!         k1 x k2 x k3 cells. C0 must be at least k1*k2*k3 x k1*k2*k3 in
!         length. (output)
!
!  CC     real vector containing the lower triangular values of the Cholesky
!         decomposition of the covariance matrix for the corner cell 2 x 2 x 2
!         subdivisions. (output)
!
!  CE     real vector containing the lower triangular values of the Cholesky
!         decomposition of the covariance matrix for the edge cell 2 x 2 x 2
!         subdivisions. (output)
!
!  CS     real vector containing the lower triangular values of the Cholesky
!         decomposition of the covariance matrix for the side cell 2 x 2 x 2
!         subdivisions. (output)
!
!  CI     real vector containing the lower triangular values of the Cholesky
!         decomposition of the covariance matrix for the interior cell
!         2 x 2 x 2 subdivisions. (output)
!
!  AC     real array containing the best linear estimation coefficients for
!         the corner cell subdivisions. (output)
!
!  AE     real array containing the best linear estimation coefficients for
!         the edge cell subdivisions. (output)
!
!  AS     real array containing the best linear estimation coefficients for
!         the side cell subdivisions. (output)
!
!  AI     real array containing the best linear estimation coefficients for
!         the interior cell subdivisions. (output)
!
!  M      the number of 2 x 2 x 2 subdivisions to perform. It is an error for
!         M to be greater than MXM. (output)
!
!  k1     integers giving the size of the initial field (see C0). It is an
!  k2     error for the product k1*k2*k3 to exceed MXK.
!  k3     (output)
!
!  kk     integer giving the size of the initial field covariance matrix
!         (kk = k1*k2*k3). (output)
!
!  iout   unit number to which error and warning messages are logged. (input)
!
!   tol   maximum relative error allowed in the Cholesky decomposition of
!         covariance matrices before a warning message is issued. (input)
!---------------------------------------------------------------------------
!  PARAMETERS:
!   MXK   represents the maximum number of cells (k1 x k2 x k3) in the initial
!         field, k1*k2*k3 <= MXK. If the value of MXK is changed here, it must
!         also be changed in LAS2G.
!
!  Requires:
!    1) from libGAFsim:	ISEED, DCVIT3, DCVMT3, DCHOL2, CORN3D, EDGE3D,
!			SIDE3D, INTR3D, DCVAA3, DCVAB3, DSIFA, DSISL, DAXPY,
!			DSWAP, IDAMAX, DDOT
!    4) user defined external variance function (see DVFN)
!----------------------------------------------------------------------------
      subroutine las3i( dvfn, N1, N2, N3, XL, YL, ZL, kseed, MXM,         &
                       C0, CC, CE, CS, CI, AC, AE, AS, AI,                &
                       ATC, ATS, ATI, CTC, CTS, CTI,                      &
                       M, k1, k2, k3, kk, iout, tol )
      parameter ( MXK = 512 )
      real C0(*), CC(28,8,*), CE(28,12,*), CS(28,6,*), CI(28,*)
      real AC(8,7,8,*), AE(12,7,12,*), AS(18,7,6,*), AI(27,7,*)
      real ATC(4,7,*), ATS(6,7,*), ATI(9,*)
      real CTC(28,*), CTS(28,*), CTI(*)
      real*8 R0(MXK*MXK)
      real*8 R(27,27,2), B(8,8), S(27,8)
      real*8 T1, T2, T3, dvfn, dble
      logical lformR, lk1, lk2, lk3
      integer mc(4,4,3), ms(6,4,3), mi(9,3)
      external dvfn

      data mc/14,17,23,26,   11,14,20,23,    5, 8,14,17,   2, 5,11,14,    &
             14,15,23,24,   13,14,22,23,    5, 6,14,15,   4, 5,13,14,     &
             14,15,17,18,   13,14,16,17,   11,12,14,15,  10,11,13,14/
      data ms/11,14,17,20,23,26,   5, 8,14,17,23,26,                      &
              2, 5,11,14,20,23,   2, 5, 8,11,14,17,                       &
             13,14,15,22,23,24,   5, 6,14,15,23,24,                       &
              4, 5,13,14,22,23,   4, 5, 6,13,14,15,                       &
             13,14,15,16,17,18,  11,12,14,15,17,18,                       &
             10,11,13,14,16,17,  10,11,12,13,14,15/
      data mi/ 2, 5, 8,11,14,17,20,23,26,                                 &
              4, 5, 6,13,14,15,22,23,24,                                  &
             10,11,12,13,14,15,16,17,18/

   1  format(a,a,a)
   2  format(a,e13.4)
   3  format(a,i4,a,i4,a,i4,a,i4,a)
!						decompose N1, N2, and N3
      k1 = N1
      k2 = N2
      k3 = N3
      do 10 m = 0, MXM
         kk = k1*k2*k3
         if( kk .le. MXK ) go to 20
         j1 = k1/2
         j2 = k2/2
         j3 = k3/2
         if( 2*j1 .ne. k1 .or. 2*j2 .ne. k2 .or. 2*j3 .ne. k3 ) go to 20
         k1 = j1
         k2 = j2
         k3 = j3
  10  continue
  15  write(iout,1)'Error: unable to determine an acceptable combination of k1, k2, k3 and m'
      write(iout,1)'       such that k1*2**m = N1, k2*2**m = N2 and k3*2**m = N3.'
      write(iout,3)'       k1 = ',k1,', k2 = ',k2,', k3 = ',k3,', m = ',m
      write(iout,3)'       (k1*k2*k3 must be less than ',MXK,' and m must be less than ',MXM,')'
      write(iout,1)'       Try changing N1, N2, and/or N3.'
      stop

  20  if(  kk .gt. MXK ) go to 15
      ifirst = 0
!						initialize internal generator
      kseed = iseed( kseed )
!						form initial covariance matrix
      T1 = dble(XL)/dble(k1)
      T2 = dble(YL)/dble(k2)
      T3 = dble(ZL)/dble(k3)
      call dcvit3( dvfn, R0, kk, R, 27, k1, k2, k3, T1, T2, T3 )

!						and compute its cholesky decomp
      call dchol2(R0,kk,kk,rerr)
      if( rerr .gt. tol ) then
         write(iout,1)'Warning: Cholesky decomposition of stage 0 covariance matrix'
         write(iout,2)'         has maximum relative error of ',rerr
      endif
!						save in real*4 for LAS2G
      L = 0
      do 30 j = 1, kk
         jj = (j-1)*kk
      do 30 i = 1, j
         L = L + 1
         C0(L) = R0(i+jj)
  30  continue
!						setup for subsequent stages
      in = 2
      io = 1
      nm = 1
!						(special k1,k2,k3 = 1 case)
      lk1 = (k1 .eq. 1)
      lk2 = (k2 .eq. 1)
      lk3 = (k3 .eq. 1)
      if( (lk1 .or. lk2 .or. lk3) .and. (m .gt. 0) ) then
         T1 = 0.5d0*T1
         T2 = 0.5d0*T2
         T3 = 0.5d0*T3
         lformR = (1 .lt. m)
         call dcvmt3(dvfn,R(1,1,in),27,B,8,S,27,T1,T2,T3,lformR)

         if((lk1.and.lk2) .or. (lk1.and.lk3) .or. (lk2.and.lk3)) then
            i2 = 14
            if( .not. lk1 ) then
               i1 = 13
               i3 = 15
            elseif( .not. lk2 ) then
               i1 = 11
               i3 = 17
            elseif( .not. lk3 ) then
               i1 = 5
               i3 = 23
            else
!						this should not happen...
               write(iout,1)'Error: not all k1, k2, k3 can be 1.'
               stop
            endif

            call thin1d(R(1,1,io),27,B,8,S,27,ATS,6,ATI,9,CTS,CTI,        &
                       i1,i2,i3,7,iout,tol)
         else
            if( lk1 ) k = 1
            if( lk2 ) k = 2
            if( lk3 ) k = 3
            call corn2d(R(1,1,io),27,B,8,S,27,CTC,28,7,ATC,               &
                       mc(1,1,k),iout,tol)

            call side2d(R(1,1,io),27,B,8,S,27,CTS,28,7,ATS,               &
                       ms(1,1,k),iout,tol)

            call intr2d(R(1,1,io),27,B,8,S,27,CTI,7,ATI,                  &
                       mi(1,k),iout,tol)
         endif
         in = 1
         io = 2
         nm = 2
      endif

      do 40 k = nm, M
         T1 = 0.5d0*T1
         T2 = 0.5d0*T2
         T3 = 0.5d0*T3
!							get basic cov matrices
         lformR = (k .lt. M)

         call dcvmt3(dvfn,R(1,1,in),27,B,8,S,27,T1,T2,T3,lformR)

!						corner parameters

         call corn3d(R(1,1,io),27,B,8,S,27,CC(1,1,k),AC(1,1,1,k),         &
                    iout,tol)
!							edge parameters

         call edge3d(R(1,1,io),27,B,8,S,27,CE(1,1,k),AE(1,1,1,k),         &
                    iout,tol)
!							side parameters

         call side3d(R(1,1,io),27,B,8,S,27,CS(1,1,k),AS(1,1,1,k),         &
                    iout,tol)
!							interior parameters

         call intr3d(R(1,1,io),27,B,8,S,27,CI(1,k),AI(1,1,k),             &
                    iout,tol)
!							swap old/new indices
         ii = in
         in = io
         io = ii
  40  continue

      return
      end


      subroutine pstati2(data,x,e,n,lfno)
      implicit real*8 (a-h,o-z)
      parameter (ndi=4)
      character*11 autofg,vout(2*ndi,ndi+1)
      dimension data(ndi,ndi,*),x(ndi,ndi),e(ndi,ndi),ceil(ndi,ndi),
     1          floor(ndi,ndi)
      call pclr(x,ndi*ndi)
      call pclr(e,ndi*ndi)
      do 11 i=1,ndi
        do 10 j=1,ndi
          ceil(i,j)=-1d31
          floor(i,j)=1d31
          do 20 k=1,n
            ceil(i,j)=max(ceil(i,j),data(i,j,k))
            floor(i,j)=min(floor(i,j),data(i,j,k))
 20       continue
          do 22 k=1,n
            x(i,j)=x(i,j)+data(i,j,k)
 22       continue
          x(i,j)=x(i,j)/n
          do 26 k=1,n
            e(i,j)=e(i,j)+(data(i,j,k)-x(i,j))**2
 26       continue
          e(i,j)=sqrt(e(i,j)/max(n-1,1))
 10     continue
 11   continue
      do 30 j=1,ndi
        vout(1,j)=autofg(    x(3,j),'11.8')
        vout(2,j)=autofg(    e(3,j),'11.8')
        vout(3,j)=autofg(floor(3,j),'11.8')
        vout(4,j)=autofg( ceil(3,j),'11.8')
        vout(5,j)=autofg(    x(1,j),'11.8')
        vout(6,j)=autofg(    e(1,j),'11.8')
        vout(7,j)=autofg(floor(1,j),'11.8')
        vout(8,j)=autofg( ceil(1,j),'11.8')
   30 continue
      vout(1,ndi+1)=autofg(    x(2,3),'11.8')
      vout(2,ndi+1)=autofg(    e(2,3),'11.8')
      vout(3,ndi+1)=autofg(floor(2,3),'11.8')
      vout(4,ndi+1)=autofg( ceil(2,3),'11.8')
      vout(5,ndi+1)=autofg(    x(2,1),'11.8')
      vout(6,ndi+1)=autofg(    e(2,1),'11.8')
      vout(7,ndi+1)=autofg(floor(2,1),'11.8')
      vout(8,ndi+1)=autofg( ceil(2,1),'11.8')
      write(lfno,1000) n,((vout(i,j),i=1,2*ndi),j=1,ndi+1)
 1000 format(1X,'Ndata=',I3,T19,'mean',T33,'sdev',T48,'min',T64,'max'/
     z       1X,'dx      rms  ',A,t27,A,T43,A,T59,A/
     z       1X,'       peak  ',A,t27,A,T43,A,T59,A/
     z       1X,'dy      rms  ',A,t27,A,T43,A,T59,A/
     z       1X,'       peak  ',A,t27,A,T43,A,T59,A/
     z       1X,'dEX     rms  ',A,t27,A,T43,A,T59,A/
     z       1X,'       peak  ',A,t27,A,T43,A,T59,A/
     z       1X,'dEY     rms  ',A,t27,A,T43,A,T59,A/
     z       1X,'       peak  ',A,t27,A,T43,A,T59,A/
     z       1X,'Steer   rms  ',A,t27,A,T43,A,T59,A/
     z       1X,' (k0)   max  ',A,t27,A,T43,A,T59,A)
      return
      end


!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!                                                                      %
! Copyright (C) 2015 Adrian Martinez Vargas                            %
!                                                                      %
! This software may be modified and distributed under the terms        %
! of the MIT license.  See the LICENSE.txt file for details.           %
!                                                                      %
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!                                                                      %
! Copyright (C) 1996, The Board of Trustees of the Leland Stanford     %
! Junior University.  All rights reserved.                             %
!                                                                      %
! The programs in GSLIB are distributed in the hope that they will be  %
! useful, but WITHOUT ANY WARRANTY.  No author or distributor accepts  %
! responsibility to anyone for the consequences of using them or for   %
! whether they serve any particular purpose or work at all, unless he  %
! says so in writing.  Everyone is granted permission to copy, modify  %
! and redistribute the programs in GSLIB, but only under the condition %
! that this notice and the above copyright notice remain intact.       %
!                                                                      %
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!-----------------------------------------------------------------------
!
! The functions and subroutines below were modified from the
! version 2.0 of the gslib code written in fortran 77
!
! The objective is to add functionality to GSLIB and to link
! this code with python using f2py. It uses f90 code convention.
! The arrays are dynamic and externally declared (from python)
!
! the code was converted from Fortran 77 to Fortran 90 using F2F.pl
!
! for more information please refer to:
! - gslib77 source code: http://www.statios.com/software/gslib77_ls.tar.gz
! - GSLIB: Geostatistical Software Library and User's Guide. Second edition
!   by Clayton V. Deutsch, Andre G. Journel, 1997.
! - F2PY Users Guide: http://docs.scipy.org/doc/numpy-dev/f2py/
! - F2F https://bitbucket.org/lemonlab/f2f
!-----------------------------------------------------------------------

!*********************************************************************************
!     Subroutines in GSLIB (auxiliary functions)
!*********************************************************************************
include 'setrot.f90'
include 'cova3.f90'
include 'sqdist.f90'
! include 'getindx.f90'
! include 'locate.f90'
! this includes sortem and dsortem
! include 'sortem.f90'
! include 'acorni.f90'
include 'gauinv.f90'
! include 'powint.f90'
! include 'gcum.f90'

subroutine bigaus(c0,it,cc,aa,aa1,aa2,ang1,ang2,ang3,nst, &
                  ncut,zc,ndir,nlag,azm,dip,xlag, &
                  out_j,out_l,out_h,out_ri,out_ci,out_rop,out_p,zcc,error)
    !-----------------------------------------------------------------------

    !          Indicator Variograms for BiGaussian Distribution
    !          ************************************************

    ! This program returns the values of the theoretical indicator
    ! semivariograms corresponding to an input normal scores semivariogram

    ! INPUT/OUTPUT PARAMETERS:

    !   outfl                  the output file for vargplt
    !   ncut                   number of cutoffs
    !   cut()                  the cutoffs (in cdf units)
    !   ndir,nlag              number of directions, number of lags
    !   xoff,yoff,zoff         for each direction: the specification
    !   nst,c0                 Normal scores variogram: nst, nugget
    !   it,aa,cc               type, a parameter, c parameter
    !   ang1,ang2,...,anis2    anisotropy definition

    ! PROGRAM NOTES:

    !   1. Setting the number of cutoffs to a -1 times the number of
    !      cutoffs will cause the variograms to be standardized to a sill
    !      of one.

    ! EXTERNAL REFERENCES:

    !       f        to calculate exp(-zc**2/(1+x))/sqrt(1-x**2)
    !       g        to calculate exp(-x**2/2)
    !       simpson  to do the numerical calculation
    !       gauinv   to get standard normal deviate

    ! Original:  H. Xiao                                                1975
    !-----------------------------------------------------------------------

    implicit none

    !input
    integer, intent(in) :: ncut,ndir,nlag,nst

    real, intent(in), dimension(nst) :: aa,aa1,aa2,cc,ang1,ang2,ang3
    integer, intent(in), dimension(nst) :: it
    real, intent(in), dimension(1) :: c0
    real, intent(in), dimension(ncut) :: zcc
    real, intent(in), dimension(ndir) :: xlag,azm,dip

    !ouput
    integer, intent(out), dimension(nlag,ndir,ncut) :: out_j, out_l
    real, intent(out), dimension(nlag,ndir,ncut) :: out_h,out_ri,out_ci,out_rop
    real, intent(out), dimension(ncut) :: out_p, zc

    integer, intent(out) :: error

    !internal
    real ::  b, p, maxcov
    real, dimension(ndir) :: xoff,yoff,zoff
    real, dimension(nlag*ndir) :: h,ri,ci,ro,gam,rop
    real*8, dimension(nst,3,3) :: rotmat
    integer :: i, id, j, l, is, icut, ii, il, ierr
    real :: xp, cov, zz, yy, xx, cmax, ci0
    real :: PI, DEG2RAD, EPSLON
    real, dimension(nst) :: anis1,anis2
    real ::  simpsong, simpsonf

    PI=3.14159265
    DEG2RAD=PI/180.0
    EPSLON = 1.0e-20

    if(ncut < 0) then
        error = -10 ! ncut may be positive
        return
    endif

    do i=1,ndir
        xoff(i) = sin(DEG2RAD*azm(i))*xlag(i)*cos(DEG2RAD*dip(i))
        yoff(i) = cos(DEG2RAD*azm(i))*xlag(i)*cos(DEG2RAD*dip(i))
        zoff(i) = sin(DEG2RAD*dip(i))*xlag(i)
        write(*,*) ' x,y,z offsets = ',xoff(i),yoff(i),zoff(i)
    end do

    do i=1,nst
        anis1(i) = aa1(i) / max(aa(i),EPSLON)
        anis2(i) = aa2(i) / max(aa(i),EPSLON)
    end do

    ! Set up the rotation matrices:

    do is=1,nst
        call setrot(ang1(is),ang2(is),ang3(is),anis1(is),anis2(is), &
        is,nst,rotmat)
    end do

    ! Convert cutoffs cumulative probabilities to standard normal cutoffs:

    do icut=1,ncut
        zc(icut)=zcc(icut)
        call gauinv(dble(zc(icut)),xp,ierr)
        zc(icut) = xp
    end do

    ! Get ready to go:

    call cova3(0.0,0.0,0.0,0.0,0.0,0.0,1,nst,c0,it,cc,aa, &
    &            1,nst,rotmat,cmax,maxcov)

    ! Set the variogram data, direction by direction up to ndir directions:

    i = 0
    do id=1,ndir
        xx  = -xoff(id)
        yy  = -yoff(id)
        zz  = -zoff(id)
        do il=1,nlag
            xx  = xx + xoff(id)
            yy  = yy + yoff(id)
            zz  = zz + zoff(id)
            call cova3(0.0,0.0,0.0,xx,yy,zz,1,nst,c0,it, &
            cc,aa,1,nst,rotmat,cmax,cov)
            i      = i + 1
            gam(i) = maxcov - cov
            ro(i)  = cov/maxcov
            h(i)   = sqrt(xx*xx+yy*yy+zz*zz)
            print *, '@@@', maxcov , cov
        end do
    end do

    ! Now, loop over all the cutoffs:

    do i=1,ncut
        ci0 = simpsonf(0.0, pi/2.0, 1.e-6, 40, zc(i))
        p   = simpsong(0.0,zc(i),1.e-6,40)
        p   = 0.5 + p/sqrt(2*PI)
        out_p(i) = p
        do l=1,ndir
            do j=1,nlag
                ii = (l-1)*nlag + j
                b = ro(ii)
                b = asin(b)
                ci(ii) = simpsonf (0.0, b, 1.e-6, 40, zc(i))
                ri(ii) = ( ci0-ci(ii)) / (2*pi)
                rop(ii) = ri(ii)/(p*(1-p))

                out_j(j,l,i) = j
                out_h(j,l,i) = h(ii)
                out_ri(j,l,i) = ri(ii)
                out_l(j,l,i) = l
                out_ci(j,l,i) = ci(ii)
                out_rop(j,l,i) = rop(ii)

            end do
        end do
    end do

    ! Finished:

end subroutine bigaus

real function f(x, zc)
    !-----------------------------------------------------------------------

    ! This function calculates the values of the function
    !       f( zc, xi)= exp ( -zc**2/ (1+sin(x))) for zc and x

    !-----------------------------------------------------------------------
    real ::       x, zc
    f = exp ( -zc**2 / (1+sin(x)))
    return
end function f

real function g(x)
    real :: x
    g= exp ( - x**2/2.0)
    return
end function g

function simpsonf(alim,blim,tol,nitn,zc)
    !-----------------------------------------------------------------------

    !       simpson performs numerical integration over the interval
    !       a,b of the function f. the method employed is modified
    !       simpson's rule. the procedure was adapted from algorithm
    !       182 of "collected algorithms from acm" vol. 1.
    !       the algorithm has been tested and found particularly useful
    !       for integration of a strongly peaked function. the function
    !       used for testing was not able to be suitably evaluated using
    !       gauss quadrature or romberg integration.

    ! PARAMETERS:

    !       a    -    lower limit of integration      (real)
    !       b    -    upper limit of integration      (real)
    !       eps  -    required tolerance            (real)
    !       nitn -    maximum level of subdivision (integer)

    !-----------------------------------------------------------------------

    double precision :: absarea
    parameter (num1 = 100)

    dimension dx(num1) , x2(num1) , x3(num1) , f2(num1) , &
    f3(num1) , epsp(num1) , f4(num1) , fmp(num1) , &
    fbp(num1) , est2(num1) , est3(num1) , &
    pval(num1,3) , irtrn(num1)

    !       initialise the return level array.

    do 30 i = 1,num1
        irtrn(i) = 0
    30 END DO
    if(nitn > 50) stop 'Sorry, I only do 50 iterations!'

    a = alim
    b = blim
    eps = tol
    lvl = 0
    est = 1.0
    absarea = 1.0
    da = b - a
    fm = 4.0 * f((a+b)/2.0,zc)
    fa = f(a,zc)
    fb = f(b,zc)

    10 continue
    lvl = lvl + 1
    dx(lvl) = da / 3.0
    sx = dx(lvl) / 6.0
    f1 = 4.0 * f(a+dx(lvl)/2.0,zc)
    x2(lvl) = a + dx(lvl)
    f2(lvl) = f(x2(lvl),zc)
    x3(lvl) = x2(lvl) + dx(lvl)
    f3(lvl) = f(x3(lvl),zc)
    epsp(lvl) = eps
    f4(lvl) = 4.0 * f(x3(lvl) + dx(lvl)/2.0,zc)
    fmp(lvl) = fm
    est1 = ( fa + f1 + f2(lvl)) * sx
    fbp(lvl) = fb
    est2(lvl) = (f2(lvl) + f3(lvl) + fm) * sx
    est3(lvl) = (f3(lvl) + f4(lvl) + fb) * sx
    sum = est1 + est2(lvl) + est3(lvl)
    absarea = absarea - abs(est) + abs(est1) + &
    abs(est2(lvl)) + abs(est3(lvl))

    if ((abs(est-sum) <= epsp(lvl) * absarea &
     .AND. est /= 1.0) &
     .OR. lvl >= nitn) then
        lvl = lvl - 1
        pval(lvl,irtrn(lvl)) = sum
        ipoint = irtrn(lvl) + 1
        goto (1,2,3,4) ipoint
    endif

    1 da = dx(lvl)
    fm = f1
    fb = f2(lvl)
    est = est1
    eps = epsp(lvl) / 1.7
    irtrn(lvl) = 1

    goto 10

    2 da = dx(lvl)
    fa = f2(lvl)
    fm = fmp(lvl)
    fb = f3(lvl)
    eps = epsp(lvl) / 1.7
    est = est2(lvl)
    a = x2(lvl)
    irtrn(lvl) = 2

    goto 10

    3 da = dx(lvl)
    fa = f3(lvl)
    fm = f4(lvl)
    fb = fbp(lvl)
    eps = epsp(lvl) / 1.7
    est = est3(lvl)
    a = x3(lvl)
    irtrn(lvl) = 3

    goto 10

    4 sum = pval(lvl,1) + pval(lvl,2) + pval(lvl,3)

    if ( lvl > 1 ) then
        lvl = lvl - 1
        pval(lvl,irtrn(lvl)) = sum
        ipoint = irtrn(lvl) + 1
        goto (1,2,3,4) ipoint
    endif

    simpsonf = sum
    return
end function simpsonf

function simpsong(alim,blim,tol,nitn)
    !-----------------------------------------------------------------------

    !       simpson performs numerical integration over the interval
    !       a,b of the function f. the method employed is modified
    !       simpson's rule. the procedure was adapted from algorithm
    !       182 of "collected algorithms from acm" vol. 1.
    !       the algorithm has been tested and found particularly useful
    !       for integration of a strongly peaked function. the function
    !       used for testing was not able to be suitably evaluated using
    !       gauss quadrature or romberg integration.

    ! PARAMETERS:

    !       a    -    lower limit of integration      (real)
    !       b    -    upper limit of integration      (real)
    !       eps  -    required tolerance            (real)
    !       nitn -    maximum level of subdivision (integer)

    !-----------------------------------------------------------------------

    double precision :: absarea
    parameter (num1 = 100)

    dimension dx(num1) , x2(num1) , x3(num1) , f2(num1) , &
    f3(num1) , epsp(num1) , f4(num1) , fmp(num1) , &
    fbp(num1) , est2(num1) , est3(num1) , &
    pval(num1,3) , irtrn(num1)

    !       initialise the return level array.

    do 30 i = 1,num1
        irtrn(i) = 0
    30 END DO
    if(nitn > 50) stop 'Sorry, I only do 50 iterations!'

    a = alim
    b = blim
    eps = tol
    lvl = 0
    est = 1.0
    absarea = 1.0
    da = b - a
    fm = 4.0 * g((a+b)/2.0)
    fa = g(a)
    fb = g(b)

    10 continue
    lvl = lvl + 1
    dx(lvl) = da / 3.0
    sx = dx(lvl) / 6.0
    f1 = 4.0 * g(a+dx(lvl)/2.0)
    x2(lvl) = a + dx(lvl)
    f2(lvl) = g(x2(lvl))
    x3(lvl) = x2(lvl) + dx(lvl)
    f3(lvl) = g(x3(lvl))
    epsp(lvl) = eps
    f4(lvl) = 4.0 * g(x3(lvl) + dx(lvl)/2.0)
    fmp(lvl) = fm
    est1 = ( fa + f1 + f2(lvl)) * sx
    fbp(lvl) = fb
    est2(lvl) = (f2(lvl) + f3(lvl) + fm) * sx
    est3(lvl) = (f3(lvl) + f4(lvl) + fb) * sx
    sum = est1 + est2(lvl) + est3(lvl)
    absarea = absarea - abs(est) + abs(est1) + &
    abs(est2(lvl)) + abs(est3(lvl))

    if ((abs(est-sum) <= epsp(lvl) * absarea &
     .AND. est /= 1.0) &
     .OR. lvl >= nitn) then
        lvl = lvl - 1
        pval(lvl,irtrn(lvl)) = sum
        ipoint = irtrn(lvl) + 1
        goto (1,2,3,4) ipoint
    endif

    1 da = dx(lvl)
    fm = f1
    fb = f2(lvl)
    est = est1
    eps = epsp(lvl) / 1.7
    irtrn(lvl) = 1

    goto 10

    2 da = dx(lvl)
    fa = f2(lvl)
    fm = fmp(lvl)
    fb = f3(lvl)
    eps = epsp(lvl) / 1.7
    est = est2(lvl)
    a = x2(lvl)
    irtrn(lvl) = 2

    goto 10

    3 da = dx(lvl)
    fa = f3(lvl)
    fm = f4(lvl)
    fb = fbp(lvl)
    eps = epsp(lvl) / 1.7
    est = est3(lvl)
    a = x3(lvl)
    irtrn(lvl) = 3

    goto 10

    4 sum = pval(lvl,1) + pval(lvl,2) + pval(lvl,3)

    if ( lvl > 1 ) then
        lvl = lvl - 1
        pval(lvl,irtrn(lvl)) = sum
        ipoint = irtrn(lvl) + 1
        goto (1,2,3,4) ipoint
    endif

    simpsong = sum
    return
end function simpsong


      SUBROUTINE MB03TD( TYP, COMPU, SELECT, LOWER, N, A, LDA, G, LDG,
     $                   U1, LDU1, U2, LDU2, WR, WI, M, DWORK, LDWORK,
     $                   INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To reorder a matrix X in skew-Hamiltonian Schur form:
C
C                   [  A   G  ]          T
C             X  =  [       T ],   G = -G,
C                   [  0   A  ]
C
C     or in Hamiltonian Schur form:
C
C                   [  A   G  ]          T
C             X  =  [       T ],   G =  G,
C                   [  0  -A  ]
C
C     where A is in upper quasi-triangular form, so that a selected
C     cluster of eigenvalues appears in the leading diagonal blocks
C     of the matrix A (in X) and the leading columns of [ U1; -U2 ] form
C     an orthonormal basis for the corresponding right invariant
C     subspace.
C
C     If X is skew-Hamiltonian, then each eigenvalue appears twice; one
C     copy corresponds to the j-th diagonal element and the other to the
C     (n+j)-th diagonal element of X. The logical array LOWER controls
C     which copy is to be reordered to the leading part of A.
C
C     If X is Hamiltonian then the eigenvalues appear in pairs
C     (lambda,-lambda); lambda corresponds to the j-th diagonal
C     element and -lambda to the (n+j)-th diagonal element of X.
C     The logical array LOWER controls whether lambda or -lambda is to
C     be reordered to the leading part of A.
C
C     The matrix A must be in Schur canonical form (as returned by the
C     LAPACK routine DHSEQR), that is, block upper triangular with
C     1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block has
C     its diagonal elements equal and its off-diagonal elements of
C     opposite sign.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     TYP     CHARACTER*1
C             Specifies the type of the input matrix X:
C             = 'S': X is skew-Hamiltonian;
C             = 'H': X is Hamiltonian.
C
C     COMPU   CHARACTER*1
C             = 'U': update the matrices U1 and U2 containing the
C                    Schur vectors;
C             = 'N': do not update U1 and U2.
C
C     SELECT  (input/output) LOGICAL array, dimension (N)
C             SELECT specifies the eigenvalues in the selected cluster.
C             To select a real eigenvalue w(j), SELECT(j) must be set
C             to .TRUE.. To select a complex conjugate pair of
C             eigenvalues w(j) and w(j+1), corresponding to a 2-by-2
C             diagonal block, both SELECT(j) and SELECT(j+1) must be set
C             to .TRUE.; a complex conjugate pair of eigenvalues must be
C             either both included in the cluster or both excluded.
C
C     LOWER   (input/output) LOGICAL array, dimension (N)
C             LOWER controls which copy of a selected eigenvalue is
C             included in the cluster. If SELECT(j) is set to .TRUE.
C             for a real eigenvalue w(j); then LOWER(j) must be set to
C             .TRUE. if the eigenvalue corresponding to the (n+j)-th
C             diagonal element of X is to be reordered to the leading
C             part; and LOWER(j) must be set to .FALSE. if the
C             eigenvalue corresponding to the j-th diagonal element of
C             X is to be reordered to the leading part. Similarly, for
C             a complex conjugate pair of eigenvalues w(j) and w(j+1),
C             both LOWER(j) and LOWER(j+1) must be set to .TRUE. if the
C             eigenvalues corresponding to the (n+j:n+j+1,n+j:n+j+1)
C             diagonal block of X are to be reordered to the leading
C             part.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix A. N >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the upper quasi-triangular matrix A in Schur
C             canonical form.
C             On exit, the leading N-by-N part of this array contains
C             the reordered matrix A, again in Schur canonical form,
C             with the selected eigenvalues in the diagonal blocks.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= MAX(1,N).
C
C     G       (input/output) DOUBLE PRECISION array, dimension (LDG,N)
C             On entry, if TYP = 'S', the leading N-by-N part of this
C             array must contain the strictly upper triangular part of
C             the skew-symmetric matrix G. The rest of this array is not
C             referenced.
C             On entry, if TYP = 'H', the leading N-by-N part of this
C             array must contain the upper triangular part of the
C             symmetric matrix G. The rest of this array is not
C             referenced.
C             On exit, if TYP = 'S', the leading N-by-N part of this
C             array contains the strictly upper triangular part of the
C             skew-symmetric matrix G, updated by the orthogonal
C             symplectic transformation which reorders X.
C             On exit, if TYP = 'H', the leading N-by-N part of this
C             array contains the upper triangular part of the symmetric
C             matrix G, updated by the orthogonal symplectic
C             transformation which reorders X.
C
C     LDG     INTEGER
C             The leading dimension of the array G.  LDG >= MAX(1,N).
C
C     U1      (input/output) DOUBLE PRECISION array, dimension (LDU1,N)
C             On entry, if COMPU = 'U', the leading N-by-N part of this
C             array must contain U1, the (1,1) block of an orthogonal
C             symplectic matrix U = [ U1, U2; -U2, U1 ].
C             On exit, if COMPU = 'U', the leading N-by-N part of this
C             array contains the (1,1) block of the matrix U,
C             postmultiplied by the orthogonal symplectic transformation
C             which reorders X. The leading M columns of U form an
C             orthonormal basis for the specified invariant subspace.
C             If COMPU = 'N', this array is not referenced.
C
C     LDU1    INTEGER
C             The leading dimension of the array U1.
C             LDU1 >= MAX(1,N),  if COMPU = 'U';
C             LDU1 >= 1,         otherwise.
C
C     U2      (input/output) DOUBLE PRECISION array, dimension (LDU2,N)
C             On entry, if COMPU = 'U', the leading N-by-N part of this
C             array must contain U2, the (1,2) block of an orthogonal
C             symplectic matrix U = [ U1, U2; -U2, U1 ].
C             On exit, if COMPU = 'U', the leading N-by-N part of this
C             array contains the (1,2) block of the matrix U,
C             postmultiplied by the orthogonal symplectic transformation
C             which reorders X.
C             If COMPU = 'N', this array is not referenced.
C
C     LDU2    INTEGER
C             The leading dimension of the array U2.
C             LDU2 >= MAX(1,N),  if COMPU = 'U';
C             LDU2 >= 1,         otherwise.
C
C     WR      (output) DOUBLE PRECISION array, dimension (N)
C     WI      (output) DOUBLE PRECISION array, dimension (N)
C             The real and imaginary parts, respectively, of the
C             reordered eigenvalues of A. The eigenvalues are stored
C             in the same order as on the diagonal of A, with
C             WR(i) = A(i,i) and, if A(i:i+1,i:i+1) is a 2-by-2 diagonal
C             block, WI(i) > 0 and WI(i+1) = -WI(i). Note that if an
C             eigenvalue is sufficiently ill-conditioned, then its value
C             may differ significantly from its value before reordering.
C
C     M       (output) INTEGER
C             The dimension of the specified invariant subspace.
C             0 <= M <= N.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0,  DWORK(1)  returns the optimal
C             value of LDWORK.
C             On exit, if  INFO = -18,  DWORK(1)  returns the minimum
C             value of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.  LDWORK >= MAX(1,N).
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C             = 1:  reordering of X failed because some eigenvalue pairs
C                   are too close to separate (the problem is very
C                   ill-conditioned); X may have been partially
C                   reordered, and WR and WI contain the eigenvalues in
C                   the same order as in X.
C
C     REFERENCES
C
C     [1] Bai, Z. and Demmel, J.W.
C         On Swapping Diagonal Blocks in Real Schur Form.
C         Linear Algebra Appl., 186, pp. 73-95, 1993.
C
C     [2] Benner, P., Kressner, D., and Mehrmann, V.
C         Skew-Hamiltonian and Hamiltonian Eigenvalue Problems: Theory,
C         Algorithms and Applications. Techn. Report, TU Berlin, 2003.
C
C     CONTRIBUTORS
C
C     D. Kressner, Technical Univ. Berlin, Germany, and
C     P. Benner, Technical Univ. Chemnitz, Germany, December 2003.
C
C     REVISIONS
C
C     V. Sima, May 2008 (SLICOT version of the HAPACK routine DHAORD).
C
C     KEYWORDS
C
C     Hamiltonian matrix, skew-Hamiltonian matrix, invariant subspace.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         COMPU, TYP
      INTEGER           INFO, LDA, LDG, LDU1, LDU2, LDWORK, M, N
C     .. Array Arguments ..
      LOGICAL           LOWER(*), SELECT(*)
      DOUBLE PRECISION  A(LDA,*), DWORK(*), G(LDG,*), U1(LDU1,*),
     $                  U2(LDU2,*), WI(*), WR(*)
C     .. Local Scalars ..
      LOGICAL           FLOW, ISHAM, PAIR, SWAP, WANTU
      INTEGER           HERE, IERR, IFST, ILST, K, KS, NBF, NBL, NBNEXT,
     $                  WRKMIN
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          MB03TS, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         DBLE, MAX
C
C     .. Executable Statements ..
C
C     Decode and check input parameters.
C
      ISHAM = LSAME( TYP, 'H' )
      WANTU = LSAME( COMPU, 'U' )
      WRKMIN = MAX( 1, N )
      INFO = 0
      IF ( .NOT.ISHAM .AND. .NOT.LSAME( TYP, 'S' ) ) THEN
         INFO = -1
      ELSE IF ( .NOT.WANTU .AND. .NOT.LSAME( COMPU, 'N' ) ) THEN
         INFO = -2
      ELSE IF ( N.LT.0 ) THEN
         INFO = -5
      ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF ( LDG.LT.MAX( 1, N ) ) THEN
         INFO = -9
      ELSE IF ( LDU1.LT.1 .OR. ( WANTU .AND. LDU1.LT.N ) ) THEN
         INFO = -11
      ELSE IF ( LDU2.LT.1 .OR. ( WANTU .AND. LDU2.LT.N ) ) THEN
         INFO = -13
      ELSE IF ( LDWORK.LT.WRKMIN ) THEN
         INFO = -18
         DWORK(1) = DBLE( WRKMIN )
      END IF
C
C     Return if there were illegal values.
C
      IF ( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB03TD', -INFO )
         RETURN
      END IF
C
C     Set M to the dimension of the specified invariant subspace.
C
      M = 0
      PAIR = .FALSE.
      DO 10 K = 1, N
         IF ( PAIR ) THEN
            PAIR = .FALSE.
         ELSE
            IF ( K.LT.N ) THEN
               IF ( A(K+1,K).EQ.ZERO ) THEN
                  IF ( SELECT(K) )
     $               M = M + 1
               ELSE
                  PAIR = .TRUE.
                  IF ( SELECT(K) .OR. SELECT(K+1) )
     $               M = M + 2
               END IF
            ELSE
               IF ( SELECT(N) )
     $            M = M + 1
            END IF
         END IF
   10 CONTINUE
C
C     Quick return if possible.
C
      IF ( N.EQ.0 ) THEN
         DWORK(1) = ONE
         RETURN
      END IF
C
C     Collect the selected blocks at the top-left corner of X.
C
      KS = 0
      PAIR = .FALSE.
      DO 60 K = 1, N
         IF ( PAIR ) THEN
            PAIR = .FALSE.
         ELSE
            SWAP = SELECT(K)
            FLOW = LOWER(K)
            IF  ( K.LT.N ) THEN
               IF ( A(K+1,K).NE.ZERO ) THEN
                  PAIR = .TRUE.
                  SWAP = SWAP.OR.SELECT(K+1)
                  FLOW = FLOW.OR.LOWER(K+1)
               END IF
            END IF
C
            IF ( PAIR ) THEN
               NBF = 2
            ELSE
               NBF = 1
            END IF
C
            IF ( SWAP ) THEN
               KS = KS + 1
               IF ( FLOW ) THEN
C
C                 Step 1: Swap the K-th block to position N.
C
                  IFST = K
                  ILST = N
                  NBL = 1
                  IF ( ILST.GT.1 ) THEN
                     IF ( A(ILST,ILST-1).NE.ZERO ) THEN
                        ILST = ILST - 1
                        NBL = 2
                     END IF
                  END IF
C
C                 Update ILST.
C
                  IF ( NBF.EQ.2 .AND. NBL.EQ.1 )
     $               ILST = ILST - 1
                  IF ( NBF.EQ.1 .AND. NBL.EQ.2 )
     $               ILST = ILST + 1
C
                  IF ( ILST.EQ.IFST )
     $               GO TO 30
C
                  HERE = IFST
C
   20             CONTINUE
C
C                 Swap block with next one below.
C
                  IF ( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN
C
C                    Current block is either 1-by-1 or 2-by-2.
C
                     NBNEXT = 1
                     IF ( HERE+NBF+1.LE.N ) THEN
                        IF ( A(HERE+NBF+1,HERE+NBF).NE.ZERO )
     $                     NBNEXT = 2
                     END IF
                     CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1,
     $                            LDU1, U2, LDU2, HERE, NBF, NBNEXT,
     $                            DWORK, IERR )
                     IF ( IERR.NE.0 ) THEN
                        INFO = 1
                        GO TO 70
                     END IF
                     HERE = HERE + NBNEXT
C
C                    Test if 2-by-2 block breaks into two 1-by-1 blocks.
C
                     IF ( NBF.EQ.2 ) THEN
                        IF ( A(HERE+1,HERE).EQ.ZERO )
     $                     NBF = 3
                     END IF
C
                  ELSE
C
C                    Current block consists of two 1-by-1 blocks each of
C                    which must be swapped individually.
C
                     NBNEXT = 1
                     IF ( HERE+3.LE.N ) THEN
                        IF ( A(HERE+3,HERE+2).NE.ZERO )
     $                     NBNEXT = 2
                     END IF
                     CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1,
     $                            LDU1, U2, LDU2, HERE+1, 1, NBNEXT,
     $                            DWORK, IERR )
                     IF ( IERR.NE.0 ) THEN
                        INFO = 1
                        GO TO 70
                     END IF
                     IF ( NBNEXT.EQ.1 ) THEN
C
C                       Swap two 1-by-1 blocks, no problems possible.
C
                        CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG,
     $                               U1, LDU1, U2, LDU2, HERE, 1,
     $                               NBNEXT, DWORK, IERR )
                        HERE = HERE + 1
                     ELSE
C
C                       Recompute NBNEXT in case 2 by 2 split.
C
                        IF ( A(HERE+2,HERE+1).EQ.ZERO )
     $                     NBNEXT = 1
                        IF ( NBNEXT.EQ.2 ) THEN
C
C                          2-by-2 block did not split
C
                           CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG,
     $                                  U1, LDU1, U2, LDU2, HERE, 1,
     $                                  NBNEXT, DWORK, IERR )
                           IF ( IERR.NE.0 ) THEN
                              INFO = 1
                              GO TO 70
                           END IF
                           HERE = HERE + 2
                        ELSE
C
C                          2-by-2 block did split
C
                           CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG,
     $                                  U1, LDU1, U2, LDU2, HERE, 1, 1,
     $                                  DWORK, IERR )
                           CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG,
     $                                  U1, LDU1, U2, LDU2, HERE+1, 1,
     $                                  1, DWORK, IERR )
                           HERE = HERE + 2
                        END IF
                     END IF
                  END IF
                  IF ( HERE.LT.ILST )
     $               GO TO 20
C
   30             CONTINUE
C
C                 Step 2: Apply an orthogonal symplectic transformation
C                         to swap the last blocks in A and -A' (or A').
C
                  IF ( NBF.EQ.1 ) THEN
C
C                    Exchange columns/rows N <-> 2*N. No problems
C                    possible.
C
                     CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG,
     $                            U1, LDU1, U2, LDU2, N, 1, 1,
     $                            DWORK, IERR )
C
                  ELSE IF ( NBF.EQ.2 ) THEN
C
C                    Swap last block with its equivalent by an
C                    orthogonal symplectic transformation.
C
                     CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG,
     $                            U1, LDU1, U2, LDU2, N-1, 2, 2,
     $                            DWORK, IERR )
                     IF ( IERR.NE.0 ) THEN
                        INFO = 1
                        GO TO 70
                     END IF
C
C                    Test if 2-by-2 block breaks into two 1-by-1 blocks.
C
                     IF ( A(N-1,N).EQ.ZERO )
     $                  NBF = 3
                  ELSE
C
C                    Block did split. Swap (N-1)-th and N-th elements
C                    consecutively by symplectic generalized
C                    permutations and one rotation.
C
                     CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1,
     $                            LDU1, U2, LDU2, N, 1, 1, DWORK, IERR )
                     CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1,
     $                            LDU1, U2, LDU2, N-1, 1, 1, DWORK,
     $                            IERR )
                     CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1,
     $                            LDU1, U2, LDU2, N, 1, 1, DWORK, IERR )
                  END IF
                  IFST = N
                  IF ( PAIR )
     $               IFST = N-1
               ELSE
                  IFST = K
               END IF
C
C              Step 3: Swap the K-th / N-th block to position KS.
C
               ILST = KS
               NBL = 1
               IF ( ILST.GT.1 ) THEN
                  IF ( A(ILST,ILST-1).NE.ZERO ) THEN
                     ILST = ILST - 1
                     NBL = 2
                  END IF
               END IF
C
               IF ( ILST.EQ.IFST )
     $            GO TO 50
C
               HERE = IFST
   40          CONTINUE
C
C              Swap block with next one above.
C
               IF ( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN
C
C                 Current block either 1 by 1 or 2 by 2.
C
                  NBNEXT = 1
                  IF ( HERE.GE.3 ) THEN
                     IF ( A(HERE-1,HERE-2).NE.ZERO )
     $                  NBNEXT = 2
                  END IF
                  CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1,
     $                         LDU1, U2, LDU2, HERE-NBNEXT, NBNEXT,
     $                         NBF, DWORK, IERR )
                  IF ( IERR.NE.0 ) THEN
                     INFO = 1
                     GO TO 70
                  END IF
                  HERE = HERE - NBNEXT
C
C                 Test if 2-by-2 block breaks into two 1-by-1 blocks.
C
                  IF ( NBF.EQ.2 ) THEN
                     IF ( A(HERE+1,HERE).EQ.ZERO )
     $                  NBF = 3
                  END IF
C
               ELSE
C
C                 Current block consists of two 1 by 1 blocks each of
C                 which must be swapped individually.
C
                  NBNEXT = 1
                  IF ( HERE.GE.3 ) THEN
                     IF ( A(HERE-1,HERE-2).NE.ZERO )
     $                  NBNEXT = 2
                  END IF
                  CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1,
     $                         LDU1, U2, LDU2, HERE-NBNEXT, NBNEXT,
     $                         1, DWORK, IERR )
                  IF ( IERR.NE.0 ) THEN
                     INFO = 1
                     GO TO 70
                  END IF
                  IF ( NBNEXT.EQ.1 ) THEN
C
C                    Swap two 1-by-1 blocks, no problems possible.
C
                     CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1,
     $                            LDU1, U2, LDU2, HERE, NBNEXT, 1,
     $                            DWORK, IERR )

                     HERE = HERE - 1
                  ELSE
C
C                    Recompute NBNEXT in case 2-by-2 split.
C
                     IF ( A(HERE,HERE-1).EQ.ZERO )
     $                  NBNEXT = 1
                     IF ( NBNEXT.EQ.2 ) THEN
C
C                       2-by-2 block did not split
C
                        CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG,
     $                               U1, LDU1, U2, LDU2, HERE-1, 2, 1,
     $                               DWORK, IERR )
                        IF ( IERR.NE.0 ) THEN
                           INFO = 1
                           GO TO 70
                        END IF
                        HERE = HERE - 2
                     ELSE
C
C                       2-by-2 block did split
C
                        CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG,
     $                               U1, LDU1, U2, LDU2, HERE, 1, 1,
     $                               DWORK, IERR )
                        CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG,
     $                               U1, LDU1, U2, LDU2, HERE-1, 1, 1,
     $                               DWORK, IERR )
                        HERE = HERE - 2
                     END IF
                  END IF
               END IF
C
               IF ( HERE.GT.ILST )
     $            GO TO 40
C
   50          CONTINUE
               IF ( PAIR )
     $            KS = KS + 1
            END IF
         END IF
   60 CONTINUE
C
   70 CONTINUE
C
C     Store eigenvalues.
C
      DO 80 K = 1, N
         WR(K) = A(K,K)
         WI(K) = ZERO
   80 CONTINUE
      DO 90 K = 1, N - 1
         IF ( A(K+1,K).NE.ZERO ) THEN
            WI(K) = SQRT( ABS( A(K,K+1) ) )*
     $              SQRT( ABS( A(K+1,K) ) )
            WI(K+1) = -WI(K)
         END IF
   90 CONTINUE
C
      DWORK(1) = DBLE( WRKMIN )
C
      RETURN
C *** Last line of MB03TD ***
      END


MODULE NCA_HLOCAL
  USE NCA_VARS_GLOBAL
  USE NCA_AUX_FUNX
  !
  USE SF_CONSTANTS,only:zero
  implicit none
  private

  public :: build_hlocal
  public :: build_c_operator
  public :: build_cdg_operator

contains

  !+------------------------------------------------------------------+
  !PURPOSE  : Build Hamiltonian sparse matrix DOUBLE PRECISION
  !+------------------------------------------------------------------+
  subroutine build_hlocal(isector,Hmat)
    real(8),dimension(:,:)             :: Hmat
    integer                            :: isector
    integer,dimension(:),allocatable   :: Hmap    !map of the Sector S to Hilbert space H
    integer,dimension(Ntot)            :: ib
    integer                            :: dim
    integer                            :: i,j,m,iorb,jorb,ispin,impi,ishift
    integer                            :: k1,k2,k3,k4
    real(8)                            :: sg1,sg2,sg3,sg4
    real(8),dimension(Norb)            :: nup,ndw
    real(8)                            :: htmp
    real(8),dimension(Nspin,Norb)      :: eloc
    logical                            :: Jcondition
    integer                            :: first_state,last_state
    !
    dim=getdim(isector)
    allocate(Hmap(dim))
    call build_sector(isector,Hmap)
    !
    if(size(Hmat,1)/=dim.OR.size(Hmat,2)/=dim)stop "NCA_HLOCAL/build_hlocal: wrong dimensions in H"
    Hmat = 0.d0
    !
    ishift     = 0
    first_state= 1
    last_state = dim
    !
    !Get diagonal part of Hloc
    do ispin=1,Nspin
       do iorb=1,Norb
          eloc(ispin,iorb)=dreal(Hloc(ispin,ispin,iorb,iorb))
       enddo
    enddo
    !
    !-----------------------------------------------!
    states: do i=first_state,last_state
       m=Hmap(i)
       impi = i-ishift
       call bdecomp(m,ib)
       htmp=0.d0
       do iorb=1,Norb
          nup(iorb)=dble(ib(iorb))
          ndw(iorb)=dble(ib(iorb+Ns))
       enddo
       !
       !LOCAL HAMILTONIAN PART:
       !local energies
       htmp = htmp - xmu*(sum(nup)+sum(ndw))
       htmp = htmp + dot_product(eloc(1,:),nup) + dot_product(eloc(Nspin,:),ndw)
       !
       !Density-density interaction: same orbital, opposite spins
       !Euloc=\sum=i U_i*(n_u*n_d)_i
       htmp = htmp + dot_product(uloc,nup*ndw)!=\sum=i U_i*(n_u*n_d)_i
       if(Norb>1)then
          !density-density interaction: different orbitals, opposite spins
          !Eust=\sum_ij Ust*(n_up_i*n_dn_j + n_up_j*n_dn_i)
          !    "="\sum_ij (Uloc - 2*Jh)*(n_up_i*n_dn_j + n_up_j*n_dn_i)
          do iorb=1,Norb
             do jorb=iorb+1,Norb
                htmp = htmp + Ust*(nup(iorb)*ndw(jorb) + nup(jorb)*ndw(iorb))
             enddo
          enddo
          !density-density interaction: different orbitals, parallel spins
          !Eund = \sum_ij Und*(n_up_i*n_up_j + n_dn_i*n_dn_j)
          !    "="\sum_ij (Ust-Jh)*(n_up_i*n_up_j + n_dn_i*n_dn_j)
          !    "="\sum_ij (Uloc-3*Jh)*(n_up_i*n_up_j + n_dn_i*n_dn_j)
          do iorb=1,Norb
             do jorb=iorb+1,Norb
                htmp = htmp + (Ust-Jh)*(nup(iorb)*nup(jorb) + ndw(iorb)*ndw(jorb))
             enddo
          enddo
       endif
       !if using the Hartree-shifted chemical potential: mu=0 for half-filling
       !sum up the contributions of hartree terms:
       if(hfmode)then
          htmp=htmp - 0.5d0*dot_product(uloc,nup+ndw) + 0.25d0*sum(uloc)
          if(Norb>1)then
             do iorb=1,Norb
                do jorb=iorb+1,Norb
                   htmp=htmp-0.5d0*Ust*(nup(iorb)+ndw(iorb)+nup(jorb)+ndw(jorb))+0.25d0*Ust
                   htmp=htmp-0.5d0*(Ust-Jh)*(nup(iorb)+ndw(iorb)+nup(jorb)+ndw(jorb))+0.25d0*(Ust-Jh)
                enddo
             enddo
          endif
       endif
       !
       Hmat(impi,i)=Hmat(impi,i)+htmp
       !
       !SPIN-EXCHANGE (S-E) and PAIR-HOPPING TERMS
       !S-E: J c^+_iorb_up c^+_jorb_dw c_iorb_dw c_jorb_up  (i.ne.j)
       !S-E: J c^+_{iorb} c^+_{jorb+Ns} c_{iorb+Ns} c_{jorb}
       if(Norb>1.AND.Jhflag)then
          do iorb=1,Norb
             do jorb=1,Norb
                Jcondition=(&
                     (iorb/=jorb).AND.&
                     (ib(jorb)==1).AND.&
                     (ib(iorb+Ns)==1).AND.&
                     (ib(jorb+Ns)==0).AND.&
                     (ib(iorb)==0))
                if(Jcondition)then
                   call c(jorb,m,k1,sg1)
                   call c(iorb+Ns,k1,k2,sg2)
                   call cdg(jorb+Ns,k2,k3,sg3)
                   call cdg(iorb,k3,k4,sg4)
                   j=binary_search(Hmap,k4)
                   htmp = Jh*sg1*sg2*sg3*sg4
                   !
                   Hmat(impi,j)=Hmat(impi,j)+htmp
                   !
                endif
             enddo
          enddo
       endif
       !
       !PAIR-HOPPING (P-H) TERMS
       !P-H: J c^+_iorb_up c^+_iorb_dw   c_jorb_dw   c_jorb_up  (i.ne.j)
       !P-H: J c^+_{iorb}  c^+_{iorb+Ns} c_{jorb+Ns} c_{jorb}
       if(Norb>1.AND.Jhflag)then
          do iorb=1,Norb
             do jorb=1,Norb
                Jcondition=(&
                     (iorb/=jorb).AND.&
                     (ib(jorb)==1).AND.&
                     (ib(jorb+Ns)==1).AND.&
                     (ib(iorb+Ns)==0).AND.&
                     (ib(iorb)==0))
                if(Jcondition)then
                   call c(jorb,m,k1,sg1)
                   call c(jorb+Ns,k1,k2,sg2)
                   call cdg(iorb+Ns,k2,k3,sg3)
                   call cdg(iorb,k3,k4,sg4)
                   j=binary_search(Hmap,k4)
                   htmp = Jh*sg1*sg2*sg3*sg4
                   !
                   Hmat(impi,j)=Hmat(impi,j)+htmp
                   !
                endif
             enddo
          enddo
       endif
       !
       !
       !
       !IMPURITY LOCAL HYBRIDIZATION
       do iorb=1,Norb
          do jorb=1,Norb
             !SPIN UP
             if((ib(iorb)==0).AND.(ib(jorb)==1))then
                call c(jorb,m,k1,sg1)
                call cdg(iorb,k1,k2,sg2)
                j=binary_search(Hmap,k2)
                htmp = Hloc(1,1,iorb,jorb)*sg1*sg2
                !
                Hmat(impi,j)=Hmat(impi,j)+htmp
                !
             endif
             !SPIN DW
             if((ib(iorb+Ns)==0).AND.(ib(jorb+Ns)==1))then
                call c(jorb+Ns,m,k1,sg1)
                call cdg(iorb+Ns,k1,k2,sg2)
                j=binary_search(Hmap,k2)
                htmp = Hloc(Nspin,Nspin,iorb,jorb)*sg1*sg2
                !
                Hmat(impi,j)=Hmat(impi,j)+htmp
                !
             endif
          enddo
       enddo
       !
    enddo states

    !-----------------------------------------------!
    !
    deallocate(Hmap)
    !
  end subroutine build_hlocal

end MODULE NCA_HLOCAL


subroutine interp_tracer(t0,t1,IPP)
    use global,only: Nx,Ny,dtp,xyz,dic,djc,dkc,pi2c,pj2c,pk2c,Npts,theta,salt,gam,tsg,NPP,tt,phihyd,fn_PHIHYD
    implicit none
    integer*8,intent(in) :: t0,t1,IPP
    integer*8 :: i,j,k,ip
    real*8 :: tmp0,tmp1
    real*4 :: tmp(2,2,2)

   if (trim(fn_PHIHYD) .ne. '') then
   call load_PHIHYD(tt)
   endif

!$OMP PARALLEL DO PRIVATE(ip,i,j,k,tmp0,tmp1) SHARED(IPP,t0,t1,dic,djc,dkc,theta,salt,gam,tsg,dtp,phihyd) SCHEDULE(dynamic)
        do ip=1,npts

            if (xyz(ip,2,IPP)<Ny-1) then
                tmp0=0d0
                tmp1=0d0
                i=floor(mod(xyz(ip,1,IPP),real(Nx-1))-0.5d0)
                j=floor(xyz(ip,2,IPP)-0.5d0)
                k=floor(xyz(ip,3,IPP)-0.5d0)

                tmp=theta(i:i+1,j:j+1,k:k+1,t0)
                where(tmp==0)tmp=maxval(tmp)
                call interp_trilinear(dic(ip,IPP),djc(ip,IPP),dkc(ip,IPP),tmp,tmp0)
                tmp=theta(i:i+1,j:j+1,k:k+1,t1)
                where(tmp==0)tmp=maxval(tmp)
                call interp_trilinear(dic(ip,IPP),djc(ip,IPP),dkc(ip,IPP),tmp,tmp1)
                tsg(ip,1,IPP) = (tmp1-tmp0)*dtp+ tmp0

                tmp=salt(i:i+1,j:j+1,k:k+1,t0)
                where(tmp==0)tmp=maxval(tmp)
                call interp_trilinear(dic(ip,IPP),djc(ip,IPP),dkc(ip,IPP),tmp,tmp0)
                tmp=salt(i:i+1,j:j+1,k:k+1,t1)
                where(tmp==0)tmp=maxval(tmp)
                call interp_trilinear(dic(ip,IPP),djc(ip,IPP),dkc(ip,IPP),tmp,tmp1)
                tsg(ip,2,IPP) = (tmp1-tmp0)*dtp + tmp0

                tmp=gam(i:i+1,j:j+1,k:k+1,t0)
                where(tmp==0)tmp=maxval(tmp)
                call interp_trilinear(dic(ip,IPP),djc(ip,IPP),dkc(ip,IPP),tmp,tmp0)
                tmp=gam(i:i+1,j:j+1,k:k+1,t1)
                where(tmp==0)tmp=maxval(tmp)
                call interp_trilinear(dic(ip,IPP),djc(ip,IPP),dkc(ip,IPP),tmp,tmp1)
                tsg(ip,3,IPP) = (tmp1-tmp0)*dtp + tmp0

                if (trim(fn_PHIHYD) .ne. '') then
                    call interp_bilinear(dic(ip,IPP),djc(ip,IPP),phihyd(i:i+1,j:j+1),tmp0)
                    tsg(ip,4,IPP) = tmp0
                endif

            endif
    enddo
!$OMP END PARALLEL DO

end subroutine interp_tracer


! =====================================================
subroutine rpn2_ptwise(ixy, num_eqn, num_aux, num_waves, q_l, q_r,            &
aux_l, aux_r, wave, s, amdq, apdq)
! =====================================================

! Riemann solver for the sample scalar equation
!  q_t + u*q_x + v*q_y = 0

! waves: 1
! equations: 1

! Conserved quantities:
!       1 q

! On input, ql contains the state vector at the left edge of each cell
!           qr contains the state vector at the right edge of each cell

! This data is along a slice in the x-direction if ixy=1
!                            or the y-direction if ixy=2.
! On output, wave contains the waves,
!            s the speeds,
!
!            amdq = A^- Delta q,
!            apdq = A^+ Delta q,
!                   the decomposition of the flux difference
!                       f(qr(i-1)) - f(ql(i))
!                   into leftgoing and rightgoing parts respectively.
!

! maux=0 and aux arrays are unused in this example.

    implicit none

    ! Input
    integer, intent(in) :: num_eqn, num_aux, num_waves, ixy
    real(kind=8), intent(in) :: q_l(num_eqn), q_r(num_eqn)
    real(kind=8), intent(in) :: aux_l(num_aux), aux_r(num_aux)

    ! Output
    real(kind=8), intent(in out) :: wave(num_eqn, num_waves)
    real(kind=8), intent(in out) :: s(num_waves)
    real(kind=8), intent(in out) :: apdq(num_eqn), amdq(num_eqn)

    ! Common block
    real(kind=8) :: u, v
    common /cparam/ u, v

    wave(1,1) = q_r(1) - q_l(1)
    if (ixy == 1) then
        s(1) = u
    else
        s(1) = v
    endif

    ! Flux differences
    amdq(1) = dmin1(s(1), 0.d0) * wave(1,1)
    apdq(1) = dmax1(s(1), 0.d0) * wave(1,1)

    end subroutine rpn2_ptwise


C-----------------------------------------------------------------------
C
C             Preconditioner Routines for Banded Problems
C                          14 September 1995
C
C The following pair of subroutines -- SBANJA and SBANPS -- provides a
C general-purpose banded preconditioner matrix for use with the SDASPK
C solver, with the Krylov linear system method.  When using SDASPK to
C solve a problem G(t,y,y') = 0, whose iteration matrix (Jacobian)
C    J = dG/dy + c * dG/dy'  (c = scalar)
C is either banded or approximately equal to a banded matrix, these
C routines can be used to generate a banded approximation to J as the
C preconditioner and to solve the resulting banded linear system, in
C conjunction with the Krylov method option (INFO(12) = 1) in SDASPK.
C
C Other than the user-supplied residual routine RES defining G(t,y,y'),
C the only other inputs required by these routines are the
C half-bandwidth parameters ML and MU of the approximate banded
C Jacobian.  If the system size is NEQ, the half-bandwidths are
C defined as integers between 0 and NEQ - 1 such that only elements
C with indices (i,j) satisfying
C    -ML .le. j - i .le. MU
C are to be retained in the preconditioner.  E.g., if ML = MU = 0, a
C diagonal matrix will be generated as the preconditioner.  The banded
C preconditioner is obtained by difference quotient approximations.  If
C the true problem Jacobian is not banded but is approximately equal to
C a matrix that is banded, the procedure used here will have the effect
C of lumping the elements outside of the band onto the elements within
C the band.
C
C To use these routines in conjunction with SDASPK, the user's calling
C program should include the following, in addition to setting the other
C SDASPK input parameters.
C
C (a) Dimension the array IPAR to have length at least 2, and load the
C     half-bandwidths into IPAR as
C       IPAR(1) = ML   and   IPAR(2) = MU
C     IPAR is used to communicate these parameters to SBANJA and SBANPS.
C     If the user program also uses IPAR for communication with RES,
C     that data should be located beyond the first 2 words of IPAR.
C
C (b) Include the names SBANJA and SBANPS in an EXTERNAL statement.
C     Set INFO(15) = 1 to indicate that a JAC routine exists.
C     Then in the call to SDASPK, pass the names SBANJA and SBANPS as
C     the arguments JAC and PSOL, respectively.
C
C (c) The SDASPK work arrays RWORK and IWORK must include segments WP
C     and IWP for use by SBANJA/SBANPS.  The lengths of these depend on
C     the problem size and half-bandwidths, as follows:
C       LWP =  length of RWORK segment WP =
C                     (2*ML + MU + 1)*NEQ + 2*( (NEQ/(ML+MU+1)) + 1)
C       LIWP = length of IWORK segment IWP = NEQ
C     (Note the integer divide in LWP.)  Load these lengths in IWORK as
C       IWORK(27) = LWP
C       IWORK(28) = LIWP
C     and include these values in the declared size of RWORK and IWORK.
C
C
C The SBANJA and SBANPS routines generate and solve the banded
C preconditioner matrix P within the preconditioned Krylov algorithm
C used by SDASPK when INFO(12) = 1.  P is generated and LU-factored
C periodically during the integration, and the factors are used to
C solve systems Px = b as needed.
C-----------------------------------------------------------------------

      SUBROUTINE SBANJA (RES, IRES, NEQ, T, Y, YPRIME, REWT, SAVR,
     *                  WK, H, CJ, WP, IWP, IER, RPAR, IPAR)
C
C***BEGIN PROLOGUE  SBANJA
C***DATE WRITTEN   891204   (YYMMDD)
C***REVISION DATE  900122
C***REVISION DATE  920929   CJ in RES call sequence
C***REVISION DATE  950914   Name change, minor revisions throughout
C***REVISION DATE  950918   Converted to single precision.
C***AUTHORS  L. R. Petzold, P. N. Brown, A. C. Hindmarsh, C. W. Ulrich
C            Numerical Mathematics Group
C            Lawrence Livermore National Laboratory
C            Livermore, CA 94551
C
C***DESCRIPTION
C
C Subroutine SBANJA generates a banded preconditioner matrix P that
C approximates the SDASPK iteration matrix  J = dG/dy + CJ*dG/dy',
C where the DAE system is  G(t,y,y') = 0.  The band matrix P has
C half-bandwidths ML and MU.  It is computed by making (ML + MU + 1)
C calls to the user's RES routine and forming difference quotients,
C exactly as in the banded direct method option of SDASPK.
C SBANJA calls the LINPACK routine SGBFA to do an LU factorization of
C this matrix.
C
C The call sequence parameters have the following meanings.
C
C     RES      = External user-supplied subroutine to evaluate the
C                residuals.  See RES description in SDASPK prologue.
C     IRES     = Output flag set by RES.  See RES description in SDASPK.
C     NEQ      = Problem size.
C     T        = Independent variable t.
C     Y        = Array containing current dependent variables y.
C     YPRIME   = Array containing current derivative y'.
C     REWT     = Vector of reciprocal error weights, used here for
C                computing increments.
C     SAVR     = Current residual evaluated at (T,Y,YPRIME).
C     WK       = Real work space of length NEQ.
C     H        = Current step size.
C     CJ       = Scalar proportional to 1/H.
C     WP       = Real work array for P etc.  On output, it contains
C                the LU decomposition of the banded approximation P.
C     IWP      = Integer work space for matrix pivot information.
C     IER      = Output flag, > 0 if P is singular, and 0 otherwise.
C     RPAR,IPAR= Real and integer arrays used for communication between
C                the calling program and external user routines.
C                IPAR(1) and IPAR(2) must contain ML and MU, resp.
C                RPAR is not used here.
C
C***ROUTINES CALLED
C   R1MACH, SGBFA, RES
C
C***END PROLOGUE  SBANJA
C
      IMPLICIT REAL(A-H,O-Z)
      EXTERNAL RES
      DIMENSION Y(*), YPRIME(*), SAVR(*), REWT(*), WK(*)
      DIMENSION WP(*), IWP(*), RPAR(*), IPAR(*)
C
C Set band parameters.
      ML = IPAR(1)
      MU = IPAR(2)
      MBAND = ML + MU + 1
      MBA = MIN(MBAND, NEQ)
      MEBAND = MBAND + ML
      MEB1 = MEBAND - 1
C
C Set the machine unit roundoff UROUND and SQRT(UROUND), used to
C set increments in the difference quotient procedure.
      UROUND = R1MACH(4)
      SQUR = SQRT(UROUND)
C
C Set pointers into WP.  LENP is the length of the segment for P.
C Following that are two segments of size (NEQ/MBAND), with offsets
C ISAVE and IPSAVE, for temporary storage of Y and YPRIME elements.
      LENP = (2*ML+MU+1)*NEQ
      MSAVE = (NEQ/MBAND) + 1
      ISAVE = LENP
      IPSAVE = ISAVE + MSAVE
C
C Initialize error flags.
      IER = 0
      IRES = 0
C
C Generate the banded approximate iteration matrix P using
C difference quotients on the results of calls to RES.
C
      DO 40 J = 1,MBA
        DO 10 N = J,NEQ,MBAND
          K= (N-J)/MBAND + 1
          WP(ISAVE+K) = Y(N)
          WP(IPSAVE+K) = YPRIME(N)
          DEL = SQUR*MAX(ABS(Y(N)), ABS(H*YPRIME(N)), ABS(1.E0/REWT(N)))
          DEL = SIGN(DEL, H*YPRIME(N))
          DEL = (Y(N) + DEL) - Y(N)
          Y(N) = Y(N) + DEL
          YPRIME(N) = YPRIME(N) + CJ*DEL
 10       CONTINUE
        CALL RES (T, Y, YPRIME, CJ, WK, IRES, RPAR, IPAR)
        IF (IRES .LT. 0) RETURN
        DO 30 N = J,NEQ,MBAND
          K = (N-J)/MBAND + 1
          Y(N) = WP(ISAVE+K)
          YPRIME(N) = WP(IPSAVE+K)
          DEL = SQUR*MAX(ABS(Y(N)), ABS(H*YPRIME(N)), ABS(1.E0/REWT(N)))
          DEL = SIGN(DEL, H*YPRIME(N))
          DEL = (Y(N) + DEL) - Y(N)
          DELINV = 1.0E0/DEL
          I1 = MAX(1, N-MU)
          I2 = MIN(NEQ, N+ML)
          II = N*MEB1 - ML
          DO 20 I = I1,I2
 20         WP(II+I) = (WK(I) - SAVR(I))*DELINV
 30       CONTINUE
 40     CONTINUE
C
C Do LU decomposition of the band matrix P.
C
      CALL SGBFA (WP, MEBAND, NEQ, ML, MU, IWP, IER)
      RETURN
C
C------------  End of Subroutine SBANJA  -------------------------------
      END

      SUBROUTINE SBANPS (NEQ, T, Y, YPRIME, SAVR, WK, CJ, WGHT,
     *                   WP, IWP, B, EPLIN, IER, RPAR, IPAR)
C
C***BEGIN PROLOGUE  SBANPS
C***DATE WRITTEN   891204   (YYMMDD)
C***REVISION DATE  900110   (YYMMDD)
C***REVISION DATE  950914   Name change, minor revisions throughout
C***REVISION DATE  950918   Converted to single precision.
C***AUTHORS  L. R. Petzold, P. N. Brown, A. C. Hindmarsh, C. W. Ulrich
C            Numerical Mathematics Group
C            Lawrence Livermore National Laboratory
C            Livermore, CA 94551
C
C***DESCRIPTION
C
C Subroutine SBANPS uses the factors produced by SBANJA to solve linear
C systems P x = b for the banded preconditioner P and a given vector b.
C It calls the LINPACK routine SGBSL for this.
C
C The call sequence parameters have the following meanings.
C
C     NEQ      = Problem size.
C     T        = Independent variable t (not used).
C     Y        = Array containing current dependent vars. (not used).
C     YPRIME   = Array containing current derivative (not used).
C     SAVR     = Current residual evaluated at (T,Y,YPRIME) (not used).
C     WK       = Real work space of length NEQ (not used).
C     CJ       = Scalar proportional to 1/H (H = step size) (not used).
C     WGHT     = Vector of error weights for computing norms (not used).
C     WP       = Real work array containing the LU decomposition of P.
C     IWP      = Integer array containing matrix pivot information.
C     B        = Right-hand side vector on input; solution on output.
C     EPLIN    = tolerance on linear system solver (not used).
C     IER      = Output error flag (not used; assumed 0 on input).
C     RPAR,IPAR= Real and integer arrays used for communication between
C                the calling program and external user routines.
C                IPAR(1) and IPAR(2) must contain ML and MU, resp.
C                RPAR is not used here.
C
C***ROUTINES CALLED
C   SGBSL
C
C***END PROLOGUE  SBANPS
C
      IMPLICIT REAL(A-H,O-Z)
      DIMENSION B(*),WP(*),IWP(*),RPAR(*),IPAR(*)
C
      ML = IPAR(1)
      MU = IPAR(2)
      MEBAND = 2*ML + MU + 1
      CALL SGBSL (WP, MEBAND, NEQ, ML, MU, IWP, B, 0)
      RETURN
C
C------------  End of Subroutine SBANPS  -------------------------------
      END