!
  subroutine spline_vmec_data
!
  use new_vmec_stuff_mod
  use vector_potentail_mod, only : ns,hs,torflux,sA_phi
!
  implicit none
!
  integer :: i,k,m,n,is,i_theta,i_phi,m_max,n_max,nsize_exp_imt,nsize_exp_inp,iexpt,iexpp
  integer :: iss,ist,isp,nrho,nheal
  double precision :: twopi,cosphase,sinphase
  complex(8)   :: base_exp_imt,base_exp_inp,base_exp_inp_inv,expphase
  double precision, dimension(:,:), allocatable :: splcoe
  double precision, dimension(:,:), allocatable :: almnc_rho,rmnc_rho,zmnc_rho
  double precision, dimension(:,:), allocatable :: almns_rho,rmns_rho,zmns_rho
  complex(8),   dimension(:),   allocatable :: exp_imt,exp_inp
!
  print *,'Splining VMEC data: ns_A = ',ns_A,'  ns_s = ',ns_s,'  ns_tp = ',ns_tp
!
  call new_allocate_vmec_stuff
!
  call vmecin(rmnc,zmns,almns,rmns,zmnc,almnc,aiota,phi,sps,axm,axn,s,    &
              nsurfm,nstrm,kpar,torflux)
!
  ns=kpar+1
  allocate(splcoe(0:ns_A,ns))
  hs=s(2)-s(1)
!
  nrho=ns
  allocate(almnc_rho(nstrm,0:nrho-1),rmnc_rho(nstrm,0:nrho-1),zmnc_rho(nstrm,0:nrho-1))
  allocate(almns_rho(nstrm,0:nrho-1),rmns_rho(nstrm,0:nrho-1),zmns_rho(nstrm,0:nrho-1))
!
  do i=1,nstrm
!
    m=nint(abs(axm(i)))
!
    nheal=min(m, 4)
!
    call s_to_rho_healaxis(m,ns,nrho,nheal,rmnc(i,:),rmnc_rho(i,:))
!
    call s_to_rho_healaxis(m,ns,nrho,nheal,zmnc(i,:),zmnc_rho(i,:))
!
    call s_to_rho_healaxis(m,ns,nrho,nheal,almnc(i,:),almnc_rho(i,:))
!
    call s_to_rho_healaxis(m,ns,nrho,nheal,rmns(i,:),rmns_rho(i,:))
!
    call s_to_rho_healaxis(m,ns,nrho,nheal,zmns(i,:),zmns_rho(i,:))
!
    call s_to_rho_healaxis(m,ns,nrho,nheal,almns(i,:),almns_rho(i,:))
!
  enddo
!
!------------------------------------
! Begin poloidal flux ($A_\varphi$):
!
  splcoe(0,:)=aiota
!
  call spl_reg(ns_A-1,ns,hs,splcoe(0:ns_A-1,:))
!
  do i=ns_A,1,-1
    splcoe(i,:)=splcoe(i-1,:)/dble(i)
  enddo
!
  splcoe(0,1)=0.d0
  do is=1,ns-1
    splcoe(0,is+1)=splcoe(ns_A,is)
    do k=ns_A-1,0,-1
      splcoe(0,is+1)=splcoe(k,is)+hs*splcoe(0,is+1)
    enddo
  enddo
!
  if(allocated(sA_phi)) deallocate(sA_phi)
  allocate(sA_phi(ns_A+1,ns))
  do k=0,ns_A
    sA_phi(k+1,:)=-torflux*splcoe(k,:)
  enddo
!
  deallocate(splcoe)
! End poloidal flux
!------------------------------
!
! Begin angular grid, sin and cos
!
  m_max=nint(maxval(axm))
  n_max=nint(maxval(axn))
!
  print *,'VMEC ns = ',ns,' m_max = ',m_max,' n_max = ',n_max
!
  n_theta = m_max*multharm+1
  n_phi = n_max*multharm+1
  twopi=8.d0*atan2(1.d0,1.d0)
  h_theta=twopi/dble(n_theta-1)
  h_phi=twopi/dble((n_phi-1)*nper)
!
  nsize_exp_imt=(n_theta-1)*m_max
  nsize_exp_inp=(n_phi-1)*n_max
!
  allocate(exp_imt(0:nsize_exp_imt),exp_inp(-nsize_exp_inp:nsize_exp_inp))
!
  base_exp_imt=exp(cmplx(0.d0,h_theta,kind=kind(0d0)))
  base_exp_inp=exp(cmplx(0.d0,h_phi,kind=kind(0d0)))
  base_exp_inp_inv=(1.d0,0.d0)/base_exp_inp
  exp_imt(0)=(1.d0,0.d0)
  exp_inp(0)=(1.d0,0.d0)
!
  do i=1,nsize_exp_imt
    exp_imt(i)=exp_imt(i-1)*base_exp_imt
  enddo
!
  do i=1,nsize_exp_inp
    exp_inp(i)=exp_inp(i-1)*base_exp_inp
    exp_inp(-i)=exp_inp(1-i)*base_exp_inp_inv
  enddo
!
  if(allocated(sR)) deallocate(sR)
  allocate(sR(ns_s+1,ns_tp+1,ns_tp+1,ns,n_theta,n_phi))
  if(allocated(sZ)) deallocate(sZ)
  allocate(sZ(ns_s+1,ns_tp+1,ns_tp+1,ns,n_theta,n_phi))
  if(allocated(slam)) deallocate(slam)
  allocate(slam(ns_s+1,ns_tp+1,ns_tp+1,ns,n_theta,n_phi))
!
  sR(1,1,1,:,:,:)=0.d0
  sZ(1,1,1,:,:,:)=0.d0
  slam(1,1,1,:,:,:)=0.d0
!
!$omp parallel private(m, n, i_theta, i_phi, i, is, iexpt, iexpp, &
!$omp&  expphase, cosphase, sinphase, k, splcoe)
!$omp do
  do i_theta=1,n_theta
    do i_phi=1,n_phi
      do i=1,nstrm
        m=nint(axm(i))
        n=nint(axn(i))
        iexpt=m*(i_theta-1)
        iexpp=n*(i_phi-1)
        expphase=exp_imt(iexpt)*exp_inp(-iexpp)
        cosphase=dble(expphase)
        sinphase=aimag(expphase)
        do is=1,ns
          sR(1,1,1,is,i_theta,i_phi) = sR(1,1,1,is,i_theta,i_phi)      &
                                     + rmnc_rho(i,is-1)*cosphase       &
                                     + rmns_rho(i,is-1)*sinphase
          sZ(1,1,1,is,i_theta,i_phi) = sZ(1,1,1,is,i_theta,i_phi)      &
                                     + zmnc_rho(i,is-1)*cosphase       &
                                     + zmns_rho(i,is-1)*sinphase
          slam(1,1,1,is,i_theta,i_phi) = slam(1,1,1,is,i_theta,i_phi)  &
                                       + almnc_rho(i,is-1)*cosphase    &
                                       + almns_rho(i,is-1)*sinphase
        enddo
      enddo
    enddo
  enddo
!$omp end do
!
!$omp barrier
!$omp single
  call new_deallocate_vmec_stuff
!$omp end single
!
! splining over $\varphi$:
!
  allocate(splcoe(0:ns_tp,n_phi))
!
!$omp do
  do is=1,ns
    do i_theta=1,n_theta
!
      splcoe(0,:)=sR(1,1,1,is,i_theta,:)
!
      call spl_per(ns_tp,n_phi,h_phi,splcoe)
!
      do k=1,ns_tp
        sR(1,1,k+1,is,i_theta,:)=splcoe(k,:)
      enddo
!
      splcoe(0,:)=sZ(1,1,1,is,i_theta,:)
!
      call spl_per(ns_tp,n_phi,h_phi,splcoe)
!
      do k=1,ns_tp
        sZ(1,1,k+1,is,i_theta,:)=splcoe(k,:)
      enddo
!
      splcoe(0,:)=slam(1,1,1,is,i_theta,:)
!
      call spl_per(ns_tp,n_phi,h_phi,splcoe)
!
      do k=1,ns_tp
        slam(1,1,k+1,is,i_theta,:)=splcoe(k,:)
      enddo
!
    enddo
  enddo
!$omp end do
!
  deallocate(splcoe)
!
! splining over $\vartheta$:
!
  allocate(splcoe(0:ns_tp,n_theta))
!
!$omp do
  do is=1,ns
    do i_phi=1,n_phi
      do isp=1,ns_tp+1
!
        splcoe(0,:)=sR(1,1,isp,is,:,i_phi)
!
        call spl_per(ns_tp,n_theta,h_theta,splcoe)
!
        do k=1,ns_tp
          sR(1,k+1,isp,is,:,i_phi)=splcoe(k,:)
        enddo
!
        splcoe(0,:)=sZ(1,1,isp,is,:,i_phi)
!
        call spl_per(ns_tp,n_theta,h_theta,splcoe)
!
        do k=1,ns_tp
          sZ(1,k+1,isp,is,:,i_phi)=splcoe(k,:)
        enddo
!
        splcoe(0,:)=slam(1,1,isp,is,:,i_phi)
!
        call spl_per(ns_tp,n_theta,h_theta,splcoe)
!
        do k=1,ns_tp
          slam(1,k+1,isp,is,:,i_phi)=splcoe(k,:)
        enddo
!
      enddo
    enddo
  enddo
!$omp end do
!
  deallocate(splcoe)
!
! splining over $s$:
!
  allocate(splcoe(0:ns_s,ns))
!
!$omp do
  do i_theta=1,n_theta
    do i_phi=1,n_phi
      do ist=1,ns_tp+1
        do isp=1,ns_tp+1
!
          splcoe(0,:)=sR(1,ist,isp,:,i_theta,i_phi)
!
          call spl_reg(ns_s,ns,hs,splcoe)
!
          do k=1,ns_s
            sR(k+1,ist,isp,:,i_theta,i_phi)=splcoe(k,:)
          enddo
!
          splcoe(0,:)=sZ(1,ist,isp,:,i_theta,i_phi)
!
          call spl_reg(ns_s,ns,hs,splcoe)
!
          do k=1,ns_s
            sZ(k+1,ist,isp,:,i_theta,i_phi)=splcoe(k,:)
          enddo
!
          splcoe(0,:)=slam(1,ist,isp,:,i_theta,i_phi)
!
          call spl_reg(ns_s,ns,hs,splcoe)
!
          do k=1,ns_s
            slam(k+1,ist,isp,:,i_theta,i_phi)=splcoe(k,:)
          enddo
!
        enddo
      enddo
    enddo
  enddo
!$omp end do
!
  deallocate(splcoe)
!$omp end parallel
  deallocate(exp_imt,exp_inp)
!
  end subroutine spline_vmec_data
!
!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!
  subroutine deallocate_vmec_spline(mode)
!
  use new_vmec_stuff_mod
!
  implicit none
!
  integer :: mode
!
  if(mode.eq.0) then
    deallocate(sR,sZ,slam)
  elseif(mode.eq.1) then
    deallocate(sR,sZ)
  elseif(mode.eq.2) then
    deallocate(slam)
  else
    print *,'deallocate_vmec_spline: unknown mode'
  endif
!
  end subroutine deallocate_vmec_spline
!
!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!
  subroutine splint_vmec_data(s,theta,varphi,A_phi,A_theta,dA_phi_ds,dA_theta_ds,aiota,       &
                              R,Z,alam,dR_ds,dR_dt,dR_dp,dZ_ds,dZ_dt,dZ_dp,dl_ds,dl_dt,dl_dp)
!
  use new_vmec_stuff_mod,   only : n_theta,n_phi,h_theta,h_phi,sR,sZ,slam,nper,ns_A,ns_s,ns_tp
  use vector_potentail_mod, only : ns,hs,torflux,sA_phi
!
  implicit none
!
  double precision, parameter :: twopi=2.d0*3.14159265358979d0
!
  integer :: is,i_theta,i_phi,k
  double precision :: ds,dtheta,dphi,rho_tor
  double precision :: s,theta,varphi,A_phi,A_theta,dA_phi_ds,dA_theta_ds,aiota,       &
                      R,Z,alam,dR_ds,dR_dt,dR_dp,dZ_ds,dZ_dt,dZ_dp,dl_ds,dl_dt,dl_dp
!
  integer, parameter :: ns_max=6
!
  integer :: nstp
!
  double precision, dimension(ns_max)        :: sp_R,sp_Z,sp_lam
  double precision, dimension(ns_max)        :: dsp_R_ds,dsp_Z_ds,dsp_lam_ds
  double precision, dimension(ns_max)        :: dsp_R_dt,dsp_Z_dt,dsp_lam_dt
  double precision, dimension(ns_max,ns_max) :: stp_R,stp_Z,stp_lam
  double precision, dimension(ns_max,ns_max) :: dstp_R_ds,dstp_Z_ds,dstp_lam_ds
!
  nstp=ns_tp+1
!
  A_theta=torflux*s
  dA_theta_ds=torflux
!
  ds=s/hs
  is=max(0,min(ns-1,int(ds)))
  ds=(ds-dble(is))*hs
  is=is+1
!
  dtheta=modulo(theta,twopi)/h_theta
  i_theta=max(0,min(n_theta-1,int(dtheta)))
  dtheta=(dtheta-dble(i_theta))*h_theta
  i_theta=i_theta+1
!
  dphi=modulo(varphi,twopi/dble(nper))/h_phi
  i_phi=max(0,min(n_phi-1,int(dphi)))
  dphi=(dphi-dble(i_phi))*h_phi
  i_phi=i_phi+1
!
! Begin interpolation over $s$
!
! Vector potential $A_\varphi$ and its derivative:
  A_phi=sA_phi(ns_A+1,is)
  dA_phi_ds=0.d0
!
  do k=ns_A,1,-1
    A_phi=sA_phi(k,is)+ds*A_phi
    dA_phi_ds=sA_phi(k+1,is)*dble(k)+ds*dA_phi_ds
  enddo
!
! R, Z and $\lambda$ and their derivatives over $s$:
!
  rho_tor=sqrt(s)
  ds=rho_tor/hs
  is=max(0,min(ns-2,int(ds)))
  ds=(ds-dble(is))*hs
  is=is+1
!
  stp_R(1:nstp,1:nstp)=sR(ns_s+1,:,:,is,i_theta,i_phi)
  dstp_R_ds(1:nstp,1:nstp)=0.d0
  stp_Z(1:nstp,1:nstp)=sZ(ns_s+1,:,:,is,i_theta,i_phi)
  dstp_Z_ds(1:nstp,1:nstp)=0.d0
  stp_lam(1:nstp,1:nstp)=slam(ns_s+1,:,:,is,i_theta,i_phi)
  dstp_lam_ds(1:nstp,1:nstp)=0.d0
