module mod_vtrans
!$$$   module documentation block
!                .      .    .                                       .
! module:    mod_vtrans      contains all routines for vertical modes
!
!   prgmmr: parrish          org: np23                date: 2006-06-26
!
! abstract:  contains routines and variables for vertical mode
!            generation and use in vertical transforms
!
! program history log:
!   2006-06-26
!   2007-05-08   kleist - finish vertical coordinate generalization
!   2011-07-04  todling  - fixes to run either single or double precision
!   2012-11-19  parrish - compute vertical mode information on pe 0 only, and
!                          then broadcast results to other processors.
!                          This fixes a problem with reproducibility encountered on tide.
!   2012-12-18  parrish - problem with reproducibility reappeared.  Even with all vertical mode
!                           computations done on pe 0, the library routine dgeev supplied on the WCOSS
!                           machine uses threading internally in ways that prevent reproducibility,
!                           even when computation is nominally restricted to one processor.  To fix this,
!                           available local subroutines within gsi src directory have been used in place of
!                           dgeev.  Subroutine eigen, located in raflib.f90, computes eigenvalues and
!                           eigenvectors of symmetric matrices.  The matrix qmat is not symmetric, but a
!                           rescaling produces an almost symmetric matrix.  The symmetric average of the
!                           rescaled qmat has eigenvalues and eigenvectors that differ from those of qmat
!                           by only a few percent.  Using these as starting values, inverse iteration can
!                           retrieve the desired eigenvalues and eigenvectors of qmat.  To reproduce the
!                           eigenvalues and eigenvectors of qmat obtained from dgeev to 15 digits, the
!                           inverse iteration refinement of the starting eigenvalues and eigenvectors is
!                           done in quad precision.  This requires a quad precision matrix inversion
!                           routine.  A copy of subroutine iminv in get_semimp_mats.f90 has been copied
!                           on the end of this module and given the name iminv_quad.  This is also used
!                           to get the inverse of qmat, instead of the previous method which was to
!                           construct the inverse of qmat from its eigenvalues and eigenvectors.  This
!                           required all of the eigenvalues and eigenvectors, which dgeev provided.
!                           However, by using iminv_quad, now only the first nvmodes_keep eigenvectors and
!                           eigenvalues need be computed.  The complete computation if the eigenvectors
!                           and eigenvalues without using dgeev uses less than 2 seconds for 8
!                           eigenvalue/vectors and all related computations.
!   2018-02-15  wu       - add code for fv3_regional option
!
! subroutines included:
!   sub init_vtrans              - initialize vertical mode related variables
!   sub create_vtrans            - allocate and load vert mode variables
!   sub destroy_vtrans           - deallocate vert mode variables
!   sub getabc                   -
!   sub vtrans_inv               - physical space u,v,T,p --> vert transformed u,v,phi
!   sub vtrans_inv_ad            - adjoint of vtrans_inv
!   sub vtrans                   - vert transformed u,v,phi --> physical space u,v,T,p
!   sub vtrans_ad                - adjoint of vtrans
!
! Variable Definitions:
!   def nvmodes_keep             - number of vertical modes to keep ( <= nsig )
!   def speeds                   - phase speeds of vertical modes
!   def vmodes                   - vertical modes
!   def dualmodes                - dual vertical modes
!   def phihat2t                 - matrix operator to convert phihat to T
!
! attributes:
!   language: f90
!   machine:  ibm RS/6000 SP
!
!$$$ end documentation block

  use kinds,only: r_kind,i_kind
  implicit none

! set default to private
  private
! set subroutines to public
  public :: init_vtrans
  public :: create_vtrans
  public :: destroy_vtrans
  public :: getabc
  public :: vtrans_inv
  public :: vtrans_inv_ad
  public :: vtrans
  public :: vtrans_ad
! set passed variables to public
  public :: nvmodes_keep,depths,speeds

  integer(i_kind) nvmodes_keep
  real(r_kind),dimension(:),allocatable:: depths,speeds
  real(r_kind),dimension(:,:),allocatable:: vmodes,phihat2t,dualmodes
  real(r_kind),dimension(:,:),allocatable:: t2phihat
  real(r_kind),dimension(:),allocatable:: p2phihat,phihat2p

  character(len=*),parameter::myname='mod_vtrans'

contains

  subroutine init_vtrans
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    init_vtrans     set default values for vtrans variables
!   prgmmr: parrish         org: np23                date: 2006-06-26
!
! abstract: set default values for vtrans variables
!
! program history log:
!   2006-06-26  parrish
!
!   input argument list:
!
!   output argument list:
!
! attributes:
!   language: f90
!   machine:  ibm RS/6000 SP
!
!$$$ end documentation block
    implicit none

    nvmodes_keep=0

  end subroutine init_vtrans

  subroutine create_vtrans(mype)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    create_vtrans   get vertical functions for dynamic constraint
!   prgmmr: parrish        org: np23         date:  2006-06-26
!
! abstract:  using linearization of dynamics about rest state, derive
!             coupling matrix and obtain eigenvectors/values
!             (linearization follows Juang, 2005, NCEP Office Note 445)
!            The conversion from mass variable to T,p follows the
!            Machenhauer-Phillips approach, pointed out by R. Errico
!            in a conversation on 7-11-2006.
!
!           Briefly, the linear equations used to define the vertical
!            modes are
!
!             dD/dt = -laplacian ( H*p + A*T )                          (1)
!
!             dT/dt = -B*D                                              (2)
!
!             dp/dt = -S*D                                              (3)
!
!                 where D is divergence, p is surface pressure, T is virtual temperature,
!
!                    and the matrices H, A, B, S are as defined in ON 445.
!
!           Taking the time derivative of (1) and substituting from (2) and (3)
!           yields an equation for just divergence,
!
!              d2D/dt2 = -Q * laplacian(D)
!
!                 Q = H*S + A*B
!
!           The vertical modes are the right eigenvectors of Q and the
!           scale geopotential values for each vertical mode are the eigenvalues of Q.
!
!                 Q = U*E*V(transpose)
!
!           To transform from physical space to vertical modes, first form
!           the mass variable
!
!                 M = H*p + A*T
!
!           Then the transform variables are
!
!            (Mhat,uhat,vhat) = V(transpose)*(M,u,v)
!
!           To return from mode space to physical space, we have
!
!             (M,u,v) = U*(Mhat,uhat,vhat)
!
!           Finally, to get T,p from M using the Machenhauer-Phillips approach,
!
!              T = B*Q**(-1)*M
!
!              p = S*Q**(-1)*M
!
!           The above is only strictly valid for T and p small perturbations in gravity modes
!           only, but that is the application for which this code is intended.
!
!
! program history log:
!   2006-06-26  parrish
!   2007-02-26  yang    - replace IBM subroutine of dgeev by GSI dgeev
!   2010-04-01  treadon - move strip to gridmod
!   2012-11-19  parrish - compute vertical mode information on pe 0 only, and
!                          then broadcast results to other processors.
!                          This fixes a problem with reproducibility encountered on tide.
!   2012-12-18  parrish - substantial rewrite of this code to allow use of all local code.
!                          r_quad precision has been used in eigenvalue/eigenvector computation
!                          to get agreement with eigenvalues/eigenvectors from library routine dgeev,
!                          which has been replaced in this version.  It appears that reproducibility
!                          has been restored.  (See more extensive comment at top of this module.)
!   2013-10-19  todling - metguess now holds background
!
!
! usage:
!   input argument list:
!       mype     - current processor number
!
!   output argument list:
!
! attributes:
!   language: f90
!   machine:  ibm RS/6000 SP
!
!$$$ end documentation block
    use kinds, only: r_quad
    use constants,only: zero,one,one_tenth,ten
    use gridmod,only: lat2,lon2,nsig,nlat,nlon
    use mpimod,only: mpi_rtype,mpi_comm_world,ierror,mpi_integer
    use guess_grids, only: ntguessig
    use general_sub2grid_mod, only: general_sub2grid
    use general_commvars_mod, only: g1
    use gsi_metguess_mod, only: gsi_metguess_bundle
    use gsi_bundlemod, only: gsi_bundlegetpointer
    use mpeu_util, only: die
    use gsi_io, only: verbose
    implicit none

!   Declare passed variables
    integer(i_kind),intent(in   ) :: mype

!   Declare local variables
    character(len=*),parameter::myname_=myname//'*create_vtrans'
    integer(i_kind) i,j,k,n
    real(r_kind) count,psbar
    real(r_kind) sum
    real(r_kind),dimension(1,lat2,lon2,1):: worksub
    real(r_kind),allocatable,dimension(:,:,:,:):: hwork
    real(r_kind),dimension(nsig+1)::pbar
    real(r_kind),dimension(nsig)::tbar
    real(r_kind),dimension(nsig+1)::ahat,bhat,chat
    real(r_kind),dimension(nsig)::hmat,smat,sqmatinv
    real(r_kind),dimension(nsig,nsig)::amat,bmat,qmat,qmatinv,bqmatinv
    real(r_kind),allocatable,dimension(:):: swww,swwwd
    real(r_kind),allocatable,dimension(:,:):: szzz,szzzd
    integer(i_kind),allocatable:: numlevs(:)
    real(r_kind),dimension(:,:  ),pointer:: ges_ps_nt=>NULL()
    real(r_kind),dimension(:,:,:),pointer:: ges_tv_nt=>NULL()
    integer(i_kind) workpe,ier,istatus
    integer(i_kind) lpivot(nsig),mpivot(nsig)
    real(r_quad) qmatinv_quad(nsig,nsig),detqmat_quad
    logical print_verbose

!   get work pe:

    print_verbose=.false.
    allocate(numlevs(0:g1%npe-1))
    numlevs(0:g1%npe-1)=g1%kend(0:g1%npe-1)-g1%kbegin(0:g1%npe-1)+1
    if(g1%mype==0) then
        workpe=-1
        do i=0,g1%npe-1
   !       write(6,*)' i,numlevs(i)=',i,numlevs(i)
           if(numlevs(i)==1) workpe=i
        end do
   !    write(6,*)' workpe=',workpe
    end if
    call mpi_bcast(workpe,1,mpi_integer,0,mpi_comm_world,ierror)
   !write(6,*)' mype,workpe=',mype,workpe
    if(verbose .and. g1%mype==workpe) print_verbose=.true.

!    obtain vertical coordinate constants ahat,bhat,chat
    if(g1%mype==workpe) call getabc(ahat,bhat,chat)

!   get global mean T and ps

    allocate(hwork(g1%inner_vars,g1%nlat,g1%nlon,g1%kbegin_loc:g1%kend_alloc))

!   count:
!  Not clear if area weighting would be better.
    count=one/float(nlat*nlon)

    ier=0
    call gsi_bundlegetpointer (gsi_metguess_bundle(ntguessig),'ps',ges_ps_nt, istatus)
    ier=ier+istatus
    call gsi_bundlegetpointer (gsi_metguess_bundle(ntguessig),'tv',ges_tv_nt, istatus)
    ier=ier+istatus
    if(ier/=0) call die(myname_,'missing require variables, ier=', ier)

!   psbar:

    do j=1,lon2
       do i=1,lat2
          worksub(1,i,j,1)=ges_ps_nt(i,j)
       end do
    end do
    call general_sub2grid(g1,worksub,hwork)
    if(g1%mype==workpe) then
       psbar=zero
       do j=1,nlon
          do i=1,nlat
             psbar=psbar+hwork(1,i,j,1)
          end do
       end do
       psbar=ten*count*psbar
       do k=1,nsig+1
          pbar(k)=ahat(k)+bhat(k)*psbar     !  + chat(k)*(T/T0)**(1/kappa)   --- add later
       end do
    end if

!   tbar:

    do k=1,nsig
       do j=1,lon2
          do i=1,lat2
             worksub(1,i,j,1)=ges_tv_nt(i,j,k)
          end do
       end do
       call general_sub2grid(g1,worksub,hwork)
       if(g1%mype==workpe) then
          tbar(k)=zero
          do j=1,nlon
             do i=1,nlat
                tbar(k)=tbar(k)+hwork(1,i,j,1)
             end do
          end do
          tbar(k)=count*tbar(k)
       end if
    end do

    if(print_verbose) then
       do k=1,nsig
          write(6,'(" k,pbar,tbar = ",i5,2f18.9)')k,pbar(k),tbar(k)
       end do
       k=nsig+1
       write(6,'(" k,pbar      = ",i5,f18.9)')k,pbar(k)
    end if

!    allocate variables used in vertical mode transformations:

    allocate(depths(nvmodes_keep),speeds(nvmodes_keep))
    allocate(vmodes(nsig,nvmodes_keep),dualmodes(nsig,nvmodes_keep))
    allocate(phihat2t(nsig,nvmodes_keep),phihat2p(nvmodes_keep))
    allocate(p2phihat(nvmodes_keep),t2phihat(nsig,nvmodes_keep))

if(mype==workpe) then    ! BEGIN MYPE=workpe SECTION !!!!!!!!!!!!!

    hmat=zero ; smat=zero ; amat=zero ; bmat=zero

! Get matrices for variable transforms/vertical modes
    call get_semimp_mats(tbar,pbar,bhat,chat,amat,bmat,hmat,smat)

