!------------------------------------------------------------------------------
!!  module: sponge damping
!------------------------------------------------------------------------------
!!
!! - fabien margairaz (fabien.margairaz@gmail.com)
!!
!! - description:
!!
!------------------------------------------------------------------------------

module sponge_damping

  use parameters_IO
  use decomp_2d
  use decomp_2d_custom
  use utility_tools

  !! - global variables
  use system_variables, only : u,v,w,rhsx,rhsy,rhsz

  implicit none
  include 'mpif.h'

  private
  TYPE(DECOMP_INFO),save :: dcp
  real(rprec),allocatable,dimension(:),save :: sponge

  public :: sponge_damping_init,sponge_damping_finalize
  public :: add_sponge_damping

contains !=======================================================================

  !------------------------------------------------------------------------------
  !! subroutine: initialise sponge damping module
  !------------------------------------------------------------------------------
  !!
  !! - fabien margairaz (fabien.margairaz@gmail.com)
  !!
  !! - description:
  !!
  !------------------------------------------------------------------------------
  subroutine sponge_damping_init(dcp_main)
    implicit none

    TYPE(DECOMP_INFO),intent(in) :: dcp_main

    real(rprec) :: sponge_layer_fraction=0._rprec!To add in parameter
    real(rprec) :: z,z_d,cfrdmp
    integer :: k
    integer :: status, errorcode

    dcp = dcp_main

    allocate(sponge(dcp%xsz(3)+1), STAT=status)
    if (status /= 0) then
       errorcode = 3
       call decomp_2d_abort(errorcode, &
            'Out of memory when initialising splonge variable')
    end if

    sponge=0._rprec

    ! For the damping_method = 2 the sponge is computed at the nodes of w (not in u,v,p nodes)
    ! Gerard Cortina 13/05/15
    z_d = sponge_layer_fraction*lz
    cfrdmp = 3.9_rprec

    do k=1,dcp%xsz(3)+1
       z=(dcp%xst(3)+k-2._rprec)*dz
       !z=(dcp%xst(3)-1+k-0.5_rprec)*dz*H0

       if((z.ge.z_d).and.(z.le.lz))then
          sponge(k)=cfrdmp*0.5_rprec*(1._rprec-cos(pi*(z-z_d)/(lz-z_d)))
       else
          sponge(k)=0._rprec
       end if
    end do

    if(dcp%xen(3)==nz)then
       sponge(dcp%xsz(3)+1)=sponge(dcp%xsz(3))
    end if

    sponge=0._rprec

!!$
!!$
!!$
!!$    elseif (damping_method==1) then
!!$       ! sets relaxation term to vertical momentum equation in top quarter
!!$       ! of domain, relaxation timescale on top is 50s with a factor of 5 if we
!!$       ! had Nz=40 for the layers 40...31, Nieuwstadt et al. 1991, turbulent shear
!!$       ! flows
!!$
!!$       $if ($MPI)
!!$       !--the non-MPI recursive form in inconvenient, so instead replace with
!!$       !  analytically evaluated version (should be this way anyway...)
!!$       sponge=0._rprec
!!$       !  factor=9._rprec/(nz_global - 3*nz_global/4 + 1)
!!$       factor=9._rprec/(nz_tot - 3*nz_tot/4 + 1)
!!$       sponge_top = z_i / (50._rprec * u_star)
!!$       do k = 1, nz
!!$          k_global = k + coord * nz
!!$          if (k_global > 3*nz_global/4 + 1) then
!!$             sponge(k) = sponge_top * 5._rprec**((k_global-nz_global) * factor)
!!$          end if
!!$       end do
!!$       $else
!!$       sponge=0._rprec
!!$       factor=9._rprec/(nz-3*nz/4+1)
!!$       sponge(nz)=z_i/(50._rprec*u_star)
!!$       do k=nz-1,3*nz/4+1,-1
!!$          sponge(k)=sponge(k+1)/5._rprec**factor
!!$       end do
!!$       $endif
!!$
!!$    end if

    return
  end subroutine sponge_damping_init

  !------------------------------------------------------------------------------
  !! subroutine: finalise sponge damping module
  !------------------------------------------------------------------------------
  subroutine sponge_damping_finalize()

    implicit none

    deallocate(sponge)

  end subroutine sponge_damping_finalize

  !------------------------------------------------------------------------------
  !! subroutine: compute planar average
  !------------------------------------------------------------------------------
  !!
  !! - fabien margairaz (fabien.margairaz@gmail.com)
  !!
  !! - description:
  !!  - add damping terms to the momentum RHS
  !!
  !------------------------------------------------------------------------------
  subroutine add_sponge_damping()

    real(rprec),dimension(dcp%xsz(3)) :: u_avg,v_avg,w_avg
    integer :: i,j,k

    call compute_planar_average(u_avg,u(:,:,1:dcp%xsz(3)),dcp)
    call compute_planar_average(v_avg,v(:,:,1:dcp%xsz(3)),dcp)
    call compute_planar_average(w_avg,w(:,:,1:dcp%xsz(3)),dcp)

    !$omp parallel do
    do k=1,dcp%xsz(3)
       do j=1,dcp%xsz(2)
          do i=1,dcp%xsz(1)
             RHSx(i,j,k)=RHSx(i,j,k)-0.5*(sponge(k)+sponge(k+1))*(u(i,j,k)-u_avg(k))
             RHSy(i,j,k)=RHSy(i,j,k)-0.5*(sponge(k)+sponge(k+1))*(v(i,j,k)-v_avg(k))
             RHSz(i,j,k)=RHSz(i,j,k)-sponge(k)*(w(i,j,k)-w_avg(k))
          enddo
       enddo
    enddo
    !$omp end parallel do

     return
   end subroutine add_sponge_damping

 end module sponge_damping


! This file is F-compatible, except for upper/lower case conventions.
!--------------------------------------------------------------------
Module CubatureRule_C2

USE Precision_Model, ONLY: stnd

Implicit NONE

PRIVATE

PUBLIC :: Rule_C2a

CONTAINS
SUBROUTINE Rule_C2a(VER,INFOLD,AREA,NUMFUN,Integrand,BASVAL,RGNERR,NUM)
!
!***BEGIN PROLOGUE Rule_C2a
!***PURPOSE  To compute basic integration rule values and
!            corresponding error estimates.
! ***REVISION DATE  950531   (YYMMDD) (Fortran90 transformation)
! ***REVISION DATE  990527   (YYMMDD) (F transformation)
! ***AUTHOR
!          Ronald Cools, Dept. of Computer Science,
!          Katholieke Universiteit Leuven, Celestijnenlaan 200A,
!          B-3001 Heverlee, Belgium
!          Email:  ronald@cs.kuleuven.ac.be
!
! ***REFERENCES
!          The cubature formula of degree 13 with 37 points is from
!          Rabinowitz & Richter. The tuning of the error estimator
!          is described in:
!          R. Cools.
!          "The subdivision strategy and reliablity in adaptive
!           integration revisited."
!          Report TW 213, Dept. of Computer Science, K.U.Leuven, 1994.
!
!***DESCRIPTION Rule_C2a computes basic integration rule values
!            for a vector of integrands over a rectangular region.
!            Rule_C2a also computes estimates for the errors by
!            using several null rule approximations.
!   ON ENTRY
!
!   VER    Real array of dimension (2,3).
!          The coordinates of the vertices of the parallellogram.
!   NUMFUN Integer.
!          Number of components of the vector integrand.
!   INFOLD Integer array
!   Integrand Externally declared subroutine for computing
!            all components of the integrand at the given
!            evaluation point.
!            It must have parameters (DIM,X,NUMFUN,FUNVLS)
!            Input parameters:
!              DIM = 2
!              X(1)      The x-coordinate of the evaluation point.
!              X(2)      The y-coordinate of the evaluation point.
!              NUMFUN Integer that defines the number of
!                     components of I.
!            Output parameter:
!              FUNVLS Real array of dimension NUMFUN
!                     that defines NUMFUN components of the integrand.
!
!   ON RETURN
!
!   BASVAL Real array of dimension NUMFUN.
!          The values for the basic rule for each component
!          of the integrand.
!   RGNERR Real array of dimension NUMFUN.
!          The error estimates for each component of the integrand.
!   NUM    Integer
!          The number of function evaluations used.
!   INFOLD Integer array
!
!***ROUTINES CALLED Integrand
!***END PROLOGUE Rule_C2a
!
!   Global variables.
!
      INTERFACE
         FUNCTION Integrand(NUMFUN,X) RESULT(Value)
            USE Precision_Model
            INTEGER, INTENT(IN) :: NUMFUN
            REAL(kind=stnd), DIMENSION(:), INTENT(IN) :: X
            REAL(kind=stnd), DIMENSION(NUMFUN) :: Value
         END FUNCTION Integrand
      END INTERFACE
      INTEGER, INTENT(IN) :: NUMFUN
      INTEGER, INTENT(OUT) :: NUM
      INTEGER, DIMENSION(:), INTENT(IN OUT) :: INFOLD
      REAL(kind=stnd), INTENT(IN) :: AREA
      REAL(kind=stnd), DIMENSION(:,:), INTENT(IN) :: VER
      REAL(kind=stnd), DIMENSION(:), INTENT(OUT) :: BASVAL, RGNERR
!
!   Parameters
!
      INTEGER, DIMENSION(0:3), PARAMETER :: &
              K = (/1,2,3,2/)                ! Rule structure parameters

      INTEGER, PARAMETER ::                 &
              ORBITS = 8                     ! Number of orbits in rule

      REAL(kind=stnd), PARAMETER ::         &
              HALF = 0.5_stnd,              &
              FOUR = 4.0_stnd,              &
              CRIVAL = 0.4_stnd,            &
              FACMED = 8.0_stnd,            &
              FACOPT = FACMED/CRIVAL**2,    &
              TRES = 50*EPSILON(HALF),      &
              CUTOFF = 1.0E-4_stnd ,        &
              DFCLEV  = 0.55_stnd

      REAL(kind=stnd), DIMENSION(0:2), PARAMETER ::     &
              DFC = (/2.97397430397053625382_stnd,      &
                      1.0_stnd,                         &
                     -2.48698715198526812691_stnd  /)
!
!  Cubature formula of degree 13 with 37 points (Rabinowitz & Richter)
!
!
!  Information for the generators
!
      INTEGER :: I
      REAL(kind=stnd), DIMENSION(1:2), PARAMETER ::                    &
              TYPE1 = (/ 0.9909890363004326469792722978603_stnd,  &
                         0.6283940712305315063814483471116_stnd  /)

      REAL(kind=stnd), DIMENSION(1:3), PARAMETER ::                    &
              TYPE2 = (/ 0.9194861553393073086142137772149_stnd,  &
                         0.6973201917871173078084506730937_stnd,  &
                         0.3805687186904854497424188074662_stnd  /)
      REAL(kind=stnd), DIMENSION(1:2,1:2), PARAMETER ::                &
              TYPE3 = RESHAPE( SOURCE=                            &
                       (/ 0.9708504361720225062147290554088_stnd, &
                          0.6390348393207252159077623446225_stnd, &
                          0.8623637916722781475018696425693_stnd, &
                          0.3162277660168700033875075593701_stnd /),&
                          SHAPE=(/2,2/) )

!       The weights of the basic rule and the null rules.
!       WEIGHT(1,1),...,WEIGHT(1,ORBITS) are weights for the basic rule.
!       WEIGHT(I,1),...,WEIGHT(I,ORBITS) for I>1 are null rule weights.
!
!
!  Weights of the cubature formula.
!
       REAL(kind=stnd), DIMENSION(ORBITS), PARAMETER ::           &
         W1 = (/                                                  &
          2.995235559387052215463143056692E-1_stnd ,              &
          3.311006686692356205977471655046E-2_stnd ,              &
          1.802214941550624038355347399683E-1_stnd ,              &
          3.916727896035153300761243260674E-2_stnd ,              &
          1.387748348777288706306435595057E-1_stnd ,              &
          2.268881207335707037147066705814E-1_stnd ,              &
          3.657395765508995601240002438981E-2_stnd ,              &
          1.169047000557533546701746277951E-1_stnd /)
!
!  Weights of the rules of degree 7, 7, 5 , 5 , 3 , 3  and 1.
!
       REAL(kind=stnd), DIMENSION(ORBITS), PARAMETER ::           &
         W2 = (/                                                  &
          7.610781847149629154716409791983E-2_stnd ,              &
          1.486101247399760261471935168346E-1_stnd ,              &
         -2.077685631717747007172983323970E-1_stnd ,              &
          6.850758313011924198538315395405E-2_stnd ,              &
          2.024205813317813585572881715385E-1_stnd ,              &
          1.108627473745508429879249169864E-1_stnd ,              &
         -1.187411393304862640859204217487E-1_stnd ,              &
         -5.208857468077715683772080394959E-2_stnd /)
!
       REAL(kind=stnd), DIMENSION(ORBITS), PARAMETER ::           &
         W3 = (/                                                  &
          4.016494861405949747097510013162E-2_stnd ,              &
         -1.093132962444079541048635452881E-1_stnd ,              &
         -2.270251673633777452624380129694E-1_stnd ,              &
          1.231674163356097016086203579325E-2_stnd ,              &
         -1.420402526499201540699111172200E-1_stnd ,              &
          1.189080551229557928776504129312E-1_stnd ,              &
         -4.482039658150474743804189300793E-3_stnd ,              &
          1.730383808319875827592824151609E-1_stnd /)
!
       REAL(kind=stnd), DIMENSION(ORBITS), PARAMETER ::           &
         W4 = (/                                                  &
         -5.643905795781771973971259866415E-1_stnd ,              &
          2.878418073676293225652331648545E-2_stnd ,              &
          1.159354231997583294689565314470E-1_stnd ,              &
          1.376081498690624477894043101438E-1_stnd ,              &
         -7.909780225340130915490382973570E-2_stnd ,              &
          1.174335441429478112778176601234E-1_stnd ,              &
         -1.107251942334134124782600707843E-1_stnd ,              &
          2.094226883312045633400182488252E-2_stnd /)
!
       REAL(kind=stnd), DIMENSION(ORBITS), PARAMETER ::           &
         W5 = (/                                                  &
         -2.269001713589584730602581694579E-1_stnd ,              &
          2.976190892690301120078774620049E-2_stnd ,              &
         -7.440193483272787588251423144751E-2_stnd ,              &
         -1.224665989043784131260454301280E-1_stnd ,              &
         -4.857910454732976198562745578156E-2_stnd ,              &
          2.228157325962656425537280474671E-1_stnd ,              &
          1.459764751457503859063666414952E-1_stnd ,              &
         -1.211789553452468781539987084682E-1_stnd /)
!
       REAL(kind=stnd), DIMENSION(ORBITS), PARAMETER ::           &
         W6 = (/                                                  &
         -3.326760468009974589269134283992E-1_stnd ,              &
          1.796655319904795478676993902115E-1_stnd ,              &
         -4.389976396805911868560791966472E-2_stnd ,              &
         -2.295841771339316497310760908889E-1_stnd ,              &
          6.182618387692816082856552878852E-2_stnd ,              &
         -1.202703885325137746461829140891E-1_stnd ,              &
          5.109536580363550180208564374234E-3_stnd ,              &
          1.126062761533095493689566169969E-1_stnd /)
