module horiz_interp_bicubic_mod

  use mpp_mod,               only: mpp_error, FATAL, stdout, mpp_pe, mpp_root_pe
  use fms_mod,               only: write_version_number
  use horiz_interp_type_mod, only: horiz_interp_type

 implicit none

! This module delivers methods for bicubic interpolation from a
! coarse regular grid on a fine regular grid.
! Subroutines
!
!       bcuint
!       bcucof
!
! are methods taken from
!
!       W. H. Press, S. A. Teukolski, W. T. Vetterling and B. P. Flannery,
!       Numerical Recipies in FORTRAN, The Art of Scientific Computing.
!       Cambridge University Press, 1992
!
! written by
!       martin.schmidt@io-warnemuende.de (2004)
! revied by
!       martin.schmidt@io-warnemuende.de (2004)
!
! Version 1.0.0.2005-07-06
! The module is thought to interact with MOM-4.
! Alle benotigten Felder werden extern von MOM verwaltet, da sie
! nicht fur alle interpolierten Daten die gleiche Dimension haben mussen.

   private

   public  :: horiz_interp_bicubic, horiz_interp_bicubic_init, horiz_interp_bicubic_end, fill_xy

  interface horiz_interp_bicubic_init
    module procedure horiz_interp_bicubic_init_1d
    module procedure horiz_interp_bicubic_init_1d_s
  end interface

!   character(len=128) :: version="bicubic 1.0.0.2004-09-30"
   character(len=128) :: version="$Id: horiz_interp_bicubic.f90,v 13.0 2006/03/28 21:39:27 fms Exp $"
   character(len=128) :: tagname = '$Name: latest $'
   logical            :: do_vers = .true.
   integer            :: verbose_bicubic = 0

!     Grid variables
!     xc, yc : co-ordinates of the coarse grid
!     xf, yf : co-ordinates of the fine grid
!     fc     : variable to be interpolated at the coarse grid
!     dfc_x  : x-derivative of fc at the coarse grid
!     dfc_y  : y-derivative of fc at the coarse grid
!     dfc_xy : x-y-derivative of fc at the coarse grid
!     ff     : variable to be interpolated at the fine grid
!     dff_x  : x-derivative of fc at the fine grid
!     dff_y  : y-derivative of fc at the fine grid
!     dff_xy : x-y-derivative of fc at the fine grid

   logical            :: initialized_bicubic = .false.

   real, save         :: missing = -1e33

   interface fill_xy
      module procedure fill_xy
   end interface

   contains
  !#######################################################################
  ! <SUBROUTINE NAME="horiz_interp_bicubic_init">

  !   <OVERVIEW>
  !      Initialization routine.
  !   </OVERVIEW>
  !   <DESCRIPTION>
  !      Allocates space and initializes a derived-type variable
  !      that contains pre-computed interpolation indices and weights.
  !   </DESCRIPTION>
  !   <TEMPLATE>
  !     call horiz_interp_bicubic_init ( Interp, lon_in, lat_in, lon_out, lat_out, verbose_bicubic, src_modulo )

  !   </TEMPLATE>
  !
  !   <IN NAME="lon_in" TYPE="real, dimension(:,:)" UNITS="radians">
  !      Longitude (in radians) for source data grid.
  !   </IN>

  !   <IN NAME="lat_in" TYPE="real, dimension(:,:)" UNITS="radians">
  !      Latitude (in radians) for source data grid.
  !   </IN>

  !   <IN NAME="lon_out" TYPE="real, dimension(:,:)" UNITS="radians" >
  !      Longitude (in radians) for source data grid.
  !   </IN>

  !   <IN NAME="lat_out" TYPE="real, dimension(:,:)" UNITS="radians" >
  !      Latitude (in radians) for source data grid.
  !   </IN>

  !   <IN NAME="src_modulo" TYPE="logical, optional">
  !      logical variable to indicate if the boundary condition along zonal boundary
  !      is cyclic or not. When true, the zonal boundary condition is cyclic.
  !   </IN>

  !   <IN NAME="verbose_bicubic" TYPE="integer, optional" >
  !      flag for the amount of print output.
  !   </IN>

  !   <INOUT NAME="Interp" TYPE="type(horiz_interp_type)" >
  !      A derived-type variable containing indices and weights used for subsequent
  !      interpolations. To reinitialize this variable for a different grid-to-grid
  !      interpolation you must first use the "horiz_interp_end" interface.
  !   </INOUT>

  subroutine horiz_interp_bicubic_init_1d_s ( Interp, lon_in, lat_in, lon_out, lat_out, &
       verbose, src_modulo )

    !-----------------------------------------------------------------------
    type(horiz_interp_type), intent(inout) :: Interp
    real, intent(in),  dimension(:)        :: lon_in , lat_in
    real, intent(in),  dimension(:,:)      :: lon_out, lat_out
    integer, intent(in),          optional :: verbose
    logical, intent(in),          optional :: src_modulo
    integer                                :: i, j, ip1, im1, jp1, jm1
    logical                                :: src_is_modulo
    integer                                :: nlon_in, nlat_in, nlon_out, nlat_out
    integer                                :: jcl, jcu, icl, icu, jj
    real                                   :: xz, yz
    integer                                :: unit

    if (do_vers) then
       call write_version_number (version, tagname)
       do_vers = .false.
    endif

    if(present(verbose)) verbose_bicubic = verbose
    src_is_modulo = .false.
    if (present(src_modulo)) src_is_modulo = src_modulo

    if(size(lon_out,1) /= size(lat_out,1) .or. size(lon_out,2) /= size(lat_out,2) ) &
         call mpp_error(FATAL,'horiz_interp_bilinear_mod: when using bilinear ' // &
         'interplation, the output grids should be geographical grids')

    !--- get the grid size
    nlon_in  = size(lon_in)   ; nlat_in  = size(lat_in)
    nlon_out = size(lon_out,1); nlat_out = size(lat_out,2)
    Interp%nlon_src = nlon_in;  Interp%nlat_src = nlat_in
    Interp%nlon_dst = nlon_out; Interp%nlat_dst = nlat_out
!   use wti(:,:,1) for x-derivative, wti(:,:,2) for y-derivative, wti(:,:,3) for xy-derivative
    allocate ( Interp%wti    (nlon_in, nlat_in, 3) )
    allocate ( Interp%lon_in (nlon_in) )
    allocate ( Interp%lat_in (nlat_in) )
    allocate ( Interp%rat_x  (nlon_out, nlat_out) )
    allocate ( Interp%rat_y  (nlon_out, nlat_out) )
    allocate ( Interp%i_lon  (nlon_out, nlat_out, 2) )
    allocate ( Interp%j_lat  (nlon_out, nlat_out, 2) )

    Interp%lon_in = lon_in
    Interp%lat_in = lat_in

    if ( verbose_bicubic > 0 ) then
       unit = stdout()
       write (unit,'(/,"Initialising bicubic interpolation, interface horiz_interp_bicubic_init_1d_s")')
       write (unit,'(/," Longitude of coarse grid points (radian): xc(i) i=1, ",i4)') Interp%nlon_src
       write (unit,'(1x,10f10.4)') (Interp%lon_in(jj),jj=1,Interp%nlon_src)
       write (unit,'(/," Latitude of coarse grid points (radian):  yc(j) j=1, ",i4)') Interp%nlat_src
       write (unit,'(1x,10f10.4)') (Interp%lat_in(jj),jj=1,Interp%nlat_src)
       do i=1, Interp%nlat_dst
         write (unit,*)
         write (unit,'(/," Longitude of fine grid points (radian): xf(i) i=1, ",i4)') Interp%nlat_dst
         write (unit,'(1x,10f10.4)') (lon_out(jj,i),jj=1,Interp%nlon_dst)
       enddo
       do i=1, Interp%nlon_dst
         write (unit,*)
         write (unit,'(/," Latitude of fine grid points (radian):  yf(j) j=1, ",i4)') Interp%nlon_dst
         write (unit,'(1x,10f10.4)') (lat_out(i,jj),jj=1,Interp%nlat_dst)
       enddo
    endif

!---------------------------------------------------------------------------
!     Find the x-derivative. Use central differences and forward or
!     backward steps at the boundaries

    do j=1,nlat_in
      do i=1,nlon_in
        ip1=min(i+1,nlon_in)
        im1=max(i-1,1)
        Interp%wti(i,j,1) = 1./(Interp%lon_in(ip1)-Interp%lon_in(im1))
      enddo
    enddo

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

