!-----------------------------------------------------------------------
!     Subroutine:    uvtomn
!     Authors:       S. Lazerson (lazerson@pppl.gov)
!     Date:          11/2/2011
!     Description:   This subroutine Fourier transforms to real space.
!                    Note this function zeros fmn.
!-----------------------------------------------------------------------
      SUBROUTINE uvtomn(k1,k,mnmax,nu,nv,xu,xv,fmn,xm,xn,f,signs,calc_trig)
!-----------------------------------------------------------------------
!     Libraries
!-----------------------------------------------------------------------
      USE stel_kinds, ONLY: rprec
!-----------------------------------------------------------------------
!     Input Parameters
!          k1           Starting index of surfaces
!          k            Number of surfaces
!          mnmax        Number of fourier modes
!          nu           Number of Poloidal points
!          nv           Number of toroidal points
!          xu           Poloidal Points array (1:nu)
!          xv           Toroidal Points array (1:nv)
!          fmn          Fourier array (0:k,1:mnmax)
!          xm           Fourier mode array (1:mnmax)
!          xn           Fourier mode array (1:mnmax)
!          f            Realspace Array
!          signs        Parity switch (0: cos, 1: sin)
!          calc_trig    Trig recalculation (0: no, 1: yes)
!-----------------------------------------------------------------------
      IMPLICIT NONE
      INTEGER, INTENT(in) :: k1
      INTEGER, INTENT(in) :: k
      INTEGER, INTENT(in) :: mnmax
      INTEGER, INTENT(in) :: nu
      INTEGER, INTENT(in) :: nv
      REAL(rprec), INTENT(in) :: xu(1:nu)
      REAL(rprec), INTENT(in) :: xv(1:nv)
      REAL(rprec), INTENT(inout) :: fmn(1:mnmax,k1:k)
      INTEGER, INTENT(in) :: xm(1:mnmax)
      INTEGER, INTENT(in) :: xn(1:mnmax)
      REAL(rprec), INTENT(in) :: f(k1:k,1:nu,1:nv)
      INTEGER, INTENT(in) :: signs
      INTEGER, INTENT(in) :: calc_trig
!-----------------------------------------------------------------------
!     Local Variables
!          mn           Dummy mode index
!           i           Dummy Angle Index
!          pi2          2 * PI
!          mt           xm x xu Array
!          nz           xn x xv Array
!-----------------------------------------------------------------------
      INTEGER     :: mn, i, j, ier, ik
      REAL(rprec) :: pi2
      REAL(rprec) :: xn_temp(1:mnmax,1)
      REAL(rprec) :: xm_temp(1:mnmax,1)
      REAL(rprec) :: mt(1:mnmax,1:nu)
      REAL(rprec) :: nz(1:mnmax,1:nv)
      REAL(rprec) :: xu_temp(1,1:nu)
      REAL(rprec) :: xv_temp(1,1:nv)
      REAL(rprec), ALLOCATABLE, SAVE :: fnuv(:)
      REAL(rprec), ALLOCATABLE, SAVE :: cosmt(:,:)
      REAL(rprec), ALLOCATABLE, SAVE :: sinmt(:,:)
      REAL(rprec), ALLOCATABLE, SAVE :: cosnz(:,:)
      REAL(rprec), ALLOCATABLE, SAVE :: sinnz(:,:)
!-----------------------------------------------------------------------
!     Begin Subroutine
!-----------------------------------------------------------------------
      pi2 = 8 * ATAN(1._rprec)
      IF (calc_trig == 1) THEN
         IF (ALLOCATED(cosmt)) DEALLOCATE(cosmt)
         IF (ALLOCATED(sinmt)) DEALLOCATE(sinmt)
         IF (ALLOCATED(cosnz)) DEALLOCATE(cosnz)
         IF (ALLOCATED(sinnz)) DEALLOCATE(sinnz)
         IF (ALLOCATED(fnuv)) DEALLOCATE(fnuv)
         ALLOCATE(fnuv(1:mnmax),STAT=ier)
         ALLOCATE(cosmt(1:mnmax,1:nu),sinmt(1:mnmax,1:nu),&
                  cosnz(1:mnmax,1:nv),sinnz(1:mnmax,1:nv),STAT=ier)
         FORALL(i=1:mnmax) xm_temp(i,1)=REAL(xm(i))
         FORALL(i=1:mnmax) xn_temp(i,1)=REAL(xn(i))
         FORALL(i=1:mnmax) fnuv(i) = 2./REAL(nu*nv)
         WHERE(xm == 0) fnuv = 0.5*fnuv
         FORALL(i=1:nu) xu_temp(1,i)=xu(i)
         FORALL(i=1:nv) xv_temp(1,i)=xv(i)
         mt = MATMUL(xm_temp,xu_temp)
         nz = MATMUL(xn_temp,xv_temp)
         FORALL(mn=1:mnmax,i=1:nu) cosmt(mn,i) = cos(pi2*mt(mn,i))
         FORALL(mn=1:mnmax,i=1:nu) sinmt(mn,i) = sin(pi2*mt(mn,i))
         FORALL(mn=1:mnmax,i=1:nv) cosnz(mn,i) = cos(pi2*nz(mn,i))
         FORALL(mn=1:mnmax,i=1:nv) sinnz(mn,i) = sin(pi2*nz(mn,i))
      END IF
      fmn(:,:) = 0.0
      IF (signs == 0) THEN
         DO mn = 1, mnmax
            DO i = 1, nu
               DO j = 1, nv
                  fmn(mn,k1:k) = fmn(mn,k1:k) + f(k1:k,i,j)*(cosmt(mn,i)*cosnz(mn,j) &
                  - sinmt(mn,i)*sinnz(mn,j))*fnuv(mn)
               END DO
            END DO
         END DO
      ELSE IF (signs == 1) THEN
         DO mn = 1, mnmax
            DO i = 1, nu
               DO j = 1, nv
                  fmn(mn,k1:k) = fmn(mn,k1:k) + f(k1:k,i,j)*(sinmt(mn,i)*cosnz(mn,j) &
                  + cosmt(mn,i)*sinnz(mn,j))*fnuv(mn)
               END DO
            END DO
         END DO
      END IF

!-----------------------------------------------------------------------
!     End Subroutine
!-----------------------------------------------------------------------
      END SUBROUTINE uvtomn


