subroutine unisamp(ipart,velonly)
!========================================================================================
!==== This subroutine develops initial random particle positions and velocities      ====
!==== using basic uniform random number sampling.                                    ====
!====    by Adam Siade                                                               ====
!========================================================================================
!========================================================================================

  use psodat

  implicit none

! specifications:
!----------------------------------------------------------------------------------------
  integer,intent(in)::ipart,velonly
  integer::iparm

  double precision::tpar,tlbnd,tubnd,r
!----------------------------------------------------------------------------------------

   do iparm=1,npar
     !
     if (trim(partrans(iparm)) == 'fixed') then
       !
       partval(ipart,iparm) = parval1(iparm)
       !
     else
       !
       if (velonly == 1) then
         !
         if (trim(partrans(iparm)) == 'log') then
           !
           call random_number(r)
           tpar = (log10(parubnd(iparm)) - log10(parlbnd(iparm)))*r + &
                  log10(parlbnd(iparm))
           !
           partval(ipart,iparm) = 1.0d+01**(tpar)
           !
         else if (trim(partrans(iparm)) == 'eqlog') then
           !
           tlbnd = (log10(parlbnd(iparm)))/(log10(base(iparm)))
           tubnd = (log10(parubnd(iparm)))/(log10(base(iparm)))
           !
           call random_number(r)
           tpar = (tubnd - tlbnd)*r + tlbnd
           !
           partval(ipart,iparm) = base(iparm)**(tpar)
           !
         else if (trim(partrans(iparm)) == 'none') then
           !
           call random_number(r)
           partval(ipart,iparm) = (parubnd(iparm) - parlbnd(iparm))*r + &
                                   parlbnd(iparm)
           !
         end if
         !
       end if
       !
       if (trim(partrans(iparm)) /= 'tied') then
         !
!        partvel values and hence, vmax, are based on transformed parameter values
         !
!        if none  is used, vmax is specified based on base parameter values' ranges
!        if log10 is used, vmax should be specified based on orders of magnitude of
!                             parameter ranges
!        if eqlog is used, vmax is specified as a fraction of maxrange (which was calc'd
!                             previously in the readpst subroutine)
         !
         call random_number(r)
         partvel(ipart,iparm) = 2.0d+00*vmax(iparm)*r - vmax(iparm)
         !
       end if
       !
     end if
     !
   end do
   !
!  tied parameters
   do iparm=1,npar
     !
     if (trim(partrans(iparm)) == 'tied' .and. velonly == 1) then
       partval(ipart,iparm) = tiedrat(iparm)*partval(ipart,partied(iparm))
     end if
     !
   end do
   !
!  since this is an initialized particle, it's pbest position is set to the initial value
   do iparm=1,npar
     pbest(ipart,iparm) = partval(ipart,iparm)
   end do

end subroutine unisamp

subroutine svdjac()
!========================================================================================
!==== This subroutine conducts SVD on Jacobian.                                      ====
!====    by Adam Siade                                                               ====
!========================================================================================
!========================================================================================

  use psodat

  implicit none

! specifications:
!----------------------------------------------------------------------------------------
  integer::iparm,iobs,lwork,lwmax,info,inull,isol

  double precision,dimension(:),allocatable::work,sp
  double precision,dimension(:,:),allocatable::up,vpt,v2t,v1t,jacsvd
!----------------------------------------------------------------------------------------

  lwmax = 100000
  !
  allocate(jacsvd(nobs,nadj),sp(nadj),up(nobs,nadj),vpt(nadj,nadj),v2t(nadj-sdim,nadj),&
           work(lwmax),v1t(sdim,nadj),nproj(nadj,nadj),sproj(nadj,nadj))
  !
  v2t   = 0.0d+00
  v1t   = 0.0d+00
  nproj = 0.0d+00
  sproj = 0.0d+00
  !
  do iparm=1,nadj
    do iobs=1,nobs
      jacsvd(iobs,iparm) = jac(iobs,iparm)
    end do
  end do
!   !
!   open(71,file='test-jac.dat')
!   do iobs=1,nobs
!     write(71,*)(jacsvd(iobs,iparm),iparm=1,100)
!   end do
!   close(71)
  !
  lwork = -1   !<-- query for optimal performance
  info = 0
  work = 0.0d+00
  sp   = 0.0d+00
  up   = 0.0d+00
  vpt  = 0.0d+00
  !
! undertake SVD
  call dgesvd('N','A',nobs,nadj,jacsvd,nobs,sp,up,1,vpt,nadj,&
                  work,lwork,info)
  !
  if (info /= 0) then
    !
    write(*,*)'SVD of Jacobian failed'
    write(*,*)'-- stopping execution --'
    stop
    !
  end if
  !
  lwork = min(lwmax,int(work(1)))
  !
  if (lwmax < int(work(1))) then
    !
    write(*,*)'Need to increase memeory for SVD work array'
    write(*,*)'work(1) = ',work(1)
    write(*,*)'-- stopping execution --'
    stop
    !
  end if
  !
  info = 0
  work = 0.0d+00
  sp   = 0.0d+00
  up   = 0.0d+00
  vpt  = 0.0d+00
  !
  call dgesvd('N','A',nobs,nadj,jacsvd,nobs,sp,up,1,vpt,nadj,&
                  work,lwork,info)
  !
  if (info /= 0) then
    !
    write(*,*)'SVD of Jacobian failed'
    write(*,*)'-- stopping execution --'
    stop
    !
  end if
  !
! basis functions spanning the null space
  do inull=1,nadj-sdim
    do iparm=1,nadj
      v2t(inull,iparm) = vpt(inull+sdim,iparm)
    end do
  end do
  !
! basis functions spanning the solution space
  do isol=1,sdim
    do iparm=1,nadj
      v1t(isol,iparm) = vpt(isol,iparm)
    end do
  end do
!   !
!   open(71,file='test-vt.dat')
!   do inull=1,nadj
!     write(71,*)(vpt(iparm,inull),iparm=301,414)
!   end do
!   close(71)
!   !
!   open(71,file='test-s.dat')
!   do iparm=1,nadj
!     write(71,*)sp(iparm)**2
!   end do
!   close(71)
!   stop
  !