!   qmat = hmat*smat + amat*bmat

    do j=1,nsig
       do i=1,nsig
          qmat(i,j)=hmat(i)*smat(j)
          do k=1,nsig
             qmat(i,j)=qmat(i,j)+amat(i,k)*bmat(k,j)
          end do
       end do
    end do

!  get inverse of Q using iminv_quad

    qmatinv_quad=qmat
    call iminv_quad(qmatinv_quad,nsig,detqmat_quad,lpivot,mpivot)
    qmatinv=qmatinv_quad

!   check inverse

 !errormax=zero
 !do j=1,nsig
 !   do i=1,nsig
 !      sum=zero
 !      if(i==j) sum=-one
 !      do k=1,nsig
 !         sum=sum+qmat(i,k)*qmatinv(k,j)
 !      end do
 !      errormax=max(abs(sum),errormax)
 !   end do
 !end do
 !write(6,*)' error in qmatinv =',errormax

!     next get eigenvalues and eigenvectors.

   allocate(swww(nvmodes_keep),swwwd(nvmodes_keep))
   allocate(szzz(nsig,nvmodes_keep),szzzd(nsig,nvmodes_keep))
   call special_eigvv(qmat,hmat,smat,nsig,swww,szzz,swwwd,szzzd,nvmodes_keep)

   do k=1,nvmodes_keep
      depths(k)=swww(k)
      speeds(k)=sqrt(depths(k))
      do j=1,nsig
         vmodes(j,k)=szzz(j,k)
         dualmodes(j,k)=szzzd(j,k)
      end do
   end do

!   next compute p2phihat and t2phihat

  t2phihat=zero
  p2phihat=zero
  do n=1,nvmodes_keep
     do k=1,nsig
        do j=1,nsig
           t2phihat(k,n)=t2phihat(k,n)+szzzd(j,n)*amat(j,k)
        end do
        p2phihat(n)=p2phihat(n)+szzzd(k,n)*hmat(k)
     end do
  end do
  p2phihat=ten*p2phihat ! in this code, p is in units of mb, but in gsi, p is in cb -- change later

!   finally compute phihat2p, phihat2t

  do j=1,nsig
     do i=1,nsig
        bqmatinv(i,j)=zero
        do k=1,nsig
           bqmatinv(i,j)=bqmatinv(i,j)+bmat(i,k)*qmatinv(k,j)
        end do
     end do
  end do
  do j=1,nsig
     sqmatinv(j)=zero
     do i=1,nsig
        sqmatinv(j)=sqmatinv(j)+smat(i)*qmatinv(i,j)
     end do
  end do

  do j=1,nvmodes_keep
     sum=zero
     do k=1,nsig
        sum=sum+sqmatinv(k)*szzz(k,j)
     end do
     phihat2p(j)=sum
     do i=1,nsig
        sum=zero
        do k=1,nsig
           sum=sum+bqmatinv(i,k)*szzz(k,j)
        end do
        phihat2t(i,j)=sum
     end do
  end do
  phihat2p=one_tenth*phihat2p ! local units are mb, but gsi units are cb--fix later
end if  ! END MYPE=workpe SECTION !!!!!!!!!!!!!

!  BROADCAST RESULTS FROM ABOVE SECTION TO ALL PES

    call mpi_bcast(depths,nvmodes_keep,mpi_rtype,workpe,mpi_comm_world,ierror)
    call mpi_bcast(speeds,nvmodes_keep,mpi_rtype,workpe,mpi_comm_world,ierror)
    call mpi_bcast(vmodes,nsig*nvmodes_keep,mpi_rtype,workpe,mpi_comm_world,ierror)
    call mpi_bcast(phihat2t,nsig*nvmodes_keep,mpi_rtype,workpe,mpi_comm_world,ierror)
    call mpi_bcast(dualmodes,nsig*nvmodes_keep,mpi_rtype,workpe,mpi_comm_world,ierror)
    call mpi_bcast(t2phihat,nsig*nvmodes_keep,mpi_rtype,workpe,mpi_comm_world,ierror)
    call mpi_bcast(p2phihat,nvmodes_keep,mpi_rtype,workpe,mpi_comm_world,ierror)
    call mpi_bcast(phihat2p,nvmodes_keep,mpi_rtype,workpe,mpi_comm_world,ierror)

  end subroutine create_vtrans

  subroutine destroy_vtrans
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    destroy_vtrans   remove space used by vtrans routines
!   prgmmr: parrish        org: np23         date:  2006-06-26
!
! abstract:  remove space used in vertical mode transformations
!
! program history log:
!   2006-06-26  parrish
!
!
! usage:
!   input argument list:
!
!   output argument list:
!
! attributes:
!   language: f90
!   machine:  ibm RS/6000 SP
!
!$$$ end documentation block
    implicit none

!    deallocate variables used in vertical mode transformations:

    deallocate(depths,speeds,vmodes,dualmodes)
    deallocate(phihat2t,phihat2p,p2phihat,t2phihat)

  end subroutine destroy_vtrans

  subroutine getabc(ahat,bhat,chat)
!$$$  subprogram documentation block
!
! subprogram:    getabc       get pressure constants
!
!   prgmmr: parrish          org: np22                date: 2006-05-04
!
! abstract: return constants used to get 3d pressure field at interfaces based on
!            generalized vertical coordinate
!
! program history log:
!   2006-05-04  kleist
!   2010-12-17  pagowski - add cmaq
!
! usage:
!   input argument list:
!
!   output argument list:
!     ahat       -   p(i,j,k)  = ahat(k) + bhat(k)*psfc(i,j)+chat(k)*(T(i,j,k)/T0(k))**(1/kappa)
!     bhat       -
!     chat       -
!
!$$$ end documentation block
    use constants,only: zero,ten
    use gridmod,only: nsig,ak5,bk5,ck5,fv3_regional
    use gridmod,only: wrf_nmm_regional,nems_nmmb_regional,eta1_ll,eta2_ll,pdtop_ll,pt_ll,cmaq_regional
    implicit none

!   Declare passed variables
    real(r_kind),dimension(nsig+1),intent(  out) :: ahat,bhat,chat

!   Declare local variables
    integer(i_kind) k

    if(wrf_nmm_regional.or.nems_nmmb_regional.or.cmaq_regional) then
       do k=1,nsig+1
          ahat(k)=eta1_ll(k)*pdtop_ll-eta2_ll(k)*(pdtop_ll+pt_ll)+pt_ll
          bhat(k)=eta2_ll(k)
          chat(k)=zero
       end do
    elseif(fv3_regional) then
       do k=1,nsig+1
          ahat(k)=eta1_ll(k)*0.01_r_kind
          bhat(k)=eta2_ll(k)
          chat(k)=zero
       end do
    else
       do k=1,nsig+1
          ahat(k)=ak5(k)*ten
          bhat(k)=bk5(k)
          chat(k)=ck5(k)*ten
       end do
    end if

    return
  end subroutine getabc

  subroutine vtrans_inv(uhat,vhat,phihat,u,v,t,p)
!$$$  subprogram documentation block
!                .      .    .
! subprogram:    vtrans_inv
!
!   prgrmmr:
!
! abstract:
!
! program history log:
!   2008-05-29  safford -- add subprogram doc block
!
!   input argument list:
!     uhat,vhat,phihat
!
!   output argument list:
!     u,v,t
!     p
!
! attributes:
!   language:  f90
!   machine:   ibm RS/6000 SP
!
!$$$ end documentation block

    use gridmod,only: lat2,lon2,nsig
    use constants,only: zero
    implicit none

    real(r_kind),dimension(lat2,lon2,nvmodes_keep),intent(in   ) :: uhat,vhat,phihat
    real(r_kind),dimension(lat2,lon2,nsig)        ,intent(  out) :: u,v,t
    real(r_kind),dimension(lat2,lon2)             ,intent(  out) :: p

    integer(i_kind) i,j,k,n

!$omp parallel do schedule(dynamic,1) private(n,i,j,k)
    do k=1,nsig
       do n=1,nvmodes_keep
          do j=1,lon2
             do i=1,lat2
                u(i,j,k)=u(i,j,k)+vmodes(k,n)*uhat(i,j,n)
                v(i,j,k)=v(i,j,k)+vmodes(k,n)*vhat(i,j,n)
                t(i,j,k)=t(i,j,k)+phihat2t(k,n)*phihat(i,j,n)
             end do
          end do
          if( k == 1)then
             do j=1,lon2
                do i=1,lat2
                   p(i,j)=p(i,j)+phihat2p(n)*phihat(i,j,n)
                end do
             end do
          end if
       end do
    end do

  end subroutine vtrans_inv

  subroutine vtrans_inv_ad(uhat,vhat,phihat,u,v,t,p)
!$$$  subprogram documentation block
!                .      .    .
! subprogram:    vtrans_inv_ad
!
!   prgrmmr:
!
! abstract:
!
! program history log:
!   2008-05-29  safford -- add subprogram doc block
!
!   input argument list:
!     uhat,vhat,phihat
!     u,v,t
!     p
!
!   output argument list:
!     uhat,vhat,phihat
!
! attributes:
!   language:  f90
!   machine:   ibm RS/6000 SP
!
!$$$ end documentation block
    use gridmod,only: lat2,lon2,nsig
    use constants,only: zero
    implicit none

    real(r_kind),dimension(lat2,lon2,nvmodes_keep),intent(inout) :: uhat,vhat,phihat
    real(r_kind),dimension(lat2,lon2,nsig)        ,intent(in   ) :: u,v,t
    real(r_kind),dimension(lat2,lon2)             ,intent(in   ) :: p

    integer(i_kind) i,j,k,n

!$omp parallel do schedule(dynamic,1) private(n,i,j,k)
    do n=1,nvmodes_keep
       do k=1,nsig
          do j=1,lon2
             do i=1,lat2
                uhat(i,j,n)=uhat(i,j,n)+vmodes(k,n)*u(i,j,k)
                vhat(i,j,n)=vhat(i,j,n)+vmodes(k,n)*v(i,j,k)
                phihat(i,j,n)=phihat(i,j,n)+phihat2t(k,n)*t(i,j,k)
             end do
          end do
       end do
       do j=1,lon2
          do i=1,lat2
             phihat(i,j,n)=phihat(i,j,n)+phihat2p(n)*p(i,j)
          end do
       end do
    end do

  end subroutine vtrans_inv_ad

  subroutine vtrans(u,v,t,p,uhat,vhat,phihat)
!$$$  subprogram documentation block
!                .      .    .
! subprogram:    vtrans
!
!   prgrmmr:
!
! abstract:
!
! program history log:
!   2008-05-29  safford -- add subprogram doc block
!
!   input argument list:
!     u,v,t
!     p
!
!   output argument list:
!     uhat,vhat,phihat
!
! attributes:
!   language:  f90
!   machine:   ibm RS/6000 SP
!
!$$$ end documentation block

    use gridmod,only: lat2,lon2,nsig
    use constants,only: zero
    implicit none

    real(r_kind),dimension(lat2,lon2,nsig)        ,intent(in   ) :: u,v,t
    real(r_kind),dimension(lat2,lon2)             ,intent(in   ) :: p
    real(r_kind),dimension(lat2,lon2,nvmodes_keep),intent(  out) :: uhat,vhat,phihat

    integer(i_kind) i,j,k,n

!$omp parallel do schedule(dynamic,1) private(n,i,j,k)
    do n=1,nvmodes_keep
       do j=1,lon2
          do i=1,lat2
             uhat(i,j,n)=zero
             vhat(i,j,n)=zero
             phihat(i,j,n)=p2phihat(n)*p(i,j)
          enddo
       enddo
       do k=1,nsig
          do j=1,lon2
             do i=1,lat2
                uhat(i,j,n)=uhat(i,j,n)+dualmodes(k,n)*u(i,j,k)
                vhat(i,j,n)=vhat(i,j,n)+dualmodes(k,n)*v(i,j,k)
                phihat(i,j,n)=phihat(i,j,n)+t2phihat(k,n)*t(i,j,k)
             end do
          end do
       end do
    end do

  end subroutine vtrans

  subroutine vtrans_ad(u,v,t,p,uhat,vhat,phihat)
!$$$  subprogram documentation block
!                .      .    .
! subprogram:    vtrans_ad
!
!   prgrmmr:
!
! abstract:
!
! program history log:
!   2008-05-29  safford -- add subprogram doc block
!
!   input argument list:
!     u,v,t
!     p
!     uhat,vhat,phihat
!
!   output argument list:
!     u,v,t
!     p
!
! attributes:
!   language:  f90
!   machine:   ibm RS/6000 SP
!
!$$$ end documentation block

    use gridmod,only: lat2,lon2,nsig
    implicit none

    real(r_kind),dimension(lat2,lon2,nsig)        ,intent(inout) :: u,v,t
    real(r_kind),dimension(lat2,lon2)             ,intent(inout) :: p
    real(r_kind),dimension(lat2,lon2,nvmodes_keep),intent(in   ) :: uhat,vhat,phihat

    integer(i_kind) i,j,k,n