!     Find the y-derivative. Use central differences and forward or
!     backward steps at the boundaries
      do j=1,nlat_in
        jp1=min(j+1,nlat_in)
        jm1=max(j-1,1)
        do i=1,nlon_in
          Interp%wti(i,j,2) = 1./(Interp%lat_in(jp1)-Interp%lat_in(jm1))
        enddo
      enddo

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

!     Find the xy-derivative. Use central differences and forward or
!     backward steps at the boundaries
      do j=1,nlat_in
        jp1=min(j+1,nlat_in)
        jm1=max(j-1,1)
        do i=1,nlon_in
          ip1=min(i+1,nlon_in)
          im1=max(i-1,1)
          Interp%wti(i,j,3) = 1./((Interp%lon_in(ip1)-Interp%lon_in(im1))*(Interp%lat_in(jp1)-Interp%lat_in(jm1)))
        enddo
      enddo
!---------------------------------------------------------------------------
!     Now for each point at the dest-grid find the boundary points of
!     the source grid
      do j=1, nlat_out
        do i=1,nlon_out
          yz  = lat_out(i,j)
          xz  = lon_out(i,j)
          jcl = 0
          jcu = 0
          jcl = indl(Interp%lat_in, yz)
          jcu = indu(Interp%lat_in, yz)
          icl = 0
          icu = 0
          icl = indl(Interp%lon_in, xz)
          icu = indu(Interp%lon_in, xz)
          Interp%j_lat(i,j,1) = jcl
          Interp%j_lat(i,j,2) = jcu
          Interp%i_lon(i,j,1) = icl
          Interp%i_lon(i,j,2) = icu
          Interp%rat_x(i,j) = (xz - Interp%lon_in(icl))/(Interp%lon_in(icu) - Interp%lon_in(icl))
          Interp%rat_y(i,j) = (yz - Interp%lat_in(jcl))/(Interp%lat_in(jcu) - Interp%lat_in(jcl))
          if(yz.gt.Interp%lat_in(jcu)) call mpp_error(FATAL, ' horiz_interp_bicubic_init_1d_s: yf < ycl, no valid boundary point')
          if(yz.lt.Interp%lat_in(jcl)) call mpp_error(FATAL, ' horiz_interp_bicubic_init_1d_s: yf > ycu, no valid boundary point')
          if(xz.gt.Interp%lon_in(icu)) call mpp_error(FATAL, ' horiz_interp_bicubic_init_1d_s: xf < xcl, no valid boundary point')
          if(xz.lt.Interp%lon_in(icl)) call mpp_error(FATAL, ' horiz_interp_bicubic_init_1d_s: xf > xcu, no valid boundary point')
        enddo
      enddo
  end subroutine horiz_interp_bicubic_init_1d_s
  ! </SUBROUTINE>
  subroutine horiz_interp_bicubic_init_1d ( Interp, lon_in, lat_in, lon_out, lat_out, &
       verbose, src_modulo )

    !-----------------------------------------------------------------------
    type(horiz_interp_type), intent(inout) :: Interp
    real, intent(in),  dimension(:)        :: lon_in , lat_in
    real, intent(in),  dimension(:)        :: lon_out, lat_out
    integer, intent(in),          optional :: verbose
    logical, intent(in),          optional :: src_modulo
    integer                                :: i, j, ip1, im1, jp1, jm1
    logical                                :: src_is_modulo
    integer                                :: nlon_in, nlat_in, nlon_out, nlat_out
    integer                                :: jcl, jcu, icl, icu, jj
    real                                   :: xz, yz
    integer                                :: unit

    if (do_vers) then
       call write_version_number (version, tagname)
       do_vers = .false.
    endif

    if(present(verbose)) verbose_bicubic = verbose
    src_is_modulo = .false.
    if (present(src_modulo)) src_is_modulo = src_modulo

    !--- get the grid size
    nlon_in  = size(lon_in) ; nlat_in  = size(lat_in)
    nlon_out = size(lon_out); nlat_out = size(lat_out)
    Interp%nlon_src = nlon_in;  Interp%nlat_src = nlat_in
    Interp%nlon_dst = nlon_out; Interp%nlat_dst = nlat_out
    allocate ( Interp%wti     (nlon_in, nlat_in, 3) )
    allocate ( Interp%lon_in  (nlon_in) )
    allocate ( Interp%lat_in  (nlat_in) )
    allocate ( Interp%rat_x   (nlon_out, nlat_out) )
    allocate ( Interp%rat_y   (nlon_out, nlat_out) )
    allocate ( Interp%i_lon   (nlon_out, nlat_out, 2) )
    allocate ( Interp%j_lat   (nlon_out, nlat_out, 2) )

    Interp%lon_in = lon_in
    Interp%lat_in = lat_in

    if ( verbose_bicubic > 0 ) then
       unit = stdout()
       write (unit,'(/,"Initialising bicubic interpolation, interface horiz_interp_bicubic_init_1d")')
       write (unit,'(/," Longitude of coarse grid points (radian): xc(i) i=1, ",i4)') Interp%nlon_src
       write (unit,'(1x,10f10.4)') (Interp%lon_in(jj),jj=1,Interp%nlon_src)
       write (unit,'(/," Latitude of coarse grid points (radian):  yc(j) j=1, ",i4)') Interp%nlat_src
       write (unit,'(1x,10f10.4)') (Interp%lat_in(jj),jj=1,Interp%nlat_src)
       write (unit,*)
       write (unit,'(/," Longitude of fine grid points (radian): xf(i) i=1, ",i4)') Interp%nlat_dst
       write (unit,'(1x,10f10.4)') (lon_out(jj),jj=1,Interp%nlon_dst)
       write (unit,'(/," Latitude of fine grid points (radian):  yf(j) j=1, ",i4)') Interp%nlon_dst
       write (unit,'(1x,10f10.4)') (lat_out(jj),jj=1,Interp%nlat_dst)
    endif

!---------------------------------------------------------------------------
!     Find the x-derivative. Use central differences and forward or
!     backward steps at the boundaries

    do j=1,nlat_in
      do i=1,nlon_in
        ip1=min(i+1,nlon_in)
        im1=max(i-1,1)
        Interp%wti(i,j,1) = 1./(lon_in(ip1)-lon_in(im1))
      enddo
    enddo

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

!     Find the y-derivative. Use central differences and forward or
!     backward steps at the boundaries
      do j=1,nlat_in
        jp1=min(j+1,nlat_in)
        jm1=max(j-1,1)
        do i=1,nlon_in
          Interp%wti(i,j,2) = 1./(lat_in(jp1)-lat_in(jm1))
        enddo
      enddo

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

!     Find the xy-derivative. Use central differences and forward or
!     backward steps at the boundaries
      do j=1,nlat_in
        jp1=min(j+1,nlat_in)
        jm1=max(j-1,1)
        do i=1,nlon_in
          ip1=min(i+1,nlon_in)
          im1=max(i-1,1)
          Interp%wti(i,j,3) = 1./((lon_in(ip1)-lon_in(im1))*(lat_in(jp1)-lat_in(jm1)))
        enddo
      enddo
!---------------------------------------------------------------------------
!     Now for each point at the dest-grid find the boundary points of
!     the source grid
      do j=1, nlat_out
        yz  = lat_out(j)
        jcl = 0
        jcu = 0
        jcl = indl(lat_in, yz)
        jcu = indu(lat_in, yz)
        do i=1,nlon_out
          xz = lon_out(i)
          icl = 0
          icu = 0
          icl = indl(lon_in, xz)
          icu = indu(lon_in, xz)
          Interp%j_lat(i,j,1) = jcl
          Interp%j_lat(i,j,2) = jcu
          Interp%i_lon(i,j,1) = icl
          Interp%i_lon(i,j,2) = icu
          if(yz.gt.lat_in(jcu)) call mpp_error(FATAL, ' horiz_interp_bicubic_init_1d: yf < ycl, no valid boundary point')
          if(yz.lt.lat_in(jcl)) call mpp_error(FATAL, ' horiz_interp_bicubic_init_1d: yf > ycu, no valid boundary point')
          if(xz.gt.lon_in(icu)) call mpp_error(FATAL, ' horiz_interp_bicubic_init_1d: xf < xcl, no valid boundary point')
          if(xz.lt.lon_in(icl)) call mpp_error(FATAL, ' horiz_interp_bicubic_init_1d: xf > xcu, no valid boundary point')
          Interp%rat_x(i,j) = (xz - Interp%lon_in(icl))/(Interp%lon_in(icu) - Interp%lon_in(icl))
          Interp%rat_y(i,j) = (yz - Interp%lat_in(jcl))/(Interp%lat_in(jcu) - Interp%lat_in(jcl))
        enddo
      enddo

  end subroutine horiz_interp_bicubic_init_1d

  subroutine horiz_interp_bicubic( Interp, data_in, data_out, verbose, mask_in, mask_out, missing_value, missing_permit)
    type (horiz_interp_type), intent(in)        :: Interp
    real, intent(in),  dimension(:,:)           :: data_in
    real, intent(out), dimension(:,:)           :: data_out
    integer, intent(in),               optional :: verbose
    real, intent(in),  dimension(:,:), optional :: mask_in
    real, intent(out), dimension(:,:), optional :: mask_out
    real, intent(in),                  optional :: missing_value
    integer, intent(in),               optional :: missing_permit
    real :: yz, ycu, ycl
    real :: xz, xcu, xcl
    real :: val, val1, val2
    real, dimension(4) :: y, y1, y2, y12
    integer :: icl, icu, jcl, jcu
    integer :: iclp1, icup1, jclp1, jcup1
    integer :: iclm1, icum1, jclm1, jcum1
    integer :: i,j

    if ( present(verbose) ) verbose_bicubic = verbose