!
       REAL(kind=stnd), DIMENSION(ORBITS), PARAMETER ::           &
         W7 = (/                                                  &
          2.290638530086106512999345512401E-1_stnd ,              &
          2.702070398116919449911037051753E-1_stnd ,              &
         -9.078047988731123605988441792069E-3_stnd ,              &
          4.618480310858703283999169489655E-2_stnd ,              &
         -2.598231009547631799096616255056E-1_stnd ,              &
         -2.518433931146441037986247681820E-2_stnd ,              &
         -1.257796993152456033984707367389E-2_stnd ,              &
         -2.720818902721190304043617320910E-2_stnd /)
!
       REAL(kind=stnd), DIMENSION(ORBITS), PARAMETER ::           &
         W8 = (/                                                  &
          2.746908885094872977794932213372E-1_stnd ,              &
         -1.149427039769738298032807785523E-2_stnd ,              &
          1.596178537820019535731955591283E-1_stnd ,              &
         -2.180626972663360443142752377527E-1_stnd ,              &
         -8.711748038292630173597899697063E-3_stnd ,              &
          1.902786182960269617633915869710E-1_stnd ,              &
         -1.189840649092108827784089292890E-1_stnd ,              &
          2.883382565767354162177931122471E-2_stnd /)

      REAL(kind=stnd), DIMENSION(1:8,1:ORBITS), PARAMETER ::      &
          WEIGHT = RESHAPE( SOURCE= (/ W1,W2,W3,W4,W5,W6,W7,W8 /),&
              SHAPE=(/8,ORBITS/), ORDER=(/2,1/) )
!
!   Local variables.
!
      INTEGER :: J,NUMBER,GENTYPE,NR,P
      REAL(kind=stnd):: R1,R2,R3,R,NOISE,DEG7,DEG5,DEG3,DEG1,   &
                        DIFFX,DIFFY,Z1,Z2
      REAL(kind=stnd), DIMENSION(2,8) :: X
      REAL(kind=stnd), DIMENSION(NUMFUN,7) :: NullRule
      REAL(kind=stnd), DIMENSION(NUMFUN) :: SUMVAL
!
!***FIRST EXECUTABLE STATEMENT Rule_C2a
!
!  The number of points used by the cubature formula is
!     NUM    = K(0) + 4*K(1) + 4*K(2) + 8*K(3)
      NUM = 37
!
!
!  Initialise BASVAL and NullRule
!
      BASVAL = 0
      NullRule = 0
      P = 1
!
!  Compute contributions from orbits with 1, 4 and 8 points
!
      DO GENTYPE = 0,3
          DO NR = 1,K(GENTYPE)
              SELECT CASE (GENTYPE)
              CASE (0) !                 Generator ( 0 , 0 )
                  NUMBER = 1
                  X(:,1) = (VER(:,2)+VER(:,3))*HALF

              CASE (1) !                 Generator ( z1 , 0 )
                  Z1 = TYPE1(NR)
                  NUMBER = 4
                  Z1 = Z1*HALF
                  X(:,1) = -VER(:,1)*Z1 + VER(:,2)*HALF +       &
                               VER(:,3)* (Z1+HALF)
                  X(:,2) = VER(:,1)*Z1 + VER(:,2)*HALF +        &
                               VER(:,3)* (-Z1+HALF)
                  X(:,3) = VER(:,1)*Z1 + VER(:,2)* (-Z1+HALF) + &
                               VER(:,3)*HALF
                  X(:,4) = -VER(:,1)*Z1 + VER(:,2)* (Z1+HALF) + &

                               VER(:,3)*HALF
              CASE (2) !                 Generator ( z(1) , z(1) )
                  Z1 = TYPE2(NR)
                  NUMBER = 4
                  Z1 = Z1*HALF
                  X(:,1) = -2*VER(:,1)*Z1 + VER(:,2)* (HALF+Z1) +&
                               VER(:,3)* (Z1+HALF)
                  X(:,2) = VER(:,2)* (HALF+Z1) +  VER(:,3)* (-Z1+HALF)
                  X(:,3) = VER(:,2)* (HALF-Z1) + VER(:,3)* (Z1+HALF)
                  X(:,4) = 2*VER(:,1)*Z1 + VER(:,2)* (HALF-Z1) + &
                               VER(:,3)* (-Z1+HALF)

              CASE (3) !                 Generator ( z(1) , z(2) )
                  Z1 = TYPE3(1,NR)*HALF
                  Z2 = TYPE3(2,NR)*HALF
                  NUMBER = 8
                  X(:,1) = VER(:,1)* (-Z1-Z2) +                     &
                               VER(:,2)* (HALF+Z2) + VER(:,3)* (HALF+Z1)
                  X(:,2) = VER(:,1)* (+Z1-Z2) +                     &
                               VER(:,2)* (HALF+Z2) + VER(:,3)* (HALF-Z1)
                  X(:,3) = VER(:,1)* (-Z1+Z2) +                     &
                               VER(:,2)* (HALF-Z2) + VER(:,3)* (HALF+Z1)
                  X(:,4) = VER(:,1)* (+Z1+Z2) +                     &
                               VER(:,2)* (HALF-Z2) + VER(:,3)* (HALF-Z1)
                  X(:,5) = VER(:,1)* (-Z1-Z2) +                     &
                               VER(:,2)* (HALF+Z1) + VER(:,3)* (HALF+Z2)
                  X(:,6) = VER(:,1)* (+Z2-Z1) +                     &
                               VER(:,2)* (HALF+Z1) + VER(:,3)* (HALF-Z2)
                  X(:,7) = VER(:,1)* (-Z2+Z1) +                     &
                               VER(:,2)* (HALF-Z1) + VER(:,3)* (HALF+Z2)
                  X(:,8) = VER(:,1)* (+Z1+Z2) +                     &
                               VER(:,2)* (HALF-Z1) + VER(:,3)* (HALF-Z2)
              END SELECT
!             CALL Integrand(2,X(1,1),NUMFUN,SUMVAL)
              SUMVAL = Integrand(NUMFUN,X(:,1))
              SELECT CASE (GENTYPE)
              CASE (0)
                  DIFFy = SUMVAL(1)*DFC(0)
                  DIFFx = DIFFy
              CASE (1)
                  DIFFy = DIFFy + SUMVAL(1)*DFC(NR)
              END SELECT

              DO J = 2,NUMBER
                  RGNERR = Integrand(NUMFUN,X(:,J))
!                 CALL Integrand(2,X(1,J),NUMFUN,RGNERR)
                  IF (GENTYPE == 1) THEN
                      IF (J <= 2) THEN
                          DIFFy = DIFFy + RGNERR(1)*DFC(NR)
                      ELSE
                          DIFFx = DIFFx + RGNERR(1)*DFC(NR)
                      END IF
                  END IF
                  DO I = 1,NUMFUN
                      SUMVAL(I) = SUMVAL(I) + RGNERR(I)
                  END DO
              END DO
              DO J = 1,NUMFUN
                  BASVAL(J) = BASVAL(J) + WEIGHT(1,P)*SUMVAL(J)
                  DO I = 1,7
                      NullRule(J,I) = NullRule(J,I) + WEIGHT(I+1,P)*SUMVAL(J)
                  END DO
              END DO
              P = P + 1
          END DO
      END DO
!
!  Decide on future subdivision direction
!
      DIFFy = ABS(DIFFy)
      DIFFx = ABS(DIFFx)
      IF (MAX(DIFFy,DIFFx) < CUTOFF) THEN
          INFOLD(4) = 0
      ELSE IF (DIFFy < DFCLEV*DIFFx) THEN
          INFOLD(4) = 1
      ELSE IF (DIFFx < DFCLEV*DIFFy) THEN
          INFOLD(4) = 2
      ELSE
          INFOLD(4) = 0
      END IF
!
!    Compute errors.
!
      DO J = 1,NUMFUN
          NOISE = ABS(BASVAL(J))*TRES
          DEG7 = SQRT(NullRule(J,1)**2+NullRule(J,2)**2)
          IF (DEG7 <= NOISE) THEN
              RGNERR(J) = NOISE
          ELSE
              DEG5 = SQRT(NullRule(J,3)**2+NullRule(J,4)**2)
              DEG3 = SQRT(NullRule(J,5)**2+NullRule(J,6)**2)
              DEG1 = SQRT(NullRule(J,7)**2+NullRule(J,6)**2)
              IF (DEG5 /= 0) THEN
                  R1 = DEG7/DEG5
              ELSE
                  R1 = 1
              END IF
              IF (DEG3 /= 0) THEN
                  R2 = DEG5/DEG3
              ELSE
                  R2 = 1
              END IF
              IF (DEG1 /= 0) THEN
                  R3 = DEG3/DEG1
              ELSE
                  R3 = 1
              END IF
              R = MAX(R1,R2,R3)
              IF (R >= 1) THEN
                  INFOLD(5) = 0
                  RGNERR(J) = FACMED*DEG7
              ELSE IF (R >= CRIVAL) THEN
                  INFOLD(5) = 0
                  RGNERR(J) = FACMED*DEG7*R
              ELSE
                  INFOLD(5) = 1
                  RGNERR(J) = FACOPT* (R**3)*DEG7
              END IF
              RGNERR(J) = MAX(NOISE,RGNERR(J))
          END IF
          RGNERR(J) = AREA*RGNERR(J)/FOUR
          BASVAL(J) = AREA*BASVAL(J)/FOUR
      END DO
      RETURN
      END SUBROUTINE Rule_C2a

END Module CubatureRule_C2


module ppm_module

  implicit none

  private

  public ppm

