c***********************************************************************
c> \file orrcolchan.f
c> \brief Solves the Orr-Sommerfeld equation for incompressible
c>        planar channel flow
c> \author S. Scott Collis
c***********************************************************************
      program Orr_col
c***********************************************************************
c
c     Purpose:  This program solves the Orr-Sommerfeld equation using a
c               Chebyshev-collocation method for channel flow.
c
c     Author:   S. Scott Collis
c
c     Date:     2-29-92
c
c     Revision: 9-18-92
c
c***********************************************************************
c     Common variables
c***********************************************************************
      parameter   (idim=1024)
      integer     n
      real        eta(0:idim), th(0:idim), lmap
      real        m1(0:idim), m2(0:idim), m3(0:idim), m4(0:idim)
      real        c(0:idim), u(0:idim), d1u(0:idim), d2u(0:idim), Re
      real        D1(0:idim,0:idim), D2(0:idim,0:idim)
      real        D3(0:idim,0:idim), D4(0:idim,0:idim)
      complex     A1(0:idim,0:idim), A2(0:idim,0:idim)
      complex     A3(0:idim,0:idim), A4(0:idim,0:idim)
      complex     A0(0:idim,0:idim), B0(0:idim,0:idim)
      complex     B1(0:idim,0:idim), B2(0:idim,0:idim)
      complex     v(0:idim), alpha, omega(0:idim)
      character*1 type

      common      /data/   n,eta,th,m1,m2,m3,m4,c,u,d1u,d2u,Re,v,
     &                     alpha,omega,type
      common      /deriv/  D1,D2,D3,D4,lmap
      common      /matrix/ A4, A3, A2, A1, A0, B2, B1, B0
c***********************************************************************
      real        alphar, alphai
c
c     Setup IMSL workspace
c
c      REAL             RWKSP(200000)
c      COMMON /WORKSP/  RWKSP
c      call IWKIN(200000)
c
c     User input
c
      write (*,10)
  10  format (/,/,10x,'Solve Orr-Sommerfeld (Collocation)')
      write (*,20)
  20  format (/,1x,'Enter the number of modes ==> ',$)
      read (*,*) n
      write (*,30)
  30  format (/,1x,'Enter Reynolds number ==> ',$)
      read (*,*) Re
      write (*,40)
  40  format (/,1x,'Enter alpha (R,I) ==> ',$)
      read (*,*) alphar, alphai

      alpha = cmplx (alphar, alphai)

      call MAKE_DERIVATIVES
      call MAKE_CHANNEL_METRICS

      call INIT_CHANNEL_PROFILE

      call MAKE_MATRIX
      call SOLVE_ORR_SOM

      stop
      end

C***********************************************************************
      subroutine MAKE_DERIVATIVES
C***********************************************************************
C
C     Make the required matrices that take derivatives in Chebyshev
C     space
C
c***********************************************************************
c     Common variables
c***********************************************************************
      parameter   (idim=1024)
      integer     n
      real        eta(0:idim), th(0:idim), lmap
      real        m1(0:idim), m2(0:idim), m3(0:idim), m4(0:idim)
      real        c(0:idim), u(0:idim), d1u(0:idim), d2u(0:idim), Re
      real        D1(0:idim,0:idim), D2(0:idim,0:idim)
      real        D3(0:idim,0:idim), D4(0:idim,0:idim)
      complex     A1(0:idim,0:idim), A2(0:idim,0:idim)
      complex     A3(0:idim,0:idim), A4(0:idim,0:idim)
      complex     A0(0:idim,0:idim), B0(0:idim,0:idim)
      complex     B1(0:idim,0:idim), B2(0:idim,0:idim)
      complex     v(0:idim), alpha, omega(0:idim)
      character*1 type

      common      /data/   n,eta,th,m1,m2,m3,m4,c,u,d1u,d2u,Re,v,
     &                     alpha,omega,type
      common      /deriv/  D1,D2,D3,D4,lmap
      common      /matrix/ A4, A3, A2, A1, A0, B2, B1, B0
c***********************************************************************
      integer  m, p, LDD, i, j, k
      real     Identity(0:idim,0:idim), D1hat(0:idim,0:idim)

      LDD = idim
      call CHEBYD (D1hat, LDD, n)
      call CHEBYD (D1   , LDD, n)
c
c     We enforce the Neumann boundary conditions indirectly by setting
c     v' = 0 at 0 and n.  NOTE THAT D1-D4 SHOULD ONLY BE APPLIED TO THE
c     v FIELD ONLY.
c
      do i = 0, n
        D1(0,i) = 0.0
        D1(N,i) = 0.0
      end do
C
C     To get higher derivatives just do matrix multiplication
C
      do i = 0, n
        do j = 0, n
          D2(i,j) = 0.0
          do k = 0, n
            D2(i,j) = D2(i,j) +  D1hat(i,k)*D1(k,j)
          end do
        end do
      end do
      do i = 0, n
        do j = 0, n
          D3(i,j) = 0.0
          do k = 0, n
            D3(i,j) = D3(i,j) +  D1hat(i,k)*D2(k,j)
          end do
        end do
      end do
      do i = 0, n
        do j = 0, n
          D4(i,j) = 0.0
          do k = 0, n
            D4(i,j) = D4(i,j) +  D1hat(i,k)*D3(k,j)
          end do
        end do
      end do

c      CALL WRRRN ('D1', N+1, N+1, D1, LDd+1, 0)
c      CALL WRRRN ('D2', N+1, N+1, D2, LDd+1, 0)
c      CALL WRRRN ('D3', N+1, N+1, D3, LDd+1, 0)
c      CALL WRRRN ('D4', N+1, N+1, D4, LDd+1, 0)

      return
      end

C***********************************************************************
      subroutine MAKE_CHANNEL_METRICS
C***********************************************************************
C
C     Setup the collocation points in the mapped coordinate, eta and in
C     chebyshev space, th.  Also compute the transformation metrics.
C
c***********************************************************************
c     Common variables
c***********************************************************************
      parameter   (idim=1024)
      integer     n
      real        eta(0:idim), th(0:idim), lmap
      real        m1(0:idim), m2(0:idim), m3(0:idim), m4(0:idim)
      real        c(0:idim), u(0:idim), d1u(0:idim), d2u(0:idim), Re
      real        D1(0:idim,0:idim), D2(0:idim,0:idim)
      real        D3(0:idim,0:idim), D4(0:idim,0:idim)
      complex     A1(0:idim,0:idim), A2(0:idim,0:idim)
      complex     A3(0:idim,0:idim), A4(0:idim,0:idim)
      complex     A0(0:idim,0:idim), B0(0:idim,0:idim)
      complex     B1(0:idim,0:idim), B2(0:idim,0:idim)
      complex     v(0:idim), alpha, omega(0:idim)
      character*1 type

      common      /data/   n,eta,th,m1,m2,m3,m4,c,u,d1u,d2u,Re,v,
     &                     alpha,omega,type
      common      /deriv/  D1,D2,D3,D4,lmap
      common      /matrix/ A4, A3, A2, A1, A0, B2, B1, B0
c***********************************************************************
      real       pi, dth
      integer    i

      pi  = ACOS(-1.0)
      dth = pi/FLOAT(n)
c
c     Make mesh in transformed, eta, and Chebyshev space, th
c
      do i = 0, n
        th(i) = FLOAT(i)*dth
        eta(i) = COS(th(i))
      end do

      return
      end

C***********************************************************************
      subroutine INIT_CHANNEL_PROFILE