! projection matrix for null space
  call dsyrk('U','T',nadj,nadj-sdim,1.0d+00,v2t,nadj-sdim,0.00d+00,nproj,nadj)
  !
! projection matrix for solution space
  call dsyrk('U','T',nadj,sdim,1.0d+00,v1t,sdim,0.00d+00,sproj,nadj)
!   !
!   open(71,file='test-v2v2t.dat')
!   do inull=1,nadj
!     write(71,*)(nproj(inull,iparm),iparm=1,100)
!   end do
!   close(71)
  !
  deallocate(work,sp,up,vpt,v2t,v1t,jacsvd)

end subroutine svdjac

subroutine nullproj(ipart)
!========================================================================================
!==== This subroutine projects randomly generated parameter pertubrations onto       ====
!====   the null space of the inverse problem.                                       ====
!====    by Adam Siade                                                               ====
!========================================================================================
!========================================================================================

  use psodat

  implicit none

! specifications:
!----------------------------------------------------------------------------------------
  integer,intent(in)::ipart
  integer::iparm,icnt,iobs

  double precision,dimension(:),allocatable::dp,pdp
!----------------------------------------------------------------------------------------

  allocate(dp(nadj),pdp(nadj))
  !
  dp   = 0.0d+00
  pdp  = 0.0d+00
  icnt = 0
  !
!   open(71,file='test-dp.dat')
! calculate the perturbation in the adjustable parameters
  do iparm=1,npar
    !
    if (trim(partrans(iparm)) == 'log' .or. trim(partrans(iparm)) == 'eqlog' .or. &
        trim(partrans(iparm)) == 'none') then
      !
      icnt = icnt + 1
      !
      dp(icnt) = parval1(iparm) - partval(ipart,iparm)
!       write(71,*)dp(icnt)
      !
    end if
    !
  end do
!   close(71)
  !
! project parameter perturbation (from calibrated parameter set) onto null space
  call dsymv('U',nadj,1.00d+00,nproj,nadj,dp,1,0.0d+00,pdp,1)
  !
  icnt = 0
  !
!   open(71,file='test-pdp.dat')
! calculate the parameter set that results from the projected perturbation
  do iparm=1,npar
    !
    if (trim(partrans(iparm)) == 'log' .or. trim(partrans(iparm)) == 'eqlog' .or. &
        trim(partrans(iparm)) == 'none') then
      !
      icnt = icnt + 1
      !
      partval(ipart,iparm) = parval1(iparm) - pdp(icnt)
!       write(71,*)pdp(icnt)
      !
    end if
    !
  end do
!   close(71)
  !
! for now we deal with parameters going beyond bounds by setting them to their bounds
  do iparm=1,npar
    !
    if (partval(ipart,iparm) > parubnd(iparm)) partval(ipart,iparm) = parubnd(iparm)
    if (partval(ipart,iparm) < parlbnd(iparm)) partval(ipart,iparm) = parlbnd(iparm)
    !
  end do
  !
  deallocate(dp,pdp)

end subroutine nullproj

subroutine solproj(ipart)
!========================================================================================
!==== This subroutine projects PSO generated parameter pertubrations onto the        ====
!====   the solution space of the inverse problem.                                   ====
!====    by Adam Siade                                                               ====
!========================================================================================
!========================================================================================

  use psodat

  implicit none

! specifications:
!----------------------------------------------------------------------------------------
  integer,intent(in)::ipart
  integer::iparm,icnt

  double precision,dimension(:),allocatable::dp,pdp
!----------------------------------------------------------------------------------------

  allocate(dp(nadj),pdp(nadj))
  !
  dp   = 0.0d+00
  pdp  = 0.0d+00
  icnt = 0
  !
!   open(71,file='test-dp.dat')
! calculate the perturbation in the adjustable parameters
  do iparm=1,npar
    !
    if (trim(partrans(iparm)) == 'log' .or. trim(partrans(iparm)) == 'eqlog' .or. &
        trim(partrans(iparm)) == 'none') then
      !
      icnt = icnt + 1
      !
      dp(icnt) = parval1(iparm) - partval(ipart,iparm)
!       write(71,*)dp(icnt)
      !
    end if
    !
  end do
!   close(71)
  !
! project parameter perturbation (from calibrated parameter set) onto null space
  call dsymv('U',nadj,1.00d+00,sproj,nadj,dp,1,0.0d+00,pdp,1)
  !
  icnt = 0
  !
!   open(71,file='test-pdp.dat')
! calculate the parameter set that results from the projected perturbation
  do iparm=1,npar
    !
    if (trim(partrans(iparm)) == 'log' .or. trim(partrans(iparm)) == 'eqlog' .or. &
        trim(partrans(iparm)) == 'none') then
      !
      icnt = icnt + 1
      !
      partval(ipart,iparm) = parval1(iparm) - pdp(icnt)
!       write(71,*)pdp(icnt)
      !
    end if
    !
  end do
!   close(71)
  !
! for now we deal with parameters going beyond bounds by setting them to their bounds
  do iparm=1,npar
    !
    if (partval(ipart,iparm) > parubnd(iparm)) partval(ipart,iparm) = parubnd(iparm)
    if (partval(ipart,iparm) < parlbnd(iparm)) partval(ipart,iparm) = parlbnd(iparm)
    !
  end do
  !
  deallocate(dp,pdp)

end subroutine solproj

subroutine transpar(ipart,trans)
!========================================================================================
!==== This subroutine transforms parameters.                                         ====
!====    by Adam Siade                                                               ====
!========================================================================================
!========================================================================================

  use psodat

  implicit none

! specifications:
!----------------------------------------------------------------------------------------
  integer,intent(in)::ipart,trans
  integer::irep,iparm