!$omp parallel do schedule(dynamic,1) private(n,i,j,k)
    do k=1,nsig
       do n=1,nvmodes_keep
          do j=1,lon2
             do i=1,lat2
                u(i,j,k)=u(i,j,k)+dualmodes(k,n)*uhat(i,j,n)
                v(i,j,k)=v(i,j,k)+dualmodes(k,n)*vhat(i,j,n)
                t(i,j,k)=t(i,j,k)+t2phihat(k,n)*phihat(i,j,n)
             end do
          end do
          if(k == 1)then
             do j=1,lon2
               do i=1,lat2
                  p(i,j)=p(i,j)+p2phihat(n)*phihat(i,j,n)
               end do
             end do
          end if
       end do
    end do

  end subroutine vtrans_ad

end module mod_vtrans

subroutine special_eigvv(qmat0,hmat0,smat0,nmat,swww0,szzz0,swwwd0,szzzd0,nvmodes_keep)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    special_eigvv   obtain eigenvalues and eigenvecgtors of qmat0
!   prgmmr: parrish        org: np22         date:  2012-12-18
!
! abstract:  Compute eigenvalues and eigenvectors of matrix qmat0.  Input and output
!            variables are r_kind, but internal calculations are done in r_quad to eliminate
!            possible failures in the inverse iteration algorithm used to refine
!            the accuracy of the eigenvectors and eigenvalues so as to agree
!            with those produced previously by library routine dgeev to 15
!            digits.  Because it is only necessary that the initial estimate of
!            eigenvectors and eigenvalues be near (but not too near) the desired
!            final values, the initial values are obtained using r_kind
!            precision only (subroutine eigen, located in raflib.F90).
!            Extensive testing with different initial eigenvalue/vector
!            estimates confirmed that identical r_kind precision
!            eigenvalues and eigenvectors are always obtained from the quad precision
!            inverse iteration algorithm.  This translates to exact
!            reproducibility on different numbers of processors for the full
!            analysis.
!
!
! program history log:
!   2012-12-18  parrish
!
!
! usage:
!   input argument list:
!     qmat0,hmat0,smat0,nmat,nvmodes_keep
!
!   output argument list:
!     swww0,szzz0,swwwd0,szzzd0
!
! attributes:
!   language: f90
!   machine:  ibm RS/6000 SP
!
!$$$ end documentation block

  use kinds, only: r_kind,i_kind,r_quad
  use gsi_io, only: verbose

  implicit none

  integer(i_kind),intent(in)::nmat,nvmodes_keep
  real(r_kind),intent(in)::qmat0(nmat,nmat),hmat0(nmat),smat0(nmat)
  real(r_kind),intent(inout):: swww0(nvmodes_keep),swwwd0(nvmodes_keep)
  real(r_kind),intent(inout):: szzz0(nmat,nvmodes_keep),szzzd0(nmat,nvmodes_keep)

  real(r_quad) qmat(nmat,nmat),hmat(nmat),smat(nmat)
  real(r_quad) swww(nvmodes_keep),swwwd(nvmodes_keep)
  real(r_quad) szzz(nmat,nvmodes_keep),szzzd(nmat,nvmodes_keep)
  real(r_quad) rmat(nmat),qtildemat(nmat,nmat),atemp(nmat*nmat),btemp(nmat,nmat)
  real(r_quad) eigvals(nmat)
  integer(i_kind) i,j,k,ia,mv,iret,istop
  real(r_quad) sum
! real(r_quad) orthoerror
  real(r_quad) aminv(nmat,nmat),aminvt(nmat,nmat)
  real(r_quad) eigval_this,eigval_next
  real(r_quad) zero_quad,half_quad,one_quad
  real(r_quad) dist_to_closest_eigval,perturb_eigval
  real(r_quad) err_aminv
  real(r_kind) atemp8(nmat*nmat),btemp8(nmat,nmat)
  logical noskip,print_verbose

  print_verbose = .false.
  if(verbose) print_verbose=.true.
  zero_quad=0.0_r_quad
  half_quad=0.5_r_quad
  one_quad =1.0_r_quad
  qmat=qmat0
  hmat=hmat0
  smat=smat0
  do i=1,nmat
     rmat(i)=sqrt(hmat(i)*smat(i))
  end do
  do j=1,nmat
     do i=1,nmat
        qtildemat(i,j)=rmat(i)*rmat(j)*qmat(i,j)/(hmat(i)*smat(j))
     end do
  end do

!  get eigenvalues, eigenvectors of symmetrized version
!    of qtildemat (gives most accurate eigenvalue estimates):
  atemp=0.0_r_quad
  do i=1,nmat
     do j=i,nmat
        ia=i+(j*j-j)/2
        atemp(ia)=half_quad*(qtildemat(j,i)+qtildemat(i,j))
     end do
  end do
  mv=0
  atemp8=atemp
  call eigen(atemp8,btemp8,nmat,mv)
  btemp=btemp8
  atemp=atemp8
  do i=1,nvmodes_keep
     j=i
     ia=i+(j*j-j)/2
     eigvals(i)=atemp(ia)
  !  write(6,*)' i,ave eigvals(i)=',i,eigvals(i)
  end do

!      iterative improvement to get eigvals, eigvects of qtildemat

  do i=1,nvmodes_keep
     szzz(:,i)=btemp(:,i)
     szzzd(:,i)=btemp(:,i)
!  renormalize szzz and szzzd
     sum=zero_quad
     do j=1,nmat
        sum=sum+szzz(j,i)**2
     end do
     sum=one_quad/sqrt(sum)
     if(szzz(1,i)<zero_quad) sum=-sum
     do j=1,nmat
        szzz(j,i)=sum*szzz(j,i)
     end do
     sum=zero_quad
     do j=1,nmat
        sum=sum+szzzd(j,i)**2
     end do
     sum=one_quad/sqrt(sum)
     if(szzzd(1,i)<zero_quad) sum=-sum
     do j=1,nmat
        szzzd(j,i)=sum*szzzd(j,i)
     end do
     eigval_this=eigvals(i)
     iret=0
     dist_to_closest_eigval=min( abs(eigvals(i)-eigvals(max(i-1,1           ))), &
                                 abs(eigvals(i)-eigvals(min(i+1,nvmodes_keep))) )
     if(i==1) then
        dist_to_closest_eigval=abs(eigvals(i+1)-eigvals(i))
     elseif(i==nvmodes_keep) then
        dist_to_closest_eigval=abs(eigvals(i)-eigvals(i-1))
     else
        dist_to_closest_eigval=min( abs(eigvals(i)-eigvals(max(i-1,1           ))), &
                                    abs(eigvals(i)-eigvals(min(i+1,nvmodes_keep))) )
     end if

     !write(6,*)' i,eigvals(i),dist_to_closest_eigval=',i,eigvals(i),dist_to_closest_eigval
     perturb_eigval=0.000001_r_quad*dist_to_closest_eigval
     !write(6,*)' i,perturb_eigval/eigvals(i)=',i,perturb_eigval/eigvals(i)
     !write(6,*)' precomputation of aminv with check on err_aminv'
     call iterative_improvement0(qtildemat,eigval_this,aminv,aminvt,nmat,iret,err_aminv)
     noskip=.false.
     if(err_aminv>10._r_quad**(-20).or.iret==1) then
        noskip=.true.
        eigval_this=eigval_this+perturb_eigval
     end if
     iret=0
     do j=1,10
        if(noskip)  call iterative_improvement0(qtildemat,eigval_this,aminv,aminvt,nmat,iret,err_aminv)
        noskip=.true.
        if(iret==1) then
           if(print_verbose)write(6,*)' det=0 in iterative_improvement0, eigenvalue converged, it = ',j
           exit
        end if
        call iterative_improvement(eigval_this,eigval_next,aminv,aminvt,szzz(:,i),szzzd(:,i),nmat,istop)
        if(eigval_this==eigval_next) then
           if(print_verbose)write(6,*)' no change in eigenvalue, convergence to machine precision achieved, it = ',j
           exit
        end if
        eigval_this=eigval_next
        if(istop==1) then
           if(print_verbose)write(6,*)' eigval relative change less than 10**(-24), no further iteration necessary, it = ',j
           exit
        end if
     end do
     swww(i)=eigval_next
     swwwd(i)=eigval_next
     !write(6,*)' i,j,swww(i)=',i,j,swww(i)
  end do

!  compute unscaled left and right eigenvectors of "corrected" matrix qmat_c

  do k=1,nvmodes_keep
     do i=1,nmat
        szzz(i,k)=hmat(i)*szzz(i,k)/rmat(i)
        szzzd(i,k)=smat(i)*szzzd(i,k)/rmat(i)
     end do
  end do

!  renormalize szzz and szzzd

  do i=1,nvmodes_keep
     sum=zero_quad
     do j=1,nmat
        sum=sum+szzz(j,i)**2
     end do
     sum=one_quad/sqrt(sum)
     if(szzz(1,i)<zero_quad) sum=-sum
     do j=1,nmat
        szzz(j,i)=sum*szzz(j,i)
     end do
     sum=zero_quad
     do j=1,nmat
        sum=sum+szzzd(j,i)**2
     end do
     sum=one_quad/sqrt(sum)
     if(szzzd(1,i)<zero_quad) sum=-sum
     do j=1,nmat
        szzzd(j,i)=sum*szzzd(j,i)
     end do
  end do

!  joint normalization:

  do i=1,nvmodes_keep
     sum=zero_quad
     do j=1,nmat
        sum=sum+szzz(j,i)*szzzd(j,i)
     end do
     sum=one_quad/sqrt(abs(sum))
     do j=1,nmat
        szzz(j,i)=sum*szzz(j,i)
        szzzd(j,i)=sum*szzzd(j,i)
     end do
  end do

 !orthoerror=zero_quad
 !do i=1,nvmodes_keep
 !   do j=1,nvmodes_keep
 !      sum=zero_quad
 !      if(i==j) sum=-one_quad
 !      do k=1,nmat
 !         sum=sum+szzz(k,i)*szzzd(k,j)
 !      end do
 !      orthoerror=max(abs(sum),orthoerror)
 !   end do
 !end do
 !write(6,*)' orthoerror for szzz,szzzd=',orthoerror

! check error in qmat*szzz - swww*szzz  and qmat_trans*szzzd - swww*szzzd

 !do i=1,nvmodes_keep
 !   sum=zero_quad
 !   rnorm=zero_quad
 !   sumd=zero_quad
 !   rnormd=zero_quad
 !   do j=1,nmat
 !      term=-swww(i)*szzz(j,i)
 !      term2=term
 !      do k=1,nmat
 !         term=term+qmat(j,k)*szzz(k,i)
 !      end do
 !      sum=sum+term**2
 !      rnorm=rnorm+term2**2
 !      term=-swww(i)*szzzd(j,i)
 !      term2=term
 !      do k=1,nmat
 !         term=term+qmat(k,j)*szzzd(k,i)
 !      end do
 !      sumd=sumd+term**2
 !      rnormd=rnormd+term2**2
 !   end do
 !   write(6,*)' i,eigval/vect error check: vec,dual errs=',i,sqrt(sum/rnorm),sqrt(sumd/rnormd)
 !end do
  swww0 =swww
  swwwd0=swwwd
  szzz0 =szzz
  szzzd0=szzzd
  !do i=1,nvmodes_keep
  !   write(6,*)' i,swww0(i),swwwd0(i)=',i,swww0(i),swwwd0(i)
  !   do j=1,nmat,nmat-1
  !      write(6,*)' i,j,szzz0(j,i),szzzd0(j,i)=',i,j,szzz0(j,i),szzzd0(j,i)
  !   end do
  !end do

end subroutine special_eigvv

subroutine iterative_improvement0(a,mu,aminv,aminvt,na,iret,errormax)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    iterative_improvement0  compute inverse of a - mu*I
!   prgmmr: parrish        org: np22         date:  2012-12-18
!
! abstract:  Compute inverse of matrix a - mu*I, where mu is current estimate of eigenvalue
!            in inverse iteration algorithm.
!
!
! program history log:
!   2012-12-18  parrish
!
!
! usage:
!   input argument list:
!     a,mu,na
!
!   output argument list:
!     aminv,aminvt,iret
!
! attributes:
!   language: f90
!   machine:  ibm RS/6000 SP
!
!$$$ end documentation block

  use kinds, only: r_quad,i_kind
  use gsi_io, only: verbose
  implicit none

  integer(i_kind),intent(in)::na
  real(r_quad),intent(in)::a(na,na),mu
  real(r_quad),intent(inout)::aminv(na,na)
  real(r_quad),intent(inout)::aminvt(na,na)
  real(r_quad),intent(out):: errormax
  integer(i_kind),intent(out)::iret

  real(r_quad) am(na,na)
  real(r_quad) sum,detam,errlimit
  integer(i_kind) i,j,k,lpivot(na),mpivot(na)
  real(r_quad) zero_quad,one_quad
  logical print_verbose

  print_verbose=.false.
  if(verbose)print_verbose=.true.
  errlimit=1000._r_quad
  zero_quad=0._r_quad
  one_quad=1._r_quad

!  compute (A-mu*I)**(-1)

  iret=0

  am=zero_quad
  do j=1,na
     am(j,j)=-mu
  end do
  do j=1,na
     do i=1,na
        am(i,j)=am(i,j)+a(i,j)
     end do
  end do
  aminv=am
  call iminv_quad(aminv,na,detam,lpivot,mpivot)
  if(detam==zero_quad) then
     iret=1
     return
  end if
  do j=1,na
     do i=1,na
        aminvt(i,j)=aminv(j,i)
     end do
  end do

