!-------------------------------------------------------------------------------
! Copyright (c) 2019 FrontISTR Commons
! This software is released under the MIT License, see LICENSE.txt
!-------------------------------------------------------------------------------
!> \brief  This module contains several strategy to free locking problem
!> in Eight-node hexagonal element
module m_static_LIB_C3D8

  use hecmw, only : kint, kreal
  use elementInfo

  implicit none

contains

  !>  This subroutine calculate stiff matrix using b-bar method
  !>
  !> \see Hughes, T. J. "Generalization of Selective Integration Procedures
  !>  to Anisotropic and Nonlinear Media", Intl. J. Numer. Methods Engng, 15,
  !>  pp1413-1418,1980
  !----------------------------------------------------------------------*
  subroutine STF_C3D8Bbar &
      (etype, nn, ecoord, gausses, stiff, cdsys_ID, coords, &
      time, tincr, u, temperature)
    !----------------------------------------------------------------------*

    use mMechGauss
    use m_MatMatrix
    use m_common_struct
    use m_static_LIB_3d, only: GEOMAT_C3

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

    integer(kind=kint), intent(in)  :: etype                  !< element type
    integer(kind=kint), intent(in)  :: nn                     !< number of elemental nodes
    real(kind=kreal), intent(in)    :: ecoord(3, nn)          !< coordinates of elemental nodes
    type(tGaussStatus), intent(in)  :: gausses(:)             !< status of qudrature points
    real(kind=kreal), intent(out)   :: stiff(:,:)             !< stiff matrix
    integer(kind=kint), intent(in)  :: cdsys_ID
    real(kind=kreal), intent(inout) :: coords(3, 3)           !< variables to define matreial coordinate system
    real(kind=kreal), intent(in)    :: time                   !< current time
    real(kind=kreal), intent(in)    :: tincr                  !< time increment
    real(kind=kreal), intent(in), optional :: u(:, :)         !< nodal displacemwent
    real(kind=kreal), intent(in), optional :: temperature(nn) !< temperature

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

    integer(kind=kint) :: flag
    integer(kind=kint), parameter :: ndof = 3
    real(kind=kreal) :: D(6, 6),B(6, ndof*nn),DB(6, ndof*nn)
    real(kind=kreal) :: gderiv(nn, 3),stress(6),mat(6, 6)
    real(kind=kreal) :: det, wg, temp, spfunc(nn)
    integer(kind=kint) :: i, j, LX, serr
    real(kind=kreal) :: naturalCoord(3)
    real(kind=kreal) :: gdispderiv(3, 3)
    real(kind=kreal) :: B1(6, ndof*nn), Bbar(nn, 3)
    real(kind=kreal) :: Smat(9, 9), elem(3, nn)
    real(kind=kreal) :: BN(9, ndof*nn), SBN(9, ndof*nn)
    real(kind=kreal) :: B4, B6, B8, coordsys(3, 3)

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

    stiff(:, :) = 0.0D0
    ! we suppose the same material type in the element
    flag = gausses(1)%pMaterial%nlgeom_flag
    if( .not. present(u) ) flag = INFINITESIMAL    ! enforce to infinitesimal deformation analysis
    elem(:, :) = ecoord(:, :)
    if( flag == UPDATELAG ) elem(:, :) = ecoord(:, :)+u(:, :)

    ! dilatation component at centroid
    naturalCoord = 0.0D0
    call getGlobalDeriv(etype, nn, naturalcoord, elem, det, Bbar)

    do LX = 1, NumOfQuadPoints(etype)

      call getQuadPoint( etype, LX, naturalCoord(:) )
      call getGlobalDeriv(etype, nn, naturalcoord, elem, det, gderiv)

      if( cdsys_ID > 0 ) then
        call set_localcoordsys( coords, g_LocalCoordSys(cdsys_ID), coordsys(:, :), serr )
        if( serr == -1 ) stop "Fail to setup local coordinate"
        if( serr == -2 ) then
          write(*, *) "WARNING! Cannot setup local coordinate, it is modified automatically"
        end if
      end if

      if( present(temperature) ) then
        call getShapeFunc( etype, naturalcoord, spfunc )
        temp = dot_product( temperature, spfunc )
        call MatlMatrix( gausses(LX), D3, D, time, tincr, coordsys, temp )
      else
        call MatlMatrix( gausses(LX), D3, D, time, tincr, coordsys )
      end if

      if( flag == UPDATELAG ) then
        call GEOMAT_C3( gausses(LX)%stress, mat )
        D(:, :) = D(:, :)-mat
      endif

      wg = getWeight(etype, LX)*det
      B(1:6, 1:nn*ndof) = 0.0D0
      do j = 1, nn
        B4 = ( Bbar(j, 1)-gderiv(j, 1) )/3.0D0
        B6 = ( Bbar(j, 2)-gderiv(j, 2) )/3.0D0
        B8 = ( Bbar(j, 3)-gderiv(j, 3) )/3.0D0
        B(1, 3*j-2) = gderiv(j, 1)+B4
        B(1, 3*j-1) = B6
        B(1, 3*j  ) = B8

        B(2, 3*j-2) = B4
        B(2, 3*j-1) = gderiv(j, 2)+B6
        B(2, 3*j  ) = B8

        B(3, 3*j-2) = B4
        B(3, 3*j-1) = B6
        B(3, 3*j  ) = gderiv(j, 3)+B8

        B(4, 3*j-2) = gderiv(j, 2)
        B(4, 3*j-1) = gderiv(j, 1)
        B(5, 3*j-1) = gderiv(j, 3)
        B(5, 3*j  ) = gderiv(j, 2)
        B(6, 3*j-2) = gderiv(j, 3)
        B(6, 3*j  ) = gderiv(j, 1)
      end do

      ! calculate the BL1 matrix ( TOTAL LAGRANGE METHOD )
      if( flag == TOTALLAG ) then
        ! ---dudx(i,j) ==> gdispderiv(i,j)
        gdispderiv(1:ndof, 1:ndof) = matmul( u(1:ndof, 1:nn), gderiv(1:nn, 1:ndof) )
        B1(1:6, 1:nn*ndof) = 0.0D0
        do j = 1, nn
          B1(1, 3*J-2) = gdispderiv(1, 1)*gderiv(J, 1)
          B1(1, 3*J-1) = gdispderiv(2, 1)*gderiv(J, 1)
          B1(1, 3*J  ) = gdispderiv(3, 1)*gderiv(J, 1)
          B1(2, 3*J-2) = gdispderiv(1, 2)*gderiv(J, 2)
          B1(2, 3*J-1) = gdispderiv(2, 2)*gderiv(J, 2)
          B1(2, 3*J  ) = gdispderiv(3, 2)*gderiv(J, 2)
          B1(3, 3*J-2) = gdispderiv(1, 3)*gderiv(J, 3)
          B1(3, 3*J-1) = gdispderiv(2, 3)*gderiv(J, 3)
          B1(3, 3*J  ) = gdispderiv(3, 3)*gderiv(J, 3)
          B1(4, 3*j-2) = gdispderiv(1, 2)*gderiv(j, 1)+gdispderiv(1, 1)*gderiv(j, 2)
          B1(4, 3*j-1) = gdispderiv(2, 2)*gderiv(j, 1)+gdispderiv(2, 1)*gderiv(j, 2)
          B1(4, 3*j  ) = gdispderiv(3, 2)*gderiv(j, 1)+gdispderiv(3, 1)*gderiv(j, 2)
          B1(5, 3*j-2) = gdispderiv(1, 2)*gderiv(j, 3)+gdispderiv(1, 3)*gderiv(j, 2)
          B1(5, 3*j-1) = gdispderiv(2, 2)*gderiv(j, 3)+gdispderiv(2, 3)*gderiv(j, 2)
          B1(5, 3*j  ) = gdispderiv(3, 2)*gderiv(j, 3)+gdispderiv(3, 3)*gderiv(j, 2)
          B1(6, 3*j-2) = gdispderiv(1, 3)*gderiv(j, 1)+gdispderiv(1, 1)*gderiv(j, 3)
          B1(6, 3*j-1) = gdispderiv(2, 3)*gderiv(j, 1)+gdispderiv(2, 1)*gderiv(j, 3)
          B1(6, 3*j  ) = gdispderiv(3, 3)*gderiv(j, 1)+gdispderiv(3, 1)*gderiv(j, 3)
        end do
        ! ---BL = BL0 + BL1
        do j = 1, nn*ndof
          B(:, j) = B(:, j)+B1(:, j)
        end do
      end if

      DB(1:6, 1:nn*ndof) = matmul( D, B(1:6, 1:nn*ndof) )
      forall( i=1:nn*ndof, j=1:nn*ndof )
        stiff(i, j) = stiff(i, j)+dot_product( B(:, i), DB(:, j) )*wg
      end forall

      ! calculate the initial stress matrix
      if( flag == TOTALLAG .or. flag == UPDATELAG ) then
        stress(1:6) = gausses(LX)%stress
        BN(1:9, 1:nn*ndof) = 0.0D0
        do j = 1, nn
          BN(1, 3*j-2) = gderiv(j, 1)
          BN(2, 3*j-1) = gderiv(j, 1)
          BN(3, 3*j  ) = gderiv(j, 1)
          BN(4, 3*j-2) = gderiv(j, 2)
          BN(5, 3*j-1) = gderiv(j, 2)
          BN(6, 3*j  ) = gderiv(j, 2)
          BN(7, 3*j-2) = gderiv(j, 3)
          BN(8, 3*j-1) = gderiv(j, 3)
          BN(9, 3*j  ) = gderiv(j, 3)
        end do
        Smat(:, :) = 0.0D0
        do j= 1, 3
          Smat(j  , j  ) = stress(1)
          Smat(j  , j+3) = stress(4)
          Smat(j  , j+6) = stress(6)
          Smat(j+3, j  ) = stress(4)
          Smat(j+3, j+3) = stress(2)
          Smat(j+3, j+6) = stress(5)
          Smat(j+6, j  ) = stress(6)
          Smat(j+6, j+3) = stress(5)
          Smat(j+6, j+6) = stress(3)
        end do
        SBN(1:9, 1:nn*ndof) = matmul( Smat(1:9, 1:9), BN(1:9, 1:nn*ndof) )
        forall( i=1:nn*ndof, j=1:nn*ndof )
          stiff(i, j) = stiff(i, j)+dot_product( BN(:, i), SBN(:, j) )*wg
        end forall
      end if

    end do ! gauss roop

  end subroutine STF_C3D8Bbar

  !>  Update Strain stress of this element
  !----------------------------------------------------------------------*
  subroutine Update_C3D8Bbar                              &
      (etype, nn, ecoord, u, du, cdsys_ID, coords, &
      qf ,gausses, iter, time, tincr, TT,T0, TN  )
    !----------------------------------------------------------------------*

    use m_fstr
    use mMaterial
    use mMechGauss
    use m_MatMatrix
    use m_ElastoPlastic
    use mHyperElastic
    use m_utilities
    use m_static_LIB_3d

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

    integer(kind=kint), intent(in)    :: etype         !< \param [in] element type
    integer(kind=kint), intent(in)    :: nn            !< \param [in] number of elemental nodes
    real(kind=kreal), intent(in)      :: ecoord(3, nn) !< \param [in] coordinates of elemental nodes
    real(kind=kreal), intent(in)      :: u(3, nn)      !< \param [in] nodal dislplacements
    real(kind=kreal), intent(in)      :: du(3, nn)     !< \param [in] nodal displacement increment
    integer(kind=kint), intent(in)    :: cdsys_ID
    real(kind=kreal), intent(inout)   :: coords(3, 3)  !< variables to define matreial coordinate system
    real(kind=kreal), intent(out)     :: qf(nn*3)      !< \param [out] Internal Force
    type(tGaussStatus), intent(inout) :: gausses(:)    !< \param [out] status of qudrature points
    integer, intent(in) :: iter
    real(kind=kreal), intent(in)      :: time          !< current time
    real(kind=kreal), intent(in)      :: tincr         !< time increment
    real(kind=kreal), intent(in), optional :: TT(nn)   !< current temperature
    real(kind=kreal), intent(in), optional :: T0(nn)   !< reference temperature
    real(kind=kreal), intent(in), optional :: TN(nn)   !< reference temperature

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

    integer(kind=kint) :: flag
    integer(kind=kint), parameter :: ndof = 3
    real(kind=kreal) :: B(6, ndof*nn), B1(6, ndof*nn)
    real(kind=kreal) :: gderiv(nn, 3), gderiv1(nn,3), gdispderiv(3, 3), F(3,3), det, det1, wg
    integer(kind=kint) :: j, LX, mtype, serr
    real(kind=kreal) :: naturalCoord(3), rot(3, 3), spfunc(nn)
    real(kind=kreal) :: totaldisp(3, nn), elem(3, nn), elem1(3, nn), coordsys(3, 3)
    real(kind=kreal) :: dstrain(6)
    real(kind=kreal) :: dvol, vol0, Bbar(nn, 3), derivdum(1:ndof, 1:ndof), BBar2(nn, 3)
    real(kind=kreal) :: B4, B6, B8, ttc, tt0, ttn, alpo(3), ina(1), EPSTH(6)
    logical :: ierr, matlaniso

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

    qf(:) = 0.0D0
    ! we suppose the same material type in the element
    flag = gausses(1)%pMaterial%nlgeom_flag
    elem(:, :) = ecoord(:, :)
    totaldisp(:, :) = u(:, :)+du(:, :)
    if( flag == UPDATELAG ) then
      elem(:, :) = ( 0.5D0*du(:, :)+u(:, :) )+ecoord(:, :)
      elem1(:, :) = ( du(:, :)+u(:, :) )+ecoord(:, :)
      !  elem = elem1
      totaldisp(:, :) = du(:, :)
    end if

    matlaniso = .FALSE.
    if( cdsys_ID > 0 .AND. present(TT) ) then
      ina = TT(1)
      call fetch_TableData( MC_ORTHOEXP, gausses(1)%pMaterial%dict, alpo(:), ierr, ina )
      if( .not. ierr ) matlaniso = .TRUE.
    end if

    ! dilatation at centroid
    naturalCoord = 0.0D0
    call getGlobalDeriv(etype, nn, naturalcoord, elem, det, Bbar)
    derivdum = matmul( totaldisp(1:ndof, 1:nn), Bbar(1:nn, 1:ndof) )
    vol0 = ( derivdum(1, 1)+derivdum(2, 2)+derivdum(3, 3) )/3.0D0
    if( flag == UPDATELAG ) call getGlobalDeriv(etype, nn, naturalcoord, elem1, det, Bbar2)

    do LX = 1, NumOfQuadPoints(etype)

      mtype = gausses(LX)%pMaterial%mtype

      call getQuadPoint( etype, LX, naturalCoord(:) )
      call getGlobalDeriv(etype, nn, naturalcoord, elem, det, gderiv)

      if( cdsys_ID > 0 ) then
        call set_localcoordsys( coords, g_LocalCoordSys(cdsys_ID), coordsys(:, :), serr )
        if( serr == -1 ) stop "Fail to setup local coordinate"
        if( serr == -2 ) then
          write(*, *) "WARNING! Cannot setup local coordinate, it is modified automatically"
        end if
      end if

      gdispderiv(1:ndof, 1:ndof) = matmul( totaldisp(1:ndof, 1:nn), gderiv(1:nn, 1:ndof) )
      dvol = vol0-( gdispderiv(1, 1)+gdispderiv(2, 2)+gdispderiv(3, 3) )/3.0D0
      !gdispderiv(1, 1) = gdispderiv(1, 1)+dvol
      !gdispderiv(2, 2) = gdispderiv(2, 2)+dvol
      !gdispderiv(3, 3) = gdispderiv(3, 3)+dvol

      ! ========================================================
      !     UPDATE STRAIN and STRESS
      ! ========================================================

      ! Thermal Strain
      EPSTH = 0.0D0
      if( present(tt) .AND. present(t0) ) then
        call getShapeFunc(etype, naturalcoord, spfunc)
        ttc = dot_product(TT, spfunc)
        tt0 = dot_product(T0, spfunc)
        ttn = dot_product(TN, spfunc)
        call Cal_Thermal_expansion_C3( tt0, ttc, gausses(LX)%pMaterial, coordsys, matlaniso, EPSTH )
      end if

      ! Update strain
      ! Small strain
      dstrain(1) = gdispderiv(1, 1)+dvol
      dstrain(2) = gdispderiv(2, 2)+dvol
      dstrain(3) = gdispderiv(3, 3)+dvol
      dstrain(4) = ( gdispderiv(1, 2)+gdispderiv(2, 1) )
      dstrain(5) = ( gdispderiv(2, 3)+gdispderiv(3, 2) )
      dstrain(6) = ( gdispderiv(3, 1)+gdispderiv(1, 3) )
      dstrain(:) = dstrain(:)-EPSTH(:)

      F(1:3,1:3) = 0.d0; F(1,1)=1.d0; F(2,2)=1.d0; F(3,3)=1.d0; !deformation gradient
      if( flag == INFINITESIMAL ) then
        gausses(LX)%strain(1:6) = dstrain(1:6)+EPSTH(:)

      else if( flag == TOTALLAG ) then
        ! Green-Lagrange strain
        dstrain(1) = dstrain(1)+0.5D0*dot_product( gdispderiv(:, 1), gdispderiv(:, 1) )
        dstrain(2) = dstrain(2)+0.5D0*dot_product( gdispderiv(:, 2), gdispderiv(:, 2) )
        dstrain(3) = dstrain(3)+0.5D0*dot_product( gdispderiv(:, 3), gdispderiv(:, 3) )
        dstrain(4) = dstrain(4)+( gdispderiv(1, 1)*gdispderiv(1, 2)                                     &
          +gdispderiv(2, 1)*gdispderiv(2, 2)+gdispderiv(3, 1)*gdispderiv(3, 2) )
        dstrain(5) = dstrain(5)+( gdispderiv(1, 2)*gdispderiv(1, 3)                                     &
          +gdispderiv(2, 2)*gdispderiv(2, 3)+gdispderiv(3, 2)*gdispderiv(3, 3) )
        dstrain(6) = dstrain(6)+( gdispderiv(1, 1)*gdispderiv(1, 3)                                     &
          +gdispderiv(2, 1)*gdispderiv(2, 3)+gdispderiv(3, 1)*gdispderiv(3, 3) )

        gausses(LX)%strain(1:6) = dstrain(1:6)+EPSTH(:)
        F(1:3,1:3) = F(1:3,1:3) + gdispderiv(1:3,1:3)

      else if( flag == UPDATELAG ) then
        rot = 0.0D0
        rot(1, 2)= 0.5D0*( gdispderiv(1, 2)-gdispderiv(2, 1) );  rot(2, 1) = -rot(1, 2)
        rot(2, 3)= 0.5D0*( gdispderiv(2, 3)-gdispderiv(3, 2) );  rot(3, 2) = -rot(2, 3)
        rot(1, 3)= 0.5D0*( gdispderiv(1, 3)-gdispderiv(3, 1) );  rot(3, 1) = -rot(1, 3)

        gausses(LX)%strain(1:6) = gausses(LX)%strain_bak(1:6)+dstrain(1:6)+EPSTH(:)
        call getGlobalDeriv(etype, nn, naturalcoord, ecoord, det1, gderiv1)
        F(1:3,1:3) = F(1:3,1:3) + matmul( u(1:ndof, 1:nn)+du(1:ndof, 1:nn), gderiv1(1:nn, 1:ndof) )

      end if

      ! Update stress
      if( present(tt) .AND. present(t0) ) then
        call Update_Stress3D( flag, gausses(LX), rot, dstrain, F, coordsys, time, tincr, ttc, tt0, ttn )
      else
        call Update_Stress3D( flag, gausses(LX), rot, dstrain, F, coordsys, time, tincr )
      end if

      ! ========================================================
      ! calculate the internal force ( equivalent nodal force )
      ! ========================================================
      ! Small strain
      B(1:6, 1:nn*ndof) = 0.0D0
      do j = 1, nn
        B4 = ( Bbar(j, 1)-gderiv(j, 1) )/3.0D0
        B6 = ( Bbar(j, 2)-gderiv(j, 2) )/3.0D0
        B8 = ( Bbar(j, 3)-gderiv(j, 3) )/3.0D0
        B(1, 3*j-2) = gderiv(j, 1)+B4
        B(1, 3*j-1) = B6
        B(1, 3*j  ) = B8

        B(2, 3*j-2) = B4
        B(2, 3*j-1) = gderiv(j, 2)+B6
        B(2, 3*j  ) = B8

        B(3, 3*j-2) = B4
        B(3, 3*j-1) = B6
        B(3, 3*j  ) = gderiv(j, 3)+B8

        B(4, 3*j-2) = gderiv(j, 2)
        B(4, 3*j-1) = gderiv(j, 1)
        B(5, 3*j-1) = gderiv(j, 3)
        B(5, 3*j  ) = gderiv(j, 2)
        B(6, 3*j-2) = gderiv(j, 3)
        B(6, 3*j  ) = gderiv(j, 1)
      end do

      if( flag == INFINITESIMAL ) then

      else if( flag == TOTALLAG ) then

        B1(1:6, 1:nn*ndof) = 0.0D0
        do j = 1, nn
          B1(1, 3*J-2) = gdispderiv(1, 1)*gderiv(J, 1)
          B1(1, 3*J-1) = gdispderiv(2, 1)*gderiv(J, 1)
          B1(1, 3*J  ) = gdispderiv(3, 1)*gderiv(J, 1)
          B1(2, 3*J-2) = gdispderiv(1, 2)*gderiv(J, 2)
          B1(2, 3*J-1) = gdispderiv(2, 2)*gderiv(J, 2)
          B1(2, 3*J  ) = gdispderiv(3, 2)*gderiv(J, 2)
          B1(3, 3*J-2) = gdispderiv(1, 3)*gderiv(J, 3)
          B1(3, 3*J-1) = gdispderiv(2, 3)*gderiv(J, 3)
          B1(3, 3*J  ) = gdispderiv(3, 3)*gderiv(J, 3)
          B1(4, 3*j-2) = gdispderiv(1, 2)*gderiv(j, 1)+gdispderiv(1, 1)*gderiv(j, 2)
          B1(4, 3*j-1) = gdispderiv(2, 2)*gderiv(j, 1)+gdispderiv(2, 1)*gderiv(j, 2)
          B1(4, 3*j  ) = gdispderiv(3, 2)*gderiv(j, 1)+gdispderiv(3, 1)*gderiv(j, 2)
          B1(5, 3*j-2) = gdispderiv(1, 2)*gderiv(j, 3)+gdispderiv(1, 3)*gderiv(j, 2)
          B1(5, 3*j-1) = gdispderiv(2, 2)*gderiv(j, 3)+gdispderiv(2, 3)*gderiv(j, 2)
          B1(5, 3*j  ) = gdispderiv(3, 2)*gderiv(j, 3)+gdispderiv(3, 3)*gderiv(j, 2)
          B1(6, 3*j-2) = gdispderiv(1, 3)*gderiv(j, 1)+gdispderiv(1, 1)*gderiv(j, 3)
          B1(6, 3*j-1) = gdispderiv(2, 3)*gderiv(j, 1)+gdispderiv(2, 1)*gderiv(j, 3)
          B1(6, 3*j  ) = gdispderiv(3, 3)*gderiv(j, 1)+gdispderiv(3, 1)*gderiv(j, 3)
        end do
        ! BL = BL0 + BL1
        do j = 1, nn*ndof
          B(:, j) = B(:, j)+B1(:, j)
        end do

      else if( flag == UPDATELAG ) then

        call getGlobalDeriv(etype, nn, naturalcoord, elem1, det, gderiv)
        B(1:6, 1:nn*ndof) = 0.0D0
        do j = 1, nn
          B4 = ( Bbar2(j, 1)-gderiv(j, 1) )/3.0D0
          B6 = ( Bbar2(j, 2)-gderiv(j, 2) )/3.0D0
          B8 = ( Bbar2(j, 3)-gderiv(j, 3) )/3.0D0
          B(1, 3*j-2) = gderiv(j, 1)+B4
          B(1, 3*j-1) = B6
          B(1, 3*j  ) = B8

          B(2, 3*j-2) = B4
          B(2, 3*j-1) = gderiv(j, 2)+B6
          B(2, 3*j  ) = B8

          B(3, 3*j-2) = B4
          B(3, 3*j-1) = B6
          B(3, 3*j  ) = gderiv(j, 3)+B8

          B(4, 3*j-2) = gderiv(j, 2)
          B(4, 3*j-1) = gderiv(j, 1)
          B(5, 3*j-1) = gderiv(j, 3)
          B(5, 3*j  ) = gderiv(j, 2)
          B(6, 3*j-2) = gderiv(j, 3)
          B(6, 3*j  ) = gderiv(j, 1)
        end do
      end if

      !!  calculate the Internal Force
      wg = getWeight(etype, LX)*det
      qf(1:nn*ndof) = qf(1:nn*ndof)                                           &
        +matmul( gausses(LX)%stress(1:6), B(1:6, 1:nn*ndof) )*wg

    end do

  end subroutine Update_C3D8Bbar

  !> This subroutien calculate thermal loading
  !----------------------------------------------------------------------*
  subroutine TLOAD_C3D8Bbar                    &
      (etype, nn, XX, YY, ZZ, TT, T0,   &
      gausses, VECT, cdsys_ID, coords)
    !----------------------------------------------------------------------*

    use m_fstr
    use mMechGauss
    use m_MatMatrix
    use m_utilities

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

    integer(kind=kint), parameter   :: ndof = 3
    integer(kind=kint), intent(in)  :: etype, nn
    type(tGaussStatus), intent(in)  :: gausses(:)             !< status of qudrature points
    real(kind=kreal), intent(in)    :: XX(nn), YY(nn), ZZ(nn)
    real(kind=kreal), intent(in)    :: TT(nn), T0(nn)
    real(kind=kreal), intent(out)   :: VECT(nn*ndof)
    integer(kind=kint), intent(in)  :: cdsys_ID
    real(kind=kreal), intent(inout) :: coords(3, 3)           !< variables to define matreial coordinate system

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

    real(kind=kreal) :: ALP, alp0, D(6, 6), B(6, ndof*nn)
    real(kind=kreal) :: B4, B6, B8, det, ecoord(3, nn)
    integer(kind=kint) :: j, LX, serr
    real(kind=kreal) :: estrain(6), SGM(6), H(nn)
    real(kind=kreal) :: naturalcoord(3), gderiv(nn, 3)
    real(kind=kreal) :: wg, outa(1), ina(1), Bbar(nn, 3), alpo(3), alpo0(3), coordsys(3, 3)
    real(kind=kreal) :: TEMPC, TEMP0, TEMPC0, TEMP00, THERMAL_EPS, tm(6,6)
    logical :: ierr, matlaniso

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

    matlaniso = .FALSE.

    if( cdsys_ID > 0 ) then   ! cannot define aniso exapansion when no local coord defined
      ina = TT(1)
      call fetch_TableData( MC_ORTHOEXP, gausses(1)%pMaterial%dict, alpo(:), ierr, ina )
      if( .not. ierr ) matlaniso = .TRUE.
    end if

    VECT(:) = 0.0D0

    ecoord(1, :) = XX(:)
    ecoord(2, :) = YY(:)
    ecoord(3, :) = ZZ(:)

    naturalCoord = 0.0D0
    call getGlobalDeriv(etype, nn, naturalcoord, ecoord, det, Bbar)
    call getShapeFunc( etype, naturalcoord, H(1:nn) )
    TEMPC0 = dot_product( H(1:nn), TT(1:nn) )
    TEMP00 = dot_product( H(1:nn), T0(1:nn) )

    ! LOOP FOR INTEGRATION POINTS
    do LX = 1, NumOfQuadPoints(etype)

      call getQuadPoint( etype, LX, naturalCoord(:) )
      call getShapeFunc( etype, naturalcoord, H(1:nn) )
      call getGlobalDeriv(etype, nn, naturalcoord, ecoord, det, gderiv)

      if( matlaniso ) then
        call set_localcoordsys(coords, g_LocalCoordSys(cdsys_ID), coordsys, serr)
        if( serr == -1 ) stop "Fail to setup local coordinate"
        if( serr == -2 ) then
          write(*, *) "WARNING! Cannot setup local coordinate, it is modified automatically"
        end if
      end if

      !  WEIGHT VALUE AT GAUSSIAN POINT
      wg = getWeight(etype, LX)*det
      B(1:6, 1:nn*ndof) = 0.0D0
      do j = 1, nn
        B4 = ( Bbar(j, 1)-gderiv(j, 1) )/3.0D0
        B6 = ( Bbar(j, 2)-gderiv(j, 2) )/3.0D0
        B8 = ( Bbar(j, 3)-gderiv(j, 3) )/3.0D0
        B(1, 3*j-2) = gderiv(j, 1)+B4
        B(1, 3*j-1) = B6
        B(1, 3*j  ) = B8

        B(2, 3*j-2) = B4
        B(2, 3*j-1) = gderiv(j, 2)+B6
        B(2, 3*j  ) = B8

        B(3, 3*j-2) = B4
        B(3, 3*j-1) = B6
        B(3, 3*j  ) = gderiv(j, 3)+B8

        B(4, 3*j-2) = gderiv(j, 2)
        B(4, 3*j-1) = gderiv(j, 1)
        B(5, 3*j-1) = gderiv(j, 3)
        B(5, 3*j  ) = gderiv(j, 2)
        B(6, 3*j-2) = gderiv(j, 3)
        B(6, 3*j  ) = gderiv(j, 1)
      end do

      TEMPC = dot_product( H(1:nn),TT(1:nn) )
      TEMP0 = dot_product( H(1:nn),T0(1:nn) )

      call MatlMatrix( gausses(LX), D3, D, 1.d0, 0.0D0, coordsys, TEMPC )

      ina(1) = TEMPC
      if( matlaniso ) then
        call fetch_TableData( MC_ORTHOEXP, gausses(LX)%pMaterial%dict, alpo(:), ierr, ina )
        if( ierr ) stop "Fails in fetching orthotropic expansion coefficient!"
      else
        call fetch_TableData( MC_THEMOEXP, gausses(LX)%pMaterial%dict, outa(:), ierr, ina )
        if( ierr ) outa(1) = gausses(LX)%pMaterial%variables(M_EXAPNSION)
        alp = outa(1)
      end if
      ina(1) = TEMP0
      if( matlaniso ) then
        call fetch_TableData( MC_ORTHOEXP, gausses(LX)%pMaterial%dict, alpo0(:), ierr, ina )
        if( ierr ) stop "Fails in fetching orthotropic expansion coefficient!"
      else
        call fetch_TableData( MC_THEMOEXP, gausses(LX)%pMaterial%dict, outa(:), ierr, ina )
        if( ierr ) outa(1) = gausses(LX)%pMaterial%variables(M_EXAPNSION)
        alp0 = outa(1)
      end if

      !**
      !** THERMAL strain
      !**
      if( matlaniso ) then
        do j = 1, 3
          estrain(j) = ALPO(j)*(TEMPC0-ref_temp)-alpo0(j)*(TEMP00-ref_temp)
        end do
        estrain(4:6) = 0.0D0
        call transformation(coordsys, tm)
        estrain(:) = matmul( estrain(:), tm  )      ! to global coord
        estrain(4:6) = estrain(4:6)*2.0D0
      else
        THERMAL_EPS = ALP*(TEMPC0-ref_temp)-alp0*(TEMP00-ref_temp)
        estrain(1:3) = THERMAL_EPS
        estrain(4:6) = 0.0D0
      end if

      !**
      !** SET SGM  {s}=[D]{e}
      !**
      SGM(:) = matmul( D(:, :), estrain(:) )

      !**
      !** CALCULATE LOAD {F}=[B]T{e}
      !**
      VECT(1:nn*ndof) = VECT(1:nn*ndof)+matmul( SGM(:), B(:, :) )*wg

    end do

  end subroutine TLOAD_C3D8Bbar