!    fill_in = .false.
!    if ( present(fill) ) fill_in = fill
!   use dfc_x and dfc_y as workspace
!    if ( fill_in ) call fill_xy(fc(ics:ice,jcs:jce), ics, ice, jcs, jce, maxpass=2)
!    where ( data_in .le. missing ) data_in(:,:) = 0.
!!
    do j=1, Interp%nlat_dst
      do i=1, Interp%nlon_dst
        yz  = Interp%rat_y(i,j)
        xz  = Interp%rat_x(i,j)
        jcl = Interp%j_lat(i,j,1)
        jcu = Interp%j_lat(i,j,2)
        icl = Interp%i_lon(i,j,1)
        icu = Interp%i_lon(i,j,2)
        iclp1 = min(icl+1,Interp%nlon_src)
        iclm1 = max(icl-1,1)
        icup1 = min(icu+1,Interp%nlon_src)
        icum1 = max(icu-1,1)
        jclp1 = min(jcl+1,Interp%nlat_src)
        jclm1 = max(jcl-1,1)
        jcup1 = min(jcu+1,Interp%nlat_src)
        jcum1 = max(jcu-1,1)
        ycl = Interp%lat_in(jcl)
        ycu = Interp%lat_in(jcu)
        xcl = Interp%lon_in(icl)
        xcu = Interp%lon_in(icu)
        y(1)  =  data_in(icl,jcl)
        y(2)  =  data_in(icu,jcl)
        y(3)  =  data_in(icu,jcu)
        y(4)  =  data_in(icl,jcu)
        y1(1) = ( data_in(iclp1,jcl) - data_in(iclm1,jcl) ) * Interp%wti(icl,jcl,1)
        y1(2) = ( data_in(icup1,jcl) - data_in(icum1,jcl) ) * Interp%wti(icu,jcl,1)
        y1(3) = ( data_in(icup1,jcu) - data_in(icum1,jcu) ) * Interp%wti(icu,jcu,1)
        y1(4) = ( data_in(iclp1,jcu) - data_in(iclm1,jcu) ) * Interp%wti(icl,jcu,1)
        y2(1) = ( data_in(icl,jclp1) - data_in(icl,jclm1) ) * Interp%wti(icl,jcl,2)
        y2(2) = ( data_in(icu,jclp1) - data_in(icu,jclm1) ) * Interp%wti(icu,jcl,2)
        y2(3) = ( data_in(icu,jcup1) - data_in(icu,jcum1) ) * Interp%wti(icu,jcu,2)
        y2(4) = ( data_in(icl,jcup1) - data_in(icl,jcum1) ) * Interp%wti(icl,jcu,2)
        y12(1)= ( data_in(iclp1,jclp1) + data_in(iclm1,jclm1) - data_in(iclm1,jclp1) &
                - data_in(iclp1,jclm1) ) * Interp%wti(icl,jcl,3)
        y12(2)= ( data_in(icup1,jclp1) + data_in(icum1,jclm1) - data_in(icum1,jclp1) &
                - data_in(icup1,jclm1) ) * Interp%wti(icu,jcl,3)
        y12(3)= ( data_in(icup1,jcup1) + data_in(icum1,jcum1) - data_in(icum1,jcup1) &
                - data_in(icup1,jcum1) ) * Interp%wti(icu,jcu,3)
        y12(4)= ( data_in(iclp1,jcup1) + data_in(iclm1,jcum1) - data_in(iclm1,jcup1) &
                - data_in(iclp1,jcum1) ) * Interp%wti(icl,jcu,3)

        call bcuint(y,y1,y2,y12,xcl,xcu,ycl,ycu,xz,yz,val,val1,val2)
        data_out   (i,j) = val
        if(present(mask_out)) mask_out(i,j) = 1.
!!        dff_x(i,j) = val1
!!        dff_y(i,j) = val2
      enddo
    enddo
  return
  end subroutine horiz_interp_bicubic

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

   subroutine bcuint(y,y1,y2,y12,x1l,x1u,x2l,x2u,t,u,ansy,ansy1,ansy2)
      real ansy,ansy1,ansy2,x1l,x1u,x2l,x2u,y(4),y1(4),y12(4),y2(4)
!     uses bcucof
      integer i
      real t,u,c(4,4)
      call bcucof(y,y1,y2,y12,x1u-x1l,x2u-x2l,c)
      ansy=0.
      ansy2=0.
      ansy1=0.
      do i=4,1,-1
        ansy=t*ansy+((c(i,4)*u+c(i,3))*u+c(i,2))*u+c(i,1)
        ansy2=t*ansy2+(3.*c(i,4)*u+2.*c(i,3))*u+c(i,2)
        ansy1=u*ansy1+(3.*c(4,i)*t+2.*c(3,i))*t+c(2,i)
      enddo
!      ansy1=ansy1/(x1u-x1l) ! could be used for accuracy checks
!      ansy2=ansy2/(x2u-x2l) ! could be used for accuracy checks
      return
!  (c) copr. 1986-92 numerical recipes software -3#(-)f.
   end subroutine bcuint
!---------------------------------------------------------------------------

   subroutine bcucof(y,y1,y2,y12,d1,d2,c)
      real d1,d2,c(4,4),y(4),y1(4),y12(4),y2(4)
      integer i,j,k,l
      real d1d2,xx,cl(16),wt(16,16),x(16)
      save wt
      data wt/1,0,-3,2,4*0,-3,0,9,-6,2,0,-6,4,8*0,3,0,-9,6,-2,0,6,-4,10* &
       0,9,-6,2*0,-6,4,2*0,3,-2,6*0,-9,6,2*0,6,-4,4*0,1,0,-3,2,-2,0,6,-4, &
       1,0,-3,2,8*0,-1,0,3,-2,1,0,-3,2,10*0,-3,2,2*0,3,-2,6*0,3,-2,2*0,   &
      -6,4,2*0,3,-2,0,1,-2,1,5*0,-3,6,-3,0,2,-4,2,9*0,3,-6,3,0,-2,4,-2,  &
       10*0,-3,3,2*0,2,-2,2*0,-1,1,6*0,3,-3,2*0,-2,2,5*0,1,-2,1,0,-2,4,   &
      -2,0,1,-2,1,9*0,-1,2,-1,0,1,-2,1,10*0,1,-1,2*0,-1,1,6*0,-1,1,2*0,  &
       2,-2,2*0,-1,1/
      d1d2=d1*d2
      do i=1,4
        x(i)=y(i)
        x(i+4)=y1(i)*d1
        x(i+8)=y2(i)*d2
        x(i+12)=y12(i)*d1d2
      enddo
      do i=1,16
        xx=0.
        do k=1,16
          xx=xx+wt(i,k)*x(k)
        enddo
        cl(i)=xx
      enddo
      l=0
      do i=1,4
        do j=1,4
          l=l+1
          c(i,j)=cl(l)
        enddo
      enddo
      return
!  (c) copr. 1986-92 numerical recipes software -3#(-)f.
   end subroutine bcucof

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

    function indl(xc, xf)
! find the lower neighbour of xf in field xc, return is the index
    real, intent(in) :: xc(1:)
    real, intent(in) :: xf
    integer             :: indl
    integer             :: ii
       indl = 1
       do ii=1, size(xc)
         if(xc(ii).gt.xf) return
         indl = ii
       enddo
       call mpp_error(FATAL,'Error in indl')
    return
    end function indl

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

    function indu(xc, xf)