!   check inverse

  errormax=zero_quad
  do j=1,na
     do i=1,na
        sum=zero_quad
        if(i==j) sum=-one_quad
        do k=1,na
           sum=sum+am(i,k)*aminv(k,j)
        end do
        errormax=max(abs(sum),errormax)
     end do
  end do
  if(print_verbose)write(6,*)' delta in aminv =',errormax
  if(errormax>errlimit) iret=-1

end subroutine iterative_improvement0

subroutine iterative_improvement(mu,mu_next,aminv,aminvt,bv,bw,na,istop)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    iterative_improvement  complete one iteration of inverse iteration
!   prgmmr: parrish        org: np22         date:  2012-12-18
!
! abstract:  Apply one iteration of inverse iteration, producing a new estimate for eigenvalue
!            and eigenvector.
!
!
! program history log:
!   2012-12-18  parrish
!
!
! usage:
!   input argument list:
!     mu,aminv,aminvt,bv,bw,na
!
!   output argument list:
!     mu_next,bv,bw,istop
!
! attributes:
!   language: f90
!   machine:  ibm RS/6000 SP
!
!$$$ end documentation block

  use kinds, only: r_quad,i_kind
  implicit none

  integer(i_kind),intent(in)::na
  integer(i_kind),intent(inout)::istop
  real(r_quad),intent(in)::mu
  real(r_quad),intent(in)::aminv(na,na),aminvt(na,na)
  real(r_quad),intent(inout):: mu_next
  real(r_quad),intent(inout)::bv(na),bw(na)

  real(r_quad) bnextv(na),bnextw(na)
  real(r_quad) factorv,factorw,sumv,sumw
  real(r_quad) zero_quad,half_quad,one_quad,two_quad,tol_quad
  integer(i_kind) i,j

  istop=0
  zero_quad=0.0_r_quad
  half_quad=0.5_r_quad
  one_quad=1.0_r_quad
  two_quad=2.0_r_quad
  tol_quad=10.0_r_quad**(-24)
  bnextv=zero_quad
  bnextw=zero_quad
  do i=1,na
     do j=1,na
        bnextv(i)=bnextv(i)+aminv(i,j)*bv(j)
        bnextw(i)=bnextw(i)+aminvt(i,j)*bw(j)
     end do
  end do

!  compute dot prod of bnext with b

  sumv=zero_quad
  sumw=zero_quad
  do i=1,na
     sumv=sumv+bnextv(i)*bv(i)
     sumw=sumw+bnextw(i)*bw(i)
  end do
  mu_next=mu+half_quad/sumv+half_quad/sumw
  if(two_quad*abs(mu_next-mu)/abs(mu+mu_next) < tol_quad) istop=1

!   normalize bnextv and bnextw

  factorv=zero_quad
  factorw=zero_quad
  do i=1,na
     factorv=factorv+bnextv(i)**2
     factorw=factorw+bnextw(i)**2
  end do
  factorv=one_quad/sqrt(factorv)
  factorw=one_quad/sqrt(factorw)
  if(bnextv(1)<zero_quad) factorv=-factorv
  if(bnextw(1)<zero_quad) factorw=-factorw
  do i=1,na
     bv(i)=factorv*bnextv(i)
     bw(i)=factorw*bnextw(i)
  end do

end subroutine iterative_improvement

      subroutine iminv_quad (a,n,d,l,m)
!$$$  subprogram documentation block
!                .      .    .
! subprogram:    iminv    invert a matrix
!
!   prgrmmr:
!
! abstract:      the standard gauss-jordan method is used. the determinant
!                is also calculated. a determinant of zero indicates that
!                the matrix is singular.
!
! remarks        matrix a must be a general matrix
!
! program history log:
!   2008-06-04  safford -- add subprogram doc block
!   2012-12-18  parrish -- create r_quad precision version
!   2013-01-10  parrish -- change so d is absolute value of determinant and
!                            is bounded by 1e50.  The variable d is only used
!                            in this application if it is exactly zero, so there
!                            is no harm in bounding by a large number.  This was
!                            done to prevent overflow trap in debug mode.
!
!   input argument list:
!     a - input matrix, destroyed in computation and replaced by resultant inverse
!     n - order of matrix a
!     d - resultant determinant
!     l - work vector of length n
!     m - work vector of length n
!
!   output argument list:
!     a - input matrix, destroyed in computation and replaced by resultant inverse
!
! attributes:
!   language:  f90
!   machine:   ibm RS/6000 SP
!
!$$$ end documentation block

        use kinds,only: r_quad,i_kind
        implicit none

        integer(i_kind)             ,intent(in   ) :: n
        integer(i_kind),dimension(n),intent(inout) :: l,m
        real(r_quad)                ,intent(inout) :: d
        real(r_quad),dimension(n*n) ,intent(inout) :: a

        integer(i_kind):: nk,k,j,iz,i,ij
        integer(i_kind):: kj,ik,jr,jq,jk,ki,kk,jp,ji

        real(r_quad):: biga,hold
        real(r_quad):: zero_quad,one_quad
        real(r_quad) dmax
!
!        if a double precision version of this routine is desired, the
!        ! in column 1 should be removed from the double precision
!        statement which follows.
!
!     double precision a, d, biga, hold
!
!        the ! must also be removed from double precision statements
!        appearing in other routines used in conjunction with this
!        routine.
!
!        the double precision version of this sr........ must also
!        contain double precision fortran functions.  abs in statemen
!        10 must be changed to dabs  .
!
!        ...............................................................

         zero_quad=0.0_r_quad
         one_quad=1.0_r_quad
         dmax=(10.0_r_quad)**50
!
!        search for largest element
!
         d=one_quad
         nk=-n
         do 80 k=1,n
            nk=nk+n
            l(k)=k
            m(k)=k
            kk=nk+k
            biga=a(kk)
            do 20 j=k,n
               iz=n*(j-1)
               do 20 i=k,n
                  ij=iz+i
   10             if(abs(biga)-abs(a(ij))) 15,20,20
   15             biga=a(ij)
                  l(k)=i
                  m(k)=j
   20       continue
!
!        interchange rows
!
            j=l(k)
            if(j-k) 35,35,25
   25       ki=k-n
            do 30 i=1,n
               ki=ki+n
               hold=-a(ki)
               ji=ki-k+j
               a(ki)=a(ji)
   30          a(ji) =hold
!
!        interchange columns
!
   35          i=m(k)
               if(i-k) 45,45,38
   38          jp=n*(i-1)
               do 40 j=1,n
                  jk=nk+j
                  ji=jp+j
                  hold=-a(jk)
                  a(jk)=a(ji)
   40             a(ji) =hold
!
!        divide column by minus pivot (value of pivot element is
!        contained in biga)
!
   45             if(biga) 48,46,48
   46             d=zero_quad
                  return
   48             do 55 i=1,n
                     if(i-k) 50,55,50
   50                ik=nk+i
                     a(ik)=a(ik)/(-biga)
   55             continue
!
!        reduce matrix
!
                  do 65 i=1,n
                     ik=nk+i
                     ij=i-n
                     do 65 j=1,n
                        ij=ij+n
                        if(i-k) 60,65,60
   60                   if(j-k) 62,65,62
   62                   kj=ij-i+k
                        a(ij)=a(ik)*a(kj)+a(ij)
   65             continue
!
!        divide row by pivot
!
                  kj=k-n
                  do 75 j=1,n
                     kj=kj+n
                     if(j-k) 70,75,70
   70                a(kj)=a(kj)/biga
   75             continue
!
!        product of pivots
!
                  d=min(dmax,abs(d*biga))
!
!        replace pivot by reciprocal
!
                  a(kk)=one_quad/biga
   80    continue
!
!        final row and column interchange
!
         k=n
         do
  100       k=(k-1)
            if(k) 150,150,105
  105       i=l(k)
            if(i-k) 120,120,108
  108       jq=n*(k-1)
            jr=n*(i-1)
            do 110 j=1,n
               jk=jq+j
               hold=a(jk)
               ji=jr+j
               a(jk)=-a(ji)
               a(ji) =hold
  110       continue
  120       j=m(k)
            if(j-k) 100,100,125
  125       ki=k-n
            do 130 i=1,n
               ki=ki+n
               hold=a(ki)
               ji=ki-k+j
               a(ki)=-a(ji)
               a(ji) =hold
  130       continue
         end do
  150    return
      end subroutine iminv_quad


SUBROUTINE calc_grav_brute
  ! Subroutine calculates gravitational forces and potentials for all particles
  ! It uses brute force O(N^2) to calculate forces and potentials
  ! for particles outside the smoothing volume

  use sphdata
  use sphneighbourdata
  use sphkerneldata
  use tachedata, only:nelement

  implicit none

  real,dimension(3) :: gravi

  integer :: ielement, jpart,k,ix
  real :: meanpot,sdpot, percent,increment

  allocate(gravxyz(3,nelement))
  allocate(poten(nelement))

  gravxyz(:,:) = 0.0
  poten(:) = 0.0

  isoft = 0

  percent = 0.0
  increment = 1.0

  do ielement = 1,nelement

     call element_percent_complete(ielement,nelement,percent,increment)

     gravi(:) = 0.0
     poteni = 0.0

     ! Loop over all elements

     !$OMP PARALLEL &
     !$OMP shared(ielement, nelement,poten,gravxyz) &
     !$OMP private(jpart,poteni,gravi,ix)
     !$OMP DO SCHEDULE(runtime)
     do jpart = 1,nelement

        if(ielement==jpart) cycle

        ! Compute the forces between ielement and jpart
        call particle_forces(ielement,jpart,poteni,gravi)

        poten(ielement) = poten(ielement) + poteni

        DO ix=1,3
           gravxyz(ix,ielement) = gravxyz(ix,ielement) + gravi(ix)
        ENDDO

     enddo
     !$OMP END DO
     !$OMP END PARALLEL
     ! End of loop over jpart

     !  Add contribution to the potential from pointmasses

     do k=1,nptmass

        jpart = listpm(k)

        if(jpart==ielement) cycle

        sep = (xyzmh(1,ielement) - xyzmh(1,jpart))**2 + &
             (xyzmh(2,ielement) - xyzmh(2,jpart))**2 +&
             (xyzmh(3,ielement) - xyzmh(3,jpart))**2

        sep =sqrt(sep)

        poten(ielement) = poten(ielement) + xyzmh(4,jpart)/sep

     enddo
     !print*, 'Particle ', ielement, ': Potential - ', poten(ielement), 'Force: ',gravi(:)
  ENDDO

  ! End loop over all particles

  ! Calculate mean and standard deviation of potential

  meanpot = sum(poten)/REAL(nelement)
  sdpot = 0.0

  !$OMP PARALLEL &
  !$OMP shared(nneigh,meanneigh,nelement)&
  !$OMP private(ielement) &
  !$OMP reduction(+:sdneigh)
  !$OMP DO SCHEDULE(runtime)
  do ielement=1,nelement
     sdpot = sdpot+(poten(ielement)-meanpot)**2
  enddo
  !$OMP END DO
  !$OMP END PARALLEL

  sdpot = sqrt(sdpot/REAL(nelement))

  print*, 'Mean potential is ', meanpot
  print*, 'Standard Deviation: ', sdpot

  return
END SUBROUTINE calc_grav_brute


*     TG01JD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          LDA, LDB, LDC, LDE
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = PMAX,
     $                   LDE = NMAX )
      INTEGER          LDWORK, LIWORK
      PARAMETER        ( LDWORK = MAX( 8*NMAX,2*MMAX,2*PMAX ),
     $                   LIWORK = 2*NMAX + MAX( MMAX, PMAX ) )
*     .. Local Scalars ..
      CHARACTER        EQUIL, JOB, SYSTYP
      INTEGER          I, INFO, J, M, N, NR, P
      DOUBLE PRECISION TOL
*     .. Local Arrays ..
      INTEGER          INFRED(7), IWORK(LIWORK)
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX),
     $                 DWORK(LDWORK), E(LDE,NMAX)
*     .. External Subroutines ..
      EXTERNAL         TG01JD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, TOL, JOB, SYSTYP, EQUIL
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99988 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99987 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N )
            IF ( P.LT.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99986 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
*              Find the irreducible descriptor system (Ar-lambda Er,Br,Cr).
               CALL TG01JD( JOB, SYSTYP, EQUIL, N, M, P, A, LDA, E, LDE,
     $                      B, LDB, C, LDC, NR, INFRED, TOL, IWORK,
     $                      DWORK, LDWORK, INFO )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99994 ) NR
                  WRITE ( NOUT, FMT = 99991 )
                  DO 10 I = 1, 4
                     IF( INFRED(I).GE.0 )
     $                  WRITE ( NOUT, FMT = 99990 ) I, INFRED(I)
   10             CONTINUE
                  WRITE ( NOUT, FMT = 99997 )
                  DO 20 I = 1, NR
                     WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,NR )
   20             CONTINUE
                  WRITE ( NOUT, FMT = 99996 )
                  DO 30 I = 1, NR
                     WRITE ( NOUT, FMT = 99995 ) ( E(I,J), J = 1,NR )
   30             CONTINUE
                  WRITE ( NOUT, FMT = 99993 )
                  DO 40 I = 1, NR
                     WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M )
   40             CONTINUE
                  WRITE ( NOUT, FMT = 99992 )
                  DO 50 I = 1, P
                     WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,NR )
   50             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' TG01JD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from TG01JD = ',I2)