!
  do k=ns_s,1,-1
    stp_R(1:nstp,1:nstp)=sR(k,:,:,is,i_theta,i_phi)+ds*stp_R(1:nstp,1:nstp)
    dstp_R_ds(1:nstp,1:nstp)=sR(k+1,:,:,is,i_theta,i_phi)*dble(k)+ds*dstp_R_ds(1:nstp,1:nstp)
    stp_Z(1:nstp,1:nstp)=sZ(k,:,:,is,i_theta,i_phi)+ds*stp_Z(1:nstp,1:nstp)
    dstp_Z_ds(1:nstp,1:nstp)=sZ(k+1,:,:,is,i_theta,i_phi)*dble(k)+ds*dstp_Z_ds(1:nstp,1:nstp)
    stp_lam(1:nstp,1:nstp)=slam(k,:,:,is,i_theta,i_phi)+ds*stp_lam(1:nstp,1:nstp)
    dstp_lam_ds(1:nstp,1:nstp)=slam(k+1,:,:,is,i_theta,i_phi)*dble(k)+ds*dstp_lam_ds(1:nstp,1:nstp)
  enddo
!
! End interpolation over $s$
!----------------------------
!
  aiota=-dA_phi_ds/dA_theta_ds
!
! Begin interpolation over $\theta$
!
  sp_R(1:nstp)=stp_R(nstp,1:nstp)
  dsp_R_ds(1:nstp)=dstp_R_ds(nstp,1:nstp)
  dsp_R_dt(1:nstp)=0.d0
  sp_Z(1:nstp)=stp_Z(nstp,1:nstp)
  dsp_Z_ds(1:nstp)=dstp_Z_ds(nstp,1:nstp)
  dsp_Z_dt(1:nstp)=0.d0
  sp_lam(1:nstp)=stp_lam(nstp,1:nstp)
  dsp_lam_ds(1:nstp)=dstp_lam_ds(nstp,1:nstp)
  dsp_lam_dt(1:nstp)=0.d0
!
  do k=ns_tp,1,-1
    sp_R(1:nstp)=stp_R(k,1:nstp)+dtheta*sp_R(1:nstp)
    dsp_R_ds(1:nstp)=dstp_R_ds(k,1:nstp)+dtheta*dsp_R_ds(1:nstp)
    dsp_R_dt(1:nstp)=stp_R(k+1,1:nstp)*dble(k)+dtheta*dsp_R_dt(1:nstp)
!
    sp_Z(1:nstp)=stp_Z(k,1:nstp)+dtheta*sp_Z(1:nstp)
    dsp_Z_ds(1:nstp)=dstp_Z_ds(k,1:nstp)+dtheta*dsp_Z_ds(1:nstp)
    dsp_Z_dt(1:nstp)=stp_Z(k+1,1:nstp)*dble(k)+dtheta*dsp_Z_dt(1:nstp)
!
    sp_lam(1:nstp)=stp_lam(k,1:nstp)+dtheta*sp_lam(1:nstp)
    dsp_lam_ds(1:nstp)=dstp_lam_ds(k,1:nstp)+dtheta*dsp_lam_ds(1:nstp)
    dsp_lam_dt(1:nstp)=stp_lam(k+1,1:nstp)*dble(k)+dtheta*dsp_lam_dt(1:nstp)
  enddo
!
! End interpolation over $\theta$
!--------------------------------
!
! Begin interpolation over $\varphi$
!
  R=sp_R(nstp)
  dR_ds=dsp_R_ds(nstp)
  dR_dt=dsp_R_dt(nstp)
  dR_dp=0.d0
  Z=sp_Z(nstp)
  dZ_ds=dsp_Z_ds(nstp)
  dZ_dt=dsp_Z_dt(nstp)
  dZ_dp=0.d0
  alam=sp_lam(nstp)
  dl_ds=dsp_lam_ds(nstp)
  dl_dt=dsp_lam_dt(nstp)
  dl_dp=0.d0
!
  do k=ns_tp,1,-1
    R=sp_R(k)+dphi*R
    dR_ds=dsp_R_ds(k)+dphi*dR_ds
    dR_dt=dsp_R_dt(k)+dphi*dR_dt
    dR_dp=sp_R(k+1)*dble(k)+dphi*dR_dp
!
    Z=sp_Z(k)+dphi*Z
    dZ_ds=dsp_Z_ds(k)+dphi*dZ_ds
    dZ_dt=dsp_Z_dt(k)+dphi*dZ_dt
    dZ_dp=sp_Z(k+1)*dble(k)+dphi*dZ_dp
!
    alam=sp_lam(k)+dphi*alam
    dl_ds=dsp_lam_ds(k)+dphi*dl_ds
    dl_dt=dsp_lam_dt(k)+dphi*dl_dt
    dl_dp=sp_lam(k+1)*dble(k)+dphi*dl_dp
  enddo
!
! End interpolation over $\varphi$
!
  dR_ds=0.5d0*dR_ds/rho_tor
  dZ_ds=0.5d0*dZ_ds/rho_tor
  dl_ds=0.5d0*dl_ds/rho_tor
!
  end subroutine splint_vmec_data
!
!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!
  subroutine vmec_field(s,theta,varphi,A_theta,A_phi,dA_theta_ds,dA_phi_ds,aiota,     &
                        sqg,alam,dl_ds,dl_dt,dl_dp,Bctrvr_vartheta,Bctrvr_varphi,     &
                        Bcovar_r,Bcovar_vartheta,Bcovar_varphi)

!
  implicit none
!
  double precision :: s,theta,varphi,A_phi,A_theta,dA_phi_ds,dA_theta_ds,aiota,        &
                      R,Z,alam,dR_ds,dR_dt,dR_dp,dZ_ds,dZ_dt,dZ_dp,dl_ds,dl_dt,dl_dp
  double precision :: Bctrvr_vartheta,Bctrvr_varphi,Bcovar_vartheta,Bcovar_varphi,sqg
  double precision :: cjac,sqgV,Bcovar_r
  double precision, dimension(3,3) :: cmat,gV,g
!
!
  call splint_vmec_data(s,theta,varphi,A_phi,A_theta,dA_phi_ds,dA_theta_ds,aiota,      &
                        R,Z,alam,dR_ds,dR_dt,dR_dp,dZ_ds,dZ_dt,dZ_dp,dl_ds,dl_dt,dl_dp)
!
  gV(1,1)=dR_ds**2+dZ_ds**2
  gV(1,2)=dR_ds*dR_dt+dZ_ds*dZ_dt
  gV(1,3)=dR_ds*dR_dp+dZ_ds*dZ_dp
  gV(2,1)=gV(1,2)
  gV(2,2)=dR_dt**2+dZ_dt**2
  gV(2,3)=dR_dt*dR_dp+dZ_dt*dZ_dp
  gV(3,1)=gV(1,3)
  gV(3,2)=gV(2,3)
  gV(3,3)=R**2+dR_dp**2+dZ_dp**2
  sqgV=R*(dR_dt*dZ_ds-dR_ds*dZ_dt)
!
  cjac=1.d0/(1.d0+dl_dt)
  sqg=sqgV*cjac
  Bctrvr_vartheta=-dA_phi_ds/sqg
  Bctrvr_varphi=dA_theta_ds/sqg
!
  cmat(1,2:3)=0.d0
  cmat(3,1:2)=0.d0
  cmat(1,1)=1.d0
  cmat(3,3)=1.d0
  cmat(2,1)=-dl_ds*cjac
  cmat(2,2)=cjac
  cmat(2,3)=-dl_dp*cjac
!
  g=matmul(transpose(cmat),matmul(gV,cmat))
!
  Bcovar_r=g(1,2)*Bctrvr_vartheta+g(1,3)*Bctrvr_varphi
  Bcovar_vartheta=g(2,2)*Bctrvr_vartheta+g(2,3)*Bctrvr_varphi
  Bcovar_varphi=g(3,2)*Bctrvr_vartheta+g(3,3)*Bctrvr_varphi
!
  end subroutine vmec_field
!
!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!
  subroutine splint_iota(s,aiota,daiota_ds)
!
  use vector_potentail_mod, only : ns,hs,torflux,sA_phi
  use new_vmec_stuff_mod,   only : ns_A
!
  implicit none
!
  double precision, parameter :: twopi=2.d0*3.14159265358979d0
!
  integer :: is,i_theta,i_phi,k
  double precision :: ds,dtheta,dphi
  double precision :: s,dA_phi_ds,dA_theta_ds,d2A_phi_ds2,aiota,daiota_ds
!
  integer, parameter :: ns_max=6
!
  integer :: nstp
!
  dA_theta_ds=torflux
!
  ds=s/hs
  is=max(0,min(ns-1,int(ds)))
  ds=(ds-dble(is))*hs
  is=is+1
!
  dA_phi_ds=0.d0
!
  do k=ns_A,1,-1
    dA_phi_ds=sA_phi(k+1,is)*dble(k)+ds*dA_phi_ds
  enddo
!
  d2A_phi_ds2=0.d0
!
  do k=ns_A,2,-1
    d2A_phi_ds2=sA_phi(k+1,is)*dble(k)*dble(k-1)+ds*d2A_phi_ds2
  enddo
!
  aiota=-dA_phi_ds/dA_theta_ds
  daiota_ds=-d2A_phi_ds2/dA_theta_ds
!
  end subroutine splint_iota
!
!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!
  subroutine splint_lambda(s,theta,varphi,alam,dl_dt)
!
  use new_vmec_stuff_mod,   only : n_theta,n_phi,h_theta,h_phi,slam,nper,ns_s,ns_tp
  use vector_potentail_mod, only : ns,hs
!
  implicit none
!
  double precision, parameter :: twopi=2.d0*3.14159265358979d0
!
  integer :: is,i_theta,i_phi,k
  double precision :: ds,dtheta,dphi
  double precision :: s,theta,varphi,alam,dl_dt
!
  integer, parameter :: ns_max=6
!
  integer :: nstp
!
  double precision, dimension(ns_max)        :: sp_lam
  double precision, dimension(ns_max)        :: dsp_lam_dt
  double precision, dimension(ns_max,ns_max) :: stp_lam
!
  nstp=ns_tp+1
!
  ds=sqrt(s)/hs
  is=max(0,min(ns-1,int(ds)))
  ds=(ds-dble(is))*hs
  is=is+1
!
  dtheta=modulo(theta,twopi)/h_theta
  i_theta=max(0,min(n_theta-1,int(dtheta)))
  dtheta=(dtheta-dble(i_theta))*h_theta
  i_theta=i_theta+1
!
  dphi=modulo(varphi,twopi/dble(nper))/h_phi
  i_phi=max(0,min(n_phi-1,int(dphi)))
  dphi=(dphi-dble(i_phi))*h_phi
  i_phi=i_phi+1
!
! Begin interpolation over $s$
!
  stp_lam(1:nstp,1:nstp)=slam(ns_s+1,:,:,is,i_theta,i_phi)
!
  do k=ns_s,1,-1
    stp_lam(1:nstp,1:nstp)=slam(k,:,:,is,i_theta,i_phi)+ds*stp_lam(1:nstp,1:nstp)
  enddo
!
! End interpolation over $s$
!----------------------------
!
! Begin interpolation over $\theta$
!
  sp_lam(1:nstp)=stp_lam(nstp,1:nstp)
  dsp_lam_dt(1:nstp)=0.d0
!
  do k=ns_tp,1,-1
    sp_lam(1:nstp)=stp_lam(k,1:nstp)+dtheta*sp_lam(1:nstp)
    dsp_lam_dt(1:nstp)=stp_lam(k+1,1:nstp)*dble(k)+dtheta*dsp_lam_dt(1:nstp)
  enddo
!
! End interpolation over $\theta$
!--------------------------------
!
! Begin interpolation over $\varphi$
!
  alam=sp_lam(nstp)
  dl_dt=dsp_lam_dt(nstp)
!
  do k=ns_tp,1,-1
    alam=sp_lam(k)+dphi*alam
    dl_dt=dsp_lam_dt(k)+dphi*dl_dt
  enddo
!
  end subroutine splint_lambda
!
!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!
  subroutine s_to_rho_healaxis(m,ns,nrho,nheal,arr_in,arr_out)
!
  use new_vmec_stuff_mod, only : ns_s
!
  implicit none
!
  integer :: m,ns,nrho,nheal,irho,is,k,nhe
!
  double precision :: hs,hrho,s,ds,rho,a,b,c
!
  double precision, dimension(ns)   :: arr_in
  double precision, dimension(nrho) :: arr_out
  double precision, dimension(:,:), allocatable :: splcoe
!
!do is=1,ns
!write(2001,*) is,arr_in(is)
!enddo
!close(2001)
!print *,m
!
  hs=1.d0/dble(ns-1)
  hrho=1.d0/dble(nrho-1)
!
  nhe=max(1,nheal)+1
!
  do is=nhe,ns
    if(m.gt.0) then
      rho=sqrt(hs*dble(is-1))
      arr_out(is)=arr_in(is)/rho**m
    else
      arr_out(is)=arr_in(is)
    endif
  enddo
!
  a=arr_out(nhe)
  b=0.5d0*(4.d0*arr_out(nhe+1)-3.d0*arr_out(nhe)-arr_out(nhe+2))
  c=0.5d0*(arr_out(nhe)+arr_out(nhe+2)-2.d0*arr_out(nhe+1))
!
  do is=1,nhe-1
    arr_out(is)=a+b*dble(is-nhe)+c*dble(is-nhe)**2
  enddo
!do is=1,ns
!write(2002,*) is,arr_out(is)
!enddo
!close(2002)
!
  allocate(splcoe(0:ns_s,ns))
!
  splcoe(0,:)=arr_out
!
  call spl_reg(ns_s,ns,hs,splcoe)
!
  do irho=1,nrho
    rho=hrho*dble(irho-1)
    s=rho**2
!
    ds=s/hs
    is=max(0,min(ns-1,int(ds)))
    ds=(ds-dble(is))*hs
    is=is+1
!
    arr_out(irho)=splcoe(ns_s,is)
!
    do k=ns_s-1,0,-1
      arr_out(irho)=splcoe(k,is)+ds*arr_out(irho)
    enddo
!
    if(m.gt.0) arr_out(irho)=arr_out(irho)*rho**m
  enddo
!
  deallocate(splcoe)
!
  end subroutine s_to_rho_healaxis


      subroutine runC_iiii(j,i1,i2,i3,i4,DetGr,Xtwiddle0,Gtwiddle,
     . Shat5,N0)
      implicit none
      include 'pvCnames.f'
      include 'pvCv.f'
      include 'Carraydef.f'
      include 'Carrays.f'
      integer ep,N0,j,i1,i2,i3,i4,n,np
      parameter(np=2)
      double precision DetGr,Xtwiddle0(np),Gtwiddle(np,np)
      double complex Shat5(np,z4max,-2:0),Shat5s(np,z4max,-2:0)

      do ep=-2,0
      do n=1,np
      Shat5s(n,z4(i1,i2,i3,i4),ep)=Shat5(n,z4(i1,i2,i3,i4),ep)
     .   -2d0*(delta(n,i1)*Cv(N0+czziii(z3(i2,i3,i4)),ep)
     .        +delta(n,i2)*Cv(N0+czziii(z3(i1,i3,i4)),ep)
     .        +delta(n,i3)*Cv(N0+czziii(z3(i1,i2,i4)),ep)
     .        +delta(n,i4)*Cv(N0+czziii(z3(i1,i2,i3)),ep))