end module m_static_LIB_C3D8


#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! z_unifact_singlestep
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine computes one iteration of Francis' singleshift
! algorithm on a unitary upper hessenberg matrix that is stored as a
! product of givens rotations and a complex diagonal matrix.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  VEC             LOGICAL
!                    .TRUE.: update eigenvectors
!                    .FALSE.: no eigenvectors
!
!  N               INTEGER
!                    dimension of matrix, must be >= 2
!
!  Q               REAL(8) array of dimension (3*(N-1))
!                    array of generators for givens rotations
!
!  D               REAL(8) array of dimension (2*N)
!                    array of generators for complex diagonal matrix
!
!  M               INTEGER
!                    leading dimension of Z
!
!  Z               COMPLEX(8) array of dimension (M,N)
!                    if VEC = .TRUE. updated
!                    if VEC = .FALSE. unused
!
!  ITCNT           INTEGER
!                   Contains the number of iterations since last deflation
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine z_unifact_singlestep(VEC,N,Q,D,M,Z,ITCNT)

  implicit none

  ! input variables
  logical, intent(in) :: VEC
  integer, intent(in) :: N, M
  integer, intent(inout) :: ITCNT
  real(8), intent(inout) :: Q(3*(N-1)), D(2*N)
  complex(8), intent(inout) :: Z(M,N)

  ! compute variables
  integer :: ii, ind1, ind2
  real(8) :: s1, s2, ar, ai, br, bi, nrm
  real(8) :: bulge(3), binv(3), qt(6)
  complex(8) :: shift
  complex(8) :: block(2,2), t1(2,2), t2(2,2)

  ! compute a nonzero shift
  ! random shift
  if(mod(ITCNT+1,11) == 0)then
    call random_number(s1)
    call random_number(s2)
    shift = cmplx(s1,s2,kind=8)

  ! wilkinson shift
  else

    ! set generators if N == 2
    if (N.EQ.2) then
      qt(1) = 1d0; qt(2:3) = 0d0
      qt(4:6) = Q
    ! else if N > 2
    else
      qt = Q((3*N-8):(3*N-3))
      nrm = sqrt(qt(1)**2+qt(2)**2)
      if (nrm.EQ.0d0) then
        qt(1) = 1d0; qt(2:3) = 0d0
      else
        qt(3) = 0d0; qt(1:2) = qt(1:2)/nrm
      end if
    end if

    ! get 2x2 block
    call z_unifact_2x2diagblock(.FALSE.,qt,D((2*N-3):(2*N)),block)

    ! compute eigenvalues and eigenvectors
    t1 = block
    call z_2x2array_eig(.FALSE.,t1,t1,t2,t2)

    ! choose wikinson shift
    ! complex abs does not matter here
    if(abs(block(2,2)-t1(1,1)) < abs(block(2,2)-t1(2,2)))then
      shift = t1(1,1)
    else
      shift = t1(2,2)
    end if

  end if

  ! project shift onto unit circle
  ar = dble(shift)
  ai = aimag(shift)
  call d_rot2_vec2gen(ar,ai,br,bi,nrm)
  shift = cmplx(br,bi,kind=8)

  ! set generators if N == 2
  if (N.EQ.2) then
    qt(1:3) = Q
    qt(4) = 1d0; qt(5:6) = 0d0
  ! else if N > 2
  else
    qt = Q(1:6)
  end if

  ! build bulge
  call z_unifact_buildbulge(qt,D(1:4),shift,bulge)

  ! update eigenvectors
  if (VEC) then
    t1(1,1) = cmplx(bulge(1),bulge(2),kind=8)
    t1(2,1) = cmplx(bulge(3),0d0,kind=8)
    t1(1,2) = -t1(2,1)
    t1(2,2) = conjg(t1(1,1))
    Z(:,1:2) = matmul(Z(:,1:2),t1)
  end if

  ! bulge inverse
  binv(1) = bulge(1)
  binv(2) = -bulge(2)
  binv(3) = -bulge(3)

  ! fusion at top
  call z_unifact_mergebulge(.TRUE.,Q(1:3),D(1:4),binv)

  ! bulge through diag
  call z_rot3_swapdiag(D(1:4),bulge)

  ! update eigenvectors
  if (VEC) then
    Z(:,1) = Z(:,1)*cmplx(binv(1),binv(2),kind=8)
    Z(:,2) = Z(:,2)*cmplx(binv(1),-binv(2),kind=8)
  end if

  ! update D(1:2)
  t1(1,1) = cmplx(D(1),D(2),kind=8)*cmplx(binv(1),binv(2),kind=8)
  call d_rot2_vec2gen(dble(t1(1,1)),aimag(t1(1,1)),D(1),D(2),nrm)

  ! update D(3:4)
  t1(1,1) = cmplx(D(3),D(4),kind=8)*cmplx(binv(1),-binv(2),kind=8)
  call d_rot2_vec2gen(dble(t1(1,1)),aimag(t1(1,1)),D(3),D(4),nrm)

  ! main chasing loop
  do ii=1,(N-2)

    ! set indices
    ind1 = 3*(ii-1) + 1
    ind2 = ind1+2

    ! through Q
    call z_rot3_turnover(Q(ind1:ind2),Q((ind1+3):(ind2+3)),bulge)

    ! update eigenvectors
    if (VEC) then
      t1(1,1) = cmplx(bulge(1),bulge(2),kind=8)
      t1(2,1) = cmplx(bulge(3),0d0,kind=8)
      t1(1,2) = -t1(2,1)
      t1(2,2) = conjg(t1(1,1))
      Z(:,(ii+1):(ii+2)) = matmul(Z(:,(ii+1):(ii+2)),t1)
    end if

    ! set indices
    ind1 = 2*ii + 1
    ind2 = ind1+3

    ! through diag
    call z_rot3_swapdiag(D(ind1:ind2),bulge)

  end do

  ! fusion at bottom
  call z_unifact_mergebulge(.FALSE.,Q((3*N-5):(3*N-3)),D((2*N-3):(2*N)),bulge)