99997 FORMAT (/' The reduced state dynamics matrix Ar is ')
99996 FORMAT (/' The reduced descriptor matrix Er is ')
99995 FORMAT (20(1X,F8.4))
99994 FORMAT (' Order of reduced system =', I5 )
99993 FORMAT (/' The reduced input/state matrix Br is ')
99992 FORMAT (/' The reduced state/output matrix Cr is ')
99991 FORMAT (/' Achieved order reductions in different phases')
99990 FORMAT (' Phase',I2,':', I3, ' elliminated eigenvalue(s)' )
99988 FORMAT (/' N is out of range.',/' N = ',I5)
99987 FORMAT (/' M is out of range.',/' M = ',I5)
99986 FORMAT (/' P is out of range.',/' P = ',I5)
      END


      subroutine writenumber (xnum)
c******************************************************************************
c     This subroutine decides on the order-of-magnitude of a number and
c     writes it to a character string in a reasonable format
c******************************************************************************

      include 'Pstuff.com'
      real*4 xnum, lognum
      integer numdec

      lognum = alog10(abs(xnum))
      if     (lognum .ge. 6.) then
         write (errmess,1002)
      elseif (lognum .ge. 0.) then
         numdec = 5 - nint(lognum)
         write (errmess,1001) numdec
      else
         write (errmess,1003)
      endif
      write (array,errmess) xnum
      return

c*****format statements
1001  format ('(f8.',i1,'$)')
1002  format ('(1pe8.1$)')
1003  format ('(f8.5$)')

      end


! PR middle-end/77719
! { dg-do compile }
! { dg-options "-O3 -ffast-math" }

SUBROUTINE urep_egr(erep,derep,surr)
  INTEGER, PARAMETER :: dp=8
  REAL(dp), INTENT(inout)                  :: erep, derep(3)
  REAL(dp), INTENT(in)                     :: surr(2)
  REAL(dp)                                 :: de_z, rz
  INTEGER :: isp,spdim,jsp,nsp
  IF (n_urpoly > 0) THEN
    IF (r < spxr(1,1)) THEN
      ispg: DO isp = 1,spdim ! condition ca)
        IF (isp /= spdim) THEN
          nsp = 5 ! condition cb
          DO jsp = 0,nsp
            IF( jsp <= 3 ) THEN
            ELSE
              erep = erep + surr(jsp-3)*rz**(jsp)
            ENDIF
          END DO
        END IF
      END DO ispg
    END IF
  END IF
END SUBROUTINE urep_egr


c=======================================================================
c
c     subroutine IMPLRET
c
c     Implied returns
c
c     ratio Sharpe = (global risk premium) / (portfolio global risk)
c                  = global risk aversion parameter
c
c     excess implied return = (global risk aversion) * Cov * w
c
c            Cov : covariance matrix
c            w   : portfolio weights
c
c     implied return = excess implied return + risk-free rate
c
c-----------------------------------------------------------------------
      SUBROUTINE implret ( n, cov, rho, w, rfr, dwork, implied, info )
c-----------------------------------------------------------------------
c
c     INPUT
c            n      : number of assets                           integer
c            cov    : covariance matrix (n*n)                     double
c            rho    : assets perf.(s) (n)                         double
c            w      : initial portfolio (n)                       double
c            rfr    : risk-free rate                              double
c
c     WORKSPACE
c            dwork   : n                                           double
c
c     OUTPUT
c            implied : implied return (n)                          double
c            info    : = 0 successful exit                        integer
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, info, i
      DOUBLE PRECISION rfr, cov(*), rho(*), w(*), implied(*)
c
c     workspaces
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER  pdwpmv
      DOUBLE PRECISION delta
c
c-----------------------------------------------------------------------
c
c     initialization
      info  = 0
      delta = 0.0
c
c     pointers for double precision work space  : dwork
c     -------------------------------------------------
      pdwpmv = 1
c     pdwpmv  : pointer for vector, so ( n ) more
c
c     Total size of dwork array = n
c
c--------------------------------------------------------------------
c     ex-ante Sharpe ratio (portfolio) - global risk aversion parameter
      CALL EXASRA ( n, cov, rho, w, rfr, delta, info)
c
c     method I, implied return (portfolio) := delta*cov*w
      CALL PMV ( n, n, cov, w, dwork(pdwpmv) )
      CALL PVX ( n, dwork(pdwpmv), delta, implied )
c
      DO i = 1,n
        implied(i) = implied(i) + rfr
      ENDDO
c
      RETURN
      END


module blas_z2
  use blas_kinds, only : ik, dp
  implicit none
  private :: ik, dp

  interface
    subroutine zgbmv(trans, m, n, kl, ku, alpha, a, lda, x, incx, beta, y, incy)
      import :: ik, dp
      integer(ik) :: lda
      character(len=1) :: trans
      integer(ik) :: m
      integer(ik) :: n
      integer(ik) :: kl
      integer(ik) :: ku
      complex(dp) :: alpha
      complex(dp) :: a(lda, *)
      complex(dp) :: x(*)
      integer(ik) :: incx
      complex(dp) :: beta
      complex(dp) :: y(*)
      integer(ik) :: incy
    end subroutine zgbmv
  end interface
  interface
    subroutine zgemv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
      import :: ik, dp
      integer(ik) :: lda
      character(len=1) :: trans
      integer(ik) :: m
      integer(ik) :: n
      complex(dp) :: alpha
      complex(dp) :: a(lda, *)
      complex(dp) :: x(*)
      integer(ik) :: incx
      complex(dp) :: beta
      complex(dp) :: y(*)
      integer(ik) :: incy
    end subroutine zgemv
  end interface
  interface
    subroutine zgerc(m, n, alpha, x, incx, y, incy, a, lda)
      import :: ik, dp
      integer(ik) :: lda
      integer(ik) :: m
      integer(ik) :: n
      complex(dp) :: alpha
      complex(dp) :: x(*)
      integer(ik) :: incx
      complex(dp) :: y(*)
      integer(ik) :: incy
      complex(dp) :: a(lda, *)
    end subroutine zgerc
  end interface
  interface
    subroutine zgeru(m, n, alpha, x, incx, y, incy, a, lda)
      import :: ik, dp
      integer(ik) :: lda
      integer(ik) :: m
      integer(ik) :: n
      complex(dp) :: alpha
      complex(dp) :: x(*)
      integer(ik) :: incx
      complex(dp) :: y(*)
      integer(ik) :: incy
      complex(dp) :: a(lda, *)
    end subroutine zgeru
  end interface
  interface
    subroutine zhbmv(uplo, n, k, alpha, a, lda, x, incx, beta, y, incy)
      import :: ik, dp
      integer(ik) :: lda
      character(len=1) :: uplo
      integer(ik) :: n
      integer(ik) :: k
      complex(dp) :: alpha
      complex(dp) :: a(lda, *)
      complex(dp) :: x(*)
      integer(ik) :: incx
      complex(dp) :: beta
      complex(dp) :: y(*)
      integer(ik) :: incy
    end subroutine zhbmv
  end interface
  interface
    subroutine zhemv(uplo, n, alpha, a, lda, x, incx, beta, y, incy)
      import :: ik, dp
      integer(ik) :: lda
      character(len=1) :: uplo
      integer(ik) :: n
      complex(dp) :: alpha
      complex(dp) :: a(lda, *)
      complex(dp) :: x(*)
      integer(ik) :: incx
      complex(dp) :: beta
      complex(dp) :: y(*)
      integer(ik) :: incy
    end subroutine zhemv
  end interface
  interface
    subroutine zher2(uplo, n, alpha, x, incx, y, incy, a, lda)
      import :: ik, dp
      integer(ik) :: lda
      character(len=1) :: uplo
      integer(ik) :: n
      complex(dp) :: alpha
      complex(dp) :: x(*)
      integer(ik) :: incx
      complex(dp) :: y(*)
      integer(ik) :: incy
      complex(dp) :: a(lda, *)
    end subroutine zher2
  end interface
  interface
    subroutine zher(uplo, n, alpha, x, incx, a, lda)
      import :: ik, dp
      integer(ik) :: lda
      character(len=1) :: uplo
      integer(ik) :: n
      real(dp) :: alpha
      complex(dp) :: x(*)
      integer(ik) :: incx
      complex(dp) :: a(lda, *)
    end subroutine zher
  end interface
  interface
    subroutine zhpmv(uplo, n, alpha, ap, x, incx, beta, y, incy)
      import :: ik, dp
      character(len=1) :: uplo
      integer(ik) :: n
      complex(dp) :: alpha
      complex(dp) :: ap(*)
      complex(dp) :: x(*)
      integer(ik) :: incx
      complex(dp) :: beta
      complex(dp) :: y(*)
      integer(ik) :: incy
    end subroutine zhpmv
  end interface
  interface
    subroutine zhpr(uplo, n, alpha, x, incx, ap)
      import :: ik, dp
      character(len=1) :: uplo
      integer(ik) :: n
      real(dp) :: alpha
      complex(dp) :: x(*)
      integer(ik) :: incx
      complex(dp) :: ap(*)
    end subroutine zhpr
  end interface
  interface
    subroutine zhpr2(uplo, n, alpha, x, incx, y, incy, ap)
      import :: ik, dp
      character(len=1) :: uplo
      integer(ik) :: n
      complex(dp) :: alpha
      complex(dp) :: x(*)
      integer(ik) :: incx
      complex(dp) :: y(*)
      integer(ik) :: incy
      complex(dp) :: ap(*)
    end subroutine zhpr2
  end interface
  interface
    subroutine ztbmv(uplo, trans, diag, n, k, a, lda, x, incx)
      import :: ik, dp
      integer(ik) :: lda
      character(len=1) :: uplo
      character(len=1) :: trans
      character(len=1) :: diag
      integer(ik) :: n
      integer(ik) :: k
      complex(dp) :: a(lda, *)
      complex(dp) :: x(*)
      integer(ik) :: incx
    end subroutine ztbmv
  end interface
  interface
    subroutine ztbsv(uplo, trans, diag, n, k, a, lda, x, incx)
      import :: ik, dp
      integer(ik) :: lda
      character(len=1) :: uplo
      character(len=1) :: trans
      character(len=1) :: diag
      integer(ik) :: n
      integer(ik) :: k
      complex(dp) :: a(lda, *)
      complex(dp) :: x(*)
      integer(ik) :: incx
    end subroutine ztbsv
  end interface
  interface
    subroutine ztpmv(uplo, trans, diag, n, ap, x, incx)
      import :: ik, dp
      character(len=1) :: uplo
      character(len=1) :: trans
      character(len=1) :: diag
      integer(ik) :: n
      complex(dp) :: ap(*)
      complex(dp) :: x(*)
      integer(ik) :: incx
    end subroutine ztpmv
  end interface
  interface
    subroutine ztpsv(uplo, trans, diag, n, ap, x, incx)
      import :: ik, dp
      character(len=1) :: uplo
      character(len=1) :: trans
      character(len=1) :: diag
      integer(ik) :: n
      complex(dp) :: ap(*)
      complex(dp) :: x(*)
      integer(ik) :: incx
    end subroutine ztpsv
  end interface
  interface
    subroutine ztrmv(uplo, trans, diag, n, a, lda, x, incx)
      import :: ik, dp
      integer(ik) :: lda
      character(len=1) :: uplo
      character(len=1) :: trans
      character(len=1) :: diag
      integer(ik) :: n
      complex(dp) :: a(lda, *)
      complex(dp) :: x(*)
      integer(ik) :: incx
    end subroutine ztrmv
  end interface
  interface
    subroutine ztrsm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
      import :: ik, dp
      integer(ik) :: ldb
      integer(ik) :: lda
      character(len=1) :: side
      character(len=1) :: uplo
      character(len=1) :: transa
      character(len=1) :: diag
      integer(ik) :: m
      integer(ik) :: n
      complex(dp) :: alpha
      complex(dp) :: a(lda, *)
      complex(dp) :: b(ldb, *)
    end subroutine ztrsm
  end interface
  interface
    subroutine ztrsv(uplo, trans, diag, n, a, lda, x, incx)
      import :: ik, dp
      integer(ik) :: lda
      character(len=1) :: uplo
      character(len=1) :: trans
      character(len=1) :: diag
      integer(ik) :: n
      complex(dp) :: a(lda, *)
      complex(dp) :: x(*)
      integer(ik) :: incx
    end subroutine ztrsv
  end interface
end module blas_z2


! Program to set up gas on a uniform grid and apply an AGN accretion and
! feedback model to it.
!
! Paul Ricker (2/2013)

program agnug

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

    use amrex_fort_module, only : rt => amrex_real

    use agn_models

    implicit none

integer                             :: N, i, j, k, m, mmax, accmodel, fbmodel
integer                             :: fnum
logical                             :: just_wrote
real(rt)                            :: gamma, t, dt, tmax, rhoinit, Pinit, tout
type(agn_particle)                  :: agn
type(agn_mesh_data)                 :: mesh
real(rt)                            :: h, L, Mdot, Eint, tnext
real(rt), allocatable, dimension(:,:,:) :: rho, P, vx, vy, vz, E, cs, rhoold
real(rt), allocatable, dimension(:,:,:) :: rhodot, rhoEdot, pxdot, pydot, pzdot

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