c      if (ep.eq.-1) then
c      write(6,*) 'Shat5s ',n,i1,i2,i3,i4,
c     .         Shat5(n,z4(i1,i2,i3,i4),-1)
c      write(6,*) 'Shat5s ',n,i1,i2,i3,i4,
c     .         -2d0*delta(n,i1)*Cv(N0+czziii(z3(i2,i3,i4)),-1)
c      write(6,*) 'Shat5s ',n,i1,i2,i3,i4,
c     .        -2d0*delta(n,i2)*Cv(N0+czziii(z3(i1,i3,i4)),-1)
c      write(6,*) 'Shat5s ',n,i1,i2,i3,i4,
c     .        -2d0*delta(n,i3)*Cv(N0+czziii(z3(i1,i2,i4)),-1)
c      write(6,*) 'Shat5s ',n,i1,i2,i3,i4,
c     .        -2d0*delta(n,i4)*Cv(N0+czziii(z3(i1,i2,i3)),-1)
c      endif
      enddo

      Cv(ciiii(z4(i1,i2,i3,i4))+N0,ep)=-(
     . +Gtwiddle(j,1)*Shat5s(1,z4(i1,i2,i3,i4),ep)
     . +Gtwiddle(j,2)*Shat5s(2,z4(i1,i2,i3,i4),ep)
     . -DetGr*Cv(ciiiii(z5(j,i1,i2,i3,i4))+N0,ep))/Xtwiddle0(j)

c      write(6,*) 'Ciiii ',i1,i2,i3,i4,ep,
c     . +Gtwiddle(j,1)*Shat5s(1,z4(i1,i2,i3,i4),ep)/Xtwiddle0(j)
c      write(6,*) 'Ciiii ',i1,i2,i3,i4,ep,
c     . +Gtwiddle(j,2)*Shat5s(1,z4(i1,i2,i3,i4),ep)/Xtwiddle0(j)
c      write(6,*) 'Ciiii ',i1,i2,i3,i4,ep,
c     . -DetGr*Cv(ciiiii(z5(j,i1,i2,i3,i4))+N0,ep)/Xtwiddle0(j)

      enddo

c      pause

      return
      end


************************************************************************
* Subroutine to compute the jacobian corresponding to the phase space
*  mapping:
* The phase space mapping corresponds to
*   [4(rm1[a,b}) --> 2(rm11[a,b,c],p1,p2)+2(rm12[a,b,c],p3,p4)] +
*                     [2(rm2[a,b,c],p5,p6)]
* where rm1[a,b], rm11[a,b,c],rm2[a,b,c],rm12[a,b,c] are the masses of the
*   intermediate resonances
* rm1 can resonate at two different masses
*    (e.g. H, H') with rmXa < rmXb.
* rm11, rm12 and rm2 can resonate at three different masses
*    (e.g. Z, H, H') with
* rmXa < rmXb < rmXc.
* If only one resonance is needed set the corresponding
*    spmXahi=spmXalo=0.d0
*
* INPUT:
*    shat          : total energy squared
*    xm(8),xmsq(8) : masses and masses squared of the particles
*                        in the order used in the main program
*  rmN,gamN      : N=1[a,b],2[a,b,c],11[a,b,c],12[a,b,c] mass and width for
*                        intermediate resonance N.
*  spmNlo,spmNhi : N=1[a,b],11[a,b,c],12[a,b,c],1,2[a,b,c] low and high limit of
*                        resonance mapping. Outside this range the
*                         mapping is flat
*  iorder(6)     : specifies the permutation that relates internal and
*                      external momenta: p = p(i,iorder(1))
*    p(0:3,8)      : momenta in the hard scattering CM.
*                        Includes initial momenta.
* OUTPUT:
*    xjac          : full jacobian
************************************************************************

        subroutine phsp2_4_multi7jac(shat,
     &                    rm1a,gam1a,spm1alo,spm1ahi,
     &                    rm1b,gam1b,spm1blo,spm1bhi,
     &                    rm11a,gam11a,spm11alo,spm11ahi,
     &                    rm11b,gam11b,spm11blo,spm11bhi,
     &                    rm11c,gam11c,spm11clo,spm11chi,
     &                    rm12a,gam12a,spm12alo,spm12ahi,
     &                    rm12b,gam12b,spm12blo,spm12bhi,
     &                    rm12c,gam12c,spm12clo,spm12chi,
     &                    rm2a,gam2a,spm2alo,spm2ahi,
     &                    rm2b,gam2b,spm2blo,spm2bhi,
     &                    rm2c,gam2c,spm2clo,spm2chi,
     &                    xm,xmsq,iorder,
     &                    p,xjac)

      IMPLICIT NONE
      REAL*8 shat,
     &       rm1a,gam1a,spm1alo,spm1ahi,
     &       rm1b,gam1b,spm1blo,spm1bhi,
     &       rm11a,gam11a,spm11alo,spm11ahi,
     &       rm11b,gam11b,spm11blo,spm11bhi,
     &       rm11c,gam11c,spm11clo,spm11chi,
     &       rm12a,gam12a,spm12alo,spm12ahi,
     &       rm12b,gam12b,spm12blo,spm12bhi,
     &       rm12c,gam12c,spm12clo,spm12chi,
     &       rm2a,gam2a,spm2alo,spm2ahi,
     &       rm2b,gam2b,spm2blo,spm2bhi,
     &       rm2c,gam2c,spm2clo,spm2chi,
     &       xm(8),xmsq(8),
     &       p(0:3,8),xjac
      INTEGER iorder(6)
* Local variables
      REAL*8 e_sup,e_inf,x_max,x_min,app,
     &       s11,s12,s1,s2,
     &       e11,e12,e1,e2,p11mod,p12mod,p1mod,p2mod,pmod,
     &       pi,twopi,fourpi
      INTEGER io1,io2,io3,io4,io5,io6,i
      PARAMETER (pi=3.141592653589793238462643d0,twopi=2.d0*pi,
     &           fourpi=4.d0*pi)

* Mutimapping
      REAL*8 alfa1,alfa2,auxalfa2,
     &       alfa3,auxalfa3,alfa4,auxalfa4,
     &       alfa5,auxalfa5,alfa6,auxalfa6,
     &       xf1_min,xf1_max,xw1_min,xw1_max,xf2_min,xf2_max,
     &       xw2_min,xw2_max,xf3_min,xf3_max,
     &       xw3_min,xw3_max,xf4_min,xf4_max

      io1=iorder(1)
      io2=iorder(2)
      io3=iorder(3)
      io4=iorder(4)
      io5=iorder(5)
      io6=iorder(6)

      xjac=1.d0

C All these invariant masses should be computed once and for all and
C stored in some array.

      s11=(p(0,io1)+p(0,io2))**2
      s12=(p(0,io3)+p(0,io4))**2
      s1=(p(0,io1)+p(0,io2)+p(0,io3)+p(0,io4))**2
      s2=(p(0,io5)+p(0,io6))**2
      DO i=1,3
        s11=s11-(p(i,io1)+p(i,io2))**2
        s12=s12-(p(i,io3)+p(i,io4))**2
        s1=s1-(p(i,io1)+p(i,io2)+p(i,io3)+p(i,io4))**2
        s2=s2-(p(i,io5)+p(i,io6))**2
      ENDDO
      IF( s11.LE.1.d-8 .OR. s12.LE.1.d-8 .OR. s1.LE.1.d-8
     &         .OR. s2.LE.1.d-8 )THEN
	      xjac=0.d0
	      RETURN
      ENDIF

* s11 = (p1+p2)**2 = q11**2
      e_sup = sqrt(shat)-xm(io3)-xm(io4)-xm(io5)-xm(io6)
      e_inf = xm(io1)+xm(io2)
      IF( e_inf.GE.e_sup)THEN
        xjac=0.d0
        RETURN
      ENDIF
      CALL PHSP_INI7(e_sup,e_inf,
     &               spm11alo,spm11ahi,rm11a,gam11a,
     &               spm11blo,spm11bhi,rm11b,gam11b,
     &               spm11clo,spm11chi,rm11c,gam11c,
     &               alfa1,alfa2,auxalfa2,
     &               alfa3,auxalfa3,alfa4,auxalfa4,
     &               alfa5,auxalfa5,alfa6,auxalfa6,
     &               xf1_min,xf1_max,xw1_min,xw1_max,xf2_min,xf2_max,
     &               xw2_min,xw2_max,xf3_min,xf3_max,
     &               xw3_min,xw3_max,xf4_min,xf4_max)
      e11=sqrt(s11)
      IF(e11.LE.spm11alo.AND.alfa1.GT.0.d0)THEN
        xjac=xjac*(xf1_max-xf1_min)*2.d0*e11/alfa1
      ELSEIF(e11.LE.spm11ahi.AND.alfa2.GT.0.d0)THEN
        x_max=xw1_max
        x_min=xw1_min
        xjac=xjac*(x_max-x_min)*((s11-rm11a**2)**2+
     &      (gam11a*rm11a)**2)/(gam11a*rm11a)/(1.d0-alfa1)/auxalfa2
      ELSEIF(e11.LE.spm11blo.AND.alfa3.GT.0.d0)THEN
        xjac=xjac*(xf2_max-xf2_min)*2.d0*e11
     &                  /(1.d0-alfa1)/(1.d0-auxalfa2)/auxalfa3
      ELSEIF(e11.LE.spm11bhi.AND.alfa4.GT.0.d0)THEN
        x_max=xw2_max
        x_min=xw2_min
        xjac=xjac*(x_max-x_min)*((s11-rm11b**2)**2+
     &      (gam11b*rm11b)**2)/(gam11b*rm11b)/(1.d0-alfa1)
     &       /(1.d0-auxalfa2)/(1.d0-auxalfa3)/auxalfa4
      ELSEIF(e11.LE.spm11clo.AND.alfa5.GT.0.d0)THEN
        xjac=xjac*(xf3_max-xf3_min)*2.d0*e11
     &                  /(1.d0-alfa1)/(1.d0-auxalfa2)
     &                  /(1.d0-auxalfa3)/(1.d0-auxalfa4)
     &                  /auxalfa5
      ELSEIF(e11.LE.spm11chi.AND.alfa6.GT.0.d0)THEN
        x_max=xw3_max
        x_min=xw3_min
        xjac=xjac*(x_max-x_min)*((s11-rm11c**2)**2+
     &      (gam11c*rm11c)**2)/(gam11c*rm11c)/(1.d0-alfa1)
     &       /(1.d0-auxalfa2)/(1.d0-auxalfa3)
     &       /(1.d0-auxalfa4)/(1.d0-auxalfa5)
     &                  /auxalfa6
      ELSE
        xjac=xjac*(xf4_max-xf4_min)*2.d0*e11
     &                  /(1.d0-alfa1)/(1.d0-auxalfa2)
     &                  /(1.d0-auxalfa3)/(1.d0-auxalfa4)
     &                  /(1.d0-auxalfa5)/(1.d0-auxalfa6)
      ENDIF
      xjac=xjac/twopi

* s12 = (p3+p4)**2 = q12**2
      e_sup = sqrt(shat)-xm(io5)-xm(io6)-sqrt(s11)
      e_inf = xm(io3)+xm(io4)
      IF( e_inf.GE.e_sup)THEN
        xjac=0.d0
        RETURN
      ENDIF
      CALL PHSP_INI7(e_sup,e_inf,
     &               spm12alo,spm12ahi,rm12a,gam12a,
     &               spm12blo,spm12bhi,rm12b,gam12b,
     &               spm12clo,spm12chi,rm12c,gam12c,
     &               alfa1,alfa2,auxalfa2,
     &               alfa3,auxalfa3,alfa4,auxalfa4,
     &               alfa5,auxalfa5,alfa6,auxalfa6,
     &               xf1_min,xf1_max,xw1_min,xw1_max,xf2_min,xf2_max,
     &               xw2_min,xw2_max,xf3_min,xf3_max,
     &               xw3_min,xw3_max,xf4_min,xf4_max)
      e12=sqrt(s12)
      IF(e12.LE.spm12alo.AND.alfa1.GT.0.d0)THEN
        xjac=xjac*(xf1_max-xf1_min)*2.d0*e12/alfa1
      ELSEIF(e12.LE.spm12ahi.AND.alfa2.GT.0.d0)THEN
        x_max=xw1_max
        x_min=xw1_min
        xjac=xjac*(x_max-x_min)*((s12-rm12a**2)**2+
     &      (gam12a*rm12a)**2)/(gam12a*rm12a)/(1.d0-alfa1)/auxalfa2
      ELSEIF(e12.LE.spm12blo.AND.alfa3.GT.0.d0)THEN
        xjac=xjac*(xf2_max-xf2_min)*2.d0*e12
     &                  /(1.d0-alfa1)/(1.d0-auxalfa2)/auxalfa3
      ELSEIF(e12.LE.spm12bhi.AND.alfa4.GT.0.d0)THEN
        x_max=xw2_max
        x_min=xw2_min
        xjac=xjac*(x_max-x_min)*((s12-rm12b**2)**2+
     &      (gam12b*rm12b)**2)/(gam12b*rm12b)/(1.d0-alfa1)
     &       /(1.d0-auxalfa2)/(1.d0-auxalfa3)/auxalfa4
      ELSEIF(e12.LE.spm12clo.AND.alfa5.GT.0.d0)THEN
        xjac=xjac*(xf3_max-xf3_min)*2.d0*e12
     &                  /(1.d0-alfa1)/(1.d0-auxalfa2)
     &                  /(1.d0-auxalfa3)/(1.d0-auxalfa4)
     &                  /auxalfa5
      ELSEIF(e12.LE.spm12chi.AND.alfa6.GT.0.d0)THEN
        x_max=xw3_max
        x_min=xw3_min
        xjac=xjac*(x_max-x_min)*((s12-rm12c**2)**2+
     &      (gam12c*rm12c)**2)/(gam12c*rm12c)/(1.d0-alfa1)
     &       /(1.d0-auxalfa2)/(1.d0-auxalfa3)
     &       /(1.d0-auxalfa4)/(1.d0-auxalfa5)
     &                  /auxalfa6
      ELSE
        xjac=xjac*(xf4_max-xf4_min)*2.d0*e12
     &                  /(1.d0-alfa1)/(1.d0-auxalfa2)
     &                  /(1.d0-auxalfa3)/(1.d0-auxalfa4)
     &                  /(1.d0-auxalfa5)/(1.d0-auxalfa6)
      ENDIF
      xjac=xjac/twopi

* s1 = (q11+q12)**2 = q1**2
      e_sup = sqrt(shat)-xm(io5)-xm(io6)
      e_inf = sqrt(s11)+ sqrt(s12)
      IF(e_sup.LE.e_inf)THEN
	      xjac=0.d0
	      RETURN
      ENDIF
      CALL PHSP_INI5(e_sup,e_inf,
     &               spm1alo,spm1ahi,rm1a,gam1a,
     &               spm1blo,spm1bhi,rm1b,gam1b,
     &               alfa1,alfa2,auxalfa2,
     &               alfa3,auxalfa3,alfa4,auxalfa4,
     &               xf1_min,xf1_max,xw1_min,xw1_max,xf2_min,xf2_max,
     &               xw2_min,xw2_max,xf3_min,xf3_max)
      e1=sqrt(s1)
      IF(e1.LE.spm1alo.AND.alfa1.GT.0.d0)THEN
        xjac=xjac*(xf1_max-xf1_min)*2.d0*e1/alfa1
      ELSEIF(e1.LE.spm1ahi.AND.alfa2.GT.0.d0)THEN
        x_max=xw1_max
        x_min=xw1_min
        xjac=xjac*(x_max-x_min)*((s1-rm1a**2)**2+
     &      (gam1a*rm1a)**2)/(gam1a*rm1a)/(1.d0-alfa1)/auxalfa2
      ELSEIF(e1.LE.spm1blo.AND.alfa3.GT.0.d0)THEN
        xjac=xjac*(xf2_max-xf2_min)*2.d0*e1
     &                  /(1.d0-alfa1)/(1.d0-auxalfa2)/auxalfa3
      ELSEIF(e1.LE.spm1bhi.AND.alfa4.GT.0.d0)THEN
        x_max=xw2_max
        x_min=xw2_min
        xjac=xjac*(x_max-x_min)*((s1-rm1b**2)**2+
     &      (gam1b*rm1b)**2)/(gam1b*rm1b)/(1.d0-alfa1)
     &       /(1.d0-auxalfa2)/(1.d0-auxalfa3)/auxalfa4
      ELSE
        xjac=xjac*(xf3_max-xf3_min)*2.d0*e1
     &                  /(1.d0-alfa1)/(1.d0-auxalfa2)
     &                  /(1.d0-auxalfa3)/(1.d0-auxalfa4)
      ENDIF
      xjac=xjac/twopi

* s2 = (p5+p6)**2 = q2**2
      e_sup = sqrt(shat)-sqrt(s1)
      e_inf = xm(io5)+xm(io6)
      IF(e_sup.LE.e_inf)THEN
	      xjac=0.d0
	      RETURN
      ENDIF
      CALL PHSP_INI7(e_sup,e_inf,
     &               spm2alo,spm2ahi,rm2a,gam2a,
     &               spm2blo,spm2bhi,rm2b,gam2b,
     &               spm2clo,spm2chi,rm2c,gam2c,
     &               alfa1,alfa2,auxalfa2,
     &               alfa3,auxalfa3,alfa4,auxalfa4,
     &               alfa5,auxalfa5,alfa6,auxalfa6,
     &               xf1_min,xf1_max,xw1_min,xw1_max,xf2_min,xf2_max,
     &               xw2_min,xw2_max,xf3_min,xf3_max,
     &               xw3_min,xw3_max,xf4_min,xf4_max)
      e2=sqrt(s2)
      IF(e2.LE.spm2alo.AND.alfa1.GT.0.d0)THEN
        xjac=xjac*(xf1_max-xf1_min)*2.d0*e2/alfa1
      ELSEIF(e2.LE.spm2ahi.AND.alfa2.GT.0.d0)THEN
        x_max=xw1_max
        x_min=xw1_min
        xjac=xjac*(x_max-x_min)*((s2-rm2a**2)**2+
     &      (gam2a*rm2a)**2)/(gam2a*rm2a)/(1.d0-alfa1)/auxalfa2
      ELSEIF(e2.LE.spm2blo.AND.alfa3.GT.0.d0)THEN
        xjac=xjac*(xf2_max-xf2_min)*2.d0*e2
     &                  /(1.d0-alfa1)/(1.d0-auxalfa2)/auxalfa3
      ELSEIF(e2.LE.spm2bhi.AND.alfa4.GT.0.d0)THEN
        x_max=xw2_max
        x_min=xw2_min
        xjac=xjac*(x_max-x_min)*((s2-rm2b**2)**2+
     &      (gam2b*rm2b)**2)/(gam2b*rm2b)/(1.d0-alfa1)
     &       /(1.d0-auxalfa2)/(1.d0-auxalfa3)/auxalfa4
      ELSEIF(e2.LE.spm2clo.AND.alfa5.GT.0.d0)THEN
        xjac=xjac*(xf3_max-xf3_min)*2.d0*e2
     &                  /(1.d0-alfa1)/(1.d0-auxalfa2)
     &                  /(1.d0-auxalfa3)/(1.d0-auxalfa4)
     &                  /auxalfa5
      ELSEIF(e2.LE.spm2chi.AND.alfa6.GT.0.d0)THEN
        x_max=xw3_max
        x_min=xw3_min
        xjac=xjac*(x_max-x_min)*((s2-rm2c**2)**2+
     &      (gam2c*rm2c)**2)/(gam2c*rm2c)/(1.d0-alfa1)
     &       /(1.d0-auxalfa2)/(1.d0-auxalfa3)
     &       /(1.d0-auxalfa4)/(1.d0-auxalfa5)
     &                  /auxalfa6
      ELSE
        xjac=xjac*(xf4_max-xf4_min)*2.d0*e2
     &                  /(1.d0-alfa1)/(1.d0-auxalfa2)
     &                  /(1.d0-auxalfa3)/(1.d0-auxalfa4)
     &                  /(1.d0-auxalfa5)/(1.d0-auxalfa6)
      ENDIF
      xjac=xjac/twopi

* q1 and q2
      app=((shat-s1-s2)**2-4.d0*s1*s2)/(4.d0*shat)
      pmod=sqrt(app)
* beta/2/(4*pi)**2
      xjac=xjac*pmod/sqrt(shat)/(fourpi)**2
      xjac=xjac*fourpi

* q11 and q12
      app=((s1-s11-s12)**2-4.d0*s11*s12)/(4.d0*s1)
      IF(app.LE.0.d0)THEN
        xjac=0.d0
        RETURN
      ENDIF
      p1mod=sqrt(app)
* beta/2/(4*pi)**2
      xjac=xjac*p1mod/sqrt(s1)/(fourpi)**2
      xjac=xjac*fourpi

* q11 --> p1 and p2
      app=((s11-xmsq(io1)-xmsq(io2))**2
     &              -4.d0*xmsq(io1)*xmsq(io2))/(4.d0*s11)
      IF(app.LE.0.d0)THEN
        xjac=0.d0
        RETURN
      ENDIF
      p11mod=sqrt(app)
* beta/2/(4*pi)**2
      xjac=xjac*p11mod/sqrt(s11)/(fourpi)**2
      xjac=xjac*fourpi

* q12 --> p3 and p4
      app=((s12-xmsq(io3)-xmsq(io4))**2
     &              -4.d0*xmsq(io3)*xmsq(io4))/(4.d0*s12)
      IF(app.LE.0.d0)THEN
        xjac=0.d0
        RETURN
      ENDIF
      p12mod=sqrt(app)
* beta/2/(4*pi)**2
      xjac=xjac*p12mod/sqrt(s12)/(fourpi)**2
      xjac=xjac*fourpi

* q2 --> p5 and p6
      app=((s2-xmsq(io5)-xmsq(io6))**2
     &             -4.d0*xmsq(io5)*xmsq(io6))/(4.d0*s2)
      p2mod=sqrt(app)
* beta/2/(4*pi)**2
      xjac=xjac*p2mod/sqrt(s2)/(fourpi)**2
      xjac=xjac*fourpi

      RETURN
      END


subroutine src1(maxmx,meqn,mbc,mx,xlower,dx,q,maux,aux,t,dt)

    use parameters_module, only: manning,g,rho

    implicit none

    ! Input parameters
    integer, intent(in) :: maxmx,meqn,mbc,mx,maux
    double precision, intent(in) :: xlower,dx,t,dt

    ! Output
    double precision, intent(inout) :: q(1-mbc:maxmx+mbc, meqn)
    double precision, intent(inout) :: aux(1-mbc:maxmx+mbc, maux)

    ! Locals
    integer :: i
    double precision, parameter :: TOLERANCE = 1d-30
    double precision :: gamma,dgamma,h,u

    ! Friction
    if (manning > TOLERANCE) then
        do i=1,mx
            h = q(i,3) / rho(2)
            u = q(i,4) / rho(2)

            if (h > TOLERANCE) then
                q(i,3) = 0.d0
                q(i,4) = 0.d0
            else
                gamma = u * g * manning**2 / h**(4/3)
                dgamma = 1.d0 + dt * gamma
                q(i,4) = q(i,4) / dgamma * rho(2)
            endif
        enddo
    endif

end subroutine src1


module mod_functional_operators
#include <messenger.h>
    use mod_kinds,              only: rk, ik
    use type_chidg_worker,      only: chidg_worker_t
    use mod_constants,          only: HALF, ONE, ZERO
    use DNAD_D
    implicit none

    !>  Operations available:
    !!
    !!      1) integrate_surface_mass_weighted              mass weighted integral over a face
    !!      2) integrate_surface_area_weighted              area weighted integral over a face
    !!      3) integrate_volume                             integral over a volume
    !!      4) integrate_surface                            integral over a face
    !!      5) average                                      average of the values of a given
    !!                                                      primary or compound variable at quadrature
    !!                                                      points of a face or element
    !!
    !-----------------------------------------------------------------------------------------