contains

      ! characteristics based on u
      subroutine ppm(s,s_l1,s_l2,s_h1,s_h2, &
                     u,cspd,qd_l1,qd_l2,qd_h1,qd_h2, &
                     flatn, &
                     Ip,Im, &
                     ilo1,ilo2,ihi1,ihi2,dx,dy,dt)

        use meth_params_module, only : ppm_type
        use bl_constants_module

        implicit none

        integer          s_l1,s_l2,s_h1,s_h2
        integer          qd_l1,qd_l2,qd_h1,qd_h2
        integer          ilo1,ilo2,ihi1,ihi2
        double precision s(s_l1:s_h1,s_l2:s_h2)
        double precision     u(qd_l1:qd_h1,qd_l2:qd_h2,1:2)
        double precision  cspd(qd_l1:qd_h1,qd_l2:qd_h2)
        double precision flatn(s_l1:s_h1,s_l2:s_h2)
        double precision Ip(ilo1-1:ihi1+1,ilo2-1:ihi2+1,1:2,1:3)
        double precision Im(ilo1-1:ihi1+1,ilo2-1:ihi2+1,1:2,1:3)
        double precision dx,dy,dt

        ! local
        integer i,j

        logical extremum, bigp, bigm

        double precision dsl, dsr, dsc, D2, D2C, D2L, D2R, D2LIM, C, alphap, alpham
        double precision sgn, sigma, s6, amax, delam, delap
        double precision dafacem, dafacep, dabarm, dabarp, dafacemin, dabarmin
        double precision dachkm, dachkp

        ! s_{\ib,+}, s_{\ib,-}
        double precision, allocatable :: sp(:,:)
        double precision, allocatable :: sm(:,:)

        ! \delta s_{\ib}^{vL}
        double precision, allocatable :: dsvl(:,:)

        ! s_{i+\half}^{H.O.}
        double precision, allocatable :: sedge(:,:)

        ! cell-centered indexing
        allocate(sp(ilo1-1:ihi1+1,ilo2-1:ihi2+1))
        allocate(sm(ilo1-1:ihi1+1,ilo2-1:ihi2+1))

        ! constant used in Colella 2008
        C = 1.25d0

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        ! x-direction
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

        ! cell-centered indexing w/extra x-ghost cell
        allocate(dsvl(ilo1-2:ihi1+2,ilo2-1:ihi2+1))

        ! edge-centered indexing for x-faces
        if (ppm_type .eq. 1) then
           allocate(sedge(ilo1-1:ihi1+2,ilo2-1:ihi2+1))
        else
           allocate(sedge(ilo1-2:ihi1+3,ilo2-1:ihi2+1))
        end if

        ! compute s at x-edges
        if (ppm_type .eq. 1) then

           ! compute van Leer slopes in x-direction (CW Eq. 1.7, 1.8
           ! w/ zone widths (dxi) all equal)
           dsvl = ZERO
           do j=ilo2-1,ihi2+1
              do i=ilo1-2,ihi1+2
                 dsc = HALF * (s(i+1,j) - s(i-1,j))
                 dsl = TWO  * (s(i  ,j) - s(i-1,j))
                 dsr = TWO  * (s(i+1,j) - s(i  ,j))
                 if (dsl*dsr .gt. ZERO) &
                      dsvl(i,j) = sign(ONE,dsc)*min(abs(dsc),abs(dsl),abs(dsr))
              end do
           end do

           ! interpolate s to x-edges (CW 1.6)
           do j=ilo2-1,ihi2+1
              do i=ilo1-1,ihi1+2
                 sedge(i,j) = HALF*(s(i,j)+s(i-1,j)) - SIXTH*(dsvl(i,j)-dsvl(i-1,j))
                 ! make sure sedge lies in between adjacent
                 ! cell-centered values -- this is not part of the
                 ! original CW algorithm, but Colella & Sekora say it
                 ! is automatically imposed by the van Leer limiting
                 ! above
                 sedge(i,j) = max(sedge(i,j),min(s(i,j),s(i-1,j)))
                 sedge(i,j) = min(sedge(i,j),max(s(i,j),s(i-1,j)))
              end do
           end do

           ! copy sedge into sp and sm
           do j=ilo2-1,ihi2+1
              do i=ilo1-1,ihi1+1
                 sp(i,j) = sedge(i+1,j)
                 sm(i,j) = sedge(i  ,j)
              end do
           end do

           ! flatten the parabola BEFORE doing the other
           ! monotonization -- this is the method that Flash does
           do j=ilo2-1,ihi2+1
              do i=ilo1-1,ihi1+1
                 sm(i,j) = flatn(i,j)*sm(i,j) + (ONE-flatn(i,j))*s(i,j)
                 sp(i,j) = flatn(i,j)*sp(i,j) + (ONE-flatn(i,j))*s(i,j)
              enddo
           enddo

           ! modify using quadratic limiters (CW 1.10) -- with a
           ! slightly different form from Colella & Sekora (Eqs. 14,
           ! 15)
           do j=ilo2-1,ihi2+1
              do i=ilo1-1,ihi1+1
                 if ((sp(i,j)-s(i,j))*(s(i,j)-sm(i,j)) .le. ZERO) then
                    sp(i,j) = s(i,j)
                    sm(i,j) = s(i,j)
                 else if (abs(sp(i,j)-s(i,j)) .ge. TWO*abs(sm(i,j)-s(i,j))) then
                    sp(i,j) = THREE*s(i,j) - TWO*sm(i,j)
                 else if (abs(sm(i,j)-s(i,j)) .ge. TWO*abs(sp(i,j)-s(i,j))) then
                    sm(i,j) = THREE*s(i,j) - TWO*sp(i,j)
                 end if
              end do
           end do

        else if (ppm_type .eq. 2) then

           ! interpolate s to x-edges
           do j=ilo2-1,ihi2+1
              do i=ilo1-2,ihi1+3
                 sedge(i,j) = SEVEN12TH*(s(i-1,j)+s(i,j)) - TWELFTH*(s(i-2,j)+s(i+1,j))
                 ! limit sedge
                 if ((sedge(i,j)-s(i-1,j))*(s(i,j)-sedge(i,j)) .lt. ZERO) then
                    D2  = THREE*(s(i-1,j)-TWO*sedge(i,j)+s(i,j))
                    D2L = s(i-2,j)-TWO*s(i-1,j)+s(i,j)
                    D2R = s(i-1,j)-TWO*s(i,j)+s(i+1,j)
                    sgn = sign(ONE,D2)
                    D2LIM = sgn*max(min(C*sgn*D2L,C*sgn*D2R,sgn*D2),ZERO)
                    sedge(i,j) = HALF*(s(i-1,j)+s(i,j)) - SIXTH*D2LIM
                 end if
              end do
           end do

           ! use Colella 2008 limiters
           ! This is a new version of the algorithm
           ! to eliminate sensitivity to roundoff.
           do j=ilo2-1,ihi2+1
              do i=ilo1-1,ihi1+1

                 alphap = sedge(i+1,j)-s(i,j)
                 alpham = sedge(i  ,j)-s(i,j)
                 bigp = abs(alphap).gt.TWO*abs(alpham)
                 bigm = abs(alpham).gt.TWO*abs(alphap)
                 extremum = .false.

                 if (alpham*alphap .ge. ZERO) then
                    extremum = .true.
                 else if (bigp .or. bigm) then
                    ! Possible extremum. We look at cell centered values and face
                    ! centered values for a change in sign in the differences adjacent to
                    ! the cell. We use the pair of differences whose minimum magnitude is the
                    ! largest, and thus least susceptible to sensitivity to roundoff.
                    dafacem = sedge(i,j) - sedge(i-1,j)
                    dafacep = sedge(i+2,j) - sedge(i+1,j)
                    dabarm = s(i,j) - s(i-1,j)
                    dabarp = s(i+1,j) - s(i,j)
                    dafacemin = min(abs(dafacem),abs(dafacep))
                    dabarmin= min(abs(dabarm),abs(dabarp))
                    if (dafacemin.ge.dabarmin) then
                       dachkm = dafacem
                       dachkp = dafacep
                    else
                       dachkm = dabarm
                       dachkp = dabarp
                    endif
                    extremum = (dachkm*dachkp .le. ZERO)
                 end if

                 if (extremum) then
                    D2  = SIX*(alpham + alphap)
                    D2L = s(i-2,j)-TWO*s(i-1,j)+s(i,j)
                    D2R = s(i,j)-TWO*s(i+1,j)+s(i+2,j)
                    D2C = s(i-1,j)-TWO*s(i,j)+s(i+1,j)
                    sgn = sign(ONE,D2)
                    D2LIM = max(min(sgn*D2,C*sgn*D2L,C*sgn*D2R,C*sgn*D2C),ZERO)
                    alpham = alpham*D2LIM/max(abs(D2),1.d-10)
                    alphap = alphap*D2LIM/max(abs(D2),1.d-10)
                 else
                    if (bigp) then
                       sgn = sign(ONE,alpham)
                       amax = -alphap**2 / (4*(alpham + alphap))
                       delam = s(i-1,j) - s(i,j)
                       if (sgn*amax .ge. sgn*delam) then
                          if (sgn*(delam - alpham).ge.1.d-10) then
                             alphap = (-TWO*delam - TWO*sgn*sqrt(delam**2 - delam*alpham))
                          else
                             alphap = -TWO*alpham
                          endif
                       endif
                    end if
                    if (bigm) then
                       sgn = sign(ONE,alphap)
                       amax = -alpham**2 / (4*(alpham + alphap))
                       delap = s(i+1,j) - s(i,j)
                       if (sgn*amax .ge. sgn*delap) then
                          if (sgn*(delap - alphap).ge.1.d-10) then
                             alpham = (-TWO*delap - TWO*sgn*sqrt(delap**2 - delap*alphap))
                          else
                             alpham = -TWO*alphap
                          endif
                       endif
                    end if
                 end if

                 sm(i,j) = s(i,j) + alpham
                 sp(i,j) = s(i,j) + alphap

              end do
           end do

           ! flatten the parabola AFTER doing the monotonization --
           ! (ppm_type = 2 is here)
           do j=ilo2-1,ihi2+1
              do i=ilo1-1,ihi1+1
                 sm(i,j) = flatn(i,j)*sm(i,j) + (ONE-flatn(i,j))*s(i,j)
                 sp(i,j) = flatn(i,j)*sp(i,j) + (ONE-flatn(i,j))*s(i,j)
              enddo
           enddo

        end if

       ! compute x-component of Ip and Im
        do j=ilo2-1,ihi2+1
           do i=ilo1-1,ihi1+1
              ! Ip/m is the integral under the parabola for the extent
              ! that a wave can travel over a timestep
              !
              ! Ip integrates to the right edge of a cell
              ! Im integrates to the left edge of a cell

              s6 = SIX*s(i,j) - THREE*(sm(i,j)+sp(i,j))

              ! u-c wave
              sigma = abs(u(i,j,1)-cspd(i,j))*dt/dx

              if (u(i,j,1)-cspd(i,j) <= ZERO) then
                 Ip(i,j,1,1) = sp(i,j)
              else
                 Ip(i,j,1,1) = sp(i,j) - &
                      HALF*sigma*(sp(i,j)-sm(i,j)-(ONE-TWO3RD*sigma)*s6)
              endif

              if (u(i,j,1)-cspd(i,j) >= ZERO) then
                 Im(i,j,1,1) = sm(i,j)
              else
                 Im(i,j,1,1) = sm(i,j) + &
                      HALF*sigma*(sp(i,j)-sm(i,j)+(ONE-TWO3RD*sigma)*s6)
              endif

              ! u wave
              sigma = abs(u(i,j,1))*dt/dx

              if (u(i,j,1) <= ZERO) then
                 Ip(i,j,1,2) = sp(i,j)
              else
                 Ip(i,j,1,2) = sp(i,j) - &
                      HALF*sigma*(sp(i,j)-sm(i,j)-(ONE-TWO3RD*sigma)*s6)
              endif

              if (u(i,j,1) >= ZERO) then
                 Im(i,j,1,2) = sm(i,j)
              else
                 Im(i,j,1,2) = sm(i,j) + &
                      HALF*sigma*(sp(i,j)-sm(i,j)+(ONE-TWO3RD*sigma)*s6)
              endif

              ! u + c wave
              sigma = abs(u(i,j,1)+cspd(i,j))*dt/dx

              if (u(i,j,1) + cspd(i,j) <= ZERO) then
                 Ip(i,j,1,3) = sp(i,j)
              else
                 Ip(i,j,1,3) = sp(i,j) - &
                      HALF*sigma*(sp(i,j)-sm(i,j)-(ONE-TWO3RD*sigma)*s6)
              endif

              if (u(i,j,1) + cspd(i,j) >= ZERO) then
                 Im(i,j,1,3) = sm(i,j)
              else
                 Im(i,j,1,3) = sm(i,j) + &
                      HALF*sigma*(sp(i,j)-sm(i,j)+(ONE-TWO3RD*sigma)*s6)
              endif
           end do
        end do

        deallocate(sedge,dsvl)

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        ! y-direction
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

        ! cell-centered indexing w/extra y-ghost cell
        allocate( dsvl(ilo1-1:ihi1+1,ilo2-2:ihi2+2))

        ! edge-centered indexing for y-faces
        if (ppm_type .eq. 1) then
           allocate(sedge(ilo1-1:ihi1+1,ilo2-1:ihi2+2))
        else
           allocate(sedge(ilo1-1:ihi1+1,ilo2-2:ihi2+3))
        end if

        ! compute s at y-edges
        if (ppm_type .eq. 1) then

           ! compute van Leer slopes in y-direction
           dsvl = ZERO
           do j=ilo2-2,ihi2+2
              do i=ilo1-1,ihi1+1
                 dsc = HALF * (s(i,j+1) - s(i,j-1))
                 dsl = TWO  * (s(i,j  ) - s(i,j-1))
                 dsr = TWO  * (s(i,j+1) - s(i,j  ))
                 if (dsl*dsr .gt. ZERO) &
                      dsvl(i,j) = sign(ONE,dsc)*min(abs(dsc),abs(dsl),abs(dsr))
              end do
           end do

           ! interpolate s to y-edges
           do j=ilo2-1,ihi2+2
              do i=ilo1-1,ihi1+1
                 sedge(i,j) = HALF*(s(i,j)+s(i,j-1)) - SIXTH*(dsvl(i,j)-dsvl(i,j-1))
                 ! make sure sedge lies in between adjacent cell-centered values
                 sedge(i,j) = max(sedge(i,j),min(s(i,j),s(i,j-1)))
                 sedge(i,j) = min(sedge(i,j),max(s(i,j),s(i,j-1)))
              end do
           end do

           ! copy sedge into sp and sm
           do j=ilo2-1,ihi2+1
              do i=ilo1-1,ihi1+1
                 sp(i,j) = sedge(i,j+1)
                 sm(i,j) = sedge(i,j  )
              end do
           end do

           ! flatten the parabola BEFORE doing the other
           ! monotonization -- this is the method that Flash does
           do j=ilo2-1,ihi2+1
              do i=ilo1-1,ihi1+1
                 sm(i,j) = flatn(i,j)*sm(i,j) + (ONE-flatn(i,j))*s(i,j)
                 sp(i,j) = flatn(i,j)*sp(i,j) + (ONE-flatn(i,j))*s(i,j)
              enddo
           enddo

           ! modify using quadratic limiters
           do j=ilo2-1,ihi2+1
              do i=ilo1-1,ihi1+1
                 if ((sp(i,j)-s(i,j))*(s(i,j)-sm(i,j)) .le. ZERO) then
                    sp(i,j) = s(i,j)
                    sm(i,j) = s(i,j)
                 else if (abs(sp(i,j)-s(i,j)) .ge. TWO*abs(sm(i,j)-s(i,j))) then
                    sp(i,j) = THREE*s(i,j) - TWO*sm(i,j)
                 else if (abs(sm(i,j)-s(i,j)) .ge. TWO*abs(sp(i,j)-s(i,j))) then
                    sm(i,j) = THREE*s(i,j) - TWO*sp(i,j)
                 end if
              end do
           end do

        else if (ppm_type .eq. 2) then

           ! interpolate s to y-edges
           do j=ilo2-2,ihi2+3
              do i=ilo1-1,ihi1+1
                 sedge(i,j) = SEVEN12TH*(s(i,j-1)+s(i,j)) - TWELFTH*(s(i,j-2)+s(i,j+1))
                 ! limit sedge
                 if ((sedge(i,j)-s(i,j-1))*(s(i,j)-sedge(i,j)) .lt. ZERO) then
                    D2  = THREE*(s(i,j-1)-TWO*sedge(i,j)+s(i,j))
                    D2L = s(i,j-2)-TWO*s(i,j-1)+s(i,j)
                    D2R = s(i,j-1)-TWO*s(i,j)+s(i,j+1)
                    sgn = sign(ONE,D2)
                    D2LIM = sgn*max(min(C*sgn*D2L,C*sgn*D2R,sgn*D2),ZERO)
                    sedge(i,j) = HALF*(s(i,j-1)+s(i,j)) - SIXTH*D2LIM
                 end if
              end do
           end do

           ! use Colella 2008 limiters
           ! This is a new version of the algorithm
           ! to eliminate sensitivity to roundoff.
           do j=ilo2-1,ihi2+1
              do i=ilo1-1,ihi1+1

                 alphap = sedge(i,j+1)-s(i,j)
                 alpham = sedge(i,j  )-s(i,j)
                 bigp = abs(alphap).gt.TWO*abs(alpham)
                 bigm = abs(alpham).gt.TWO*abs(alphap)
                 extremum = .false.

                 if (alpham*alphap .ge. ZERO) then
                    extremum = .true.
                 else if (bigp .or. bigm) then
                    ! Possible extremum. We look at cell centered values and face
                    ! centered values for a change in sign in the differences adjacent to
                    ! the cell. We use the pair of differences whose minimum magnitude is the
                    ! largest, and thus least susceptible to sensitivity to roundoff.
                    dafacem = sedge(i,j) - sedge(i,j-1)
                    dafacep = sedge(i,j+2) - sedge(i,j+1)
                    dabarm = s(i,j) - s(i,j-1)
                    dabarp = s(i,j+1) - s(i,j)
                    dafacemin = min(abs(dafacem),abs(dafacep))
                    dabarmin= min(abs(dabarm),abs(dabarp))
                    if (dafacemin.ge.dabarmin) then
                       dachkm = dafacem
                       dachkp = dafacep
                    else
                       dachkm = dabarm
                       dachkp = dabarp
                    endif
                    extremum = (dachkm*dachkp .le. ZERO)
                 end if

                 if (extremum) then
                    D2  = SIX*(alpham + alphap)
                    D2L = s(i,j-2)-TWO*s(i,j-1)+s(i,j)
                    D2R = s(i,j)-TWO*s(i,j+1)+s(i,j+2)
                    D2C = s(i,j-1)-TWO*s(i,j)+s(i,j+1)
                    sgn = sign(ONE,D2)
                    D2LIM = max(min(sgn*D2,C*sgn*D2L,C*sgn*D2R,C*sgn*D2C),ZERO)
                    alpham = alpham*D2LIM/max(abs(D2),1.d-10)
                    alphap = alphap*D2LIM/max(abs(D2),1.d-10)
                 else
                    if (bigp) then
                       sgn = sign(ONE,alpham)
                       amax = -alphap**2 / (4*(alpham + alphap))
                       delam = s(i,j-1) - s(i,j)
                       if (sgn*amax .ge. sgn*delam) then
                          if (sgn*(delam - alpham).ge.1.d-10) then
                             alphap = (-TWO*delam - TWO*sgn*sqrt(delam**2 - delam*alpham))
                          else
                             alphap = -TWO*alpham
                          endif
                       endif
                    end if
                    if (bigm) then
                       sgn = sign(ONE,alphap)
                       amax = -alpham**2 / (4*(alpham + alphap))
                       delap = s(i,j+1) - s(i,j)
                       if (sgn*amax .ge. sgn*delap) then
                          if (sgn*(delap - alphap).ge.1.d-10) then
                             alpham = (-TWO*delap - TWO*sgn*sqrt(delap**2 - delap*alphap))
                          else
                             alpham = -TWO*alphap
                          endif
                       endif
                    end if
                 end if

                 sm(i,j) = s(i,j) + alpham
                 sp(i,j) = s(i,j) + alphap

              end do
           end do

           ! flatten the parabola AFTER doing the monotonization --
           ! (ppm_type = 2 is here)
           do j=ilo2-1,ihi2+1
              do i=ilo1-1,ihi1+1
                 sm(i,j) = flatn(i,j)*sm(i,j) + (ONE-flatn(i,j))*s(i,j)
                 sp(i,j) = flatn(i,j)*sp(i,j) + (ONE-flatn(i,j))*s(i,j)
              enddo
           enddo

        end if

        ! compute y-component of Ip and Im
        do j=ilo2-1,ihi2+1
           do i=ilo1-1,ihi1+1

              s6 = SIX*s(i,j) - THREE*(sm(i,j)+sp(i,j))

              ! v-c wave
              sigma = abs(u(i,j,2)-cspd(i,j))*dt/dy

              if (u(i,j,2)-cspd(i,j) <= ZERO) then
                 Ip(i,j,2,1) = sp(i,j)
              else
                 Ip(i,j,2,1) = sp(i,j) - &
                   HALF*sigma*(sp(i,j)-sm(i,j)-(ONE-TWO3RD*sigma)*s6)
              endif

              if (u(i,j,2)-cspd(i,j) >= ZERO) then
                 Im(i,j,2,1) = sm(i,j)
              else
                 Im(i,j,2,1) = sm(i,j) + &
                   HALF*sigma*(sp(i,j)-sm(i,j)+(ONE-TWO3RD*sigma)*s6)
              endif

              ! v wave
              sigma = abs(u(i,j,2))*dt/dy

              if (u(i,j,2) <= ZERO) then
                 Ip(i,j,2,2) = sp(i,j)
              else
                 Ip(i,j,2,2) = sp(i,j) - &
                   HALF*sigma*(sp(i,j)-sm(i,j)-(ONE-TWO3RD*sigma)*s6)
              endif

              if (u(i,j,2) >= ZERO) then
                 Im(i,j,2,2) = sm(i,j)
              else
                 Im(i,j,2,2) = sm(i,j) + &
                   HALF*sigma*(sp(i,j)-sm(i,j)+(ONE-TWO3RD*sigma)*s6)
              endif

              ! v+c wave
              sigma = abs(u(i,j,2)+cspd(i,j))*dt/dy

              if (u(i,j,2)+cspd(i,j) <= ZERO) then
                 Ip(i,j,2,3) = sp(i,j)
              else
                 Ip(i,j,2,3) = sp(i,j) - &
                   HALF*sigma*(sp(i,j)-sm(i,j)-(ONE-TWO3RD*sigma)*s6)
              endif

              if (u(i,j,2)+cspd(i,j) >= ZERO) then
                 Im(i,j,2,3) = sm(i,j)
              else
                 Im(i,j,2,3) = sm(i,j) + &
                   HALF*sigma*(sp(i,j)-sm(i,j)+(ONE-TWO3RD*sigma)*s6)
              endif

           end do
        end do

        deallocate(sp,sm,dsvl,sedge)

      end subroutine ppm