!----------------------------------------------------------------------------------------

  do iparm=1,npar
    !
    if (trim(partrans(iparm)) == 'log' .and. trans == 1) then
      !
      partval(ipart,iparm) = log10(partval(ipart,iparm))
      pbest(ipart,iparm)   = log10(pbest(ipart,iparm))
      !
    else if (trim(partrans(iparm)) == 'eqlog' .and. trans == 1) then
      !
      partval(ipart,iparm) = (log10(partval(ipart,iparm)))/(log10(base(iparm)))
      pbest(ipart,iparm) = (log10(pbest(ipart,iparm)))/(log10(base(iparm)))
      !
    end if
    !
    if (trim(partrans(iparm)) == 'log' .and. trans == 0) then
      !
      partval(ipart,iparm) = 1.0d+01**(partval(ipart,iparm))
      pbest(ipart,iparm)   = 1.0d+01**(pbest(ipart,iparm))
      !
    else if (trim(partrans(iparm)) == 'eqlog' .and. trans == 0) then
      !
      partval(ipart,iparm) = base(iparm)**(partval(ipart,iparm))
      pbest(ipart,iparm)   = base(iparm)**(pbest(ipart,iparm))
      !
    end if
    !
  end do

end subroutine transpar

subroutine transrep(trans)
!========================================================================================
!==== This subroutine transforms parameters.                                         ====
!====    by Adam Siade                                                               ====
!========================================================================================
!========================================================================================

  use psodat

  implicit none

! specifications:
!----------------------------------------------------------------------------------------
  integer,intent(in)::trans
  integer::irep,iparm
!----------------------------------------------------------------------------------------

  do iparm=1,npar
    !
    if (trim(partrans(iparm)) == 'log' .and. trans == 1) then
      !
      do irep=1,nrep+npop
        if (repindx(irep) == 1) then
          reposit(irep,iparm) = log10(reposit(irep,iparm))
        end if
      end do
      !
    else if (trim(partrans(iparm)) == 'eqlog' .and. trans == 1) then
      !
      do irep=1,nrep+npop
        if (repindx(irep) == 1) then
          reposit(irep,iparm) = (log10(reposit(irep,iparm)))/(log10(base(iparm)))
        end if
      end do
      !
    end if
    !
    if (trim(partrans(iparm)) == 'log' .and. trans == 0) then
      !
      do irep=1,nrep+npop
        if (repindx(irep) == 1) then
          reposit(irep,iparm) = 1.0d+01**(reposit(irep,iparm))
        end if
      end do
      !
    else if (trim(partrans(iparm)) == 'eqlog' .and. trans == 0) then
      !
      do irep=1,nrep+npop
        if (repindx(irep) == 1) then
          reposit(irep,iparm) = base(iparm)**(reposit(irep,iparm))
        end if
      end do
      !
    end if
    !
  end do

end subroutine transrep

subroutine transbnd(trans)
!========================================================================================
!==== This subroutine transforms parameters.                                         ====
!====    by Adam Siade                                                               ====
!========================================================================================
!========================================================================================

  use psodat

  implicit none

! specifications:
!----------------------------------------------------------------------------------------
  integer,intent(in)::trans
  integer::iparm
!----------------------------------------------------------------------------------------

  do iparm=1,npar
    !
    if (trim(partrans(iparm)) == 'log' .and. trans == 1) then
      !
      parlbnd(iparm)       = log10(parlbnd(iparm))
      parubnd(iparm)       = log10(parubnd(iparm))
      !
      parval1(iparm)       = log10(parval1(iparm))
      !
    else if (trim(partrans(iparm)) == 'eqlog' .and. trans == 1) then
      !
      parlbnd(iparm) = (log10(parlbnd(iparm)))/(log10(base(iparm)))
      parubnd(iparm) = (log10(parubnd(iparm)))/(log10(base(iparm)))
      !
      parval1(iparm) = (log10(parval1(iparm)))/(log10(base(iparm)))
      !
    end if
    !
    if (trim(partrans(iparm)) == 'log' .and. trans == 0) then
      !
      parlbnd(iparm)       = 1.0d+01**(parlbnd(iparm))
      parubnd(iparm)       = 1.0d+01**(parubnd(iparm))
      !
      parval1(iparm)       = 1.0d+01**(parval1(iparm))
      !
    else if (trim(partrans(iparm)) == 'eqlog' .and. trans == 0) then
      !
      parlbnd(iparm)       = base(iparm)**(parlbnd(iparm))
      parubnd(iparm)       = base(iparm)**(parubnd(iparm))
      !
      parval1(iparm)       = base(iparm)**(parval1(iparm))
      !
    end if
    !
  end do

end subroutine transbnd

subroutine transparunc(nsav,trans)
!========================================================================================
!==== This subroutine transforms parameters.                                         ====
!====    by Adam Siade                                                               ====
!========================================================================================
!========================================================================================

  use psodat

  implicit none

! specifications:
!----------------------------------------------------------------------------------------
  integer,intent(in)::trans,nsav
  integer::iparm,isav
!----------------------------------------------------------------------------------------

  do iparm=1,npar
    !
    if (trim(partrans(iparm)) == 'log' .and. trans == 1) then
      !
      do isav=1,nsav
        parsav(iparm,isav) = log10(parsav(iparm,isav))
      end do
      !
    else if (trim(partrans(iparm)) == 'eqlog' .and. trans == 1) then
      !
      do isav=1,nsav
        parsav(iparm,isav) = (log10(parsav(iparm,isav)))/(log10(base(iparm)))
      end do
      !
    end if
    !
    if (trim(partrans(iparm)) == 'log' .and. trans == 0) then
      !
      do isav=1,nsav
        parsav(iparm,isav) = 1.0d+01**(parsav(iparm,isav))
      end do
      !
    else if (trim(partrans(iparm)) == 'eqlog' .and. trans == 0) then
      !
      do isav=1,nsav
        parsav(iparm,isav) = base(iparm)**(parsav(iparm,isav))
      end do
      !
    end if
    !
  end do

end subroutine transparunc


      real(kind(0.0d0)) function ddot (n, dx, incx, dy, incy)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  double
!...Translated by Pacific-Sierra Research 77to90  4.3E  21:52:17  11/14/01
!...Switches:
      implicit none
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      integer , intent(in) :: n
      integer , intent(in) :: incx
      integer , intent(in) :: incy
      real(double) , intent(in) :: dx(1)
      real(double) , intent(in) :: dy(1)
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      integer :: i, ix, iy, m, mp1
      real(double) :: dtemp