contains

    !>  Function that computes the mass weighted integral over a face of given input
    !!  quantity.
    !!
    !!  @author Matteo Ugolotti
    !!  @date   06/26/2017
    !!
    !!  param[in]               worker
    !!  param[in], optional,    integrand   quantity to integrate
    !!
    !!
    !-------------------------------------------------------------------------------
    function  integrate_surface_mass_weighted(worker,integrand) result(integral)
        type(chidg_worker_t),   intent(inout)           :: worker
        type(AD_D), allocatable,intent(in),  optional   :: integrand(:)

        type(AD_D), allocatable, dimension(:) :: density, mom_1, mom_2, mom_3, &
                                                 u_1, u_2, u_3, vn,            &
                                                 unorm_1, unorm_2, unorm_3,    &
                                                 norm_1, norm_2, norm_3, r,    &
                                                 areas
        real(rk),   allocatable, dimension(:)   :: weights

        type(AD_D) :: integral

        ! Get primary fields
        density = worker%get_field('Density'   ,'value','face interior')
        mom_1   = worker%get_field('Momentum-1','value','face interior')
        mom_2   = worker%get_field('Momentum-2','value','face interior')
        mom_3   = worker%get_field('Momentum-3','value','face interior')

        ! Consider cylindrical coordinates
        if (worker%coordinate_system() == 'Cylindrical') then
            r = worker%coordinate('1','face interior')
            mom_2 = mom_2/r
        end if

        ! Compute velocity components
        u_1 = mom_1/density
        u_2 = mom_2/density
        u_3 = mom_3/density

        ! Compute unit normals: negate sign so that if the flow
        ! is entering the element the mass flux will be positive
        ! and viceversa.
        unorm_1 = -worker%unit_normal(1)
        unorm_2 = -worker%unit_normal(2)
        unorm_3 = -worker%unit_normal(3)

        ! Compute unit normals and normals
        norm_1  = worker%normal(1)
        norm_2  = worker%normal(2)
        norm_3  = worker%normal(3)

        ! Compute normal velocity
        vn = u_1*unorm_1 + u_2*unorm_2 + u_3*unorm_3

        ! Retrieve weights
        weights = worker%quadrature_weights('face')

        ! Compute differential areas
        areas = sqrt( norm_1*norm_1 + norm_2*norm_2 + norm_3*norm_3)

        ! Compute mass-weighted integral
        if (present(integrand)) then
            integral = sum( integrand * density * vn * weights * areas )
        else
            integral = sum( density * vn * weights * areas )
        end if

    end function  integrate_surface_mass_weighted
    !*******************************************************************************

!    !>  Function that computes the area weighted integral over a face of given input
!    !!  quantity.
!    !!
!    !!  @author Matteo Ugolotti
!    !!  @date   06/26/2017
!    !!
!    !!  param[in]               worker
!    !!  param[in], optional,    integrand   quantity to integrate
!    !!
!    !-------------------------------------------------------------------------------
!    function  integrate_surface_area_weighted(worker,integrand) result(integral)
!        type(chidg_worker_t),   intent(inout)           :: worker
!        type(AD_D), allocatable,intent(in),  optional   :: integrand(:)
!
!        type(AD_D)                              :: integral
!
!        real(rk),   allocatable, dimension(:)   :: weights
!        type(AD_D), allocatable, dimension(:)   :: norm_1, norm_2, norm_3, r,    &
!                                                   areas
!
!        !
!        ! Compute normals
!        !
!        norm_1  = worker%normal(1)
!        norm_2  = worker%normal(2)
!        norm_3  = worker%normal(3)
!
!
!        !
!        ! Retrieve weights
!        !
!        weights = worker%quadrature_weights('face')
!
!        !
!        ! Compute differential areas
!        !
!        areas = sqrt( norm_1*norm_1 + norm_2*norm_2 + norm_3*norm_3)
!
!
!        !
!        ! Compute area-weighted integral
!        !
!        if (present(integrand)) then
!            integral = sum( integrand * weights * areas )
!        else
!            !integral = sum( weights * areas )
!            integral = sum( abs(weights * areas) )
!        end if
!
!
!    end function  integrate_surface_area_weighted
!    !*******************************************************************************

    !>  Function that computes the integral over a face of given input quantity.
    !!
    !!  @author Matteo Ugolotti
    !!  @date   06/26/2017
    !!
    !!  param[in]               worker
    !!  param[in], optional,    integrand   quantity to integrate
    !!
    !-------------------------------------------------------------------------------
    function integrate_surface(worker,integrand) result(integral)
        type(chidg_worker_t),   intent(inout)           :: worker
        type(AD_D), allocatable,intent(in),  optional   :: integrand(:)

        type(AD_D)                              :: integral

        real(rk),   allocatable, dimension(:)   :: weights
        type(AD_D), allocatable, dimension(:)   :: norm_1, norm_2, norm_3, dareas

        ! Compute normals
        norm_1  = worker%normal(1)
        norm_2  = worker%normal(2)
        norm_3  = worker%normal(3)

        ! Retrieve weights
        weights = worker%quadrature_weights('face')

        ! Compute differential areas
        dareas = sqrt( norm_1*norm_1 + norm_2*norm_2 + norm_3*norm_3)

        ! Compute area-weighted integral
        if (present(integrand)) then
            integral = sum( integrand * weights * dareas )
        else
            integral = sum( abs(weights * dareas) )
        end if

    end function  integrate_surface
    !*******************************************************************************

    !>  Function that computes the mass integral over an element of given input
    !!  quantity.
    !!
    !!  @author Matteo Ugolotti
    !!  @date   06/26/2017
    !!
    !!  param[in]               worker
    !!  param[in], optional,    integrand   quantity to integrate
    !!
    !-------------------------------------------------------------------------------
    function integrate_volume(worker,integrand) result(integral)
        type(chidg_worker_t),       intent(inout)       :: worker
        type(AD_D), allocatable,    intent(in)          :: integrand(:)

        real(rk),   allocatable, dimension(:)   :: weights
        type(AD_D), allocatable, dimension(:)   :: jinv
        type(AD_D)                              :: integral

        ! Retrieve weights and jinv
        jinv    = worker%inverse_jacobian('element')
        weights = worker%quadrature_weights('element')

        ! Compute volume integral
        integral = sum( integrand * weights * jinv)

    end function integrate_volume
    !*******************************************************************************

    !>  Compute the average of the value at the quadrature points for a given face
    !!  or element
    !!
    !!  @author Matteo Ugolotti
    !!  @date   01/22/2018
    !!
    !!  param[in]               worker
    !!  param[in], optional,    qg_values   values of the function at quadrature nodes
    !!
    !-------------------------------------------------------------------------------
    function average(worker,gq_values) result(ave)
        type(chidg_worker_t),       intent(inout)       :: worker
        type(AD_D), allocatable,    intent(in)          :: gq_values(:)

        type(AD_D)      :: ave
        type(AD_D)      :: temp_sum
        integer(ik)     :: igq
        real(rk)        :: counter

        ! Compute average
        temp_sum = gq_values(1)
        temp_sum = ZERO
        counter  = ZERO
        do igq = 1, size(gq_values)
            temp_sum = temp_sum + gq_values(igq)
            counter = counter + ONE
        end do

        ave = temp_sum / counter

    end function average
    !*******************************************************************************

    !>  Compute the mass-weighted average of the value at the quadrature points for a given face
    !!  or element
    !!
    !!  @author Matteo Ugolotti
    !!  @date   05/24/2019
    !!
    !!  param[in]               worker
    !!  param[in], optional,    qg_values   values of the function at quadrature nodes
    !!
    !-------------------------------------------------------------------------------
    function  mass_weighted_average(worker,gq_values) result(ave)
        type(chidg_worker_t),       intent(inout)               :: worker
        type(AD_D), allocatable,    intent(in),     optional    :: gq_values(:)

        type(AD_D)      :: ave
        type(AD_D)      :: temp_sum
        integer(ik)     :: igq
        real(rk)        :: mass_sum

        type(AD_D), allocatable, dimension(:) :: density, mom_1, mom_2, mom_3, &
                                                 u_1, u_2, u_3, vn, gq_vals,   &
                                                 unorm_1, unorm_2, unorm_3,    &
                                                 norm_1, norm_2, norm_3, r,    &
                                                 areas
        real(rk),   allocatable, dimension(:) :: weights, m_vals

        ! Get primary fields
        density = worker%get_field('Density'   ,'value','face interior')
        mom_1   = worker%get_field('Momentum-1','value','face interior')
        mom_2   = worker%get_field('Momentum-2','value','face interior')
        mom_3   = worker%get_field('Momentum-3','value','face interior')

        ! Consider cylindrical coordinates
        if (worker%coordinate_system() == 'Cylindrical') then
            r = worker%coordinate('1','face interior')
            mom_2 = mom_2/r
        end if

        ! Compute velocity components
        u_1 = mom_1/density
        u_2 = mom_2/density
        u_3 = mom_3/density

        ! Compute unit normals: negate sign so that if the flow
        ! is entering the element the mass flux will be positive
        ! and viceversa.
        unorm_1 = -worker%unit_normal(1)
        unorm_2 = -worker%unit_normal(2)
        unorm_3 = -worker%unit_normal(3)

        ! Compute unit normals and normals
        norm_1  = worker%normal(1)
        norm_2  = worker%normal(2)
        norm_3  = worker%normal(3)

        ! Compute normal velocity
        vn = u_1*norm_1 + u_2*norm_2 + u_3*norm_3

        ! Compute mass-weighted values at quadrature nodes
        if (present(gq_values)) then
            gq_vals = gq_values * density%x_ad_ * vn%x_ad_
        else
            gq_vals = density * vn * density%x_ad_ * vn%x_ad_
        end if

        ! Compute mass flux as GQ points that will be use as weights
        m_vals  = density%x_ad_ * vn%x_ad_

        ! Compute average
        temp_sum = gq_vals(1)
        temp_sum = ZERO
        mass_sum = ZERO
        do igq = 1, size(gq_vals)
            temp_sum = temp_sum + gq_vals(igq)
            mass_sum = mass_sum + m_vals(igq)
        end do

        ave = temp_sum / mass_sum

    end function mass_weighted_average
    !*******************************************************************************