end subroutine z_unifact_singlestep


  ! compute the diffusion source terms and fluxes for all the
  ! conservative equations.
  !
module diffterm_module

  implicit none

  private

  public :: pc_diffterm

contains

  subroutine pc_diffterm(lo,  hi,&
                         dmnlo, dmnhi,&
                         Q,   Qlo,   Qhi,&
                         Dx,  Dxlo,  Dxhi,&
                         mux, muxlo, muxhi,&
                         xix, xixlo, xixhi,&
                         lamx,lamxlo,lamxhi,&
                         Ax,  Axlo,  Axhi,&
                         fx,  fxlo,  fxhi,&
                         V,   Vlo,   Vhi,&
                         D,   Dlo,   Dhi,&
                         deltax) bind(C, name = "pc_diffterm")

    use actual_network, only     : nspec
    use meth_params_module, only : NVAR, UMX, UEDEN, UFS, QVAR, QU, QPRES, QTEMP, QFS, QRHO
    use amrex_constants_module
    use eos_type_module
    use eos_module

    implicit none

    integer, intent(in) ::     lo(1),    hi(1)
    integer, intent(in) ::  dmnlo(1), dmnhi(1)
    integer, intent(in) ::    Qlo(1),   Qhi(1)
    integer, intent(in) ::   Dxlo(1),  Dxhi(1)
    integer, intent(in) ::  muxlo(1), muxhi(1)
    integer, intent(in) ::  xixlo(1), xixhi(1)
    integer, intent(in) :: lamxlo(1),lamxhi(1)
    integer, intent(in) ::   Axlo(1),  Axhi(1)
    integer, intent(in) ::   fxlo(1),  fxhi(1)

    integer, intent(in) ::    Vlo(1),   Vhi(1)
    integer, intent(in) ::    Dlo(1),   Dhi(1)

    double precision, intent(in   ) ::    Q(   Qlo(1):   Qhi(1), QVAR)
    double precision, intent(in   ) ::   Dx(  Dxlo(1):  Dxhi(1), nspec)
    double precision, intent(in   ) ::  mux( muxlo(1): muxhi(1)  )
    double precision, intent(in   ) ::  xix( xixlo(1): xixhi(1)  )
    double precision, intent(in   ) :: lamx(lamxlo(1):lamxhi(1)  )
    double precision, intent(in   ) ::   Ax(  Axlo(1):  Axhi(1)  )
    double precision, intent(inout) ::   fx(  fxlo(1):  fxhi(1), NVAR)
    double precision, intent(inout) ::    D(   Dlo(1):   Dhi(1), NVAR)
    double precision, intent(in   ) ::    V(   Vlo(1):   Vhi(1)  )
    double precision, intent(in   ) :: deltax(1)

    integer :: i, n, nn
    double precision :: tauxx, dudx, divu
    double precision :: uface, pface, hface, Yface
    double precision :: dTdx, Vd
    double precision :: Vc(lo(1):hi(1)+1)
    double precision :: ddrive(lo(1):hi(1)+1,nspec), gradY(lo(1):hi(1)+1,nspec)
    double precision :: gradP(lo(1):hi(1)+1), dsum(lo(1):hi(1)+1)
    double precision, parameter :: twoThirds = 2.d0/3.d0
    double precision :: dxinv(1)
    type(eos_t) :: eos_state(lo(1)-1:hi(1)+1)

    dxinv = 1.d0/deltax
    do i=lo(1)-1,hi(1)+1
       call build(eos_state(i))
    enddo

    do i=lo(1),hi(1)+1
       ! viscous stress
       dudx = dxinv(1)*(Q(i,QU) - Q(i-1,QU))
       divu = dudx
       tauxx = mux(i)*(2.d0*dudx-twoThirds*divu) + xix(i)*divu
       uface = HALF*(Q(i,QU)    + Q(i-1,QU))
       pface = HALF*(Q(i,QPRES) + Q(i-1,QPRES))

       fx(i,UMX)   = -tauxx
       fx(i,UEDEN) = -tauxx*uface

       ! thermal conduction
       dTdx = dxinv(1) * (Q(i,QTEMP) - Q(i-1,QTEMP))
       fx(i,UEDEN) = fx(i,UEDEN) - lamx(i)*dTdx

       ! (1/p)(dp/dx)
   !    dlnp(i) = dxinv(1) * (Q(i,QPRES) - Q(i-1,QPRES)) / pface
       gradP(i) = dxinv(1) * (Q(i,QPRES) - Q(i-1,QPRES))
       Vc(i) = 0.d0
    end do

    do i=lo(1)-1,hi(1)+1
       eos_state(i) % massfrac(:) = Q(i,QFS:QFS+nspec-1)
       eos_state(i) % T           = Q(i,QTEMP)
       eos_state(i) % rho         = Q(i,QRHO)
       call eos_ytx(eos_state(i))
       call eos_hi(eos_state(i))
       call eos_get_transport(eos_state(i))
    end do

      do n=1,nspec
          do i = lo(1), hi(1)+1

             gradY(i,n) = dxinv(1) * (eos_state(i)%massfrac(n) - eos_state(i-1)%massfrac(n))

!    put in P term
             ddrive(i,n) = 0.5d0*(eos_state(i)% diP(n) + eos_state(i-1)% diP(n)) * gradP(i)

          enddo
       enddo

       do n=1,nspec
       do nn=1,nspec
          do i = lo(1), hi(1)+1

            ddrive(i,n) = ddrive(i,n)+ 0.5d0* (eos_state(i) % dijY(n,nn) &
                           + eos_state(i-1) % dijY(n,nn)) * gradY(i,nn)

          enddo
       enddo
       enddo

       dsum = 0.d0
       do n=1,nspec
          do i = lo(1), hi(1)+1

            dsum(i) = dsum(i) + ddrive(i,n)

          enddo
       enddo
       do n=1,nspec
          do i = lo(1), hi(1)+1

            ddrive(i,n) =  ddrive(i,n) - eos_state(i)%massfrac(n) * dsum(i)

          enddo
       enddo

    ! Get species/enthalpy diffusion, compute correction velocity
    do n=1,nspec
       do i = lo(1), hi(1)+1
          hface = HALF*(eos_state(i)%hi(n)       + eos_state(i-1)%hi(n))

          Vd = -Dx(i,n)*ddrive(i,n)

          fx(i,UFS+n-1) = Vd
          Vc(i) = Vc(i) + Vd
          fx(i,UEDEN) = fx(i,UEDEN) + Vd*hface
       end do
    end do

    ! Add correction velocity
    do n=1,nspec
       do i = lo(1), hi(1)+1
          Yface = HALF*(eos_state(i)%massfrac(n) + eos_state(i-1)%massfrac(n))
          hface = HALF*(eos_state(i)%hi(n)       + eos_state(i-1)%hi(n))

          fx(i,UFS+n-1) = fx(i,UFS+n-1) - Yface*Vc(i)
          fx(i,UEDEN)   = fx(i,UEDEN)   - Yface*Vc(i)*hface
       end do
    end do

    ! Scale fluxes by area
    do i=lo(1),hi(1)+1
       fx(i,UMX)   = fx(i,UMX)   * Ax(i)
       fx(i,UEDEN) = fx(i,UEDEN) * Ax(i)
       fx(i,UFS:UFS+nspec-1) = fx(i,UFS:UFS+nspec-1) * Ax(i)
    enddo

    do i=lo(1)+1,hi(1)-1
       call destroy(eos_state(i))
    enddo

    do n=1,NVAR
       do i = lo(1), hi(1)
          D(i,n) = - (fx(i+1,n)-fx(i,n)) / V(i)
       end do
    end do

  end subroutine pc_diffterm