!-----------------------------------------------
!
!     forms the dot product of two vectors.
!     uses unrolled loops for increments equal to one.
!     jack dongarra, linpack, 3/11/78.
!
!
      ddot = 0.0D0
      dtemp = 0.0D0
      if (n <= 0) return
      if (incx/=1 .or. incy/=1) then
!
!        code for unequal increments or equal increments
!          not equal to 1
!
         ix = 1
         iy = 1
         if (incx < 0) ix = ((-n) + 1)*incx + 1
         if (incy < 0) iy = ((-n) + 1)*incy + 1
         dtemp = dot_product(dx(ix:(n-1)*incx+ix:incx),dy(iy:(n-1)*incy+iy:incy&
            ))
         ddot = dtemp
         return
      endif
!
!        code for both increments equal to 1
!
!
!        clean-up loop
!
      m = mod(n,5)
      if (m == 0) go to 40
      dtemp = dot_product(dx(:m),dy(:m))
      if (n < 5) go to 60
   40 continue
      mp1 = m + 1
      dtemp = dtemp + dot_product(dx(mp1:((n-mp1+5)/5)*5-1+mp1),dy(mp1:((n-mp1+&
         5)/5)*5-1+mp1))
   60 continue
      ddot = dtemp
      return
      end function ddot


subroutine force_ion
  use global_variables
  implicit none
  complex(8) :: zCt(NK*NB),zAt(NK*NB,NK*NB)
  integer :: icell, icell2, aion, bion,ik
  real(8) :: la_full,x
!LAPACK ==
  complex(8),parameter :: zONE = (1d0,0d0),zZero = 0d0
  integer :: Nmax
  integer :: info
  Nmax = NB*NK
!LAPACK ==

  la_full = lattice_a*dble(NK)

! Force
  Fion = 0d0
  do aion = 1,Nion
    do icell=1,NK

! electron-ion interaction ==
      zAt = zF_mat_full(:,:,icell,aion) +2d0*zG_mat_full(:,:,icell,aion)*Uion(icell,aion)

      call zhemm('L','U',Nmax,NK,zONE,zAt,Nmax,zpsi_Ct,Nmax,zZero,zhpsi_Ct_t,Nmax)
      Fion(icell,aion) = Fion(icell,aion) + 2d0*sum(conjg(zpsi_Ct(:,:))*zhpsi_Ct_t(:,:))
!      do ik = 1,NK
!        zCt = matmul(zF_mat_full(:,:,icell,aion),zpsi_Ct(:,ik))
!        zCt = matmul(zAt(:,:),zpsi_Ct(:,ik))
!        Fion(icell,aion) = Fion(icell,aion) + 2d0*sum(conjg(zpsi_Ct(:,ik))*zCt(:))
!      end do

! ion-ion interaction ==
      do icell2 = 1,NK
        do bion=1,Nion
          if(icell2 == icell .and. bion == aion)cycle
          x = Rion(aion) + dble(icell-1)*lattice_a &
            - (Rion(bion) + dble(icell2-1)*lattice_a) &
            + Uion(icell,aion) - Uion(icell2,bion)

          Fion(icell,aion)=Fion(icell,aion) - Zion(aion)*Zion(bion)*( &
        int_pot_drv1_ii(x) + int_pot_drv1_ii(x + la_full) + int_pot_drv1_ii(x - la_full))

!            write(*,"(3I6,e26.16e3)")aion,bion,cion,- 2d0*Zion(bion)*Zion(cion)*( &
!              int_pot_drv1(x) + int_pot_drv1(x + la_full) + int_pot_drv1(x - la_full) &
!              + int_pot_drv1(x + 2d0*la_full) + int_pot_drv1(x - 2d0*la_full) )

        end do
      end do
    end do
  end do

!! zero-force
!  x = sum(Fion)/dble(NK*NB)
!  Fion = Fion -x

  return
end subroutine force_ion


      subroutine ct4h(c1,h2,t4,ect4h)

      implicit double precision(a-h,o-z)

      dimension h2(3,3,3,3),t4(3,3,3,3)

c  this subroutine evaluates the quadrupole-quadrupole
c  electrostatic interaction

      dimension a(15),b(15)

      a(1)=t4(1,1,1,1)*h2(1,1,1,1)
      a(2)=t4(1,1,1,2)*h2(1,1,1,2)*4.d0
      a(3)=t4(1,1,1,3)*h2(1,1,1,3)*4.d0
      a(4)=t4(1,1,2,2)*h2(1,1,2,2)*6.d0
      a(5)=t4(1,1,2,3)*h2(1,1,2,3)*12.d0
      a(6)=t4(1,1,3,3)*h2(1,1,3,3)*6.d0
      a(7)=t4(1,2,2,2)*h2(1,2,2,2)*4.d0
      a(8)=t4(1,2,2,3)*h2(1,2,2,3)*12.d0
      a(9)=t4(1,2,3,3)*h2(1,2,3,3)*12.d0
      a(10)=t4(1,3,3,3)*h2(1,3,3,3)*4.d0
      a(11)=t4(2,2,2,2)*h2(2,2,2,2)
      a(12)=t4(2,2,2,3)*h2(2,2,2,3)*4.d0
      a(13)=t4(2,2,3,3)*h2(2,2,3,3)*6.d0
      a(14)=t4(2,3,3,3)*h2(2,3,3,3)*4.d0
      a(15)=t4(3,3,3,3)*h2(3,3,3,3)

      ect4h=c1*(a(1)+a(2)+a(3)+a(4)+a(5)+a(6)+
     .          a(7)+a(8)+a(9)+a(10)+a(11)+a(12)+
     .          a(13)+a(14)+a(15))

      return
      end