C***********************************************************************
C
C     Setup the initial channel profile
C
c***********************************************************************
c     Common variables
c***********************************************************************
      parameter   (idim=1024)
      integer     n
      real        eta(0:idim), th(0:idim), lmap
      real        m1(0:idim), m2(0:idim), m3(0:idim), m4(0:idim)
      real        c(0:idim), u(0:idim), d1u(0:idim), d2u(0:idim), Re
      real        D1(0:idim,0:idim), D2(0:idim,0:idim)
      real        D3(0:idim,0:idim), D4(0:idim,0:idim)
      complex     A1(0:idim,0:idim), A2(0:idim,0:idim)
      complex     A3(0:idim,0:idim), A4(0:idim,0:idim)
      complex     A0(0:idim,0:idim), B0(0:idim,0:idim)
      complex     B1(0:idim,0:idim), B2(0:idim,0:idim)
      complex     v(0:idim), alpha, omega(0:idim)
      character*1 type

      common      /data/   n,eta,th,m1,m2,m3,m4,c,u,d1u,d2u,Re,v,
     &                     alpha,omega,type
      common      /deriv/  D1,D2,D3,D4,lmap
      common      /matrix/ A4, A3, A2, A1, A0, B2, B1, B0
c***********************************************************************
      integer     i, LDD
      real        D1hat(0:idim,0:idim), D2hat(0:idim,0:idim)

      LDD = idim

      open(10)
      do i = 0, n
        u(i) = (1.-eta(i)**2)
        d1u(i) = -2.*eta(i)
        d2u(i) = -2.0
        write(10,20) eta(i), u(i), d1u(i), d2u(i)
 20     format (1x,4(es16.8e3,1x))
      end do
      close(10)
#if 0
c
c     Compute the collocation derivatives
c
      call CHEBYD (D1hat, LDD, n)
c     CALL WRRRN ('D1hat', N+1, N+1, D1hat, LDd+1, 0)
      do i = 0, n
        do j = 0, n
          D2hat(i,j) = 0.0
          do k = 0, n
            D2hat(i,j) = D2hat(i,j) +  D1hat(i,k)*D1hat(k,j)
          end do
        end do
      end do
      do i = 0, n
        d1u(i) = 0.0
        d2u(i) = 0.0
        do k = 0, n
            d1u(i) = d1u(i) + D1hat(i,k)*u(k)
            d2u(i) = d2u(i) + D2hat(i,k)*u(k)
        end do
c       write (*,10) eta(i), u(i), d1u(i), d2u(i)
c  10   format (1x,4(e12.4,1x))
      end do
#endif
      return
      end

C***********************************************************************
      subroutine MAKE_MATRIX
C***********************************************************************
C
C     This routine generates the matrices which are combined to make
C     the generalized eigenvalue problem.
C
c***********************************************************************
c     Common variables
c***********************************************************************
      parameter   (idim=1024)
      integer     n
      real        eta(0:idim), th(0:idim), lmap
      real        m1(0:idim), m2(0:idim), m3(0:idim), m4(0:idim)
      real        c(0:idim), u(0:idim), d1u(0:idim), d2u(0:idim), Re
      real        D1(0:idim,0:idim), D2(0:idim,0:idim)
      real        D3(0:idim,0:idim), D4(0:idim,0:idim)
      complex     A1(0:idim,0:idim), A2(0:idim,0:idim)
      complex     A3(0:idim,0:idim), A4(0:idim,0:idim)
      complex     A0(0:idim,0:idim), B0(0:idim,0:idim)
      complex     B1(0:idim,0:idim), B2(0:idim,0:idim)
      complex     v(0:idim), alpha, omega(0:idim)
      character*1 type

      common      /data/   n,eta,th,m1,m2,m3,m4,c,u,d1u,d2u,Re,v,
     &                     alpha,omega,type
      common      /deriv/  D1,D2,D3,D4,lmap
      common      /matrix/ A4, A3, A2, A1, A0, B2, B1, B0
c***********************************************************************
      real      rwork(0:idim), cwork(0:idim), identity(0:idim,0:idim)
      complex   work

      do i = 0, n
        do j = 0, n
          A4(i,j) = 0.0
          A3(i,j) = 0.0
          A2(i,j) = 0.0
          A1(i,j) = 0.0
          B2(i,j) = 0.0
          B1(i,j) = 0.0
          B0(i,j) = 0.0
          identity(i,j) = 0.0
        end do
        identity(i,i) = 1.0
      end do

      do i = 0, n
        do j = 0, n
          A4(i,j) = CMPLX( D4(i,j), 0.0 )
        end do
      end do

      do i = 0, n
        work = -2.0 * alpha**2 - cmplx(0.,1.)*alpha*Re*U(i)
        do j = 0, n
          A2(i,j) = work*D2(i,j)
        end do
      end do

      do i = 0, n
        work = alpha**4 + cmplx(0.,1.)*alpha**3*Re*U(i) +
     &                    cmplx(0.,1.)*alpha*Re*d2u(i)
        do j = 0, n
          A0(i,j) = work*identity(i,j)
        end do
      end do

      do i = 0, n
        work = -1.0*cmplx(0.,1.)*Re
        do j = 0, n
          B2(i,j) = work*D2(i,j)
        end do
      end do

      do i = 0, n
        work = alpha**2*cmplx(0.,1.)*Re
        do j = 0, n
          B0(i,j) = work*identity(i,j)
        end do
      end do

      return
      end

C***********************************************************************
      subroutine SOLVE_ORR_SOM
C***********************************************************************
C
C     This routine generates the discrete eigenvalue problem in
C     Chebyshev space for the Orr-Sommerfeld equation.
C
c***********************************************************************
c     Common variables
c***********************************************************************
      parameter   (idim=1024)
      integer     n
      real        eta(0:idim), th(0:idim), lmap
      real        m1(0:idim), m2(0:idim), m3(0:idim), m4(0:idim)
      real        c(0:idim), u(0:idim), d1u(0:idim), d2u(0:idim), Re
      real        D1(0:idim,0:idim), D2(0:idim,0:idim)
      real        D3(0:idim,0:idim), D4(0:idim,0:idim)
      complex     A1(0:idim,0:idim), A2(0:idim,0:idim)
      complex     A3(0:idim,0:idim), A4(0:idim,0:idim)
      complex     A0(0:idim,0:idim), B0(0:idim,0:idim)
      complex     B1(0:idim,0:idim), B2(0:idim,0:idim)
      complex     v(0:idim), alpha, omega(0:idim)
      character*1 type

      common      /data/   n,eta,th,m1,m2,m3,m4,c,u,d1u,d2u,Re,v,
     &                     alpha,omega,type
      common      /deriv/  D1,D2,D3,D4,lmap
      common      /matrix/ A4, A3, A2, A1, A0, B2, B1, B0
c***********************************************************************
      complex     A(0:idim,0:idim), B(0:idim,0:idim), alp(0:idim)
      complex     T1(0:idim,0:idim), T2(0:idim,0:idim)
      complex     T3(0:idim,0:idim), T4(0:idim,0:idim)
      complex     beta(0:idim), evec(0:idim,0:idim), temp3(0:idim)
      complex     avec(0:idim,0:idim)
      complex     evec2(0:idim,0:idim), eval(0:idim)
      complex     P1(0:idim,0:idim), P2(0:idim,0:idim)
      real        temp1(0:idim), temp2(0:idim), CHECKEIG, nw
      integer     lda, ldb, ldevec, p, i, j, which, k, l, m
      complex     eigenvalue, eigenvector(0:idim), tvec(0:idim)
      integer     index(0:idim)
      logical     first, print
      external    CHECKEIG

      integer     info, lwork, ipvt(0:idim)
      complex     work(16*(idim+1))
      real        rwork(8*(idim+1))

      complex     zdotc, escale
      external    zdotc
C***********************************************************************
      lwork = 16*(idim+1)

      lda = idim+1
      ldb = idim+1
      ldevec = idim+1
c
c.... Build the matrix system
c
      do i = 0, n
        do j = 0, n
          A(i,j) = A4(i,j)+A3(i,j)+A2(i,j)+A1(i,j)+A0(i,j)
          B(i,j) = B2(i,j)+B1(i,j)+B0(i,j)
        end do
      end do