! Get input from user

write(*,*) 'agnug.'
write(*,*)
write(*,*) 'Enter size of grid in CGS units: '
read(*,*)  L
write(*,*) 'Enter number of zones per side of grid: '
read(*,*)  N
write(*,*) 'Enter initial density and pressure in CGS units: '
read(*,*)  rhoinit, Pinit
write(*,*) 'Enter adiabatic index: '
read(*,*)  gamma
write(*,*) 'Enter black hole mass in CGS units: '
read(*,*)  agn%m
write(*,*) 'Enter end time in seconds and maximum number of steps: '
read(*,*)  tmax, mmax
write(*,*) 'Enter choice of accretion and feedback models: '
read(*,*)  accmodel, fbmodel
write(*,*) 'Enter output time interval in seconds: '
read(*,*)  tout

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

! Set up initial conditions

allocate(rho(N,N,N))
allocate(rhoold(N,N,N))
allocate(P(N,N,N))
allocate(vx(N,N,N))
allocate(vy(N,N,N))
allocate(vz(N,N,N))
allocate(E(N,N,N))
allocate(cs(N,N,N))

allocate(rhodot(N,N,N))
allocate(pxdot(N,N,N))
allocate(pydot(N,N,N))
allocate(pzdot(N,N,N))
allocate(rhoEdot(N,N,N))

allocate(mesh%x(N))
allocate(mesh%y(N))
allocate(mesh%z(N))
allocate(mesh%dx(N))
allocate(mesh%dy(N))
allocate(mesh%dz(N))

agn%mlast = agn%m ! black hole mass at time of last outburst

agn%x = 0.5 * L   ! position of black hole
agn%y = 0.5 * L
agn%z = 0.5 * L

agn%vx = 0.       ! velocity of black hole
agn%vy = 0.
agn%vz = 0.

agn%nx = 0.       ! direction cosines for jet angle
agn%ny = 0.
agn%nz = 1.

h = L / N

mesh%Nx   = N
mesh%xmin = 0.
mesh%xmax = L
mesh%x    = (/ ((i-0.5)*h, i = 1, N) /)
mesh%dx   = (/ (h, i = 1, N) /)

mesh%Ny   = N
mesh%ymin = 0.
mesh%ymax = L
mesh%y    = (/ ((i-0.5)*h, i = 1, N) /)
mesh%dy   = (/ (h, i = 1, N) /)

mesh%Nz   = N
mesh%zmin = 0.
mesh%zmax = L
mesh%z    = (/ ((i-0.5)*h, i = 1, N) /)
mesh%dz   = (/ (h, i = 1, N) /)

rho = rhoinit
P   = Pinit
vx  = 0.
vy  = 0.
vz  = 0.
E   = P/((gamma-1)*rho) + 0.5*(vx**2 + vy**2 + vz**2)

t   = 0.

call output(0, mesh, rho, P, vx, vy, vz, E)
just_wrote = .true.

fnum  = 1
tnext = tout

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

! Timestep loop

write(*,*)
write(*,'(A1,5X,A1,13X,A2,12X,A3,11X,A4)') 'n', 't', 'dt', 'Mbh', 'Mdot'

do m = 1, mmax

!   Compute timestep

  cs = sqrt(gamma*P/rho)
  dt = 0.5 * h / maxval(cs + sqrt(vx**2 + vy**2 + vz**2))
  if (t+dt > tnext) dt = (tnext-t) * 1.000001

!   Determine accretion rate onto BH

  call agn_compute_acc_rate(agn, Mdot, t, mesh, rho, P, vx, vy, vz, E, gamma, &
                            accmodel)

!   Write log message

  write(*,'(I5,4(1X,ES13.6))') m, t, dt, agn%m, Mdot

!   Apply feedback to the gas

  call agn_compute_feedback(agn, Mdot, t, dt, mesh, rho, P, vx, vy, vz, E, &
                            rhodot, pxdot, pydot, pzdot, rhoEdot, fbmodel)

  rhoold = rho

  rho = max(rho + rhodot*dt, agn_small_rho)
  vx  = (rhoold*vx + pxdot*dt) / rho
  vy  = (rhoold*vy + pydot*dt) / rho
  vz  = (rhoold*vz + pzdot*dt) / rho
  E   = max( (rhoold*E + rhoEdot*dt) / rho, agn_small_e )

!   Update pressure by differencing total and kinetic energy; if we were
!   tracking temperature we would also call EOS here

  do k = 1, N
    do j = 1, N
      do i = 1, N
        Eint = E(i,j,k) - 0.5*(vx(i,j,k)**2 + vy(i,j,k)**2 + vz(i,j,k)**2)
        if (Eint > agn_small_e) then
          P(i,j,k) = (gamma-1) * rho(i,j,k) * Eint
        else
          P(i,j,k) = (gamma-1) * rho(i,j,k) * agn_small_e
          E(i,j,k) = agn_small_e + 0.5*(vx(i,j,k)**2 + vy(i,j,k)**2 + vz(i,j,k)**2)
        endif
      enddo
    enddo
  enddo

!   Grow the BH

  agn%m = agn%m + Mdot*dt

!   Update counters and output if necessary

  t = t + dt
  just_wrote = .false.

  if (t >= tnext) then
    call output(fnum, mesh, rho, P, vx, vy, vz, E)
    fnum = fnum + 1
    tnext = tnext + tout
    just_wrote = .true.
  endif

  if (t >= tmax) exit

enddo

if (.not. just_wrote) call output(fnum, mesh, rho, P, vx, vy, vz, E)

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

end program agnug

! output: A simple output routine that writes bricks of bytes.

subroutine output(n, m, rho, P, vx, vy, vz, E)

use agn_mesh

implicit none

integer, intent(in)             :: n
type(agn_mesh_data), intent(in) :: m
real(rt), dimension(:,:,:)          :: rho, P, vx, vy, vz, E

character(len=8)                :: fname
integer                         :: nbytes

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

nbytes = m%Nx * m%Ny * m%Nz * 8

write(fname(1:8),'(A4,I4.4)') 'dens', n
open(1, file=fname, form='unformatted', access='direct', recl=nbytes)
write(1,rec=1) rho
close(1)

write(fname(1:8),'(A4,I4.4)') 'pres', n
open(1, file=fname, form='unformatted', access='direct', recl=nbytes)
write(1,rec=1) P
close(1)

write(fname(1:8),'(A4,I4.4)') 'velx', n
open(1, file=fname, form='unformatted', access='direct', recl=nbytes)
write(1,rec=1) vx
close(1)

write(fname(1:8),'(A4,I4.4)') 'vely', n
open(1, file=fname, form='unformatted', access='direct', recl=nbytes)
write(1,rec=1) vy
close(1)

write(fname(1:8),'(A4,I4.4)') 'velz', n
open(1, file=fname, form='unformatted', access='direct', recl=nbytes)
write(1,rec=1) vz
close(1)

write(fname(1:8),'(A4,I4.4)') 'ener', n
open(1, file=fname, form='unformatted', access='direct', recl=nbytes)
write(1,rec=1) E
close(1)

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

return
end subroutine output


      SUBROUTINE SPTTS2( N, NRHS, D, E, B, LDB )
*
*  -- LAPACK routine (version 3.2) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2006
*
*     .. Scalar Arguments ..
      INTEGER            LDB, N, NRHS
*     ..
*     .. Array Arguments ..
      REAL               B( LDB, * ), D( * ), E( * )
*     ..
*
*  Purpose
*  =======
*
*  SPTTS2 solves a tridiagonal system of the form
*     A * X = B
*  using the L*D*L' factorization of A computed by SPTTRF.  D is a
*  diagonal matrix specified in the vector D, L is a unit bidiagonal
*  matrix whose subdiagonal is specified in the vector E, and X and B
*  are N by NRHS matrices.
*
*  Arguments
*  =========
*
*  N       (input) INTEGER
*          The order of the tridiagonal matrix A.  N >= 0.
*
*  NRHS    (input) INTEGER
*          The number of right hand sides, i.e., the number of columns
*          of the matrix B.  NRHS >= 0.
*
*  D       (input) REAL array, dimension (N)
*          The n diagonal elements of the diagonal matrix D from the
*          L*D*L' factorization of A.
*
*  E       (input) REAL array, dimension (N-1)
*          The (n-1) subdiagonal elements of the unit bidiagonal factor
*          L from the L*D*L' factorization of A.  E can also be regarded
*          as the superdiagonal of the unit bidiagonal factor U from the
*          factorization A = U'*D*U.
*
*  B       (input/output) REAL array, dimension (LDB,NRHS)
*          On entry, the right hand side vectors B for the system of
*          linear equations.
*          On exit, the solution vectors, X.
*
*  LDB     (input) INTEGER
*          The leading dimension of the array B.  LDB >= max(1,N).
*
*  =====================================================================
*
*     .. Local Scalars ..
      INTEGER            I, J
*     ..
*     .. External Subroutines ..
      EXTERNAL           SSCAL
*     ..
*     .. Executable Statements ..
*
*     Quick return if possible
*
      IF( N.LE.1 ) THEN
         IF( N.EQ.1 )
     $      CALL SSCAL( NRHS, 1. / D( 1 ), B, LDB )
         RETURN
      END IF
*
*     Solve A * X = B using the factorization A = L*D*L',
*     overwriting each right hand side vector with its solution.
*
      DO 30 J = 1, NRHS
*
*           Solve L * x = b.
*
         DO 10 I = 2, N
            B( I, J ) = B( I, J ) - B( I-1, J )*E( I-1 )
   10    CONTINUE
*
*           Solve D * L' * x = b.
*
         B( N, J ) = B( N, J ) / D( N )
         DO 20 I = N - 1, 1, -1
            B( I, J ) = B( I, J ) / D( I ) - B( I+1, J )*E( I )
   20    CONTINUE
   30 CONTINUE
*
      RETURN
*
*     End of SPTTS2
*
      END


!** Copyright (c) 2000, NVIDIA CORPORATION.  All rights reserved.
!**
!** Licensed under the Apache License, Version 2.0 (the "License");
!** you may not use this file except in compliance with the License.
!** You may obtain a copy of the License at
!**
!**     http://www.apache.org/licenses/LICENSE-2.0
!**
!** Unless required by applicable law or agreed to in writing, software
!** distributed under the License is distributed on an "AS IS" BASIS,
!** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
!** See the License for the specific language governing permissions and
!** limitations under the License.
!
! Tests scalar mask for sum intrinsic.

	program p

	integer stuff(3,3)
	logical(4) msk1(3,3),msk2(3,3)
	logical(4) expect(2)
	logical(4) rslt(2)
	data expect /.true.,.true./
	integer atrue(3), afalse(3)
	integer sfalse(3), strue(3)

	do i=1,3
	do j=1,3
	stuff(i,j) = i
	enddo
	enddo

	msk1 = .true.
	msk2 = .false.

	atrue = sum(stuff,dim=1,mask=msk1)
	strue = sum(stuff,dim=1,mask=.true.)
	afalse = sum(stuff,dim=1,mask=msk2)
	sfalse = sum(stuff,dim=1,mask=.false.)
	rslt(1) = all(atrue .eq. strue)
	rslt(2) = all(afalse .eq. sfalse)
	call check(rslt,expect,2)

	end