!  cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!  S. Aliabadi                                                          c
!  cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
subroutine vol(xloc, ien)
  use fluid_variables
  implicit none

  integer :: ien(nen,ne)
  real(8) :: xloc(nsd,nn)
  real(8) :: x(nsd,nen)
  real(8) :: eft0,det
  real(8) :: sh(0:nsd,nen)
  real(8) :: xr(nsd,nsd),cf(nsd,nsd),sx(nsd,nsd)
  real(8) :: e_liq,p_liq
  integer :: inl,ie,iq

  p_liq =  0.0

  do ie=1,ne
     do inl=1,nen
        x(:,inl) = xloc(:,ien(inl,ie))
     enddo

     e_liq = 0.0
     do iq=1,nquad
	 	if (nsd==2) then
		    if (nen.eq.3) then !calculate shape function at quad point
			   include "sh2d3n.h"
			elseif (nen.eq.4) then
				include "sh2d4n.h"
			endif
		elseif (nsd==3) then
		    if (nen.eq.4) then !calculate shape function at quad point
			   include "sh3d4n.h"
			elseif (nen.eq.8) then
				include "sh3d8n.h"
			endif
		endif

        eft0 = abs(det) * wq(iq)

        e_liq = e_liq + eft0

     enddo

     p_liq = p_liq + e_liq

  enddo

  liq=p_liq

  return
end subroutine vol


subroutine fpvsx_ad( t, es, t_ad, es_ad, adjoint )
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    fpvsx_ad     forward and adjoint model for saturation vapor pressure
!     prgmmr:    treadon     org: np23                date: 2003-12-18
!
! abstract:  This subroutine contains the forward and ajoint models for the
!            calculation of saturation vapor pressure.
!
! program history log:
!   03-12-18  treadon - initial routine
!   04-06-14  treadon - reformat documenation
!
!   input argument list:
!     t       - temperature
!     t_ad    - partial derivative of vapor pressure with respect to temperature
!     es_ad   - vapor pressure perturbation
!     adjoint - logical flag (.false.=forward model only, .true.=forward and ajoint)
!
!   output argument list:
!     es
!     t_ad    - partial derivative of vapor pressure with respect to temperature
!     es_ad   - vapor pressure perturbation
!
! remarks:
!    The adjoint portion of this routine was generated by the
!    Tangent linear and Adjoint Model Compiler,  TAMC 5.3.0
!
! attributes:
!   language: f90
!   machine:  ibm RS/6000 SP
!
!$$$
!==============================================
! all entries are defined explicitly
!==============================================
  use kinds, only: r_kind
  use constants, only: zero, one, tmix, xai, xbi, xa, xb, ttp, psatk
  implicit none

!==============================================
! define arguments
!==============================================
  logical     ,intent(in   ) :: adjoint
  real(r_kind),intent(inout) :: es_ad
  real(r_kind),intent(inout) :: t_ad
  real(r_kind),intent(  out) :: es
  real(r_kind),intent(in   ) :: t

!==============================================
! define local variables
!==============================================
  real(r_kind) tr_ad
  real(r_kind) w_ad
  real(r_kind) tr
  real(r_kind) w

!----------------------------------------------
! RESET LOCAL ADJOINT VARIABLES
!----------------------------------------------
  tr_ad = zero
  w_ad = zero
!----------------------------------------------
! ROUTINE BODY
!----------------------------------------------
!----------------------------------------------
! FUNCTION AND TAPE COMPUTATIONS
!----------------------------------------------

  tr = ttp/t
  if (t >= ttp) then
     es = psatk*tr**xa*exp(xb*(one-tr))
  else if (t < tmix) then
     es = psatk*tr**xai*exp(xbi*(one-tr))
  else
     w = (t-tmix)/(ttp-tmix)
     es = w*psatk*tr**xa*exp(xb*(one-tr))+(one-w)*psatk*tr**xai* &
          exp(xbi*(one-tr))
  endif
  if (.not.adjoint) return

!----------------------------------------------
! ADJOINT COMPUTATIONS
!----------------------------------------------
  if (t >= ttp) then
     tr_ad = tr_ad+es_ad*((-(psatk*tr**xa*xb*exp(xb*(one-tr))))+psatk*xa* &
          tr**(xa-one)*exp(xb*(one-tr)))
     es_ad = zero
  else if (t < tmix) then
     tr_ad = tr_ad+es_ad*((-(psatk*tr**xai*xbi*exp(xbi*(one-tr))))+psatk* &
          xai*tr**(xai-one)*exp(xbi*(one-tr)))
     es_ad = zero
  else
     tr_ad = tr_ad+es_ad*((-(w*psatk*tr**xa*xb*exp(xb*(one-tr))))+w* &
          psatk*xa*tr**(xa-one)*exp(xb*(one-tr))-(one-w)*psatk*tr**xai*xbi* &
          exp(xbi*(one-tr))+(one-w)*psatk*xai*tr**(xai-one)*exp(xbi*(one-tr)))
     w_ad = w_ad+es_ad*(psatk*tr**xa*exp(xb*(one-tr))-psatk*tr**xai* &
          exp(xbi*(one-tr)))
     es_ad = zero
     t_ad = t_ad+w_ad/(ttp-tmix)
     w_ad = zero
  endif
  t_ad = t_ad-tr_ad*(ttp/(t*t))
  tr_ad = zero

  return
end subroutine fpvsx_ad

subroutine fpvsx_tl( t, es, t_d, es_d )
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    fpvsx_tl     forward and tangent linear model for saturation vapor pressure
!     prgmmr:    kim     org: np23                date: 2012-02-16
!
! abstract:  This subroutine contains the forward and tangent linear models for the
!            calculation of saturation vapor pressure.
!
! program history log:
!   2012-02-16  kim - initial routine based on Russ Treadon's fpvsx_ad subroutine
!
!$$$
!==============================================
! all entries are defined explicitly
!==============================================
  use kinds, only: r_kind
  use constants, only: zero, one, tmix, xai, xbi, xa, xb, ttp, psatk
  implicit none

!==============================================
! define arguments
!==============================================
  real(r_kind),intent(out) :: es_d
  real(r_kind),intent(in) :: t_d
  real(r_kind),intent(  out) :: es
  real(r_kind),intent(in   ) :: t

!==============================================
! define local variables
!==============================================
  real(r_kind) tr_d
  real(r_kind) w_d
  real(r_kind) tr
  real(r_kind) w

!----------------------------------------------
! RESET LOCAL ADJOINT VARIABLES
!----------------------------------------------
  tr_d = zero
  w_d = zero