end module diffterm_module


!==========================================================================
elemental function gsw_adiabatic_lapse_rate_ice (t, p)
!==========================================================================
!
!  Calculates the adiabatic lapse rate of ice.
!
!  t  =  in-situ temperature (ITS-90)                             [ deg C ]
!  p  =  sea pressure                                              [ dbar ]
!         ( i.e. absolute pressure - 10.1325 dbar )
!
!    Note.  The output is in unit of degress Celsius per Pa,
!      (or equivilently K/Pa) not in units of K/dbar.
!--------------------------------------------------------------------------

use gsw_mod_toolbox, only : gsw_gibbs_ice

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: t, p

real (r8) :: gsw_adiabatic_lapse_rate_ice

gsw_adiabatic_lapse_rate_ice = -gsw_gibbs_ice(1,1,t,p)/gsw_gibbs_ice(2,0,t,p)

return
end function

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


      double precision function Hqarbsq(i1,i2,i3,i4)
      implicit none
C----Matrix element squared for the process
C----q(p1)+r(p3) -> q(p2)+r(p4)+Higgs
C----summed over incoming/outgoing colors and spins.
C    with a factor of gsq*Asq removed.

c       +V*((s13*s24-s23*s14)**2+s12**2*s34**2)/s34**2/s12**2
c       +1/2*V*((s13-s24)**2+(s14-s23)**2)/s34/s12
c       -1/2*e*V*(s13+s14+s23+s24)**2/s34/s12;

      include 'constants.f'
      include 'sprods_com.f'
      integer i1,i2,i3,i4
      double precision s12,s13,s14,s23,s24,s34
      s12=s(i1,i2)
      s13=s(i1,i3)
      s14=s(i1,i4)
      s23=s(i2,i3)
      s24=s(i2,i4)
      s34=s(i3,i4)
C GZ
!      write(*,*) 'in Hqarbsq'
!       s12 = 1.000000000000000d0
!       s13= -0.2861267766967376d0
!       s14= -0.3784302994364646d0
!       s23= -0.6215181025806800d0
!       s24= -0.3421507931851938d0
!       s34=  0.6319744100498450d0

      Hqarbsq=V*(((s13*s24-s23*s14)**2+s12**2*s34**2)/s34**2/s12**2
     . +0.5d0*((s13-s24)**2+(s14-s23)**2)/s34/s12)
c      write(*,*) 'In Hqarbsq',Hqarbsq
      return
      end


   module fluid_model_mb09

      use class_four_vector
      use interpolate, only: interp
      use kerr, only: kerr_metric, lnrf_frame, uks2ubl, bl2ks, surf_integral
      use phys_constants, only: pi
      use math, only: zbrent
      implicit none

      namelist /mb09/  dfile, gfile, nt, nfiles, indf, jonfix, offset, sim
      integer :: nx1, nx2, nx3, ndumps, nt, nfiles, indf, defcoord, &
           jonfix, dlen, offset, header_length, field_header_length
      character(len=100) :: dfile, gfile
      character(len=100) :: sim
      integer :: n
      integer :: ndim=3, nhead=30, test=1, binary=1, DEBUG=0
      integer, dimension(:), allocatable :: dumps
      real :: tstep, h, dx1, dx2, dx3, gam, startx1, startx2, startx3, dt, &
           r0, rin, rout
      real(8) :: xbr,toffset=0.,asim
      real, dimension(:), allocatable :: t
      real(8), dimension(:), allocatable :: x1_arr, x2_arr, x3_arr, r_arr, th_arr, ph_arr
      real, dimension(:), allocatable :: rho_arr, p_arr, u0_arr, vrl_arr, &
        vpl_arr, vtl_arr
      real, dimension(:), allocatable :: b0_arr, br_arr, bth_arr, bph_arr

      interface init_mb09_data
        module procedure init_mb09_data
      end interface

      interface calcthmks
         module procedure calcthmks
         module procedure calcthmks_single
         module procedure calcthmks8
         module procedure calcthmks8_single
      end interface

      interface del_mb09_data
        module procedure del_mb09_data
      end interface

      interface initialize_mb09_model
        module procedure initialize_mb09_model
      end interface

      interface transformbl2mks
         module procedure transformbl2mks
      end interface

      interface umks2uks
         module procedure umks2uks
      end interface

      interface mb09_vals
        module procedure mb09_vals
      end interface

!      interface coord_def
!         module procedure coord_def
!      end interface

      interface calcrmks
         module procedure calcrmks
         module procedure calcrmks_single
      end interface

      contains

        function calcrmks(x1,xbr) result(r)
          ! Compute r given x1 for Jon's simulations
          ! JAD 7/24/2011
          real(8), intent(in), dimension(:) :: x1
          real(8), intent(in) :: xbr
          real(8) :: npow2
          real(8), dimension(size(x1)) :: r, xi
          npow2=10d0
          where(x1.gt.xbr)
             xi=x1+(x1-xbr)**npow2
          elsewhere
             xi=x1
          endwhere
          r=exp(xi)
        end function calcrmks

        function calcrmks_single(x1,xbr) result(r)
          ! Compute r given x1 for Jon's simulations
          ! JAD 7/24/2011
          real(8), intent(in) :: x1,xbr
          real(8) :: npow2
          real(8) :: r, xi
          npow2=10d0
          if(x1.gt.xbr) then
             xi=x1+(x1-xbr)**npow2
          else
             xi=x1
          endif
          r=exp(xi)
        end function calcrmks_single

        function umks2uks(fum,x1,x2,xbr) result(uks)
          real(8), intent(in), dimension(:) :: x1,x2
          type (four_vector), dimension(:), intent(in) :: fum
          real(8), intent(in) :: xbr
          type (four_vector), dimension(size(fum)) :: uks
          real(8), dimension(size(x1)) :: r,dr,dx2,dx1,drdx1,dthdrnum,dthdx2num
          ! Convert four-vectors from MKS to KS numerically using central differences.
          ! JAD 5/24/2010
          ! These parameters are from comparing numerical and analytical values
          ! using the jetcoords3 grid.
          r=calcrmks(x1,xbr)
          dr=1d-4*r; dx2=1d-6*x2; dx1=1d-4*x1
          ! r numerically:
          drdx1=(calcrmks(x1+.5d0*dx1,xbr)-calcrmks(x1-.5d0*dx1,xbr))/dx1
          uks%data(2)=drdx1*fum%data(2)
          ! Now do \theta numerically:
          dthdrnum=(calcthmks(x2,r+.5d0*dr)-calcthmks(x2,r-.5d0*dr))/dr
          dthdx2num=(calcthmks(x2+.5d0*dx2,r)-calcthmks(x2-.5d0*dx2,r))/dx2
          uks%data(3)=fum%data(3)*dthdx2num+uks%data(2)*dthdrnum
          ! simple phi
          uks%data(4)=fum%data(4)*2.*pi
          ! time component doesn't change
          uks%data(1)=fum%data(1)
          write(6,*) 'umks2uks r: ',r(1),x1(1),x2(1),xbr
          write(6,*) 'umks2uks dr: ',dr(1),dx1(1),dx2(1)
          write(6,*) 'umks2uks drdx: ',calcrmks(x1(1:2)+0.5d0*dx1(1:2),xbr)
          write(6,*) 'umks2uks umks: ',fum(1)%data(1:4)
          write(6,*) 'umks2uks drdx1: ',drdx1(1)
          write(6,*) 'umks2uks dthdrnum: ',dthdrnum(1)
          write(6,*) 'umks2uks dthdx2num: ',dthdx2num(1)
          write(6,*) 'umks2uks uks: ',uks(1)%data
        end function umks2uks

        function calcthmks(x2,r) result(th)
!          Calculate theta from mks coordinate x2 (McKinney & Gammie (2006a)) and bl/ks coordinate r.
!          JAD 4/9/2009
!          These parameter definitions are based on Jon's defcoord=9:
          real, dimension(:), intent(in) :: x2,r
          real, dimension(size(x2)) :: th
          real, dimension(size(r)) :: g,h
          real :: rj,nj,r0j,rsj,q
          rj=2.8
          nj=0.3
          r0j=20.
          rsj=80.
          q=1.3
          g=-nj*(.5+1./pi*atan((r-rsj)/r0j))
          h=2.-q*(r/rj)**g
          where(x2.lt.0.5)
             th=(pi*x2+(1.-h)/2.*sin(2.*pi*x2))
          elsewhere
             th=(pi*x2-(1.-h)/2.*sin(2.*pi*(1.-x2)))
          endwhere
        end function calcthmks

        function calcthmks_single(x2,r) result(th)
!          Calculate theta from mks coordinate x2 (McKinney & Gammie (2006a)) and bl/ks coordinate r.
!          JAD 4/9/2009
!          These parameter definitions are based on Jon's defcoord=9:
          real, intent(in) :: x2,r
          real :: th
          real :: rj,nj,r0j,rsj,q,g,h
          rj=2.8
          nj=0.3
          r0j=20.
          rsj=80.
          q=1.3
          g=-nj*(.5+1./pi*atan((r-rsj)/r0j))
          h=2.-q*(r/rj)**g
          if(x2.lt.0.5) then
             th=(pi*x2+(1.-h)/2.*sin(2.*pi*x2))
          else
             th=(pi*x2-(1.-h)/2.*sin(2.*pi*(1.-x2)))
          endif
        end function calcthmks_single

        function calcthmks8(x2,r) result(th)
!          Calculate theta from mks coordinate x2 (McKinney & Gammie (2006a)) and bl/ks coordinate r.
!          JAD 4/9/2009
!          These parameter definitions are based on Jon's defcoord=9:
          real(8), dimension(:), intent(in) :: x2,r
          real(8), dimension(size(x2)) :: th
          real(8), dimension(size(r)) :: g,h
          real(8) :: rj,nj,r0j,rsj,q
          rj=2.8
          nj=0.3
          r0j=20.
          rsj=80.
          q=1.3
          g=-nj*(.5+1./pi*atan((r-rsj)/r0j))
          h=2.-q*(r/rj)**g
          where(x2.lt.0.5)
             th=(pi*x2+(1.-h)/2.*sin(2.*pi*x2))
          elsewhere
             th=(pi*x2-(1.-h)/2.*sin(2.*pi*(1.-x2)))
          endwhere
        end function calcthmks8

        function calcthmks8_single(x2,r) result(th)