! find the upper neighbour of xf in field xc, return is the index
    real, intent(in) :: xc(1:)
    real, intent(in) :: xf
    integer             :: indu
    integer             :: ii
       do ii=1, size(xc)
         indu = ii
         if(xc(ii).gt.xf) return
       enddo
       call mpp_error(FATAL,'Error in indu')
    return
    end function indu

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

    subroutine fill_xy(fi, ics, ice, jcs, jce, mask, maxpass)
      integer, intent(in)        :: ics,ice,jcs,jce
      real, intent(inout)        :: fi(ics:ice,jcs:jce)
      real, intent(in), optional :: mask(ics:ice,jcs:jce)
      integer, intent(in)        :: maxpass
      real                       :: work_old(ics:ice,jcs:jce)
      real                       :: work_new(ics:ice,jcs:jce)
      logical :: ready
      real    :: blank = -1.e30
      real    :: tavr
      integer :: ipass = 0
      integer :: inl, inr, jnl, jnu, i, j, is, js,  iavr

      ready = .false.

      work_new(:,:) = fi(:,:)
      work_old(:,:) = work_new(:,:)
      ipass = 0
      if ( present(mask) ) then
         do while (.not.ready)
           ipass = ipass+1
           ready = .true.
           do j=jcs, jce
             do i=ics, ice
               if (work_old(i,j).le.blank) then
                 tavr=0.
                 iavr=0
                 inl = max(i-1,ics)
                 inr = min(i+1,ice)
                 jnl = max(j-1,jcs)
                 jnu = min(j+1,jce)
                 do js=jnl,jnu
                   do is=inl,inr
                     if (work_old(is,js) .ne. blank .and. mask(is,js).ne.0) then
                       tavr = tavr + work_old(is,js)
                       iavr = iavr+1
                     endif
                   enddo
                 enddo
                 if (iavr.gt.0) then
                   if (iavr.eq.1) then
! spreading is not allowed if the only valid neighbor is a corner point
! otherwise an ill posed cellular automaton is established leading to
! a spreading of constant values in diagonal direction
! if all corner points are blanked the valid neighbor must be a direct one
! and spreading is allowed
                     if (work_old(inl,jnu).eq.blank.and.&
                         work_old(inr,jnu).eq.blank.and.&
                         work_old(inr,jnl).eq.blank.and.&
                         work_old(inl,jnl).eq.blank) then
                           work_new(i,j)=tavr/iavr
                           ready = .false.
                     endif
                  else
                    work_new(i,j)=tavr/iavr
                    ready = .false.
                  endif
                endif
              endif
            enddo ! j
          enddo   ! i
! save changes made during this pass to work_old
          work_old(:,:)=work_new(:,:)
          if(ipass.eq.maxpass) ready=.true.
        enddo !while (.not.ready)
        fi(:,:) = work_new(:,:)
      else
         do while (.not.ready)
           ipass = ipass+1
           ready = .true.
           do j=jcs, jce
             do i=ics, ice
               if (work_old(i,j).le.blank) then
                 tavr=0.
                 iavr=0
                 inl = max(i-1,ics)
                 inr = min(i+1,ice)
                 jnl = max(j-1,jcs)
                 jnu = min(j+1,jce)
                 do is=inl,inr
                   do js=jnl,jnu
                     if (work_old(is,js).gt.blank) then
                       tavr = tavr + work_old(is,js)
                       iavr = iavr+1
                     endif
                   enddo
                 enddo
                 if (iavr.gt.0) then
                   if (iavr.eq.1) then
! spreading is not allowed if the only valid neighbor is a corner point
! otherwise an ill posed cellular automaton is established leading to
! a spreading of constant values in diagonal direction
! if all corner points are blanked the valid neighbor must be a direct one
! and spreading is allowed
                     if (work_old(inl,jnu).le.blank.and. &
                         work_old(inr,jnu).le.blank.and. &
                         work_old(inr,jnl).le.blank.and. &
                         work_old(inl,jnl).le.blank) then
                           work_new(i,j)=tavr/iavr
                           ready = .false.
                     endif
                  else
                    work_new(i,j)=tavr/iavr
                    ready = .false.
                  endif
                endif
              endif
            enddo ! j
          enddo   ! i
! save changes made during this pass to work_old
          work_old(:,:)=work_new(:,:)
          if(ipass.eq.maxpass) ready=.true.
        enddo !while (.not.ready)
        fi(:,:) = work_new(:,:)
      endif
      return
    end subroutine fill_xy

  subroutine horiz_interp_bicubic_end( Interp )

    type (horiz_interp_type), intent(inout) :: Interp

    deallocate ( Interp%rat_x, Interp%rat_y )
    deallocate ( Interp%lon_in,  Interp%lat_in )
    deallocate ( Interp%i_lon )
    deallocate ( Interp%j_lat )
    deallocate ( Interp%wti )

  end subroutine horiz_interp_bicubic_end

end module horiz_interp_bicubic_mod


!
!     ------------------------------------------------------------------
!     G E T S
!     ------------------------------------------------------------------
!
      SUBROUTINE GETS(S, NSHLI, NSHLF)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
!
! Obtain overlap matrix between all I shells and
! all F shells
!
!...Translated by Pacific-Sierra Research 77to90  4.3E  14:40:05  11/20/01
!...Switches:
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE quadr_I
      USE wrtmat_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER  :: NSHLI
      INTEGER  :: NSHLF
      REAL(DOUBLE)  :: S(NSHLI,NSHLF)
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: II, IF, NTEST
!-----------------------------------------------
!
!
      DO II = 1, NSHLI
         DO IF = 1, NSHLF
            S(II,IF) = QUADR(II,IF + NSHLI,0)
         END DO
      END DO
!
      NTEST = 0
      IF (NTEST /= 0) THEN
         WRITE (6, *) ' S matrix from GETS'
         CALL WRTMAT (S, NSHLI, NSHLF, NSHLI, NSHLF)
      ENDIF
!
      RETURN
      END SUBROUTINE GETS


cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
cc                                                                    cc
cc              mnsuev : surev test program                           cc
cc                                                                    cc
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      real fac
      integer i,idim,ier,j,m,mu,mv,m0,m1,m2,m3,nc,nu4,nv4,nu,nv,l
      real tu(11),tv(10),c(126),u(6),v(6),f(108),wrk(48)
      integer iwrk(12)
c  we set up the grid points for evaluating the spline surface.
      mu = 6
      mv = 6
      do 10 i=1,6
      u(i) = (i-1)*0.2
      v(i) = u(i)
  10  continue
c  the interior knots with respect to the u-variable.
      tu(5) = 0.4
      tu(6) = 0.7
      tu(7) = 0.9
      nu = 11
c  the interior knots with respect to the v-variable.
      tv(5) = 0.3
      tv(6) = 0.8
      nv = 10
c  the boundary knots
      do 20 i=1,4
        tu(i) = 0.
        tv(i) = 0.
        tu(i+7) = 1.
        tv(i+6) = 1.
  20  continue
c  we generate the b-spline coefficients for the test surface
c        x = u*v    y = v**2    z = u+v     0 <= u,v <= 1
c  the dimension of the surface
      idim = 3
c  the number of b-spline coefficients for each co-ordinate
      nu4 = nu-4
      nv4 = nv-4
      nc = nu4*nv4
c  the coefficients for x = u*v
      do 30 i=1,nv4
        c(i) = 0.
  30  continue
      do 40 i=2,nu4
        c((i-1)*nv4+1) = 0.
  40  continue
      m0 = 1
      do 60 i=2,nu4
        m1 = m0+nv4
        fac = (tu(i+3)-tu(i))/9.
        do 50 j=2,nv4
          m2 = m0+1
          m3 = m1+1
          c(m3) = c(m1)+c(m2)-c(m0)+fac*(tv(j+3)-tv(j))
          m0 = m0+1
          m1 = m1+1
  50    continue
        m0 = m0+1
  60  continue
c  the coefficients for y = v**2.
      l = nc
      m0 = l+1
      m1 = m0+1
      c(m0) = 0.
      c(m1) = 0.
      do 70 i=3,nv4
        c(m1+1) = c(m1)+(tv(i+3)-tv(i))*((c(m1)-c(m0))/(tv(i+2)-tv(i-1))
     *    +(tv(i+2)-tv(i))/3.)
        m0 = m1
        m1 = m0+1
  70  continue
      do 80 i=1,nv4
        m0 = l+i
        fac = c(m0)
        do 80 j=1,nu4
          m0 = m0+nv4
          c(m0) = fac
  80  continue