!----------------------------------------------
! ROUTINE BODY
!----------------------------------------------
!----------------------------------------------
! FUNCTION AND TAPE COMPUTATIONS
!----------------------------------------------

  tr = ttp/t
  tr_d = -ttp*t_d/t**2

  if (t >= ttp) then
     es = psatk*tr**xa*exp(xb*(one-tr))
     es_d = xa*psatk*tr_d*tr**(xa-1)*exp(xb*(one-tr)) &
           -xb*tr_d*psatk*tr**xa*exp(xb*(one-tr))
  else if (t < tmix) then
     es = psatk*tr**xai*exp(xbi*(one-tr))
     es_d = psatk*xai*tr_d*tr**(xai-1)*exp(xbi*(one-tr)) &
           -xbi*tr_d*psatk*tr**xai*exp(xbi*(one-tr))
  else
     w = (t-tmix)/(ttp-tmix)
     w_d = t_d/(ttp-tmix)
     es = w*psatk*tr**xa*exp(xb*(one-tr))+(one-w)*psatk*tr**xai* &
          exp(xbi*(one-tr))
     es_d = w_d*psatk*tr**xa*exp(xb*(one-tr)) + w*psatk*xa*tr_d*tr**(xa-1)*exp(xb*(one-tr)) &
           -xb*tr_d*w*psatk*tr**xa*exp(xb*(one-tr)) &
           -w_d*psatk*tr**xai*exp(xbi*(one-tr)) &
           +(one-w)*psatk*xai*tr_d*tr**(xai-1)*exp(xbi*(one-tr)) &
           -xbi*tr_d*(one-w)*psatk*tr**xai*exp(xbi*(one-tr))
  endif
RETURN
END subroutine fpvsx_TL


module ek_solver_scalapack_all_m
  use mpi
  use ek_descriptor_parameters_m
  use ek_distribute_matrix_m, only : &
       get_local_cols, gather_matrix, allgather_row_wise, setup_distributed_matrix, &
       distribute_global_sparse_matrix
  use ek_eigenpairs_types_m, only : ek_eigenpairs_types_union_t
  use ek_event_logger_m, only : add_event
  use ek_generalized_to_standard_m, only : reduce_generalized, recovery_generalized
  use ek_processes_m, only : check_master, ek_process_t, terminate
  use ek_matrix_io_m, only : ek_sparse_mat_t
  implicit none

  private
  public :: eigen_solver_scalapack_all, solve_with_general_scalapack