!          Calculate theta from mks coordinate x2 (McKinney & Gammie (2006a)) and bl/ks coordinate r.
!          JAD 4/9/2009
!          These parameter definitions are based on Jon's defcoord=9:
          real(8), intent(in) :: x2,r
          real(8) :: th
          real(8) :: rj,nj,r0j,rsj,q,g,h
          rj=2.8
          nj=0.3
          r0j=20.
          rsj=80.
          q=1.3
          g=-nj*(.5+1./pi*atan((r-rsj)/r0j))
          h=2.-q*(r/rj)**g
          if(x2.lt.0.5) then
             th=(pi*x2+(1.-h)/2.*sin(2.*pi*x2))
          else
             th=(pi*x2-(1.-h)/2.*sin(2.*pi*(1.-x2)))
          endif
        end function calcthmks8_single

        function calcthmks6(x2,r) result(theta)
          real, intent(in), dimension(:) :: x2, r
          real, dimension(size(x2)) :: theta,myhslope,th2, &
               th0,switch0,switch2,theta1,theta2,arctan2
          real :: r0r,r1jet,njet,r0jet,rsjet,qjet, &
               rs,r0,r0jet3,rsjet3,h0,ntheta,htheta,rsjet2,r0jet2
          r0r=0.
          r1jet=2.8
          njet=0.3
          r0jet=15.
          rsjet=40.
          qjet=1.3
          rs=40.
          r0=20.
          r0jet3=20.
          rsjet3=0.
          h0=0.3
          njet=1.0
          ntheta=5.
          htheta=0.15
          rsjet2=5.0
          r0jet2=2.0
          myhslope=h0+((r-rsjet3)/r0jet3)**njet
          th2=0.5*pi*(1.+atan(myhslope*(x2-0.5))/atan(myhslope*.5))
          myhslope=2.0-qjet*(r/r1jet)**(-njet*(0.5+1.0/pi*atan(r/r0jet-rsjet/r0jet)))
          th0=pi*x2+((1.-myhslope)*0.5)*sin(2.*pi*x2)
          switch0=0.5+1.0/pi*atan((r-rs)/r0)
          switch2=0.5-1.0/pi*atan((r-rs)/r0)
          theta1=th0*switch2+th2*switch0
          theta2=pi*.5*(htheta*(2.*x2-1.)+(1.-htheta)*(2.*x2-1.)**ntheta+1.)
          arctan2=.5+1./pi*(atan((r-rsjet2)/r0jet2))
          theta=theta2+arctan2*(theta1-theta2)
        end function calcthmks6

        function calcthmks6_single(x2,r) result(theta)
          ! Calculates \theta for Jon's defcoord = 1401
          ! JAD 5/14/2010, fortran 12/28/2012
          real, intent(in) :: x2,r
          real :: th,r0r,r1jet,njet,r0jet,rsjet,qjet, &
               rs,r0,r0jet3,rsjet3,h0,ntheta,htheta,rsjet2,r0jet2,myhslope,th2, &
               th0,switch0,switch2,theta1,theta2,arctan2,theta
          r0r=0.
          r1jet=2.8
          njet=0.3
          r0jet=15.
          rsjet=40.
          qjet=1.3
          rs=40.
          r0=20.
          r0jet3=20.
          rsjet3=0.
          h0=0.3
          njet=1.0
          ntheta=5.
          htheta=0.15
          rsjet2=5.0
          r0jet2=2.0
          myhslope=h0+((r-rsjet3)/r0jet3)**njet
          th2=0.5*pi*(1.+atan(myhslope*(x2-0.5))/atan(myhslope*.5))
          myhslope=2.0-qjet*(r/r1jet)**(-njet*(0.5+1.0/pi*atan(r/r0jet-rsjet/r0jet)))
          th0=pi*x2+((1.-myhslope)*0.5)*sin(2.*pi*x2)
          switch0=0.5+1.0/pi*atan((r-rs)/r0)
          switch2=0.5-1.0/pi*atan((r-rs)/r0)
          theta1=th0*switch2+th2*switch0
          theta2=pi*.5*(htheta*(2.*x2-1.)+(1.-htheta)*(2.*x2-1.)**ntheta+1.)
          arctan2=.5+1./pi*(atan((r-rsjet2)/r0jet2))
          theta=theta2+arctan2*(theta1-theta2)
        end function calcthmks6_single

        function calcthmks6_8(x2,r) result(theta)
          real(8), intent(in), dimension(:) :: x2, r
          real(8), dimension(size(x2)) :: theta,myhslope,th2, &
               th0,switch0,switch2,theta1,theta2,arctan2
          real(8) :: r0r,r1jet,njet,r0jet,rsjet,qjet, &
               rs,r0,r0jet3,rsjet3,h0,ntheta,htheta,rsjet2,r0jet2
          r0r=0.
          r1jet=2.8
          njet=0.3
          r0jet=15.
          rsjet=40.
          qjet=1.3
          rs=40.
          r0=20.
          r0jet3=20.
          rsjet3=0.
          h0=0.3
          njet=1.0
          ntheta=5.
          htheta=0.15
          rsjet2=5.0
          r0jet2=2.0
          myhslope=h0+((r-rsjet3)/r0jet3)**njet
          th2=0.5*pi*(1.+atan(myhslope*(x2-0.5))/atan(myhslope*.5))
          myhslope=2.0-qjet*(r/r1jet)**(-njet*(0.5+1.0/pi*atan(r/r0jet-rsjet/r0jet)))
          th0=pi*x2+((1.-myhslope)*0.5)*sin(2.*pi*x2)
          switch0=0.5+1.0/pi*atan((r-rs)/r0)
          switch2=0.5-1.0/pi*atan((r-rs)/r0)
          theta1=th0*switch2+th2*switch0
          theta2=pi*.5*(htheta*(2.*x2-1.)+(1.-htheta)*(2.*x2-1.)**ntheta+1.)
          arctan2=.5+1./pi*(atan((r-rsjet2)/r0jet2))
          theta=theta2+arctan2*(theta1-theta2)
        end function calcthmks6_8

        function calcthmks6_8single(x2,r) result(theta)
          ! Calculates \theta for Jon's defcoord = 1401
          ! JAD 5/14/2010, fortran 12/28/2012
          real(8), intent(in) :: x2,r
          real(8) :: th,r0r,r1jet,njet,r0jet,rsjet,qjet, &
               rs,r0,r0jet3,rsjet3,h0,ntheta,htheta,rsjet2,r0jet2,myhslope,th2, &
               th0,switch0,switch2,theta1,theta2,arctan2,theta
          r0r=0.
          r1jet=2.8
          njet=0.3
          r0jet=15.
          rsjet=40.
          qjet=1.3
          rs=40.
          r0=20.
          r0jet3=20.
          rsjet3=0.
          h0=0.3
          njet=1.0
          ntheta=5.
          htheta=0.15
          rsjet2=5.0
          r0jet2=2.0
          myhslope=h0+((r-rsjet3)/r0jet3)**njet
          th2=0.5*pi*(1.+atan(myhslope*(x2-0.5))/atan(myhslope*.5))
          myhslope=2.0-qjet*(r/r1jet)**(-njet*(0.5+1.0/pi*atan(r/r0jet-rsjet/r0jet)))
          th0=pi*x2+((1.-myhslope)*0.5)*sin(2.*pi*x2)
          switch0=0.5+1.0/pi*atan((r-rs)/r0)
          switch2=0.5-1.0/pi*atan((r-rs)/r0)
          theta1=th0*switch2+th2*switch0
          theta2=pi*.5*(htheta*(2.*x2-1.)+(1.-htheta)*(2.*x2-1.)**ntheta+1.)
          arctan2=.5+1./pi*(atan((r-rsjet2)/r0jet2))
          theta=theta2+arctan2*(theta1-theta2)
        end function calcthmks6_8single

        function findx2mks6(x2,args) result(diff)
          ! Calculates \theta for Jon's defcoord = 1401
          ! JAD 5/14/2010, fortran 12/28/2012
          real(kind=8), intent(in) :: x2
          real(kind=8), intent(in), dimension(:) :: args
          real(kind=8) :: diff,th,r,r0r,r1jet,njet,r0jet,rsjet,qjet, &
               rs,r0,r0jet3,rsjet3,h0,ntheta,htheta,rsjet2,r0jet2,myhslope,th2, &
               th0,switch0,switch2,theta1,theta2,arctan2,theta
          th=args(2) ; r=args(1)
          theta=calcthmks(real(x2),real(r))
          diff=th-theta
        end function findx2mks6

        function findx2mks(x2,args) result(diff)
          ! Calculate theta from mks coordinate x2 (McKinney & Gammie (2006a)) and bl/ks coordinate r.
          ! JAD 4/9/2009
          ! These parameter definitions are based on Jon's defcoord=9:
          real(kind=8), intent(in), dimension(:) :: args
          real(kind=8), intent(in) :: x2
          real(kind=8) :: diff,th,r,rj,r0j,nj,rsj,q,g,h
          th=args(2); r=args(1)
          rj=2.8
          nj=0.3
          r0j=20.
          rsj=80.
          q=1.3
          g=-nj*(.5+1./pi*atan((r-rsj)/r0j))
          h=2.-q*(r/rj)**g
          if(x2.lt.0.5) then
             diff=th-((pi*x2+(1.-h)/2.*sin(2.*pi*x2)))
          else
             diff=th-(pi*x2-(1.-h)/2.*sin(2.*pi*(1.-x2)))
          endif
        end function findx2mks

        function findx1mks(x1,args) result(diff)
          real(8), intent(in), dimension(:) :: args
          real(8), intent(in) :: x1
          real(8) :: xbr,npow2,r,xi,diff
        ! Compute x1 given r for Jon's simulations
          xbr=args(2)
          npow2=10d0
          r=args(1)
          diff=r-calcrmks(x1,xbr)
        end function findx1mks

        subroutine transformbl2mks(r,th,ph,x1,x2,x3)
        ! transform Boyer-Lindquist coordinates to modified Kerr-Schild coordinates used by mb09
        real, intent(in), dimension(:) :: r,th,ph
        real, intent(out), dimension(size(r)) :: x1,x2,x3
        real, dimension(2) :: args
        integer :: i
        do i=1,size(r)
           args(1)=r(i); args(2)=xbr
           x1(i)=zbrent(findx1mks,0d0,10d0,dble(args),1d-6)
           args(2)=th(i)
           x2(i)=zbrent(findx2mks,0d0,1d0,dble(args),1d-6)
        enddo
        x3=ph/2./pi
        end subroutine transformbl2mks

        subroutine mb09_vals(x0,a,rho,p,b,u,bmag)
        type (four_Vector), intent(in), dimension(:) :: x0
        real, intent(in) :: a
        real(8), dimension(size(x0)) :: done
        real, dimension(size(x0)) :: x2,x1,x3,zm,theta,fone, &
         vpl0,vrl0,vtl0,rd,td,pd,rttd,zr,dzero, &
         vr0,vth0,vph0,bth,dummy,tt,ttd,zt,zphi,zpp
        real(8), dimension(nx1) :: uniqx1,uniqr
        real(8), dimension(nx2) :: uniqx2
        real(8), dimension(nx3) :: uniqx3,uniqp
        real, dimension(size(x0),2**(ndim+1)) :: ppi,rhoi,vrli,vtli, &
         vpli,bri,bthi,bphi,b0i,u0i
        real, dimension(size(x0)) :: dth,minp
        real :: dph
        integer, dimension(size(x0)*2*(2**ndim)) :: indx
        integer, dimension(size(x0)) :: x1l,x1u,x2l,x2u,x3l,x3u,tindx
        integer, dimension(size(x0)) :: lx1,lx2,ux1,ux2, &
         umax,one,lx3,ux3
        integer :: npts,i,maxtindx
        real, dimension(size(x0)), intent(out) :: rho,p,bmag
        type (four_Vector), intent(out), dimension(size(x0)) :: u,b
        ! Interpolates MB09 data to input coordinates
        ! JAD 3/20/2009, fortran 12/28/2012
!        write(6,*) 'mb09_vals'
        one=1; dzero=0d0; done=1d0; fone=1.
!        write(6,*) 'before uniq: ',nx1,nx2,nx3
        uniqx1=x1_arr(1:nx1)
!        write(6,*) 'between', minval(x0%data(4)), maxval(x0%data(4))
        uniqx2=x2_arr(1:nx1*(nx2-1)+1:nx1)
!        write(6,*) 'uniqx3: ',size(x3_arr(1:nx1*nx2*(nx3-1)+1:nx1*nx2)),nx3
!        write(6,*) 'uniqx3: ',size(x3_arr),nx1*nx2*nx3,nx1*nx2*(nx3-1)+1
        uniqx3=x3_arr(1:nx1*nx2*(nx3-1)+1:nx1*nx2)
! put case statement for coordinate systems here? Then do all transformations?
 !       write(6,*) 'after uniqx3',minval(uniqx1),maxval(uniqx1),xbr
        uniqr=calcrmks(uniqx1,xbr)
        uniqp=2.*pi*uniqx3
!        write(6,*) 'uniqx1: ',maxval(uniqx1)
!        write(6,*) 'uniqx2: ',uniqx2
!        write(6,*) 'uniqx3: ',uniqp
        npts=size(x0)
        theta=x0%data(3)
        zr=x0%data(2)
        zt=x0%data(1)
!        write(6,*) 'zt: ',zt(1),bl2ks(dble(zr(1)),0d0,dble(a),1)
!        write(6,*) 'zt: ',zt
        tt=bl2ks(dble(zr),dble(zt),dble(a),1)-bl2ks(dble(zr(1)),0d0,dble(a),1)
!        write(6,*) 'tt: ',tt(1:5)
! after converting to KS switch back to Kerr-Schild
        tt=-tt
!        write(6,*) 'tt: ',minval(x0%data(1)),maxval(x0%data(1)),minval(tt),maxval(tt)
        zpp=x0%data(4)
        zphi=bl2ks(dble(zr),dble(zpp),dble(a))
! put mb09 on [0,2pi]
        zphi=mod(zphi,(2.*pi))
        where(zphi.lt.0.)
           zphi=zphi+2.*pi
        endwhere
!        where(zphi.gt.(2.*pi))
!           zphi=zphi-2.*pi
!        endwhere
!        write(6,*) 'zphi: ',minval(zphi),maxval(zphi)
!        write(6,*) 'transform: ',xbr,minval(zr),maxval(zr)
        call transformbl2mks(zr,theta,zphi,x1,x2,x3)
!        write(6,*) 'transform: ',maxval(zr), minval(zr), maxval(x1), minval(x1)
!        write(6,*) 'transform: ',maxval(theta), minval(theta), minval(x2), maxval(x2)
        lx1=floor((x1-uniqx1(1))/(uniqx1(nx1)-uniqx1(1))*(nx1-1))+1
        ux1=lx1+1
        lx2=floor((x2-uniqx2(1))/(uniqx2(nx2)-uniqx2(1))*(nx2-1))+1
        ux2=lx2+1
        lx3=floor((x3-uniqx3(1))/(uniqx3(nx3)-uniqx3(1))*(nx3-1))+1
        ux3=lx3+1
        lx2=merge(lx2,one,lx2.ge.1)
        ux2=merge(ux2,nx2,ux2.le.nx2)
! Deal with poles
!        write(6,*) 'poles',size(zr),size(uniqx2(lx2)),size(uniqx2(ux2))
        where(ux2.ne.lx2)
           dth=calcthmks(uniqx2(ux2),dble(zr))-calcthmks(uniqx2(lx2),dble(zr))
        elsewhere
           dth=calcthmks(uniqx2(1)+0d0*dble(zr),dble(zr))
        endwhere
! periodic in phi
        minp=uniqp(lx3)
        where(ux3.gt.nx3)
           ux3=1
        endwhere
        where(lx3.lt.1)
           lx3=nx3
           minp=uniqp(lx3)-2.*pi
        endwhere
! uniform in phi
        pd=(zphi-minp)/(uniqp(2)-uniqp(1))
!        write(6,*) 'pd: ',x3(maxloc(abs(pd))), zphi(maxloc(abs(pd))), uniqp(lx3(maxloc(abs(pd)))), &
!             lx3(maxloc(abs(pd))), pd(maxloc(abs(pd)))
        td=abs(theta-calcthmks(uniqx2(lx2),dble(zr)))/dth
!        write(6,*) 'lx2: ',minval(lx2),maxval(lx2),nx2
        rd=(zr-uniqr(lx1))/(uniqr(ux1)-uniqr(lx1))
! When the geodesic is inside the innermost zone center located outside the horizon,
! use nearest neighbor rather than interpolate
        where(uniqr(lx1).le.(1.+sqrt(1.-a**2.)))
           rd=1.
        endwhere
!        write(6,*) 'rd td: ',minval(rd),maxval(rd),minval(td),maxval(td),minval(pd),maxval(pd)
!        write(6,*) 'ux lx: ',minval(lx1),maxval(ux1),minval(lx2),maxval(ux2)
        ! th is fastest changing index
        x1l=lx1-1; x1u=ux1-1
        x2l=(lx2-1)*nx1 ; x2u=(ux2-1)*nx1
        x3l=(lx3-1)*nx1*nx2; x3u=(ux3-1)*nx1*nx2
! Indices for nearest neighbors in 3D
!        write(6,*) 'sindx', maxval(sindx), sindx(npts+1), x1l(1)+x2u(1)+1, size(sindx)
! Now find timestep indices:
        maxtindx=nt-2
        where(floor(tt/tstep).le.maxtindx)
           tindx=floor(tt/tstep)
           ttd=(tt-tindx*tstep)/tstep
        elsewhere
           tindx=maxtindx+1
           ttd=0.
        endwhere
!        write(6,*) 'tindx: ',tindx,n*tindx
! Create index array across times and 2D nearest neighbors (first half at first time, second half at second time):
! Need to make sure there aren't integer problems when these indices get very large
!        write(6,*) 'indx', size(indx), 2**ndim, maxval(tindx), minval(tindx), tstep
        indx=(/(/x1l+x2l+x3l+1+n*tindx/),(/x1l+x2u+x3l+1+n*tindx/),(/x1u+x2l+x3l+1+n*tindx/), &
             (/x1u+x2u+x3l+1+n*tindx/),(/x1l+x2l+x3u+1+n*tindx/), &
             (/x1l+x2u+x3u+1+n*tindx/),(/x1u+x2l+x3u+1+n*tindx/),(/x1u+x2u+x3u+1+n*tindx/), &
             (/x1l+x2l+x3l+1+n*(tindx+1)/),(/x1l+x2u+x3l+1+n*(tindx+1)/),(/x1u+x2l+x3l+1+n*(tindx+1)/), &
             (/x1u+x2u+x3l+1+n*(tindx+1)/),(/x1l+x2l+x3u+1+n*(tindx+1)/),(/x1l+x2u+x3u+1+n*(tindx+1)/), &
             (/x1u+x2l+x3u+1+n*(tindx+1)/),(/x1u+x2u+x3u+1+n*(tindx+1)/)/)