c  the coefficients for z = u+v
      l = l+nc
      m0 = l+1
      c(m0) = 0.
      do 90 i=2,nv4
        m1 = m0+1
        c(m1) = c(m0)+(tv(i+3)-tv(i))/3.
        m0 = m1
  90  continue
      do 100 i=1,nv4
        m0 = l+i
        do 100 j=2,nu4
          m1 = m0+nv4
          c(m1) = c(m0)+(tu(j+3)-tu(j))/3.
          m0 = m1
 100  continue
c  evaluation of the spline surface
      call surev(idim,tu,nu,tv,nv,c,u,mu,v,mv,f,108,wrk,48,iwrk,12,ier)
c  printing of the results
      write(6,900)
      write(6,910)
      write(6,920) (tu(i),i=1,nu)
      write(6,930)
      write(6,920) (tv(i),i=1,nv)
      write(6,940)
      m1 = 0
      do 110 l=1,idim
        m0 = m1+1
        m1 = m1+nc
        write(6,950) (c(j),j=m0,m1)
 110  continue
      write(6,960)
      write(6,970) (v(i),i=1,mv)
      write(6,980)
      m = mu*mv
      m0 = 0
      do 130 i=1,mu
        write(6,990) u(i)
        m1 = m0
        do 120 l=1,idim
          m2 = m1+1
          m3 = m1+mv
          write(6,995) (f(j),j=m2,m3)
          m1 = m1+m
 120    continue
        m0 = m0+mv
 130  continue
      stop
c  format statements.
 900  format(23h0bicubic spline surface)
 910  format(1x,40hposition of the knots in the u-direction)
 920  format(1x,15f5.1)
 930  format(1x,40hposition of the knots in the v-direction)
 940  format(23h b-spline coefficients )
 950  format(5x,8f9.4)
 960  format(1h0,37hspline values at selected grid points)
 970  format(1h0,2x,1hv,6(3x,f4.1))
 980  format(1h ,1x,1hu)
 990  format(1h ,f4.1)
 995  format(5x,6f7.3)
      end


!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 2011 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                     FFTPACK  version 5.1                      *
!     *                                                               *
!     *                 A Fortran Package of Fast Fourier             *
!     *                                                               *
!     *                Subroutines and Example Programs               *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *               Paul Swarztrauber and Dick Valent               *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
program tcfft1

    use, intrinsic :: ISO_C_binding, only: &
        wp => C_DOUBLE, &
        ip => C_INT

    use, intrinsic :: ISO_Fortran_env, only: &
        stdout => OUTPUT_UNIT, &
        stderr => ERROR_UNIT

    use type_FFTpack, only: &
        FFTpack

    ! Explicit typing only
    implicit none

    !------------------------------------------------------
    ! Dictionary
    !------------------------------------------------------
    type (FFTpack)          :: fft
    integer (ip), parameter :: n = 10**3
    complex (wp)            :: complex_data(n)
    real (wp)               :: real_part(n), imaginary_part(n)
    !------------------------------------------------------

    !
    !==> Identify test
    !
    write( stdout, '(A)') 'program tcfft1 and related messages:'

    !
    !==> Generate test vector for forward-backward test
    !
    call get_random_vector(real_part, imaginary_part, complex_data)

    !
    !==> Perform backward transform
    !
    call fft%ifft(complex_data)

    !
    !==> Perform forward transform
    !
    call fft%fft(complex_data)

    !
    !==> Print test results
    !
    associate( max_err => maxval(abs(complex_data-cmplx(real_part, imaginary_part, kind=wp))) )

        write( stdout, '(A,E23.15E3)' ) 'cfft1 backward-forward max error =', max_err

    end associate

    !
    !==> Generate test vector for forward-backward test
    !
    call get_random_vector(real_part, imaginary_part, complex_data)

    !
    !==> Perform forward transform
    !
    call fft%fft(complex_data)

    !
    !==> Perform backward transform
    !
    call fft%ifft(complex_data)

    !
    !==> Print test results
    !
    associate( max_err => maxval(abs(complex_data-cmplx(real_part, imaginary_part, kind=wp))) )

        write( stdout, '(A,E23.15E3)' ) 'cfft1 forward-backward max error =', max_err
        write( stdout, '(A, /)') 'end program tcfft1 and related messages'

    end associate

contains

    subroutine get_random_vector(real_part, imaginary_part, complex_data)
        !--------------------------------------------------
        ! Dictionary: calling arguments
        !--------------------------------------------------
        real (wp),    intent (out) :: real_part(:)
        real (wp),    intent (out) :: imaginary_part(:)
        complex (wp), intent (out) :: complex_data(:)
        !--------------------------------------------------

        call random_seed()
        call random_number(real_part)
        call random_number(imaginary_part)

        complex_data = cmplx(real_part, imaginary_part, kind=wp)

    end subroutine get_random_vector

end program tcfft1


C
C     This file is a part of HAXX
C
C     Copyright (c) 2017 David Williams-Young
C     All rights reserved.
C
C     See LICENSE.txt
C
      Subroutine HAXPYCH(SIDE, N, ALPHA, X, INCX, Y, INCY)
C
      LOGICAL LSAME
      EXTERNAL LSAME
C
      LOGICAL   MRIGHT
      CHARACTER SIDE
      INTEGER*4 N, INCX, INCY, I, IX, IY
      REAL*8    ALPHA(2), X(4,*), Y(4,*)
C
      IF ( N.LE.0 ) RETURN
      IF ( ALPHA(1).EQ.0.0D0 .AND. ALPHA(2).EQ.0.0D0 ) RETURN
C
      MRIGHT = LSAME('R',SIDE)
C
      IF ( INCX.EQ.1 .AND. INCY.EQ.1 ) THEN
        IF ( .NOT. MRIGHT ) THEN
          DO 10 I = 1,N
C           Hamilton Product
            Y(1,I) = Y(1,I) + ALPHA(1)*X(1,I) - ALPHA(2)*X(2,I)
            Y(2,I) = Y(2,I) + ALPHA(1)*X(2,I) + ALPHA(2)*X(1,I)
            Y(3,I) = Y(3,I) + ALPHA(1)*X(3,I) - ALPHA(2)*X(4,I)
            Y(4,I) = Y(4,I) + ALPHA(1)*X(4,I) + ALPHA(2)*X(3,I)
  10      CONTINUE
        ELSE
          DO 20 I = 1,N
C           Hamilton Product
            Y(1,I) = Y(1,I) + X(1,I)*ALPHA(1) - X(2,I)*ALPHA(2)
            Y(2,I) = Y(2,I) + X(1,I)*ALPHA(2) + X(2,I)*ALPHA(1)
            Y(3,I) = Y(3,I) + X(3,I)*ALPHA(1) + X(4,I)*ALPHA(2)
            Y(4,I) = Y(4,I) - X(3,I)*ALPHA(2) + X(4,I)*ALPHA(1)
  20      CONTINUE
        ENDIF
      ELSE

        IX = 1
        IY = 1
        IF ( INCX.LT.0 ) IX = (-N + 1)*INCX + 1
        IF ( INCY.LT.0 ) IY = (-N + 1)*INCY + 1

        IF ( .NOT. MRIGHT ) THEN
          DO 30 I = 1,N
C           Hamilton Product
            Y(1,IY) = Y(1,IY) + ALPHA(1)*X(1,IX) - ALPHA(2)*X(2,IX)
            Y(2,IY) = Y(2,IY) + ALPHA(1)*X(2,IX) + ALPHA(2)*X(1,IX)
            Y(3,IY) = Y(3,IY) + ALPHA(1)*X(3,IX) - ALPHA(2)*X(4,IX)
            Y(4,IY) = Y(4,IY) + ALPHA(1)*X(4,IX) + ALPHA(2)*X(3,IX)

            IX = IX + INCX
            IY = IY + INCY
  30      CONTINUE
        ELSE
          DO 40 I = 1,N
C           Hamilton Product
            Y(1,IY) = Y(1,IY) + X(1,IX)*ALPHA(1) - X(2,IX)*ALPHA(2)
            Y(2,IY) = Y(2,IY) + X(1,IX)*ALPHA(2) + X(2,IX)*ALPHA(1)
            Y(3,IY) = Y(3,IY) + X(3,IX)*ALPHA(1) + X(4,IX)*ALPHA(2)
            Y(4,IY) = Y(4,IY) - X(3,IX)*ALPHA(2) + X(4,IX)*ALPHA(1)

            IX = IX + INCX
            IY = IY + INCY
  40      CONTINUE
        ENDIF
      ENDIF