c
c     Now enforce the v = 0 @ +_ 1 boundary condition instead of the
c     Orr-Sommerfeld equation at n = 0 and n = N.  The Neumann
c     boundary condition is implicitly enforced.
c
      do j = 0, n
        B(0,j) = CMPLX(0.0, 0.0)
        B(j,0) = CMPLX(0.0, 0.0)
        B(n,j) = CMPLX(0.0, 0.0)
        B(j,n) = CMPLX(0.0, 0.0)
        A(0,j) = CMPLX(0.0, 0.0)
        A(j,0) = CMPLX(0.0, 0.0)
        A(n,j) = CMPLX(0.0, 0.0)
        A(j,n) = CMPLX(0.0, 0.0)
      end do
      A(0,0) = CMPLX(1.0, 0.0)
      A(n,n) = CMPLX(1.0, 0.0)
c
c.... Solve the eigenvalue problem
c
#ifdef USE_ISML
c
c.... The top and bottom rows are trivial so that they could be removed
c
      CALL LINCG (N-1, B, LDA, T1, LDA)
      CALL MCRCR (N-1, N-1, T1, LDA, N-1, N-1, A, LDA,
     &            N-1, N-1, T4, LDA)

      CALL EVCCG (N-1, T4, LDA, eval, evec, ldevec)
#else
      if (.false.) then
c
c.... Cannot use this as B is singular
c
         call ZGETRF(N+1, N+1, B, lda, ipvt, info)
         call ZGETRS('N', N+1, N+1, B, lda, ipvt, A, lda, info)
         call ZGEEV('V', 'V', N+1, A, lda, eval, avec,
     &              lda, evec, lda, work, lwork, rwork, info)
      else
c
c.... Use generalized engenvalue solver
c
         call ZGEGV( 'V', 'V', N+1, A, LDA, B, LDA, alp, beta, avec,
     &               LDA, evec, LDA, work, lwork, rwork, info)
c
c.... compute the eigenvalues as ratios of alp and beta
c
         do i = 0, N
           if (beta(i).ne.0) then
             eval(i) = alp(i)/beta(i)
           else
             eval(i) = 0.0
           end if
         end do
      end if
#endif
c
c     Sort the eigenvalues.
c
      do i = 0, N
        temp2(i) = IMAG(eval(i))
        index(i) = i
      end do

c     Need to issolate the most unstable eigenvalue and eigenvector
c     Must watch out, this routine isn't very robust.

      call PIKSR2(n+1,temp2,index)
      do i = 0, N
         temp1(i) = real(eval(index(i)))
         do j = 0, N
            A(j,i) = evec(j,index(i))
            B(j,i) = avec(j,index(i))
         end do
      end do

      do i = 0, N
         eval(i) = cmplx(temp1(i),temp2(i))
         do j = 0, N
            evec(j,i) = A(j,i)
            avec(j,i) = B(j,i)
         end do
      end do

      write (*,50) N+1
  50  format (/,1x,'Eigenvalues for N+1 = ',i4,/)
c
c     Print eigenvalues
c
      do i = 0, N
        omega(i) = eval(i)
        write (*,35) i, REAL(omega(i)), IMAG(omega(i)),
     &               REAL(omega(i)/alpha), IMAG(omega(i)/alpha)
  35    format (1x,i5,2x,4(1pe17.10,1x))
      end do

      escale = 0.0
      write (*,40)
      read (*,*) which
      do while (which .ne. -1)

        eigenvalue = eval(which)
        do i = 0, N
          eigenvector(i) = evec(i,which)
        end do
c       write (*,*) CHECKEIG(N-1,T4,lda,eigenvalue,eigenvector)
c
c.... normalize the eigenvector
c
        do i = 0, N
          if (abs(evec(i,which)) .gt. abs(escale)) then
            escale = evec(i,which)
          endif
        end do
        escale = 1.0/(escale)
        call zscal( N+1, escale, evec(0,which), 1)
c
c.... check the orthogonality of the adjoint and regular eigenvectors
c
        escale = zdotc( N+1, avec(0,which), 1, evec(0,which), 1 )
        write(*,*) escale
c
c.... scale the adjoint by the inner product
c
        escale = 1.0/conjg(escale)
        call zscal( N+1, escale, avec(0,which), 1)
        escale = zdotc( N+1, avec(0,which), 1, evec(0,which), 1 )
        write(*,*) escale

c       call CHEBYSHEV(temp1,n,1)
c       call CHEBYSHEV(temp2,n,1)
        open(10)
        do i = 0, N
          write (11,999) eta(i),
     &                   real(evec(i,which)), aimag(evec(i,which)),
     &                   real(avec(i,which)), aimag(avec(i,which))
 999      format (1x,6(ES16.8E3,1x))
        end do
        close(11)
c
c.... Interpolate to a finer mesh
c
        if (.false.) then
         do i = 1, n
           temp1(i) = REAL(avec(i,which))
           temp2(i) = IMAG(avec(i,which))
         end do
         call CHEBYINT(n, temp1, temp2, 256)
         end if

        write (*,40)
        read (*,*) which
      end do
 40   format (/,1x,'Eigenvector for which eigenvalue (-1 quits) ==> ',$)

      return
      end

C***********************************************************************
      function CHECKEIG(N,A,LDA,EVAL,EVEC)
C***********************************************************************
C
C     Check an eigenvalue and eigenvector
C
C***********************************************************************
      PARAMETER (idim=1024)

      integer    N
      complex    A(LDA,N), EVAL, EVEC(N)
      complex    X(idim), Y(idim)
      real       CHECKEIG
#ifdef USE_IMSL
      CALL MUCRV (N, N, A, LDA, N, EVEC, 1, N, X)
#else
      CALL ZGEMV ('N', N, N, 1.0, A, LDA, EVEC, 1, 0.0, X, 1)
#endif
      CHECKEIG = 0.0
      DO I = 1, N
        CHECKEIG = CHECKEIG + ABS(X(I)-EVAL*EVEC(I))
      END DO
      CHECKEIG = CHECKEIG/FLOAT(N)

      RETURN
      END

C***********************************************************************
      SUBROUTINE DCHEBYSHEV(N, Y, DY)
C***********************************************************************
C
C     Calculate the Chebyshev transform of a set Y of N+1 real-valued
C     data points and compute the derivative in Chebyshev space.
C     Then inverse transform and return the derivative in DY in real
C     space.  Note that Y is returned unscathed.
C
C***********************************************************************
      INTEGER N
      REAL Y(0:N), DY(0:N)

      PARAMETER (idim=1024)
      REAL WORK(0:IDIM)

      IF (N.GT.IDIM) THEN
        WRITE (*,*) 'ERROR.  N > IDIM in DCHEBYSHEV'
        STOP
      END IF
C
C     SAVE THE INPUT VECTOR
C
      DO I = 0, N
        WORK(I) = Y(I)
      END DO
C
C     COMPUTE THE CHEBYSHEV TRANSFORM
C
      CALL CHEBYSHEV(Y,N,1)
C
C     NOW USE THE RECURSIVE RELATION TO TAKE THE DERIVATIVE
C
      DY(N) = 0.0
      DY(N-1) = 2.*FLOAT(N)*Y(N)
      DO K = N-2, 0, -1
        DY(K) = DY(K+2) + 2.*(K+1.)*Y(K+1)
      END DO
      DY(0) = DY(0)/2.
C
C     INVERSE TRANSFORM TO GET BACK TO REAL SPACE
C
      CALL CHEBYSHEV(DY,N,-1)

      DO I = 0, N
        Y(I) = WORK(I)
      END DO

      RETURN
      END

C***********************************************************************
      SUBROUTINE ICHEBYSHEV(Y,YI,N)
C***********************************************************************
C
C     Calculate the Chebyshev transform of a set Y of N+1 real-valued
C     data points and integrate in Chebyshev space.  The integral is
C     returned in real space in YI and Y is unscathed.
C
C***********************************************************************
      REAL Y(0:N), YI(0:N+1)
      PARAMETER (idim=1024)
      REAL WORK(0:IDIM)

      DO I = 0, N
        WORK(I) = Y(I)
      END DO
C
C     COMPUTE THE CHEBYSHEV TRANSFORM
C
      CALL CHEBYSHEV(Y,N,1)