end module ppm_module


program prodrv
    use param
    use prolate_swf

    implicit none

    integer   i, im, j, mmin, minc, mnum, m, l, lnum, ioprad, iopang, &
              iopnorm, ioparg, narg, kind, kindd, kindq
    real(knd) c, x1, arg1, darg, api
    character chr

    real(knd), dimension(:), allocatable ::    arg, r1c, r1dc, r2c, r2dc
    integer, dimension(:), allocatable ::      ir1e, ir1de, ir2e, ir2de, naccr
    real(knd), dimension (:,:), allocatable :: s1c, s1dc
    integer, dimension(:,:), allocatable ::    is1e, is1de, naccs

    kindd =  8
    kindq = 16

!   open input and output files
    open(1, file='profcn.dat')
    open(20 ,file='fort.20')
    open(30, file='fort.30')
    open(40 ,file='fort.20')
    open(50, file='fort.30')
    open(60, file='fort.30')

!
!   read input data
    read(1,*) mmin, minc, mnum, lnum
    read(1,*) ioprad, iopang, iopnorm
    read(1,*) c, x1
    if(iopang /= 0) read(1,*) ioparg, arg1, darg, narg

    api = acos(-1.0e0_knd) / 180.0e0_knd

    allocate (arg(narg), r1c(lnum), r1dc(lnum), r2c(lnum), r2dc(lnum))
    allocate (ir1e(lnum), ir1de(lnum), ir2e(lnum), ir2de(lnum), naccr(lnum))
    allocate (s1c(lnum, narg), s1dc(lnum, narg))
    allocate (is1e(lnum, narg), is1de(lnum, narg), naccs(lnum, narg))

    if (iopang /= 0) then
        do j = 1, narg
            arg(j) = arg1 + (j - 1) * darg
            if(ioparg == 0) arg(j) = cos(api * arg(j))
        end do
    end if

    do im = 1, mnum
        m = mmin + (im - 1) * minc

        call profcn(c, m, lnum, ioprad, x1, iopang, iopnorm, narg, arg, &
                    r1c, ir1e, r1dc, ir1de, r2c, ir2e, r2dc, ir2de, naccr, &
                    s1c, is1e, s1dc, is1de, naccs)

        if (ioprad /= 0) then

            if(knd == kindd) write(20, 10) x1 + 1.00e0_knd, c, m
            if(knd == kindq) write(20, 20) x1 + 1.00e0_knd, c, m
10          format(1x,e23.14,e23.14,i5)
20          format(1x,e39.30,e39.30,i5)

            do i = 1, lnum
                l = m + i - 1
                chr = 'w'
                if (naccr(i) < 0) chr = 'e'
                if(ioprad == 2) write(20,690) l, r1c(i), ir1e(i), r1dc(i), ir1de(i), r2c(i), ir2e(i), r2dc(i), ir2de(i), abs(naccr(i)), chr
                if(ioprad == 1) write(20,710) l, r1c(i), ir1e(i), r1dc(i), ir1de(i)
690             format(1x,i6,2x,4(f17.14,1x,i6,2x),i2,a)
710             format(1x,i6,2x,2(f17.14,1x,i6,2x))
            end do

        end if

        if (iopang /= 0) then

            if(knd == kindd) write(30, 30) c, m
            if(knd == kindq) write(30, 40) c, m
30          format(1x,e23.14,i5)
40          format(1x,e39.30,i5)

            do i = 1, lnum
                l = m + i - 1

                write(30, 50) l
50              format(1x,i6)

                do j = 1, narg

                    if(ioparg == 0) then
                        if(iopang == 1) write(30, 60) arg(j), s1c(i, j), is1e(i, j), naccs(i, j)
                        if(iopang == 2) write(30, 70) arg(j), s1c(i, j), is1e(i, j), s1dc(i, j), is1de(i, j), naccs(i, j)
                    end if
                    if(ioparg == 1) then
                        if(iopang == 1) write(30, 60) arg(j), s1c(i, j), is1e(i, j), naccs(i, j)
                        if(iopang == 2) write(30, 70) arg(j), s1c(i, j), is1e(i, j), s1dc(i, j), is1de(i, j), naccs(i, j)
                    end if
60                  format(1x,f19.14,2x,f17.14,2x,i5,2x,', ',i2)
70                  format(1x,f19.14,2x,f17.14,2x,i5,2x,f17.14,2x,i5,2x,i2)
                end do
            end do
        end if
    end do

    deallocate (is1e, is1de, naccs)
    deallocate (s1c, s1dc)
    deallocate (ir1e, ir1de, ir2e, ir2de, naccr)
    deallocate (arg, r1c, r1dc, r2c, r2dc)
    close(60)
    close(50)
    close(40)
    close(30)
    close(20)
    close(1)

end program prodrv


C NCLFORTSTART
      SUBROUTINE Z2GEOUV(Z,MLON,NLAT,ZMSG,GLON,GLAT,UG,VG,IOPT)
      IMPLICIT NONE

c NCL: uv = z2geouv(z,lat,lon,iopt)           ; uv(2,...,nlat,mlon)
c                                               INPUT
      INTEGER MLON,NLAT,IOPT
      DOUBLE PRECISION Z(MLON,NLAT),ZMSG,GLAT(NLAT),GLON(MLON)
c                                               OUTPUT
      DOUBLE PRECISION UG(MLON,NLAT),VG(MLON,NLAT)
C NCLEND

c Given geopotential height (gpm): calculate geostrophic wind components

c INPUT
c .   z     - geopotential height (south to north order)
c .   mlon  - number of longitudes
c .   nlat  - number of latitudes
c .   zmsg  - missing value code
c .   glat  - latitudes  of grid points
c .   glon  - longitudes of grid points
c .   iopt  - option: iopt=0 z is not cyclic in longitude
c .                   iopt=1 z is cyclic in longitude
c OUTPUT
c .   ug,vg - geostrophic wind components

      INTEGER NL,ML

      IF (GLAT(2).GT.GLAT(1)) THEN
c                                         south to north
          CALL Z2GUV(Z,MLON,NLAT,ZMSG,GLON,GLAT,UG,VG,IOPT)
      ELSE
c                                         north to south [reorder]
          CALL ZUVNEW(Z,MLON,NLAT,ZMSG,GLON,GLAT,UG,VG,IOPT)
      END IF

      RETURN
      END
C -------
      SUBROUTINE ZUVNEW(Z,MLON,NLAT,ZMSG,GLON,GLAT,UG,VG,IOPT)
      IMPLICIT NONE
c
c data array need to be rearranged to go fron south to north
c
c                                               INPUT
      INTEGER MLON,NLAT,IOPT
      DOUBLE PRECISION Z(MLON,NLAT),ZMSG,GLAT(NLAT),GLON(MLON)
c                                               OUTPUT
      DOUBLE PRECISION UG(MLON,NLAT),VG(MLON,NLAT)

c local temporary arrays.
      DOUBLE PRECISION ZTMP(MLON,NLAT),GLATTMP(NLAT),UTMP(NLAT),
     +                 VTMP(NLAT)
      INTEGER NL,ML,NLAT1

c reorder [ S ==> N ]
      NLAT1 = NLAT + 1
      DO NL = 1,NLAT
          GLATTMP(NLAT1-NL) = GLAT(NL)
          DO ML = 1,MLON
              ZTMP(ML,NLAT1-NL) = Z(ML,NL)
          END DO
      END DO

      CALL Z2GUV(ZTMP,MLON,NLAT,ZMSG,GLON,GLATTMP,UG,VG,IOPT)

c put in original order

      DO ML = 1,MLON
          DO NL = 1,NLAT
              UTMP(NLAT1-NL) = UG(ML,NL)
              VTMP(NLAT1-NL) = VG(ML,NL)
          END DO
          DO NL = 1,NLAT
              UG(ML,NL) = UTMP(NL)
              VG(ML,NL) = VTMP(NL)
          END DO
      END DO

      RETURN
      END
C -------
      SUBROUTINE Z2GUV(Z,MLON,NLAT,ZMSG,GLON,GLAT,UG,VG,IOPT)
      IMPLICIT NONE
c                                               INPUT
      INTEGER MLON,NLAT,IOPT
      DOUBLE PRECISION Z(MLON,NLAT),ZMSG,GLAT(NLAT),GLON(MLON)
c                                               OUTPUT
      DOUBLE PRECISION UG(MLON,NLAT),VG(MLON,NLAT)

c Given geopotential height (gpm): calculate geostrophic components

c INPUT
c .   z     - geopotential height (south to north order)
c .   mlon  - number of longitudes
c .   nlat  - number of latitudes
c .   zmsg  - missing value code
c .   glat  - latitudes  of grid points
c .   glon  - longitudes of grid points
c .   iopt  - option: iopt=0 z is not cyclic in longitude
c .                   iopt=1 z is cyclic in longitude
c OUTPUT
c .   ug,vg - geostrophic wind components

      INTEGER NL,ML
      DOUBLE PRECISION ZZ(0:MLON+1,0:NLAT+1)
      DOUBLE PRECISION GF(0:NLAT+1),DX(0:NLAT+1),DY(0:NLAT+1)
      DOUBLE PRECISION GR,RAD,RE,RR,OMEGA,DLON,DLON2