! keep indx from going out of bounds when loading one time slice
        where(indx.gt.size(rho_arr))
           indx=indx-n
        endwhere
!        do i=1,2**ndim
!           indx((i-1)*npts+1:i*npts)=sindx((i-1)*npts+1)+npts*tindx
!           indx((2**ndim+i-1)*npts+1:(i+2**ndim)*npts)=sindx((i-1)*npts+1)+npts*(tindx+1)
!        end do
!        write(6,*) 'after indx: ', minloc(indx), x1(minloc(indx)), x2(minloc(indx)), x3(minloc(indx))
!        write(6,*) 'after indx: ',lx1(minloc(indx)),lx2(minloc(indx)),lx3(minloc(indx))
!        write(6,*) 'after indx: ',x1u(minloc(indx)),x2u(minloc(indx)),x3u(minloc(indx))
!        write(6,*) 'after indx: ',x1l(minloc(indx)),x2l(minloc(indx)),x3l(minloc(indx))
!        write(6,*) 'after indx', maxval(indx),minval(indx),size(rho_arr)!,size(rho_arr(indx))
!        write(6,*) 'after indx',npts,2**(ndim+1),size(rhoi)
        rhoi=reshape(rho_arr(indx),(/npts,2**(ndim+1)/))
!        write(6,*) 'rhoi',size(rho_arr(indx)),npts,2**(ndim+1),size(rhoi)
        vrli=reshape(vrl_arr(indx),(/npts,2**(ndim+1)/))
        vtli=reshape(vtl_arr(indx),(/npts,2**(ndim+1)/))
        vpli=reshape(vpl_arr(indx),(/npts,2**(ndim+1)/))
        ppi=reshape(p_arr(indx),(/npts,2**(ndim+1)/))
        b0i=reshape(b0_arr(indx),(/npts,2**(ndim+1)/))
        bri=reshape(br_arr(indx),(/npts,2**(ndim+1)/))
        bthi=reshape(bth_arr(indx),(/npts,2**(ndim+1)/))
        bphi=reshape(bph_arr(indx),(/npts,2**(ndim+1)/))
        u0i=reshape(u0_arr(indx),(/npts,2**(ndim+1)/))
!        rttd=ttd
        rttd=0.
        rho=merge(interp(rhoi,rttd,pd,rd,td),dzero,x1.gt.uniqx1(1))
!        write(6,*) 'interp test u0i: ',u0i(7041,:)
!        write(6,*) 'interp test u0i: ',vrli(7041,:)
!        write(6,*) 'interp test u0i: ',vtli(7041,:)
!        write(6,*) 'interp test u0i: ',vpli(7041,:)
!        write(6,*) 'interp test pd: ',pd(7041),rd(7041),td(7041)
!        write(6,*) 'interp test rho: ',u0(7041)
        p=merge(interp(ppi,rttd,pd,rd,td),fone,x1.gt.uniqx1(1))
!        write(6,*) 'rho: ', rho, p
        vrl0=merge(interp(vrli,rttd,pd,rd,td),dzero,x1.gt.uniqx1(1))
        vtl0=merge(interp(vtli,rttd,pd,rd,td),fone,x1.gt.uniqx1(1))
!        write(6,*) 'v'
        b%data(1)=merge(interp(b0i,rttd,pd,rd,td),fone,x1.gt.uniqx1(1))
        b%data(2)=merge(interp(bri,rttd,pd,rd,td),fone,x1.gt.uniqx1(1))
!        write(6,*) 'b'
        b%data(3)=merge(interp(bthi,rttd,pd,rd,td),fone,x1.gt.uniqx1(1))
        b%data(4)=merge(interp(bphi,rttd,pd,rd,td),fone,x1.gt.uniqx1(1))
!        write(6,*) 'u'
        u%data(1)=merge(dble(interp(u0i,rttd,pd,rd,td)),done,x1.gt.uniqx1(1))
        vpl0=merge(interp(vpli,rttd,pd,rd,td),dzero,x1.gt.uniqx1(1))
!        write(6,*) 'after assign'
        ! Protect azimuthal velocities at poles
        ! Compute magnitude of interpolated b-field and force b^2 > 0 (need to look into numerical issues here):
        call assign_metric(b,transpose(kerr_metric(zr, &
         real(x0%data(3)),a)))
        bmag=b*b; bmag=merge(bmag,dzero,bmag.ge.0d0)
        bmag=sqrt(bmag)
        ! Get four-velocity:
        call lnrf_frame(vrl0,vtl0,vpl0,zr,a,real(x0%data(3)) &
         ,vr0,vth0,vph0,1)
        u%data(2)=u%data(1)*dble(vr0)
        u%data(3)=u%data(1)*dble(vth0)
        u%data(4)=u%data(1)*dble(vph0)
!        write(6,*) 'interp test u: ',vrl0(7041),vtl0(7041),vpl0(7041)
!        write(6,*) 'interp test u: ',u(7041)%data
!        write(6,*) 'interp test u: ',vrl0(7041)**2+vtl0(7041)**2+vpl0(7041)**2
!        write(6,*) 'interp test u: ',x1_arr(indx(7041)),x2_arr(indx(7041)), &
!             x3_arr(indx(7041))
!        write(6,*) 'interp test u: ',x1_arr(indx(7041+size(x0)*4)),x2_arr(indx(7041+size(x0)*4)), &
!             x3_arr(indx(7041+size(x0)*4))
!        write(6,*) 'interp test u: ',x1(7041),x2(7041),x3(7041)
        call assign_metric(u,transpose(kerr_metric(zr,real(x0%data(3)) &
        ,a)))
!        write(6,*) '7041: ',u(7041)*u(7041)
        if(DEBUG.eq.1) then
        ! output quantities for debugging
           write(6,*) 'debug!'
           open(unit=8,file='fluid_model_mb09_debug.out')
           write(8,*) nx1,nx2,nx3,size(x0%data(1)),xbr
           write(8,*) rho_arr
           write(8,*) x0%data(1), x0%data(2), x0%data(3), x0%data(4)
           write(8,*) tt,zr,theta,zphi
           write(8,*) x1,x2,x3
           write(8,*) uniqx1,uniqx2,uniqx3
           write(8,*) x1_arr, x2_arr, x3_arr
           write(8,*) lx1,lx2,lx3,ux1,ux2,ux3
           write(8,*) rd,td,pd
           write(8,*) x1l,x1u,x2l,x2u,x3l,x3u
           write(8,*) indx
           write(8,*) u0i, vrli, vtli, vpli
           write(8,*) u%data(1), u%data(2), u%data(3), u%data(4)
        endif
!        write(6,*) 'mb09 vals rho: ',rho
!        write(6,*) 'mb09 vals minloc: ',minloc(rho),rd(minloc(rho)), &
!             td(minloc(rho)),x0(minloc(rho))%data(3),uniqth(lx2(minloc(rho))), &
!             lx2(minloc(rho))
!        write(6,*) 'mb09 vals rhoi: ',rhoi(minloc(rho),:)
        end subroutine mb09_vals

        subroutine read_mb09_inputs(ifile)
        character(len=20), intent(in) :: ifile
        open(unit=8,file=ifile,form='formatted',status='old')
        read(8,nml=mb09)
        write(6,*) 'read: ',nt
        close(unit=8)
        xbr=25.
        end subroutine read_mb09_inputs

        subroutine calc_mb09_jet_power(jet_power,wind_power)
        ! calculate jet and wind power using definitions from mckinney et al. 2012
        ! this assumes data loaded is four-velocity rather than lnrf vels
        real(8), dimension(nx1), intent(out) :: jet_power, wind_power
        integer, dimension(nx1,nx2,nx3) :: wjet, wwind
        type (four_vector), dimension(nx1*nx2*nx3) :: ucov,bcov,u,b
        real(8), dimension(nx1,nx2,nx3) :: trtem
        wjet=0; wwind=0
        u%data(1)=u0_arr; u%data(2)=vrl_arr; u%data(3)=vtl_arr; u%data(4)=vpl_arr
        b%data(1)=b0_arr; b%data(2)=br_arr; b%data(3)=bth_arr; b%data(4)=bph_arr
        call assign_metric(b,transpose(kerr_metric(r_arr,th_arr,asim)))
        call assign_metric(u,transpose(kerr_metric(r_arr,th_arr,asim)))
        where(reshape(b(1:nx1*nx2*nx3)*b(1:nx1*nx2*nx3)/rho_arr(1:nx1*nx2*nx3), &
             (/nx1,nx2,nx3/)).gt.1)
           wjet=1
        endwhere
        where(reshape(b(1:nx1*nx2*nx3)*b(1:nx1*nx2*nx3)/rho_arr(1:nx1*nx2*nx3), &
             (/nx1,nx2,nx3/)).lt.1. &
             .and.reshape(p_arr(1:nx1*nx2*nx3)/(b(1:nx1*nx2*nx3)*b(1:nx1*nx2*nx3)/8./pi), &
             (/nx1,nx2,nx3/)).lt.2.)
           wwind=1
        endwhere
        write(6,*) 'wjet, wwind: ',sum(wjet),sum(wwind)
        ucov=lower(u); bcov=lower(b)
        trtem=reshape(b*b*ucov%data(1)*u%data(2)-bcov%data(1)*b%data(2),(/nx1,nx2,nx3/))
        wind_power=surf_integral(trtem*wwind,reshape(r_arr,(/nx1,nx2,nx3/)),reshape(th_arr,(/nx1,nx2,nx3/)),&
             reshape(ph_arr,(/nx1,nx2,nx3/)),asim)
        jet_power=surf_integral(trtem*wjet,reshape(r_arr,(/nx1,nx2,nx3/)),reshape(th_arr,(/nx1,nx2,nx3/)),&
             reshape(ph_arr,(/nx1,nx2,nx3/)),asim)
        end subroutine calc_mb09_jet_power

!        subroutine calc_mb09_inner_edge(rin)
        ! calculate disk inner edge using definitions from hawley & krolik 2001
!        rin=
!        end subroutine calc_mb09_inner_edge

        subroutine initialize_mb09_model(a,transform,ifile,gf,df,ntt,nft, &
             indft,jf,simt)
        real(8), intent(in) :: a
        real(8) :: tcur, tstep_test
        integer :: nx, status
        integer, intent(in) :: transform
        character(len=20), intent(in), optional :: ifile,simt
        character(len=20) :: default_ifile='mb09.in', append
        character(len=100), intent(in), optional :: gf,df
        integer, intent(in), optional :: ntt,nft,indft,jf
        character(len=100) :: header_file
        if (present(gf)) then
           dfile = df
           gfile = gf
           nt = ntt
           nfiles = nft
           indf = indft
           jonfix = jf
           sim = simt
        else
           if (present(ifile)) then
              call read_mb09_inputs(ifile)
           else
              call read_mb09_inputs(default_ifile)
           endif
        endif
! hard coded to be large and not be used.
        xbr = 25.
        write(6,*) 'inputs read: ',allocated(ph_arr),a
!        write(6,*) 'init mb09'
! length of header at start of mb09 files (these should be determined by Python)
!        header_length=390+offset
!        field_header_length=header_length+6
! should change fmt to be more general -- figure out max # files, assign fmt accordingly
        write(append, fmt='(I4.4)') indf
!        header_file=trim(dfile) // trim(append) // trim('.bin')
        write(6,*) 'nhead: ',nhead
!        call read_mb09_data_header(gfile,header_length)
!        call read_mb09_data_header(header_file,field_header_length)
!        write(6,*) 'header lengths: ',header_length,field_header_length
!        write(6,*) 'rin: ',rin,rout,calcrmks(10d0,xbr)
        write(6,*) 'nhead: ',nhead,allocated(ph_arr)
!        if(abs(asim-a).gt.1e-4) then
!           write(6,*) 'ERROR -- Different simulation and grtrans spin values!', asim, a
!           return
!        endif
        asim=a
        n=nx1*nx2*nx3
!        call init_mb09_data(n,n*nt)
        write(6,*) 'init: ',allocated(rho_arr),size(rho_arr),n,nt
        call read_mb09_grid_file(nt)
        write(6,*) 'read grid: ',minval(x1_arr),maxval(x1_arr)
! transform to get others
        ph_arr=2.*pi*x3_arr
        r_arr=calcrmks(x1_arr,xbr)
        th_arr=calcthmks(x2_arr,r_arr)
        write(6,*) 'r th ph: ',minval(r_arr),maxval(th_arr)
        write(6,*) 'nhead: ',nhead,allocated(ph_arr)
        write(6,*) 'read header', nx1, nx2, allocated(ph_arr), allocated(r_arr)
        write(6,*) 'init data', nt, indf, dfile
        call load_mb09_data(nt,1)
        end subroutine initialize_mb09_model

        subroutine read_mb09_grid_file(nt)
        integer, intent(in) :: nt
        integer :: n
          open(unit=8,file=gfile,form='unformatted',status='old')
          read(8) nx1,nx2,nx3
          n=nx1*nx2*nx3
          ! allocate data
          call init_mb09_data(n,n*nt)
          write(6,*) 'read grid: ',size(x1_arr),size(x2_arr),size(x3_arr)
          read(8) x1_arr
          read(8) x2_arr
          read(8) x3_arr
          close(unit=8)
        end subroutine read_mb09_grid_file

        subroutine read_mb09_data(dfile,rho,p,u0,vr,vth,vph,b0,br,bth,bph)
        integer :: nx, status
        real, dimension(:), allocatable :: data
        real, intent(inout), dimension(:) :: rho,p,u0,vr,vth,vph,b0,br,bth,bph
        real, dimension(size(rho),10) :: metric
        real, dimension(size(rho)) :: ui2
        character(len=100), intent(in) :: dfile
        open(unit=8,file=dfile,form='unformatted',status='old')
        read(8) nx
        if(nx.ne.9*nx1*nx2*nx3) then
           write(6,*) 'ERROR: INCORRECT DATA SIZE IN READ_MB09_DATA: ',nx,nx1,nx2,nx3
           return
        endif
        allocate(data(nx))
        read(8) data
        close(8)
        rho=data(1:nx1*nx2*nx3)
        p=data(nx1*nx2*nx3+1:2*nx1*nx2*nx3)
        vr=data(2*nx1*nx2*nx3+1:3*nx1*nx2*nx3)
        vth=data(3*nx1*nx2*nx3+1:4*nx1*nx2*nx3)
        vph=data(4*nx1*nx2*nx3+1:5*nx1*nx2*nx3)
        b0=data(5*nx1*nx2*nx3+1:6*nx1*nx2*nx3)
        br=data(6*nx1*nx2*nx3+1:7*nx1*nx2*nx3)
        bth=data(7*nx1*nx2*nx3+1:8*nx1*nx2*nx3)
        bph=data(8*nx1*nx2*nx3+1:9*nx1*nx2*nx3)
        deallocate(data)