C
C     NOW INTEGRATE
C     NOTE I AM ASSUMING THAT Y(N) IS SMALL SUCH THAT YI(N+1) = 0.0
C
      YI(N+1) = Y(N)/(2.*(N+1.))
      YI(N) = Y(N-1)/(2.*N)
      YI(1) = 1./2.*(2.*Y(0)-Y(2))
      YI(0) = YI(1)
      DO K = 2, N-1
        YI(K) = 1./(2.*K)*(Y(K-1)-Y(K+1))
        YI(0) = YI(0) + (-1.)**(K-1)*YI(K)
      END DO

      CALL CHEBYSHEV(YI,N,-1)
      DO I = 0, N
        Y(I) = WORK(I)
      END DO

      RETURN
      END

C***********************************************************************
      SUBROUTINE CHEBYINT(nmode,U,V,NBIG)
C***********************************************************************
C
C     Interpolate two functions to a finer mesh
C
c***********************************************************************
      INTEGER   NBIG, nmode
      REAL      U(0:Nmode), V(0:Nmode)
      REAL      IU, IV, X, PI

      PI = ACOS(-1.0)

      call CHEBYSHEV (U,nmode,1)
      call CHEBYSHEV (V,nmode,1)

      open(30)
      do i = 0, NBIG
        X = I*PI/NBIG
        IU = 0.0
        IV = 0.0
        DO M = 0, Nmode
          IU = IU + U(M)*COS(FLOAT(M)*X)
          IV = IV + V(M)*COS(FLOAT(M)*X)
        END DO
        write (30,10) cos(x), Iu, Iv
      end do
      close(30)
  10  format (1x,3(es16.8e3,1x))

      RETURN
      END

C************************************************************************
      SUBROUTINE COSFT3 (Y,N,ISIGN)
C************************************************************************
C
C     Do a brute force transform.  ISIGN = 1 does a forward transform.
C     ISIGN = -1 a backward transform.  This is a hybrid double/single
C     precision routine.
C
C************************************************************************
      integer     N, ISIGN
      real        Y(0:N), T(0:N)
      real*16     YY(0:N), TT(0:N), PI

      PI = DACOS(-1.0D0)

      DO I = 0, N
        TT(I) = DBLE(Y(I))
      END DO

      if (isign .eq. 1) then
        DO I = 0, N
          YY(I) = TT(0)/2.D0 + TT(N)*COS(DFLOAT(I)*PI)/2.D0
          DO M = 1, N-1
            YY(I) = YY(I) + TT(M)*COS(DFLOAT(M)*DFLOAT(I)*PI/DFLOAT(N))
          END DO
          YY(I) = YY(I)*2./DFLOAT(N)
        end do
        YY(0) = YY(0)/2.D0
        YY(N) = YY(N)/2.D0
      else
        DO I = 0, N
          YY(I) = 0.0
          DO M = 0, N
            YY(I) = YY(I) + TT(M)*COS(DFLOAT(M)*DFLOAT(I)*PI/DFLOAT(N))
          END DO
        END DO
      end if
C
C     GO BACK TO SINGLE PRECISION
C
      DO I = 0, N
        if (Y(i).le.1e-14) then
          Y(I) = 0.0
        end if
        Y(I) = SNGL(YY(I))
      END DO

      RETURN
      END

C***********************************************************************
      subroutine CHEBYSHEV (Y, N, ISIGN)
C***********************************************************************
C
C     Take the Chebyshev transform and normalize
C
C***********************************************************************
      integer  n, isign
      real     y(0:n), t(0:256)

      if (isign .ne. 1) then
        if (isign .ne. -1) then
          write (*,*) 'ERROR:  Invalid Isign in CHEBYSHEV'
          stop
        end if
      end if

      do i = 1, n
        t(i) = y(i)
      end do

      call COSFT3 (y,n,isign)

C     call COSFT (y,n,isign)

C     if (isign .eq. 1) then
C       do i = 0,n
C         y(i) = y(i)/float(n)*2.
c          if (abs(y(i)) .lt. 1.e-6) then
c              y(i) = 0.0
c          end if
c           write (*,*) i, y(i)
C       end do
C    end if

      return
      end

C***********************************************************************
      subroutine CONVOLVE (NDIM, A, B, LDB, ES, LDE, C)
C***********************************************************************
C
C     Form the Chebyshev convolution of real vector A with real matrix B
C     and put the result in real matrix E.
c
c     A  double
c     B  double
c     ES single
C
C***********************************************************************
      INTEGER NDIM, LDB, LDE
      REAL    ES(0:LDE,0:NDIM), C(0:NDIM)
      REAL*16 A(0:NDIM),  B(0:LDB,0:NDIM),  E(0:LDE,0:NDIM)

      call COSFT3D (A,NDIM,1)

      DO N = 0, NDIM
        DO J = 0, NDIM
          E(N,J) = 0.0D0
        END DO
        DO M = -NDIM, NDIM
          IF (ABS(N-M).LE.NDIM) THEN
            DO J = 0, NDIM
              E(N,J) = E(N,J)+ DBLE(C(ABS(N-M))) * A(ABS(N-M)) *
     &                         DBLE(C(ABS(M)))   * B(ABS(M),J)
            END DO
          END IF
        END DO
        DO J = 0, NDIM
          E(N,J) = E(N,J)/2.D0
        END DO
      END DO
      DO J = 0, NDIM
        E(0,J) = E(0,J)/2.D0
      END DO

      DO N = 0, NDIM
        DO J = 0, NDIM
          ES(N,J) = SNGL(E(N,J))
        END DO
      END DO

      RETURN
      END

C**************************************************************************
      SUBROUTINE COSFT3D (YY,N,ISIGN)
C**************************************************************************
C
C     Do a brute force transform. ISIGN = 1 does a forward transform.
C     ISIGN = -1 a backward transform. This one is fully double precision.
C
C**************************************************************************
      integer     N, ISIGN
      real*16     YY(0:N), TT(0:N), PI

      PI = DACOS(-1.0D0)

      DO I = 0, N
        TT(I) = YY(I)
      END DO

      if (isign .eq. 1) then
        DO I = 0, N
          YY(I) = TT(0)/2.D0 + TT(N)*COS(DFLOAT(I)*PI)/2.D0
          DO M = 1, N-1
            YY(I) = YY(I) + TT(M)*COS(DFLOAT(M)*DFLOAT(I)*PI/DFLOAT(N))
          END DO
          YY(I) = YY(I)*2./DFLOAT(N)
        end do
        YY(0) = YY(0)/2.D0
        YY(N) = YY(N)/2.D0
      else
        DO I = 0, N
          YY(I) = 0.0
          DO M = 0, N
            YY(I) = YY(I) + TT(M)*COS(DFLOAT(M)*DFLOAT(I)*PI/DFLOAT(N))
          END DO
        END DO
      end if

      RETURN
      END

C**************************************************************************
      SUBROUTINE CHEBYD (D, LDD1, N)
C**************************************************************************
C
C     Calculation the Chebyshev collocation derivative matrix
C
C**************************************************************************
      PARAMETER (IDIM=1024)
      REAL      D(0:LDD1,0:N), PI
      REAL      C(0:IDIM)

      IF (N .GT. IDIM) THEN
        WRITE (*,*) 'ERROR:  N > IDIM in CHEBYD'
        STOP
      END IF

      PI = ACOS(-1.0)

      DO I = 1, N-1
        C(I) = 1.0
      END DO
      C(0) = 2.0
      C(N) = 2.0

      DO J = 0, N
        DO K = 0, N
          IF ( J.EQ.0 .AND. K.EQ.0) THEN
            D(J,K) = (2.0*FLOAT(N)**2+1.0)/6.0
          ELSE IF ( J.EQ.N .AND. K.EQ.N) THEN
            D(J,K) = -1.0*(2.*FLOAT(N)**2+1.0)/6.0
          ELSE IF (J.EQ.K) THEN
            D(J,K) =  -1.0*COS(FLOAT(J)*PI/FLOAT(N))/
     &                (2.*(1.-(COS(FLOAT(J)*PI/FLOAT(N)))**2))
          ELSE
            D(J,K) = C(J)*(-1.0)**(J+K)/(C(K)*(COS(FLOAT(J)*PI/
     &               FLOAT(N))-COS(FLOAT(K)*PI/FLOAT(N))))
          END IF
        END DO
      END DO

      RETURN
      END