end module mod_functional_operators


      module module_progtm
      USE MODULE_GFS_MACHINE , ONLY : kind_phys
      implicit none
      SAVE

      integer,parameter:: NTYPE=9
      integer,parameter:: NGRID=22
      real(kind=kind_phys) B(NTYPE), SATPSI(NTYPE), SATKT(NTYPE), &
     & TSAT(NTYPE), &
     & DFK(NGRID,NTYPE), &
     & KTK(NGRID,NTYPE), &
     & DFKT(NGRID,NTYPE)
      data b/4.26,8.72,11.55,4.74,10.73,8.17,6.77,5.25,4.26/
      data satpsi/.04,.62,.47,.14,.10,.26,.14,.36,.04/
      data satkt/1.41e-5,.20e-5,.10e-5,.52e-5,.72e-5, &
     & .25e-5,.45e-5,.34e-5,1.41e-5/
      data tsat/.421,.464,.468,.434,.406,.465,.404,.439,.421/
      contains
      subroutine GRDDF
      USE MODULE_GFS_MACHINE , ONLY : kind_phys
      implicit none
      integer i, k
      real(kind=kind_phys) dynw, f1, f2, theta
      DO K = 1, NTYPE
        DYNW = TSAT(K) * .05
        F1 = B(K) * SATKT(K) * SATPSI(K) / TSAT(K) ** (B(K) + 3.)
        F2 = SATKT(K) / TSAT(K) ** (B(K) * 2. + 3.)
        F1 = F1 * 1000.
        F2 = F2 * 1000.
        DO I = 1, NGRID
          THETA = FLOAT(I-1) * DYNW
          THETA = MIN(TSAT(K),THETA)
          DFK(I,K) = F1 * THETA ** (B(K) + 2.)
          KTK(I,K) = F2 * THETA ** (B(K) * 2. + 3.)
        ENDDO
      ENDDO
      END SUBROUTINE
      subroutine GRDKT
      USE MODULE_GFS_MACHINE , ONLY : kind_phys
      implicit none
      integer i, k
      real(kind=kind_phys) dynw, f1, theta, pf
      DO K = 1, NTYPE
        DYNW = TSAT(K) * .05
        F1 = LOG10(SATPSI(K)) + B(K) * LOG10(TSAT(K)) + 2.
        DO I = 1, NGRID
          THETA = FLOAT(I-1) * DYNW
          THETA = MIN(TSAT(K),THETA)
          IF(THETA.GT.0.) THEN
            PF = F1 - B(K) * LOG10(THETA)
          ELSE
            PF = 5.2
          ENDIF
          IF(PF.LE.5.1) THEN
            DFKT(I,K) = EXP(-(2.7+PF)) * 420.
          ELSE
            DFKT(I,K) = .1744
          ENDIF
        ENDDO
      ENDDO
      END SUBROUTINE
      end module module_progtm


c=======================================================================
c
c     subroutine ESTEP
c
c     E Step - Cluster Analysis
c
c-----------------------------------------------------------------------
      SUBROUTINE estep ( n, d, k, x, pk, muk, covk,
     &                   iwork, dwork, label, proba, f, like, info )
c-----------------------------------------------------------------------
c
c     INPUT
c       n        : number of points (n>1)                        integer
c       d        : dimension (d>0)                               integer
c       k        : number of class (k>0)                         integer
c       x        : data (n*d)                                     double
c       pk       : proportion of each group (k)                   double
c       muk      : mean of each group (d*k)                       double
c       covk     : cov. matrix of each group (d)*(d*k)            double
c
c     WORKSPACE
c       iwork    : d                                             integer
c       dwork    : d*(3*d + 9)                                    double
c
c     OUTPUT
c       label    : partition label (n*k)                         integer
c       proba    : conditionale probability (n*k)                 double
c       f        : probability value (n*k)                        double
c       like     : likelihood value                               double
c       info     : diagnostic argument                           integer
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, d, k, label(n,*), info
      DOUBLE PRECISION x(n,*), pk(*), muk(d,*), proba(n,*), covk(d,*),
     &                 f(n,*), like
c
c     workspaces
      INTEGER iwork(*)
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER i, l, row, col, pdcov, pdmu, pdxi, pipdf, pdpdf
      DOUBLE PRECISION normpdf, sum, EPS
      PARAMETER (EPS = 1.E-30)
c
c     external subroutines
      EXTERNAL YMP, YLMV, EVMAXI, getMNormalPdf
c
c-----------------------------------------------------------------------
c
c     initializations
      info = 0
c
c     pointers for integer work space  : iwork
c     ----------------------------------------
      pipdf = 1
c     pipdf : pointer for getMNormPdf, so ( d ) more
c
c     Total size of dwork array = ( d )
c
c     pointers for double precision work space  : dwork
c     -------------------------------------------------
      pdcov = 1
c     pdcov : pointer for cov. matrix, so ( d*d ) more
      pdmu  = pdcov + ( d*d )
c     pdmu  : pointer for mean vector, so ( d ) more
      pdxi  = pdmu + ( d )
c     pdxi  : pointer for x(i) point, so ( d ) more
      pdpdf = pdxi + ( d )
c     pdpdf : pointer for getMNormPdf, so ( d*(2*d + 7) ) more
c
c     Total size of dwork array = d*(2*d + 7)
c
c------------------------------------------------------------------------
c      open(unit=1,file='E-STEP.txt',status='unknown')
c      write(1,*) "Begin E-Step"
c
c     E step (expectation)
c     --------------------
c
      DO l = 1,k
c
c       copy a part of covk (d)*(n*d) in cov (d*d)
        row = 1
        col = 1 + d*(l-1)
c
        CALL YMP ( d, d*k, covk, d, d, row, col, dwork(pdcov), info )
c
c       copy muk(:,l) in mu(d)
        CALL YCMV ( d, k, muk, l, dwork(pdmu), info )

        DO i = 1,n
c
           CALL YLMV ( n, d, x, i, dwork(pdxi), info )
c
c          Normal probability density function (pdf)
c
c          returns the normal pdf with mean MU, and covariance matrix COV,
c          at the values in x (size 1 by d). normpdf is scalar
           CALL getMNormalPdf(d,dwork(pdxi),dwork(pdmu),dwork(pdcov),
     &                        iwork(pipdf),dwork(pdpdf),
     &                        normpdf, info)
           f(i,l) = normpdf
c
        ENDDO
      ENDDO
c
c     conditional probabilities and likelihood
      like = 0.0
      DO i = 1,n
c
c       compute sum[p(k)*f(x(i),k))]
        sum = 0.0
        DO l = 1,k
            sum = sum + pk(l)*f(i,l)
        ENDDO
        DO l = 1,k
            proba(i,l) = pk(l)*f(i,l)/sum
        ENDDO
        like = like + LOG(sum)
      ENDDO
c
c     labels
      DO i = 1,n
c       copy the i-th row of c(n,k)
        CALL YLMV ( n, k, proba, i, dwork(pdmu), info )
c
c        CALL YLMV ( n, k, f, i, dwork(pdmu), info )
c       max. of i-th row
        CALL EVMAXI ( k, dwork(pdmu), sum, col )
        DO l = 1,k
            label(i,l) = 0
        ENDDO
        label(i,col) = 1
      ENDDO
c
      RETURN
      END


      double precision function del4(p1,p2,p3,p4,k1,k2,k3,k4)
      implicit none
      double precision ovdot,del3,p1(4),p2(4),p3(4),p4(4),
     &                            k1(4),k2(4),k3(4),k4(4)
      del4=ovdot(p1,k1)*del3(p2,p3,p4,k2,k3,k4)
     &    -ovdot(p1,k2)*del3(p2,p3,p4,k1,k3,k4)
     &    +ovdot(p1,k3)*del3(p2,p3,p4,k1,k2,k4)
     &    -ovdot(p1,k4)*del3(p2,p3,p4,k1,k2,k3)
      return
      end


      subroutine lk_comp_joint_surv(bev,lnu,xiv,phi,psiv,k,piv,Pi,si2,
     c typ,n,M,npX,XM,npW,W,YM,PM,btv,Pp1,dev,tv,lk)

      integer k,n,M,npX,npW,i,mi,m1,dev(n),PM(n,M)
      double precision bev(npX),lnu,xiv(k),phi,psiv(npW),piv(k),Pi(k)
      double precision si2,XM(n,M,npX),YM(n,M),W(n,npW),btv(M)
      double precision Pp1(k,M,n),tv(n),btvnu(M),dbtvnu(M-1)
      double precision l2,l3,tmp00(k),Wp(n),tmp0(k),muv(k),etmp0(k),lk
      double precision nu,lsi2pi
      character (len=4) typ
      parameter (pig=3.1415926535897932)

c to compute the second and third components of the expect complete log-likelihood

c preliminaries
      nu = exp(lnu)
      btvnu = btv**nu
	  dbtvnu = btvnu(2:M)-btvnu(1:(M-1))
	  if (typ=="norm") then
        lsi2pi = log(si2)+log(2*pig)
	  end if
c compute functions
	  l2 = 0
	  l3 = 0
	  tmp00 = xiv*phi
	  Wp = matmul(W,psiv)
	  do i=1,n
      	tmp0 = tmp00+Wp(i)
		etmp0 = exp(tmp0)
		mi = count(btv.le.tv(i))
		do m1 = 1,mi
          if (PM(i,m1)==1) then
            muv = xiv+sum(XM(i,m1,:)*bev)
            if (typ=="norm") then
              l2 = l2-0.5*sum((lsi2pi+(YM(i,m1)-muv)**2/si2)*
     c             Pp1(:,m1,i))
            end if
            if (typ=="bino") then
              muv = exp(muv)/(1+exp(muv))
              l2 = l2+sum((YM(i,m1)*log(muv)+(1-YM(i,m1))*log(1-muv))*
     c             Pp1(:,m1,i))
            end if
          end if
		end do
		if(mi>1) then
		  do m1=2,mi
		    l3 = l3-dbtvnu(m1-1)*sum(etmp0*Pp1(:,m1-1,i))
		  end do
		endif
        if (dev(i)==1) then
          l3 = l3+sum((lnu+(nu-1)*log(tv(i))+tmp0-
     c                 etmp0*(tv(i)**nu-btvnu(mi)))*Pp1(:,mi,i))
        else
          l3 = l3-sum((etmp0*(tv(i)**nu-btvnu(mi)))*Pp1(:,mi,i))
        end if
      end do
      lk = l2+l3

      end


      REAL*8 FUNCTION RPMAX2(R1,R2,M1,M2,KS1,KS2,VINF)
*
*
*       Maximum periastron factor for capture.
*       --------------------------------------
*
*       Developed by Rosemary Mardling (March 1996).
*       @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
*
      REAL*8  R1,R2,M1,M2,VINF,M21,A(8),B(2),P(2)
      INTEGER KS1,KS2,KS(2)
      DATA  A /-600.2227,3538.748,1703.075,77.31540,
     &         191.8260,-2.203482,1202.116,70.80281/
      DATA B /0.54,1.08/
*
*
*       Define mass and radius ratios and swap stellar type if necessary.
      IF (R1.GE.R2) THEN
          M21 = M2/M1
          R21 = R2/R1
          KS(1) = KS1
	  KS(2) = KS2
      ELSE
	  M21 = M1/M2
	  R21 = R1/R2
	  KS(1) = KS2
	  KS(2) = KS1
      END IF