! calculate u0 from others (from IDL grtrans):
        metric=kerr_metric(r_arr,th_arr,asim)
        ui2=metric(:,1)+2.*metric(:,4)*vph+vr**2*metric(:,5)+metric(:,8)*vth**2+metric(:,10)*vph**2
        u0=1./sqrt(-ui2)
        end subroutine read_mb09_data

! routine to load a single simh52binary.pro binary file
        subroutine load_mb09_data(nt,transform)
        integer :: nx, k
        integer, intent(in) :: nt,transform
        real, dimension(:), allocatable :: rho,p,u0,vr,vth,vph,b0,br,bth,bph,vrl,vtl,vpl
        real :: tcur
!        character(len=100), intent(in) :: dfile
        character(len=100) :: data_file
        character(len=20) :: append
        tstep=2.
        write(6,*) 'load mb09', dfile
        n=nx1*nx2*nx3
        allocate(rho(n)); allocate(p(n)); allocate(u0(n))
        allocate(vph(n)); allocate(vth(n)); allocate(b0(n))
        allocate(br(n)); allocate(bth(n)); allocate(bph(n))
        allocate(vr(n))
        if(transform.eq.1) then
           allocate(vrl(n)); allocate(vtl(n)); allocate(vpl(n))
        endif
        do k=1,nt
           write(append, fmt='(I4.4)') indf-(k-1)
           data_file = trim(dfile) // trim(append) // '.bin'
           write(6,*) 'data_file: ',indf-(k-1),append,data_file
           call read_mb09_data(data_file,rho,p,u0,vr,vth,vph,b0,br,bth,bph)
           write(6,*) 'read mb09 data: ',minval(u0),maxval(u0),minval(vph),maxval(vph)
           write(6,*) 'read mb09 data: ',minval(vr),maxval(vr),minval(vth),maxval(vth)
           write(6,*) 'read mb09 data: ',asim,minval(r_arr),maxval(r_arr),minval(th_arr),maxval(th_arr)
           write(6,*) 'read mb09 data: ',minval(b0),maxval(b0),nx1,nx2,nx3
           write(6,*) 'after read mb09 data', n, size(rho), size(rho_arr)
           write(6,*) 'after read mb09 data', minval(vph), maxval(vph), minval(vr), maxval(vr)
           if(k.eq.1) t(k)=tcur
           ! assign to data arrays
           rho_arr((k-1)*n+1:k*n)=rho
           write(6,*) 'after assign rho'
           p_arr((k-1)*n+1:k*n)=p
           b0_arr((k-1)*n+1:k*n)=b0
           br_arr((k-1)*n+1:k*n)=br
           bth_arr((k-1)*n+1:k*n)=bth
           bph_arr((k-1)*n+1:k*n)=bph
!           write(6,*) 'v assign'
           u0_arr((k-1)*n+1:k*n)=u0
           write(6,*) 'after all assign',minval(p_arr),maxval(rho_arr)
! for some applications want lnrf vels rather than four-velocity
           if(transform.eq.1) then
              call lnrf_frame(vr,vth,vph,real(r_arr),real(asim),real(th_arr),vrl,vtl,vpl)
              vrl_arr((k-1)*n+1:k*n)=real(vrl)
              !           write(6,*) 'after assign', size(vtl_arr((k-1)*n+1:k*n)), size(vtl)
              vpl_arr((k-1)*n+1:k*n)=real(vpl)
              !           write(6,*) 'after vpl', vtl(1), vtl(n), vtl
              vtl_arr((k-1)*n+1:k*n)=real(vtl)
                         write(6,*) 'after vtl',minval(vrl_arr),maxval(vrl_arr),minval(vpl_arr)
              !           write(6,*) 'assign'
           else
              vrl_arr((k-1)*n+1:k*n)=vr
              vpl_arr((k-1)*n+1:k*n)=vph
              vtl_arr((k-1)*n+1:k*n)=vth
           endif
        end do
        deallocate(rho); deallocate(p); deallocate(u0)
        deallocate(vph); deallocate(vth); deallocate(b0)
        deallocate(br); deallocate(bth); deallocate(bph)
        deallocate(vr)
        if(transform.eq.1) then
           deallocate(vrl); deallocate(vtl); deallocate(vpl)
        endif

        end subroutine load_mb09_data

        subroutine advance_mb09_timestep(dtobs)
        real(8), intent(in) :: dtobs
        integer :: nupdate
        nupdate = floor(dtobs / tstep)
        toffset = toffset+dtobs-tstep*nupdate
! after a couple stpes might be accumulating offset
        nupdate=nupdate+floor(toffset/tstep)
        toffset=toffset-floor(toffset/tstep)*tstep
        indf=indf+nupdate
        write(6,*) 'advance mb09 timestep: ',dtobs,tstep,toffset,indf,nupdate
        call update_mb09_data(nupdate)
        end subroutine advance_mb09_timestep

        subroutine update_mb09_data(nupdate)
        integer, intent(in) :: nupdate
        integer :: nshift
        if(nupdate.gt.nt) then
! this is case where we just load all new data
           call load_mb09_data(nt,1)
        else
! this is case where we shift existing data back and then load more
           nshift=n*nupdate+1
!           rho_arr=rho_arr(nshift:nshift-1:1)
!           allocate(temp_arr(n))
           rho_arr(nshift:n*nt)=rho_arr(1:n*nt-nshift)
           p_arr(nshift:n*nt)=p_arr(1:n*nt-nshift)
           br_arr(nshift:n*nt)=br_arr(1:n*nt-nshift)
           bth_arr(nshift:n*nt)=bth_arr(1:n*nt-nshift)
           bph_arr(nshift:n*nt)=bph_arr(1:n*nt-nshift)
           b0_arr(nshift:n*nt)=b0_arr(1:n*nt-nshift)
           vrl_arr(nshift:n*nt)=vrl_arr(1:n*nt-nshift)
           vtl_arr(nshift:n*nt)=vtl_arr(1:n*nt-nshift)
           vpl_arr(nshift:n*nt)=vpl_arr(1:n*nt-nshift)
           call load_mb09_data(nupdate,1)
        end if
        end subroutine update_mb09_data

        subroutine init_mb09_data(nx,n)
        integer, intent(in) :: n,nx
        allocate(rho_arr(n)); allocate(p_arr(n)); allocate(u0_arr(n))
        allocate(vrl_arr(n)); allocate(vtl_arr(n)); allocate(vpl_arr(n))
        allocate(b0_arr(n)); allocate(br_arr(n)); allocate(bth_arr(n))
        allocate(bph_arr(n)); allocate(ph_arr(nx))
        allocate(x1_arr(nx)); allocate(x2_arr(nx)); allocate(r_arr(nx))
        allocate(th_arr(nx)); allocate(t(nt)); allocate(x3_arr(nx))
        end subroutine init_mb09_data

        subroutine del_mb09_data()
        deallocate(rho_arr); deallocate(p_arr); deallocate(u0_arr)
        deallocate(vrl_arr); deallocate(vtl_arr); deallocate(vpl_arr)
        deallocate(b0_arr); deallocate(br_arr); deallocate(bth_arr)
        deallocate(bph_arr); deallocate(x1_arr); deallocate(x2_arr)
        deallocate(r_arr); deallocate(th_arr); deallocate(ph_arr)
        deallocate(t); deallocate(x3_arr)
        end subroutine del_mb09_data

      end module fluid_model_mb09


C
C $Id: e0fndp.f,v 1.5 2008-07-27 00:17:08 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      DOUBLE PRECISION FUNCTION E0FNDP (ECCNTS)
C
C This function computes the constant E0.
C
      IMPLICIT DOUBLE PRECISION (A-Z)
      DATA QUART,ONE,ONEQ,THREE,SIXT /0.25D0,1.0D0,1.25D0,3.0D0,16.0D0/
C
      E0FNDP = ONE - QUART * ECCNTS * (ONE + ECCNTS / SIXT *
     .         (THREE + ONEQ * ECCNTS))