program main

    use mpi
    use mpi_topology
    use multigrid
    use geometry
    use matrix
    use, intrinsic :: ISO_C_BINDING

    implicit none

    real(kind=8), parameter         :: PI = 3.1415926535897932384626d0

    integer(kind=4)                 :: npx, npy, npz
    integer(kind=4)                 :: nx, ny, nz
    real(kind=8)                    :: ox, oy, oz
    real(kind=8)                    :: lx, ly, lz
    real(kind=8)                    :: ax, ay, az
    real(kind=8)                    :: alpha_x, alpha_y, alpha_z

    type(domain)                    :: g_domain
    type(subdomain)                 :: s_domain
    type(matrix_heptadiagonal)      :: a_poisson

    real(kind=8), allocatable       :: ref_sub(:,:,:)
    real(kind=8), allocatable       :: u_x, u_y, u_z

    real(kind=8)                    :: rms, rms_local

    ! aggretation method
    ! 0 : no aggregation
    ! 1 : single aggregation
    ! 2 : adaptive aggregation (not implemented yet)
    integer(kind=4) :: i, j, k, maxiteration, number_of_vcycles, number_of_levels, aggregation_method, CGA_level, CGPSA_level(3)
    real(kind=8)    :: tolerance, t0, omega_sor
    ! character(256)  :: myfilename

    integer(kind=4) :: ierr

    call MPI_Init(ierr)
    call MPI_Comm_size( MPI_COMM_WORLD, nprocs, ierr)
    call MPI_Comm_rank( MPI_COMM_WORLD, myrank, ierr)

    namelist /meshes/ nx, ny, nz
    namelist /origin/ ox, oy, oz
    namelist /length/ lx, ly, lz
    namelist /mesh_stretch/ ax, ay, az
    namelist /procs/ npx, npy, npz
    namelist /control/ maxiteration, tolerance, number_of_vcycles, number_of_levels, aggregation_method, CGA_level, CGPSA_level, omega_sor
    namelist /coefficients/ alpha_x, alpha_y, alpha_z

    open (unit = 1, file = "PARA_INPUT.inp")
    read (1, meshes)
    read (1, origin)
    read (1, length)
    read (1, mesh_stretch)
    read (1, procs)
    read (1, control)
    read (1, coefficients)
    close (1)

    np_dim(0)=npx
    np_dim(1)=npy
    np_dim(2)=npz
    period(0)=.false.; period(1)=.false.; period(2)=.false.

    call mpi_topology_create()

    call geometry_domain_create(g_domain, nx, ny, nz, ox, oy, oz, lx, ly, lz, ax, ay, az, period)
    if(myrank.eq.0) print '(a)', '[Poisson] Geometry and matrix size initialized.'

    call geometry_subdomain_create(s_domain, g_domain)
    call geometry_subdomain_ddt_create(s_domain)

    allocate( ref_sub(0:s_domain%nx+1, 0:s_domain%ny+1, 0:s_domain%nz+1) )
    ref_sub(:,:,:) = 0.0d0

    ! Problem 1 : cosine function over -l/2 <= x,y,z <=l/2
    do k = 1, s_domain%nz
        do j = 1, s_domain%ny
            do i = 1, s_domain%nx
                s_domain%x(i, j, k) = 0.0d0
                s_domain%b(i, j, k) =-cos(s_domain%xg(i)/lx*PI) &
                                    *cos(s_domain%yg(j)/ly*PI) &
                                    *cos(s_domain%zg(k)/lz*PI) &
                                    *PI*PI*(1.0d0/(lx*lx)+1.0d0/(ly*ly)+1.0d0/(lz*lz))
                ref_sub(i, j, k) =  cos(s_domain%xg(i)/lx*PI)*cos(s_domain%yg(j)/ly*PI)*cos(s_domain%zg(k)/lz*PI)
            enddo
        enddo
    enddo

    ! Problem 2 : delta function at x = y = z = 0.0
    ! do k = 1, s_domain%nz
    !     kg = k + s_domain%ksta - 1
    !     do j = 1, s_domain%ny
    !         jg = j + s_domain%jsta - 1
    !         do i = 1, s_domain%nx
    !             ig = i + s_domain%ista - 1
    !             if( (ig.eq.g_domain%nx/4).and.(jg.eq.g_domain%ny/4).and.(kg.eq.g_domain%nz/4) ) then
    !                 s_domain%b(i,j,k) = 4.0d0 *PI / 8.0d0 / (s_domain%dxm(i)*s_domain%dym(j)*s_domain%dzm(k) )
    !                 print *, '1', myrank, i, j, k, s_domain%b(i,j,k)
    !             endif
    !             if( (ig.eq.g_domain%nx/4+1).and.(jg.eq.g_domain%ny/4).and.(kg.eq.g_domain%nz/4) ) then
    !                 s_domain%b(i,j,k) = 4.0d0 *PI / 8.0d0  / (s_domain%dxm(i)*s_domain%dym(j)*s_domain%dzm(k) )
    !                 print *, '2', myrank, i, j, k, s_domain%b(i,j,k)
    !             endif
    !             if( (ig.eq.g_domain%nx/4).and.(jg.eq.g_domain%ny/4+1).and.(kg.eq.g_domain%nz/4) ) then
    !                 s_domain%b(i,j,k) = 4.0d0 *PI / 8.0d0  / (s_domain%dxm(i)*s_domain%dym(j)*s_domain%dzm(k) )
    !                 print *, '3', myrank, i, j, k, s_domain%b(i,j,k)
    !             endif
    !             if( (ig.eq.g_domain%nx/4+1).and.(jg.eq.g_domain%ny/4+1).and.(kg.eq.g_domain%nz/4) ) then
    !                 s_domain%b(i,j,k) = 4.0d0 *PI  / 8.0d0 / (s_domain%dxm(i)*s_domain%dym(j)*s_domain%dzm(k) )
    !                 print *, '4', myrank, i, j, k, s_domain%b(i,j,k)
    !             endif
    !             if( (ig.eq.g_domain%nx/4).and.(jg.eq.g_domain%ny/4).and.(kg.eq.g_domain%nz/4+1) ) then
    !                 s_domain%b(i,j,k) = 4.0d0 *PI / 8.0d0  / (s_domain%dxm(i)*s_domain%dym(j)*s_domain%dzm(k) )
    !                 print *, '5', myrank, i, j, k, s_domain%b(i,j,k)
    !             endif
    !             if( (ig.eq.g_domain%nx/4+1).and.(jg.eq.g_domain%ny/4).and.(kg.eq.g_domain%nz/4+1) ) then
    !                 s_domain%b(i,j,k) = 4.0d0 *PI / 8.0d0  / (s_domain%dxm(i)*s_domain%dym(j)*s_domain%dzm(k) )
    !                 print *, '6', myrank, i, j, k, s_domain%b(i,j,k)
    !             endif
    !             if( (ig.eq.g_domain%nx/4).and.(jg.eq.g_domain%ny/4+1).and.(kg.eq.g_domain%nz/4+1) ) then
    !                 s_domain%b(i,j,k) = 4.0d0 *PI / 8.0d0  / (s_domain%dxm(i)*s_domain%dym(j)*s_domain%dzm(k) )
    !                 print *, '7', myrank, i, j, k, s_domain%b(i,j,k)
    !             endif
    !             if( (ig.eq.g_domain%nx/4+1).and.(jg.eq.g_domain%ny/4+1).and.(kg.eq.g_domain%nz/4+1) ) then
    !                 s_domain%b(i,j,k) = 4.0d0 *PI / 8.0d0  / (s_domain%dxm(i)*s_domain%dym(j)*s_domain%dzm(k) )
    !                 print *, '8', myrank, i, j, k, s_domain%b(i,j,k)
    !             endif
    !         enddo
    !     enddo
    ! enddo
    ! do k = 0, s_domain%nz+1
    !     do j = 0, s_domain%ny+1
    !         do i = 0, s_domain%nx+1
    !             r01=sqrt(s_domain%xg(i)**2+s_domain%yg(j)**2+s_domain%zg(k)**2)
    !             ref_sub(i, j, k) =  - 1.0d0 / r01
    !         enddo
    !     enddo
    ! enddo

    ! Problem 3 : Exponential function, -1.0 <= x <= 1.0
    ! do k = 0, s_domain%nz+1
    !     do j = 0, s_domain%ny+1
    !         do i = 0, s_domain%nx+1
    !             u_x = ( 1.0d0 - exp( alpha_x*((s_domain%xg(i))**2 - 1.0d0) ) ) / ( 1.0d0 - exp(-alpha_x) )
    !             u_y = ( 1.0d0 - exp( alpha_y*((s_domain%yg(j))**2 - 1.0d0) ) ) / ( 1.0d0 - exp(-alpha_y) )
    !             u_z = ( 1.0d0 - exp( alpha_z*((s_domain%zg(k))**2 - 1.0d0) ) ) / ( 1.0d0 - exp(-alpha_z) )

    !             s_domain%x(i, j, k) = 0.0d0
    !             s_domain%b(i, j, k) = ( 2.0d0*alpha_x + 4.0d0*alpha_x**2 * (s_domain%xg(i))**2 ) * (u_x - 1.0d0/(1.0d0 - exp(-alpha_x))) * u_y * u_z &
    !                                 + ( 2.0d0*alpha_y + 4.0d0*alpha_y**2 * (s_domain%yg(j))**2 ) * (u_y - 1.0d0/(1.0d0 - exp(-alpha_y))) * u_z * u_x &
    !                                 + ( 2.0d0*alpha_z + 4.0d0*alpha_z**2 * (s_domain%zg(k))**2 ) * (u_z - 1.0d0/(1.0d0 - exp(-alpha_z))) * u_x * u_y
    !             ref_sub(i, j, k) =  u_x * u_y * u_z
    !         enddo
    !     enddo
    ! enddo

    if(myrank.eq.0) print '(a)', '[Poisson] Geometry and rhs constructed.'

    call matrix_heptadiagonal_create(a_poisson, s_domain)
    if(myrank.eq.0) print '(a)', '[Poisson] Poisson matrix constructed.'

    if(myrank.eq.0) print '(a)', '[Poisson] Start solving equations.'

    t0=MPI_Wtime()

    call multigrid_create(s_domain, number_of_levels, number_of_vcycles, aggregation_method, CGA_level, CGPSA_level)
    call multigrid_solve_vcycle(s_domain%x, s_domain%r, a_poisson, s_domain%b, s_domain, maxiteration, tolerance, omega_sor)
    call multigrid_destroy
    rms = 0.0d0
    rms_local = 0.0d0
    do k=1, s_domain%nz
        do j=1, s_domain%ny
            do i=1, s_domain%nx
                rms_local = rms_local + (s_domain%x(i,j,k)-ref_sub(i,j,k))**2
            enddo
        enddo
    enddo
    call MPI_Allreduce(rms_local, rms, 1, MPI_REAL8, MPI_SUM, MPI_COMM_WORLD, ierr)
    if(myrank.eq.0) print '(a,e20.10)','[Poisson] RMS = ',rms/g_domain%nx/g_domain%ny/g_domain%nz
    if(myrank.eq.0) print '(a,f12.6)', '[Poisson] Solution obtained. Execution time = ',MPI_Wtime()-t0

    ! call file_write
    ! call binary_file_check

    if(myrank.eq.0) print '(a)', '[Poisson] Solution printed.'

    deallocate(ref_sub)

    call matrix_heptadiagonal_destroy(a_poisson)
    call mpi_topology_destroy
    call geometry_subdomain_ddt_destroy(s_domain)
    call geometry_subdomain_destroy(s_domain)
    call geometry_domain_destroy(g_domain)

    if(myrank.eq.0) print '(a)', '[Poisson] Memory deallocated.'

    call MPI_Finalize(ierr)

    contains

    subroutine file_write

        use mpi
        use mpi_topology

        implicit none

        !---- MPI write ----
        real(kind=8), allocatable, dimension(:, :, :)   :: sol_all, global_x
        integer(kind=4), allocatable, dimension(:,:)    :: cart_coord
        integer(kind=4), allocatable, dimension(:)      :: n1subm_cnt,  n2subm_cnt,  n3subm_cnt
        integer(kind=4), allocatable, dimension(:)      :: n1subm_disp, n2subm_disp, n3subm_disp
        integer(kind=4), allocatable, dimension(:)      :: ddtype_data_write_recv, request_recv

        integer(kind=4) :: ddtype_temp, ddtype_temp2, ddtype_data_write_send, ddtype_write_gatherv, ddtype_file, request_send
        integer(kind=4) :: ddtype_temp3, ddtype_write_gatherv_halo
        integer(kind=4) :: sizes(0:2), subsizes(0:2), starts(0:2)
        integer(kind=4) :: i, j, k, ierr, r8size
        integer(kind=4) :: status(MPI_STATUS_SIZE), filep

        integer(kind=MPI_OFFSET_KIND) :: disp
        integer(kind=MPI_ADDRESS_KIND):: extent, lb
        integer(kind=4), allocatable, dimension(:)   :: cnt_gatherv
        integer(kind=4), allocatable, dimension(:)   :: disps_gatherv
        ! ascii file write

        allocate(n1subm_cnt(0:comm_1d_x%nprocs-1), n1subm_disp(0:comm_1d_x%nprocs-1))
        allocate(n2subm_cnt(0:comm_1d_y%nprocs-1), n2subm_disp(0:comm_1d_y%nprocs-1))
        allocate(n3subm_cnt(0:comm_1d_z%nprocs-1), n3subm_disp(0:comm_1d_z%nprocs-1))
        allocate(ddtype_data_write_recv(0:nprocs-1))
        allocate(request_recv(0:nprocs-1))
        allocate(disps_gatherv(0:nprocs-1), cnt_gatherv(0:nprocs-1))
        allocate(sol_all(1:g_domain%nx,1:g_domain%ny,1:g_domain%nz))
        allocate(global_x(0:g_domain%nx+1,0:g_domain%ny+1,0:g_domain%nz+1))

        sol_all(:,:,:) = 0.0d0
        allocate( cart_coord(0:2,0:nprocs-1) )
        do i = 0, nprocs-1
            call MPI_Cart_coords(mpi_world_cart, i, 3, cart_coord(:,i), ierr )
        enddo

        call MPI_Allgather(s_domain%nx, 1, MPI_INTEGER, n1subm_cnt,1, MPI_INTEGER, comm_1d_x%mpi_comm, ierr)
        call MPI_Allgather(s_domain%ny, 1, MPI_INTEGER, n2subm_cnt,1, MPI_INTEGER, comm_1d_y%mpi_comm, ierr)
        call MPI_Allgather(s_domain%nz, 1, MPI_INTEGER, n3subm_cnt,1, MPI_INTEGER, comm_1d_z%mpi_comm, ierr)

        n1subm_disp(0) = 0
        do i = 1, comm_1d_x%nprocs-1
            n1subm_disp(i)=sum(n1subm_cnt(0:i-1))
        enddo

        n2subm_disp(0) = 0
        do i = 1, comm_1d_y%nprocs-1
            n2subm_disp(i)=sum(n2subm_cnt(0:i-1))
        enddo

        n3subm_disp(0) = 0
        do i = 1, comm_1d_z%nprocs-1
            n3subm_disp(i)=sum(n3subm_cnt(0:i-1))
        enddo

        ! Make data types for MPI_Send/Recv
        ! ddtype_send is common
        sizes    = (/s_domain%nx+2,s_domain%ny+2,s_domain%nz+2/)
        subsizes = (/s_domain%nx,s_domain%ny,s_domain%nz/)
        starts   = (/1,      1,      1/)
        call MPI_Type_create_subarray(3, sizes, subsizes, starts, MPI_ORDER_FORTRAN, &
                                    MPI_REAL8, ddtype_temp, ierr)
        CALL MPI_Type_size(MPI_REAL8, r8size, ierr)
        lb = 0
        extent = r8size * s_domain%nx
        call MPI_Type_create_resized(ddtype_temp, lb, extent, ddtype_data_write_send, ierr)
        call MPI_Type_commit( ddtype_data_write_send, ierr)

        ! ddtype_recv for MPI_Send/Recv
        do i = 0, nprocs-1
            sizes    = (/g_domain%nx, g_domain%ny, g_domain%nz/)
            subsizes = (/n1subm_cnt(cart_coord(0,i)), n2subm_cnt(cart_coord(1,i)), n3subm_cnt(cart_coord(2,i))/)
            starts   = (/n1subm_disp(cart_coord(0,i)), n2subm_disp(cart_coord(1,i)), n3subm_disp(cart_coord(2,i))/)

            call MPI_Type_create_subarray(3, sizes, subsizes, starts, MPI_ORDER_FORTRAN, &
                                        MPI_REAL8, ddtype_data_write_recv(i), ierr)
            call MPI_Type_commit( ddtype_data_write_recv(i), ierr)
        enddo

        ! Communication using MPI_Send/Recv
        call MPI_Isend(s_domain%x(0,0,0), 1, ddtype_data_write_send, 0, 101, MPI_COMM_WORLD, request_send, ierr)

        if(myrank == 0 ) then
            do i = 0, nprocs-1
                call MPI_Irecv(sol_all(1,1,1), 1, ddtype_data_write_recv(i), i, 101, MPI_COMM_WORLD, request_recv(i), ierr)
            enddo
        endif

        call MPI_Wait(request_send, status, ierr)
        if(myrank == 0 ) then
            call MPI_Waitall(nprocs, request_recv, MPI_STATUSES_IGNORE, ierr)
        endif

        ! File write after MPI_Send/Recv
        if(myrank == 0) then
            open(unit=myrank,form="formatted",file="solution_all.dat")
            do k = 1, g_domain%nz
                do j = 1, g_domain%ny
                    do i = 1, g_domain%nx
                        write(myrank,'(3D20.10,1E30.20)') g_domain%xg(i),g_domain%yg(j),g_domain%zg(k),sol_all(i,j,k)
                    enddo
                enddo
            enddo
            close(myrank)

            open(unit=myrank+1,form="unformatted",file="solution_all.bin")
            write(myrank+1) sol_all
            close(myrank+1)
        endif

        ! ddtype_recv for MPI_Gatherv

        sol_all = 0.0d0

        sizes    = (/g_domain%nx, g_domain%ny, g_domain%nz/)
        subsizes = (/s_domain%nx, s_domain%ny, s_domain%nz/)
        starts   = (/0, 0, 0/)

        call MPI_Type_create_subarray(3, sizes, subsizes, starts, MPI_ORDER_FORTRAN, &
                                    MPI_REAL8, ddtype_temp2, ierr)
        CALL MPI_Type_size(MPI_REAL8, r8size, ierr)
        lb = 0
        extent = r8size
        call MPI_Type_create_resized(ddtype_temp2, lb, extent, ddtype_write_gatherv, ierr)
        call MPI_Type_commit(ddtype_write_gatherv, ierr)

        do i = 0, nprocs-1
            cnt_gatherv(i) = 1
            disps_gatherv(i) = n1subm_disp(cart_coord(0,i))  &
                             + n2subm_disp(cart_coord(1,i)) * g_domain%nx  &
                             + n3subm_disp(cart_coord(2,i)) * g_domain%nx * g_domain%ny
        enddo

        call MPI_Gatherv(s_domain%x, 1, s_domain%ddt_inner_domain, sol_all(1,1,1), cnt_gatherv, disps_gatherv, ddtype_write_gatherv, 0, MPI_COMM_WORLD, ierr)

        ! File write after MPI_Gatherv
        if(myrank == 0) then
            open(unit=myrank,form="formatted",file="solution_all_gatherv.dat")
            do k = 1, g_domain%nz
                do j = 1, g_domain%ny
                    do i = 1, g_domain%nx
                        write(myrank,'(3D20.10,1E30.20)') g_domain%xg(i),g_domain%yg(j),g_domain%zg(k),sol_all(i,j,k)
                    enddo
                enddo
            enddo
            close(myrank)

            open(unit=myrank+1,form="unformatted",file="solution_all_gatherv.bin")
            write(myrank+1) sol_all
            close(myrank+1)
        endif

        ! ddtype_recv for MPI_Gatherv with halo cells

        global_x = 0.0d0

        sizes    = (/g_domain%nx+2, g_domain%ny+2, g_domain%nz+2/)
        subsizes = (/s_domain%nx, s_domain%ny, s_domain%nz/)
        starts   = (/1, 1, 1/)

        call MPI_Type_create_subarray(3, sizes, subsizes, starts, MPI_ORDER_FORTRAN, &
                                    MPI_REAL8, ddtype_temp3, ierr)
        CALL MPI_Type_size(MPI_REAL8, r8size, ierr)
        lb = 0
        extent = r8size
        call MPI_Type_create_resized(ddtype_temp3, lb, extent, ddtype_write_gatherv_halo, ierr)
        call MPI_Type_commit(ddtype_write_gatherv_halo, ierr)

        do i = 0, nprocs-1
            cnt_gatherv(i) = 1
            disps_gatherv(i) = n1subm_disp(cart_coord(0,i))  &
                             + n2subm_disp(cart_coord(1,i)) * (g_domain%nx + 2)  &
                             + n3subm_disp(cart_coord(2,i)) * (g_domain%nx + 2) * (g_domain%ny + 2)
        enddo

        call MPI_Gatherv(s_domain%x, 1, s_domain%ddt_inner_domain, global_x, cnt_gatherv, disps_gatherv, ddtype_write_gatherv_halo, 0, MPI_COMM_WORLD, ierr)

        ! File write after MPI_Gatherv with halo cells
        if(myrank == 0) then
            open(unit=myrank,form="formatted",file="solution_all_gatherv_halo.dat")
            do k = 1, g_domain%nz
                do j = 1, g_domain%ny
                    do i = 1, g_domain%nx
                        write(myrank,'(3D20.10,1E30.20)') g_domain%xg(i),g_domain%yg(j),g_domain%zg(k),global_x(i,j,k)
                    enddo
                enddo
            enddo
            close(myrank)

            open(unit=myrank+1,form="unformatted",file="solution_all_gatherv_halo.bin")
            write(myrank+1) sol_all
            close(myrank+1)
        endif

        ! ddtype_recv for MPI_Send/Recv
        do i = 0, nprocs-1
            sizes    = (/g_domain%nx, g_domain%ny, g_domain%nz/)
            subsizes = (/n1subm_cnt(cart_coord(0,i)), n2subm_cnt(cart_coord(1,i)), n3subm_cnt(cart_coord(2,i))/)
            starts   = (/n1subm_disp(cart_coord(0,i)), n2subm_disp(cart_coord(1,i)), n3subm_disp(cart_coord(2,i))/)

            call MPI_Type_create_subarray(3, sizes, subsizes, starts, MPI_ORDER_FORTRAN, &
                                        MPI_REAL8, ddtype_data_write_recv(i), ierr)
            call MPI_Type_commit( ddtype_data_write_recv(i), ierr)
        enddo

        ! For binary file write
        ! ddtype for MPI file write
        sizes    = (/g_domain%nx, g_domain%ny, g_domain%nz/)
        subsizes = (/s_domain%nx, s_domain%ny, s_domain%nz/)
        starts   = (/s_domain%ista-1, s_domain%jsta-1, s_domain%ksta-1/)
        call MPI_Type_create_subarray(3, sizes, subsizes, starts, MPI_ORDER_FORTRAN, &
                                    MPI_REAL8, ddtype_file, ierr)
        call MPI_Type_commit( ddtype_file, ierr)

        ! Set view and file write
        disp = 0
        call MPI_File_open(MPI_COMM_WORLD, 'solution_all_MPI_IO.bin', MPI_MODE_WRONLY+MPI_MODE_CREATE, MPI_INFO_NULL, filep, ierr)
        call MPI_File_set_view(filep, disp, MPI_REAL8, ddtype_file, 'native', MPI_INFO_NULL, ierr)
        call MPI_File_write(filep, s_domain%x(0,0,0), 1, ddtype_data_write_send, MPI_STATUS_IGNORE, ierr)
        call MPI_File_close(filep, ierr)

        call MPI_Type_free(ddtype_data_write_send, ierr)
        do i = 0, nprocs-1
            call MPI_Type_free(ddtype_data_write_recv(i), ierr)
        enddo
        call MPI_Type_free(ddtype_write_gatherv_halo, ierr)
        call MPI_Type_free(ddtype_write_gatherv, ierr)
        call MPI_Type_free(ddtype_file, ierr)
        deallocate(sol_all)
        deallocate(global_x)
        deallocate(n1subm_cnt, n1subm_disp)
        deallocate(n2subm_cnt, n2subm_disp)
        deallocate(n3subm_cnt, n3subm_disp)
        deallocate(ddtype_data_write_recv, request_recv)
        deallocate(cnt_gatherv, disps_gatherv)
        deallocate( cart_coord )

    end subroutine file_write

    subroutine binary_file_check

        use mpi
        use mpi_topology
        implicit none

        integer(kind=4) :: filep, ierr
        integer(kind=4) :: status(MPI_STATUS_SIZE)
        real(kind=8), allocatable :: temp1(:,:,:), temp2(:,:,:)

        if(myrank.eq.0) then

            allocate(temp1(1:g_domain%nx,1:g_domain%ny,1:g_domain%nz))
            open(unit=1,form='unformatted',file="solution_all.bin")
            read(1) temp1
            close(1)

            allocate(temp2(1:g_domain%nx,1:g_domain%ny,1:g_domain%nz))
            call mpi_file_open(MPI_COMM_SELF, 'solution_all_MPI_IO.bin', MPI_MODE_RDONLY, &
            MPI_INFO_NULL, filep, ierr)
            call mpi_file_read(filep, temp2, g_domain%nx*g_domain%ny*g_domain%nz, MPI_REAL8, status, ierr)
            call mpi_file_close(filep,ierr)

            do k = 1, g_domain%nz
                do j = 1, g_domain%ny
                    do i = 1, g_domain%nx
                        if(temp1(i,j,k).ne.temp2(i,j,k)) then
                            print *, i, j, k, temp1(i,j,k), temp2(i,j,k)
                        endif
                    enddo
                enddo
            enddo

            deallocate(temp1, temp2)
        endif

    end subroutine binary_file_check