*
*       Choose polytropic index for each star (adopt n=1.5 for giants).
      DO 1 I = 1,2
          IF(KS(I).EQ.0.OR.KS(I).EQ.3.OR.KS(I).EQ.5.OR.
     &       KS(I).EQ.6.OR.KS(I).EQ.9)THEN
              IP = 1
              PP = B(1)
          ELSE
              IP = 5
              PP = B(2)
          ENDIF
          P(I) = (((A(IP+3)*M21 + A(IP+2))*M21 + A(IP+1))*M21
     &                                         + A(IP))/VINF**PP
    1 CONTINUE
*
*       Calculate maximum periastron separation for capture (note arg < 0).
      Z = P(1) + (R21**5/M21**2)*P(2)
      IF (Z.LE.0.0) THEN
*       Adopt factor 2 for collision test in case of small mass ratio.
          RPMAX2 = 2.0
      ELSE
          RPMAX2 = Z**(1.0/6.0)
*         RPMAX2 = (P(1) + (R21**5/M21**2)*P(2))**(1.0/6.0)
      END IF
*
      RETURN
*
      END


!########################################################
!     Program  : HMMPT
!     TYPE     : Main program
!     PURPOSE  : Solve the Hubbard model using DMFT away from half-filling
! with modified itertive perturbation scheme (MPT)
!     AUTHORS  : Adriano Amaricci
!########################################################
MODULE COMMON
  USE GREENFUNX
  USE OPTIMIZE
  implicit none
  real(8)                :: xmu0,n,n0
  type(matsubara_gf)     :: sigma,fg,fg0,gamma
  complex(8),allocatable :: sold(:)
contains

  FUNCTION FUNCV(x)
    USE DMFT_IPT
    implicit none
    real(8),dimension(:),intent(in)  ::  x
    real(8),dimension(size(x))       ::  funcv
    real(8)                          :: zn0
    xmu0=x(1)
    !Hartree corrected WF is: \tilde{\calG0}^-1 = \calG0^-1 +xmu -xmu0 -U*n
    fg0%iw = one/(one/gamma%iw +xmu-xmu0-u*(n-0.5d0))
    call fftgf_iw2tau(fg0%iw,fg0%tau,beta)
    n0=-fg0%tau(L)
    funcv(1)=n-n0
    write(*,"(3(f13.9))")n,n0,xmu0
  END FUNCTION FUNCV

END MODULE COMMON

program hmmpt_matsubara
  USE DMFT_IPT
  USE COMMON
  USE IOTOOLS
  USE ERROR
  implicit none
  real(8)    :: x(1),z
  logical    :: check
  complex(8) :: zeta
  logical :: converged
  integer :: i,iloop
  real(8),dimension(:),allocatable :: wm

  call read_input("inputIPT.in")
  call allocate_gf(fg,L)
  call allocate_gf(fg0,L)
  call allocate_gf(sigma,L)
  call allocate_gf(gamma,L)
  allocate(sold(size(sigma%iw)))
  allocate(wm(L))

  wm = pi/beta*real(2*arange(1,L)-1,8)

  n=0.5d0 ; sigma%iw= U*(n-0.5d0) ; xmu0=xmu
  iloop=0 ; converged=.false.;D=1.d0
  do while (.not.converged)
     iloop=iloop+1
     write(*,"(A,i5)")"DMFT-loop",iloop
     do i=1,L
        zeta    = xi*wm(i) + xmu - sigma%iw(i)
        fg%iw(i) = gfbethe(wm(i),zeta,D)
     enddo
     call fftgf_iw2tau(fg%iw,fg%tau,beta)
     n=-real(fg%tau(L))

     !Get the regular Weiss Field: \Gamma(w+xmu)
     gamma%iw= one/(one/fg%iw + sigma%iw)

     !Fix the xmu0 w/ condition n0=n
     x(1)=xmu
     call broydn(funcv,x,check)
     xmu0=x(1)
     sigma%iw = solve_mpt_matsubara(fg0%iw,n,n0,xmu0)
     sigma%iw = weight*sigma%iw + (1.d0-weight)*sold ; sold=sigma%iw
     converged=check_convergence(sigma%iw,dmft_error,Nsuccess,Nloop)
     z=1.d0 - dimag(sigma%iw(1))/wm(1);z=1.d0/z
     call splot("obserbables_all.ipt",dble(iloop),u,n,z,append=.true.)
  enddo
  call splot("G_iw.ipt",wm,fg%iw)
  call splot("G0_iw.ipt",wm,fg0%iw)
  call splot("Sigma_iw.ipt",wm,sigma%iw)

end program hmmpt_matsubara


!***********************************************************************
!                                                                      *
      REAL(KIND(0.0D0)) FUNCTION DSUBRS (EOL, I, J, JBLOCK)
!                                                                      *
!   The coefficients d   for  I = r, J = s  are calculated here.       *
!                     rs                                               *
!                                                                      *
!                         NCMIN                                        *
!                          Sum     w     c          c                  *
!                         t = 1     t     r Gamma    s Gamma           *
!                                                t          t          *
!    EOL:          d   = -------------------------------------         *
!                   rs             NCMIN                               *
!                                   Sum     w                          *
!                                  t = 1     t                         *
!                                                                      *
!                                                                      *
!                                           /  NCF                     *
!    EAL:             d   =  delta     w   /   Sum   w                 *
!                      rs         rs    r /   t = 1   t                *
!                                                                      *
!                                                                      *
!   Written by Farid A Parpia               Last update: 18 Dec 1992   *
!                                                                      *
!***********************************************************************
!
!   This routine assumes (and does not check) that I and J belong
!   the same block and the job is done within the block specified
!   by parameter jblock
!
!************************************************************************
!...Translated by Pacific-Sierra Research 77to90  4.3E  14:06:32   1/ 3/07
!...Modified by Charlotte Froese Fischer
!                     Gediminas Gaigalas  10/05/17
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      USE def_C
      USE eigv_C
      USE hblock_C
      USE pos_C
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER  :: I
      INTEGER , INTENT(IN) :: J
      INTEGER  :: JBLOCK
      LOGICAL , INTENT(IN) :: EOL
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: K, KCMIN, IK, JK
!-----------------------------------------------

      IF (EOL) THEN
         DSUBRS = 0.D0
         DO K = 1, NEVBLK(JBLOCK)
            KCMIN = K + NCMINPAST(JBLOCK)
            IK = I + NEVECPAST(JBLOCK) + (K - 1)*NCFBLK(JBLOCK)
            JK = J + NEVECPAST(JBLOCK) + (K - 1)*NCFBLK(JBLOCK)
            DSUBRS = DSUBRS + EVEC(IK)*EVEC(JK)*WT(KCMIN)
         END DO
      ELSE IF (I == J) THEN
         DSUBRS = WT(I)
      ELSE
         DSUBRS = 0.D0
      ENDIF

      RETURN
      END FUNCTION DSUBRS


!c****************************************************************

!c     Program upsampledem

!c****************************************************************
!c**
!c**   FILE NAME: upsampledem.f
!c**
!c**   DATE WRITTEN: 12/09/2013
!c**
!c**   PROGRAMMER: Piyush Agram
!c**
!c**   FUNCTIONAL DESCRIPTION: This program will take a dem and will
!c**   upsample it in both dimensions by integer factor using Akima
!c**   interpolation.
!c**
!c**   ROUTINES CALLED: Functions from AkimaLib
!c**
!c**   NOTES:
!c**
!c**   1. This program does not fill voids. Voids in input dem must be
!c**   filled first. Else expect artifacts around voids.
!c**
!c*****************************************************************

      subroutine upsampledem(inAccessor,outAccessor,method)

      use upsampledemState
      use AkimaLib
      use fortranUtils
      implicit none

      !character*120 a_infile,a_outfile,a_string,a_geoidfile
      integer*8 inAccessor,outAccessor
      character*20000 MESSAGE
      integer i,j,ii,jj,ip,xx,yy
      integer method
      real*8 ix,iy
      real*4, allocatable, dimension(:,:) :: r_indata
      real*4, allocatable, dimension(:,:) :: r_outdata
      real*4, allocatable, dimension(:)   :: r_lastline
      real*8, dimension(aki_nsys) :: poly

      integer i_outnumlines,i_outsamples,npatch,i_line
      integer i_completed

      real*4 interp2DSpline
      !!Overlap between patches for Akima-resampling
      integer , parameter :: i_overlap = 8

!c     PROCESSING STEPS:
      write(MESSAGE,*) ' '
      call write_out(stdWriter,MESSAGE)
      write(MESSAGE,'(a)') '    <<Upsample DEM>> '
      call write_out(stdWriter,MESSAGE)

      write(MESSAGE,*) ' '
      call write_out(stdWriter,MESSAGE)

      write(MESSAGE,'(a)') 'Jet Propulsion Laboratory - Radar Science and Engineering '
      call write_out(stdWriter,MESSAGE)

      write(MESSAGE,*) ' '
      call write_out(stdWriter,MESSAGE)

      write(MESSAGE,*) 'Input dimensions: ', i_numlines, i_samples
      call write_out(stdWriter, MESSAGE)
      !! Compute output dimensions
      i_outsamples = (i_samples-1)*i_xfactor + 1
      i_outnumlines = (i_numlines-1)*i_yfactor + 1
      npatch = ceiling(real(i_numlines)/(i_patch-i_overlap))
      write(MESSAGE,*) 'Number of patches: ', npatch
      call write_out(stdWriter,MESSAGE)

      !! Allocate statements
      allocate(r_indata(i_samples, i_patch))
      allocate(r_outdata(i_outsamples, i_yfactor))
      allocate(r_lastline(i_outsamples))

      write(MESSAGE,*) 'Scale Factors : ', i_yfactor, i_xfactor
      call write_out(stdWriter, MESSAGE)
      write(MESSAGE,*) 'Output Dimensions: ', i_outnumlines, i_outsamples
      call write_out(stdWriter, MESSAGE)

      !! Start patch wise processing
      i_completed = 0
      do ip=1,npatch

        r_indata = 0.
        r_outdata = 0.

        !!Read a patch of the input DEM
        do i=1,i_patch
            i_line = (ip-1)*(i_patch-i_overlap) + i
            if(i_line.le.i_numlines) then
                call getLine(inAccessor,r_indata(:,i), i_line)
            endif
        enddo

        if (method.eq.AKIMA_METHOD) then
            !!Start interpolating the patch
            do i=1,i_patch-i_overlap/2
                i_line = (ip-1)*(i_patch-i_overlap) + i    !!Get input line number
                if (i_line.gt.i_completed) then    !!Skip lines already completed
                    if (mod(i_line,100).eq.0) then
                        write(MESSAGE,*)'Completed line: ', i_line
                        call write_out(stdWriter, MESSAGE)
                    endif

                    do j=1,i_samples-1
                        !!Create the Akima polynomial
                        call polyfitAkima(i_samples, i_patch, r_indata,j,i,poly)
                        do ii=1,i_yfactor
                            iy = i + (ii-1)/(1.0*i_yfactor)
                            yy = (i_line-1)*i_yfactor + ii
                            do jj=1,i_xfactor
                                ix =j + (jj-1)/(1.0*i_xfactor)
                                xx = (j-1)*i_xfactor + jj

                                !!Evaluate the Akima polynomial
                                r_outdata(xx,ii) = polyvalAkima(j,i,ix,iy,poly)
                            enddo
                        enddo
                    enddo

                    !!Write lines to output
                    do ii=1,i_yfactor
                        yy = (i_line-1)*i_yfactor + ii
                        !!Fill out last data point
                        r_outdata(i_outsamples,ii) = r_outdata(i_outsamples-1,ii)
                        if(yy.lt.i_outnumlines) then
                            call setLineSequential(outAccessor, r_outdata(:,ii))
                            r_lastline = r_outdata(:,ii)
                        endif
                    enddo

                    i_completed = i_completed+1

                    !!Fill out last line if needed
                    if(i_completed.eq.(i_numlines-1)) then
                        call setLineSequential(outAccessor, r_lastline)
                        i_completed = i_completed + 1
                    endif
                endif
            enddo !!End of patch interpolation

        else if (method.eq.BIQUINTIC_METHOD) then

            !!Start interpolating the path
            do i=1,i_patch-i_overlap/2
                i_line = (ip-1)*(i_patch-i_overlap) + i !!Get input line number
                if (i_line .gt. i_completed) then   !!Skip lines already completed
                    if (mod(i_line,100).eq.0) then
                        write(MESSAGE,*) 'Completed line: ', i_line
                        call write_out(stdWriter, MESSAGE)
                    endif

                    do j=1, i_samples-1

                        do ii=1,i_yfactor
                            iy = i + (ii-1)/(1.0*i_yfactor)
                            yy = (i_line-1)*i_yfactor + ii
                            do jj=1, i_xfactor
                                ix = j + (jj-1)/(1.0*i_xfactor)
                                xx = (j-1)*i_xfactor + jj

                                r_outdata(xx,ii) = interp2DSpline(6,i_patch,i_samples,r_indata,iy,ix)
                            end do
                        end do
                    end do

                    !!Write lines to output
                    do ii=1,i_yfactor
                        yy = (i_line-1)*i_yfactor + ii
                        !! Fill out last data point
                        r_outdata(i_outsamples,ii) = r_outdata(i_outsamples-1,ii)
                        if (yy.lt.i_outnumlines) then
                            call setLineSequential(outAccessor, r_outdata(:,ii))
                            r_lastline = r_outdata(:,ii)
                        endif
                    enddo

                    i_completed = i_completed + 1

                    !!Fill out last line if needed
                    if (i_completed.eq.(i_numlines-1)) then
                        call setLineSequential(outAccessor, r_lastline)
                        i_completed = i_completed + 1
                    endif
                endif
            enddo
        else
            print *, 'Unknown interpolation method: ', method
            stop
        endif
      enddo

      deallocate(r_indata)
      deallocate(r_outdata)
      deallocate(r_lastline)

      end subroutine upsampledem


    !-------------------------------------------------------------------------------------------------------------
    !
    !> \file    GibbsEnergy.f90
    !> \brief   Calculates the Gibbs energy of a given input system.
    !> \author  M. Poschmann
    !> \date    July 24, 2019
    !
    !
    ! Revisions:
    ! ==========
    !
    !   Date            Programmer          Description of change
    !   ----            ----------          ---------------------
    !   07/24/2019      M. Poschmann         Original code.
    !
    !
    ! Purpose:
    ! ========
    !
    !> \details The purpose of this subroutine is to print the results to screen in a style similar to FactSage.
    !
    !
    ! Pertinent variables:
    ! ====================
    !
    ! nConPhasesIn        An integer scalar representing the number of stable pure condensed phases input.
    ! nSolnPhasesIn       An integer scalar representing the number of stable solution phases input.
    ! iAssemblageIn       An integer vector representing the absolute indices of stable phases input.
    ! dMolesPhaseIn       A double real vector representing the number of moles for each stable phase in the system.
    ! dMolFractionIn      A double real vector representing the mole fraction of each species in the system.
    ! dGibbsEnergySysOut  A double real scalar representing the integral Gibbs energy of the system. This is the output variable.
    !
    !-------------------------------------------------------------------------------------------------------------