C*************************************************************************
C
C     These routines are for READ_BL only!
C
C*************************************************************************
      SUBROUTINE DCHEBYSHEVF(Y,YP,N)
C*************************************************************************
C
C     Calculate the Chebyshev transform of a set Y of N+1 real-valued data
C     points and compute the derivative in Chebyshev space.  Then inverse
C     transform and return the derivative in YP and the chebyshev
C     coefficients of the derivative in Y.
C
C************************************************************************
      DIMENSION Y(0:N), YP(0:N)
C
C     NOW USE THE RECURSIVE RELATION TO TAKE THE DERIVATIVE
C
      YP(N) = 0.0
      YP(N-1) = 2.*FLOAT(N)*Y(N)
      DO K = N-2, 0, -1
        YP(K) = YP(K+2) + 2.*(K+1.)*Y(K+1)
      END DO
      YP(0) = YP(0)/2.

c     DO K = 0, N
c       Y(K) = YP(K)
c     END DO

      RETURN
      END

C***********************************************************************
      SUBROUTINE COSFT (Y,N,ISIGN)
C***********************************************************************
C
C     Do a brute force transform.  ISIGN = 1 does a forward transform.
C     ISIGN = -1 a backward transform.  This is a hybrid double/single
C     precision routine.
C
C***********************************************************************
      integer     N, ISIGN
      real        Y(0:N), T(0:N)
      real*16     YY(0:N), TT(0:N), PI

      PI = DACOS(-1.0D0)

      DO I = 0, N
        TT(I) = DBLE(Y(I))
      END DO

      if (isign .eq. 1) then
        DO I = 0, N
          YY(I) = TT(0)/2.D0 + TT(N)*COS(DFLOAT(I)*PI)/2.D0
          DO M = 1, N-1
            YY(I) = YY(I) + TT(M)*COS(DFLOAT(M)*DFLOAT(I)*PI/DFLOAT(N))
          END DO
          YY(I) = YY(I)*2./DFLOAT(N)
        end do
        YY(0) = YY(0)/2.D0
        YY(N) = YY(N)/2.D0
      else
        DO I = 0, N
          YY(I) = 0.0
          DO M = 0, N
            YY(I) = YY(I) + TT(M)*COS(DFLOAT(M)*DFLOAT(I)*PI/DFLOAT(N))
          END DO
        END DO
      end if
C
C     GO BACK TO SINGLE PRECISION
C
      DO I = 0, N
        if (Y(i).le.1e-14) then
          Y(I) = 0.0
        end if
        Y(I) = SNGL(YY(I))
      END DO

      RETURN
      END

C*************************************************************************
      SUBROUTINE CHEBYINTF(N,INTERP,X,Y)
C*************************************************************************
C
C     Do a Chebyshev interpolation based on the Chebyshev coefficients Y.
C     The interpolated result is given in INTERP.
C
C*************************************************************************
      INTEGER   N
      REAL      Y(0:N)
      REAL      INTERP, X

      INTERP = 0.0
      DO M = 0, N
        INTERP = INTERP + Y(M)*COS(FLOAT(M)*X)
      END DO

      RETURN
      END
C***********************************************************************
      SUBROUTINE SPLINE (N,X,Y,FDP)
C***********************************************************************
C-----THIS SUBROUTINE COMPUTES THE SECOND DERIVATIVES NEEDED
C-----IN CUBIC SPLINE INTERPOLATION.  THE INPUT DATA ARE:
C-----N = NUMBER OF DATA POINTS
C-----X = ARRAY CONTAINING THE VALUES OF THE INDEPENDENT VARIABLE
C-----    (ASSUMED TO BE IN ASCENDING ORDER)
C-----Y = ARRAY CONTAINING THE VALUES OF THE FUNCTION AT THE
C-----    DATA POINTS GIVEN IN THE X ARRAY
C-----THE OUTPUT IS THE ARRAY FDP WHICH CONTAINS THE SECOND
C-----DERIVATIVES OF THE INTERPOLATING CUBIC SPLINE.
      DIMENSION X(N),Y(N),A(N),B(N),C(N),R(N),FDP(N)
C-----COMPUTE THE COEFFICIENTS AND THE RHS OF THE EQUATIONS.
C-----THIS ROUTINE USES THE CANTILEVER CONDITION.  THE PARAMETER
C-----ALAMDA (LAMBDA) IS SET TO 1. BUT THIS CAN BE USER-MODIFIED.
C-----A,B,C ARE THE THREE DIAGONALS OF THE TRIDIAGONAL SYSTEM;
C-----R IS THE RIGHT HAND SIDE.  THESE ARE NOW ASSEMBLED.
      ALAMDA = 1.
      NM2 = N - 2
      NM1 = N - 1
      C(1) = X(2) - X(1)
      DO 1 I=2,NM1
      C(I) = X(I+1) - X(I)
      A(I) = C(I-1)
      B(I) = 2.*(A(I) + C(I))
      R(I) = 6.*((Y(I+1) - Y(I))/C(I) - (Y(I) - Y(I-1))/C(I-1))
    1 CONTINUE
      B(2) = B(2) + ALAMDA * C(1)
      B(NM1) = B(NM1) + ALAMDA * C(NM1)
C-----AT THIS POINT WE COULD CALL A TRIDIAGONAL SOLVER SUBROUTINE
C-----BUT THE NOTATION IS CLUMSY SO WE WILL SOLVE DIRECTLY.  THE
C-----NEXT SECTION SOLVES THE SYSTEM WE HAVE JUST SET UP.
      DO 2 I=3,NM1
      T = A(I)/B(I-1)
      B(I) = B(I) - T * C(I-1)
      R(I) = R(I) - T * R(I-1)
    2 CONTINUE
      FDP(NM1) = R(NM1)/B(NM1)
      DO 3 I=2,NM2
      NMI = N - I
      FDP(NMI) = (R(NMI) - C(NMI)*FDP(NMI+1))/B(NMI)
    3 CONTINUE
      FDP(1) = ALAMDA * FDP(2)
      FDP(N) = ALAMDA * FDP(NM1)
C-----WE NOW HAVE THE DESIRED DERIVATIVES SO WE RETURN TO THE
C-----MAIN PROGRAM.
      RETURN
      END
C***********************************************************************
      SUBROUTINE SPEVAL (N,X,Y,FDP,XX,F)
C***********************************************************************
C-----THIS SUBROUTINE EVALUATES THE CUBIC SPLINE GIVEN
C-----THE DERIVATIVE COMPUTED BY SUBROUTINE SPLINE.
C-----THE INPUT PARAMETERS N,X,Y,FDP HAVE THE SAME
C-----MEANING AS IN SPLINE.
C-----XX = VALUE OF INDEPENDENT VARIABLE FOR WHICH
C-----     AN INTERPOLATED VALUE IS REQUESTED
C-----F =  THE INTERPOLATED RESULT
      DIMENSION X(N),Y(N),FDP(N)
C-----THE FIRST JOB IS TO FIND THE PROPER INTERVAL.
      NM1 = N - 1
      DO 1 I=1,NM1
      IF (XX.LE.X(I+1)) GO TO 10
    1 CONTINUE
C-----NOW EVALUATE THE CUBIC
   10 DXM = XX - X(I)
      DXP = X(I+1) - XX
      DEL = X(I+1) - X(I)
      F = FDP(I)*DXP*(DXP*DXP/DEL - DEL)/6.
     1   +FDP(I+1)*DXM*(DXM*DXM/DEL - DEL)/6.
     2   +Y(I)*DXP/DEL + Y(I+1)*DXM/DEL
      RETURN
      END


!***************************************************************
		REAL*8 FUNCTION RHtoSVPD(Tair, Pair)
!****************************************************************
!	This function converts relative humidity and air temperature to
!	vapor pressure using the relations in Gill's Atmosphere-Ocean dynamics
!
!	use this to compute SVPD   ! ambient vapor pressure of atmosphere {mb}
!
      USE DLMWQ_VARIABLES
      USE DLMWQ_SERVICES
		IMPLICIT NONE
      SAVE