C
      END


      double precision function cosine_bell_sum(x,y,z)
      implicit none

      double precision x,y,z

      double precision wcloc(3,2)
      common /location_parms/ wcloc

      double precision r, hmax, b, c
      common /cosinebell_parms/ r, hmax, b, c

      integer m,k
      double precision w(3), q,qv, cosbell

      q = 0
      do m = 1,2
         do k = 1,3
            w(k) = wcloc(k,m)
         end do
         qv = cosbell(x,y,z,w,r,hmax)
         q  = q  + qv
      enddo
      cosine_bell_sum = b + c*q

      end

      double precision function cosbell(x,y,z,w,r,hmax)
      implicit none

      double precision x,y,z,w(3),r,hmax
      double precision get_gc_distance, h1, ri

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

      ri = get_gc_distance(x,y,z,w)

      if (ri .le. r) then
         h1 = hmax*(1 + cos(pi*ri/r))
      else
         h1 = 0.d0
      endif
      cosbell = h1

      end


C NCLFORTSTART
      DOUBLE PRECISION FUNCTION DFLXEDY(X,Y,NPTS,XMSG,IER)
      INTEGER NPTS,IER
      DOUBLE PRECISION X(NPTS),Y(NPTS),XMSG
C*PT*WARNING* Already double-precision
C NCLEND

c NCL: z = fluxEddy (x,y) ; "z" will be allocated by the NCL driver

c NCL Note to Dennis: we could expand the calling sequence as follows
c  double precision function flxedy (x,y,npts,xmsg,xave,yave,xpxp,ypyp,
c                                    cc,ntot,ier)
c   and then return "xave,yave,xpxp,ypyp,cc,ntot" as attributes of "z"
c   Too much memory if doing this over a grid ... attributes
c   can not be multiply dimensioned.

c Calculate time mean eddy flux quantities (eg, ave{v'T'})
c .   Method: xy = XY + x'y' where x and y are instantaneous values
c .                                X     Y are time means of x and y
c .           x'y' = xy-XY
C*PL*ERROR* Comment line too long
c Calculate the correlation coef between x'y' (add to arguments if desired)
c .            cc  = x'y'/sqrt(x'x' + y'y')

C Example:   double u(ntims,mlon,nlat,klev), v(ntims,mlon,nlat,klev)
c .          double upvp(mlon,nlat,klev)
c .          do kl=1,klev
c .           do nl=1,nlat
c .            do ml=1,mlon
c .               upvp(ml,nl,kl) =
c .               dflxedy (u(1,ml,nl,kl),v(1,ml,nl,kl),ntims,xmsg,ier)
c .            end do
c .           end do
c .          end do

c local stuff

      DOUBLE PRECISION XAVE,YAVE,XXAVE,YYAVE,XYAVE,XPYP,XPXP,YPYP,XN,CC
      INTEGER N,NTOT

      IER = 0
      IF (NPTS.LE.0) THEN
          IER = 1
          DFLXEDY = XMSG
          RETURN
      END IF

      NTOT = 0
C*PT*WARNING* Constant already double-precision
      XAVE = 0.d0
C*PT*WARNING* Constant already double-precision
      YAVE = 0.d0
C*PT*WARNING* Constant already double-precision
      XYAVE = 0.d0
C*PT*WARNING* Constant already double-precision
      XXAVE = 0.d0
C*PT*WARNING* Constant already double-precision
      YYAVE = 0.d0
      DO N = 1,NPTS
          IF (X(N).NE.XMSG .AND. Y(N).NE.XMSG) THEN
              NTOT = NTOT + 1
C*PT*WARNING* Already double-precision (DBLE)
              XAVE = XAVE + DBLE(X(N))
C*PT*WARNING* Already double-precision (DBLE)
              YAVE = YAVE + DBLE(Y(N))
C*PT*WARNING* DPROD found - result may be incorrect
              XYAVE = XYAVE + X(N)*Y(N)
C*PT*WARNING* DPROD found - result may be incorrect
              XXAVE = XXAVE + X(N)*X(N)
C*PT*WARNING* DPROD found - result may be incorrect
              YYAVE = YYAVE + Y(N)*Y(N)
          END IF
      END DO

      IF (NTOT.GT.0) THEN
C*PT*WARNING* Already double-precision (DBLE)
          XN = DBLE(DBLE(NTOT))
          XAVE = XAVE/XN
          YAVE = YAVE/XN
          XYAVE = XYAVE/XN
          XXAVE = XXAVE/XN
          YYAVE = YYAVE/XN
          XPYP = XYAVE - XAVE*YAVE
          XPXP = XXAVE - XAVE*XAVE
          YPYP = YYAVE - YAVE*YAVE
          CC = XPYP/DSQRT(XPXP*YPYP)
      ELSE
          XAVE = XMSG
          YAVE = XMSG
          XYAVE = XMSG
          XPYP = XMSG
          XPXP = XMSG
          YPYP = XMSG
          CC = XMSG
      END IF
C*PT*WARNING* Non-reversible tranformation (SNGL)

      DFLXEDY = XPYP

      RETURN
      END


!
!   FnVFRRet.f90
!
!
!   Created by Kurt Mitman on 17/10/14.

DOUBLE PRECISION FUNCTION FnVFRRet(bsav)

USE Params
USE Globals
USE funcs
USE Procedures

IMPLICIT NONE

DOUBLE PRECISION, INTENT(IN) :: bsav
DOUBLE PRECISION             :: cons
DOUBLE PRECISION             :: vals(2)
INTEGER                      :: inds(2)

cons=gliq-FnQb(bsav,0.0d0)*bsav

if(cons .LT. cmin) then
FnVFRRet = 1.d10+10.0d0*(cmin-cons)

else
call basefun(GridB,nb,bsav,vals,inds)
FnVFRRet = -1.0d0*(urent(cons,GridHR(gih),gij)+bet*(vals(1)*EVrentRet(inds(1),gij)+vals(2)*EVrentRet(inds(2),gij)))
endif

END FUNCTION FnVFRRet


!    Copyright (C) 2012 The SPEED FOUNDATION
!    Author: Ilario Mazzieri
!
!    This file is part of SPEED.
!
!    SPEED is free software; you can redistribute it and/or modify it
!    under the terms of the GNU Affero General Public License as
!    published by the Free Software Foundation, either version 3 of the
!    License, or (at your option) any later version.
!
!    SPEED is distributed in the hope that it will be useful, but
!    WITHOUT ANY WARRANTY; without even the implied warranty of
!    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
!    Affero General Public License for more details.
!
!    You should have received a copy of the GNU Affero General Public License
!    along with SPEED.  If not, see <http://www.gnu.org/licenses/>.

!> @brief Computes ABC's.
!! @author Ilario Mazzieri
!> @date September, 2013
!> @version 1.0
!> @param[in] nn number of 1D GLL nodes
!> @param[in] xq GLL nodes
!> @param[in] wq GLL weights
!> @param[in] dd spectral derivative matrix
!> @param[in] rho
!> @param[in] lambda
!> @param[in] mu material properties given node by node
!> @param[in] AA11  costant value for the bilinear map
!> @param[in] AA12  costant value for the bilinear map
!> @param[in] AA13  costant value for the bilinear map
!> @param[in] AA21  costant value for the bilinear map
!> @param[in] AA22  costant value for the bilinear map
!> @param[in] AA23  costant value for the bilinear map
!> @param[in] AA31  costant value for the bilinear map
!> @param[in] AA32  costant value for the bilinear map
!> @param[in] AA33  costant value for the bilinear map
!> @param[in] BB11  costant value for the bilinear map
!> @param[in] BB12  costant value for the bilinear map
!> @param[in] BB13  costant value for the bilinear map
!> @param[in] BB21  costant value for the bilinear map
!> @param[in] BB22  costant value for the bilinear map
!> @param[in] BB23  costant value for the bilinear map
!> @param[in] BB31  costant value for the bilinear map
!> @param[in] BB32  costant value for the bilinear map
!> @param[in] BB33  costant value for the bilinear map
!> @param[in] GG1  costant value for the bilinear map
!> @param[in] GG2  costant value for the bilinear map
!> @param[in] GG3  costant value for the bilinear map
!> @param[in] DD1  costant value for the bilinear map
!> @param[in] DD2  costant value for the bilinear map
!> @param[in] DD3  costant value for the bilinear map
!> @param[in] ia index for selecting the element absorbing face
!> @param[in] ib index for selecting the element absorbing face
!> @param[in] ja index for selecting the element absorbing face
!> @param[in] jb index for selecting the element absorbing face
!> @param[in] ka index for selecting the element absorbing face
!> @param[in] kb index for selecting the element absorbing face
!> @param[in] ux x-displacement
!> @param[in] uy y-displacement
!> @param[in] uz z-displacement
!> @param[in] vx x-velocity
!> @param[in] vy y-velocity
!> @param[in] vz z-velocity
!> @param[out] fx x-absorbing forces
!> @param[out] fy y-absorbing forces
!> @param[out] fz z-absorbing forces

      subroutine MAKE_ABC_FORCE(nn,xq,wq,dd,rho,lambda,mu,&
                                AA11,AA12,AA13,AA21,AA22,AA23,&
                                AA31,AA32,AA33,BB11,BB12,BB13,&
                                BB21,BB22,BB23,BB31,BB32,BB33,&
                                GG1,GG2,GG3,DD1,DD2,DD3,&
                                ia,ib,ja,jb,ka,kb,ux,uy,uz,vx,vy,vz,fx,fy,fz)