C
      RETURN
      END


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                     C
C    ROUTINE TO FILL THE ARRAYS INCLUDING ALL THE SCALAR INTEGRALS    C
C     FOR THE CHARGED HIGGS PAIR PRODUCTION                           C
C                                                                     C
C       SCALAR_ARRAY_HH(MASSIN,SCA,SCB,SCBP,SCC,SCD)                  C
C                                                                     C
C    INPUT  : MASSIN(1:30)                                            C
C                                                                     C
C             MASSIN(1)  = S                                          C
C             MASSIN(2)  = T2                                         C
C             MASSIN(6)  = MH                                         C
C             MASSIN(7)  = MT                                         C
C             MASSIN(8)  = MZ                                         C
C             MASSIN(9)  = MH1                                        C
C             MASSIN(10) = MH2                                        C
C             MASSIN(11) = MS                                         C
C                                                                     C
C    OUTPUT : SCA(1:10)                                               C
C             SCB(1:10,1:6)                                           C
C             SCBP(1:10)                                              C
C             SCC(1:20,1:9)                                           C
C             SCD(1:10,1:8)                                           C
C                                                                     C
C        Afin(mt)                      = SCA(1,1)                     C
C        Bfin(p1,mt,0)                 = SCB(2,1)                     C
C        Bfin(p2,mt,0)                 = SCB(3,1)                     C
C        Bfin(k1+k2,0,0)               = SCB(4,1)                     C
C        Bfin(p1+k2,mt,0)              = SCB(5,1)                     C
C        Bfin(p1+k1,mt,0)              = SCB(6,1)                     C
C        Bfin(mt,mt,0)                 = SCB(7,1)                     C
C        Cfin(k1,k2,0,0,0)             = SCC(1,1)                     C
C        Cfin(p1,k1,mt,0,0)            = SCC(2,1)                     C
C        Cfin(p2,k2,mt,0,0)            = SCC(5,1)                     C
C        Cfin(p1,p2,0,mt,0)            = SCC(6,1)                     C
C        Dfin(k2,k1,p1,0,0,0,mt)       = SCD(1,4)                     C
C                                                                     C
C                                                                     C
C   N.B. : THE INTEGRAL MEASURE IS D^NQ/(I*Pi^2)                      C
C          ALL VARIABLES REAL*8, ONLY THE REAL PARTS OF THE INTEGRALS C
C                                                                     C
C                                                                     C
C    NECESSARY SUBROUTINES :  XSPENCE.F                               C
C                             XWOPOINT_SPIRA.F                        C
C                             XTHREEPOINT_SPIRA.F                     C
C                             XDENNER_3.F                             C
C                                                                     C
C    CALLED FUNCTIONS : B02                                           C
C                       BP02                                          C
C                       C03                                           C
C                       D04                                           C
C                       CSPEN                                         C
C                                                                     C
C    LAST MODIFIED : 02.09.04 (inset the forgotten B(mt)              C
C                                                                     C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

c ---------------------------------------------------------------------
      subroutine SCALAR_ARRAY_HH(massin,sca,scb,scbp,scc,scd)

      implicit none

      integer    n,n1,n2

      real*8     massin(1:30)
     &          ,sca(1:10),scb(1:10,1:6),scbp(1:10)
     &          ,scc(1:20,1:9),scd(1:10,1:8)
     &          ,s,t,m1,m2,mt,u,mu2,ms
     &          ,zeta2,eps1,eps2,epsi,Li2,B02,BP02
     &          ,duma,dumc_1,dumd_2
     &          ,mg,msb1,msb2,mst1,mst2

      complex*16 C03,CSPEN,D04,m2c2,msc2,mtc2,sc

      external B02,BP02,C03,D04,CSPEN

c               real part of the spence function included in D04
      Li2(s) = real( CSPEN(dcmplx(s)) )

c               finite part of one point function
      duma(mt,mu2) = mt**2*( 1.D0 - log(mt**2/mu2) )

c               divergent three point functions, first roland's (0.34)
      dumc_1(t,m1,m2,m2c2,mu2) =
     &  (   Li2(t/m2**2) - Li2(m1**2/m2**2)
     &    + real( log( 1.D0 - t/m2c2     )**2 )
     &    - real( log( 1.D0 - m1**2/m2c2 )**2 )
     &    + log(m2**2/mu2) * log( abs(-(t-m2**2)/(m2**2-m1**2) ) ) )
     &  /(t-m1**2)

c               same as above for m1=ms, roland's (0.33)
c$$$      dumc_3(t,m1,m1c2,mu2,zeta2) =
c$$$     &  (   Li2(t/m1**2)
c$$$     &    + real( log( 1.D0 - t/m1c2**2 )**2 )
c$$$     &    + 1.D0/4.D0 * log(mu2/m1**2)**2
c$$$     &    - log(mu2/m1**2)*log(abs(-(t-m1**2)/m1**2))
c$$$     &    + zeta2/4.D0                            )
c$$$     &  /(t-m1**2)

c               divergent four point, roland's (0.46)
c$$$      dumd_1(t,m1,m2,m1c2,s,mu2,zeta2) =
c$$$     &  ( - 2.D0 * Li2( (m2**2-t)/(m1**2-t) )
c$$$     &    - real( log( (m1c2-m2**2)/m1/sqrt(mu2) )**2 )
c$$$     &    + 2.D0*log( (m1**2-t)/m1/sqrt(mu2) )*log(s/mu2)
c$$$     &    - 13.D0 * zeta2 /4.D0 )
c$$$     &   /s/(t-m1**2)

c               divergent four point function, roland's (0.41)
c               generalized to m1.ne.m2, copy from ng, mg->m2
      dumd_2(t,m1,m2,ms,msc2,s,sc,mu2,zeta2) =
     &  ( - 2.D0 * Li2( 1.D0 + (ms**2-m1**2)/(t-ms**2) )
     &    - 2.D0 * Li2( 1.D0 + (ms**2-m2**2)/(t-ms**2) )
     &    - Li2( 1.D0 + (ms**2-m1**2)*(ms**2-m2**2)/s/ms**2 )
     &    - 3.D0/2.D0 * zeta2
     &    - real( log( 1.D0 + (msc2-m1**2)*(msc2-m2**2)/s/msc2 )
     &             * (   log( -(msc2-m1**2)*(msc2-m2**2)/s/msc2 )
     &                 - log( (msc2-m1**2)/mu2)
     &                 - log( (msc2-m2**2)/mu2)
     &                 + log( -s*msc2/mu2**2)         )              )
     &    + log( s/mu2  )**2 /2.D0
     &    - log( s/ms**2)**2 /2.D0
     &    + 2.D0*real( log( -sc/mu2 )
     &                 *log( -(t-msc2)/msc2) )
     &    - real( log( (msc2-m1**2)/mu2 )
     &            *log( (msc2-m1**2)/msc2) )
     &    - real( log( (msc2-m2**2)/mu2 )
     &            *log( (msc2-m2**2)/msc2) )                        )
     &  /s/(t-ms**2)

c               roland's (0.49)
c$$$      dumd_3(t,u,m1,m2,mu2,zeta2) =
c$$$     &  (  2.D0 * Li2((t-m2**2)/(m1**2-m2**2))
c$$$     &   - 2.D0 * Li2((m2**2-u)/(m1**2-u))
c$$$     &   + log((m1**2-t)/m1/sqrt(mu2))**2
c$$$     &   + 2.D0 * log((m1**2-t)/m1/sqrt(mu2))
c$$$     &          * log(abs((m1**2-u)/(m1**2-m2**2)))
c$$$     &   - 6.D0*zeta2/8.D0                           )
c$$$     &   /(t-m1**2)/(u-m1**2)

c               constants
      zeta2 = ( 4.D0*atan(1.D0) )**2 /6.D0

c               define the different variables and fix the scale
      s  = massin(1)
      m1 = massin(6)
      m2 = massin(6)
      mt = massin(7)
      mg    = massin(15)
      msb1  = massin(16)
      msb2  = massin(17)
      mst1  = massin(18)
      mst2  = massin(19)

c               cut-off for external momenta in C03 and D04 [non-zero 1.D-7]
      eps1 = 1.D-7

c               cut-off for masses in C03 and D04 [1.D-8]
      eps2 = 1.D-8

c               imaginary part for masses [1.D-8]
      epsi = 1.D-8

c               needed for the loop particle masses
      mtc2 = mt**2 * dcmplx(1.D0,-epsi)
      sc = s * dcmplx(1.D0,epsi)

c               fix the scale to the value in the oval all prefactor
      mu2 = m1**2

      t    = massin(2) + m2**2
      u    = m1**2 + m2**2 - s - t

c               set everything to 9.99999D+9
      do n=1,10,1
         sca(n) = 9.99999D+9
      end do

      do n1=1,10,1
         do n2=1,6,1
            scb(n1,n2) = 9.99999D+9
         end do
      end do

      do n=1,10,1
         scbp(n) = 9.99999D+9
      end do

      do n1=1,20,1
         do n2=1,9,1
            scc(n1,n2) = 9.99999D+9
         end do
      end do

      do n1=1,10,1
         do n2=1,8,1
            scd(n1,n2) = 9.99999D+9
         end do
      end do

c               the one point functions (finite parts)
      sca(1) = duma(mt,mu2)
      sca(2) = duma(mg,mu2)
      sca(3) = duma(mst1,mu2)
      sca(4) = duma(mst2,mu2)
      sca(5) = duma(msb1,mu2)
      sca(6) = duma(msb2,mu2)

c               the two point functions (finite parts)
      scb(1,1) = B02(0.D0 ,mg  ,msb1,mu2)
      scb(1,2) = B02(0.D0 ,mg  ,msb2,mu2)
      scb(2,1) = B02(m1**2,mt  ,0.D0,mu2)
      scb(2,2) = B02(m1**2,msb1,mst1,mu2)
      scb(2,3) = B02(m1**2,msb1,mst2,mu2)
      scb(2,4) = B02(m1**2,msb2,mst1,mu2)
      scb(2,5) = B02(m1**2,msb2,mst2,mu2)
      scb(3,1) = B02(m2**2,mt,  0.D0,mu2)
      scb(4,1) = B02(s,    0.D0,0.D0,mu2)
      scb(4,4) = B02(s,    msb1,msb1,mu2)
      scb(4,5) = B02(s,    msb1,msb2,mu2)
      scb(4,6) = B02(s,    msb2,msb2,mu2)
      scb(5,1) = B02(u,    mt,  0.D0,mu2)
      scb(6,1) = B02(t,    mt,  0.D0,mu2)
      scb(6,2) = B02(t,    mg,  mst1,mu2)
      scb(6,3) = B02(t,    mg,  mst2,mu2)
      scb(7,1) = B02(mt**2,mt,  0.D0,mu2)
      scb(7,2) = B02(mt**2,mg,  mst1,mu2)
      scb(7,3) = B02(mt**2,mg,  mst2,mu2)

      scbp(1) = BP02(0.D0,mg,msb1,mu2)
      scbp(2) = BP02(0.D0,mg,msb2,mu2)

c               three point functions
      scc(6,1)  = real( C03(m1**2,m2**2,s ,eps2,mt  ,eps2) )

      scc(1,2)  = real( C03(eps1 ,eps1 ,s ,msb1,mg  ,msb1) )
      scc(1,3)  = real( C03(eps1 ,eps1 ,s ,msb1,mg  ,msb2) )
      scc(1,4)  = real( C03(eps1 ,eps1 ,s ,msb2,mg  ,msb1) )
      scc(1,5)  = real( C03(eps1 ,eps1 ,s ,msb2,mg  ,msb2) )

      scc(2,2)  = real( C03(m1**2,eps1 ,t ,mst1,mg  ,msb1) )
      scc(2,3)  = real( C03(m1**2,eps1 ,t ,mst2,mg  ,msb1) )
      scc(2,4)  = real( C03(m1**2,eps1 ,t ,mst1,mg  ,msb2) )
      scc(2,5)  = real( C03(m1**2,eps1 ,t ,mst2,mg  ,msb2) )

      scc(6,2)  = real( C03(m1**2,m1**2,s ,msb1,mst1,msb1) )
      scc(6,3)  = real( C03(m1**2,m1**2,s ,msb1,mst2,msb1) )
      scc(6,4)  = real( C03(m1**2,m1**2,s ,msb1,mst1,msb2) )
      scc(6,5)  = real( C03(m1**2,m1**2,s ,msb1,mst2,msb2) )
      scc(6,6)  = real( C03(m1**2,m1**2,s ,msb2,mst1,msb1) )
      scc(6,7)  = real( C03(m1**2,m1**2,s ,msb2,mst2,msb1) )
      scc(6,8)  = real( C03(m1**2,m1**2,s ,msb2,mst1,msb2) )
      scc(6,9)  = real( C03(m1**2,m1**2,s ,msb2,mst2,msb2) )

c               roland's (0.20)
      scc(1,1) = ( 1.D0/2.D0 * log(s/mu2)**2 - 7.D0/2.D0*zeta2 )/s
c                        (0.34)
      scc(2,1) = dumc_1(t,m1,mt,mtc2,mu2)
      scc(5,1) = dumc_1(t,m1,mt,mtc2,mu2)

c               finite four point functions
      scd(3,1) = real(D04(eps1,eps1,m1**2,m2**2,s,t,msb1,mg,msb1,mst1))
      scd(3,2) = real(D04(eps1,eps1,m1**2,m2**2,s,t,msb1,mg,msb1,mst2))
      scd(3,3) = real(D04(eps1,eps1,m1**2,m2**2,s,t,msb1,mg,msb2,mst1))
      scd(3,4) = real(D04(eps1,eps1,m1**2,m2**2,s,t,msb1,mg,msb2,mst2))
      scd(3,5) = real(D04(eps1,eps1,m1**2,m2**2,s,t,msb2,mg,msb1,mst1))
      scd(3,6) = real(D04(eps1,eps1,m1**2,m2**2,s,t,msb2,mg,msb1,mst2))
      scd(3,7) = real(D04(eps1,eps1,m1**2,m2**2,s,t,msb2,mg,msb2,mst1))
      scd(3,8) = real(D04(eps1,eps1,m1**2,m2**2,s,t,msb2,mg,msb2,mst2))

c               divergent four point functions
      scd(1,4) = dumd_2(t,m1,m2,mt,mtc2,s,sc,mu2,zeta2)

      return
      end


! reference: R. J. Purser (J. of Clim. and Apld. Meteorology, 1987)

module filter_module

  ! 3-point filter: T=1, R=S=0
  use amrex_fort_module, only : rt => amrex_real
  real(rt)        , dimension(0:1), parameter :: ff1 = &
       (/ 0.5e0_rt, 0.25e0_rt /)
  ! For boundary cell
  real(rt)        , dimension(0:1), parameter :: ff1b = &
       (/ 0.75e0_rt, 0.25e0_rt /)

  ! 5-point filter: T=2, R+S+1=T
  ! S = 0, 1
  real(rt)        , dimension(0:2,0:1), parameter :: ff2 = reshape( &
       [ 0.625e0_rt, 0.25e0_rt, -0.0625e0_rt, &
       & 0.375e0_rt, 0.25e0_rt,  0.0625e0_rt ], &
       [3,2] )
  ! For first bondary cell
  real(rt)        , dimension(0:2), parameter :: ff2b0 = &
       (/ 17.e0_rt/16.e0_rt, -2.e0_rt/16.e0_rt, 1.e0_rt/16.e0_rt /)
  ! for second boundary cell
  real(rt)        , dimension(-1:2), parameter :: ff2b1 = &
       (/ -2.e0_rt/16.e0_rt, 21.e0_rt/16.e0_rt, -4.e0_rt/16.e0_rt, 1.e0_rt/16.e0_rt /)

  ! 7-point filter: T=3, R+S+1=T
  ! S = 0, 1, 2
  real(rt)        , dimension(0:3,0:2), parameter :: ff3 = reshape( &
       [ 44.e0_rt/64.e0_rt, 15.e0_rt/64.e0_rt, -6.e0_rt/64.e0_rt,  1.e0_rt/64.e0_rt, &
       & 32.e0_rt/64.e0_rt, 18.e0_rt/64.e0_rt,  0.e0_rt      , -2.e0_rt/64.e0_rt, &
       & 20.e0_rt/64.e0_rt, 15.e0_rt/64.e0_rt,  6.e0_rt/64.e0_rt,  1.e0_rt/64.e0_rt ], &
       [4,3] )
  ! for boundary cells
  real(rt)        , dimension(0:3), parameter :: ff3b0 = &
       (/ 63.e0_rt/64.e0_rt, 3.e0_rt/64.e0_rt, -3.e0_rt/64.e0_rt, 1.e0_rt/64.e0_rt /)
  real(rt)        , dimension(-1:3), parameter :: ff3b1 = &
       (/ 3.e0_rt/64.e0_rt, &
       54.e0_rt/64.e0_rt, 12.e0_rt/64.e0_rt, -6.e0_rt/64.e0_rt, 1.e0_rt/64.e0_rt /)
  real(rt)        , dimension(-2:3), parameter :: ff3b2 = &
       (/ -3.e0_rt/64.e0_rt, 12.e0_rt/64.e0_rt, &
       45.e0_rt/64.e0_rt, 15.e0_rt/64.e0_rt, -6.e0_rt/64.e0_rt, 1.e0_rt/64.e0_rt /)

  ! 9-point filter: T=4, R+S+1=T
  ! S = 0, 1, 2, 3
  real(rt)        , dimension(0:4,0:3), parameter :: ff4 = reshape( &
       [ 186.e0_rt/256.e0_rt, 56.e0_rt/256.e0_rt, -28.e0_rt/256.e0_rt,  8.e0_rt/256.e0_rt, -1.e0_rt/256.e0_rt, &
       & 146.e0_rt/256.e0_rt, 72.e0_rt/256.e0_rt, -12.e0_rt/256.e0_rt, -8.e0_rt/256.e0_rt,  3.e0_rt/256.e0_rt, &
       & 110.e0_rt/256.e0_rt, 72.e0_rt/256.e0_rt,  12.e0_rt/256.e0_rt, -8.e0_rt/256.e0_rt, -3.e0_rt/256.e0_rt, &
       &  70.e0_rt/256.e0_rt, 56.e0_rt/256.e0_rt,  28.e0_rt/256.e0_rt,  8.e0_rt/256.e0_rt,  1.e0_rt/256.e0_rt ], &
       [5,4] )
  ! for boundary cells
  real(rt)        , dimension(0:4), parameter :: ff4b0 = &
       (/ 257.e0_rt/256.e0_rt, -4.e0_rt/256.e0_rt, 6.e0_rt/256.e0_rt, -4.e0_rt/256.e0_rt, 1.e0_rt/256.e0_rt /)
  real(rt)        , dimension(-1:4), parameter :: ff4b1 = &
       (/ -4.e0_rt/256.e0_rt,  &
       273.e0_rt/256.e0_rt, -28.e0_rt/256.e0_rt, 22.e0_rt/256.e0_rt, -8.e0_rt/256.e0_rt, 1.e0_rt/256.e0_rt /)
  real(rt)        , dimension(-2:4), parameter :: ff4b2 = &
       (/ 6.e0_rt/256.e0_rt, -28.e0_rt/256.e0_rt, &
       309.e0_rt/256.e0_rt, -52.e0_rt/256.e0_rt, 28.e0_rt/256.e0_rt, -8.e0_rt/256.e0_rt, 1.e0_rt/256.e0_rt /)
  real(rt)        , dimension(-3:4), parameter :: ff4b3 = &
       (/ -4.e0_rt/256.e0_rt, 22.e0_rt/256.e0_rt, -52.e0_rt/256.e0_rt, &
       325.e0_rt/256.e0_rt, -56.e0_rt/256.e0_rt, 28.e0_rt/256.e0_rt, -8.e0_rt/256.e0_rt, 1.e0_rt/256.e0_rt /)

end module filter_module


!  *********************************************************************
!  *                                                                   *
!  *                S U B R O U T I N E   P H O T O P E R              *
!  *                                                      gm   1/31/05 *
!  *                                                                   *
!  *                                                                   *
!  *********************************************************************
!  The PHOTOPER subroutine
! the equation to calculate the daylength factor which will be used to
! affect development rate comes from the publication by
! 'McMaster et al., 2008, Simulating the influence of vernalization,
! photoperiod and optimum temperature on wheat development rates.'

!  INPUTS:  daynum(R), hemisp(R), vernal(C), verns(C)

!  OUTPUTS: vernal(C), verns(C)

      subroutine photoper(daynum, df, pp, p1d) !,hemisp, vernal, verns)
!hrlt is passed from PhenologyMMS into pp.
      implicit none

      integer  daynum !, verns

      ! df = daylength factor
      real  df, p1d !, vernal

    !  character *22  hemisp

!     Local Variables
      real pp

! Calculate the day length factor
!     p1d is the photoperiod coefficient and is the sensitivity
!     of a cultivar to photoperiod. It is a DSSAT parameter.
!     It should be read in from a file but for now set it here.
!     Perhaps, photoperiod and vernalization coefficients could
!     be in a text file with values for each crop/cultivar and read in
!     like emerge.txt. These values, based on the crop/cultivar, could
!     then be written to tinputs. The coefficients file will have to be
!     searched with the crop/cultivar names in order to get the values
!     specific to that crop/cultivar and then be written to the
!     tinputs file. This will be done via the interface code. For now,
!     p1d is initialized in initcepv.for and passed here where it is set
!     to a value.

 !debe moved setting of p1d to PhenologyMMS subroutine.
!      p1d = 30.0

! Should '20' be set in a file?
      df = 1-((p1d/10000) * ((20-pp)**2))
 !     print *, 'df = ', df

      return
      end