!
!	constants
!
		REAL*8 epsilon	! ratio of gas constants (dry air)/(water vapor)
		REAL*8 Ra		! gas constant for dry air {J/kg-K}
		REAL*8 Rv		! gas constant for water vapor {J/kg-K}

		PARAMETER (epsilon=0.62197,Ra=287.04,Rv=461.50)

		REAL*8 one,hundrd,dCtodK

		PARAMETER (one=1.0d0,hundrd=100.0d0,dCtodK=273.15d0)

		REAL*8 Pair		! atmospheric pressure {mb}
		REAL*8 q		! observed specific humidity
		REAL*8 qw		! specific humidity for saturated air
		REAL*8 r		! observed mixing ratio
		REAL*8 rw		! saturated mixing ratio for moist air
!IF		REAL*8 RH		! relative humidity (%)
!IF		REAL*8 RelHum		! relative humidity {decimal}
		REAL*8 RHOair		! ambient air density {kg/m^3}
!		REAL*8 RHOsurf	! density of saturated air @ surface {kg/m^3}
!		REAL*8 sign		! sign of cube root
!IF		REAL*8 SATVAP		! function to calculate saturated vapor pres.
		REAL*8 SVPair		! saturated vapor pressure at Tair {mb}
!		REAL*8 SVPD		! ambient vapor pressure of atmosphere {mb}
		REAL*8 Tair		! air temperature (C)

!
!	calculate specific humidities and densities from observed data
!
		RelHum=RH
		SVPair=SATVAP(Tair)
		rw=SVPair/(Pair-SVPair)*epsilon
		r=RelHum*rw
		qw=rw/(one+rw)
		q=r/(one+r)

		RHOair=Pair*hundrd/(Ra*(Tair+dCtodK)*(one+(-one+one/epsilon)*q))
!
!	calculate atmospheric vapor pressure for evaporative fluxes
!	into moving air, i.e. SVPD is used in bulk formula for vapor flux.
!
		RHtoSVPD = RHOair*q*Rv*(Tair+dCtodK)/hundrd

		RETURN
		END FUNCTION RHtoSVPD


! { dg-do compile }
! { dg-options "-Winteger-division" }
program main
  integer, parameter :: n = 23
  integer, parameter :: m = n*(n+1)/2  ! No warning
  integer, parameter :: i = n*(n+1)/17 ! { dg-warning "Integer division truncated to constant" }
  print *, 3/5 ! { dg-warning "Integer division truncated to constant" }
end program main


C
C
*+ image_addring

      subroutine image_addring(minirt,data,uv,ellipse_centre,
     *                         ellipse_theta, ellipse_eccen,
     *                         n_annuli, r_annuli,
     *                         flux,ndata,frac_area,status   )
C     --------------------------------------------------------
C
C To calculate the average flux in elliptical annuli
C
C Given:
C   mini redtape of image
       integer     minirt(8)
C   image data
       real*4      data(*)
C   range on image to analyse
       integer     uv(4)
C   centre of ellipse
       real*4      ellipse_centre(2)
C    eccentricity and position-angle of ellipse
       real*4      ellipse_theta, ellipse_eccen
C   number of annuli
       integer     n_annuli
C   spacing of annuli along major axis
       real*4      r_annuli
C   value above which averaging is performed
       real*4      gate
C Returned:
C   results for each annulus
C     flux
       real*4      flux(n_annuli)
C     number of data points
       integer     ndata(n_annuli)
C     fraction of correct annular arear foundd by cell averaging
       real*4      frac_area(n_annuli)
C   error return code
       integer     status
C
C The distribution of flux on an image centred at a given location
C within elliptical annuli is calculated according to the following
C algorithm.
C
C Divide image into elliptical bins and evaluate the mean flux density
C within each bin.  All the flux within a cell contributes to the bin
C enclosing the centre of that cell.  Two quantities are provided to
C estimate the usefulness of the output; the number of cells which have
C been averaged per bin; and the fraction of the correct area which has
C been evaluated by these points per bin.  Data values .le. the level
C 'gate' are not counted as valid data points
*-
C [A.J. Fitt, MRAO, Cambridge. June 1988.]
C [to NORD and ANMAP by P. Alexander, MRAO, Cambridge. June 1988.]
C [improved interface and standard coordinated, PA. 4/4/91]
C
C Local variables
C  coordinate along ellipse
       real*4      a, b
C  counters and sums
      integer      iu, iv, n, uv_point(2)
      equivalence (uv_point(1), iu)
      equivalence (uv_point(2), iv)
      real*4       x, y, value, rsq, areaconst, annarea
      real*4       sin_th, cos_th
C  constant pi
      real*4       pi
      data         pi/3.14159265/

C check status on entry
      if (status.ne.0) return

C calculate geometric values
      sin_th = sin(ellipse_theta)
      cos_th = cos(ellipse_theta)

C initialise arrays
      do n = 1,n_annuli
        flux(n) = 0.0
        ndata(n) = 0
      end do
      gate = 0.0
      do iv = uv(3),uv(4),-1
        do iu = uv(1),uv(2)
C .. find values
          call iuvval2(minirt,data,uv_point,value,status)
C .. find bin (n) containing point (x,y)
          x = float(iu) - ellipse_centre(1)
          y = float(iv) - ellipse_centre(2)
          a = -x*sin_th + y*cos_th
          b = x*cos_th + y*sin_th
          rsq = a**2 + (b*ellipse_eccen)**2
          n = sqrt(rsq)/r_annuli + 1.0
C .. add flux to correct bin
          if ((n.le.n_annuli) .and. (abs(value).gt.gate)) then
            flux(n) = flux(n) + value
            ndata(n) = ndata(n) + 1
          end if
        end do
      end do

C normalize and calculate fractional areas
      areaconst = pi*(r_annuli**2)/ellipse_eccen
      do n = 1,n_annuli
        if (ndata(n) .gt. 0 ) then
          flux(n) = flux(n)/float(ndata(n))
        else
          flux(n) = 0.0
        end if
        annarea = areaconst*float(2*n-1)
        frac_area(n) = ndata(n)/annarea
      end do
      call cmd_err(status,'image_addring',' ')
      end


      subroutine hanklf( order, hnklfd, argarr, n )
        integer n
        real order, argarr(n)
        complex hnklfd(n)
c
c       compute the hankel function, multiplied by exp( + i arg )
c       for use with the generalized filon integration of
c       frazer and gettrust ( gjras v76, pp. 461-481 )
c       note the different fourier transform sign conventions....
c       computes for n arguments passed in array argarr
c
        intrinsic atan, cmplx, exp, sqrt, abs
        real argsqi, atan, az, bz, mu, pi, sqrt, arg
        real a1, a2, a3, b1, b2, b3, b4
        complex cmplx
        integer i
         pi = 4. * atan(1.)
         mu = 4. * order * order
         a1 = ( mu - 1. ) / 16.
         a2 =  ( mu - 13. )/8.
         a3 = (mu*mu -53.*mu +412.)/48.
         b1 =  ( mu - 1. )/8.
         b2 =  (mu - 25.)/48.
         b3 =  ( mu*mu -114.*mu + 1073.)/640.
         b4 = - pi*( order + 0.5 )/2.
         do 10 i = 1, n
            arg = argarr(i)
            if ( arg .lt. 1.5+ abs( order ) ) then
	      if ( arg .ne. 0. ) then
		hnklfd(i) = sqrt(2./(pi*arg)) * exp( cmplx( 0., b4 ) )
	      else
		hnklfd(i) = ( 0., 0. )
	      endif
             else
              argsqi = 1./ ( arg * arg )
              az = a1*argsqi*( 1. + ( a2 + a3*argsqi)*argsqi )
c
c             bz = arg + (b1/arg)*( 1. + ( b2 + b3*argsqi)*argsqi) + b4
c             modified for generalized filon, multiply by exp( + i arg )
c
              bz = (b1/arg)*( 1. + ( b2 + b3*argsqi)*argsqi) + b4
              hnklfd(i) = sqrt(2./(pi*arg)) * exp(cmplx(az,-bz))
             endif
 10      continue
         return
      end