subroutine GibbsEnergy(nConPhasesIn, nSolnPhasesIn, iAssemblageIn, dMolesPhaseIn, dMolFractionIn, dGibbsEnergySysOut)

    USE ModuleThermo
    USE ModuleThermoIO
    USE ModuleGEMSolver

    implicit none

    integer, intent(in)  :: nConPhasesIn, nSolnPhasesIn
    integer, intent(in)  :: iAssemblageIn(nElements)
    real(8), intent(in)  :: dMolesPhaseIn(nElements), dMolFractionIn(nSpecies)
    real(8), intent(out) :: dGibbsEnergySysOut
    integer              :: i, j, k, iPhaseIndex
    real(8)              :: dGibbsPhase, dMolFractionPhase, dGibbsEnergySysTemp

    ! Temporary variables to store things that must be overwritten
    integer  :: nConPhasesTemp, nSolnPhasesTemp
    integer  :: iAssemblageTemp(nElements)
    real(8)  :: dMolesPhaseTemp(nElements), dMolFractionTemp(nSpecies), dMolesSpeciesTemp(nSpecies)

    nConPhasesTemp = nConPhases
    nSolnPhasesTemp = nSolnPhases
    iAssemblageTemp = iAssemblage
    dMolesPhaseTemp = dMolesPhase
    dMolFractionTemp = dMolFraction
    dMolesSpeciesTemp = dMolesSpecies
    dGibbsEnergySysTemp = dGibbsEnergySys

    nConPhases = nConPhasesIn
    nSolnPhases = nSolnPhasesIn
    iAssemblage = iAssemblageIn
    dMolesPhase = dMolesPhaseIn
    dMolFraction = dMolFractionIn

    dMolesSpecies = 0D0
    do i =1, nSolnPhasesIn
        k = nElements - i + 1
        iPhaseIndex = -iAssemblageIn(k)
        do j = nSpeciesPhase(iPhaseIndex - 1) + 1, nSpeciesPhase(iPhaseIndex)
            dMolesSpecies(j) = dMolesPhaseIn(k) * dMolFractionIn(j)
        end do
    end do

    call CompChemicalPotential(.TRUE.)

    dGibbsEnergySysOut = 0D0
    ! Only proceed for a successful calculation:
    IF_PASS: if (INFOThermo == 0) then

        do i = 1, nSolnPhasesIn
            k = nElements - i + 1
            iPhaseIndex = -iAssemblageIn(k)
            dGibbsPhase = 0D0
            dMolFractionPhase = 0D0
            do j = nSpeciesPhase(iPhaseIndex - 1) + 1, nSpeciesPhase(iPhaseIndex)
                dGibbsPhase = dGibbsPhase + dChemicalPotential(j) * dMolesPhase(k) * dMolFraction(j)
                dMolFractionPhase = dMolFractionPhase + dMolFraction(j)
            end do
            dGibbsEnergySysOut = dGibbsEnergySysOut + dGibbsPhase / dMolFractionPhase
        end do
        do i = 1, nConPhasesIn
            iPhaseIndex = iAssemblageIn(i)
            dGibbsEnergySysOut = dGibbsEnergySysOut + dStdGibbsEnergy(iPhaseIndex) * dMolesPhaseIn(i)
        end do
        dGibbsEnergySysOut = dGibbsEnergySysOut * dIdealConstant * dTemperature
        dGibbsEnergySys = dGibbsEnergySysOut
        ! call PrintResults
        dGibbsEnergySys = dGibbsEnergySysTemp
        print '(A26,ES12.5,A4)', ' Gibbs energy of input  = ', dGibbsEnergySysOut, ' [J]'
        print '(A26,ES12.5,A4)', ' Gibbs energy diff      = ', dGibbsEnergySysOut - dGibbsEnergySys, ' [J]'

    end if IF_PASS

    ! Return original values to variables
    nConPhases = nConPhasesTemp
    nSolnPhases = nSolnPhasesTemp
    iAssemblage = iAssemblageTemp
    dMolesPhase = dMolesPhaseTemp
    dMolFraction = dMolFractionTemp
    dMolesSpecies = dMolesSpeciesTemp

    return

end subroutine GibbsEnergy

    !---------------------------------------------------------------------------
    !                      END - GibbsEnergy.f90
    !---------------------------------------------------------------------------


MODULE jw
  IMPLICIT NONE
  !
  !  Functions for setting up initial conditions for the Jablonowski-Williamson test case.
  !
  !  Given longitude (radians), latitude (radians), eta (pressure) and rotation_angle (degrees)
  !  the functions will return temperature, surface geopotential, zonal and meridional wind
  !  components, respectively.
  !
  !  lperturb=.FALSE. result in initial conditions for the steady-state test case.
  !  lperturb=.TRUE.  result in initial conditions for the baroclinic wave test case.
  !
  !     T   : FUNCTION temperature         (lon,lat,eta,rotation_angle)
  !     PHIS: FUNCTION surface_geopotential(lon,lat,rotation_angle)
  !     U   : FUNCTION u_wind              (lon,lat,eta,lperturb,rotation_angle)
  !     V   : FUNCTION v_wind              (lon,lat,eta,lperturb,rotation_angle)
  !
  !  The non-rotated (rotation_angle=0) version of the test cases is described in:
  !
  !                 Jablonowski, C., and D. L. Williamson, 2006: A baroclinic instability
  !                 test case for atmospheric model dynamical cores.
  !                 Quart. J. Roy. Meteor. Soc., 132, 2943-2975.
  !
  !                 Jablonowski, C., and D. L. Williamson, 2006: A Baroclinic Wave Test Case
  !                 for Dynamical Cores of General Circulation Models: Model Intercomparisons,
  !                 NCAR Technical Note, NCAR/TN-469+STR, 89 pp.
  !
  !  The rotated version simply rotates the initial conditions so that the spherical coordinate
  !  poles do not conicide with the earth's rotation axis. Thereby the Coriolis parameter is
  !  a function of latitude and longitude:
  !
  !      f = 2*Omega*(-cos(lon)*cos(lat)*sin(rotation_angle)+sin(lat)*cos(rotation_angle))
  !
  !  where Omega = 7.292 x 10E-5/s and rotation_angle is the angle between the flow direction
  !  and equator.
  !
  !  Author: Peter Hjort Lauritzen (NCAR, pel@ucar.edu)
  !
  INTEGER,PARAMETER :: r8 = SELECTED_REAL_KIND(12) ! 8 byte real

  REAL(r8), PARAMETER ::       &
       eta_strato = 0.2d0     ,&! tropopause level
       u0         = 35.d0     ,&! 35 m/s
       T0         = 288.d0    ,&! global mean T at surface
       p0         = 100000.d0 ,&! global mean surface pressure
       eta0       = 0.252d0   ,&! center of jets (hybrid)
       !
       radius                 = 10.d0,             & ! radius of the perturbation
       perturbation_amplitude =  1.d0,             & ! amplitude of u perturbation 1 m/s
       perturbation_longitude = 20.d0,             & ! longitudinal position, 20E
       perturbation_latitude  = 40.d0,             & ! latitudinal position, 40N
       perturbation_latitude_tracer = 55.d0,       &
       !
       !
       !
       Rd         = 287.d0    ,&! gas constant J/(K kg)
       g          = 9.80616d0 ,&! gravitational acceleration (m/s^2)
       a          = 6371229.d0,&! Earth's radius in m
       omega      = 7.29212d-5,&! angular velocity 1/s
       gamma      = 0.005d0   ,&! lapse rate
       pi         = 3.14159265358979323846_R8,&  ! pi
       deg2rad    = pi/180.d0

CONTAINS
  !
  !********************************************************************
  !
  ! Temperature (equation (6) in Jablonowski and Williamson, 2006)
  !
  !********************************************************************
  !
  REAL(r8) FUNCTION temperature(lon,lat,eta,rotation_angle)
    IMPLICIT NONE
    REAL(r8), INTENT(IN) :: eta, lon, lat, rotation_angle
    REAL(r8)             :: rot_lon, rot_lat

    IF (ABS(rotation_angle)<1.0E-8) THEN
       rot_lon = lon
       rot_lat = lat
    ELSE
       CALL regrot(lon,lat,rot_lon,rot_lat,0.0d0,-0.5d0*pi+rotation_angle*deg2rad,1)
    ENDIF

    temperature  = t_mean(eta) + t_deviation(rot_lon,rot_lat,eta)
  END FUNCTION temperature
  !
  ! Horizontally averaged temperature (equation (4) and (5) in Jablonowski and Williamson (2006))
  !
  REAL(r8) FUNCTION t_mean(eta)
    IMPLICIT NONE
    REAL(r8), INTENT(IN) :: eta
    REAL(r8)             :: exponent, delta_T

    exponent = Rd*gamma/g
    delta_T  = 480000.d0  ! in K, for T mean calculation
    IF (eta.gt.(eta_strato)) THEN
       t_mean = T0*eta**exponent                                ! mean temperature at each level (troposphere)
    ELSE
       t_mean = T0*eta**exponent + delta_T*(eta_strato-eta)**5  ! mean temperature at each level (stratosphere)
    ENDIF
  END FUNCTION t_mean
  !
  ! Temperature deviation from the horizontal mean
  ! (equation (6) minus horizontally averaged temperature)
  !
  REAL(r8) FUNCTION t_deviation(lon,lat,eta)
    IMPLICIT NONE
    REAL(r8), INTENT(IN) :: eta, lon, lat
    REAL(r8)             :: factor, phi_vertical, rot_lon, rot_lat, a_omega

    factor       = eta*pi*u0/Rd
    phi_vertical = (eta - eta0) * 0.5d0*pi
    a_omega      = a*omega

    rot_lon = lon
    rot_lat = lat

    t_deviation = factor * 1.5d0 * SIN(phi_vertical) * (cos(phi_vertical))**0.5d0 *                        &
                  ((-2.d0*(SIN(rot_lat))**6 * ((COS(rot_lat))**2 + 1.d0/3.d0) + 10.d0/63.d0)*              &
                  u0 * (COS(phi_vertical))**1.5d0  +                                                       &
                  (8.d0/5.d0*(COS(rot_lat))**3 * ((SIN(rot_lat))**2 + 2.d0/3.d0) - pi/4.d0)*a_omega*0.5d0 )
  END FUNCTION t_deviation
  !
  !**************************************************************************
  !
  ! Surface geopotential (equaiton (7) in Jablonowski and Williamson, 2006)
  !
  !**************************************************************************
  !
  REAL(r8) FUNCTION surface_geopotential(lon,lat,rotation_angle)
    IMPLICIT NONE
    REAL(r8), INTENT(IN) :: lon, lat, rotation_angle
    REAL(r8)             :: cos_tmp, eta_sfc, rot_lon, rot_lat, a_omega

    IF (ABS(rotation_angle)<1.0E-8) THEN
       rot_lon = lon
       rot_lat = lat
    ELSE
       CALL regrot(lon,lat,rot_lon,rot_lat,0.0d0,-0.5d0*pi+rotation_angle*deg2rad,1)
    ENDIF

    eta_sfc    = 1.d0
    cos_tmp    = u0 * (cos((eta_sfc-eta0)*pi*0.5d0))**1.5d0
    a_omega    = a*omega

    surface_geopotential = ((-2.d0*(SIN(rot_lat))**6 * ((COS(rot_lat))**2 + 1.d0/3.d0) + 10.d0/63.d0)*COS_tmp   &
                 + (8.d0/5.d0*(COS(rot_lat))**3 * ((SIN(rot_lat))**2 + 2.d0/3.d0) - pi/4.d0)*a_omega)*COS_tmp
  END FUNCTION surface_geopotential
  !
  !********************************************************************
  !
  ! wind components (equation 2 in Jablonowski and Williamson, 2006)
  !
  !********************************************************************
  !
  REAL(r8) FUNCTION u_wind(lon,lat,eta,lperturb,rotation_angle)
    IMPLICIT NONE
    REAL(r8), INTENT(IN) :: lon,lat,eta,rotation_angle
    LOGICAL, INTENT(IN)  :: lperturb
    REAL(r8) :: cos_lat, u_lat, phi_vertical, rot_lon, rot_lat, sin_tmp, cos_tmp, r, u_perturb, v_lat
    REAL(r8) :: perturb_lon, perturb_lat, v_tmp

    perturb_lon = perturbation_longitude*deg2rad
    perturb_lat = perturbation_latitude*deg2rad

    IF (ABS(rotation_angle)<1.0E-8) THEN
       rot_lon = lon
       rot_lat = lat
    ELSE
       CALL regrot(lon,lat,rot_lon,rot_lat,0.0d0,-0.5d0*pi+rotation_angle*deg2rad,1)
    ENDIF

    phi_vertical = (eta - eta0) *0.5d0*pi
    u_lat = (COS(phi_vertical))**1.5d0 * 4.d0 * u0 * (sin(rot_lat))**2 * (cos(rot_lat))**2
    u_wind = u_lat

    IF (lperturb) THEN

       sin_tmp = SIN(perturb_lat)*SIN(rot_lat)
       cos_tmp = COS(perturb_lat)*COS(rot_lat)

       r = ACOS( sin_tmp + cos_tmp*COS(rot_lon-perturb_lon) )    ! great circle distance
       u_perturb = perturbation_amplitude*EXP(- (r*radius)**2 )
       u_lat     = u_perturb + u_lat
    ENDIF
    IF (ABS(rotation_angle)<1.0E-8) THEN
       u_wind = u_lat
    ELSE
       v_lat = 0.0d0
       !
       ! rotate wind components
       !
       CALL turnwi(u_lat,v_lat, u_wind,v_tmp,lon,lat,rot_lon,rot_lat,0.0d0,-0.5d0*pi+rotation_angle*deg2rad,-1)
       IF (ABS(u_wind)<1.0E-10) u_wind=0.0d0
    ENDIF
  END FUNCTION u_wind

  REAL(r8) FUNCTION v_wind(lon,lat,eta,lperturb,rotation_angle)
    IMPLICIT NONE
    REAL(r8), INTENT(IN) :: lon,lat,eta,rotation_angle
    LOGICAL, INTENT(IN)  :: lperturb
    REAL(r8) :: cos_lat, u_lat, phi_vertical, rot_lon, rot_lat, sin_tmp, cos_tmp, r, u_perturb, v_lat
    REAL(r8) :: perturb_lon, perturb_lat, u_tmp

    perturb_lon = perturbation_longitude*deg2rad
    perturb_lat = perturbation_latitude*deg2rad

    IF (ABS(rotation_angle)<1.0E-8) THEN
       v_wind = 0.0d0
    ELSE
       CALL regrot(lon,lat,rot_lon,rot_lat,0.0d0,-0.5d0*pi+rotation_angle*deg2rad,1)

       phi_vertical = (eta - eta0) *0.5d0*pi
       u_lat = (COS(phi_vertical))**1.5d0 * 4.d0 * u0 * (sin(rot_lat))**2 * (cos(rot_lat))**2

       IF (lperturb) THEN

          sin_tmp = SIN(perturb_lat)*SIN(rot_lat)
          cos_tmp = COS(perturb_lat)*COS(rot_lat)

          r = ACOS( sin_tmp + cos_tmp*COS(rot_lon-perturb_lon) )    ! great circle distance
          u_perturb = perturbation_amplitude*EXP(- (r*radius)**2 )
          u_lat     = u_perturb + u_lat
       ENDIF

       v_lat = 0.0d0
       !
       ! pole point velocities are not well-defined
       !
       IF (ABS(pi*0.5d0-lat)<1.0E-8.OR.ABS(pi*0.5d0+lat)<1.0E-8) THEN
          v_wind = 0.0d0
       ELSE
          !
          ! rotate wind components
          !
          CALL turnwi(u_lat,v_lat, u_tmp,v_wind,lon,lat,rot_lon,rot_lat,0.0d0,-0.5d0*pi+rotation_angle*deg2rad,-1)
       ENDIF
    ENDIF
  END FUNCTION v_wind
  !
  !******************************************************************************
  !
  ! Subroutines for rotation
  !
  !******************************************************************************
  !

  SUBROUTINE regrot(pxreg,pyreg,pxrot,pyrot,pxcen,pycen,kcall)
    IMPLICIT NONE