!
!     (c) 2019 Guide Star Engineering, LLC
!     This Software was developed for the US Nuclear Regulatory Commission (US NRC)
!     under contract "Multi-Dimensional Physics Implementation into Fuel Analysis under
!     Steady-state and Transients (FAST)", contract # NRC-HQ-60-17-C-0007
!
!    NEMO - Numerical Engine (for) Multiphysics Operators
! Copyright (c) 2007, Stefano Toninel
!                     Gian Marco Bianchi  University of Bologna
!              David P. Schmidt    University of Massachusetts - Amherst
!              Salvatore Filippone University of Rome Tor Vergata
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without modification,
! are permitted provided that the following conditions are met:
!
!     1. Redistributions of source code must retain the above copyright notice,
!        this list of conditions and the following disclaimer.
!     2. Redistributions in binary form must reproduce the above copyright notice,
!        this list of conditions and the following disclaimer in the documentation
!        and/or other materials provided with the distribution.
!     3. Neither the name of the NEMO project nor the names of its contributors
!        may be used to endorse or promote products derived from this software
!        without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
! ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
! WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR
! ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
! (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
! LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
! ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
! (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
! SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
!
!---------------------------------------------------------------------------------
!
! $Id: laplacian_smooth.f90 8157 2014-10-09 13:02:44Z sfilippo $
!
! Description: moves all interior points to the average position of their neighbors.
! This is done by forming three linear systems, one for each of the x,y,z components
! of position and using PSBLAS linear solvers
!
SUBMODULE(tools_mesh_optimize) laplacian_smooth_implementation
    IMPLICIT NONE

    CONTAINS

        MODULE PROCEDURE laplacian_smooth
        USE class_psblas
        USE class_connectivity
        USE class_vector
        USE class_vertex
        USE tools_mesh_basics
        USE tools_math, ONLY : build_prec, solve_sys
        IMPLICIT NONE
        ! Local variables
        REAL(psb_dpk_), ALLOCATABLE :: bx(:),by(:),bz(:)! Right-hand side of the eqns
        REAL(psb_dpk_), ALLOCATABLE :: newx(:),newy(:),newz(:)  ! new locations
        REAL(psb_dpk_), ALLOCATABLE :: acoeffs(:)     ! non-zero coefficients of A
        INTEGER,        ALLOCATABLE :: ia(:),ja(:)    ! indexing arrays for A's elements
        TYPE(psb_dspmat_type)          :: Amatrix        ! the matrix for averaging for x,y,z
        INTEGER                        :: n_entries      ! number of non-zero elements of A
        INTEGER                        :: err_act, info, icontxt
        INTEGER                        :: i,j,iglob
        INTEGER                        :: nverts         ! number of local verts
        INTEGER,POINTER                :: iv2v(:)=>null()! given a vert, list neighbors
        REAL(psb_dpk_)                 :: rhs            ! an entry to be inserted in the RHS
        TYPE(psb_dprec_type)           :: Aprec          ! the preconditioner
        INTEGER                        :: iter
        REAL(psb_dpk_)                 :: err
        TYPE(vector)                   :: new_pos        ! new vertex position
        LOGICAL, ALLOCATABLE           :: fixed(:)       ! identifies verts to be fixed in pos.
        CHARACTER(len=32), PARAMETER   :: name_err = 'laplacian_smooth'

        ! Set error handling for PSBLAS-2 routines
        CALL psb_erractionsave(err_act)

        ! Get PSBLAS context
        icontxt = icontxt_()

        nverts = psb_cd_get_local_rows(desc_v) ! local and shared vertices

        ALLOCATE(fixed(nverts), stat=info)
        IF(info /= 0) THEN
            WRITE(*,100)
            CALL abort_psblas
        END IF

        fixed = mixed .OR. verts(1:nverts)%on_boundary_()
        !initialize so that all mixed-cell and boundary vertices are fixed

        IF (n_unconstrained > 0) THEN
            DO i = 1, n_unconstrained
                fixed( unconstrained(i) ) = .FALSE.
            ENDDO
        ENDIF

        !NEL is the number of diag. elements and NCONN the off-diag. elements
        n_entries = v2v%nel_() + v2v%nconn_() ! estimated non-zero values

        ! Allocate matrices
        CALL psb_spall(Amatrix, desc_v, info, n_entries)
        CALL psb_check_error(info,name_err,'psb_spall',icontxt)

        ! Allocate all three right-hand sides
        CALL psb_geall(bx, desc_v, info)
        CALL psb_check_error(info,name_err,'psb_geall',icontxt)

        CALL psb_geall(by, desc_v, info)
        CALL psb_check_error(info,name_err,'psb_geall',icontxt)

        CALL psb_geall(bz, desc_v, info)
        CALL psb_check_error(info,name_err,'psb_geall',icontxt)

        ! Allocate all three solution vectors
        CALL psb_geall(newx, desc_v, info)
        CALL psb_check_error(info,name_err,'psb_geall',icontxt)

        CALL psb_geall(newy, desc_v, info)
        CALL psb_check_error(info,name_err,'psb_geall',icontxt)

        CALL psb_geall(newz, desc_v, info)
        CALL psb_check_error(info,name_err,'psb_geall',icontxt)

        ! Loop over all vertices and add equations to the linear systems
        ! Note the Amatrix is identical for all three systems
        DO i = 1, nverts

            iglob = loc_to_glob_(desc_v,i)

            IF ( fixed(i) ) THEN
                ! we simply apply a Dirichlet BC

                n_entries = 1

                ! insert 1.0 on diagonal
                CALL psb_spins(n_entries, (/iglob/), (/iglob/), (/1.0d0/), Amatrix, desc_v, info)
                CALL psb_check_error(info,name_err,'psb_spins',icontxt)

                ! insert vertex location on the right hand sides
                rhs = verts(i)%x_()
                CALL psb_geins(1, (/iglob/), (/rhs/), bx, desc_v, info, psb_dupl_ovwrt_)
                CALL psb_check_error(info,name_err,'psb_geins',icontxt)

                rhs = verts(i)%y_()
                CALL psb_geins(1, (/iglob/), (/rhs/), by, desc_v, info, psb_dupl_ovwrt_)
                CALL psb_check_error(info,name_err,'psb_geins',icontxt)

                rhs = verts(i)%z_()
                CALL psb_geins(1, (/iglob/), (/rhs/), bz, desc_v, info, psb_dupl_ovwrt_)
                CALL psb_check_error(info,name_err,'psb_geins',icontxt)

            ELSE
                ! set this vertex's position to be the average of his neighbors
                ! thus the matrix has 1's on off-diagonals corresponding to neighbors
                ! and -1/N on the diagonal.  The RHS is zero
                ! -1/N*position_p + sum(positions_neighbors) = 0

                CALL v2v%get_ith_conn(iv2v,i) ! get neighbors
                n_entries = SIZE(iv2v) + 1 ! add 1 for the diagonal

                ALLOCATE(acoeffs(n_entries), ia(n_entries), ja(n_entries), stat=info)

                ! fill arrays with off-diag elements first
                DO j = 1, SIZE(iv2v)
                    acoeffs(j) = 1.0d0
                    ia(j)      = iglob
                    ja(j)      = loc_to_glob_(desc_v,iv2v(j))
                ENDDO

                acoeffs(n_entries) = -1.0d0*REAL(SIZE(iv2v))
                ia     (n_entries) = iglob
                ja     (n_entries) = iglob

                ! insert matrix coefficients
                CALL psb_spins(n_entries, ia, ja, acoeffs, Amatrix, desc_v, info)
                CALL psb_check_error(info,name_err,'psb_spins',icontxt)

                ! insert RHS
                CALL psb_geins(1, (/iglob/), (/0.0d0/), bx, desc_v, info, psb_dupl_ovwrt_)
                CALL psb_check_error(info,name_err,'psb_geins',icontxt)

                CALL psb_geins(1, (/iglob/), (/0.0d0/), by, desc_v, info, psb_dupl_ovwrt_)
                CALL psb_check_error(info,name_err,'psb_geins',icontxt)

                CALL psb_geins(1, (/iglob/), (/0.0d0/), bz, desc_v, info, psb_dupl_ovwrt_)
                CALL psb_check_error(info,name_err,'psb_geins',icontxt)

                DEALLOCATE(acoeffs, ia, ja)

            ENDIF ! end of if-test about interior vs. bndry point

        ENDDO

        ! Assemble matrices and right-hand sides

        CALL psb_spasb(Amatrix, desc_v, info, dupl= psb_dupl_ovwrt_)
        CALL psb_check_error(info,name_err,'psb_spasb',icontxt)

        CALL psb_geasb(bx, desc_v, info)
        CALL psb_check_error(info,name_err,'psb_geasb',icontxt)

        CALL psb_geasb(by, desc_v, info)
        CALL psb_check_error(info,name_err,'psb_geasb',icontxt)

        CALL psb_geasb(bz, desc_v, info)
        CALL psb_check_error(info,name_err,'psb_geasb',icontxt)

        ! Set initial guesses: Loop over all vertices
        DO i = 1, nverts

            iglob = loc_to_glob_(desc_v,i)

            CALL psb_geins(1, (/iglob/), (/verts(i)%x_()/), newx, desc_v, info, psb_dupl_ovwrt_)
            CALL psb_check_error(info,name_err,'psb_geins',icontxt)

            CALL psb_geins(1, (/iglob/), (/verts(i)%y_()/), newy, desc_v, info, psb_dupl_ovwrt_)
            CALL psb_check_error(info,name_err,'psb_geins',icontxt)

            CALL psb_geins(1, (/iglob/), (/verts(i)%z_()/), newz, desc_v, info, psb_dupl_ovwrt_)
            CALL psb_check_error(info,name_err,'psb_geins',icontxt)

        ENDDO

        ! assemble guesses
        CALL psb_geasb(newx, desc_v, info)
        CALL psb_check_error(info,name_err,'psb_geasb',icontxt)

        CALL psb_geasb(newy, desc_v, info)
        CALL psb_check_error(info,name_err,'psb_geasb',icontxt)

        CALL psb_geasb(newz, desc_v, info)
        CALL psb_check_error(info,name_err,'psb_geasb',icontxt)

        ! note the preconditioner can be re-used after each solve

        ! select and build preconditioner and solve
        CALL build_prec("BJAC",1,"BICGSTAB",Amatrix,desc_v,Aprec)
        CALL solve_sys(Amatrix, Aprec, bx, newx, desc_v, "BICGSTAB", 1.0D-6, 50, iter, err)
        CALL solve_sys(Amatrix, Aprec, by, newy, desc_v, "BICGSTAB", 1.0D-6, 50, iter, err)
        CALL solve_sys(Amatrix, Aprec, bz, newz, desc_v, "BICGSTAB", 1.0D-6, 50, iter, err)

        CALL psb_ovrl(newx,desc_v,info,update=psb_avg_)
        CALL psb_ovrl(newy,desc_v,info,update=psb_avg_)
        CALL psb_ovrl(newz,desc_v,info,update=psb_avg_)

        ! extract answers

        ! Loop over all vertices
        DO i = 1, nverts

            ! set position of vertices
            new_pos  = vector_( newx(i), newy(i), newz(i) )
            verts(i) = new_pos

        ENDDO

        ! free preconditioner
        CALL psb_precfree(Aprec,info)
        CALL psb_check_error(info,name_err,'psb_precfree',icontxt)

        ! free matrices and b vectors
        CALL psb_spfree(Amatrix, desc_v, info)
        CALL psb_check_error(info,name_err,'psb_spfree',icontxt)

        CALL psb_gefree(bx, desc_v, info)
        CALL psb_check_error(info,name_err,'psb_gefree',icontxt)

        CALL psb_gefree(by, desc_v, info)
        CALL psb_check_error(info,name_err,'psb_gefree',icontxt)

        CALL psb_gefree(bz, desc_v, info)
        CALL psb_check_error(info,name_err,'psb_gefree',icontxt)

        CALL psb_gefree(newx, desc_v, info)
        CALL psb_check_error(info,name_err,'psb_gefree',icontxt)

        CALL psb_gefree(newy, desc_v, info)
        CALL psb_check_error(info,name_err,'psb_gefree',icontxt)

        CALL psb_gefree(newz, desc_v, info)
        CALL psb_check_error(info,name_err,'psb_gefree',icontxt)

        NULLIFY(iv2v)
        DEALLOCATE(fixed)

        ! ----- Normal Termination -----
        CALL psb_erractionrestore(err_act)

100     FORMAT(' ERROR! Memory allocation failure in LAPLACIAN_SMOOTH')

        END PROCEDURE laplacian_smooth

END SUBMODULE laplacian_smooth_implementation


program main

  use DataInputM
  use Structural2DApplicationM
  use GIDDataOutputM
  use StructuralStrategyM
  use SolvingStrategyM

  implicit none

  type(Structural2DApplicationDT) :: application
  type(StructuralStrategyDT)      :: strategy
  type(SolvingStrategyDT)         :: solvingStrategy

  call initFEM2D(application)
  solvingStrategy = InitSolvingStrategy(strategy, application%model)
  call solvingStrategy%useStrategy()
  call initDataOutput()
  call printResults(resultName = 'Displacement'      &
       , step         = 1                            &
       , graphType    = 'Vector'                     &
       , locationName = 'onNodes'                    &
       , resultNumber = application%model%getnNode()  &
       , nDof         = 2                             &
       , component1   = application%model%dof         )

  call printResults(resultName = 'NormalStressOnTriangs'                  &
       , type         = 'Triangle'                                        &
       , step         = 1                                                 &
       , graphType    = 'Vector'                                          &
       , locationName = 'onGaussPoints'                                   &
       , gaussPoints  = application%model%normalStress%triangGPoint       &
       , resultNumber = size(application%model%normalStress%triangElemID) &
       , elemID       = application%model%normalStress%triangElemID       &
       , component1   = application%model%normalStress%triangNS(:,1)       &
       , component2   = application%model%normalStress%triangNS(:,2)       )
  call printResults(resultName = 'NormalStressOnQuads'                   &
       , type         = 'Quadrilateral'                                  &
       , step         = 1                                                &
       , graphType    = 'Vector'                                         &
       , locationName = 'onGaussPoints'                                  &
       , gaussPoints  = application%model%normalStress%quadGPoint        &
       , resultNumber = size(application%model%normalStress%quadElemID)  &
       , elemID       = application%model%normalStress%quadElemID        &
       , component1   = application%model%normalStress%quadNS(:,1)       &
       , component2   = application%model%normalStress%quadNS(:,2)       )

  call printResults(resultName = 'ShearStressOnTriangs'                 &
       , type         = 'Triangle'                                      &
       , step         = 1                                               &
       , graphType    = 'Scalar'                                        &
       , locationName = 'onGaussPoints'                                 &
       , gaussPoints  = application%model%shearStress%triangGPoint       &
       , resultNumber = size(application%model%shearStress%triangElemID) &
       , elemID       = application%model%shearStress%triangElemID       &
       , component1   = application%model%shearStress%triangShS          )
  call printResults(resultName = 'ShearStressOnQuads'                  &
       , type         = 'Quadrilateral'                                &
       , step         = 1                                              &
       , graphType    = 'Scalar'                                       &
       , locationName = 'onGaussPoints'                                &
       , gaussPoints  = application%model%shearStress%quadGPoint        &
       , resultNumber = size(application%model%shearStress%quadElemID)  &
       , elemID       = application%model%shearStress%quadElemID        &
       , component1   = application%model%shearStress%quadShS           )

  call printResults(resultName = 'StrainStressOnTriangs'           &
       , type         = 'Triangle'                                 &
       , step         = 1                                          &
       , graphType    = 'Vector'                                   &
       , locationName = 'onGaussPoints'                            &
       , gaussPoints  = application%model%strain%triangGPoint       &
       , resultNumber = size(application%model%strain%triangElemID) &
       , elemID       = application%model%strain%triangElemID       &
       , component1   = application%model%strain%triangEp(:,1)      &
       , component2   = application%model%strain%triangEp(:,2)      )
  call printResults(resultName = 'StrainStressOnQuads'            &
       , type         = 'Quadrilateral'                           &
       , step         = 1                                         &
       , graphType    = 'Vector'                                  &
       , locationName = 'onGaussPoints'                           &
       , gaussPoints  = application%model%strain%quadGPoint        &
       , resultNumber = size(application%model%strain%quadElemID)  &
       , elemID       = application%model%strain%quadElemID        &
       , component1   = application%model%strain%quadEp(:,1)       &
       , component2   = application%model%strain%quadEp(:,2)       )

end program main


module kubo
	!
	!	calculates some of the Kubo formulas available in postw90
	!	see wann guide chapter 12 for details
	!		http://www.wannier.org/doc/user_guide.pdf
	!
	!
	use omp_lib
	use input_paras,	only:	kubo_tol
	use constants,		only:	dp, i_dp, pi_dp, aUtoEv
	use statistics,		only:	fd_stat

	implicit none

	private
	public			::			kubo_ahc_tens,		&
								velo_ahc_tens,		&
								kubo_opt_tens,		&
								kubo_ohc_tens

contains

!
!	^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
!				ANOMALOUS HALL (hw -> 0 LIMIT)!	------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------

!public

	function kubo_ahc_tens(en_k, V_ka, fd_distrib) result( o_ahc)
		!	see wann guide chapter 12
		!		eq. (12.16)
		real(dp),						intent(in)		::	en_k(:), fd_distrib(:,:)
		complex(dp), 					intent(in)		::	V_ka(:,:,:)
		real(dp)										::	curv_nn(3,3)
		real(dp),		allocatable						::	o_ahc(:,:,:)
		integer											::	n, np, i,j, ef_idx, n_ef, n_wf
		!
		n_wf	=	size(en_k,1)
		n_ef	=	size(fd_distrib,1)
		allocate(		o_ahc(	3,3		,	n_ef	))
		o_ahc	=	0.0_dp
		!
		!
		!$OMP PARALLEL  DO 										&
		!$OMP DEFAULT(	none								)	&
		!$OMP PRIVATE( 	np, i,j, curv_nn, ef_idx				)	&
		!$OMP SHARED(	n_wf, n_ef,en_k, V_ka, fd_distrib	)	&
		!----
		!$OMP 	REDUCTION( + : o_ahc	)
		do n = 1, n_wf
			!
			curv_nn	=	0.0_dp
			do np = 1, n_wf
				if(np==n)	cycle
				do j = 1, 3
					do i = 1, 3
						curv_nn(i,j)	=	curv_nn(i,j)	- 2.0_dp *	aimag(	V_ka(i,n,np) * V_ka(j,np,n)	)	/ (en_k(np) - en_k(n))**2
					end do
				end do
			end do
			!
			do ef_idx =1 ,n_ef
				o_ahc(:,:,ef_idx)	=	o_ahc(:,:,ef_idx)	-	curv_nn(:,:)	*	fd_distrib(ef_idx,n)
			end do
		end do
		!$OMP END PARALLEL DO
		!
		!
		return
	end function

!
!
!	^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
!				OPTICAL CONDUTCTIVITY (hw \non_eq 0)
!	------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------

	function velo_ahc_tens(en_k, V_ka, hw_lst, fd_distrib, i_eta_smr) result( o_ahc)
		!
		!	use Wanxiangs expression to calculate the ohc
		!
		!		VIA VELOCITIES
		real(dp),		intent(in)		::	en_k(:), hw_lst(:), fd_distrib(:,:)
		complex(dp), 	intent(in)		::	V_ka(:,:,:), i_eta_smr
		complex(dp)	,	allocatable		::	o_ahc(:,:,:,:), vv_dE_hw(:,:,:)
		real(dp),		allocatable		::	d_ef_lst(:)
		real(dp)						::	dE_sqr, v_nm_mn(3,3)
		integer							::	n, np, j, hw_idx, n_ef, n_hw, n_wf, ef_idx
		!
		n_hw	=	size(	hw_lst		,	1)
		n_ef	=	size(	fd_distrib	,	1)
		n_wf	=	size(	en_k		,	1)
		!
		allocate(		d_ef_lst(						n_ef	)	)
		allocate(		vv_dE_hw(	3,3		,	n_hw			)	)
		allocate(	o_ahc(			3,3		,	n_hw,	n_ef	)	)
		o_ahc	=	0.0_dp
		!
		!$OMP  PARALLEL DO DEFAULT(NONE)  											&
		!$OMP PRIVATE(np, d_ef_lst, dE_sqr, j, v_nm_mn, hw_idx, vv_dE_hw, ef_idx)	&
		!$OMP SHARED(fd_distrib, en_k, V_ka, hw_lst, n_wf, n_hw, n_ef, i_eta_smr) 	&
		!$OMP REDUCTION(+: o_ahc)
		do n = 1, n_wf
			do np = 1, n_wf
				if(np==n) cycle
				!
				!	dE	BANDS
				d_ef_lst	=		fd_distrib(:,n)		-	fd_distrib(:,np)
				dE_sqr		= 	(	en_k(	 n) 		- 		en_k(	 np)	 )**2
				!
				!	loop real space direction
				do j = 1, 3
					v_nm_mn(:,j)			=	aimag(	V_ka(:,n,np) * V_ka(j,np,n)		)
				end do
				!
				!	LOOP HW
				do hw_idx =1, n_hw
					vv_dE_hw(:,:,hw_idx)	=	 v_nm_mn(:,:)	/	(	dE_sqr	- (	hw_lst(hw_idx) + i_eta_smr	)**2	)
				end do
				!
				!	LOOP FERMI LEVEL
				do ef_idx = 1, n_ef
					o_ahc(:,:,:,ef_idx)		=	o_ahc(:,:,:,ef_idx)	+	d_ef_lst(ef_idx)	*	vv_dE_hw(:,:,:)
				end do
				!
			end do
		end do
		!$OMP END PARALLEL DO
		!
		!
		return
	end function

	function kubo_ohc_tens(en_k, V_ka, hw_lst, fd_distrib, i_eta_smr)	result(z_ohc)
		!
		!		calculates wann guide (12.5) explicitly
		!
		!	via VELOCITIES
		real(dp),		intent(in)		::	en_k(:), hw_lst(:), fd_distrib(:,:)
		complex(dp),	intent(in)		::	V_ka(:,:,:), i_eta_smr
		complex(dp), 	allocatable		::	z_ohc(:,:,:,:), vv_dE_hw(:,:,:)
		real(dp), 		allocatable		::	df_mn(:)
		complex(dp)						::	v_nm_mn(3,3)
		real(dp)						::	dE_mn
		integer							::	n, m, j, n_ef, n_hw, n_wf, ef_idx, hw_idx
		!
		n_ef	=	size(	fd_distrib	,	1	)
		n_hw	=	size(	hw_lst		,	1	)
		n_wf	=	size(	en_k		,	1	)
		!
		allocate(		df_mn(						n_ef	))
		allocate(		vv_dE_hw(	3,3,	n_hw			))
		allocate(		z_ohc(		3,3,	n_hw,	n_ef	))
		!
		z_ohc	=	cmplx(0.0_dp, 0.0_dp, dp)
		!
		!$OMP  PARALLEL DO DEFAULT(NONE)  													&
		!$OMP PRIVATE(n, df_mn, dE_mn, j, v_nm_mn, vv_dE_hw, hw_idx, ef_idx)				&
		!$OMP SHARED(fd_distrib, en_k, V_ka, hw_lst, n_wf, n_hw, n_ef, kubo_tol, i_eta_smr)&
		!$OMP REDUCTION(+: z_ohc)
		do m = 1 , n_wf
			do n = 1, n_wf
				if(m==n)	cycle
				dE_mn 		=	en_k(m)			-	en_k(n)
				df_mn		=	fd_distrib(:,m)	-	fd_distrib(:,n)
				!
				!	loop real space direction
				do j = 1, 3
					v_nm_mn(:,j)	=	V_ka(:,n,m) * V_ka(j,m,n)
				end do
				!
				!	LOOP HW
				vv_dE_hw	=	cmplx(0.0_dp,0.0_dp,dp)
				do hw_idx = 1, n_hw
					vv_dE_hw(:,:,hw_idx)	=	v_nm_mn(:,:)	/	(	dE_mn * (dE_mn - hw_lst(hw_idx) - i_eta_smr))
				end do
				!
				!	LOOP FERMI LEVEL
				do ef_idx = 1, n_ef
					z_ohc(:,:,:,ef_idx)		=	z_ohc(:,:,:,ef_idx)	+ 	i_dp * 	vv_dE_hw(:,:,:) * df_mn(ef_idx)
				end do
			end do
		end do
		!$OMP END PARALLEL DO
		!
		return
	end function

	subroutine kubo_opt_tens(en_k, A_ka, hw_lst, fd_distrib, i_eta_smr, opt_symm, opt_asymm)
		!	see wann guide chapter 12
		!		eq. (12.14) & (12.15)
		!
		!	via CONNECTION
		real(dp),					intent(in)		::	en_k(:), hw_lst(:), fd_distrib(:,:)
		complex(dp),				intent(in)		::	i_eta_smr
		complex(dp), allocatable,	intent(in)		::	A_ka(:,:,:)
		complex(dp), allocatable,	intent(out)		::	opt_symm(:,:,:,:), 	opt_asymm(:,:,:,:)
		complex(dp), allocatable					::	opt_herm(:,:,:,:),	opt_aherm(:,:,:,:)
		integer										::	n_hw, n_ef
		!
		n_hw	=	size(	hw_lst		,	1)
		n_ef	=	size(	fd_distrib	,	1)
		!
		allocate(	opt_symm(	3,3,	n_hw, n_ef		))
		allocate(	opt_asymm(	3,3,	n_hw, n_ef		))
		!
		opt_symm	= 	0.0_dp
		opt_asymm	=	0.0_dp
		!
		if(allocated(A_ka)) then
			allocate(	opt_aherm(	3,3,	n_hw, n_ef		))
			allocate(	opt_herm(	3,3,	n_hw, n_ef		))
			!
			opt_herm	=	get_hermitian(hw_lst, fd_distrib, i_eta_smr, en_k, A_ka)
			opt_aherm	=	get_anti_herm(hw_lst, fd_distrib, i_eta_smr, en_k, A_ka)
			!
			opt_symm	=	real(	opt_herm	,	dp) 		+	i_dp * aimag(	opt_aherm	)		!	(12.14)
			opt_asymm	=	real(	opt_aherm	,	dp)			+	i_dp * aimag(	opt_herm	)		!	(12.15)
		end if
		!
		return
	end subroutine

!private:
	 function delta_broad(dE_mn, hw_lst,  smr)	result(d_broad)
		!see wannier guide eq. (12.9)
		! 'broadened delta-function'
		real(dp),		intent(in)	::	dE_mn, hw_lst(:)		!	energy
		complex(dp),	intent(in)	::	smr				!	smearing factor
		complex(dp),	allocatable	::	d_broad(:)
		complex(dp)					::	dE_smr
		integer						::	n_hw, hw_idx
		!
		n_hw	=	size(hw_lst,1)
		allocate(	d_broad(n_hw))
		d_broad	=	cmplx(0.0_dp,0.0_dp,dp)
		!
		dE_smr	=	pi_dp * (dE_mn - smr )
		!
		do hw_idx = 1, n_hw
			d_broad(hw_idx)		=	aimag(	1.0_dp	/ 	(dE_smr	-	pi_dp * hw_lst(hw_idx))	)
		end do
		!
		return
	end function

	function get_hermitian(hw_lst, fd_distrib, i_eta_smr, en_k, A_ka)	result(opt_herm)
		!	wann guide eq. (12.10)
		real(dp),		intent(in)		::	hw_lst(:), fd_distrib(:,:), en_k(:)
		complex(dp),	intent(in)		::	i_eta_smr
		complex(dp),	intent(in)		::	A_ka(:,:,:)
		complex(dp),	allocatable		::	opt_herm(:,:,:,:), a_dE_hw(:,:,:), d_broad(:)
		real(dp),		allocatable		::	df_mn(:)
		complex(dp)						::	a_nm_mn(3,3)
		integer							::	n, m, b, 	&
											hw_idx, ef_idx, n_hw, n_ef, n_wf
		real(dp)						::	dE_mn
		!
		n_hw	=	size(hw_lst		,	1)
		n_ef	=	size(fd_distrib	,	1)
		n_wf	=	size(en_k		,	1)
		!
		allocate(	df_mn(						n_ef	))
		allocate(	a_dE_hw(	3,3,	n_hw			))
		allocate(	opt_herm(	3,3,	n_hw,	n_ef	))
		!
		opt_herm	=	0.0_dp
		!
		!
		!$OMP PARALLEL DO DEFAULT(none)												&
		!$OMP PRIVATE(df_mn, dE_mn, b, a_nm_mn, d_broad, a_dE_hw, hw_idx, ef_idx )	&
		!$OMP SHARED(n_wf, n_hw, n_ef,  hw_lst, fd_distrib, en_k, A_ka, i_eta_smr)	&
		!$OMP REDUCTION(+: opt_herm)
		do m = 1, n_wf
			do n = 1, n_wf
				if(n/=m) then
					!
					!	dE	BANDS
					df_mn(:)				=	fd_distrib(:,m)	-	fd_distrib(:,n)
					dE_mn					=		en_k(m)		-	en_k(n)
					! --
					!
					!	LOOP DIRECTIONS
					a_nm_mn					=	cmplx(0.0_dp,0.0_dp,dp)
					do b = 1, 3
						a_nm_mn(:,b)		=	A_ka(:,n,m) 	* 	A_ka(b,m,n)
					end do
					a_nm_mn					=	dE_mn * a_nm_mn
					! --
					!
					!	LOOP HW
					d_broad(:)				= 	delta_broad(dE_mn, hw_lst(:),  i_eta_smr)
					a_dE_hw					=	cmplx(0.0_dp,0.0_dp,dp)
					do hw_idx = 1, n_hw
						a_dE_hw(:,:,hw_idx)	=	a_nm_mn(:,:) * d_broad(hw_idx)
					end do
					! --
					!
					!	LOOP FERMI LEVEL
					do ef_idx = 1, n_ef
						opt_herm(:,:,:,ef_idx)	=		opt_herm(:,:,:,ef_idx)		&
													- pi_dp * a_dE_hw(:,:,:) * df_mn(ef_idx)
					end do
					! --
				end if
			end do
		end do
		!$OMP END PARALLEL DO
		!
		!
		return
	end function

	function get_anti_herm(hw_lst, fd_distrib, i_eta_smr, en_k, A_ka)	result(opt_aherm)
		!	wann guide eq. (12.11)
		real(dp),		intent(in)		::	hw_lst(:), fd_distrib(:,:), en_k(:)
		complex(dp),	intent(in)		::	i_eta_smr
		complex(dp),	intent(in)		::	A_ka(:,:,:)
		complex(dp),	allocatable		::	a_dE_hw(:,:,:) ,opt_aherm(:,:,:,:)
		real(dp),		allocatable		::	df_mn(:)
		complex(dp)						::	a_nm_mn(3,3)
		integer							::	n, m, b, 		&
											hw_idx, n_hw,	&
											ef_idx, n_ef,	&
											n_wf
		real(dp)						::	dE_mn
		!
		n_hw	=	size(	hw_lst		,	1	)
		n_ef	=	size(	fd_distrib	,	1	)
		n_wf	=	size(	en_k		,	1	)
		!
		allocate(	df_mn(						n_ef	))
		allocate(	a_dE_hw(	3,3,	n_hw			))
		allocate(	opt_aherm(	3,3,	n_hw,	n_ef	))
		opt_aherm	=	cmplx(0.0, 0.0, dp)
		!
		!$OMP PARALLEL DO DEFAULT(	none )												&
		!$OMP PRIVATE(df_mn, dE_mn, b, a_nm_mn, a_dE_hw, hw_idx, ef_idx)			&
		!$OMP SHARED(n_wf,n_hw,n_ef, fd_distrib, en_k, A_ka, hw_lst, i_eta_smr )	&
		!$OMP REDUCTION(+: opt_aherm)
		do m = 1, n_wf
			do n = 1, n_wf
				if(n/=m) then
					!
					!	dE	BANDS
					df_mn(:)	=	fd_distrib(:,m)		-	fd_distrib(:,n)
					dE_mn		=		en_k(m) 		- 		en_k(n)
					! --
					!
					!	LOOP DIRECTIONS
					a_nm_mn	=	0.0_dp
					do b = 1, 3
						a_nm_mn(:,b)	=	A_ka(:,n,m) * A_ka(b,m,n)
					end do
					a_nm_mn		=	a_nm_mn  * dE_mn
					! --
					!
					!	LOOP HW LASER
					a_dE_hw		=	cmplx(0.0_dp,0.0_dp,dp)
					do hw_idx = 1, n_hw
						a_dE_hw(:,:,hw_idx)	=	a_nm_mn(:,:)							&
												/	real(dE_mn - hw_lst(hw_idx) - i_eta_smr , dp)
					end do
					! --
					!
					!	LOOP FERMI LEVEL
					do ef_idx = 1, n_ef
						opt_aherm(:,:,:,ef_idx)	=	opt_aherm(:,:,:,ef_idx)	+ i_dp	* a_dE_hw(:,:,:)	* df_mn(ef_idx)
					end do
					! --
					!
				end if
			end do
		end do
		!$OMP END PARALLEL DO
		!
		return
	end function

end module kubo


!=============================================================================!
        subroutine checkbc(vl)
!=============================================================================!
        use stuff
        real :: vl(ny,nx,ndof)

        real, parameter :: gc1 = -2.083333333333333333333E+00
        real, parameter :: gc2 =  4.000000000000000000000E+00
        real, parameter :: gc3 = -3.000000000000000000000E+00
        real, parameter :: gc4 =  1.333333333333333333333E+00
        real, parameter :: gc5 = -2.500000000000000000000E-01
!=============================================================================!

!.... WARNING

        return

        if (.true.) then

!         vl(1,:,1) = zero              ! zero disturbance

          vl(1,:,1) = vl(2,:,1)         ! first-order difference

!         vl(1,:,1)      = -( gc2 * vl(2,:,1)  + &
!                             gc3 * vl(3,:,1)  + &
!                             gc4 * vl(4,:,1)  + &
!                             gc5 * vl(5,:,1)  ) / gc1
        end if

!.... no slip wall

          vl(1,:,2:ndof-1)  = zero

!.... adiabatic temperature ( dT/deta = 0 )

        if (.true.) then

!         vl(1,:,ndof) = zero           ! zero disturbance

          vl(1,:,ndof) = vl(2,:,ndof)   ! first-order difference

!         vl(1,:,ndof)   = -( gc2 * vl(2,:,ndof)  + &
!                             gc3 * vl(3,:,ndof)  + &
!                             gc4 * vl(4,:,ndof)  + &
!                             gc5 * vl(5,:,ndof)  ) / gc1
        end if

        return
        end


      subroutine stmp_solt

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine estimates daily average temperature at the bottom
!!    of each soil layer

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    albday      |none          |albedo of ground for day
!!    hru_ra(:)   |MJ/m^2        |solar radiation for the day in HRU
!!    tmp_an(:)   |deg C         |average annual air temperature
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    Intrinsic: Exp, Log, Max, Min

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      use climate_module
      use septic_data_module
      use hru_module, only : hru, hru_ra, iseptic, ihru, tmpav, tmx, tmn, i_sep, iwgen, albday, isep
      use soil_module
      use time_module
      use organic_mineral_mass_module

      implicit none

      integer :: j               !none          |HRU number
      integer :: k               !none          |counter
      real :: f                  !none          |variable to hold intermediate calculation result
      real :: dp                 !mm            |maximum damping depth
      real :: ww                 !none          |variable to hold intermediate calculation
      real :: b                  !none          |variable to hold intermediate calculation
      real :: wc                 !none          |scaling factor for soil water impact on daily damping depth
      real :: dd                 !mm            |damping depth for day
      real :: xx                 !none          |variable to hold intermediate calculation
      real :: st0                !MJ/m^2        |radiation hitting soil surface on day
      real :: tlag               !none          |lag coefficient for soil temperature
      real :: df                 !none          |depth factor
      real :: zd                 !none          |ratio of depth at center of layer to damping depth
      real :: bcv                !none          |lagging factor for cover
      real :: tbare              !deg C         |temperature of bare soil surface
      real :: tcov               !deg C         |temperature of soil surface corrected for cover
      real :: tmp_srf            !deg C         |temperature of soil surface
      real :: cover              !kg/ha         |soil cover

      j = ihru

      tlag = 0.8

!! calculate damping depth

      !! calculate maximum damping depth
      !! SWAT manual equation 2.3.6
      f = 0.
      dp = 0.
      f = soil(j)%avbd / (soil(j)%avbd + 686. * Exp(-5.63 *       &
              soil(j)%avbd))
      dp = 1000. + 2500. * f

      !! calculate scaling factor for soil water
      !! SWAT manual equation 2.3.7
      ww = 0.
      wc = 0.
      ww = .356 - .144 * soil(j)%avbd
      wc = soil(j)%sw / (ww * soil(j)%phys(soil(j)%nly)%d)

      !! calculate daily value for damping depth
      !! SWAT manual equation 2.3.8
      b = 0.
      f = 0.
      dd = 0.
      b = Log(500. / dp)
      f = Exp(b * ((1. - wc) / (1. + wc))**2)
      dd = f * dp

!! calculate lagging factor for soil cover impact on soil surface temp
!! SWAT manual equation 2.3.11
      cover = pl_mass(j)%ab_gr_com%m + rsd1(j)%tot_com%m
      bcv = cover / (cover + Exp(7.563 - 1.297e-4 * cover))
      if (hru(j)%sno_mm /= 0.) then
        if (hru(j)%sno_mm <= 120.) then
          xx = 0.
          xx = hru(j)%sno_mm / (hru(j)%sno_mm + Exp(6.055 - .3002 * hru(j)%sno_mm))
        else
          xx = 1.
        end if
        bcv = Max(xx,bcv)
      end if

!! calculate temperature at soil surface
      st0 = 0.
      tbare = 0.
      tcov = 0.
      tmp_srf = 0.
      !! SWAT manual equation 2.3.10
      st0 = (hru_ra(j) * (1. - albday) - 14.) / 20.
      !! SWAT manual equation 2.3.9
      tbare = tmpav(j) + 0.5 * (tmx(j) - tmn(j)) * st0
      !! SWAT manual equation 2.3.12
      tcov = bcv * soil(j)%phys(2)%tmp + (1. - bcv) * tbare

!!    taking average of bare soil and covered soil as in APEX
!!    previously using minumum causing soil temp to decrease
!!    in summer due to high biomass

      tmp_srf = 0.5 * (tbare + tcov)  ! following Jimmy"s code

!! calculate temperature for each layer on current day
      xx = 0.
      do k = 1, soil(j)%nly
        zd = 0.
        df = 0.
        zd = (xx + soil(j)%phys(k)%d) / 2.  ! calculate depth at center of layer
        zd = zd / dd                 ! SWAT manual equation 2.3.5
        !! SWAT manual equation 2.3.4
        df = zd / (zd + Exp(-.8669 - 2.0775 * zd))
        !! SWAT manual equation 2.3.3
        soil(j)%phys(k)%tmp = tlag * soil(j)%phys(k)%tmp + (1. - tlag) *       &
                      (df * (wgn_pms(iwgen)%tmp_an - tmp_srf) + tmp_srf)
        xx = soil(j)%phys(k)%d

        ! Temperature correction for Onsite Septic systems
        isep = iseptic(j)
        if (sep(isep)%opt /= 0 .and. time%yrc >= sep(isep)%yr .and. k >=       &
                                                          i_sep(j)) then
	   if ( soil(j)%phys(k)%tmp < 10.) then
	       soil(j)%phys(k)%tmp = 10. - (10. - soil(j)%phys(k)%tmp) * 0.1
	   end if
	  endif

      end do

      return
      end subroutine stmp_solt


program miRPT_hMetal
use mod_miRPT_hMetal
use PhreeqcRM
implicit none

! ==============================================================================
!                           SIMULATION PARAMETERS
! ==============================================================================
integer, parameter          :: nthreads = 0
    ! number of OpenMP threads for reaction module. <= 0 implies the number of
    ! threads equals the number of processors of the computer
double precision, parameter :: maxtime = 1.577d8 ! 5 years = 1.577d8 seconds
double precision, parameter :: lowx = 0.0d0, upx = 0.4d0, omega = upx - lowx
    ! domain length, lower, upper bounds
double precision, parameter :: dt = 25920.0_dp ! time step [s] (25920 seconds = 0.3 days)
integer, parameter          :: nsteps = nint(maxtime/dt)! number of time steps
integer, parameter          :: nipart = 40 ! number of immobile particles
integer, parameter          :: nCellD = nipart ! number of cells in the diffusion field
    ! number of immobile particles and velocity field cells
double precision, parameter :: dxv = omega/dble(nCellD), dx = omega/dble(nipart)
    ! dx for velocity grid, and for calculating boundary injection
integer, parameter          :: nptot = 4e3
    ! number of mobile particles
double precision, parameter :: save_dt = dt * 1e2_dp
integer, parameter          :: save_steps = nint(maxtime/(save_dt)) + 1
    ! time step for saving concentrations for plotting and number of writes to be done

! ==============================================================================
!                           PHYSICAL PARAMETERS
! ==============================================================================
double precision, parameter :: porosity = 0.47d0
double precision, parameter :: init_D = 4.27e-10 / porosity ! effective diffusion coefficient
double precision            :: D(nCellD) = init_D
double precision            ::  repvol
    ! vectors for velocity and diffusion coefficients

! ==============================================================================
!                               GENERAL VARIABLES
! ==============================================================================
type(mparticle)               :: mparts(nptot) ! mobile particles
type(iparticle)               :: iparts(nipart) ! immobile particles
integer                       :: indices(nptot) ! array for easy indexing
integer, allocatable          :: alive(:)
    ! arrays for indexing to alive particles
integer                       :: nactive
    ! number of active mobile particles and how many exited in time step
double precision, allocatable :: Distmat(:, :)
    ! pairwise distance matrix for mass transfers
double precision, parameter   :: concPertMag = 0.0d0 ! magnitude (percentage) by which concentrations will be perturbed
double precision, allocatable :: concPerts(:, :), pertSum(:)
logical, parameter            :: normTotConc = .true. ! logical indicating whether to normalize the perturbed concentrations to sum to their original, unperturbed, values

! ==============================================================================
!                          PHREEQCRM VARIABLES
! ==============================================================================
double precision, dimension(nipart)   :: den_0, prs_0, tmp_0, sat_0, por_0, vol_0
double precision                      :: cur_time
integer                               :: i, j, m, id, status, ngrd
integer                               :: ncomp, nchem, so_col
integer                               :: ic1(nipart, 7)
integer                               :: mask(nipart)
double precision, allocatable         :: bc_conc(:, :), comp_conc(:, :),&
                                         sOut(:, :), fig3_plot_concs(:, :),&
                                         fig4_plot_concs(:, :), plot_times(:)
integer                               :: bc1(1) ! this is for one boundary condition

! ==============================================================================
!                          PHREEQCRM DEBUGGING VARIABLES
! ==============================================================================

! type(component_list), allocatable :: comp_list(:)
! character(50) :: tempname
! type(selectout_list), allocatable :: head_list(:)

! ==============================================================================
!                             READ/WRITE VARIABLES
! ==============================================================================

integer, parameter      :: fig3_numel = 7
integer                 :: fig3_elements(fig3_numel)
integer, parameter      :: fig3Plot_unit = 11
character(*), parameter :: fig3Plot_name = 'fig3_concs.txt'

integer, parameter      :: fig4_numel = 3
integer                 :: fig4_elements(fig4_numel)
integer, parameter      :: fig4Plot_unit = 12
character(*), parameter :: fig4Plot_name = 'fig4_concs.txt'

integer, parameter      :: statsPlot_unit = 13
character(*), parameter :: statsPlot_name = 'stats.txt'

! to store position vector of immobile particles
integer, parameter      :: immPos_unit = 14
character(*), parameter :: immPos_name = 'immPos.txt'

! ==============================================================================

! print some summary info, to begin with
write (*, *) '====================================================================='
write (*, *) 'maxtime = ', maxtime
write (*, *) 'dt = ', dt
write (*, *) 'nsteps = ', nsteps
write (*, *) 'kappaD, kappaM = ', kappaD, kappaM
write (*, *) 'init_D = ', init_D
write (*, *) 'N mobile = ', nptot
write (*, *) 'N immobile = ', nipart
write (*, *) 'MI stability condition (eta <= 8) = ', (omega / dble(2.0d0 * nipart))**2 /&
                                        (kappa * kappaM * init_D * dt)
write (*, *) 'IM stability condition (eta <= 8) = ', (omega / dble(2.0d0 * nptot))**2 /&
                                        (kappa * kappaM * init_D * dt)
write (*, *) '====================================================================='

open (unit = statsPlot_unit, file = statsPlot_name, action = 'write')
write (statsPlot_unit, *) '====================================================================='
write (statsPlot_unit, *) 'maxtime = ', maxtime
write (statsPlot_unit, *) 'dt = ', dt
write (statsPlot_unit, *) 'nsteps = ', nsteps
write (statsPlot_unit, *) 'kappaD, kappaM = ', kappaD, kappaM
write (statsPlot_unit, *) 'init_D = ', init_D
write (statsPlot_unit, *) 'N mobile = ', nptot
write (statsPlot_unit, *) 'N immobile = ', nipart
write (statsPlot_unit, *) 'MT stability condition = ', (omega / dble(min(nipart, nptot)))**2 /&
                                        (kappa * kappaM * init_D * dt)
write (statsPlot_unit, *) '====================================================================='
close (unit = statsPlot_unit, status = 'keep')

cur_time = 0.0d0

! calculate representative volume for immobile particles (1e3 = L/m^3)
repvol = (omega * 1e3_dp)/ dble(nipart)

! make all initial particles active
mparts%active = .false.
nactive = nptot
mparts(1 : nptot)%active = .true.
indices = (/(i, i = 1, nptot)/) ! this is for easy array-indexing of mparts

! scatter the mobile particles randomly throughout domain
call init_random_seed()
call random_number(mparts(1 : nptot)%loc)
mparts(1 : nptot)%loc = (upx - lowx) * mparts(1 : nptot)%loc + lowx
! initialize all mobile particle's bin to -999 for error catching
mparts%bin = -999

! distribute immobile particles evenly
iparts%loc = (/(dble(i) * (omega / (dble(nipart) - 1.0d0)), i = 0, nipart - 1)/)
! distribute immobile particles uniformly, making sure to hit the endpoints
! call random_number(iparts%loc)
! iparts%loc = lowx + (upx - lowx) * iparts%loc
! call quicksort(iparts%loc, 1, nipart)
! iparts(1)%loc = lowx
! iparts(nipart)%loc = upx
! write immobile positions to file
open (unit = immPos_unit, file = immPos_name, action = 'write')
write (immPos_unit, *) nipart
write (immPos_unit, *) iparts%loc
close (unit = immPos_unit, status = 'keep')

do i = 1, nipart
    iparts(i)%concs = 0.0d0
enddo

! ==============================================================================
!                   DEFINE PHYSICAL CONDITIONS (for PHREEQCRM)
! ==============================================================================
den_0 = 1.0d0 ! Density
prs_0 = 0.986923d0 ! Pressure 0.986923 atm = 1 bar
tmp_0 = 25.0d0 ! Temperature
sat_0 = 1.0d0 ! Saturation
por_0 = porosity ! Porosity
vol_0 = 1.0d0

! print chemistry mask to print detailed output (headings) for only first element
mask = 0
mask = 1
mask(1) = 1

id = RM_Create(nipart, nthreads)
write (*, *) 'Num threads = ', RM_GetThreadCount(id)
! database location
! location of file when running from main directory
status = RM_LoadDatabase(id, './phreeqc_files/PHREEQC-database.txt')
if (status < 0) then
    print *, 'Database Load Error'
    call exit(status)
endif

! initialize all the settings for the reaction module
status = RM_OpenFiles(id)
status = RM_SetRepresentativeVolume(id, vol_0)
status = RM_SetSaturation(id, sat_0)
status = RM_SetPorosity(id, por_0)
status = RM_SetTime(id, cur_time)
status = RM_SetTimeStep(id, dt)
status = RM_SetDensity(id, den_0)
status = RM_SetTemperature(id, tmp_0)
status = RM_SetPressure(id, prs_0)
status = RM_SetSelectedOutputOn(id, 1) ! turn on selected output to get dolomite/calcite values
status = RM_SetUnitsSolution(id, 2) ! 2 = mol/L
status = RM_SetUnitsPPassemblage(id, 0) ! 0 = mol/L of representative volume
status = RM_SetUnitsKinetics(id, 0) ! 0 = mol/L of representative volume
status = RM_SetUnitsExchange(id, 0) ! 0 = mol/L of representative volume
status = RM_SetUnitsSurface(id, 0) ! 0 = mol/L of representative volume
status = RM_SetUnitsSSassemblage(id, 1) ! 1 = mol/L of representative volume
status = RM_SetPrintChemistryMask(id, mask)
! status = RM_SetPrintChemistryOn(id, 1, 1, 1) ! this toggles detailed output about reaction calculations
status = RM_SetPrintChemistryOn(id, 0, 0, 0) ! this toggles detailed output about reaction calculations
status = RM_SetScreenOn(id, 0) ! turn off messages about rebalancing
status = RM_SetComponentH2O(id, 1)
    ! 0 implies that H2O is not given as a separate component--just H and O
    ! 1 is default with H2O as separate component
! location of file when running from main directory
status = RM_RunFile(id, 1, 1, 1, './phreeqc_files/PHREEQC-Case1-Input.txt')

! the following isn't strictly necessary if you already know what your problem
! looks like, but it's quick and only done once.

ncomp = RM_FindComponents(id)
! get number of grid cells in model (this can change, so it needs to be checked)
ngrd = RM_GetGridCellCount(id)
if (ngrd /= nipart) then
    print *, '****** Cell count differs from particle number ******'
    call exit(status)
endif

print *, 'ncomp = ', ncomp

nchem = RM_GetChemistryCellCount(id)
if (nchem /= nipart) then
    print *, '****** Chem count differs from particle number ******'
    call exit(status)
endif

! ==============================================================================
!                       INITIAL/BOUNDARY CONDITIONS
! ==============================================================================
! ||     (1) SOLUTIONS, (2) EQUILIBRIUM_PHASES, (3) EXCHANGE,                 ||
! ||     (4) SURFACE, (5) GAS_PHASE, (6) SOLID_SOLUTIONS, and (7) KINETICS    ||
! ==============================================================================

ic1 = -1
ic1(:, 1) = 1
ic1(:, 2) = 1
ic1(:, 4) = 1
ic1(:, 7) = 1

allocate(bc_conc(1, ncomp))
    ! must be 2D array for module--requires singleton dimension in this case
bc1 = 1 ! corresponds to solution zero in input file

status = RM_InitialPhreeqc2Module(id, ic1)
! =======================================================================

! ==============================================================================
!              GET AQUEOUS COMPONENT AND SELECTED OUTPUT NAMES
! ==============================================================================
! the following blocks will give you the names of the components and
! headings for selected output.
! They are left here purely for reference, and will not run unless you
! instantiate the corresponding variables in the PHREEQCRM DEBUGGING VARIABLES
! block, above.
! ==============================================================================

! ! this makes a list of the names of components
! ! (requires PHREEQCRM DEBUGGING VARIABLES to be uncommented)
! allocate(comp_list(ncomp))
! print *, 'ncomp = ', ncomp
! do i = 1, ncomp
!     status = RM_GetComponent(id, i, tempname)
!     allocate(character(len_trim(tempname)) :: comp_list(i)%comp)
!     comp_list(i)%comp = trim(tempname)
!     print *, comp_list(i)%comp
! enddo
! ==============================================================================

! need to run the cells to get the selected output headings(?)
status = RM_RunCells(id)

! ==============================================================================

! so_col = RM_GetSelectedOutputcolumncount(id)
! so_row = RM_GetSelectedOutputrowcount(id)
! allocate(sOut(so_row, so_col))
! status = RM_GetSelectedOutput(id, sOut)

! ! this makes a list of the names of selected output elements
! ! (requires PHREEQCRM DEBUGGING VARIABLES to be uncommented)
! allocate(head_list(so_col))
! do i = 1, so_col
!     status = RM_GetSelectedOutputheading(id, i, tempname)
!     allocate(character(len_trim(tempname)) :: head_list(i)%head)
!     head_list(i)%head = trim(tempname)
!     print *, 'sOut entry #', i, ' = ', head_list(i)%head
! enddo

! ==============================================================================

! get ion concentrations from the reaction module
allocate(comp_conc(nipart, ncomp))
status = RM_GetConcentrations(id, comp_conc)

! perturb the concentrations, if they are to be perturbed
if (concPertMag > 0.0d0) then

    allocate(concPerts(nipart, ncomp), pertSum(ncomp))

    ! use this for normalizing the perturbed total concentration to the original value
    pertSum = sum(comp_conc, 1)

    call random_number(concPerts)
    ! rescale concPerts to be (-concPertMag, concPertMag)
    concPerts = -concPertMag + 2.0d0 * concPertMag * concPerts
    ! make concPerts (-concPertMag * comp_conc, concPertMag * comp_conc) and add it to comp_conc
    comp_conc = comp_conc + concPerts * comp_conc

    if (normTotConc) then
        ! this normalizes the perturbed initial concentrations to sum to the original total concentration
        do i = 1, ncomp
            comp_conc(:, i) = comp_conc(:, i) * (pertSum(i) / sum(comp_conc(:, i)))
        enddo
    endif

    deallocate(concPerts, pertSum)

endif

! transfer the concentration array to the immobile particles
call concs_to_iparts(comp_conc, iparts, nipart)

! get the boundary condition
status = RM_InitialPhreeqc2Concentrations(id, bc_conc, 1, bc1)

! add the boundary condition to the boundary immobile particle
iparts(1)%concs(:) = iparts(1)%concs(:) + bc_conc(1, :)

! ==============================================================================
!               SELECTED OUTPUT (based on the PHREEQC input file)
! ==============================================================================

! the names of the fields in sOut can be found in the file: sOut_fields.txt

! assign the indices of sOut that will be used for re-creating Fig. 3 of Arora, et al.
! These are: pH, Alkalinity, N(5), Sulfate, Feii, Pb
fig3_elements = (/ 7, 50, 10, 14, 12, 40, 28 /)

! assign the indices of sOut that will be used for re-creating Fig. 4 of Arora, et al.
! These are: Ferrihydrite, FeS, and Siderite
fig4_elements = (/ 21, 22, 23  /)

! ==============================================================================
!        CONCS (what is being transported and given to the reaction module)
! ==============================================================================
! dimension of concs is ntrans (# chemistry cells + 1 for boundary) x ncomp

! For this specific problem:

! If (RM_SetComponentH2O(id, 0)):
! (1) H, (2) O, (3) Charge, (4) Acetate, (5) C, (6) Ca, (7) Cl, (8) Fe, (9) Feii,
! (10) K, (11) Mg, (12) N, (13) Na, (14) Naq, (15) Oxy, (16) Pb, (17) S,
! (18) Sulfate, (19) Zn

! If (RM_SetComponentH2O(id, 1)):
! (1) H2O, (2) H, (3) O, (4) Charge, (5) Acetate, (6) C, (7) Ca, (8) Cl, (9) Fe,
! (10) Feii, (11) K, (12) Mg, (13) N, (14) Na, (15) Naq, (16) Oxy, (17) Pb,
! (18) S, (19) Sulfate, (20) Zn

! ==============================================================================

so_col = RM_GetSelectedOutputcolumncount(id)
allocate(sOut(nipart, so_col))
status = RM_GetSelectedOutput(id, sOut)
allocate(fig3_plot_concs(nipart, fig3_numel + 1),&
         fig4_plot_concs(nipart, fig4_numel), plot_times(save_steps + 1))

! find out which bins the initial particles are in
allocate (alive(nactive))
alive = (/(i, i = 1, nactive)/)
mparts(alive)%bin = floor(mparts(alive)%loc/dxv) + 1 ! bin based on velocity grid

do i = 1, nptot
    mparts(i)%concs = 0.0d0
enddo

! get the pairwise distance matrix
allocate(Distmat(nipart, nactive))
call build_Distmat(iparts, mparts, nactive, alive, nipart, D, dt, Distmat)

! do the immobile to mobile transfer
call immobile2mobile(iparts, mparts, nactive, alive, nipart, D, dt, ncomp, Distmat)
deallocate(Distmat, alive)

fig3_plot_concs(:, 1 : fig3_numel) = sOut(:, fig3_elements)
fig3_plot_concs(:, fig3_numel + 1) = iparts%concs(6) ! *** "alkalinity" seems to correspond to the C species

fig4_plot_concs(:, :) = sOut(:, fig4_elements)

plot_times(1 : save_steps) = (/((i - 1) * save_dt, i = 1, save_steps)/)
plot_times(save_steps + 1) = maxtime

! this is the file that stores what comes from fig3_plot_concs
! the header gives the shape of the full array and the number of time steps
open (unit = fig3Plot_unit, file = fig3Plot_name, action = 'write')
write (fig3Plot_unit, *) shape(fig3_plot_concs), save_steps
write (fig3Plot_unit, *) fig3_plot_concs
close (unit = fig3Plot_unit, status = 'keep')

open (unit = fig4Plot_unit, file = fig4Plot_name, action = 'write')
write (fig4Plot_unit, *) shape(fig4_plot_concs), save_steps
write (fig4Plot_unit, *) fig4_plot_concs
close (unit = fig4Plot_unit, status = 'keep')

! counter for plot_times
j = 2

! time stepping loop
do m = 1, nsteps
    write (*, *) 'step = ', m, ' of ', nsteps

    ! get indices of alive particles
    nactive = count(mparts%active)
    allocate (alive(nactive))
    alive = pack(indices, mparts%active)
    mparts(alive)%bin = floor(mparts(alive)%loc/dxv) + 1 ! bin based on velocity grid

    call diffuse(mparts, nactive, D, dt, alive)

    ! impose reflecting/absorbing boundary conditions
    call reflectlow(mparts, lowx, alive)
    call reflecthigh(mparts, upx, alive)

    ! determine what particles are alive (in bounds) after transport
    deallocate (alive)
    nactive = count(mparts%active)
    allocate (alive(nactive))
    alive = pack(indices, mparts%active)
    mparts(alive)%bin = floor(mparts(alive)%loc/dxv) + 1

    ! build the pairwise distance matrix after moving the particles
    allocate(Distmat(nipart, nactive))
    call build_Distmat(iparts, mparts, nactive, alive, nipart, D, dt, Distmat)

    ! conduct the mobile-to-immobile transfers
    call mobile2immobile(iparts, mparts, nactive, alive, nipart, D, dt, ncomp, Distmat)
    deallocate(Distmat)

    ! transfer the concentrations in the particles array to the PHREEQCRM concs array
    call iparts_to_concs(comp_conc, iparts, nipart)

    cur_time = cur_time + dt
    status = RM_SetTime(id, cur_time)
    status = RM_SetConcentrations(id, comp_conc)
    status = RM_RunCells(id)
    status = RM_GetConcentrations(id, comp_conc)

    call concs_to_iparts(comp_conc, iparts, nipart)

    ! write out the plotting arrays
    if (cur_time >= plot_times(j)) then
        status = RM_GetSelectedOutput(id, sOut)
        fig3_plot_concs(:, 1 : fig3_numel) = sOut(:, fig3_elements)
        fig3_plot_concs(:, fig3_numel + 1) = iparts%concs(6) ! *** "alkalinity" seems to correspond to the C species
        fig4_plot_concs(:, :) = sOut(:, fig4_elements)

        open (unit = fig3Plot_unit, file = fig3Plot_name, action = 'write',&
              status = 'old', access = 'append')
        write (fig3Plot_unit, *) fig3_plot_concs
        close (unit = fig3Plot_unit, status = 'keep')

        open (unit = fig4Plot_unit, file = fig4Plot_name, action = 'write',&
              status = 'old', access = 'append')
        write (fig4Plot_unit, *) fig4_plot_concs
        close (unit = fig4Plot_unit, status = 'keep')

        j = j + 1
    endif

    ! add boundary injection to first immobile particle
    iparts(1)%concs(:) = iparts(1)%concs(:) + bc_conc(1, :)

    deallocate (alive)
    nactive = count(mparts%active)
    allocate (alive(nactive)) ! maybe preallocate to avoid repeatedly doing this
    alive = pack(indices, mparts%active)
    mparts(alive)%bin = floor(mparts(alive)%loc/dxv) + 1

    ! build the distance matrix again
    allocate(Distmat(nipart, nactive))
    call build_Distmat(iparts, mparts, nactive, alive, nipart, D, dt, Distmat)

    ! conduct the immobile-to-mobile transfers
    call immobile2mobile(iparts, mparts, nactive, alive, nipart, D, dt, ncomp, Distmat)

    deallocate(Distmat)

    deallocate (alive)

enddo

status = RM_Destroy(id)
deallocate (bc_conc, comp_conc, sOut, fig3_plot_concs, plot_times)

end program miRPT_hMetal


      double precision function Hggggvsq(j1,j2,j3,j4)
      implicit none
      include 'epinv.f'
      include 'epinv2.f'
      include 'first_time.f'
C---  matrix element squared for H--g(j1)+g(j2)+g(j3)+g(j4)
      integer al,j1,j2,j3,j4
      double precision q(4,5),qswap(4,5),sqres(-2:0)
      common/GZmom/q
!$omp threadprivate(/GZmom/)

      do al=1,4
      qswap(al,1)=q(al,j1)
      qswap(al,2)=q(al,j2)
      qswap(al,3)=q(al,j3)
      qswap(al,4)=q(al,j4)
      qswap(al,5)=-q(al,j1)-q(al,j2)-q(al,j3)-q(al,j4)
      enddo

C      write(*,*) 'scale, hmass',scale, hmass
      call GZHggggvsqPoles(qswap,sqres)
C      call GZHggggvsq(qswap,sqres,first_time,new_event,scale,hmass)
      Hggggvsq=epinv*epinv2*sqres(-2)+epinv*sqres(-1)+sqres(0)
      if (first_time) first_time = .false.
      !if (new_event) new_event = .false.
      return
      end


! Fortran translation of Mersenne Twister pseudo-random number generator.
!
!! @author Michael P. Howard
!
! The original code is modified and used under the following license:
!
!   Copyright (C) 1997 - 2002, Makoto Matsumoto and Takuji Nishimura,
!   All rights reserved.
!
!   Redistribution and use in source and binary forms, with or without
!   modification, are permitted provided that the following conditions
!   are met:
!
!     1. Redistributions of source code must retain the above copyright
!        notice, this list of conditions and the following disclaimer.
!
!     2. Redistributions in binary form must reproduce the above copyright
!        notice, this list of conditions and the following disclaimer in the
!        documentation and/or other materials provided with the distribution.
!
!     3. The names of its contributors may not be used to endorse or promote
!        products derived from this software without specific prior written
!        permission.
!
!   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
!   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
!   A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT OWNER OR
!   CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
!   EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
!   PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
!   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
!   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
!   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
!   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
!
! The original paper can be found here:
!
!   http://www.math.sci.hiroshima-u.ac.jp/~m-mat/values/ARTICLES/mt.pdf
!
! Note this paper uses a different initialization procedure, which was later
! shown to have some issues.

module mt19937
    implicit none

    private
    public :: mt19937_t, mt19937_seed, mt19937_int32, mt19937_uniform, &
              mt19937_uniform_int, mt19937_uniform_real

    ! values required for manipulating the MT state
    integer(kind=4),parameter :: N = 624
    integer(kind=4),parameter :: M = 397
    integer(kind=4),parameter :: LOWER_MASK = 2147483647
    integer(kind=4),parameter :: UPPER_MASK = -LOWER_MASK-1
    integer(kind=4),parameter,dimension(0:1) :: MAG01 = (/0,-1727483681/)

    !> @brief State of the random number generator
    !!
    !! This holds a vector of values created when the generator is advanced.
    !! The index points into this list of values (0-indexed). Restoring this
    !! state would be sufficient to restart the generator exactly.
    type :: mt19937_t
        integer(kind=4),dimension(0:N-1) :: values
        integer(kind=4) :: idx = N
    end type mt19937_t

contains

    !> @ brief Set seed for the random number generator.
    !!
    !! The initial state of the generator is set using a linear
    !! congruential generator. The index of the state is set to its end
    !! so that the next call will update the state. This method **must**
    !! be called before using the state of the generator.
    !!
    !! @param[inout]    state   State of the random number generator.
    !! @param[in]       seed    Seed for the generator.
    !!
    subroutine mt19937_seed(state, seed)
        type(mt19937_t), intent(inout) :: state
        integer(kind=4), intent(in) :: seed
        integer(kind=4) i

        state%idx = N
        state%values(0) = iand(seed,-1)
        do i=1,N-1
            state%values(i) = iand(1812433253*ieor(state%values(i-1),ishft(state%values(i-1),-30))+i,-1)
        end do
    end subroutine mt19937_seed

    !!> @brief Generate a random 32-bit signed integer.
    !!
    !! A random integer is drawn using the MT19937 algorithm. The state of
    !! the generator is advanced if new values are required; otherwise, values
    !! are pulled from the cached state. The returned value is tempered for use.
    !!
    !! @param[inout]    state   State of the random number generator.
    !! @param[out]      value   Random 32-bit signed integer.
    !!
    subroutine mt19937_int32(state, value)
        type(mt19937_t), intent(inout) :: state
        integer(kind=4), intent(out) :: value
        integer(kind=4) i,y

        ! advance state if we have run out of values
        if (state%idx >= N) then
            ! section 1
            do i=0,N-M-1
                y = ior(iand(state%values(i),UPPER_MASK),iand(state%values(i+1),LOWER_MASK))
                state%values(i) = ieor(ieor(state%values(i+M),ishft(y,-1)),MAG01(iand(y,1)))
            end do

            ! section 2
            do i=N-M,N-2
                y = ior(iand(state%values(i),UPPER_MASK),iand(state%values(i+1),LOWER_MASK))
                state%values(i) = ieor(ieor(state%values(i+(M-N)),ishft(y,-1)),MAG01(iand(y,1)))
            end do

            ! final section
            y = ior(iand(state%values(N-1),UPPER_MASK),iand(state%values(0),LOWER_MASK))
            state%values(i) = ieor(ieor(state%values(M-1),ishft(y,-1)),MAG01(iand(y,1)))

            ! reset counter
            state%idx = 0
        endif

        ! temper value
        y = state%values(state%idx)
        state%idx = state%idx + 1
        y = ieor(y,ishft(y,-11))
        y = ieor(y,iand(ishft(y,7),-1658038656))
        y = ieor(y,iand(ishft(y,15),-272236544))
        y = ieor(y,ishft(y,-18))

        ! return
        value = y
    end subroutine mt19937_int32

    !!> @brief Generate a uniform random real in [0,1) with 32-bits of randomness.
    !!
    !! The random real is generated by drawing an integer and converting it to the
    !! [0,1) range. Note that this generates only 32-bits of randomness. If additional
    !! bits are required, a method drawing 53-bits from two 32-bit integers can be
    !! implemented.
    !!
    !! @param[inout]    state   State of the random number generator.
    !! @param[out]      value   Random real(8) in [0,1).
    !!
    subroutine mt19937_uniform(state, value)
        type(mt19937_t), intent(inout) :: state
        real(kind=8), intent(out) :: value
        integer(kind=4) y

        call mt19937_int32(state,y)

        ! convert int to double
        value = 0.5d0+dble(y)/4294967296.0d0
    end subroutine mt19937_uniform

    !!> @brief Generate a uniform random int in [0,n).
    !!
    !! A random integer in [0,n) is generated by drawing a uniform real, then
    !! scaling and flooring it into this range.
    !!
    !! @param[inout]    state   State of the random number generator.
    !! @param[out]      value   Random integer in [0,n).
    !! @param[n]        n       Maximum value (exclusive).
    !!
    subroutine mt19937_uniform_int(state, value, n)
        type(mt19937_t), intent(inout) :: state
        integer(kind=4), intent(out) :: value
        integer(kind=4), intent(in) :: n
        real(kind=8) :: r

        call mt19937_uniform(state,r)
        value = floor(n*r)
    end subroutine mt19937_uniform_int

    !!> @brief Generate a uniform random real in [0,n) with 32-bits of randomness.
    !!
    !! A random real in [0,n) is generated by scaling a uniform real. Note that this
    !! real still has 32-bits of randomness.
    !!
    !! @param[inout]    state   State of the random number generator.
    !! @param[out]      value   Random real(8) in [0,n).
    !! @param[n]        n       Maximum value (exclusive).
    !!
    subroutine mt19937_uniform_real(state, value, n)
        type(mt19937_t), intent(inout) :: state
        real(kind=8), intent(out) :: value
        real(kind=8), intent(in) :: n

        call mt19937_uniform(state, value)
        value = n*value
    end subroutine mt19937_uniform_real

end module mt19937


      SUBROUTINE ETP (XI,YI, XFRMT, XO,YO)

      REAL XFRMT (3,3), PTI(3,1), PTO(3,1)
      REAL XI,YI, XO,YO, W

      PTI(1,1) = XI
      PTI(2,1) = YI
      PTI(3,1) = 1.0

      CALL MATMUL (3,3,1, XFRMT, PTI, PTO)
      W  = PTO(3,1)
      XO = PTO(1,1) / W
      YO = PTO(2,1) / W

      END


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Covariance matrices for real-space EZmocks multipoles
! for any issue please contact ginevra.favole@port.ac.uk
!-------------------------------------------------------
!compile as:
!  ifort -fopenmp covariances_real.f90 -o covreal
!execute as:
! ./covreal

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

program main
  implicit none
  CHARACTER(150), PARAMETER   :: inputcat='multipoles/mean_multipoles_real.txt'
  CHARACTER(150), PARAMETER   :: output00='covariances/covariance_xi0xi0_real.txt'
  CHARACTER(150), PARAMETER   :: output22='covariances/covariance_xi2xi2_real.txt'
  CHARACTER(150), PARAMETER   :: output44='covariances/covariance_xi4xi4_real.txt'
  CHARACTER(150), PARAMETER   :: output02='covariances/covariance_xi0xi2_real.txt'
  CHARACTER(150), PARAMETER   :: output04='covariances/covariance_xi0xi4_real.txt'
  CHARACTER(150), PARAMETER   :: output24='covariances/covariance_xi2xi4_real.txt'
  CHARACTER(150), PARAMETER   :: outputsigma00='covariances/sigma_xi0_real.txt'
  CHARACTER(150), PARAMETER   :: outputsigma22='covariances/sigma_xi2_real.txt'
  CHARACTER(150), PARAMETER   :: outputsigma44='covariances/sigma_xi4_real.txt'

  CHARACTER(len=150) :: FN
  CHARACTER(len=150) :: GN
  integer, parameter :: Nres=999,cov_num=40
  real*8, dimension(:), allocatable  :: s, xi0m, xi2m, xi4m, s_mock, xi0_mock, xi2_mock, xi4_mock
  real*8, dimension(cov_num,cov_num) :: cov00,cov22,cov44,cov02,cov04,cov24,b1
  integer :: l, i, j, k, io, media_num, N_halsum
  real*8 :: temp

!----------------------------------------- read input mean catalogue:
  open(unit=1400,file=inputcat)
  media_num = 0
200 read(1400,*,end=201) b1
  media_num = media_num+1
  goto 200
201 close(1400)

  allocate(s(media_num),xi0m(media_num),xi2m(media_num),xi4m(media_num))

  open(unit=1400,file=inputcat)
  do l=1,media_num
     read(1400,*) s(l),xi0m(l),xi2m(l),xi4m(l)
  end do
  close(1400)

  !------------------------------------------------ compute covariances
cov00=0.
cov22=0.
cov44=0.
cov02=0.
cov04=0.
cov24=0.

DO I=0,Nres
WRITE(FN,10)I
WRITE(6,*)FN
j=1
OPEN(1,FILE=FN)
DO
READ(1,*,IOSTAT=io) temp
IF (io < 0) THEN
N_halsum = j-1
EXIT
ENDIF
j =j+1
ENDDO
allocate(s_mock(1:N_halsum),xi0_mock(1:N_halsum), xi2_mock(1:N_halsum), xi4_mock(1:N_halsum))
rewind(1)

do k=1,N_halsum
read(1,*,IOSTAT=io) s_mock(k), xi0_mock(k), xi2_mock(k), xi4_mock(k)
enddo

do l=1,N_halsum
do j=1,N_halsum
cov00(l,j)=cov00(l,j)+(xi0_mock(l)-xi0m(l))*(xi0_mock(j)-xi0m(j))
cov22(l,j)=cov22(l,j)+(xi2_mock(l)-xi2m(l))*(xi2_mock(j)-xi2m(j))
cov44(l,j)=cov44(l,j)+(xi4_mock(l)-xi4m(l))*(xi4_mock(j)-xi4m(j))
cov02(l,j)=cov02(l,j)+(xi0_mock(l)-xi0m(l))*(xi2_mock(j)-xi2m(j))
cov04(l,j)=cov04(l,j)+(xi0_mock(l)-xi0m(l))*(xi4_mock(j)-xi4m(j))
cov24(l,j)=cov24(l,j)+(xi2_mock(l)-xi2m(l))*(xi4_mock(j)-xi4m(j))
enddo
enddo

CLOSE(1)
DEALLOCATE(s_mock,xi0_mock, xi2_mock, xi4_mock)
ENDDO

!------------------------------------ outputs in matrix format (40 x 40)
open(unit=1570,file=output00)
open(unit=1571,file=output22)
open(unit=1572,file=output44)
open(unit=1573,file=output02)
open(unit=1574,file=output04)
open(unit=1575,file=output24)

open(unit=1576,file=outputsigma00)
open(unit=1577,file=outputsigma22)
open(unit=1578,file=outputsigma44)

do l=1,N_halsum
do j=1,N_halsum
!we have 1000 mocks with 0<=Nres<=999 and here we need to divide by 999:
cov00(l,j)=(1./dble(Nres))*cov00(l,j)
cov22(l,j)=(1./dble(Nres))*cov22(l,j)
cov44(l,j)=(1./dble(Nres))*cov44(l,j)
cov02(l,j)=(1./dble(Nres))*cov02(l,j)
cov04(l,j)=(1./dble(Nres))*cov04(l,j)
cov24(l,j)=(1./dble(Nres))*cov24(l,j)
enddo
write(1570,'(40(e,x))') (cov00(l,j), j=1,N_halsum)
write(1571,'(40(e,x))') (cov22(l,j), j=1,N_halsum)
write(1572,'(40(e,x))') (cov44(l,j), j=1,N_halsum)
write(1573,'(40(e,x))') (cov02(l,j), j=1,N_halsum)
write(1574,'(40(e,x))') (cov04(l,j), j=1,N_halsum)
write(1575,'(40(e,x))') (cov24(l,j), j=1,N_halsum)

write(1576,'(f20.8)') sqrt(cov00(l,l))
write(1577,'(f20.8)') sqrt(cov22(l,l))
write(1578,'(f20.8)') sqrt(cov44(l,l))
enddo
close(1570)
close(1571)
close(1572)
close(1573)
close(1574)
close(1575)
close(1576)
close(1577)
close(1578)

10 FORMAT('multipoles/xilreal_',I3.3,'.txt')

deallocate(s, xi0m, xi2m, xi4m)
end program main


      program zlatev
c-----------------------------------------------------------------------
c
c test suite for zlatev matrices. generates three matrices and
c writes them in three different files in Harwell-Boeing format.
c      zlatev1.mat  produced from matrf2
c      zlatev2.mat  produced from  dcn
c      zlatev3.mat  produced from  ecn
c
c-----------------------------------------------------------------------
      parameter (nmax = 1000, nzmax=20*nmax)
      implicit real*8 (a-h,o-z)
      integer ia(nzmax), ja(nzmax), iwk(nmax)
      real*8 a(nzmax)
      character title*72, key*3,type*8, guesol*2
c
      open (unit=7,file='zlatev1.mat')
      open (unit=8,file='zlatev2.mat')
      open (unit=9,file='zlatev3.mat')
c
      m = 100
      n = m
      ic = n/2
      index = 10
      alpha = 5.0
      nn = nzmax
c
c call matrf2
c
      call matrf2(m,n,ic,index,alpha,nn,nz,a,ia,ja,ierr)
      job = 1
c      do 110 i = 1, nz
c         print *, ia(i), ja(i), a(i)
c 110  continue
      call coicsr(n, nz, job, a, ja, ia, iwk)
c-----
      title = ' 1st matrix from zlatev examples                '
      type  = 'RUA'
      key   = ' ZLATEV1'
      iout  = 7
      guesol='NN'
c
      ifmt = 3
      job = 2
c
c write result in H-B format.
c
c Replaces prtmt with smms in order to print matrix in format for
c SMMS instead.
c      call smms (n,1,n,0,a,ja,ia,iout)
      call prtmt (n,n,a,ja,ia,rhs,guesol,title,type,key,
     1	                  ifmt,job,iout)

c-------- second type of matrices dcn matrices ---------------
       n = 200
       nn = nzmax
       ic = 20
c-------------------------------------------------------
c matrix of the type e(c,n)
c-------------------------------------------------------
       call dcn(a,ia,ja,n,ne,ic,nn,ierr)
c---------------------------------------------------
      call coicsr(n, ne, job, a, ja, ia, iwk)
      title = ' 2nd matrix from zlatev examples                '
      iout = iout+1
      guesol='NN'
      type  = 'RUA'
      key = ' ZLATEV2'
c
      ifmt = 3
      job = 2
c
c write result in second file
c
c Replaced prtmt with smms in order to print matrix in format for
c SMMS instead.
c      call smms (n,1,n,0,a,ja,ia,iout)
      call prtmt (n,n,a,ja,ia,rhs,guesol,title,type,key,
     1	                  ifmt,job,iout)
c-------------------------------------------------------
c matrix of the type e(c,n)
c-------------------------------------------------------
       n = 200
       ic = 20
       nn = nzmax
c
c call ecn
c
      call ecn(n,ic,ne,ia,ja,a,nn,ierr)
      call coicsr(n, ne, job, a, ja, ia, iwk)
      title = ' 3nd matrix from zlatev examples                '
      guesol='NN'
      type  = 'RUA'
      key = ' ZLATEV3'
      iout = iout+1
c
      ifmt = 3
      job = 2
c
c write resulting matrix in third file
c
c Replaced prtmt with smms in order to print matrix in format for
c SMMS instead.
c      call smms (n,1,n,0,a,ja,ia,iout)
      call prtmt (n,n,a,ja,ia,rhs,guesol,title,type,key,
     1	                  ifmt,job,iout)
      stop
      end


!> Weighted Essentially Non-Oscillatory, WENO, functions and subroutines.
!! Fifth order accurate WENO scheme designed by Jiang and C.-W. Shu 1996.
!!
!! @author Prashant Valluri, Lennon O Naraigh, Iain Bethune,
!! Toni Collis, David Scott, Peter Spelt.
!! @copyright (c) 2013-2015, Prashant Valluri, Lennon O Naraigh,
!! Iain Bethune, Toni Collis, David Scott, Peter Spelt.
!! This program is distributed under the BSD License See LICENSE.txt
!! for details.

module weno

  implicit none

contains

  ! Compute the upwinding convective term.
  subroutine WENOAppoxConvection(phi, u, v, w, sx, ex, sy, ey, l, n, dfx,dfy, dfz)
    !call      WENOAppoxConvection(phi_augaug, u2, v2, w2, sx, ex, sy, ey, maxl, maxn, dfx, dfy, dfz)
    implicit none

    ! Arguments
    integer, intent(in) :: sx, ex, sy, ey, l, n

    double precision, intent(in) :: phi(sx-3:ex+3, sy-3:ey+3, 0:n)
    double precision, intent(in) :: u(sx-1:ex+1, sy-1:ey+1, 0:n-2)
    double precision, intent(in) :: v(sx-1:ex+1, sy-1:ey+1, 0:n-2)
    double precision, intent(in) :: w(sx-1:ex+1, sy-1:ey+1, 0:n-1)

    double precision, intent(out) :: dfx(sx-1:ex+1, sy-1:ey+1, 0:n-2)
    double precision, intent(out) :: dfy(sx-1:ex+1, sy-1:ey+1, 0:n-2)
    double precision, intent(out) :: dfz(sx-1:ex+1, sy-1:ey+1, 0:n-1)

    ! Local variables
    integer :: i, j, k, im2, im1, ip2, ip3, jm2, jm1, jp2, jp3

    double precision :: v1, v2, v3, v4, v5

    !$omp parallel default(shared), private(i, j, k, im2, im1, ip2, ip3, v1, v2, v3, v4, v5)
    !$omp do
    do k = 0, n-2
       do j = sy, ey
          do i = sx, ex

             if((i.ge.3).and.(i.le.(l-3))) then

                im2 = i-2
                im1 = i-1
                ip2 = i+2
                ip3 = i+3

                if(u(i, j, k).ge.0)then
                   v1 = phi(im2, j+1, k+1)
                   v2 = phi(im1, j+1, k+1)
                   v3 = phi(i, j+1, k+1)
                   v4 = phi(i+1, j+1, k+1)
                   v5 = phi(ip2, j+1, k+1)
                else
                   v1 = phi(ip3, j+1, k+1)
                   v2 = phi(ip2, j+1, k+1)
                   v3 = phi(i+1, j+1, k+1)
                   v4 = phi(i, j+1, k+1)
                   v5 = phi(im1, j+1, k+1)
                endif

                dfx(i, j, k) = WENO5(v1, v2, v3, v4, v5)

             else

                if(u(i, j, k).ge.0.d0)then
                   dfx(i, j, k) = phi(i, j+1, k+1)
                else
                   dfx(i, j, k) = phi(i+1, j+1, k+1)
                endif

             end if

          enddo
       enddo
    enddo
    !$omp end do
    !$omp end parallel

    ! Take care of boundary point at i=0 as this is the only one needed

    if(sx==1)then
       !$omp parallel default(shared), private(j, k)
       !$omp do
       do k = 0, n-2
          do j = sy, ey
             if(u(0, j, k).ge.0.d0)then
                dfx(0, j, k) = phi(0, j+1, k+1)
             else
                dfx(0, j, k) = phi(1, j+1, k+1)
             endif
          end do
       end do
       !$omp end do
       !$omp end parallel
    end if

    !$omp parallel default(shared), private(i, j, k, jm2, jm1, jp2, jp3, v1, v2, v3, v4, v5)

    !$omp do
    do k = 0, n-2
       do j = sy, ey
          do i = sx, ex

             jm2 = j-2
             jm1 = j-1
             jp2 = j+2
             jp3 = j+3

             if(v(i, j, k).ge.0.d0)then
                v1 = phi(i, jm2, k+1)
                v2 = phi(i, jm1, k+1)
                v3 = phi(i, j, k+1)
                v4 = phi(i, j+1, k+1)
                v5 = phi(i, jp2, k+1)
             else
                v1 = phi(i, jp3, k+1)
                v2 = phi(i, jp2, k+1)
                v3 = phi(i, j+1, k+1)
                v4 = phi(i, j, k+1)
                v5 = phi(i, jm1, k+1)
             endif

             dfy(i, j, k) = WENO5(v1, v2, v3, v4, v5)

          enddo
       enddo
    enddo
    !$omp end do

    !$omp do
    do k = 0, n-1
       do j = sy, ey
          do i = sx, ex

             if((k.ge.3).and.(k.le.(n-3)))then

                if(w(i, j, k).ge.0)then
                   v1 = phi(i, j+1, k-2)
                   v2 = phi(i, j+1, k-1)
                   v3 = phi(i, j+1, k)
                   v4 = phi(i, j+1, k+1)
                   v5 = phi(i, j+1, k+2)
                else
                   v1 = phi(i, j+1, k+3)
                   v2 = phi(i, j+1, k+2)
                   v3 = phi(i, j+1, k+1)
                   v4 = phi(i, j+1, k)
                   v5 = phi(i, j+1, k-1)
                endif

                dfz(i, j, k) = WENO5(v1, v2, v3, v4, v5)

             else

                dfz(i, j, k) = (phi(i, j+1, k)+phi(i, j+1, k+1))/2.d0

             endif

          enddo
       enddo
    enddo
    !$omp end do

    !$omp end parallel

    return
  end subroutine WENOAppoxConvection

  function WENO5(v1, v2, v3, v4, v5)

    implicit none

    ! Arguments
    double precision :: WENO5
    double precision :: v1, v2, v3, v4, v5

    ! Local variables
    double precision, parameter :: epslon = 1.e-7
    double precision :: t1, t2, t3
    double precision :: s1, s2, s3
    double precision :: w1, w2, w3
    double precision :: a1, a2, a3

    t1 = v1 - 2.d0*v2 + v3
    t2 = v1 - 4.d0*v2 + 3.d0*v3
    s1 = 13.d0/12.d0*t1*t1 + 0.25d0*t2*t2

    t1 = v2 - 2.d0*v3 + v4
    t2 = v2 - v4
    s2 = 13.d0/12.d0*t1*t1 + 0.25d0*t2*t2

    t1 = v3 - 2.d0*v4 + v5
    t2 = 3.d0*v3 - 4.d0*v4 + v5
    s3 = 13.d0/12.d0*t1*t1 + 0.25d0*t2*t2

    a1 = 0.1d0/(epslon+s1)**2
    a2 = 0.6d0/(epslon+s2)**2
    a3 = 0.3d0/(epslon+s3)**2
    w1 = a1/(a1+a2+a3)
    w2 = a2/(a1+a2+a3)
    w3 = a3/(a1+a2+a3)

    t1 = v1/3.d0 - 7.d0*v2/6.d0 + 11.d0*v3/6.d0
    t2 = -v2/6.d0 + 5.d0*v3/6.d0 + v4/3.d0
    t3 = v3/3.d0 + 5.d0*v4/6.d0 - v5/6.d0

    WENO5 = w1*t1 + w2*t2 + w3*t3

  end function WENO5

end module weno


************************************************************************
*
*     Subroutine AMLPVAL                   Called by: AMLSTAT, AMLSTAT2
*
*     calculate P-values corresponding to AMLE parameter estimates
*
*     based on Tim Cohn's code, obtained from www.timcohn.com
*     (Software; Tobit) Nov. 27, 2001.
*
*     local vars
*     ----------
*     ITEST    flag indicating which AMLE param. estimate PVAL is for
*     XLIKEP   log-likelihood function for AMLE parameter estimate
*
************************************************************************
      SUBROUTINE AMLPVAL(CENSFLAG,LDOUT,NOBSC,NOBSCI,NPAR,PVAL,XLCAL,
     &                   XLIKE,YD,YLCAL)
*
*     dimensional parameters
*
      INCLUDE 'fmodules.inc'
*
*     subroutine arguments
*
      LOGICAL CENSFLAG(*)
      INTEGER*4 LDOUT,NOBSC,NOBSCI,NPAR
      DOUBLE PRECISION XLIKE,PVAL(*),YD(*),YLCAL(*),XLCAL(NOBSCI,*)
*
*     local vars
*
      INTEGER*4 I,K,ITEST(MAXPARMS)
      DOUBLE PRECISION XLIKEP(MAXPARMS)
*
*     function declaration
*
      DOUBLE PRECISION PVALUE
*
*     get likel. ratio test P-values corresponding to parameter
*     estimates
*
      DO 20 K=1,NPAR
         DO 10 I=1,NPAR
            ITEST(I) = 0
 10      CONTINUE
         ITEST(K) = 1
         CALL TACIT_TEST(CENSFLAG,ITEST,NOBSC,NPAR,XLCAL,XLIKEP(K),YD,
     &                   YLCAL,NOBSCI)
         PVAL(K) = PVALUE(XLIKEP(K),XLIKE,LDOUT)
 20   CONTINUE

      RETURN
      END


/* Examples for testing */

 lambda X. lambda x:X. x;
 (lambda X. lambda x:X. x) [All X.X->X];

lambda x:Top. x;
 (lambda x:Top. x) (lambda x:Top. x);
(lambda x:Top->Top. x) (lambda x:Top. x);

lambda X<:Top->Top. lambda x:X. x x;


      program tester

          use DiscreteSampler
          use StringCast
          real*8 jac, to_test
          REAL*8 integral_target, computed_int, variance
          integer i,j
          integer pts_per_it(4), pts
          data pts_per_it/30,100000,10000,100000/
          real*8 avg_acc
          real*8 this_acc
          real*8 mvariance

          mvariance=0.0d0
          do i=1,10
            mvariance = mvariance + (1.0/12.0)*to_test(i,.True.)**2
          enddo

          integral_target = 0.0d0
          do i=1,10
            integral_target = integral_target + to_test(i,.True.)
          enddo
          call DS_register_dimension('TestDim',10)
          avg_acc = 0.0d0
          call DS_set_min_points(2)
          do i=1,10
            call DS_add_entry('conv',i,1.0d0)
          enddo
          call DS_add_entry('conv',7,70.0d0,reset=.True.)
          do j=1,1
            if(j.le.size(pts_per_it)) then
              pts = pts_per_it(j)
            else
              pts = 100000
            endif
c            write(*,*) 'Grid before iteration'
c            call DS_print_global_info()
            call approx(pts,computed_int,'norm')
            write(*,*) '=== ITERATION #'//trim(toStr(j))//' with '//
     & trim(toStr(pts))//' points.'
            write(*,*) 'exact integral is :',integral_target
            write(*,*) 'computed integral :',computed_int
            this_acc = abs(integral_target-computed_int)/
     &                                               integral_target
            avg_acc = (avg_acc*float(j-1)+this_acc)/float(j)
            write(*,*) 'relative diff (%) :   ',
     &       trim(toStr(this_acc*100.0d0,'Fw.3'))
            write(*,*) 'avg rel. diff (%) :   ',
     &       trim(toStr(avg_acc*100.0d0,'Fw.3'))
            write(*,*) 'Grid before update'
            call DS_print_global_info()
            call DS_update_grid('TestDim')
c            write(*,*) 'Grid after update'
c            call DS_print_global_info('TestDim')
          enddo
          call DS_write_grid('rrrr.dsg','TestDim')
          call DS_load_grid('rrrr.dsg','TestDim')
          call DS_print_global_info()
      end program tester

      subroutine approx(n_trials,res,mode)
          use DiscreteSampler
         integer n_trials
         character(len=*) mode
         real*8 res, to_test, computed_int, jac, func
         REAL*8 r(1)
         integer picked,i
          computed_int = 0.0d0
          do i=1,n_trials
            CALL RANDOM_NUMBER(r)
            call DS_get_point('TestDim',r(1),picked,jac,
     &      mode)
c     &      ,(/'conv'/))
            write(*,*) 'Picked:',picked
            func = to_test(picked,.false.)
            computed_int = (computed_int*float(i-1)
     &       + func*jac)/float(i)
            call DS_add_entry('TestDim',picked,func)
          enddo
          res = computed_int

      end subroutine approx

      function to_test(sector,exact)
          integer sector
          real*8 r(1), to_test
          real*8 values(10)
          logical           exact
          data values/1.0d0, 2.0d0, -34.0d0, 3.0d0, 4.0d0,
     &    5.0d0, 2.0d0, 3.0d0, 1.0d0, 2.5d0/

          ! When using the function below, one recovers exact result
          ! with as little as one point using the updated grid
          if (exact) then
            to_test = values(sector)
          else
            CALL RANDOM_NUMBER(r)
            ! This simulates a convergence process
            to_test = (values(sector)*(1.0d0))*(0.5+r(1))
          endif
          return

      end function to_test


MODULE kinetic_module

  use kinetic_variables
  use kinetic_sol_module
  use kinetic_mol_module
  use fd_module

  implicit none

  PRIVATE
  PUBLIC :: init_kinetic, op_kinetic &
           ,read_kinetic, read_oldformat_kinetic &
           ,SYStype

!  integer :: SYStype=0

CONTAINS

  SUBROUTINE init_kinetic( aa, bb, MBZ, kbb, Hgrid, Igrid, MBD, disp_switch )
    implicit none
    real(8),intent(IN) :: aa(3,3),bb(3,3)
    integer,intent(IN) :: MBZ
    real(8),intent(IN) :: kbb(3,MBZ)
    real(8),optional,intent(IN) :: Hgrid(3)
    integer,optional,intent(IN) :: Igrid(2,0:3),MBD
    logical,optional,intent(IN) :: disp_switch
    integer :: m,n,k,is,i
    real(8) :: c1,c2,c3,kx,ky,kz,pi2
    real(8) :: a1,a2,a3,H1,H2,H3
    complex(8),parameter :: zi=(0.d0,1.d0)
    real(8),allocatable :: nab(:),lap(:)
    logical :: first_time = .true.
    logical :: disp_sw

    call write_border( 80, " init_kinetic(start)" )

    pi2 = 2.d0*acos(-1.d0)
    a1  = sqrt(sum(aa(1:3,1)**2))/pi2
    a2  = sqrt(sum(aa(1:3,2)**2))/pi2
    a3  = sqrt(sum(aa(1:3,3)**2))/pi2

    disp_sw=.false.
    if ( present(disp_switch) ) disp_sw=disp_switch

    if ( first_time ) then

       first_time = .false.

       allocate( coef_lap(3,Md) ) ; coef_lap=0.0d0
       allocate( coef_nab(3,Md) ) ; coef_nab=0.0d0

       allocate( lap(-Md:Md) ) ; lap=0.d0
       allocate( nab(-Md:Md) ) ; nab=0.d0

       call get_coef_lapla_fd(Md,lap)
       call get_coef_nabla_fd(Md,nab)

       if ( disp_switch ) then
          do i=0,Md
             write(*,'(1x,2f12.8,2x,2f12.8)') lap(i),lap(-i),nab(i),nab(-i)
          end do
       end if

       call get_ggg_kinetic(aa,bb,ggg)

       if ( disp_sw ) write(*,'(1x,"ggg=",6f10.5)') ggg

       flag_n12 = .false.
       flag_n23 = .false.
       flag_n31 = .false.
       if ( ggg(4) /= 0.d0 ) flag_n12 = .true.
       if ( ggg(5) /= 0.d0 ) flag_n23 = .true.
       if ( ggg(6) /= 0.d0 ) flag_n31 = .true.

       H1 = Hgrid(1)
       H2 = Hgrid(2)
       H3 = Hgrid(3)

       c1 = -0.5d0*ggg(1)/H1**2
       c2 = -0.5d0*ggg(2)/H2**2
       c3 = -0.5d0*ggg(3)/H3**2

       coef_lap0 = lap(0)*(c1+c2+c3)
       do n=1,Md
          coef_lap(1,n)=lap(n)*c1
          coef_lap(2,n)=lap(n)*c2
          coef_lap(3,n)=lap(n)*c3
       end do

       do n=1,Md
          coef_nab(1,n)=nab(n)/H1
          coef_nab(2,n)=nab(n)/H2
          coef_nab(3,n)=nab(n)/H3
       end do

       if ( disp_sw ) then
          write(*,'(1x,3x,3x,a20,3x,a20)') "lap","coef_lap"
          write(*,'(1x,i3,3x,f20.15,3x,f20.15)') 0,lap(0),coef_lap0
          do n=1,Md
             write(*,'(1x,i3,3x,f20.15,3x,3f20.15)') n,lap(n),coef_lap(1:3,n)
          end do
          write(*,'(1x,3x,3x,a20,3x,a20)') "nab","coef_nab"
          do n=1,Md
             write(*,'(1x,i3,3x,f20.15,3x,3f20.15)') n,nab(n),coef_nab(1:3,n)
          end do
       end if

       deallocate( nab,lap )

       call allocate_wk( Igrid, MBD )

       allocate( coef_kin(Md) ) ; coef_kin=0.0d0
       coef_kin(1:Md) = coef_lap(1,1:Md)

    end if ! first_time

! -- k-dependent coefficient --

    if ( allocated(const_k2)  ) deallocate( const_k2  )
    if ( allocated(zcoef_kin) ) deallocate( zcoef_kin )
    if ( allocated(coef_nabk) ) deallocate( coef_nabk )
    allocate( coef_nabk(3,Md,MBZ)     ) ; coef_nabk=0.0d0
    allocate( zcoef_kin(3,-Md:Md,MBZ) ) ; zcoef_kin=(0.0d0,0.0d0)
    allocate( const_k2(0:MBZ)         ) ; const_k2=0.d0

    flag_nab = .false.
    do k=1,MBZ
       kx=bb(1,1)*kbb(1,k)+bb(1,2)*kbb(2,k)+bb(1,3)*kbb(3,k)
       ky=bb(2,1)*kbb(1,k)+bb(2,2)*kbb(2,k)+bb(2,3)*kbb(3,k)
       kz=bb(3,1)*kbb(1,k)+bb(3,2)*kbb(2,k)+bb(3,3)*kbb(3,k)
       c1=a1*( bb(1,1)*kx+bb(2,1)*ky+bb(3,1)*kz )
       c2=a2*( bb(1,2)*kx+bb(2,2)*ky+bb(3,2)*kz )
       c3=a3*( bb(1,3)*kx+bb(2,3)*ky+bb(3,3)*kz )
       if ( c1/=0.d0 .or. c2/=0.d0 .or. c3/=0.d0 ) flag_nab=.true.
       do n=1,Md
          coef_nabk(1,n,k)=coef_nab(1,n)*c1
          coef_nabk(2,n,k)=coef_nab(2,n)*c2
          coef_nabk(3,n,k)=coef_nab(3,n)*c3
       end do
       const_k2(k) = 0.5d0*( kx*kx + ky*ky + kz*kz )
    end do

    do k=1,MBZ
       do n=1,Md
          zcoef_kin(1:3,-n,k)=coef_lap(1:3,n)+zi*coef_nabk(1:3,n,k)
          zcoef_kin(1:3, n,k)=coef_lap(1:3,n)-zi*coef_nabk(1:3,n,k)
       end do
    end do

    call write_border( 80, " init_kinetic(end)" )

  END SUBROUTINE init_kinetic

  SUBROUTINE allocate_wk( Igrid, MBD )
    implicit none
    integer,intent(IN) :: Igrid(2,0:3),MBD
    integer :: a1,a2,a3,b1,b2,b3,nb
    a1=Igrid(1,1)-Md ; b1=Igrid(2,1)+Md
    a2=Igrid(1,2)-Md ; b2=Igrid(2,2)+Md
    a3=Igrid(1,3)-Md ; b3=Igrid(2,3)+Md
    allocate( wk(a1:b1,a2:b2,a3:b3,MBD) )
    wk=(0.0d0,0.0d0)
  END SUBROUTINE allocate_wk

  SUBROUTINE get_ggg_kinetic(aa,bb,ggg)
    implicit none
    real(8),intent(IN)  :: aa(3,3),bb(3,3)
    real(8),intent(OUT) :: ggg(6)
    real(8) :: const,a1,a2,a3
    const=1.d0/(4.d0*acos(-1.d0)**2)
    a1 = sqrt( sum( aa(:,1)**2 ) )
    a2 = sqrt( sum( aa(:,2)**2 ) )
    a3 = sqrt( sum( aa(:,3)**2 ) )
    ggg(1) = a1*a1*sum(bb(:,1)*bb(:,1))*const
    ggg(2) = a2*a2*sum(bb(:,2)*bb(:,2))*const
    ggg(3) = a3*a3*sum(bb(:,3)*bb(:,3))*const
    ggg(4) = a1*a2*sum(bb(:,1)*bb(:,2))*const
    ggg(5) = a2*a3*sum(bb(:,2)*bb(:,3))*const
    ggg(6) = a3*a1*sum(bb(:,3)*bb(:,1))*const
  END SUBROUTINE get_ggg_kinetic

  SUBROUTINE op_kinetic(k,tpsi,htpsi,n1,n2,ib1,ib2)
    implicit none
    integer,intent(IN) :: k,n1,n2,ib1,ib2
#ifdef _DRSDFT_
    real(8),intent(IN)  :: tpsi(n1:n2,ib1:ib2)
    real(8),intent(INOUT) :: htpsi(n1:n2,ib1:ib2)
#else
    complex(8),intent(IN)  :: tpsi(n1:n2,ib1:ib2)
    complex(8),intent(INOUT) :: htpsi(n1:n2,ib1:ib2)
#endif
    select case(SYStype)
    case default
       call op_kinetic_sol(k,tpsi,htpsi,n1,n2,ib1,ib2)
    case(1)
       call op_kinetic_mol(n1,n2,ib1,ib2,tpsi,htpsi)
    end select
  END SUBROUTINE op_kinetic

END MODULE kinetic_module