module filter_cpu
use dimen
use precision
contains

subroutine ddxy_filter_cpu(f,dfdx,dfdy,flag)

    !---------------------------------------------------------------------------
    ! declaration
    !---------------------------------------------------------------------------

    implicit none
    include '../common/fftw3.f90'

    real*8,dimension(nx,ny,nz2),intent(out) :: dfdx,dfdy
    real*8,dimension(nx,ny,nz2),intent(inout) :: f
    integer,intent(in) :: flag

    integer*8 :: plan_forward,plan_backward
    real*8,dimension(nx,ny) :: f_2d
    double complex,dimension(nx/2+1,ny) :: f_hat,dfdx_hat,dfdy_hat

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

    save plan_forward,plan_backward

    !---------------------------------------------------------------------------
    ! main code
    !---------------------------------------------------------------------------

    !---------------------------------------------------------------------------
    ! init

    if (flag==0) then

       call dfftw_plan_dft_r2c_2d(plan_forward,nx,ny,f_2d,f_hat,fftw_patient)
       call dfftw_plan_dft_c2r_2d(plan_backward,nx,ny,f_hat,f_2d,fftw_patient)

    !---------------------------------------------------------------------------
    ! compute

    elseif (flag==1) then

        do k=2,nzb+1
            ! forward fft --> f_hat
            call dfftw_execute_dft_r2c(plan_forward,f(:,:,k),f_hat)
            f_hat=f_hat*inxny
            ! filter and compute deriv
            do j=1,ny
                jj=j-1
                if(jj>nint(ny/2.0)) jj=jj-ny
                jj=jj*l_r
                do i=1,nx/2+1
                    ii=i-1
                    ! filter x
                    if (ii>=nint(nx/(2.0*fgr)))then
                        f_hat(i,j)=0.d0
                    ! filter y
                    elseif(abs(jj)>=nint(l_r*ny/(2.0*fgr)))then
                        f_hat(i,j)=0.d0
                    end if
                    ! dfdx_hat
                    dfdx_hat(i,j)=dcmplx(dimag(f_hat(i,j))*(-1.d0),dreal(f_hat(i,j)))*ii
                    ! dfdy_hat
                    dfdy_hat(i,j)=dcmplx(dimag(f_hat(i,j))*(-1.d0),dreal(f_hat(i,j)))*jj
                enddo
            enddo
            ! ! backward fft --> f
            call dfftw_execute_dft_c2r(plan_backward,f_hat,f(:,:,k))
            ! backward fft --> dfdx
            call dfftw_execute_dft_c2r(plan_backward,dfdx_hat,dfdx(:,:,k))
            ! backward fft --> dfdy
            call dfftw_execute_dft_c2r(plan_backward,dfdy_hat,dfdy(:,:,k))

        end do
    ! print *,f_hat(3,:,10)
    !---------------------------------------------------------------------------
    ! finalize

    elseif (flag==2) then

        call dfftw_destroy_plan(plan_forward)
        call dfftw_destroy_plan(plan_backward)

    endif

end subroutine ddxy_filter_cpu
end module filter_cpu


      SUBROUTINE HORNER2(N,A,X,Y,Z)
C COMPUTE POLYNOMIAL VALUE AND DERIVATIVE
C SEE "ROUNDOFF IN POLYNOMIAL EVALUATION", W. KAHAN, 1986
C POLY: A(1)+A(2)*X+...+A(N)*X**(N-1)
C Y: VALUE, Z: DERIVATIVE
      IMPLICIT NONE
      INTEGER I,N
      DOUBLE PRECISION A(N),X,Y,Z
      Z=0.0D0
      Y=A(N)
      DO 10 I=N-1,1,-1
      Z=Z*X+Y
   10 Y=Y*X+A(I)
      END


!#########################################################
!#########################################################
!#########################################################
!#########################################################
subroutine gravana(x,f,dx,ncell)
  use amr_parameters,only:boxlen
  use poisson_parameters
  use pm_commons,only:msink, xsink

  implicit none
  integer ::ncell                         ! Size of input arrays
  real(dp)::dx                            ! Cell size
  real(dp),dimension(1:nvector,1:ndim)::f ! Gravitational acceleration
  real(dp),dimension(1:nvector,1:ndim)::x ! Cell center position.
  !================================================================
  ! This routine computes the acceleration using analytical models.
  ! x(i,1:ndim) are cell center position in [0,boxlen] (user units).
  ! f(i,1:ndim) is the gravitational acceleration in user units.
  !================================================================
  integer::idim,i
  real(dp):: rr,rx,ry,rz

  ! Constant vector
  if(gravity_type==1)then
     do idim=1,ndim
        do i=1,ncell
           f(i,idim)=gravity_params(idim)
        end do
     end do
  end if

  ! Point mass
  if(gravity_type==2)then
     do i=1,ncell
        rx=0.0d0; ry=0.0d0; rz=0.0d0
        rx=x(i,1)-xsink(1,1)
        ry=x(i,2)-xsink(1,2)
        rz=x(i,3)-xsink(1,3)
        rr=sqrt(rx**2+ry**2+rz**2+gravity_params(1)**2) ! Softened gravity
        f(i,1)=-msink(1)*rx/rr**3
        f(i,2)=-msink(1)*ry/rr**3
        f(i,3)=-msink(1)*rz/rr**3
     end do
  end if

end subroutine gravana
!#########################################################
!#########################################################
!#########################################################
!#########################################################
subroutine phi_ana(rr,pp,ngrid)
  use amr_commons
  use poisson_commons
  implicit none
  integer::ngrid
  real(dp),dimension(1:nvector)::rr,pp
  ! -------------------------------------------------------------------
  ! This routine set up boundary conditions for fine levels.
  ! -------------------------------------------------------------------

  integer :: i
  real(dp):: fourpi

  fourpi=4.D0*ACOS(-1.0D0)

#if NDIM==1
  do i=1,ngrid
     pp(i)=multipole(1)*fourpi/2d0*rr(i)
  end do
#endif
#if NDIM==2
  do i=1,ngrid
     pp(i)=multipole(1)*2d0*log(rr(i))
  end do
#endif
#if NDIM==3
  do i=1,ngrid
     pp(i)=-multipole(1)/rr(i)
  end do
#endif
end subroutine phi_ana
!#########################################################
!#########################################################
!#########################################################


C Compute the phase, incidence, and emission angles for a point on the ring.
C
      subroutine ring_light(vsc,vsun,r,lon,i,e,p)
      implicit none
      real*8 vsc(3)             !Vector from target center to S/C (RS vector)
      real*8 vsun(3)            !Vector from target center to sun
      real*8 r,lon		!Radius and longitude of ring point
      real*8 i,e,p		!Incidence, emission, and phase angles (deg)

      real*8 v(3),s(3),c(3),PI,rpd,dpr
      real*8 solrange,scrange,elon
      integer j

      PI = 3.141592653589793D0
      rpd = PI/180.d0		!Radians per degree
      dpr = 180.d0/PI           !Degrees per radian
      elon = 360.d0 - lon	!East longitude

C     ....Compute vector from planet center to ring point
      v(1) = r*dcos(elon*rpd)
      v(2) = r*dsin(elon*rpd)
      v(3) = 0.

      do j=1,3
         s(j) = vsun(j) - v(j)		!Vector from ring point to sun
         c(j) = vsc(j)  - v(j)		!Vector from ring point to S/C
      enddo

C     ....Convert to unit vectors
      solrange = dsqrt(s(1)**2+s(2)**2+s(3)**2)		!Sun range
      scrange  = dsqrt(c(1)**2+c(2)**2+c(3)**2)		!S/C range
      do j=1,3
         s(j) = s(j)/solrange
         c(j) = c(j)/scrange
      enddo

C     ....First assume the sun illuminates the northern half of the ring plane.
C     ....Unit normal to ring plane is n = (0,0,1)
C     ....Cosine of incidence angle is dot product of s and n
      i = dacos(s(3))*dpr