!
!**************************************************************************************************

      implicit none

      integer*4 :: nn
      integer*4 :: ia,ib,ja,jb,ka,kb
      integer*4 :: i,j,k,p,q,r

      real*8 :: AA11,AA12,AA13,AA21,AA22,AA23,AA31,AA32,AA33
      real*8 :: BB11,BB12,BB13,BB21,BB22,BB23,BB31,BB32,BB33
      real*8 :: GG1,GG2,GG3,DD1,DD2,DD3
      real*8 :: dxdx,dxdy,dxdz,dydx,dydy,dydz,dzdx,dzdy,dzdz,det_j
      real*8 :: duxdx,duxdy,duxdz,duydx,duydy,duydz,duzdx,duzdy,duzdz
      real*8 :: dut1dt1,dut2dt2,dut3dt1,dut3dt2
      real*8 :: dxdu,dxdv,dydu,dydv,dzdu,dzdv
      real*8 :: s1,s2,s3,vt1,vt2,vt3,r8t
      real*8 :: t1x,t1y,t1z,t2x,t2y,t2z,t3x,t3y,t3z
      real*8 :: t1ux,t2ux,t3ux,t1uy,t2uy,t3uy,t1uz,t2uz,t3uz

      real*8, dimension(nn) :: xq,wq

      real*8, dimension(nn,nn) :: dd

      real*8, dimension(nn,nn,nn) :: rho,lambda,mu
      real*8, dimension(nn,nn,nn) :: ux,uy,uz
      real*8, dimension(nn,nn,nn) :: vx,vy,vz
      real*8, dimension(nn,nn,nn) :: fx,fy,fz
      real*8, dimension(nn,nn,nn) :: alfa,beta

      do r = 1,nn
         do q = 1,nn
            do p = 1,nn
               alfa(p,q,r) = dsqrt((lambda(p,q,r) + 2.0d0*mu(p,q,r))/rho(p,q,r))
               beta(p,q,r) = dsqrt(mu(p,q,r)/rho(p,q,r))
            enddo
         enddo
      enddo

      do r = 1,nn
         do q = 1,nn
            do p = 1,nn
               fx(p,q,r) = 0.0d0;  fy(p,q,r) = 0.0d0;   fz(p,q,r) = 0.0d0
            enddo
         enddo
      enddo

      do r = ka,kb
         do q = ja,jb
            do p = ia,ib
               t1ux = 0.d0; t1uy = 0.d0; t1uz = 0.d0
               t2ux = 0.d0; t2uy = 0.d0; t2uz = 0.d0
               t3ux = 0.d0; t3uy = 0.d0; t3uz = 0.d0

               dxdx = AA11 + BB12*xq(r) + BB13*xq(q) + GG1*xq(q)*xq(r)
               dydx = AA21 + BB22*xq(r) + BB23*xq(q) + GG2*xq(q)*xq(r)
               dzdx = AA31 + BB32*xq(r) + BB33*xq(q) + GG3*xq(q)*xq(r)

               dxdy = AA12 + BB11*xq(r) + BB13*xq(p) + GG1*xq(r)*xq(p)
               dydy = AA22 + BB21*xq(r) + BB23*xq(p) + GG2*xq(r)*xq(p)
               dzdy = AA32 + BB31*xq(r) + BB33*xq(p) + GG3*xq(r)*xq(p)

               dxdz = AA13 + BB11*xq(q) + BB12*xq(p) + GG1*xq(p)*xq(q)
               dydz = AA23 + BB21*xq(q) + BB22*xq(p) + GG2*xq(p)*xq(q)
               dzdz = AA33 + BB31*xq(q) + BB32*xq(p) + GG3*xq(p)*xq(q)

               det_j = dxdz * (dydx*dzdy - dzdx*dydy) &
                     - dydz * (dxdx*dzdy - dzdx*dxdy) &
                     + dzdz * (dxdx*dydy - dydx*dxdy)

               do i = 1,nn
                  t1ux = t1ux + ux(i,q,r) * dd(p,i)
                  t1uy = t1uy + uy(i,q,r) * dd(p,i)
                  t1uz = t1uz + uz(i,q,r) * dd(p,i)
               enddo

               do j = 1,nn
                  t2ux = t2ux + ux(p,j,r) * dd(q,j)
                  t2uy = t2uy + uy(p,j,r) * dd(q,j)
                  t2uz = t2uz + uz(p,j,r) * dd(q,j)
               enddo

               do k = 1,nn
                  t3ux = t3ux + ux(p,q,k) * dd(r,k)
                  t3uy = t3uy + uy(p,q,k) * dd(r,k)
                  t3uz = t3uz + uz(p,q,k) * dd(r,k)
               enddo

               duxdx = 1.0d0 / det_j *(&
                    ((dydy*dzdz - dydz*dzdy) * t1ux) + &
                    ((dydz*dzdx - dydx*dzdz) * t2ux) + &
                    ((dydx*dzdy - dydy*dzdx) * t3ux))

               duydx = 1.0d0 / det_j *(&
                    ((dydy*dzdz - dydz*dzdy) * t1uy) + &
                    ((dydz*dzdx - dydx*dzdz) * t2uy) + &
                    ((dydx*dzdy - dydy*dzdx) * t3uy))

               duzdx = 1.0d0 / det_j *(&
                    ((dydy*dzdz - dydz*dzdy) * t1uz) + &
                    ((dydz*dzdx - dydx*dzdz) * t2uz) + &
                    ((dydx*dzdy - dydy*dzdx) * t3uz))

               duxdy = 1.0d0 / det_j *(&
                    ((dzdy*dxdz - dzdz*dxdy) * t1ux) + &
                    ((dzdz*dxdx - dzdx*dxdz) * t2ux) + &
                    ((dzdx*dxdy - dzdy*dxdx) * t3ux))

               duydy = 1.0d0 / det_j *(&
                    ((dzdy*dxdz - dzdz*dxdy) * t1uy) + &
                    ((dzdz*dxdx - dzdx*dxdz) * t2uy) + &
                    ((dzdx*dxdy - dzdy*dxdx) * t3uy))

               duzdy = 1.0d0 / det_j *(&
                    ((dzdy*dxdz - dzdz*dxdy) * t1uz) + &
                    ((dzdz*dxdx - dzdx*dxdz) * t2uz) + &
                    ((dzdx*dxdy - dzdy*dxdx) * t3uz))

               duxdz = 1.0d0 / det_j *(&
                    ((dxdy*dydz - dxdz*dydy) * t1ux) + &
                    ((dxdz*dydx - dxdx*dydz) * t2ux) + &
                    ((dxdx*dydy - dxdy*dydx) * t3ux))

               duydz = 1.0d0 / det_j *(&
                    ((dxdy*dydz - dxdz*dydy) * t1uy) + &
                    ((dxdz*dydx - dxdx*dydz) * t2uy) + &
                    ((dxdx*dydy - dxdy*dydx) * t3uy))

               duzdz = 1.0d0 / det_j *(&
                    ((dxdy*dydz - dxdz*dydy) * t1uz) + &
                    ((dxdz*dydx - dxdx*dydz) * t2uz) + &
                    ((dxdx*dydy - dxdy*dydx) * t3uz))

               if ((ia.eq.ib).and.(ia.eq.1)) then
                  dxdu = dxdy
                  dydu = dydy
                  dzdu = dzdy

                  dxdv = -dxdz
                  dydv = -dydz
                  dzdv = -dzdz
               endif

               if ((ja.eq.jb).and.(ja.eq.1)) then
                  dxdu = dxdz
                  dydu = dydz
                  dzdu = dzdz

                  dxdv = -dxdx
                  dydv = -dydx
                  dzdv = -dzdx
               endif

               if ((ka.eq.kb).and.(ka.eq.1)) then
                  dxdu = dxdx
                  dydu = dydx
                  dzdu = dzdx

                  dxdv = -dxdy
                  dydv = -dydy
                  dzdv = -dzdy
               endif

               if ((ia.eq.ib).and.(ia.eq.nn)) then
                  dxdu = dxdy
                  dydu = dydy
                  dzdu = dzdy

                  dxdv = dxdz
                  dydv = dydz
                  dzdv = dzdz
               endif

               if ((ja.eq.jb).and.(ja.eq.nn)) then
                  dxdu = dxdz
                  dydu = dydz
                  dzdu = dzdz

                  dxdv = dxdx
                  dydv = dydx
                  dzdv = dzdx
               endif

               if ((ka.eq.kb).and.(ka.eq.nn)) then
                  dxdu = dxdx
                  dydu = dydx
                  dzdu = dzdx

                  dxdv = dxdy
                  dydv = dydy
                  dzdv = dzdy
               endif

               t1x = dxdu
               t1y = dydu
               t1z = dzdu

               t2x = dxdv
               t2y = dydv
               t2z = dzdv

               t3x = t1y*t2z - t1z*t2y
               t3y = t1z*t2x - t1x*t2z
               t3z = t1x*t2y - t1y*t2x

               r8t = dsqrt(t1x*t1x +t1y*t1y +t1z*t1z)
               t1x = t1x/r8t
               t1y = t1y/r8t
               t1z = t1z/r8t

               r8t = dsqrt(t3x*t3x +t3y*t3y +t3z*t3z)
               t3x = t3x/r8t
               t3y = t3y/r8t
               t3z = t3z/r8t

               t2x = t3y*t1z - t3z*t1y
               t2y = t3z*t1x - t3x*t1z
               t2z = t3x*t1y - t3y*t1x

               dut1dt1 = t1x*t1x*duxdx + t1x*t1y*duydx + t1x*t1z*duzdx &
                       + t1y*t1x*duxdy + t1y*t1y*duydy + t1y*t1z*duzdy &
                       + t1z*t1x*duxdz + t1z*t1y*duydz + t1z*t1z*duzdz

               dut2dt2 = t2x*t2x*duxdx + t2x*t2y*duydx + t2x*t2z*duzdx &
                       + t2y*t2x*duxdy + t2y*t2y*duydy + t2y*t2z*duzdy &
                       + t2z*t2x*duxdz + t2z*t2y*duydz + t2z*t2z*duzdz

               dut3dt1 = t1x*t3x*duxdx + t1x*t3y*duydx + t1x*t3z*duzdx &
                       + t1y*t3x*duxdy + t1y*t3y*duydy + t1y*t3z*duzdy &
                       + t1z*t3x*duxdz + t1z*t3y*duydz + t1z*t3z*duzdz

               dut3dt2 = t2x*t3x*duxdx + t2x*t3y*duydx + t2x*t3z*duzdx &
                       + t2y*t3x*duxdy + t2y*t3y*duydy + t2y*t3z*duzdy &
                       + t2z*t3x*duxdz + t2z*t3y*duydz + t2z*t3z*duzdz

               vt1 = t1x*vx(p,q,r) + t1y*vy(p,q,r) + t1z*vz(p,q,r)
               vt2 = t2x*vx(p,q,r) + t2y*vy(p,q,r) + t2z*vz(p,q,r)
               vt3 = t3x*vx(p,q,r) + t3y*vy(p,q,r) + t3z*vz(p,q,r)

               s1 = (mu(p,q,r)*(2.0d0*beta(p,q,r) -alfa(p,q,r))) &
                                /beta(p,q,r) * dut3dt1 - mu(p,q,r)/beta(p,q,r) * vt1
               s2 = (mu(p,q,r)*(2.0d0*beta(p,q,r) -alfa(p,q,r))) &
                                /beta(p,q,r) * dut3dt2 - mu(p,q,r)/beta(p,q,r) * vt2
               s3 = (lambda(p,q,r)*beta(p,q,r) +2.0d0*mu(p,q,r)* &
                                (beta(p,q,r) -alfa(p,q,r)))/alfa(p,q,r) &
                   * (dut1dt1 +dut2dt2) - (lambda(p,q,r) +2.0d0*mu(p,q,r))/alfa(p,q,r) * vt3

               det_j = dsqrt(((dxdu*dxdu +dydu*dydu +dzdu*dzdu) &
                     * (dxdv*dxdv +dydv*dydv +dzdv*dzdv)) &
                     -((dxdu*dxdv +dydu*dydv +dzdu*dzdv) &
                     * (dxdu*dxdv +dydu*dydv +dzdu*dzdv)))

               fx(p,q,r) = fx(p,q,r) - wq(p)*wq(q)*wq(r)*det_j/wq(1) &
                         * (s1*t1x + s2*t2x + s3*t3x)
               fy(p,q,r) = fy(p,q,r) - wq(p)*wq(q)*wq(r)*det_j/wq(1) &
                         * (s1*t1y + s2*t2y + s3*t3y)
               fz(p,q,r) = fz(p,q,r) - wq(p)*wq(q)*wq(r)*det_j/wq(1) &
                         * (s1*t1z + s2*t2z + s3*t3z)

            enddo
         enddo
      enddo

      return

      end subroutine MAKE_ABC_FORCE