!
!----------------------------------------------------------------------
!
!*    conversion between regular and rotated spherical coordinates.
!*
!*    pxreg     longitudes of the regular coordinates
!*    pyreg     latitudes of the regular coordinates
!*    pxrot     longitudes of the rotated coordinates
!*    pyrot     latitudes of the rotated coordinates
!*              all coordinates given in degrees n (negative for s)
!*              and degrees e (negative values for w)
!*    pxcen     regular longitude of the south pole of the rotated grid
!*    pycen     regular latitude of the south pole of the rotated grid
!*
!*    kcall=-1: find regular as functions of rotated coordinates.
!*    kcall= 1: find rotated as functions of regular coordinates.
!
!-----------------------------------------------------------------------
!
      integer kxdim,kydim,kx,ky,kcall
      real(r8) :: pxreg,pyreg,&
                  pxrot,pyrot,&
                  pxcen,pycen
!
!-----------------------------------------------------------------------
!
      real(r8) zsycen,zcycen,zxmxc,zsxmxc,zcxmxc,zsyreg,zcyreg, &
               zsyrot,zcyrot,zcxrot,zsxrot,zpi,zpih
      integer jy,jx

      zpih = pi*0.5d0
!
      !----------------------------------------------------------------------
!
      zsycen = SIN((pycen+zpih))
      zcycen = COS((pycen+zpih))
!
      IF (kcall.eq.1) then
!
         zxmxc  = pxreg - pxcen
         zsxmxc = SIN(zxmxc)
         zcxmxc = COS(zxmxc)
         zsyreg = SIN(pyreg)
         zcyreg = COS(pyreg)
         zsyrot = zcycen*zsyreg - zsycen*zcyreg*zcxmxc
         zsyrot = max(zsyrot,-1.d0)
         zsyrot = min(zsyrot,+1.d0)
         !
         pyrot = ASIN(zsyrot)
         !
         zcyrot = COS(pyrot)
         zcxrot = (zcycen*zcyreg*zcxmxc +zsycen*zsyreg)/zcyrot
         zcxrot = max(zcxrot,-1.d0)
         zcxrot = min(zcxrot,+1.d0)
         zsxrot = zcyreg*zsxmxc/zcyrot
         !
         pxrot = ACOS(zcxrot)
         !
         IF (zsxrot<0.0) pxrot = -pxrot
               !
      ELSEIF (kcall.eq.-1) then
         !
         zsxrot = SIN(pxrot)
         zcxrot = COS(pxrot)
         zsyrot = SIN(pyrot)
         zcyrot = COS(pyrot)
         zsyreg = zcycen*zsyrot + zsycen*zcyrot*zcxrot
         zsyreg = max(zsyreg,-1.d0)
         zsyreg = min(zsyreg,+1.d0)
         !
         pyreg = ASIN(zsyreg)
         !
         zcyreg = COS(pyreg)
         zcxmxc = (zcycen*zcyrot*zcxrot -&
              zsycen*zsyrot)/zcyreg
         zcxmxc = max(zcxmxc,-1.d0)
         zcxmxc = min(zcxmxc,+1.d0)
         zsxmxc = zcyrot*zsxrot/zcyreg
         zxmxc  = ACOS(zcxmxc)
         IF (zsxmxc<0.0) zxmxc = -zxmxc
         !
         pxreg = zxmxc + pxcen
         !
      ELSE
         WRITE(6,'(1x,''invalid kcall in regrot'')')
         STOP
      ENDIF
    END SUBROUTINE regrot

    SUBROUTINE turnwi(puarg,pvarg,pures,pvres,         &
                      pxreg,pyreg,pxrot,pyrot,   &
                      pxcen,pycen,kcall)
!
      IMPLICIT NONE
!
!-----------------------------------------------------------------------
!
!*    turn horizontal velocity components between regular and
!*    rotated spherical coordinates.
!
!*    puarg : input u components
!*    pvarg : input v components
!*    pures : output u components
!*    pvres : output v components
!*    pa    : transformation coefficients
!*    pb    :    -"-
!*    pc    :    -"-
!*    pd    :    -"-
!*    pxreg : regular longitudes
!*    pyreg : regular latitudes
!*    pxrot : rotated longitudes
!*    pyrot : rotated latitudes
!*    kxdim              : dimension in the x (longitude) direction
!*    kydim              : dimension in the y (latitude) direction
!*    kx                 : number of gridpoints in the x direction
!*    ky                 : number of gridpoints in the y direction
!*    pxcen              : regular longitude of the south pole of the
!*                         transformed grid
!*    pycen              : regular latitude of the south pole of the
!*                         transformed grid
!*
!*    kcall < 0          : find wind components in regular coordinates
!*                         from wind components in rotated coordinates
!*    kcall > 0          : find wind components in rotated coordinates
!*                         from wind components in regular coordinates
!*    note that all coordinates are given in degrees n and degrees e.
!*       (negative values for s and w)
!
!-----------------------------------------------------------------------

      integer kxdim,kydim,kx,ky,kcall
      real(r8) puarg,pvarg,    &
               pures,pvres,    &
               pa,   pb,       &
               pc,   pd,       &
               pxreg,pyreg,    &
               pxrot,pyrot
      real(r8) pxcen,pycen
!
!-----------------------------------------------------------------------
!
      integer jy,jx
      real(r8) zpih,zsyc,zcyc,zsxreg,zcxreg,zsyreg,zcyreg,zxmxc,&
               zsxmxc,zcxmxc,zsxrot,zcxrot,zsyrot,zcyrot
!
!-----------------------------------------------------------------------
!
      IF (kcall.eq.1) then
         zpih = pi*0.5d0
         zsyc = SIN(pycen+zpih)
         zcyc = COS(pycen+zpih)
         !
         zsxreg = SIN(pxreg)
         zcxreg = COS(pxreg)
         zsyreg = SIN(pyreg)
         zcyreg = COS(pyreg)
         !
         zxmxc  = pxreg - pxcen
         zsxmxc = SIN(zxmxc)
         zcxmxc = COS(zxmxc)
         !
         zsxrot = SIN(pxrot)
         zcxrot = COS(pxrot)
         zsyrot = SIN(pyrot)
         zcyrot = COS(pyrot)
         !
         pa = zcyc*zsxmxc*zsxrot + zcxmxc*zcxrot
         pb = zcyc*zcxmxc*zsyreg*zsxrot - zsyc*zcyreg*zsxrot - &
              zsxmxc*zsyreg*zcxrot
         pc = zsyc*zsxmxc/zcyrot
         pd = (zsyc*zcxmxc*zsyreg + zcyc*zcyreg)/zcyrot
         !
         pures = pa*puarg + pb*pvarg
         pvres = pc*puarg + pd*pvarg
      ELSEIF (kcall.eq.-1) then
         zpih = pi*0.5d0
         zsyc = SIN(pycen+zpih)
         zcyc = COS(pycen+zpih)
         !
         zsxreg = SIN(pxreg)
         zcxreg = COS(pxreg)
         zsyreg = SIN(pyreg)
         zcyreg = COS(pyreg)
         !
         zxmxc  = pxreg - pxcen
         zsxmxc = SIN(zxmxc)
         zcxmxc = COS(zxmxc)
         !
         zsxrot = SIN(pxrot)
         zcxrot = COS(pxrot)
         zsyrot = SIN(pyrot)
         zcyrot = COS(pyrot)
         !
         pa = zcxmxc*zcxrot + zcyc*zsxmxc*zsxrot
         pb = zcyc*zsxmxc*zcxrot*zsyrot + zsyc*zsxmxc*zcyrot -&
              zcxmxc*zsxrot*zsyrot
         pc =-zsyc*zsxrot/zcyreg
         pd = (zcyc*zcyrot - zsyc*zcxrot*zsyrot)/zcyreg
         !
         pures = pa*puarg + pb*pvarg
         pvres = pc*puarg + pd*pvarg
      ELSE
         write(6,'(1x,''invalid kcall in turnwi'')')
         STOP
      ENDIF
    END SUBROUTINE turnwi

!********************************************************************
!
! Tracers
!
!********************************************************************

!-----------------------------------------------------------------------
! Tracer q1 and q2
!-----------------------------------------------------------------------
  REAL(r8) FUNCTION tracer_q1_q2(lon,lat,eta,rotation_angle, eta_c)
    IMPLICIT NONE
    REAL(r8), INTENT(IN) :: eta, lon, lat, rotation_angle, eta_c
    REAL(r8) :: rot_lon, rot_lat, sin_tmp, cos_tmp, r
    REAL(r8) :: rot_perturb_lon, rot_perturb_lat, tmp

    rot_perturb_lon = perturbation_longitude*deg2rad
    rot_perturb_lat = perturbation_latitude_tracer *deg2rad

    IF (ABS(rotation_angle)<1.0E-8) THEN
       rot_lon = lon
       rot_lat = lat
    ELSE
       CALL regrot(lon,lat,rot_lon,rot_lat,0.0d0,-0.5d0*pi+rotation_angle*deg2rad,1)
    ENDIF
    sin_tmp = SIN(rot_perturb_lat)*SIN(rot_lat)
    cos_tmp = COS(rot_perturb_lat)*COS(rot_lat)
    r = ACOS( sin_tmp + cos_tmp*COS(rot_lon-rot_perturb_lon) )    ! great circle distance

    tmp = EXP(- ((r*radius)**2 + ((eta-eta_c)/0.1_r8)**2))
    IF (ABS(tmp)<1.0E-8) tmp = 0.0
    tracer_q1_q2 = tmp
  END FUNCTION tracer_q1_q2

!-----------------------------------------------------------------------
! Tracer q3
!-----------------------------------------------------------------------
  REAL(r8) FUNCTION tracer_q3(lon,lat,eta,rotation_angle)
    IMPLICIT NONE
    REAL(r8), INTENT(IN) :: eta, lon, lat, rotation_angle
    REAL(r8) :: rot_lon, rot_lat

    IF (ABS(rotation_angle)<1.0E-8) THEN
       rot_lon = lon
       rot_lat = lat
    ELSE
       CALL regrot(lon,lat,rot_lon,rot_lat,0.0d0,-0.5d0*pi+rotation_angle*deg2rad,1)
    ENDIF
    tracer_q3 = 0.5_r8 * ( tanh( 3._r8*abs(rot_lat)-pi ) + 1._r8)

  END FUNCTION tracer_q3

!-----------------------------------------------------------------------
! Tracer q, absolute value of the relative vorticity of the unperturbed initial state
!           multiplied by 10^5
!-----------------------------------------------------------------------
  REAL(r8) FUNCTION tracer_q(lon,lat,eta,rotation_angle)
    IMPLICIT NONE
    REAL(r8), INTENT(IN) :: eta, lon, lat, rotation_angle
    REAL(r8) :: rot_lon, rot_lat

    IF (ABS(rotation_angle)<1.0E-8) THEN
       rot_lon = lon
       rot_lat = lat
    ELSE
       CALL regrot(lon,lat,rot_lon,rot_lat,0.0d0,-0.5d0*pi+rotation_angle*deg2rad,1)
    ENDIF
    tracer_q = abs(-4._r8 * u0/a * (cos((eta-eta0)*pi*0.5_r8))**1.5_r8 * sin(rot_lat) * &
               cos(rot_lat) * (2._r8-5._r8*(sin(rot_lat))**2)) * 1.e5_r8
    if (tracer_q < 1.e-9_r8) tracer_q = 0._r8  !  otherwise error in netcdf file

  END FUNCTION tracer_q

END MODULE jw


subroutine bss(r12, rs, zs, ru12, zu12, bsubs, &
               lu, lv, br, bphi, bz)

      use stel_kinds, only: dp
      use name0, only: cp25, cp5
      use scalars, only: nrzt
      use realsp, only: r1, ru, rv, z1, zu, zv
      use scalefac, only: shalf

      implicit none

      real(kind=dp), intent(in)  :: r12  (nrzt)
      real(kind=dp), intent(in)  :: rs   (nrzt)
      real(kind=dp), intent(in)  :: zs   (nrzt)
      real(kind=dp), intent(in)  :: ru12 (nrzt)
      real(kind=dp), intent(in)  :: zu12 (nrzt)
      real(kind=dp), intent(in)  :: lu   (nrzt)
      real(kind=dp), intent(in)  :: lv   (nrzt)
      real(kind=dp), intent(out) :: bsubs(nrzt)
      real(kind=dp), intent(out) :: br   (nrzt)
      real(kind=dp), intent(out) :: bphi (nrzt)
      real(kind=dp), intent(out) :: bz   (nrzt)

      integer       :: l, lodd
      real(kind=dp) :: rv12, zv12
      real(kind=dp) :: gsu, gsv

      do l = 2, nrzt
        lodd = l + nrzt

        rv12 =     cp5 * ( rv(l) + rv(l-1) + shalf(l) * (rv(lodd)+rv(lodd-1)) )
        zv12 =     cp5 * ( zv(l) + zv(l-1) + shalf(l) * (zv(lodd)+zv(lodd-1)) )

        ! metric elements g_su, g_sv on half-grid
        gsu  =   rs(l) * ru12(l)                                       &
               + zs(l) * zu12(l)                                       &
               +  cp25 * (     r1(lodd)*ru(lodd)+r1(lodd-1)*ru(lodd-1) &
                          +    z1(lodd)*zu(lodd)+z1(lodd-1)*zu(lodd-1) &
                          + (  r1(lodd)*ru(l)   +r1(lodd-1)*ru(l-1)    &
                             + z1(lodd)*zu(l)   +z1(lodd-1)*zu(l-1) )/shalf(l) )

        gsv  =   rs(l) * rv12                                          &
               + zs(l) * zv12                                          &
               +  cp25 * (     r1(lodd)*rv(lodd)+r1(lodd-1)*rv(lodd-1) &
                          +    z1(lodd)*zv(lodd)+z1(lodd-1)*zv(lodd-1) &
                          + (  r1(lodd)*rv(l)   +r1(lodd-1)*rv(l-1)    &
                             + z1(lodd)*zv(l)   +z1(lodd-1)*zv(l-1) )/shalf(l) )

        bsubs(l)= lv(l)*gsu     + lu(l)*gsv

        br(l)   = lv(l)*ru12(l) + lu(l)*rv12
        bphi(l) =                 lu(l)*r12(l)
        bz(l)   = lv(l)*zu12(l) + lu(l)*zv12
      end do

      return
end