contains

  subroutine eigen_solver_scalapack_all(proc, desc_A, A, eigenpairs)
    type(ek_process_t) :: proc
    integer, intent(in) :: desc_A(9)
    double precision, intent(in) :: A(:, :)
    type(ek_eigenpairs_types_union_t), intent(out) :: eigenpairs

    integer :: ierr, info
    integer :: dim, work_size, iwork_size, diag_size, subdiag_size
    integer :: eigenvectors_local_cols

    character(len = 1) :: uplo, side

    double precision, allocatable :: diag_local(:), subdiag_local(:)
    double precision, allocatable :: subdiag_global(:)
    double precision, allocatable :: tau(:), work(:), work_print(:)
    integer, allocatable :: iwork(:)
    double precision :: time_start, time_start_part, time_end
    integer :: numroc

    time_start = mpi_wtime()
    time_start_part = time_start

    eigenpairs%type_number = 2

    dim = desc_A(rows_)
    diag_size = numroc(dim, desc_A(block_col_), proc%my_proc_col, 0, proc%n_procs_col)
    subdiag_size = numroc(dim - 1, desc_A(block_col_), proc%my_proc_col, 0, proc%n_procs_col)
    work_size = max(desc_A(block_row_) * (desc_A(local_rows_) + 1), 3 * desc_A(block_row_))

    allocate(diag_local(diag_size), subdiag_local(subdiag_size), tau(diag_size), &
         work(work_size), work_print(desc_A(block_row_)), stat = ierr)
    if (ierr /= 0) then
      call terminate('eigen_solver_scalapack_all: allocation failed', ierr)
    end if

    time_end = mpi_wtime()
    call add_event('eigen_solver_scalapack_all:allocate', time_end - time_start_part)
    time_start_part = time_end

    uplo = 'l'
    call pdsytrd(uplo, dim, A, 1, 1, desc_A, diag_local, subdiag_local, tau, work, work_size, info)
    deallocate(work)
    if (proc%my_rank == 0) then
       print '("info(pdsytrd): ", i0)', info
    end if

    time_end = mpi_wtime()
    call add_event('eigen_solver_scalapack_all:pdsytrd', time_end - time_start_part)
    time_start_part = time_end

    ! Diagonal elements of the tridiagonal matrix Initially
    allocate(eigenpairs%blacs%values(dim), subdiag_global(dim - 1), stat = ierr)
    if (ierr /= 0) then
      call terminate('eigen_solver_scalapack_all: allocation failed', ierr)
    end if

    call allgather_row_wise(diag_local, proc%context, desc_A(block_col_), &
         eigenpairs%blacs%values)
    call allgather_row_wise(subdiag_local, proc%context, desc_A(block_col_), &
         subdiag_global)

    call setup_distributed_matrix('Eigenvectors', proc, dim, dim, &
         eigenpairs%blacs%desc, eigenpairs%blacs%Vectors, desc_A(block_row_))
    eigenvectors_local_cols = get_local_cols(proc, eigenpairs%blacs%desc)

    work_size = 6 * dim + 2 * eigenpairs%blacs%desc(local_rows_) * &
         eigenvectors_local_cols
    iwork_size = 2 + 7 * dim + 8 * proc%n_procs_col
    allocate(work(work_size), iwork(iwork_size), stat = ierr)
    if (ierr /= 0) then
      call terminate('eigen_solver_scalapack_all: allocation failed', ierr)
    end if

    time_end = mpi_wtime()
    call add_event('eigen_solver_scalapack_all:gather1', time_end - time_start_part)
    time_start_part = time_end

    call pdstedc('i', dim, eigenpairs%blacs%values, subdiag_global, &
         eigenpairs%blacs%Vectors, 1, 1, eigenpairs%blacs%desc, &
         work, work_size, iwork, iwork_size, info)
    if (proc%my_rank == 0) then
       print '("info(pdstedc): ", i0)', info
    end if

    time_end = mpi_wtime()
    call add_event('eigen_solver_scalapack_all:pdstedc', time_end - time_start_part)
    time_start_part = time_end

    side = 'l'
    work_size = work_size_for_pdormtr(side, uplo, dim, dim, 1, 1, 1, 1, desc_A, eigenpairs%blacs%desc)
    deallocate(work)
    allocate(work(work_size), stat = ierr)
    if (ierr /= 0) then
      call terminate('eigen_solver_scalapack_all: allocation failed', ierr)
    end if

    call pdormtr(side, uplo, 'n', dim, dim, A, 1, 1, desc_A, tau, &
         eigenpairs%blacs%Vectors, 1, 1, eigenpairs%blacs%desc, work, work_size, info)
    if (proc%my_rank == 0) then
       print '("info(pdormtr): ", i0)', info
    end if

    time_end = mpi_wtime()
    call add_event('eigen_solver_scalapack_all:pdormtr', time_end - time_start_part)
    call add_event('eigen_solver_scalapack_all', time_end - time_start)
  end subroutine eigen_solver_scalapack_all

  subroutine solve_with_general_scalapack(n, proc, matrix_A, eigenpairs, matrix_B)
    integer, intent(in) :: n
    type(ek_process_t), intent(in) :: proc
    type(ek_sparse_mat_t), intent(in) :: matrix_A
    type(ek_sparse_mat_t), intent(in) :: matrix_B
    type(ek_eigenpairs_types_union_t), intent(out) :: eigenpairs

    integer :: desc_A(desc_size), desc_B(desc_size)
    double precision, allocatable :: matrix_A_dist(:, :), matrix_B_dist(:, :)
    double precision :: time_start, time_start_part, time_end

    time_start = mpi_wtime()
    time_start_part = time_start

    call setup_distributed_matrix('A', proc, n, n, desc_A, matrix_A_dist)
    call setup_distributed_matrix('B', proc, n, n, desc_B, matrix_B_dist)
    call distribute_global_sparse_matrix(matrix_A, desc_A, matrix_A_dist)
    call distribute_global_sparse_matrix(matrix_B, desc_B, matrix_B_dist)

    time_end = mpi_wtime()
    call add_event('solve_with_general_scalapack:setup_matrices', time_end - time_start_part)
    time_start_part = time_end

    call reduce_generalized(n, matrix_A_dist, desc_A, matrix_B_dist, desc_B)

    time_end = mpi_wtime()
    call add_event('solve_with_general_scalapack:reduce_generalized', time_end - time_start_part)
    time_start_part = time_end

    call eigen_solver_scalapack_all(proc, desc_A, matrix_A_dist, eigenpairs)

    time_end = mpi_wtime()
    call add_event('solve_with_general_scalapack:eigen_solver_scalapack_all', time_end - time_start_part)
    time_start_part = time_end

    call recovery_generalized(n, n, matrix_B_dist, desc_B, &
         eigenpairs%blacs%Vectors, eigenpairs%blacs%desc)

    time_end = mpi_wtime()
    call add_event('solve_with_general_scalapack:recovery_generalized', time_end - time_start_part)
    call add_event('solve_with_general_scalapack', time_end - time_start)
  end subroutine solve_with_general_scalapack

  integer function work_size_for_pdormtr(side, uplo, m, n, ia, ja, ic, jc, desc_A, desc_C) result(size)
    character(len = 1), intent(in) :: side, uplo
    integer, intent(in) :: m, n, ia, ja, ic, jc
    integer, intent(in) :: desc_A(9), desc_C(9)
    integer :: context, n_procs_row, n_procs_col, my_proc_row, my_proc_col
    integer :: mb_a, nb_a, mb_c, nb_c
    integer :: iaa, jaa, icc, jcc
    integer :: lcmq, npa0 , mpc0, nqc0
    integer :: iroffa, icoffa, iarow, iroffc, icoffc, icrow, iccol
    integer :: mi, ni
    logical :: is_upper, is_left

    integer :: numroc, indxg2p, ilcm
    logical :: lsame

    is_upper = lsame(uplo, 'U')
    is_left = lsame(side, 'L')

    mb_a = desc_A(5)
    nb_a = desc_A(6)
    mb_c = desc_C(5)
    nb_c = desc_C(6)

    context = desc_A(2)
    call blacs_gridinfo(context, n_procs_row, n_procs_col, my_proc_row, my_proc_col)

    if (is_upper) then
      iaa = ia
      jaa = ja + 1
      icc = ic
      jcc = jc
    else
      iaa = ia + 1
      jaa = ja
      if (is_left) then
        icc = ic + 1
        jcc = jc
      else
        icc = ic
        jcc = jc + 1
      end if
    end if

    if (is_left) then
      mi = m - 1
      ni = n
    else
      mi = m
      ni = n - 1
    end if

    iroffc = mod(icc - 1, mb_c)
    icoffc = mod(jcc - 1, nb_c)
    icrow = indxg2p(icc, mb_c, my_proc_row, desc_C(7), n_procs_row)
    iccol = indxg2p(jcc, nb_c, my_proc_col, desc_C(8), n_procs_col)

    mpc0 = numroc(mi + iroffc, mb_c, my_proc_row, icrow, n_procs_row)
    nqc0 = numroc(ni + icoffc, nb_c, my_proc_col, iccol, n_procs_col)

    if (is_left) then
      size = max((nb_a * (nb_a - 1)) / 2, (nqc0 + mpc0) * nb_a) + nb_a * nb_a
    else
      iroffa = mod(iaa - 1, mb_a)
      icoffa = mod(jaa - 1, nb_a)
      iarow = indxg2p(iaa, mb_a, my_proc_row, desc_A(7), n_procs_row)
      npa0 = numroc(ni + iroffa, mb_a, my_proc_row, iarow, n_procs_row)
      lcmq = ilcm(n_procs_row, n_procs_col) / n_procs_col
      size = max((nb_a * (nb_a - 1)) / 2, &
           (nqc0 + max(npa0 + numroc(numroc(ni + icoffc, nb_a, 0, 0, n_procs_col), &
           nb_a, 0, 0, lcmq), mpc0)) * nb_a) + &
           nb_a * nb_a
    end if
  end function work_size_for_pdormtr