end program main


      subroutine setprob()

      implicit none

      integer iunit
      character(len=25) fname

      double precision pi, pi2
      common /compi/ pi, pi2

      integer example
      common /example_comm/ example

      integer initchoice
      common /initchoice_comm/ initchoice

      integer refine_pattern
      common /refine_comm/ refine_pattern

      double precision init_radius
      common /initradius_comm/ init_radius

      double precision revs_per_s, cart_speed
      common /stream_comm/ revs_per_s, cart_speed

      double precision alpha, beta, theta_range(2), phi_range(2)
      common /torus_comm/ alpha, beta, theta_range, phi_range

      integer maxlevel, rfactor, grid_mx, mi, mj
      common /amr_comm/ maxlevel, rfactor, grid_mx, mi, mj

      integer qad_mode
      common /qad_comm/ qad_mode

      pi = 4.d0*atan(1.d0)
      pi2 = 2*pi

      iunit = 10
      fname = 'setprob.data'
      call opendatafile(iunit, fname)
      read(10,*) example
      read(10,*) initchoice
      read(10,*) refine_pattern
      read(10,*) alpha
      read(10,*) beta
      read(10,*) init_radius
      read(10,*) revs_per_s
      read(10,*) cart_speed
      read(10,*) theta_range(1)
      read(10,*) theta_range(2)
      read(10,*) phi_range(1)
      read(10,*) phi_range(2)

      read(iunit,*) grid_mx
      read(iunit,*) mi
      read(iunit,*) mj
      read(iunit,*) maxlevel
      read(iunit,*) rfactor
      read(iunit,*) qad_mode
      close(iunit)

      open(10,file='mapping.dat')
      write(10,*) example
      write(10,*) initchoice
      write(10,*) refine_pattern
      write(10,*) alpha
      write(10,*) beta
      write(10,*) init_radius
      write(10,*) revs_per_s
      write(10,*) cart_speed
      write(10,*) theta_range(1)
      write(10,*) theta_range(2)
      write(10,*) phi_range(1)
      write(10,*) phi_range(2)
      close(10)

      end