C     ....Cosine of emission angle is dot product of c and n
      e = dacos(c(3))*dpr
C     ....cosine of phase angle is dot product of s and c
      p = dacos(s(1)*c(1)+s(2)*c(2)+s(3)*c(3))*dpr
C     ....If sun illuminates southern half of ring plane, then
C     ....unit normal to ring plane is n = (0,0,-1)
      if (i .gt. 90.) then
         i = 180. - i
         e = 180. - e
      endif
      return
      end


MODULE Write_Data
USE open_mpi
USE Read_Inputs

INTERFACE write_fes
  MODULE PROCEDURE print_pmf_2d
END INTERFACE write_fes

CONTAINS
  SUBROUTINE print_pmf_2d(prob)
  REAL*8, INTENT(IN) :: prob(:,:)
 integer:: nbin1, nbin2, ncv
!  REAL*8, INTENT(IN) :: prob(nbin1,nbin2)
  LOGICAL :: parent
 integer:: i_s1, i_s2
! integer:: nbin1, nbin2, ncv
! real*8 :: grid0(3,ncv)
 real*8 :: s1, s2, kt, dum
 real*8, allocatable :: prob1(:,:),grid0(:,:)
 character (len=50):: f2

 allocate(prob1(nbin1,nbin2))
 prob1=0.0
 CALL GlobSumR(prob,prob1,nbin1*nbin2)
 if (parent)then
 f2= 'free_energy'
 open( unit =7 , file = f2, status =  'unknown' )
 do i_s1=1,nbin1
  s1=DFLOAT(i_s1-1)*grid0(3,1)+grid0(1,1)
  do i_s2=1,nbin2
     s2=DFLOAT(i_s2-1)*grid0(3,2)+grid0(1,2)
     dum= -kt*DLOG(prob1(i_s1,i_s2))
     write(7,'(4E16.8)') s1, s2, dum, prob(i_s1,i_s2)
  enddo
  write(7,*)
 enddo
 write(*,*) 'free energy written in ',f2
 close(7)
 end if
 end subroutine print_pmf_2d

END MODULE Write_Data


!***********************************/
!	Name:計算格子の格子幅を求めるプログラム
!	Alias:CalcWidth
!	Description:分割数と領域の下限から格子を計算する
!	Type:Geom
!	Input:Geom%Bound,Geom%CellNumber
!	Output:Geom%Width
!	Note:
!	Author:Akitaka Toyota
!	Date:2017.10.26
!	Update:2017.11.09
!	Other:
!***********************************/
subroutine CalcWidth(Geom)
use StructVar_Mod
use LoopVar_Mod
implicit none
    type(Geometry),intent(inout) :: Geom

    do iLoop=1, Geom%Dimension
        Geom%Width(1,1,iLoop) = 0.5d0 * dabs(Geom%Bound(2,iLoop) - Geom%Bound(1,iLoop)) / dble(Geom%CellNumber(iLoop)) !セル中心から界面まで(格子幅の半分)
    end do

return
end subroutine CalcWidth


      PROGRAM PRIMES
*
*     Program to print the first N primes (N .LE. 10000)
*
      INTEGER P(10000)
      INTEGER CAND
*
      P(1)=2
      NP=1
      READ(*,*)N
      CAND=1
      J=1
      MAX=4
      DO I = 2, N
         P(I)=NEXT(P,J,MAX,CAND)
      END DO
      WRITE(*,'(10I8)') (P(I),I=1,N)
      END
*
*
      FUNCTION NEXT(P,J,MAX,CAND)
*
      INTEGER P(*)
      INTEGER CAND
      LOGICAL PRIME, TEST
*
      PRIME=.FALSE.
      DO WHILE (.NOT. PRIME)
         CAND=CAND+2
         IF (CAND .GT. MAX) THEN
            J=J+1
            MAX=P(J)*P(J)
         ENDIF
         PRIME=TEST(CAND,P,J)
      END DO
      NEXT=CAND
      RETURN
      END
*
*
      LOGICAL FUNCTION TEST(CAND,P,J)
*
      INTEGER P(*)
      INTEGER CAND
*
      TEST=.TRUE.
      DO I = 1, J
         IF (CAND/P(I)*P(I) .EQ. CAND) TEST =.FALSE.
      END DO
      RETURN
      END


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

*   Exponentiation (** operator) to real, double, or complex powers.

	program p
	implicit complex (c), real*8 (d)

	integer rslts(18), expect(18)

	integer ctoi
	ctoi(c) = real(c) + aimag(c)

	data x2 / 2.0/, d2 / 2.0d0/, i2 / 2 /
	data c2, c23, c11, c12/ (2, 0), (2, 3), (1, 1), (1, 2) /

c --- tests 1 - 6:  exponentiation to real power:

	rslts(1) = 2.1 ** 2.0
	rslts(2) = 2.1 ** x2
	rslts(3) = (3 ** x2) * 100.001
	rslts(4) = (i2 + 1) ** 3.01
	rslts(5) = i2 ** (x2 + 1) + .01
	rslts(6) = x2 ** 0.0 * 100

c --- tests 7 - 12: exponentiation to double prec. power:

	rslts(7) = 2.1d0 ** 2.0d0
	rslts(8) = 2.1d0 ** x2
	rslts(9) = (3 ** d2) * 100.001
	rslts(10) = (x2 + 1) ** 3.01d0
	rslts(11) = i2 ** (d2 + 1) + .01
	rslts(12) = d2 ** 0.0 * 100

c --- tests 13 - 18:  exponentiation to complex power:

	rslts(13) = ctoi( (2.1, 0.0) ** (2.0, 0.0) )
	rslts(14) = ctoi( (2.1, 0.0) ** c2)
	rslts(15) = ctoi( c23 ** x2 + .001 )
	rslts(16) = c23 ** c11 + 10
	rslts(17) = ctoi( 10 ** c12 )
	rslts(18) = ctoi(x2 ** (-1.0, 2.0) * 10)

c --- check results:

	call check(rslts, expect, 18)

	data expect / 4, 4, 900, 27, 8, 100,
     +                4, 4, 900, 27, 8, 100,
     +                4, 4, 7, 9, -11, 5      /

	end


!==========================================================================
elemental function gsw_pt0_cold_ice_poly (pot_enthalpy_ice)
!==========================================================================
!
!  Calculates an initial estimate of pt0_ice when it is less than about
!  -100 deg C.
!
!  pot_enthalpy_ice  =  potential enthalpy of ice                  [ J/kg ]
!
!  pt0_cold_ice_poly  =  initial estimate of potential temperatur
!                        of very cold ice in dgress C (not K)     [ deg C ]
!--------------------------------------------------------------------------

use gsw_mod_teos10_constants, only : gsw_t0

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: pot_enthalpy_ice

real (r8) :: gsw_pt0_cold_ice_poly

real (r8) :: log_abs_theta0, log_h_diff

! h00 = gsw_enthalpy_ice(-gsw_t0,0)
real (r8), parameter :: h00 = -6.320202333358860e5_r8

real (r8), parameter :: s0 =  1.493103204647916_r8
real (r8), parameter :: s1 =  2.372788609320607e-1_r8
real (r8), parameter :: s2 = -2.014996002119374e-3_r8
real (r8), parameter :: s3 =  2.640600197732682e-6_r8
real (r8), parameter :: s4 =  3.134706016844293e-5_r8
real (r8), parameter :: s5 =  2.733592344937913e-6_r8
real (r8), parameter :: s6 =  4.726828010223258e-8_r8
real (r8), parameter :: s7 = -2.735193883189589e-9_r8
real (r8), parameter :: s8 = -8.547714991377670e-11_r8

log_h_diff = log(pot_enthalpy_ice - h00)

log_abs_theta0 = s0 + log_h_diff*(s1 + log_h_diff*(s2 + log_h_diff*(s3 &
                + log_h_diff*(s4 + log_h_diff*(s5 + log_h_diff*(s6 &
                + log_h_diff*(s7 + log_h_diff*s8)))))))

gsw_pt0_cold_ice_poly = exp(log_abs_theta0) - gsw_t0

return
end function

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