end module ek_solver_scalapack_all_m


      SUBROUTINE DCONVO(ITYPE,BUFIN,NSAMPS,FILTER,NPTS,OBUF,NOUT)
c   Double Precision convo
C     CONVO PERFORMS TIME DOMAIN CONVOLUTION AND CORRELATION BETWEEN ARRAYS
C BUFIN AND FILTER.  THE OUTPUT IS RETURNED IN OBUF AND IS  VARIABLE IN LENGTH
C DEPENDING ON THE TYPE OF OPERATION REQUESTED.
C
C ARGUMENTS:
C        ITYPE  - TYPE OF CONVOLUTION OR CORRRELATION DESIGNATOR.
C               =-1,  FULL CONVOLUTION.  THE TIME REFERENCE OF THE FIRST OUTPUT
C                     POINT IS T1+T2, WHERE T1 IS THE TIME OF THE FIRST SAMPLE
C                     IN BUFIN AND T2 IS THE TIME OF THE FIRST SAMPLE IN ARRAY
C                     FILTER.  E.G.  IF A ZERO PHASE FILTER HAS TIME POINTS -19
C                     TO +19 AND THE FIRST SAMPLE IN BUFIN IS AT TIME 0, THEN
C                     THE TIME OF THE FIRST OUTPUT SAMPLE IS -19.
C               =+1,  FULL CORRELATION.  BOTH POSITIVE AND NEGATIVE LAGS ARE
C                     COMPUTED.  CORRELATIONS ARE EVEN FUNCTIONS, THEREFORE HALF
C                     CORRELATIONS GIVE THE SAME INFORMATION AND SHOULD BE USED
C                     MOST OF THE TIME.
C               =+2,  HALF CORRELATION.  ONLY THE RIGHT HALF OF THE CORRELATION
C                     IS PERFORMED..
C        BUFIN  - INPUT ARRAY TO BE FILTERED (CONVOLVED) OR CORRELATED.
C        NSAMPS - THE NUMBER OF SAMPLES IN BUFIN TO FILTER.
C        FILTER - AN ARRAY OF REAL FILTER WEIGHTS.  AN ARRAY OF VALUES TO BE
C                 CORRELATED.
C        MPTS   - THE NUMBER OF POINTS IN THE FILTER ARRAY.
C        OBUF   - THE OUTPUT ARRAY.
C        NOUT   - THE NUMBER OF OUTPUT SAMPLES TO GENERATE.  FOR CONVOLUTION
C                 THIS SHOULD NORMALLY BE MSAMPS+MPTS.  FOR CORRELATION THIS IS
C                 THE NUMBER OF LAGS TO OUTPUT, IT MIGHT BE  MIN0(MSAMPS,MPTS).
C
C   NOTE:  LEADING AND TRAILING ZEROES DO NOT HAVE TO BE GIVEN.
C
C
C  WRITTEN AND COPYRIGHTED BY:
C  PAUL HENKART, SCRIPPS INSTITUTION OF OCEANOGRAPHY, FEBRUARY 1979
C  ALL RIGHTS ARE RESERVED BY THE AUTHOR.  PERMISSION TO COPY OR REPRODUCE THIS
C  SUBROUTINE, BY COMPUTER OR OTHER MEANS, MAY BE OBTAINED ONLY FROM THE AUTHOR.
      REAL*8 temp
      DIMENSION BUFIN(nsamps),FILTER(npts),OBUF(nout)
      NEXTM=1                                                           ! /* THE INDEX TO THE FIRST FILTER POINT
      I=0
      IF( IABS(ITYPE) .EQ. 1 ) THEN
C****
C****    DO THE FRONT TAPER IF A FULL CONVOLUTION/CORRELATION
C****
          M = NPTS - 1
          IF( ITYPE .LE. 0 ) THEN
              DO 50 N1 = 1, M                                           ! convolution
                 I = I + 1
                 TEMP = 0.
                 DO 40 N2 = 1, N1
                    TEMP = TEMP + BUFIN(N2) * FILTER(N1+1-N2)           ! /*  CONVOLUTION
   40            CONTINUE
                 obuf(i) = temp
   50         CONTINUE
          ELSE
              DO 70 N1 = 1, M                                               ! correlation
                 I = I + 1
                 TEMP = 0.
                 DO 60 N2 = 1, N1
                    TEMP = TEMP + BUFIN(N2) * FILTER(npts-n1-N2)
   60            CONTINUE
                 obuf(i) = temp
   70         CONTINUE
          ENDIF
      ENDIF
C****
C****  DO THE CONVOLUTION OR CORRELATION
C****
      I = I + 1
      JJ = 0
      IF( ITYPE .GE. 0 )THEN
          K = NPTS -1
          IF( ITYPE .EQ. 2 ) JJ = NPTS - 1
          INC = -1
      ELSE
          K = 0
          INC = 1
      ENDIF
      IF( inc .GT. 0 ) THEN
          DO 100 ii = i, nout
             J = K
             TEMP = 0.
             M = NEXTM
             jjj = ii + jj
             DO 90 j = k, npts - 1
                TEMP = TEMP + BUFIN(jjj-J) * FILTER(M)
                M = M + 1
   90        CONTINUE
             obuf(ii) = temp
             IF( ii .GE. nsamps) THEN
                 k = k + inc
                 nextm = nextm + 1
             ENDIF
  100     CONTINUE
      ELSE
          DO 150 ii = i, nout
             J = K
             TEMP = 0.
             M = NEXTM
             jjj = ii + jj
             DO 140 j = k, ii-1, inc
                TEMP = TEMP + BUFIN(jjj-J) * FILTER(M)
                M = M + 1
  140        CONTINUE
             obuf(ii) = temp
             IF( ii .GE. nsamps) THEN
                 k = k + inc
                 nextm = nextm + 1
             ENDIF
  150     CONTINUE
      ENDIF
      RETURN
      END