c  calculate `constant' quantities

      GR = 9.80616D0
      RAD = 4.D0*ATAN(1.0D0)/180.D0
      RE = 6371220.D0
      RR = RE*RAD
      DLON = RR* (GLON(2)-GLON(1))
      DLON2 = 2.D0*DLON
      OMEGA = 7.292D-05

c  calculate the quantity [gravity/coriolis_force])
c .   dx and dy represent the distances over which finite diff apply
c .   Note: dy(1) and dy(nlat) are half width for
c .   one sided differences

c                       calculate the quantity [gravity/[cor force])
      DO NL = 1,NLAT
          IF (GLAT(NL).NE.0.D0) THEN
              GF(NL) = GR/ (2.D0*OMEGA*SIN(GLAT(NL)*RAD))
          ELSE
              GF(NL) = ZMSG
          END IF
          DX(NL) = DLON2*COS(GLAT(NL)*RAD)
      END DO
c                                     get around 'rounding' problem
      IF (GLAT(1).LT.-89.999D0) THEN
          DX(1) = 0.0D0
      END IF
      IF (GLAT(NLAT).GT.89.999D0) THEN
          DX(NLAT) = 0.0D0
      END IF
c                                     lat can have variable spacing
c                                     dy(1) and dy(nlat) are half size
c                                     for use in one-sided differences
      DY(1) = (GLAT(2)-GLAT(1))*RR
      DO NL = 2,NLAT - 1
          DY(NL) = (GLAT(NL+1)-GLAT(NL-1))*RR
      END DO
      DY(NLAT) = (GLAT(NLAT)-GLAT(NLAT-1))*RR

c set ug and vg to default values

      DO NL = 1,NLAT
          DO ML = 1,MLON
              UG(ML,NL) = ZMSG
              VG(ML,NL) = ZMSG
          END DO
      END DO

c use zz array to eliminate the need for special
c .   loops/statements to handle the east and west boundaries

c                                     fill zz 'middle'
      DO NL = 1,NLAT
          DO ML = 1,MLON
              ZZ(ML,NL) = Z(ML,NL)
          END DO
      END DO
c                                     bottom and top boundaries
      DO ML = 1,MLON
          ZZ(ML,0) = ZZ(ML,1)
          ZZ(ML,NLAT+1) = ZZ(ML,NLAT)
      END DO
c                                     left and right boundaries
      IF (IOPT.EQ.1) THEN
c                                     specify cyclic values
          DO NL = 1,NLAT
              ZZ(0,NL) = ZZ(MLON,NL)
              ZZ(MLON+1,NL) = ZZ(1,NL)
          END DO
      ELSE
c                                     duplicate adjacent points
          DO NL = 1,NLAT
              ZZ(0,NL) = ZZ(1,NL)
              ZZ(MLON+1,NL) = ZZ(MLON,NL)
          END DO
      END IF

c calculate the winds at all grid points of array zz
c .   ug calculated via a one-sided differences [crude approx]
c Note: a 'trick' is used
c .   (1) the top and bottom rows of zz are duplicates of adjacent rows
c .   (2) dy(1) and dy(nlat) are already set for one-sided differences
c .   (3) the combination will result in numerically correct results

      DO NL = 1,NLAT
          IF (.NOT. (GLAT(NL).EQ.0.0D0.OR.ABS(GLAT(NL)).GT.89.999D0))
     +        THEN
              DO ML = 1,MLON
                  IF (ZZ(ML,NL+1).NE.ZMSG .AND.
     +                ZZ(ML,NL-1).NE.ZMSG) THEN
                      UG(ML,NL) = -GF(NL)* (ZZ(ML,NL+1)-ZZ(ML,NL-1))/
     +                            DY(NL)
                  END IF
                  IF (ZZ(ML+1,NL).NE.ZMSG .AND.
     +                ZZ(ML-1,NL).NE.ZMSG) THEN
                      VG(ML,NL) = GF(NL)* (ZZ(ML+1,NL)-ZZ(ML-1,NL))/
     +                            DX(NL)
                  END IF
              END DO
          END IF
      END DO

c if not cyclic in lon then "adjust" the vg for the left/right columns
c .   Basically, they should be one sided differences BUT they were
c .   divided by 2*dx. The multiplication by 2 below undoes this.
c .   The reason for the "if" is to handle the case at the EQ

      IF (IOPT.NE.1) THEN
          DO NL = 1,NLAT
              IF (VG(1,NL).NE.ZMSG) VG(1,NL) = VG(1,NL)*2.0D0
              IF (VG(MLON,NL).NE.ZMSG) VG(MLON,NL) = VG(MLON,NL)*2.0D0
          END DO
      END IF

      RETURN
      END


!!  Module of FFT based routines using fftpack
!
! This file is part of LIBPFASST.
!
!>  Module for using fftpack
module pf_mod_fft_abs
  use pf_mod_dtype
  use pf_mod_utils
  implicit none

  !>  Variables and storage for FFT
  type, abstract  :: pf_fft_abs_t
     integer ::   nx,ny,nz                         !! grid sizes
     integer ::   ndim                             !! number of spatial dimensions
     real(pfdp) :: Lx, Ly, Lz                      !! domain size
     complex(pfdp), pointer :: wk_1d(:)            ! work space
     complex(pfdp), pointer :: wk_2d(:,:)          ! work space
     complex(pfdp), pointer :: wk_3d(:,:,:)        ! work space
     real(pfdp), allocatable :: kx(:),ky(:),kz(:)              ! work space
   contains
     procedure(pf_fft_s_p),deferred :: fft_setup
     procedure(pf_fft_p),deferred :: fft_destroy
     procedure(pf_fft_p),deferred :: fftf   !  Forward FFT
     procedure(pf_fft_p),deferred :: fftb   !  Inverse (backward)  FFT
     !  FFT
     procedure, private  :: fft_1d, fft_2d, fft_3d, zfft_1d, zfft_2d, zfft_3d
     generic :: fft => fft_1d, fft_2d, fft_3d, zfft_1d, zfft_2d, zfft_3d
     !  Inverse FFT
     procedure, private  :: ifft_1d, ifft_2d, ifft_3d,izfft_1d, izfft_2d, izfft_3d
     generic :: ifft => ifft_1d, ifft_2d, ifft_3d,izfft_1d, izfft_2d, izfft_3d
     !  Convolution in spectral space for real data
     procedure, private  :: conv_1d, conv_2d, conv_3d
     generic :: conv => conv_1d, conv_2d, conv_3d
     !  Dealiasing
     procedure, private  :: dealias_1d, dealias_2d, dealias_3d
     generic :: dealias => dealias_1d, dealias_2d, dealias_3d
     !  Complex convolution in real space for spectral data
     procedure, private :: zconv_1d, zconv_2d, zconv_3d
     generic :: zconv => zconv_1d, zconv_2d, zconv_3d
     !  Convenience function to grab pointer to workspace
     procedure , private :: get_wk_ptr_1d, get_wk_ptr_2d, get_wk_ptr_3d
     generic   :: get_wk_ptr =>get_wk_ptr_1d,get_wk_ptr_2d,get_wk_ptr_3d
     !  Construct spectral Laplacian
     procedure , private :: make_lap_1d,make_lap_2d, make_lap_3d
     generic   :: make_lap =>make_lap_1d,make_lap_2d,make_lap_3d
     !  Construct inverse spectral Laplacian
     procedure , private :: make_ilap_1d,make_ilap_2d, make_ilap_3d
     generic   :: make_ilap =>make_ilap_1d,make_ilap_2d,make_ilap_3d
     !  Construct spectral derivative
     procedure , private :: make_deriv_1d,make_deriv_2d, make_deriv_3d
     generic   :: make_deriv =>make_deriv_1d,make_deriv_2d,make_deriv_3d
     !  Restrict in spectral space
     procedure , private :: restrict_1d,restrict_2d, restrict_3d,zrestrict_1d,zrestrict_2d,zrestrict_3d
     generic   :: restrict =>restrict_1d,restrict_2d,restrict_3d,zrestrict_1d,zrestrict_2d,zrestrict_3d

  end type pf_fft_abs_t

  interface
     subroutine pf_fft_s_p(this, grid_shape, ndim, grid_size)
       import pf_fft_abs_t,pfdp
       class(pf_fft_abs_t), intent(inout) :: this
       integer,              intent(in   ) :: ndim
       integer,              intent(in   ) :: grid_shape(ndim)
       real(pfdp), optional, intent(in   ) :: grid_size(ndim)
     end subroutine pf_fft_s_p
     subroutine pf_fft_p(this)
       import pf_fft_abs_t,pfdp
       class(pf_fft_abs_t), intent(inout) :: this
     end subroutine pf_fft_p
  end interface

contains

 subroutine get_wk_ptr_1d(this,wk)
    class(pf_fft_abs_t), intent(inout) :: this
    complex(pfdp), pointer,intent(inout) :: wk(:)              ! work space
    wk=>this%wk_1d
  end subroutine get_wk_ptr_1d
  subroutine get_wk_ptr_2d(this,wk)
    class(pf_fft_abs_t), intent(inout) :: this
    complex(pfdp), pointer,intent(inout) :: wk(:,:)              ! work space
    wk=>this%wk_2d
  end subroutine get_wk_ptr_2d
  subroutine get_wk_ptr_3d(this,wk)
    class(pf_fft_abs_t), intent(inout) :: this
    complex(pfdp), pointer,intent(inout) :: wk(:,:,:)              ! work space
    wk=>this%wk_3d
  end subroutine get_wk_ptr_3d

  !++++++++++ Forward FFT real to complex  ++++++++++++++++
  subroutine fft_1d(this, g,ghat)
    class(pf_fft_abs_t), intent(inout) :: this
    real(pfdp), intent(in) :: g(:)
    complex(pfdp), intent(inout) :: ghat(:)

    this%wk_1d=g
    call this%fftf()
    ghat=this%wk_1d
  end subroutine fft_1d

  subroutine fft_2d(this, g,ghat)
    class(pf_fft_abs_t), intent(inout) :: this
    real(pfdp), intent(in) :: g(:,:)
    complex(pfdp), intent(inout) :: ghat(:,:)

    this%wk_2d=g
    call this%fftf()
    ghat=this%wk_2d
  end subroutine fft_2d

    subroutine fft_3d(this, g,ghat)
    class(pf_fft_abs_t), intent(inout) :: this
    real(pfdp), intent(in) :: g(:,:,:)
    complex(pfdp), intent(inout) :: ghat(:,:,:)

    this%wk_3d=g
    call this%fftf()
    ghat=this%wk_3d
  end subroutine fft_3d

  !++++++++++ Backward FFT complex to real   ++++++++++++++++
  subroutine ifft_1d(this,ghat,g)
    class(pf_fft_abs_t), intent(inout) :: this
    real(pfdp), intent(inout) :: g(:)
    complex(pfdp), intent(in) :: ghat(:)

    this%wk_1d=ghat
    call this%fftb()
    g=REAL(this%wk_1d,pfdp)
  end subroutine ifft_1d

  subroutine ifft_2d(this, ghat,g)
    class(pf_fft_abs_t), intent(inout) :: this
    real(pfdp), intent(inout) :: g(:,:)
    complex(pfdp), intent(in) :: ghat(:,:)

    this%wk_2d=ghat
    call this%fftb()
    g=REAL(this%wk_2d,pfdp)
  end subroutine ifft_2d

    subroutine ifft_3d(this, ghat,g)
    class(pf_fft_abs_t), intent(inout) :: this
    real(pfdp), intent(inout) :: g(:,:,:)
    complex(pfdp), intent(in) :: ghat(:,:,:)

    this%wk_3d=ghat
    call this%fftb()
    g=REAL(this%wk_3d)
  end subroutine ifft_3d

  !++++++++++ Forward FFT complex to complex   ++++++++++++++++
  subroutine zfft_1d(this, g,ghat)
    class(pf_fft_abs_t), intent(inout) :: this
    complex(pfdp), intent(in) :: g(:)
    complex(pfdp), intent(inout) :: ghat(:)

    this%wk_1d=g
    call this%fftf()
    ghat=this%wk_1d
  end subroutine zfft_1d

    subroutine zfft_2d(this, g,ghat)
    class(pf_fft_abs_t), intent(inout) :: this
    complex(pfdp), intent(in) :: g(:,:)
    complex(pfdp), intent(inout) :: ghat(:,:)

    this%wk_2d=g
    call this%fftf()
    ghat=this%wk_2d
  end subroutine zfft_2d

  subroutine zfft_3d(this, g,ghat)
    class(pf_fft_abs_t), intent(inout) :: this
    complex(pfdp), intent(in) :: g(:,:,:)
    complex(pfdp), intent(inout) :: ghat(:,:,:)

    this%wk_3d=g
    call this%fftf()
    ghat=this%wk_3d
  end subroutine zfft_3d

  !++++++++++ Backward FFT complex to complex   ++++++++++++++++
  subroutine izfft_1d(this,ghat,g)
    class(pf_fft_abs_t), intent(inout) :: this
    complex(pfdp), intent(in) :: ghat(:)
    complex(pfdp), intent(inout) :: g(:)

    this%wk_1d=ghat
    call this%fftb()
    g=this%wk_1d
  end subroutine izfft_1d

  ! Take forward FFT
  subroutine izfft_2d(this, ghat,g)
    class(pf_fft_abs_t), intent(inout) :: this
    complex(pfdp), intent(in) :: ghat(:,:)
    complex(pfdp), intent(inout) :: g(:,:)

    this%wk_2d=ghat
    call this%fftb()
    g=this%wk_2d
  end subroutine izfft_2d

  subroutine izfft_3d(this, ghat,g)
    class(pf_fft_abs_t), intent(inout) :: this
    complex(pfdp), intent(in) :: ghat(:,:,:)
    complex(pfdp), intent(inout) :: g(:,:,:)

    this%wk_3d=ghat
    call this%fftb()
    g=this%wk_3d
  end subroutine izfft_3d
  ! Routines to do 2/(p+1) rule dealiasing
  subroutine dealias_1d(this,yhat,p)
    class(pf_fft_abs_t), intent(inout) :: this
    complex(pfdp), intent(inout) :: yhat(:)
    integer, intent(in) :: p
    integer :: nmax
    nmax = FLOOR(real(this%nx,pfdp)/(1.0_pfdp+real(p,pfdp)))+1
    yhat(nmax+1:this%nx-nmax)=0.0_pfdp
  end subroutine dealias_1d

  subroutine dealias_2d(this,yhat,p)
    class(pf_fft_abs_t), intent(inout) :: this
    complex(pfdp), intent(inout) :: yhat(:,:)
    integer, intent(in) :: p
    integer :: nxmax,nymax
    nxmax = FLOOR(real(this%nx)/(1.0_pfdp+real(p,pfdp)))+1
    nymax = FLOOR(real(this%ny)/(1.0_pfdp+real(p,pfdp)))+1
    yhat(nxmax+1:this%nx-nxmax,nymax+1:this%ny-nymax)=0.0_pfdp
  end subroutine dealias_2d

  subroutine dealias_3d(this,yhat,p)
    class(pf_fft_abs_t), intent(inout) :: this
    complex(pfdp), intent(inout) :: yhat(:,:,:)
    integer, intent(in) :: p
    integer :: nxmax,nymax,nzmax
    nxmax = FLOOR(real(this%nx)/(1.0_pfdp+real(p,pfdp)))+1
    nymax = FLOOR(real(this%ny)/(1.0_pfdp+real(p,pfdp)))+1
    nzmax = FLOOR(real(this%nz)/(1.0_pfdp+real(p,pfdp)))+1
    yhat(nxmax+1:this%nx-nxmax,nymax+1:this%ny-nymax,nzmax+1:this%nz-nzmax)=0.0_pfdp
  end subroutine dealias_3d

  ! Convolve g with spectral op and return in c
  subroutine conv_1d(this, g,op,c,dealias)
    class(pf_fft_abs_t), intent(inout) :: this
    real(pfdp), intent(in) :: g(:)
    complex(pfdp), intent(in) :: op(:)
    real(pfdp), intent(inout) :: c(:)
    logical, optional, intent(in) :: dealias

    logical  :: do_dealias
    do_dealias=.FALSE.
    if(present(dealias)) do_dealias=dealias

    this%wk_1d=g
    call this%fftf()
    if (do_dealias) call this%dealias_1d(this%wk_1d,2)
    this%wk_1d = this%wk_1d * op
    call this%fftb()
    c=REAL(this%wk_1d,pfdp)
  end subroutine conv_1d

  ! Convolve g with spectral op and return in c
  subroutine conv_2d(this, g,op,c,dealias)
    class(pf_fft_abs_t), intent(inout) :: this
    real(pfdp), intent(in) :: g(:,:)
    complex(pfdp), intent(in) :: op(:,:)
    real(pfdp), intent(inout) :: c(:,:)
    logical, optional, intent(in) :: dealias

    logical  :: do_dealias
    do_dealias=.FALSE.
    if(present(dealias)) do_dealias=dealias

    this%wk_2d=g
    call this%fftf()
    if (do_dealias) call this%dealias_2d(this%wk_2d,2)
    this%wk_2d = this%wk_2d * op
    call this%fftb()
    c=REAL(this%wk_2d,pfdp)
  end subroutine conv_2d

  subroutine conv_3d(this, g,op,c,dealias)
    class(pf_fft_abs_t), intent(inout) :: this
    real(pfdp), intent(in) :: g(:,:,:)
    complex(pfdp), intent(in) :: op(:,:,:)
    real(pfdp), intent(inout) :: c(:,:,:)
    logical, optional, intent(in) :: dealias

    logical  :: do_dealias
    do_dealias=.FALSE.
    if(present(dealias)) do_dealias=dealias

    this%wk_3d=g
    call this%fftf()
    if (do_dealias) call this%dealias_3d(this%wk_3d,3)
    this%wk_3d = this%wk_3d * op
    call this%fftb()
    c=REAL(this%wk_3d,pfdp)
  end subroutine conv_3d

  ! Convolution in real space
  subroutine zconv_1d(this, ghat,op,chat)
    class(pf_fft_abs_t), intent(inout) :: this
    complex(pfdp), intent(in) :: ghat(:),op(:)
    complex(pfdp), intent(inout) :: chat(:)

    this%wk_1d=ghat
    call this%fftb()
    this%wk_1d = this%wk_1d * op
    call this%fftf()
    chat=this%wk_1d

  end subroutine zconv_1d

  subroutine zconv_2d(this, ghat,op,chat)
    class(pf_fft_abs_t), intent(inout) :: this
    complex(pfdp), intent(in) :: ghat(:,:),op(:,:)
    complex(pfdp), intent(inout) ::chat(:,:)

    this%wk_2d=ghat
    call this%fftb()
    this%wk_2d = this%wk_2d * op
    call this%fftf()
    chat=this%wk_2d

  end subroutine zconv_2d

  subroutine zconv_3d(this, ghat,op,chat)
    class(pf_fft_abs_t), intent(inout) :: this
    complex(pfdp), intent(in) :: ghat(:,:,:),op(:,:,:)
    complex(pfdp), intent(inout) ::chat(:,:,:)

    this%wk_3d=ghat
    call this%fftb()
    this%wk_3d = this%wk_3d * op
    call this%fftf()
    chat=this%wk_3d

  end subroutine zconv_3d

  !  Make the inverse of the Laplacian in spectral space
  subroutine make_ilap_1d(this, ilap,order)
    class(pf_fft_abs_t), intent(inout) :: this
    complex(pfdp), intent(inout) :: ilap(:)
    integer, intent(in),optional :: order

    integer     :: i,nx,local_order
    real(pfdp) :: dx
    local_order=0
    if (present(order)) local_order = order
    nx=this%nx
    ilap(1) = 0.0_pfdp !    This sets DC component    '
    select case (local_order)
       case (0)
          do i = 2, nx
             ilap(i) = -1.0_pfdp/(this%kx(i)**2)
          end do
       case (2)
          dx=this%Lx/real(nx,pfdp)
          do i = 2, nx
             ilap(i) = dx*dx/(-2.0_pfdp+2.0_pfdp*cos(this%kx(i)*dx))
          end do
       case (4)
          dx=this%Lx/real(nx,pfdp)
          do i = 2, nx
             ilap(i) = (12.0_pfdp*dx*dx)/(-30.0_pfdp+32.0_pfdp*cos(this%kx(i)*dx)-2.0_pfdp*cos(2.0_pfdp*this%kx(i)*dx))
          end do
       case DEFAULT
          call pf_stop(__FILE__,__LINE__,'Bad case in SELECT',local_order)
       end select

  end subroutine make_ilap_1d

  subroutine make_ilap_2d(this, ilap,order)
    class(pf_fft_abs_t), intent(inout) :: this
    complex(pfdp), intent(inout) :: ilap(:,:)
    integer, intent(in),optional :: order
    integer     :: i,j,nx,ny,local_order
    real(pfdp) :: dx,dy,kk
    local_order=0
    if (present(order)) local_order = order

    nx=this%nx
    ny=this%ny

    ilap(1,1) = 0.0_pfdp !    This sets DC component
    select case (local_order)
       case (0)
          do i = 2, nx
             ilap(i,1) = -1.0_pfdp/(this%kx(i)**2)
          end do
          do j = 2, ny
             do i = 1, nx
                ilap(i,j) = -1.0_pfdp/(this%kx(i)**2+this%ky(j)**2)
             end do
          end do
       case(2)
          dx=this%Lx/real(nx,pfdp)
          dy=this%Ly/real(ny,pfdp)
          do i = 2, nx
             ilap(i,1) = dx*dx/(-2.0_pfdp+2.0_pfdp*cos(this%kx(i)*dx))
          end do
          do j = 2, ny
             do i = 1, nx
                ilap(i,j) = dx*dx/(-2.0_pfdp+2.0_pfdp*cos(this%kx(i)*dx)) + dy*dy/(-2.0_pfdp+2.0_pfdp*cos(this%ky(j)*dy))
             end do
          end do
       case(4)
          dx=this%Lx/real(nx,pfdp)
          dy=this%Ly/real(ny,pfdp)
          do j = 1, ny
             do i = 1, nx
                kk=(-30.0_pfdp+32.0_pfdp*cos(this%kx(i)*dx)-2.0_pfdp*cos(2.0_pfdp*this%kx(i)*dx))/(12.0_pfdp*dx*dx) &
                     + (-30.0_pfdp+32.0_pfdp*cos(this%ky(j)*dy)-2.0_pfdp*cos(2.0_pfdp*this%ky(j)*dy))/(12.0_pfdp*dy*dy)
                if (abs(kk) .gt. 0.0) then
                   ilap(i,j) = 1.0_pfdp/kk
                else
                   ilap(i,j) = 0.0_pfdp
                end if
             end do
          end do
       case DEFAULT
          call pf_stop(__FILE__,__LINE__,'Bad case in SELECT',local_order)
       end select

  end subroutine make_ilap_2d

  subroutine make_ilap_3d(this, ilap,order)
    class(pf_fft_abs_t), intent(inout) :: this
    complex(pfdp), intent(inout) :: ilap(:,:,:)
    integer, intent(in),optional :: order

    integer     :: i,j,k,nx,ny,nz,kk,local_order
    real(pfdp) :: dx,dy,dz
    local_order=0
    if (present(order)) local_order = order

    nx=this%nx
    ny=this%ny
    nz=this%nz
    select case (local_order)
       case (0)
          do k = 1,nz
             do j = 1, ny
                do i = 1, nx
                   kk=-this%kx(i)**2-this%ky(j)**2-this%kz(k)**2
                   if (abs(kk) .gt. 0.0) then
                      ilap(i,j,k) = 1.0_pfdp/kk
                   else
                      ilap(i,j,k) = 0.0_pfdp !    This sets DC component
                   end if
                end do
             end do
          end do
       case(2)
          dx=this%Lx/real(nx,pfdp)
          dy=this%Ly/real(ny,pfdp)
          dz=this%Lz/real(nz,pfdp)
          do k = 1,nz
             do j = 1, ny
                do i = 1, nx
                   kk=(-2.0_pfdp+2.0_pfdp*cos(this%kx(i)*dx))/(dx*dx) + (-2.0_pfdp+2.0_pfdp*cos(this%ky(j)*dy))/(dy*dy)+ (-2.0_pfdp+2.0_pfdp*cos(this%kz(k)*dz))/(dz*dz)
                   if (abs(kk) .gt. 0.0) then
                      ilap(i,j,k) = 1.0_pfdp/kk
                   else
                      ilap(i,j,k) = 0.0_pfdp !    This sets DC component
                   end if
                end do
             end do
          end do
       case(4)
          dx=this%Lx/real(nx,pfdp)
          dy=this%Ly/real(ny,pfdp)
          dz=this%Lz/real(nz,pfdp)
          do k = 1,nz
             do j = 1, ny
                do i = 1, nx
                   kk=(-30.0_pfdp+32.0_pfdp*cos(this%kx(i)*dx)-2.0_pfdp*cos(2.0_pfdp*this%kx(i)*dx))/(12.0_pfdp*dx*dx) &
                        + (-30.0_pfdp+32.0_pfdp*cos(this%ky(j)*dy)-2.0_pfdp*cos(2.0_pfdp*this%ky(j)*dy))/(12.0_pfdp*dy*dy) &
                        + (-30.0_pfdp+32.0_pfdp*cos(this%kz(k)*dz)-2.0_pfdp*cos(2.0_pfdp*this%kz(k)*dz))/(12.0_pfdp*dz*dz)
                   if (abs(kk) .gt. 0.0) then
                      ilap(i,j,k) = 1.0_pfdp/kk
                   else
                      ilap(i,j,k) = 0.0_pfdp !    This sets DC component
                   end if
                end do
             end do
          end do
       case DEFAULT
          call pf_stop(__FILE__,__LINE__,'Bad case in SELECT',local_order)
       end select

  end subroutine make_ilap_3d

  subroutine make_lap_1d(this, lap,order)
    class(pf_fft_abs_t), intent(inout) :: this
    complex(pfdp), intent(inout) :: lap(:)
    integer, intent(in),optional :: order

    integer     :: i,nx,local_order
    real(pfdp) :: dx
    local_order=0
    if (present(order)) local_order = order
    nx=this%nx

    select case (local_order)
    case (0)
       do i = 2, nx
          lap(i) = -(this%kx(i)**2)
       end do
    case (2)
       dx=this%Lx/real(nx,pfdp)
       do i = 2, nx
          lap(i) = (-2.0_pfdp+2.0_pfdp*cos(this%kx(i)*dx))/(dx*dx)
       end do
    case (4)
       dx=this%Lx/real(nx,pfdp)
       do i = 2, nx
          lap(i) = (-30.0_pfdp+32.0_pfdp*cos(this%kx(i)*dx)-2.0_pfdp*cos(2.0_pfdp*this%kx(i)*dx))/(12.0_pfdp*dx*dx)
       end do
    case DEFAULT
       call pf_stop(__FILE__,__LINE__,'Bad case in SELECT',local_order)
    end select

  end subroutine make_lap_1d

  subroutine make_lap_2d(this, lap,order)
    class(pf_fft_abs_t), intent(inout) :: this
    complex(pfdp), intent(inout) :: lap(:,:)

    integer, intent(in),optional :: order
    integer     :: i,j,nx,ny,local_order
    real(pfdp) :: dx,dy
    local_order=0
    if (present(order)) local_order = order
    nx=this%nx
    ny=this%ny

    select case (local_order)
       case (0)
          do j = 1, ny
             do i = 1, nx
                lap(i,j) = -(this%kx(i)**2+this%ky(j)**2)
             end do
          end do
       case(2)
          dx=this%Lx/real(nx,pfdp)
          dy=this%Ly/real(ny,pfdp)
          do j = 1, ny
             do i = 1, nx
                lap(i,j) = (-2.0_pfdp+2.0_pfdp*cos(this%kx(i)*dx))/(dx*dx) + (-2.0_pfdp+2.0_pfdp*cos(this%ky(j)*dy))/(dy*dy)
             end do
          end do
       case(4)
          dx=this%Lx/real(nx,pfdp)
          dy=this%Ly/real(ny,pfdp)
          do j = 1, ny
             do i = 1, nx
                   lap(i,j)=(-30.0_pfdp+32.0_pfdp*cos(this%kx(i)*dx)-2.0_pfdp*cos(2.0_pfdp*this%kx(i)*dx))/(12.0_pfdp*dx*dx) &
                        + (-30.0_pfdp+32.0_pfdp*cos(this%ky(j)*dy)-2.0_pfdp*cos(2.0_pfdp*this%ky(j)*dy))/(12.0_pfdp*dy*dy)
               end do
          end do
       case DEFAULT
          call pf_stop(__FILE__,__LINE__,'Bad case in SELECT',local_order)
       end select

  end subroutine make_lap_2d

  subroutine make_lap_3d(this, lap,order)
    class(pf_fft_abs_t), intent(inout) :: this
    complex(pfdp), intent(inout) :: lap(:,:,:)
    integer, intent(in),optional :: order

    integer     :: i,j,k,nx,ny,nz,local_order
    real(pfdp) :: dx,dy,dz
    local_order=0
    if (present(order)) local_order = order

    nx=this%nx
    ny=this%ny
    nz=this%nz
    select case (local_order)
       case (0)
          do k = 1,nz
             do j = 1, ny
                do i = 1, nx
                   lap(i,j,k)=-this%kx(i)**2-this%ky(j)**2-this%kz(k)**2
                end do
             end do
          end do
       case(2)
          dx=this%Lx/real(nx,pfdp)
          dy=this%Ly/real(ny,pfdp)
          dz=this%Lz/real(nz,pfdp)
          do k = 1,nz
             do j = 1, ny
                do i = 1, nx
                   lap(i,j,k)=(-2.0_pfdp+2.0_pfdp*cos(this%kx(i)*dx))/(dx*dx) + (-2.0_pfdp+2.0_pfdp*cos(this%ky(j)*dy))/(dy*dy)+ (-2.0_pfdp+2.0_pfdp*cos(this%kz(k)*dz))/(dz*dz)
                end do
             end do
          end do
       case(4)
          dx=this%Lx/real(nx,pfdp)
          dy=this%Ly/real(ny,pfdp)
          dz=this%Lz/real(nz,pfdp)
          do k = 1,nz
             do j = 1, ny
                do i = 1, nx
                   lap(i,j,k)=(-30.0_pfdp+32.0_pfdp*cos(this%kx(i)*dx)-2.0_pfdp*cos(2.0_pfdp*this%kx(i)*dx))/(12.0_pfdp*dx*dx) &
                        + (-30.0_pfdp+32.0_pfdp*cos(this%ky(j)*dy)-2.0_pfdp*cos(2.0_pfdp*this%ky(j)*dy))/(12.0_pfdp*dy*dy) &
                        + (-30.0_pfdp+32.0_pfdp*cos(this%kz(k)*dz)-2.0_pfdp*cos(2.0_pfdp*this%kz(k)*dz))/(12.0_pfdp*dz*dz)
                end do
             end do
          end do
       case DEFAULT
          call pf_stop(__FILE__,__LINE__,'Bad case in SELECT',local_order)
       end select

  end subroutine make_lap_3d

  !subroutine make_ilap_3d(this, ilap)
  !  class(pf_fft_abs_t), intent(inout) :: this
  !  complex(pfdp), intent(inout) :: ilap(:,:,:)

  !  integer     :: i,j,k,nx,ny,nz
!
!    nx=this%nx
!    ny=this%ny
!    nz=this%nz
!    do k = 1,nz
!       do j = 1, ny
!          do i = 1, nx
!             if (i .eq. 1  .and. j .eq. 1 ) then !CHECK!
!                ilap(i,j,k) = 0.0_pfdp !    This sets DC component
!             else
!                ilap(i,j,k) = -1.0_pfdp/(this%kx(i)**2+this%ky(j)**2+this%kz(k)**2)
!             end if
!          end do
!       end do
!    end do
!
!  end subroutine make_ilap_3d

    subroutine make_deriv_1d(this, ddx,order)
      class(pf_fft_abs_t), intent(inout) :: this
      complex(pfdp), intent(inout) :: ddx(:)
      integer, intent(in),optional :: order
      integer     :: i,nx,local_order
      real(pfdp) :: dx
      local_order=0
      if (present(order)) local_order = order

      nx=this%nx
      dx=this%Lx/real(nx,pfdp)
      select case(local_order)
      case(0)
         do i = 1, nx
            ddx(i) = (0.0_pfdp, 1.0_pfdp) * this%kx(i)
         end do
      case (2)
         do i = 1, nx
            ddx(i) = (0.0_pfdp, 1.0_pfdp) * sin(dx*this%kx(i))/dx
         end do
      case (4)
         do i = 1, nx
            ddx(i) = (0.0_pfdp, 1.0_pfdp) * (-2.0_pfdp*sin(2.0_pfdp*dx*this%kx(i))+16.0_pfdp*sin(dx*this%kx(i)))/(12.0_pfdp*dx)
         end do
      case DEFAULT
          call pf_stop(__FILE__,__LINE__,'Bad case in SELECT',local_order)
       end select

     end subroutine make_deriv_1d

    subroutine make_deriv_2d(this, deriv,dir,order)
      class(pf_fft_abs_t), intent(inout) :: this
      complex(pfdp), intent(inout) :: deriv(:,:)
      integer, intent(in) :: dir
      integer, intent(in),optional :: order

      integer     :: i,j,nx,ny,local_order
      real(pfdp) :: dx,dy
      local_order=0
      if (present(order)) local_order = order

      nx=this%nx
      ny=this%ny

      select case(local_order)
      case(0)
      if (dir .eq. 1) then
         do i = 1, nx
            deriv(i,:) = (0.0_pfdp,1.0_pfdp)*this%kx(i)
         end do
      else
         do j = 1, ny
            deriv(:,j) = (0.0_pfdp,1.0_pfdp)*this%ky(j)
         end do
      endif
      case(2)
         if (dir .eq. 1) then
            dx=this%Lx/real(nx,pfdp)
            do i = 1, nx
               deriv(i,:) = (0.0_pfdp,1.0_pfdp)*sin(this%kx(i)*dx)/dx
            end do
         else
            dy=this%Ly/real(ny,pfdp)
            do j = 1, ny
               deriv(:,j) = (0.0_pfdp,1.0_pfdp)*sin(this%ky(j)*dx)/dy
            end do
         endif
      case(4)
         if (dir .eq. 1) then
            dx=this%Lx/real(nx,pfdp)
            do i = 1, nx
               deriv(i,:) = (0.0_pfdp,1.0_pfdp)*(-2.0_pfdp*sin(2.0_pfdp*dx*this%kx(i))+16.0_pfdp*sin(dx*this%kx(i)))/(12.0_pfdp*dx)
            end do
         else
            dy=this%Ly/real(ny,pfdp)
            do j = 1, ny
               deriv(:,j) = (0.0_pfdp,1.0_pfdp)*(-2.0_pfdp*sin(2.0_pfdp*dy*this%ky(j))+16.0_pfdp*sin(dy*this%ky(j)))/(12.0_pfdp*dy)
            end do
         endif
      case DEFAULT
         call pf_stop(__FILE__,__LINE__,'Bad case in SELECT',local_order)
      end select

    end subroutine make_deriv_2d

    subroutine make_deriv_3d(this, deriv,dir,order)
      class(pf_fft_abs_t), intent(inout) :: this
      complex(pfdp), intent(inout) :: deriv(:,:,:)
      integer, intent(in) :: dir
      integer, intent(in),optional :: order

      integer     :: i,j,k,nx,ny,nz,local_order
      real(pfdp) :: dx,dy,dz
      local_order=0
      if (present(order)) local_order = order

      nx=this%nx
      ny=this%ny
      nz=this%nz
      select case(local_order)
         case (0)
            select case (dir)
            case (1)
               do i = 1, nx
                  deriv(i,:,:) = (0.0_pfdp,1.0_pfdp)*this%kx(i)
               end do
            case (2)
               do j = 1, ny
                  deriv(:,j,:) = (0.0_pfdp,1.0_pfdp)*this%ky(j)
               end do
            case (3)
               do k = 1, nz
                  deriv(:,:,k) = (0.0_pfdp,1.0_pfdp)*this%kz(k)
               end do
            case DEFAULT
               call pf_stop(__FILE__,__LINE__,'Bad case in SELECT',dir)
            end select
         case(2)
            select case (dir)
            case (1)
               dx=this%Lx/real(nx,pfdp)
               do i = 1, nx
                  deriv(i,:,:) = (0.0_pfdp,1.0_pfdp)*sin(this%kx(i)*dx)/dx
               end do
            case (2)
               dy=this%Ly/real(ny,pfdp)
               do j = 1, ny
                  deriv(:,j,:) = (0.0_pfdp,1.0_pfdp)*sin(this%ky(j)*dy)/dy
               end do
            case (3)
               dz=this%Lz/real(nz,pfdp)
               do k = 1, nz
                  deriv(:,:,k) = (0.0_pfdp,1.0_pfdp)*sin(this%kz(k)*dz)/dz
               end do
            case DEFAULT
               call pf_stop(__FILE__,__LINE__,'Bad case in SELECT',dir)
            end select
         case(4)
            select case (dir)
            case (1)
               dx=this%Lx/real(nx,pfdp)
               do i = 1, nx
                  deriv(i,:,:) = (0.0_pfdp,1.0_pfdp)*(-2.0_pfdp*sin(2.0_pfdp*dx*this%kx(i))+16.0_pfdp*sin(dx*this%kx(i)))/(12.0_pfdp*dx)
               end do
            case (2)
               dy=this%Ly/real(ny,pfdp)
               do j = 1, ny
                  deriv(:,j,:) = (0.0_pfdp,1.0_pfdp)*(-2.0_pfdp*sin(2.0_pfdp*dy*this%ky(j))+16.0_pfdp*sin(dy*this%ky(j)))/(12.0_pfdp*dy)
               end do
            case (3)
               dz=this%Lz/real(nz,pfdp)
               do k = 1, nz
                  deriv(:,:,k) = (0.0_pfdp,1.0_pfdp)*(-2.0_pfdp*sin(2.0_pfdp*dz*this%kz(k))+16.0_pfdp*sin(dz*this%kz(k)))/(12.0_pfdp*dz)
               end do
            case DEFAULT
               call pf_stop(__FILE__,__LINE__,'Bad case in SELECT',dir)
            end select
         case DEFAULT
            call pf_stop(__FILE__,__LINE__,'Bad case in SELECT',local_order)
         end select

    end subroutine make_deriv_3d

  !  Restrict routines that take a fine vector and produce a coarse version
  subroutine restrict_1d(this, yvec_f, yvec_c)
    class(pf_fft_abs_t), intent(inout) :: this
    real(pfdp),         pointer :: yvec_f(:), yvec_c(:)
    integer :: nx_f, nx_c,irat
    nx_f = SIZE(yvec_f)
    nx_c = SIZE(yvec_c)
    irat  = nx_f/nx_c

    yvec_c = yvec_f(::irat)
  end subroutine restrict_1d
  subroutine restrict_2d(this, yvec_f, yvec_c)
    class(pf_fft_abs_t), intent(inout) :: this
    real(pfdp),         pointer :: yvec_f(:,:), yvec_c(:,:)
    integer :: nx_f(2), nx_c(2), irat, jrat

    nx_f = SHAPE(yvec_f)
    nx_c = SHAPE(yvec_c)

    irat  = nx_f(1)/nx_c(1)
    jrat  = nx_f(2)/nx_c(2)

    yvec_c = yvec_f(::irat,::jrat)
  end subroutine restrict_2d
  subroutine restrict_3d(this, yvec_f, yvec_c)
    class(pf_fft_abs_t), intent(inout) :: this
    real(pfdp),         pointer :: yvec_f(:,:,:), yvec_c(:,:,:)
    integer :: nx_f(3), nx_c(3)
    integer :: irat, jrat,krat

    nx_f = SHAPE(yvec_f)
    nx_c = SHAPE(yvec_c)

    irat  = nx_f(1)/nx_c(1)
    jrat  = nx_f(2)/nx_c(2)
    krat  = nx_f(3)/nx_c(3)

    yvec_c = yvec_f(::irat,::jrat,::krat)
  end subroutine restrict_3d

  subroutine zrestrict_1d(this, yhat_f, yhat_c)
    class(pf_fft_abs_t), intent(inout) :: this
    complex(pfdp),  pointer :: yhat_f(:), yhat_c(:)
    integer :: nx_f, nx_c

    nx_f = SIZE(yhat_f)
    nx_c = SIZE(yhat_c)
    if (nx_f .eq. nx_c)  then
       yhat_c=yhat_f
       return
    end if

    yhat_c=0.0_pfdp
    yhat_c(1:nx_c/2) = yhat_f(1:nx_c/2)
    yhat_c(nx_c/2+2:nx_c) = yhat_f(nx_f-nx_c/2+2:nx_f)

  end subroutine zrestrict_1d
  subroutine zrestrict_2d(this, yhat_f, yhat_c)
    class(pf_fft_abs_t), intent(inout) :: this
    complex(pfdp),         pointer :: yhat_f(:,:), yhat_c(:,:)

    integer :: nx_f(2), nx_c(2),nf1,nf2,nc1,nc2
    nx_f = SHAPE(yhat_f)
    nx_c = SHAPE(yhat_c)
    if (nx_f(1) .eq. nx_c(1) .and. nx_f(2) .eq. nx_c(2))  then
       yhat_c=yhat_f
       return
    end if

    nf1=nx_f(1)-nx_c(1)/2+2
    nf2=nx_f(2)-nx_c(2)/2+2
    nc1=nx_c(1)/2+2
    nc2=nx_c(2)/2+2

    yhat_c=0.0_pfdp
    yhat_c(1:nx_c(1)/2,1:nx_c(2)/2) = yhat_f(1:nx_c(1)/2,1:nx_c(2)/2)
    yhat_c(nc1:nx_c(1),1:nx_c(2)/2) = yhat_f(nf1:nx_f(1),1:nx_c(2)/2)
    yhat_c(1:nx_c(1)/2,nc2:nx_c(2)) = yhat_f(1:nx_c(1)/2,nf2:nx_f(2))
    yhat_c(nc1:nx_c(1),nc2:nx_c(2)) = yhat_f(nf1:nx_f(1),nf2:nx_f(2))

  end subroutine zrestrict_2d
  subroutine zrestrict_3d(this, yhat_f, yhat_c)
    class(pf_fft_abs_t), intent(inout) :: this
    complex(pfdp),         pointer :: yhat_f(:,:,:), yhat_c(:,:,:)

    integer :: nx_f(3), nx_c(3),nf1,nf2,nf3,nc1,nc2,nc3

    yhat_c = 0.0_pfdp

    nx_f = SHAPE(yhat_f)
    nx_c = SHAPE(yhat_c)
    if (nx_f(1) .eq. nx_c(1) .and. nx_f(2) .eq. nx_c(2) .and. nx_f(3) .eq. nx_c(3))  then
       yhat_c=yhat_f
       return
    end if
    nf1=nx_f(1)-nx_c(1)/2+2
    nf2=nx_f(2)-nx_c(2)/2+2
    nf3=nx_f(3)-nx_c(3)/2+2
    nc1=nx_c(1)/2+2
    nc2=nx_c(2)/2+2
    nc3=nx_c(3)/2+2

    yhat_c(1:nx_c(1)/2,1:nx_c(2)/2,1:nx_c(3)/2) = yhat_f(1:nx_c(1)/2,1:nx_c(2)/2,1:nx_c(3)/2)
    yhat_c(nc1:nx_c(1),1:nx_c(2)/2,1:nx_c(3)/2) = yhat_f(nf1:nx_f(1),1:nx_c(2)/2,1:nx_c(3)/2)
    yhat_c(1:nx_c(1)/2,nc2:nx_c(2),1:nx_c(3)/2) = yhat_f(1:nx_c(1)/2,nf2:nx_f(2),1:nx_c(3)/2)
    yhat_c(nc1:nx_c(1),nc2:nx_c(2),1:nx_c(3)/2) = yhat_f(nf1:nx_f(1),nf2:nx_f(2),1:nx_c(3)/2)

    yhat_c(1:nx_c(1)/2,1:nx_c(2)/2,nc3:nx_c(3)) = yhat_f(1:nx_c(1)/2,1:nx_c(2)/2,nf3:nx_f(3))
    yhat_c(nc1:nx_c(1),1:nx_c(2)/2,nc3:nx_c(3)) = yhat_f(nf1:nx_f(1),1:nx_c(2)/2,nf3:nx_f(3))
    yhat_c(1:nx_c(1)/2,nc2:nx_c(2),nc3:nx_c(3)) = yhat_f(1:nx_c(1)/2,nf2:nx_f(2),nf3:nx_f(3))
    yhat_c(nc1:nx_c(1),nc2:nx_c(2),nc3:nx_c(3)) = yhat_f(nf1:nx_f(1),nf2:nx_f(2),nf3:nx_f(3))

  end subroutine zrestrict_3d

  end module pf_mod_fft_abs


c=======================================================================
c
c     function ranf
c
c     This function Generates Uniform[0,1] random numbers.
c     The function has no arguments.
c
c-----------------------------------------------------------------------
c
c     Copyright (c) 2014 NumX
c     All rights reserved.
c
c     This software is the confidential and proprietary information
c     of NumX. You shall not disclose such Confidential
C     Information and shall use it only in accordance with the terms
c     of the licence agreement you entered into with NumX.
c
c     author: Yann Vernaz
c
c-----------------------------------------------------------------------
c
      FUNCTION ranf()
c
      IMPLICIT NONE
      REAL ranf

      INTEGER init_seed_linux, s
      EXTERNAL init_seed_linux
c
c-----------------------------------------------------------------------
c
c     Pseudorandom numbers from the uniform distribution
c     within the range 0 <= x <=1
c
      s = init_seed_linux()
      ranf = rand(s)
      RETURN
      END


# define ANGULAR_MOMENTUM 0

module setup_analyze_mod

use constants_mod

character(len=255) :: fpath = 'analysis.dat'

integer, parameter :: idens      = 1
integer, parameter :: imomx      = 2
integer, parameter :: imomy      = 3
integer, parameter :: imomz      = 4
integer, parameter :: ietot      = 5

integer, parameter :: idl2norm   = 7
integer, parameter :: idl8norm   = 8

integer, parameter :: iel2norm   = 9
integer, parameter :: iel8norm   = 10

integer, parameter :: sums_len  = 10

real(dp), save :: sums(1:SUMS_LEN) !! accumulators
real(dp), save :: nextanalyze = 0.0

real(dp), save :: nodes(N_NODES),ws(N_NODES)

contains

subroutine hook_init_830

    use interpol_mod, only: LegendreGaussNodesAndWeights

    call LegendreGaussNodesAndWeights(N_NODES-1,nodes,ws)
    nodes = 0.5_dp*nodes
    ws = 0.5_dp*ws

end subroutine

subroutine analyze_cb(quad)

    use setup_config_mod
    use equations_const_mod

    use equations_mod, only: pressure
    use mesh_types_mod, only: quad_t
    use quad_utils_mod, only: quad_get_volumes
    use quad_utils_mod, only: quad_get_coords
    use setup_manufacsol_mod
    use share_mod, only: rt => runtime

    type(quad_t), intent(inout) :: quad

    real(dp) :: coords(N_NODES,N_NODES,N_NODES,N_DIMS)

    real(dp), dimension(N_NODES,N_NODES,N_NODES) :: dens, momx, momy, momz, etot, ekin, eint, epot
    real(dp) :: vols(N_NODES,N_NODES,N_NODES)

    real(dp) :: u(N_NODES,N_NODES,N_NODES,N_VARS)

    real(dp) :: xs(N_NODES)
    real(dp) :: ys(N_NODES)
    real(dp) :: zs(N_NODES)

    real(dp) :: time

    integer :: i,j,k, ii,jj,kk

    vols = quad_get_volumes(quad)
    coords = quad_get_coords(quad)

    time = rt%simtime

    u = 0.0_dp
    do k = 1,N_NODES; do j = 1,N_NODES; do i = 1,N_NODES;
        xs = coords(i,j,k,1) + quad%delta(1)/REAL(N_NODES,dp)*nodes
        ys = coords(i,j,k,2) + quad%delta(2)/REAL(N_NODES,dp)*nodes
        zs = coords(i,j,k,3) + quad%delta(3)/REAL(N_NODES,dp)*nodes

        do kk = 1,N_NODES; do jj = 1,N_NODES; do ii = 1,N_NODES;
            u(i,j,k,:) = u(i,j,k,:) + ws(ii)*ws(jj)*ws(kk)*init_manufacsol(time,xs(ii),ys(jj),zs(kk))
        end do; end do; end do
    end do; end do; end do

    dens = quad%pld%hydro%state(:,:,:,DENS_VAR)
    momx = quad%pld%hydro%state(:,:,:,MOMX_VAR)
    momy = quad%pld%hydro%state(:,:,:,MOMY_VAR)
    momz = quad%pld%hydro%state(:,:,:,MOMZ_VAR)
    etot = quad%pld%hydro%state(:,:,:,ENER_VAR)

    !$omp critical
    sums(idens) = sums(idens) + sum(vols * dens)
    sums(imomx) = sums(imomx) + sum(vols * momx)
    sums(imomy) = sums(imomy) + sum(vols * momy)
    sums(imomz) = sums(imomz) + sum(vols * momz)
    sums(ietot) = sums(ietot) + sum(vols * etot)

    sums(idl2norm) = sums(idl2norm) + sum(vols*(u(:,:,:,DENS_VAR)-quad%pld%hydro%state(:,:,:,DENS_VAR))**2)
    sums(idl8norm) = max(sums(idl8norm),maxval(abs(u(:,:,:,DENS_VAR)-quad%pld%hydro%state(:,:,:,DENS_VAR))))

    sums(iel2norm) = sums(iel2norm) + sum(vols*(u(:,:,:,ENER_VAR)-quad%pld%hydro%state(:,:,:,ENER_VAR))**2)
    sums(iel8norm) = max(sums(iel8norm),maxval(abs(u(:,:,:,ENER_VAR)-quad%pld%hydro%state(:,:,:,ENER_VAR))))
    !$omp end critical

end subroutine

subroutine hook_analyze_500

    use mesh_utils_mod, only: mesh_iterate_quads
    use mpi_f08, only: mpi_reduce,MPI_SUM,MPI_DOUBLE_PRECISION

    use utils_mod, only: incr, write2file
    use share_mod, only: mesh, rt => runtime

    use setup_config_mod, only: dt_analyze

    integer :: ierr
    integer :: cnt = 0
    real(dp) :: resBuf(99)
    real(dp) :: recv(1:SUMS_LEN) !! mpi accumulator

    if (rt%simtime < nextanalyze) return

    nextanalyze = rt%simtime + dt_analyze

    sums = 0.0

    call mesh_iterate_quads(mesh,analyze_cb)

    call mpi_reduce(sums,recv,SUMS_LEN, MPI_DOUBLE_PRECISION, MPI_SUM, 0, rt%mpi%comm, ierr)

    if (rt%mpi%root) then
        cnt = 0

        resBuf(incr(cnt)) = rt%simtime
        resBuf(incr(cnt)) = rt%maxtimestep
        resBuf(incr(cnt)) = recv(idens)
        resBuf(incr(cnt)) = recv(ietot)

        resBuf(incr(cnt)) = sums(idl8norm) / REAL(rt%mpi%size,dp)
        resBuf(incr(cnt)) = SQRT(sums(idl2norm))

        resBuf(incr(cnt)) = sums(iel8norm) / REAL(rt%mpi%size,dp)
        resBuf(incr(cnt)) = SQRT(sums(iel2norm))

        call write2file(fpath, cnt, resBuf)
    end if

end subroutine

end module


! Copyright 2016 Krysta M Bouzek
!
! Licensed under the Apache License, Version 2.0 (the "License");
! you may not use this file except in compliance with the License.
! You may obtain a copy of the License at

!    http://www.apache.org/licenses/LICENSE-2.0

!    Unless required by applicable law or agreed to in writing, software
!    distributed under the License is distributed on an "AS IS" BASIS,
!    WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
!    See the License for the specific language governing permissions and
!    limitations under the License.

module ndcg_test
	use ranking_ndcg
	implicit none
contains
	subroutine assert_almost_equal_r8(expected, actual, name)
		real, intent(in) :: expected, actual
		character(len=*), intent(in) :: name

		if (abs(actual - expected) > tol) then
			write (*, *) '*** ', name, ' not equal to : ', expected, actual
		end if

	end subroutine assert_almost_equal_r8

	subroutine assert_same_int(x, xcopy)
		integer, intent(in), dimension(:) :: x, xcopy

		if ((size(x) .NE. size(xcopy)) .OR. any(x .NE. xcopy)) then
			write (*, *) '*** Arrays not equal'
			write(*, *) x
			write(*, *) xcopy
		end if
	end subroutine assert_same_int

	subroutine assert_cg(relevance, expected)
		! TODO use an actual unit test framework
		! sadly most seem to rely on Ruby
		integer, intent(in), dimension(:) :: relevance
		integer, intent(in) :: expected
		integer :: actual

		actual = rank_cg(relevance)

		if (actual .NE. expected) then
			write (*, *) '*** Cumulative gain not equal to : ', expected, actual
		end if
	end subroutine assert_cg

	subroutine assert_log2(x, expected)
		real, intent(in), dimension(:) :: x, expected
		real, dimension(size(x)) :: actual
		actual = log2(x * 1.0)

		if (any(abs(actual - expected) > tol)) then
			write (*, *) '*** log2 not equal to : ', expected, 'got ', actual
		end if
	end subroutine

	subroutine assert_dcg(x, alternate, expected)
		integer, intent(in), dimension(:) :: x
		real, intent(in) :: expected
		integer, dimension(size(x)) :: xcopy
		logical :: alternate

		xcopy = x
		call assert_almost_equal_r8(rank_dcg(x, alternate), expected, 'DCG')
		call assert_same_int(xcopy, x)

	end subroutine assert_dcg

	subroutine assert_idcg(x, alternate, expected)
		integer, intent(in), dimension(:) :: x
		real, intent(in) :: expected
		integer, dimension(size(x)) :: xcopy
		logical :: alternate

		xcopy = x
		call assert_almost_equal_r8(rank_idcg(x, alternate), expected, 'IDCG')
		call assert_same_int(xcopy, x)

	end subroutine assert_idcg

	subroutine assert_ndcg(x, nranks, alternate, expected)
		integer, intent(in), dimension(:) :: x
		real, intent(in) :: expected
		integer, dimension(size(x)) :: xcopy
		integer :: nranks
		real :: actual
		logical :: alternate

		xcopy = x
		actual = rank_ndcg(x, nranks, alternate)
		call assert_almost_equal_r8(actual, expected, 'NDCG')
		call assert_same_int(xcopy, x)

	end subroutine assert_ndcg

end module ndcg_test

program test_ndcg
	use ndcg_test
	implicit none
	integer, dimension(0) :: empty_array
	integer :: i

	!!! Test pad() !!!

	! pad larger
	call assert_same_int((/7, 4, 3, 0, 0/), pad((/7, 4, 3/), 0, 5))
	call assert_same_int((/7, 4, 3, 3, 3/), pad((/7, 4, 3/), 3, 5))

	! pad smaller
	call assert_same_int((/7, 4, 3/), pad((/7, 4, 3/), 0, 0))
	call assert_same_int((/99, 43, 3, 0, 1/), pad((/99, 43, 3, 0, 1/), 0, 3))
	call assert_same_int((/99, 43, 3, 4, 5/), pad((/99, 43, 3, 4, 5/), 5, 3))

	! pad exact
	call assert_same_int((/99, 43, 3, 0, 1/), pad((/99, 43, 3, 0, 1/), 0, 5))

	!!! Test CG !!!

	! test cumulative gain for zeros / empty array
	call assert_cg((/0, 0, 0/), 0)
	call assert_cg((/0, 0, 0/), 0)
	call assert_cg(empty_array, 0)
	call assert_cg(empty_array, 0)

	call assert_cg((/3, 2, 3, 0, 1, 2/), 11)
	! order should not matter for cumulative gain
	call assert_cg((/3, 3, 2, 1, 0, 2/), 11)

	call assert_log2((/3.0, 4.0, 5.6/), (/1.5849625, 2.0, 2.48542683/))
	! make sure it works with a do loop constructor
	call assert_log2((/ (i, i=2, 5) /) * 1.0, (/1.0 , 1.58496, 2.0, 2.321928/))

	!!! Test DCG !!!
	! empty
	call assert_dcg(empty_array, .TRUE., 0.0)
	call assert_dcg(empty_array, .FALSE., 0.0)

	! zeros
	call assert_dcg((/0, 0, 0/), .TRUE., 0.0)
	call assert_dcg((/0, 0, 0/), .FALSE., 0.0)

	! from wikipedia
	! standard formulation
	call assert_dcg((/1, 1, 0, 1/), .FALSE., 2.5)
	call assert_dcg((/8, 9, 1, 0, 2/), .FALSE., 18.4922829)
	call assert_dcg((/3, 2, 3, 0, 1, 2/), .FALSE., 8.0971714)

	! check alternate DCG implementation
	call assert_dcg((/1, 1, 0, 1/), .TRUE., 2.0616063)
	call assert_dcg((/8, 9, 1, 0, 2 /), .TRUE., 579.0656625)

	!!!! test ideal DCG !!!
	! empty
	call assert_idcg(empty_array, .TRUE., 0.0)
	call assert_idcg(empty_array, .FALSE., 0.0)

	! zeros
	call assert_idcg((/0, 0, 0, 0/), .TRUE., 0.0)
    call assert_idcg((/0, 0, 0, 0/), .FALSE., 0.0)

	! from wikipedia
	! order is irrelevant
    call assert_idcg((/3, 2, 3, 0, 1, 2/), .FALSE., 8.6925361)
	call assert_idcg((/3, 2, 0, 3, 2, 1/), .FALSE., 8.6925361)

	!!! test NDCG !!!!

    ! zeros
	call assert_ndcg((/0, 0, 0, 0/), 2, .TRUE., 0.0)
	call assert_ndcg((/0, 0, 0, 0/), 2, .FALSE., 0.0)
	call assert_ndcg((/0, 0, 0, 0/), 4, .TRUE., 0.0)
	call assert_ndcg((/0, 0, 0, 0/), 4, .FALSE., 0.0)
	call assert_ndcg((/0, 0, 0, 0/), 6, .TRUE., 0.0)
	call assert_ndcg((/0, 0, 0, 0/), 6, .FALSE., 0.0)

	! empty array
	call assert_ndcg(empty_array, 2, .TRUE., 0.0)
	call assert_ndcg(empty_array, 2, .FALSE., 0.0)
	call assert_ndcg(empty_array, 4, .TRUE., 0.0)
	call assert_ndcg(empty_array, 4, .FALSE., 0.0)
	call assert_ndcg(empty_array, 6, .TRUE., 0.0)
	call assert_ndcg(empty_array, 6, .FALSE., 0.0)

    ! from wikipedia
    call assert_ndcg((/3, 2, 3, 0, 1, 2/), 6, .FALSE., 0.9315085)

	! is nranks respected?
    call assert_ndcg((/3, 2, 3, 0/), 4, .FALSE., 0.9491769)
    call assert_ndcg((/3, 2, 3/), 4, .FALSE., 0.9491769)

end program test_ndcg


program rotsizetest
  use flips

  implicit none

  type(flips_d) :: gg
  integer :: nsize, bufsize, n, id
  real(dp) :: ts, te, total
  real(dp), dimension(:), allocatable :: arow
  real(dp), dimension(:), allocatable :: yrow
  real(dp) ,dimension(1) :: error

  write(*,*) 'Give the number of unknowns:'
  read(*,*) nsize
  write(*,*) 'Give the size of the rotation buffer:'
  read(*,*) bufsize
  write(*,*) 'Give file idnum (zero uses memory):'
  read(*,*) id

  error = 1.0D0

  ! initialize
  if (id <= 0) then
     call flips_init(gg,nsize,1,buffersize=bufsize)
  else
     call flips_init(gg,nsize,1,idnum=id,buffersize=bufsize)
  end if

  allocate(arow(nsize**2),yrow(nsize))

  total = 0.0D0

  ! Main loop
  !do n = 1,nsize

  ! Create data
  call random_number(arow)
  call random_number(yrow)
  !yrow = 1.0

  ! add to flips
  call cpu_time(ts)
  call flips_add(gg,nsize,arow,yrow)
  call cpu_time(te)
  total = total + (te-ts)

  !end do

  ! make the last rotation
  call cpu_time(ts)
  call make_rotations_d(gg)
  call cpu_time(te)

  total = total + (te-ts)

  write(*,*) 'Total CPU time for rotations:',total

  !	write(*,*) gg%solexists

  ! Solve (do not calculate residual)
  call cpu_time(ts)
  call flips_solve(gg,.FALSE.)
  call cpu_time(te)

  total = te - ts

  write(*,*) 'Total CPU time for solving:', total

  !	write(*,*) gg%solexists

  ! Calculate residual

  !	 write(*,*) 'TMPRES:',gg%tmpres

  call cpu_time(ts)
  call calculate_residual_d(gg)
  call cpu_time(te)

  total = te-ts

  write(*,*) 'Residual calculation time:', total
  write(*,*) 'Residual:',gg%residual

  ! Calculate covariance (DIAGONAL)
  call cpu_time(ts)
  call flips_calc_cov(gg,full=.FALSE.)
  call cpu_time(te)

  write(*,*) 'Covariance (diag) calc time:',te-ts

  !if (allocated(gg%cmat)) deallocate(gg%cmat)
  !print*, "hep"

  !call print_info_s(gg)

  !if (allocated(gg%cmat)) deallocate(gg%cmat)

  !call print_info_s(gg)

  ! Calculate covariance (FULL)
  call cpu_time(ts)
  call flips_calc_cov(gg,full=.TRUE.)
  call cpu_time(te)

  write(*,*) 'Covariance (full) calc time:',te-ts

 ! call print_info_d(gg)

  call flips_kill(gg)

  deallocate(arow)

end program rotsizetest


      function rsimp(f,r,irn,dx)
c===================
c     radial integration via simpson
c
      implicit real*8 (a-h,o-z)
c
      dimension f(*),r(*)
c
      isw=0
      rsimp=0.d0
      if(irn.le.2) return
      if(irn/2*2.eq.irn) isw=1
      np=irn-isw
      s=f(1)*r(1)+f(np)*r(np)
      nl=np-1
      do i=2,nl,2
        s=s+4.d0*f(i)*r(i)
      end do
      nl=nl-1
      if(nl.lt.3) goto 15
      do i=3,nl,2
        s=s+2.d0*f(i)*r(i)
      end do
   15 s=s*dx/3.d0
      if(isw.eq.1) goto 30
      rsimp=s
      return
   30 rsimp=s+(f(irn)*r(irn)+f(irn-1)*r(irn-1))*0.5d0*dx
      return
      end