module mod_monolis_solver_CG
  use mod_monolis_prm
  use mod_monolis_com
  use mod_monolis_mat
  use mod_monolis_precond
  use mod_monolis_matvec
  use mod_monolis_linalg
  use mod_monolis_linalg_util
  use mod_monolis_converge
  use mod_monolis_util

  implicit none

contains

  subroutine monolis_solver_CG(monoPRM, monoCOM, monoMAT)
    implicit none
    type(monolis_prm) :: monoPRM
    type(monolis_com) :: monoCOM
    type(monolis_mat) :: monoMAT
    integer(kint) :: N, NP, NDOF, NNDOF
    integer(kint) :: i, iter, iter_RR
    real(kdouble) :: alpha, beta, rho, rho1, omega, B2
    real(kdouble), allocatable :: R(:), Z(:), Q(:), P(:)
    real(kdouble), pointer :: B(:), X(:)
    logical :: is_converge

    if(monoPRM%is_debug) call monolis_debug_header("monolis_solver_CG")

    N     = monoMAT%N
    NP    = monoMAT%NP
    NDOF  = monoMAT%NDOF
    NNDOF = N*NDOF
    X => monoMAT%X
    B => monoMAT%B
    iter_RR = 200

    if(monoPRM%is_init_x) X = 0.0d0

    allocate(R(NDOF*NP), source = 0.0d0)
    allocate(Z(NDOF*NP), source = 0.0d0)
    allocate(Q(NDOF*NP), source = 0.0d0)
    allocate(P(NDOF*NP), source = 0.0d0)

    call monolis_set_converge(monoPRM, monoCOM, monoMAT, B, B2, is_converge, monoPRM%tdotp, monoPRM%tcomm_dotp)
    if(is_converge) return
    call monolis_residual(monoCOM, monoMAT, X, B, R, monoPRM%tspmv, monoPRM%tcomm_spmv)

    do iter = 1, monoPRM%maxiter
      call monolis_precond_apply(monoPRM, monoCOM, monoMAT, R, Z)
      call monolis_inner_product_R(monoCOM, N, NDOF, R, Z, rho, monoPRM%tdotp, monoPRM%tcomm_dotp)

      if(1 < iter)then
        beta = rho/rho1
        call monolis_vec_AXPY(N, NDOF, beta, P, Z, P)
      else
        call monolis_vec_copy_R(N, NDOF, Z, P)
      endif

      call monolis_matvec(monoCOM, monoMAT, P, Q, monoPRM%tspmv, monoPRM%tcomm_spmv)
      call monolis_inner_product_R(monoCOM, N, NDOF, P, Q, omega, monoPRM%tdotp, monoPRM%tcomm_dotp)
      alpha = rho/omega

      call monolis_vec_AXPY(N, NDOF, alpha, P, X, X)

      if(mod(iter, iter_RR) == 0)then
        call monolis_residual(monoCOM, monoMAT, X, B, R, monoPRM%tspmv, monoPRM%tcomm_spmv)
      else
        call monolis_vec_AXPY(N, NDOF, -alpha, Q, R, R)
      endif

      call monolis_check_converge(monoPRM, monoCOM, monoMAT, R, B2, iter, is_converge, monoPRM%tdotp, monoPRM%tcomm_dotp)
      if(is_converge) exit

      rho1 = rho
    enddo

    call monolis_update_R(monoCOM, NDOF, X, monoPRM%tcomm_spmv)

    deallocate(R)
    deallocate(Z)
    deallocate(Q)
    deallocate(P)
  end subroutine monolis_solver_CG

end module mod_monolis_solver_CG