!=============================================================================c
        program ogrid
!=============================================================================c
!
!  Purpose:  Given a closed body, this program generates an O-grid
!            suitable for Euler calculations
!
!  Author:   S. Scott Collis
!
!  Revised:  6-17-97
!
!=============================================================================c
        implicit none

        real, parameter :: zero=0.0d0, pt5=0.5d0, one=1.0d0, onept5=1.5d0, &
                           two=2.0d0, twopt5=2.5d0, three=3.0d0,           &
                           pi=3.1415926535897932385d+0

        integer, parameter :: iin=10, iout=11, ibs=12

        integer :: i, j, im, jm

        real, allocatable ::  x(:,:), y(:,:)
        real :: dx, theta, dtheta, r = 10.0, d, dd

        integer :: nmax
        real :: eps

        real, external :: sharp_foil
        real, external :: rounded_foil

        character(80) :: name

        integer :: narg, iarg
        character(128) arg
        logical :: airfoil=.false.
        logical :: rounded=.true.
!=============================================================================c

!.... parse the argument list

        narg = iargc()
        do iarg = 1, narg
          call getarg(iarg,arg)
          select case (arg(1:2))
          case ('-a')
            airfoil = .true.
            rounded = .true.
          case ('-s')
            airfoil = .true.
            rounded = .false.
          case ('-c')
            airfoil = .false.
          case ('-h')
            write(*,"('-----------------------------------------------')")
            write(*,"('Usage:  ogrid [options]                        ')")
            write(*,"('-----------------------------------------------')")
            write(*,"('   -h:  this help                              ')")
            write(*,"('-----------------------------------------------')")
            write(*,"('   -a:  use rounded TE airfoil geometry        ')")
            write(*,"('   -s:  use sharp TE airfoil geometry        ')")
            write(*,"('   -c:  use circle geometry (default)          ')")
            write(*,"('-----------------------------------------------')")
            call exit(0)
          case default
            write(*,"('Argument ',i2,' ignored.')") iarg
          end select
        end do

!.... get the maximum indices in ij directions

        write(*,"('Enter im, jm ==> ',$)")
        read(*,*) im, jm

        allocate( x(im,jm), y(im,jm) )

!.... make the mesh along the body

        dx = one / real(im - 1)
        dtheta = two * pi / real(im-1)
        if (airfoil) then
          name = "foil.xyz"
          write(*,*) "Building mesh for an airfoil"
          do i = 1, im
#if 0
            theta = pi - real(i-1) * dtheta
            x(i,1) = real(i-1) * dx
#else
            theta = -real(i-1) * dtheta
            x(i,1) = ( cos( theta ) + one) * pt5
#endif
            if (rounded) then
              y(i,1) = rounded_foil( x(i,1), 0.1 )
            else
              y(i,1) = sharp_foil( x(i,1), 0.1 )
            endif
            if (theta .gt. -pi) y(i,1) = -y(i,1)
            write (10,*) x(i,1), y(i,1), theta
          end do
        else
          name = "circ.xyz"
          write(*,*) "Building mesh for a circular cylinder"
          do i = 1, im
            theta = - real(i-1) * dtheta
            x(i,1) = ( cos( theta ) + one) * pt5
            y(i,1) = ( sin( theta ) ) * pt5
            write (10,*) x(i,1), y(i,1), theta
          end do
        end if

!.... make the mesh along the top circle

        dtheta = two * pi / real(im-1)
        do i = 1, im
!          theta = pi - real(i-1) * dtheta
           theta = - real(i-1) * dtheta
           x(i,jm) = r * cos(theta) + 0.5
           y(i,jm) = r * sin(theta)
        end do

!.... now connect the boundary points by straight lines

        do i = 1, im
           dd  = sqrt( (x(i,jm)-x(i,1))**2 + (y(i,jm)-y(i,1))**2 ) / real(jm-1)
           theta = atan2( y(i,jm)-y(i,1), x(i,jm)-x(i,1) )
           do j = 2, jm-1
              d = real(j-1) * dd
              x(i,j) = x(i,1) + d * cos(theta)
              y(i,j) = y(i,1) + d * sin(theta)
           end do
        end do

!.... elliptic grid generator

        write(*,"(/,'Using elliptic smoother...')")
        write(*,"('Enter eps, nmax ==> ',$)")
        read(*,*) eps, nmax
        call elliptic( im, jm, x, y, eps, nmax)

!.... output grid file

        open(unit=iout, file=name, form='unformatted')
        write(iout) im, jm, 1
        write(iout) ((x(i,j), i=1,im), j=1,jm), &
                    ((y(i,j), i=1,im), j=1,jm), &
                    ((  zero, i=1,im), j=1,jm)
        close(iout)

        call exit(0)
        end

!=============================================================================c
        function rounded_foil(x,t)
!=============================================================================c
        implicit none
        real foil, x, t
        real r, x0, y0, y, term, xp
        real :: rounded_foil
        real, external :: sharp_foil
!=============================================================================c
        r  = 0.00255       ! SSC: hand tuned
        x0 = 1.0 - r
        y0 = 0.0
        xp = x/(1.0+0.02)  ! SSC:  hand tuned
        foil = sharp_foil(xp,t)
        if (x.ge.x0) then
          term = r**2 - (x-x0)**2
          if (term.le.0) then
            y = 0.0
          else
            y = sqrt(term) + y0
          end if
          write (*,*) x, y, foil
          if (y.lt.foil) foil = y
        end if
        rounded_foil = foil
        return
        end

!=============================================================================c
        function sharp_foil(x,t)
!=============================================================================c
        implicit none
        real foil, x, t
        real sharp_foil
!=============================================================================c
        foil = t/0.2 * ( 0.2969 * sqrt(x) - 0.1281 * x - 0.3516 * x**2 + &
               0.2843 * x**3 - 0.1015 * x**4 )
        sharp_foil = foil
        return
        end

!=============================================================================c
      subroutine elliptic( nx, ny, x, y, eps, nmax )
!
!     This routine performs an elliptic smoothing of the input grid
!
!     Author:  Scott Collis
!
!     Date:    6-17-97
!
!=============================================================================c
      implicit none

      integer :: nx, ny, nmax
      real :: x(nx,ny), y(nx,ny), eps

      real, parameter :: zero=0.0, pt5=0.5, one=1.0, two=2.0

      integer :: n, i, j, ibc=1
      real :: dxi, deta, dxdeta, dydeta, dxdxi, dydxi
      real :: a, b, c, xnew, ynew, err, jac

      real :: w, rx(nx), ry(nx), ad(nx), bd(nx), cd(nx), xl(nx), yl(nx)
      real :: xi(nx), eta(ny), p(nx), q(nx), dn(nx)
      real :: px, py
!=============================================================================c

      dxi = one / float(nx-1)
      deta = one / float(ny-1)

      do j = 1, ny
        eta(j) = real(j-1) * deta
      end do

      do i = 1, nx
        xi(i) = real(i-1) * dxi
        dn(i) = sqrt( (x(i,2)-x(i,1))**2 + (y(i,2)-y(i,1))**2 )
      end do

!.... Line Gauss-Siedel with SOR (because of the nonlinearity
!.... SOR is unstable for w > 1?)

      w = one
!     write(*,"(/,'Enter the SOR parmameter (0 < w < 2, w = 1.78) ==> ',$)")
!     read(*,*) w
      n = 0
 20   continue
         n = n + 1
         err = zero

         if (.false. .and. n .ge. 1) then
           call ortho(nx, ny, dxi, deta, x, y, dn, p, q)
         else
           p = zero
           q = zero
         end if

         do j = 2, ny-1

            do i = 2, nx-1
               dxdeta = (x(i,j+1)-x(i,j-1)) / (two * deta)
               dydeta = (y(i,j+1)-y(i,j-1)) / (two * deta)
               dxdxi  = (x(i+1,j)-x(i-1,j)) / (two * dxi)
               dydxi  = (y(i+1,j)-y(i-1,j)) / (two * dxi)

               a = (dxdeta**2 + dydeta**2) / dxi**2
               b = (dxdxi*dxdeta + dydxi*dydeta) / ( two * dxi * deta )
               c = (dxdxi**2 + dydxi**2) / deta**2

               rx(i) = -two*(one-w)*(a + c) * x(i,j) + w*b*(x(i+1,j+1) - &
                       x(i+1,j-1) + x(i-1,j-1) - x(i-1,j+1)) -           &
                       w*c*(x(i,j+1) + x(i,j-1))

               ry(i) = -two*(one-w)*(a + c) * y(i,j) + w*b*(y(i+1,j+1) - &
                       y(i+1,j-1) + y(i-1,j-1) - y(i-1,j+1)) -           &
                       w*c*(y(i,j+1) + y(i,j-1))

               jac = one / ( dxdxi * dydeta - dydxi * dxdeta )
               if (p(i) .gt. zero) then
                 dxdxi = (x(i,j)-x(i-1,j)) / dxi
                 dydxi = (y(i,j)-y(i-1,j)) / dxi
               else
                 dxdxi = (x(i+1,j)-x(i,j)) / dxi
                 dydxi = (y(i+1,j)-y(i,j)) / dxi
               end if
               if (q(i) .gt. zero) then
                 dxdeta = (x(i,j)-x(i,j-1)) / deta
                 dydeta = (y(i,j)-y(i,j-1)) / deta
               else
                 dxdeta = (x(i,j+1)-x(i,j)) / deta
                 dydeta = (y(i,j+1)-y(i,j)) / deta
               end if
               px = -one/jac**2 * ( p(i) * exp( -(eta(j)-eta(1)) ) * dxdxi + &
                                    q(i) * exp( -(eta(j)-eta(1)) ) * dxdeta )
               py = -one/jac**2 * ( p(i) * exp( -(eta(j)-eta(1)) ) * dydxi + &
                                    q(i) * exp( -(eta(j)-eta(1)) ) * dydeta )

               rx(i) = rx(i) + w * px
               ry(i) = ry(i) + w * py

               ad(i) = w * a
               bd(i) = -two * (a + c)
               cd(i) = w * a
            end do

!.... apply the boundary conditions

            if (ibc .eq. 0) then             ! fixed boundaries
               rx(1)  = x(1,j)
               ry(1)  = y(1,j)
               rx(nx) = x(nx,j)
               ry(nx) = y(nx,j)

               ad(1) = zero
               bd(1) = one
               cd(1) = zero

               ad(nx) = zero
               bd(nx) = one
               cd(nx) = zero

            else if (ibc .eq. 1) then        ! symmetry boundaries
               i = 1
               dxdeta = (x(i,j+1)-x(i,j-1)) / (two * deta)
               dydeta = (y(i,j+1)-y(i,j-1)) / (two * deta)
               dxdxi  = (x(i+1,j)-x(i+1,j)) / (two * dxi)
               dydxi  = (y(i+1,j)+y(i+1,j)) / (two * dxi)

               a = (dxdeta**2 + dydeta**2) / dxi**2
               b = (dxdxi*dxdeta + dydxi*dydeta) / ( two * dxi * deta )
               c = (dxdxi**2 + dydxi**2) / deta**2

               rx(i) = -two*(one-w)*(a + c) * x(i,j) + w*b*(x(i+1,j+1) - &
                       x(i+1,j-1) + x(i+1,j-1) - x(i+1,j+1)) -           &
                       w*c*(x(i,j+1) + x(i,j-1))

               ry(i) = -two*(one-w)*(a + c) * y(i,j) + w*b*(y(i+1,j+1) - &
                       y(i+1,j-1) - y(i+1,j-1) + y(i+1,j+1)) -           &
                       w*c*(y(i,j+1) + y(i,j-1))

               jac = one / ( dxdxi * dydeta - dydxi * dxdeta )
               if (p(i) .gt. zero) then
                 dxdxi = (x(i,j)-x(i+1,j)) / dxi
                 dydxi = (y(i,j)-y(i+1,j)) / dxi
               else
                 dxdxi = (x(i+1,j)-x(i,j)) / dxi
                 dydxi = (y(i+1,j)-y(i,j)) / dxi
               end if
               if (q(i) .gt. zero) then
                 dxdeta = (x(i,j)-x(i,j-1)) / deta
                 dydeta = (y(i,j)-y(i,j-1)) / deta
               else
                 dxdeta = (x(i,j+1)-x(i,j)) / deta
                 dydeta = (y(i,j+1)-y(i,j)) / deta
               end if
               px = -one/jac**2 * ( p(i) * exp( -(eta(j)-eta(1)) ) * dxdxi + &
                                    q(i) * exp( -(eta(j)-eta(1)) ) * dxdeta )
               py = -one/jac**2 * ( p(i) * exp( -(eta(j)-eta(1)) ) * dydxi + &
                                    q(i) * exp( -(eta(j)-eta(1)) ) * dydeta )

               rx(i) = rx(i) + w * px
               ry(i) = ry(i) + w * py

               ad(i) = zero
               bd(i) = -two * (a + c)
               cd(i) = two * w * a

               i = nx
               dxdeta = ( x(i,j+1)-x(i,j-1)) / (two * deta)
               dydeta = ( y(i,j+1)-y(i,j-1)) / (two * deta)
               dxdxi  = ( x(i-1,j)-x(i-1,j)) / (two * dxi)
               dydxi  = (-y(i-1,j)-y(i-1,j)) / (two * dxi)

               a = (dxdeta**2 + dydeta**2) / dxi**2
               b = (dxdxi*dxdeta + dydxi*dydeta) / ( two * dxi * deta )
               c = (dxdxi**2 + dydxi**2) / deta**2

               rx(i) = -two*(one-w)*(a + c) * x(i,j) + w*b*(x(i-1,j+1) - &
                       x(i-1,j-1) + x(i-1,j-1) - x(i-1,j+1)) -           &
                       w*c*(x(i,j+1) + x(i,j-1))

               ry(i) = -two*(one-w)*(a + c) * y(i,j) + w*b*(-y(i-1,j+1) + &
                       y(i-1,j-1) + y(i-1,j-1) - y(i-1,j+1)) -            &
                       w*c*(y(i,j+1) + y(i,j-1))

               jac = one / ( dxdxi * dydeta - dydxi * dxdeta )
               if (p(i) .gt. zero) then
                 dxdxi = (x(i,j)-x(i-1,j)) / dxi
                 dydxi = (y(i,j)-y(i-1,j)) / dxi
               else
                 dxdxi = (x(i-1,j)-x(i,j)) / dxi
                 dydxi = (-y(i-1,j)-y(i,j)) / dxi
               end if
               if (q(i) .gt. zero) then
                 dxdeta = (x(i,j)-x(i,j-1)) / deta
                 dydeta = (y(i,j)-y(i,j-1)) / deta
               else
                 dxdeta = (x(i,j+1)-x(i,j)) / deta
                 dydeta = (y(i,j+1)-y(i,j)) / deta
               end if

               px = -one/jac**2 * ( p(i) * exp( -(eta(j)-eta(1)) ) * dxdxi + &
                                    q(i) * exp( -(eta(j)-eta(1)) ) * dxdeta )
               py = -one/jac**2 * ( p(i) * exp( -(eta(j)-eta(1)) ) * dydxi + &
                                    q(i) * exp( -(eta(j)-eta(1)) ) * dydeta )

               rx(i) = rx(i) + w * px
               ry(i) = ry(i) + w * py

               ad(i) = two * w * a
               bd(i) = -two * (a + c)
               cd(i) = zero
            end if

            call tridag( ad, bd, cd, rx, xl, nx )

            if (ibc .eq. 1) then
               cd(1) = zero
               ad(nx) = zero
            end if

            call tridag( ad, bd, cd, ry, yl, nx )

            do i = 1, nx
               err = err + abs(x(i,j)-xl(i)) + abs(y(i,j)-yl(i))
               x(i,j) = xl(i)
               y(i,j) = yl(i)
            end do

         end do

         err = err / real( (nx-2)*(ny-2) )
         write(*,"(i5,1x,1pe13.6)") n, err
      if ( err .gt. eps .and. n .lt. nmax) goto 20

      return
      end

!=============================================================================c
      subroutine ortho (nx, ny, dxi, deta, x, y, dn, p, q)
!=============================================================================c
      implicit none

      integer, intent(in) :: nx, ny
      real, intent(in)    :: dxi, deta, x(nx,ny), y(nx,ny), dn(nx)
      real, intent(out)   :: p(nx), q(nx)

      real, parameter :: zero=0.0d0, pt5=0.5d0, one=1.0d0, onept5=1.5d0, &
                         two=2.0d0, twopt5=2.5d0, three=3.0d0,           &
                         pi=3.1415926535897932385d+0

      integer :: i
      real :: dxdxi(nx), dydxi(nx), d2xdxi2(nx), d2ydxi2(nx)
      real :: dxdeta(nx), dydeta(nx), d2xdeta2(nx), d2ydeta2(nx)
      real :: d2xdxideta(nx), d2ydxideta(nx)

      real :: jac, r1, r2, a, b, c
!=============================================================================c
      i = 1
      dxdxi(i) = ( x(i+1,1) - x(i+1,1) ) / (two * dxi)
      dydxi(i) = ( y(i+1,1) + y(i+1,1) ) / (two * dxi)
      d2xdxi2(i) = ( x(i+1,1) - two * x(i,1) + x(i+1,1) ) / dxi**2
      d2ydxi2(i) = ( y(i+1,1) - two * y(i,1) - y(i+1,1) ) / dxi**2
      do i = 2, nx-1
        dxdxi(i) = ( x(i+1,1) - x(i-1,1) ) / (two * dxi)
        dydxi(i) = ( y(i+1,1) - y(i-1,1) ) / (two * dxi)
        d2xdxi2(i) = ( x(i+1,1) - two * x(i,1) + x(i-1,1) ) / dxi**2
        d2ydxi2(i) = ( y(i+1,1) - two * y(i,1) + y(i-1,1) ) / dxi**2
      end do
      i = nx
      dxdxi(i) = ( x(i-1,1) - x(i-1,1) ) / (two * dxi)
      dydxi(i) = (-y(i-1,1) - y(i-1,1) ) / (two * dxi)
      d2xdxi2(i) = ( x(i-1,1) - two * x(i,1) + x(i-1,1) ) / dxi**2
      d2ydxi2(i) = (-y(i-1,1) - two * y(i,1) + y(i-1,1) ) / dxi**2

      do i = 1, nx
        dxdeta(i) = dn(i)/deta * (-dydxi(i)) / sqrt(dxdxi(i)**2 + dydxi(i)**2)
        dydeta(i) = dn(i)/deta * ( dxdxi(i)) / sqrt(dxdxi(i)**2 + dydxi(i)**2)
      end do

      do i = 1, nx
        d2xdeta2(i) = (-7.0 * x(i,1) + 8.0 * x(i,2) - x(i,3)) / &
                      (2.0 * deta**2) - 3.0 * dxdeta(i) / deta
        d2ydeta2(i) = (-7.0 * y(i,1) + 8.0 * y(i,2) - y(i,3)) / &
                      (2.0 * deta**2) - 3.0 * dydeta(i) / deta
      end do

      i = 1
      d2xdxideta(i) = ( dxdeta(i+1) - dxdeta(i+1) ) / (two * dxi)
      d2ydxideta(i) = ( dydeta(i+1) + dydeta(i+1) ) / (two * dxi)
      do i = 2, nx-1
        d2xdxideta(i) = ( dxdeta(i+1) - dxdeta(i-1) ) / (two * dxi)
        d2ydxideta(i) = ( dydeta(i+1) - dydeta(i-1) ) / (two * dxi)
      end do
      i = nx
      d2xdxideta(i) = ( dxdeta(i-1) - dxdeta(i-1) ) / (two * dxi)
      d2ydxideta(i) = (-dydeta(i-1) - dydeta(i-1) ) / (two * dxi)

      do i = 1, nx
        a = dxdeta(i)**2 + dydeta(i)**2
        b = dxdxi(i)*dxdeta(i) + dydxi(i)*dydeta(i)
        c = dxdxi(i)**2 + dydxi(i)**2

        jac = one / ( dxdxi(i) * dydeta(i) - dydxi(i) * dxdeta(i) )

        r1 = -(jac**2) * ( a * d2xdxi2(i) - two * b * d2xdxideta(i) + &
                           c * d2xdeta2(i) )

        r2 = -(jac**2) * ( a * d2ydxi2(i) - two * b * d2ydxideta(i) + &
                           c * d2ydeta2(i) )

        p(i) = jac * ( dydeta(i) * r1 - dxdeta(i) * r2 )
        q(i) = jac * ( -dydxi(i) * r1 + dxdxi(i) * r2 )
      end do

      return
      end

!=============================================================================c
      SUBROUTINE TRIDAG(A,B,C,R,U,N)
!=============================================================================c
      DIMENSION GAM(N),A(N),B(N),C(N),R(N),U(N)
      IF(B(1).EQ.0.)THEN
        WRITE(*,*) 'ERROR IN TRIDAG:  B(1) = 0'
        CALL EXIT(1)
      END IF
      BET=B(1)
      U(1)=R(1)/BET
      DO 11 J=2,N
        GAM(J)=C(J-1)/BET
        BET=B(J)-A(J)*GAM(J)
        IF(BET.EQ.0.)THEN
          WRITE(*,*) 'ERROR IN TRIDAG: B = 0', J
          CALL EXIT(1)
        END IF
        U(J)=(R(J)-A(J)*U(J-1))/BET
11    CONTINUE
      DO 12 J=N-1,1,-1
        U(J)=U(J)-GAM(J+1)*U(J+1)
12    CONTINUE
      RETURN
      END


      SUBROUTINE SEA_MODEL_INIT (fmask_s,rlat)
C--
C--   SUBROUTINE SEA_MODEL_INIT (fmask_s,rlat)
C--
C--   Purpose : Initialization of sea model
C--   Initialized common blocks: SEA_MC
C--

      include "atparam.h"

      PARAMETER ( NLON=IX, NLAT=IL, NGP=NLON*NLAT )

C     Input variables

      real fmask_s(nlon,nlat)            ! sea mask (fraction of sea)
      real rlat(nlat)                    ! latitudes in degrees

      include "com_cplcon_sea.h"

C     Auxiliary variables

      real    dmask(nlon,nlat)              ! domain mask
      logical l_globe,
     &        l_northe, l_natlan, l_npacif,
     &        l_tropic, l_indian            ! domain flags

      real hcaps(nlat)                      ! heat capacity of mixed-l.
      real hcapi(nlat)                      ! heat capacity of sea-ice

C--
C--   1. Set geographical domain, heat capacities and dissipation times
C--      for sea (mixed layer) and sea-ice

C     Model parameters (default values)

C     ocean mixed layer depth: d + (d0-d)*(cos_lat)^3
      depth_ml = 60.               ! High-latitude depth
      dept0_ml = 40.               ! Minimum depth (tropics)

C     sea-ice depth : d + (d0-d)*(cos_lat)^2
      depth_ice = 2.5              ! High-latitude depth
      dept0_ice = 1.5              ! Minimum depth

C     Dissipation time (days) for sea-surface temp. anomalies
      tdsst  = 90.

C     Dissipation time (days) for sea-ice temp. anomalies
      tdice = 30.

C     Heat flux coefficient at sea/ice interface [(W/m^2)/deg]
      beta = 1.

C     Minimum fraction of sea for the definition of anomalies
      fseamin = 1./3.

C     Geographical domain
C     note : more than one regional domain may be set .true.

      l_globe  =  .true.         ! global domain
      l_northe = .false.         ! Northern hem. oceans (lat > 20N)
      l_natlan = .false.         ! N. Atlantic (lat 20-80N, lon 100W-45E)
      l_npacif = .false.         ! N. Pacific  (lat 20-80N, lon 100E-100W)
      l_tropic = .false.         ! Tropics (lat 30S-30N)
      l_indian = .false.         ! Indian Ocean (lat 30S-30N, lon 30-120E)

C     Reset model parameters

      include "cls_insea.h"

C     Heat capacities per m^2 (depth*heat_cap/m^3)

      crad=asin(1.)/90.
      do j=1,nlat
        coslat   = cos(crad*rlat(j))
        hcaps(j) = 4.18e+6*(depth_ml +(dept0_ml -depth_ml) *coslat**3)
        hcapi(j) = 1.93e+6*(depth_ice+(dept0_ice-depth_ice)*coslat**2)
      enddo
C--
C--   3. Compute constant parameters and fields

C     Set domain mask

      if (l_globe) then
        dmask(:,:) = 1.
      else
        dmask(:,:) = 0.
        if (l_northe) call SEA_DOMAIN ('northe',rlat,dmask)
cfk        if (l_arctic) call SEA_DOMAIN ('arctic',rlat,dmask)
        if (l_natlan) call SEA_DOMAIN ('natlan',rlat,dmask)
        if (l_npacif) call SEA_DOMAIN ('npacif',rlat,dmask)
        if (l_tropic) call SEA_DOMAIN ('tropic',rlat,dmask)
        if (l_indian) call SEA_DOMAIN ('indian',rlat,dmask)
      endif

C     Smooth latitudinal boundaries and blank out land points

      do j=2,nlat-1
         rhcaps(:,j) = 0.25*(dmask(:,j-1)+2*dmask(:,j)+dmask(:,j+1))
      enddo
      dmask(:,2:nlat-1) = rhcaps(:,2:nlat-1)

      do j=1,nlat
        do i=1,nlon
           if (fmask_s(i,j).lt.fseamin) dmask(i,j) = 0
        enddo
      enddo

C     Set heat capacity and dissipation time over selected domain

      do j=1,nlat
         rhcaps(:,j) = 86400./hcaps(j)
         rhcapi(:,j) = 86400./hcapi(j)
      enddo

      cdsea(:,:) = dmask(:,:)*tdsst/(1.+dmask(:,:)*tdsst)
      cdice(:,:) = dmask(:,:)*tdice/(1.+dmask(:,:)*tdice)

      return
      end

      SUBROUTINE SEA_MODEL
C--
C--   SUBROUTINE SEA_MODEL
C--
C--   Purpose : Integrate slab ocean and sea-ice models for one day

      include "atparam.h"

      PARAMETER ( NLON=IX, NLAT=IL, NGP=NLON*NLAT )

c      real vsea_input(nlon,nlat,8), vsea_output(nlon,nlat,3)

      include "com_cplcon_sea.h"

      include "com_cplvar_sea.h"

C     Input variables:

      real  sst0(nlon,nlat)     ! SST at initial time
      real tice0(nlon,nlat)     ! sea ice temp. at initial time
      real sice0(nlon,nlat)     ! sea ice fraction at initial time
      real hfsea(nlon,nlat)     ! sea+ice  sfc. heat flux between t0 and t1
      real hfice(nlon,nlat)     ! ice-only sfc. heat flux between t0 and t1

      real  sstcl1(nlon,nlat)   ! clim. SST at final time
      real ticecl1(nlon,nlat)   ! clim. sea ice temp. at final time
      real hfseacl(nlon,nlat)   ! clim. heat flux due to advection/upwelling

      equivalence    (sst0,vsea_input(1,1))
      equivalence   (tice0,vsea_input(1,2))
      equivalence   (sice0,vsea_input(1,3))
      equivalence   (hfsea,vsea_input(1,4))
      equivalence   (hfice,vsea_input(1,5))
      equivalence  (sstcl1,vsea_input(1,6))
      equivalence (ticecl1,vsea_input(1,7))
      equivalence (hfseacl,vsea_input(1,8))

C     Output variables

      real  sst1(nlon,nlat)     ! SST at final time
      real tice1(nlon,nlat)     ! sea ice temp. at final time
      real sice1(nlon,nlat)     ! sea ice fraction at final time

      equivalence  (sst1,vsea_output(1,1))
      equivalence (tice1,vsea_output(1,2))
      equivalence (sice1,vsea_output(1,3))

C     Auxiliary variables

      real hflux(nlon,nlat)   ! net sfc. heat flux
      real tanom(nlon,nlat)   ! sfc. temperature anomaly
      real  cdis(nlon,nlat)   ! dissipation ceofficient

      sstfr = 273.2-1.8       ! SST at freezing point

c      beta = 1.               ! heat flux coef. at sea-ice bottom
C--
C--   1. Ocean mixed layer

C     Net heat flux
      hflux(:,:) = hfsea(:,:)-hfseacl(:,:)
     &             -sice0(:,:)*(hfice(:,:)+beta*(sstfr-tice0(:,:)))

C     Anomaly at t0 minus climatological temp. tendency
      tanom(:,:) = sst0(:,:) - sstcl1(:,:)

C     Time evoloution of temp. anomaly
      tanom(:,:) = cdsea(:,:)*(tanom(:,:)+rhcaps(:,:)*hflux(:,:))

C     Full SST at final time
      sst1(:,:) = tanom(:,:) + sstcl1(:,:)

C--
C--   2. Sea-ice slab model

C     Net heat flux
      hflux(:,:) = hfice(:,:)
     &           + beta*(sstfr-tice0(:,:))

C     Anomaly w.r.t final-time climatological temp.
      tanom(:,:) = tice0(:,:) - ticecl1(:,:)

C     Definition of non-linear damping coefficient
      anom0     = 20.
      cdis(:,:) = cdice(:,:)*(anom0/(anom0+abs(tanom(:,:))))
c     cdis(:,:) = cdice(:,:)

C     Time evoloution of temp. anomaly
      tanom(:,:) = cdis(:,:)*(tanom(:,:)+rhcapi(:,:)*hflux(:,:))

C     Full ice temperature at final time
      tice1(:,:) = tanom(:,:) + ticecl1(:,:)

C     Persistence of sea ice fraction
      sice1(:,:) = sice0(:,:)

      return
      end

      SUBROUTINE SEA_DOMAIN (cdomain,rlat,dmask)
C--
C--   SUBROUTINE SEA_DOMAIN (cdomain,rlat,dmask)
C--
C--   Purpose : Definition of ocean domains
C--

      include "atparam.h"

      PARAMETER ( NLON=IX, NLAT=IL )

C     Input variables

      character*6 cdomain           ! domain name
      real rlat(nlat)               ! latitudes in degrees

C     Output variables (initialized by calling routine)

      real dmask(nlon,nlat)         ! domain mask

      print *, 'sea domain : ', cdomain

      dlon = 360./float(nlon)

      if (cdomain.eq.'northe') then
        do j=1,nlat
          if (rlat(j).gt.20.0) dmask(:,j) = 1.
        enddo
      endif

      if (cdomain.eq.'natlan') then
         do j=1,nlat
           if (rlat(j).gt.20.0.and.rlat(j).lt.80.0) then
             do i=1,nlon
               rlon = (i-1)*dlon
               if (rlon.lt.45.0.or.rlon.gt.260.0) dmask(i,j) = 1.
             enddo
           endif
         enddo
      endif

      if (cdomain.eq.'npacif') then
         do j=1,nlat
           if (rlat(j).gt.20.0.and.rlat(j).lt.65.0) then
             do i=1,nlon
               rlon = (i-1)*dlon
               if (rlon.gt.120.0.and.rlon.lt.260.0) dmask(i,j) = 1.
             enddo
           endif
         enddo
      endif

      if (cdomain.eq.'tropic') then
        do j=1,nlat
          if (rlat(j).gt.-30.0.and.rlat(j).lt.30.0) dmask(:,j) = 1.
        enddo
      endif

      if (cdomain.eq.'indian') then
         do j=1,nlat
           if (rlat(j).gt.-30.0.and.rlat(j).lt.30.0) then
             do i=1,nlon
               rlon = (i-1)*dlon
               if (rlon.gt.30.0.and.rlon.lt.120.0) dmask(i,j) = 1.
             enddo
           endif
         enddo
      endif

      if (cdomain.eq.'elnino') then
         do j=1,nlat
           arlat = abs(rlat(j))
           if (arlat.lt.25.0) then
             wlat = 1.
             if (arlat.gt.15.0) wlat = (0.1*(25.-arlat))**2
             rlonw = 300.-2*max(rlat(j),0.)
             do i=1,nlon
               rlon = (i-1)*dlon
               if (rlon.gt.165.0.and.rlon.lt.rlonw) then
                  dmask(i,j) = wlat
               else if (rlon.gt.155.0.and.rlon.lt.165.0) then
                  dmask(i,j) = wlat*0.1*(rlon-155.)
               endif
             enddo
           endif
         enddo
      endif

c      do j=1,nlat
c       print *, 'lat = ',rlat(j),' sea model domain  = ',dmask(nlon/2,j)
c      enddo

      return
      end


   subroutine Gless(c_vec1,c_vec2,den,n_t,n_k,Gans,n_v)

    implicit none

    integer*4, intent(in) :: n_t,n_k,n_v
    complex*16, dimension(n_k,n_v,n_t), intent(in) :: c_vec1
    complex*16, dimension(n_k,n_v,n_t), intent(in) :: c_vec2
    real*8, dimension(n_k,2), intent(in) :: den
    complex*16, dimension(n_t,n_t), intent(out) :: Gans
    integer*4 :: t1
    integer*4 :: t2

    do t1 = 1, n_t
        do t2 = 1, n_t
            Gans(t1,t2) = sum(sum((c_vec1(:,:,t1))*c_vec2(:,:,t2),dim=2)*den(:,1)*den(:,2))
        end do
    end do

   end subroutine Gless


program DenoisingAutoencoder
    use NobleNeuron

    implicit none

    integer,parameter   :: dp = kind(1.d0)
    type(NeuralNetwork) :: DAE
    integer             :: i,j
    real                :: r,r1,r2
    real(dp)            :: sample(20,1)
    real(dp)            :: expected(20,1)
    double precision    :: L
    real(dp)            :: gL(1,20)

    logical             :: existent
    character(len=50)   :: fname

    real(dp),parameter  :: pi = 3.1415926535897932384

    !--------------------------------------------------!
    !              Create Neural Network               !
    !--------------------------------------------------!
    DAE = NeuralNetwork(20,"L2","SGD")
    i = DAE%addLayer(5,"tanh")
    i = DAE%addLayer(20,"tanh")

    !--------------------------------------------------!
    !                 Train Network                    !
    !--------------------------------------------------!
    L = 1.0
    do while(L > 5E-3)

        ! Epoch = 360 runs
        L = 0.0
        do j = 1,360
            ! Input vector = A.sin(w.t + theta)
            call random_number(r1)
            r1 = -pi + r1*2*pi
            do i = 1,20
                call random_number(r)
                r2 = sin((i-1)*2*pi/20)
                sample(i,1) = r2 + r/5  ! Noisy input
                expected(i,1) = r2      ! Clear output
            end do

            ! Feedforward / Loss / Backpropagation
            call DAE%feedforward(sample)
            L = L + DAE%Loss(expected)
            gL = DAE%gradLoss(expected)
            call DAE%backpropagate(sample,gL)
        end do
        L = L/360

        ! Plot loss and apply gradients
        write(*,*) L
        call DAE%applyGrads(0.001)
    end do

    !--------------------------------------------------!
    !      Save Results for plotting in Python         !
    !--------------------------------------------------!
    ! Open file
    fname = "python/out.dat"
    inquire(file=fname,exist=existent)

    if (existent) then
        open(1,file=fname,status="old")
    else
        open(1,file=fname,status="new")
    end if

    ! Create input vector
    do i = 1,20
        r2 = sin((i-1)*2*pi/5)
        sample(i,1) = r2
    end do

    ! Feedforward
    call DAE%feedforward(sample)
    write(1,*) DAE%output()
    close(1)

end program


      subroutine brooks_corey_rlp(s, p1, p2, lambda, q, prop1, dprop11,
     &      prop2, dprop21)
!***********************************************************************
! Copyright 2009 Los Alamos National Security, LLC  All rights reserved
! Unless otherwise indicated,  this information has been authored by an
! employee or employees of the Los Alamos National Security, LLC (LANS),
! operator of the  Los  Alamos National  Laboratory  under Contract  No.
! DE-AC52-06NA25396  with  the U. S. Department  of  Energy.  The  U. S.
! Government   has   rights  to  use,  reproduce,  and  distribute  this
! information.  The  public may copy  and  use this  information without
! charge, provided that this  Notice and any statement of authorship are
! reproduced on all copies.  Neither  the  Government nor LANS makes any
! warranty,   express   or   implied,   or   assumes  any  liability  or
! responsibility for the use of this information.
!***********************************************************************
!D1
!D1 PURPOSE
!D1
!D1 Calculate Brooks-Corey relative permeability
! 2-phase
! input:  s is wetting phase saturation
!         p1 is residual wetting phase saturation
!         p2 is residual non-wetting phase saturation
!         lambda (Li and Horne, 2006)
! output: prop1 is rel perm (wetting phase saturation)
!	  dprop11 is dr/ds
!	  dprop12 is dr/ds(gas) - always 0 if 2-phase
!	  prop2 is rel perm (non-wetting phase saturation)
!	  dprop21 is dr/ds
!	  dprop22 is dr/ds(gas) - always 0 if 2-phase
!***********************************************************************

c      use comdi
      use comrlp

      implicit none
      real*8 s, p1, p2, lambda, prop1, dprop11, dprop12
      real*8 rp31, sw_star, ds, prop2, dprop21, dprop22
      real*8 rp32
      real*8 q

c The Brooks-Corey rel. perm curves follow Miller et al. Adv. Water
c Resourc. (1998), Table 4
c q is equivalent to 'l' in Miller et al.  Earlier versions of FEHM hard-wired q==2

      rp31 = 1.d0+2.d0/lambda  !exp. in 2nd parentheses in krn (prop2)
      sw_star = (s-p1)/(1.d0-p1-p2)
      ds = 1.d0/(1.d0-p1-p2)
c     calculate rel perms
      if(sw_star.le.0.d0) then
         prop1 = 0.d0
         dprop11 = 0.d0
         prop2 = 1.d0
         dprop21 = 0.d0
       elseif(sw_star.ge.1.d0) then
         prop1 = 1.d0
         dprop11 = 0.d0
         prop2 = 0.d0
         dprop21 = 0.d0
      else
         prop1 = sw_star**(q+rp31)
         dprop11=ds**(q+rp31)*(q+rp31)*(s-p1)**(q+rp31-1.d0)
         prop2 = ((1.d0-sw_star)**q)*(1.d0-sw_star**rp31)
! this is derivative of non-wetting rlp with respect to wetting sat
         dprop21=ds*(q*(1.d0-sw_star)**(q-1.d0)*(1.d0-sw_star**rp31)+
     $        rp31*(1.d0-sw_star)**q*sw_star**(rp31-1.d0))

      endif

      end subroutine brooks_corey_rlp


module schroed_assembly
use types, only: dp
use sorting, only: sort
use utils, only: assert
use sparse, only: coo2csr_canonical
implicit none
private
public assemble_3d, assemble_3d_csr

contains

real(dp) elemental function f(x, y, z)
real(dp), intent(in) :: x, y, z
real(dp) :: V0, r0, r, Xion(3, 2)
integer :: n
V0 = 16
r0 = 0.5_dp
f = 0
Xion(:,1) = [6, 5, 5]/2._dp
Xion(:,2) = [6, 5, 5]/2._dp
Xion(1,:) = Xion(1,:) + [-1, 1]
do n = 1, 2
    r = sqrt(sum(([x,y,z]-Xion(:,n))**2))
    f = f - V0 * exp(-r**2/r0**2)
end do
end function

subroutine assemble_3d_coo(xin, nodes, elems, ib, xiq, wtq, phihq, dphihq, &
    matAi, matAj, matAx, idx, Bdiag)
! Assemble on a 2D rectangular uniform mesh
real(dp), intent(in):: xin(:), nodes(:, :), xiq(:), wtq(:, :, :), &
    phihq(:, :), dphihq(:, :)
integer, intent(in):: elems(:, :), ib(:, :, :, :)
integer, intent(out) :: matAi(:), matAj(:)
real(dp), intent(out):: matAx(:), Bdiag(:)
integer, intent(out) :: idx
real(dp), dimension(size(xiq), size(xiq), size(xiq), &
    size(xin), size(xin), size(xin)) :: phi_v, phi_dx, phi_dy, phi_dz
real(dp), dimension(size(xiq), size(xiq), size(xiq), &
    size(xiq), size(xiq), size(xiq)) :: Am_loc, Bm_loc
real(dp), dimension(size(xiq), size(xiq), size(xiq)) :: fq
real(dp), dimension(size(xiq)) :: x, y, z, xp, yp, zp
integer :: Ne, p, e, i, j, iqx, iqy, iqz
real(dp) :: lx, ly, lz
integer :: ax, ay, az, bx, by, bz
real(dp) :: jacx, jacy, jacz, jac_det

Ne = size(elems, 2)
p = size(xin) - 1
! 3D shape functions
do az = 1, p+1
do ay = 1, p+1
do ax = 1, p+1
    do iqz = 1, size(xiq)
    do iqy = 1, size(xiq)
    do iqx = 1, size(xiq)
        phi_v (iqx, iqy, iqz, ax, ay, az) = &
             phihq(iqx, ax) *  phihq(iqy, ay) *  phihq(iqz, az)
        phi_dx(iqx, iqy, iqz, ax, ay, az) = &
            dphihq(iqx, ax) *  phihq(iqy, ay) *  phihq(iqz, az)
        phi_dy(iqx, iqy, iqz, ax, ay, az) = &
             phihq(iqx, ax) * dphihq(iqy, ay) *  phihq(iqz, az)
        phi_dz(iqx, iqy, iqz, ax, ay, az) = &
             phihq(iqx, ax) *  phihq(iqy, ay) * dphihq(iqz, az)
    end do
    end do
    end do
end do
end do
end do
! Precalculate as much as possible:
lx = nodes(1, elems(7, 1)) - nodes(1, elems(1, 1)) ! Element sizes
ly = nodes(2, elems(7, 1)) - nodes(2, elems(1, 1))
lz = nodes(3, elems(7, 1)) - nodes(3, elems(1, 1))
jacx = lx/2
jacy = ly/2
jacz = lz/2
jac_det = abs(jacx*jacy*jacz)
xp = (xiq + 1) * jacx
yp = (xiq + 1) * jacy
zp = (xiq + 1) * jacz
phi_dx = phi_dx / jacx
phi_dy = phi_dy / jacy
phi_dz = phi_dz / jacz
! Precalculate element matrices:
do bz = 1, p+1
do by = 1, p+1
do bx = 1, p+1
    do az = 1, p+1
    do ay = 1, p+1
    do ax = 1, p+1
        Am_loc(ax, ay, az, bx, by, bz) = sum(( &
            phi_dx(:, :, :, ax, ay, az)*phi_dx(:, :, :, bx, by, bz) + &
            phi_dy(:, :, :, ax, ay, az)*phi_dy(:, :, :, bx, by, bz) + &
            phi_dz(:, :, :, ax, ay, az)*phi_dz(:, :, :, bx, by, bz)) &
            * jac_det * wtq) / 2
        Bm_loc(ax, ay, az, bx, by, bz) = sum(( &
            phi_v(:, :, :, ax, ay, az) * phi_v(:, :, :, bx, by, bz) &
            * jac_det * wtq))
    end do
    end do
    end do
end do
end do
end do
Bdiag = 0
idx = 0
do e = 1, Ne
    x = xp + nodes(1, elems(1, e))
    y = yp + nodes(2, elems(1, e))
    z = zp + nodes(3, elems(1, e))
    do iqz = 1, size(xiq)
    do iqy = 1, size(xiq)
    do iqx = 1, size(xiq)
        fq(iqx, iqy, iqz) = f(x(iqx), y(iqy), z(iqz))
    end do
    end do
    end do
    do bz = 1, p+1
    do by = 1, p+1
    do bx = 1, p+1
        j = ib(bx, by, bz, e)
        if (j==0) cycle
        do az = 1, p+1
        do ay = 1, p+1
        do ax = 1, p+1
            i = ib(ax, ay, az, e)
            if (i == 0) cycle
            if (j > i) cycle
            idx = idx + 1
            matAi(idx) = i
            matAj(idx) = j
            matAx(idx) = Am_loc(ax, ay, az, bx, by, bz) + sum(fq * &
                phi_v(:, :, :, ax, ay, az)*phi_v(:, :, :, bx, by, bz) &
                * jac_det * wtq)
            if (i /= j) then
                ! Symmetric contribution
                idx = idx + 1
                matAi(idx) = j
                matAj(idx) = i
                matAx(idx) = matAx(idx-1)
            end if
            if (i == j) Bdiag(i) = Bdiag(i) + Bm_loc(ax, ay, az, bx, by, bz)
        end do
        end do
        end do
    end do
    end do
    end do
end do
end subroutine

subroutine assemble_3d(xin, nodes, elems, ib, xiq, wtq, phihq, dphihq, &
    Am, Bdiag)
! Assemble on a 2D rectangular uniform mesh
real(dp), intent(in):: xin(:), nodes(:, :), xiq(:), wtq(:, :, :), &
    phihq(:, :), dphihq(:, :)
integer, intent(in):: elems(:, :), ib(:, :, :, :)
real(dp), intent(out):: Am(:,:), Bdiag(:)
integer, allocatable :: matAi(:), matAj(:)
real(dp), allocatable :: matAx(:)
integer :: idx, nmax
integer :: i, Ne, p
Ne = size(elems, 2)
p = size(xin) - 1
nmax = Ne*(p+1)**6
allocate(matAi(nmax), matAj(nmax), matAx(nmax))
call assemble_3d_coo(xin, nodes, elems, ib, xiq, wtq, phihq, dphihq, &
    matAi, matAj, matAx, idx, Bdiag)
call assert(idx <= nmax)
Am = 0
do i = 1, idx
    Am(matAi(i),matAj(i)) = Am(matAi(i),matAj(i)) + matAx(i)
end do
end subroutine

subroutine assemble_3d_csr(xin, nodes, elems, ib, xiq, wtq, phihq, dphihq, &
    matBp, matBj, matBx, Bdiag)
! Assemble on a 2D rectangular uniform mesh
real(dp), intent(in):: xin(:), nodes(:, :), xiq(:), wtq(:, :, :), &
    phihq(:, :), dphihq(:, :)
integer, intent(in):: elems(:, :), ib(:, :, :, :)
integer, intent(out), allocatable :: matBp(:), matBj(:)
real(dp), intent(out), allocatable :: matBx(:)
real(dp), intent(out):: Bdiag(:)
integer, allocatable :: matAi(:), matAj(:)
real(dp), allocatable :: matAx(:)
integer :: idx, nmax
integer :: i, Ne, p
Ne = size(elems, 2)
p = size(xin) - 1
nmax = Ne*(p+1)**6
allocate(matAi(nmax), matAj(nmax), matAx(nmax))
call assemble_3d_coo(xin, nodes, elems, ib, xiq, wtq, phihq, dphihq, &
    matAi, matAj, matAx, idx, Bdiag)
call assert(idx <= nmax)
call coo2csr_canonical(matAi(:idx), matAj(:idx), matAx(:idx), &
    matBp, matBj, matBx, verbose=.true.)
end subroutine

end module

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

program schroed3d

use types, only: dp
use fe_mesh, only: cartesian_mesh_3d, define_connect_tensor_3d
use schroed_assembly, only: assemble_3d, assemble_3d_csr
use feutils, only: get_parent_nodes, get_parent_quad_pts_wts, phih, dphih
use linalg, only: eigh
use linalg_feast, only: eigh_feast => eigh
use arpack, only: eig
use sparse, only: csr_matvec
implicit none

integer :: Nn, Ne
! nodes(:, i) are the (x,y) coordinates of the i-th mesh node
real(dp), allocatable :: nodes(:, :)
integer, allocatable :: elems(:, :) ! elems(:, i) are nodes of the i-th element
integer :: Nq, p, Nb
real(dp), allocatable :: xin(:), xiq(:), wtq(:), &
    lam(:), wtq3(:, :, :), phihq(:, :), dphihq(:, :), v(:,:), d(:), Bdiag(:)
integer, allocatable :: matAp(:), matAj(:)
real(dp), allocatable :: matAx(:)
integer, allocatable :: ib(:, :, :, :), in(:, :, :, :)
integer :: i, j, k, Nex, Ney, Nez, Neig, solver_type, M0, nev, ncv
real(dp) :: t1, t2

Nex = 4
Ney = 4
Nez = 4
p = 2
Nq = p+1

call cartesian_mesh_3d(Nex, Ney, Nez, &
    [0._dp, 0._dp, 0._dp], [6._dp, 5._dp, 5._dp], &
    nodes, elems)
Nn = size(nodes, 2)
Ne = size(elems, 2)

print *, "Number of nodes:", Nn
print *, "Number of elements:", Ne

allocate(xin(p+1))
call get_parent_nodes(2, p, xin)
allocate(xiq(Nq), wtq(Nq), wtq3(Nq, Nq, Nq))
call get_parent_quad_pts_wts(2, Nq, xiq, wtq)
forall(i=1:Nq, j=1:Nq, k=1:Nq) wtq3(i, j, k) = wtq(i)*wtq(j)*wtq(k)
allocate(phihq(size(xiq), size(xin)))
allocate(dphihq(size(xiq), size(xin)))
! Tabulate parent basis at quadrature points
forall(i=1:size(xiq), j=1:size(xin))  phihq(i, j) =  phih(xin, j, xiq(i))
forall(i=1:size(xiq), j=1:size(xin)) dphihq(i, j) = dphih(xin, j, xiq(i))

call define_connect_tensor_3d(Nex, Ney, Nez, p, 1, in)
call define_connect_tensor_3d(Nex, Ney, Nez, p, 3, ib)
Nb = maxval(ib)
print *, "p =", p
print *, "DOFs =", Nb
allocate(Bdiag(Nb))

!print *, "Assembling..."
!call assemble_3d(xin, nodes, elems, ib, xiq, wtq3, phihq, dphihq, A, Bdiag)
print *, "Assembling CSR..."
call assemble_3d_csr(xin, nodes, elems, ib, xiq, wtq3, phihq, dphihq, &
    matAp, matAj, matAx, Bdiag)
!print *, "Solving..."
!solver_type = 1
!select case(solver_type)
!    case (1)
!Neig = Nb
!allocate(c(Nb, Neig), lam(Neig))
!        call eigh(A, B, lam, c)
!    case (2)
!        M0 = 15
!        call eigh_feast(A, B, 0._dp, 5._dp, M0, lam, c)
!        Neig = size(lam)
!end select
!print *, "Eigenvalues:"
!Neig = 10
!do i = 1, Neig
!    print *, i, lam(i)
!end do
Bdiag = sqrt(Bdiag)
nev = 1
ncv = 20
allocate(v(Nb,ncv), d(ncv))
print *, "Eigensolver"
call cpu_time(t1)
call eig(Nb, nev, ncv, "SA", av, d, v)
call cpu_time(t2)
print *, "Arpack time:", t2-t1
print *, "i E"
do i = 1, nev
    print *, i, d(i)
end do

print *, "LINE:"
print *, Nex, Ney, Nez, p, Nb, d(:nev), 0, 0, 0

!B = 0
!do i = 1, Nb
!    B(i,i) = 1 / sqrt(Bdiag(i))
!end do
!print *, "Mul"
!A = matmul(matmul(B, A), B)
!print *, "Solve"
!call eigh(A, B, lam, c)
!do i = 1, nev
!    print *, i, lam(i)
!end do

contains

    subroutine av(x, y)
    ! Compute y = A*x
    real(dp), intent(in) :: x(:)
    real(dp), intent(out) :: y(:)
    !y = matmul(A, x/Bdiag)/Bdiag
    y = csr_matvec(matAp, matAj, matAx, x/Bdiag) / Bdiag
    end

end program


      program dihedral
      implicit double precision(a-h,o-z)

      real*8, allocatable :: co(:,:)
      character*2, allocatable :: lab(:)
      character*80 filename

      dimension x1(3),x2(3),x3(3),x4(3)
      dimension r12(3),r23(3),r34(3)
      dimension a(3),b(3),c(3)
      dimension acb(3),acc(3),ccb(3)

      pi=2.d0*acos(0.d0)

      open(unit=1,file='xyzFILENAME',status='old')
      read(1,100)filename
      close(unit=1)
100   format(a80)
      open(unit=1,file=trim(filename),status='old')
      read(1,*)natom
      allocate(lab(natom))
      allocate(co(natom,3))
      read(1,*)
      do n=1,natom
       read(1,*)lab(n),(co(n,k),k=1,3)
      enddo

      read(5,*) n1,n2,n3,n4

      do k=1,3
       x1(k)=co(n1,k)
       x2(k)=co(n2,k)
       x3(k)=co(n3,k)
       x4(k)=co(n4,k)
      enddo

      do k=1,3
       r12(k)=x2(k)-x1(k)
       r23(k)=x3(k)-x2(k)
       r34(k)=x4(k)-x3(k)
       c(k)=r23(k)
      enddo
      a(1)=r34(2)*r23(3)-r34(3)*r23(2)
      a(2)=r34(3)*r23(1)-r34(1)*r23(3)
      a(3)=r34(1)*r23(2)-r34(2)*r23(1)
      b(1)=r23(2)*r12(3)-r23(3)*r12(2)
      b(2)=r23(3)*r12(1)-r23(1)*r12(3)
      b(3)=r23(1)*r12(2)-r23(2)*r12(1)
      ccb(1)=c(2)*b(3)-c(3)*b(2)
      ccb(2)=c(3)*b(1)-c(1)*b(3)
      ccb(3)=c(1)*b(2)-c(2)*b(1)

      acc(1)=a(2)*c(3)-a(3)*c(2)
      acc(2)=a(3)*c(1)-a(1)*c(3)
      acc(3)=a(1)*c(2)-a(2)*c(1)

      acb(1)=a(2)*b(3)-a(3)*b(2)
      acb(2)=a(3)*b(1)-a(1)*b(3)
      acb(3)=a(1)*b(2)-a(2)*b(1)

      sum1=0.d0
      sum2=0.d0
      sum3=0.d0
      sum4=0.d0
      sum5=0.d0
      do k=1,3
       sum1=sum1+a(k)*a(k)
       sum2=sum2+b(k)*b(k)
       sum3=sum3+c(k)*c(k)
       sum4=sum4+a(k)*b(k)
       sum5=sum5+c(k)*acb(k)
      enddo
      sum1=sqrt(sum1)
      sum2=sqrt(sum2)
      sum3=sqrt(sum3)
      sumab=sum1*sum2
      cd=sum4/sumab
      sumabc=sumab*sum3
      sd=-sum5/sumabc

      phi=acos(cd)
      if(sd.lt.0.d0)phi=-phi
      phi=phi*180.d0/pi

      write(6,101)n1,n2,n3,n4,phi
101   format(4i10,f13.6)
      end


\ .( Loading Matrix Multiplication benchmark...) cr
\ NOTE: This version needs 0.5MB data space

\ A classical benchmark of an O(n**3) algorithm; Matrix Multiplication
\
\ Part of the programs gathered by John Hennessy for the MIPS
\ RISC project at Stanford. Translated to forth by  Marty Fraeman,
\ Johns Hopkins University/Applied Physics Laboratory.

\ MM forth2c doesn't have it !
: mybounds  over + swap ;

\ 1 cells constant cell

variable seed

: initiate-seed ( -- )  74755 seed ! ;
: random  ( -- n )  seed @ 1309 * 13849 + 65535 and dup seed ! ;

200 constant row-size
row-size cells constant row-byte-size

row-size row-size * constant mat-size
mat-size cells constant mat-byte-size

align create ima mat-byte-size allot
align create imb mat-byte-size allot
align create imr mat-byte-size allot

: initiate-matrix ( m[row-size][row-size] -- )
  mat-byte-size mybounds do
    random dup 120 / 120 * - 60 - i !
  1 cells +loop
;

: innerproduct ( a[row][*] b[*][column] -- int)
  0 row-size 0 do
    >r over @ over @ * r> + >r
    swap cell+ swap row-byte-size +
    r>
  loop
  >r 2drop r>
;

: mainx  ( -- )
  initiate-seed
  ima initiate-matrix
  imb initiate-matrix
  imr ima mat-byte-size mybounds do
    imb row-byte-size mybounds do
      j i innerproduct over ! cell+
    cell +loop
  row-size cells +loop
  drop
;

: main 10 0 do mainx loop ;


      SUBROUTINE EVALS(a1,a2,a3,theta,S,NN,s1,s2,N,dt,alpha)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      DIMENSION S(3,NN),s1(NN),s2(NN)
C
      t1 = a2/dt - a1*theta + a3 * theta * (1-alpha)
      t2 = 4.0 * a2/dt + 2.0 * a1 * theta + 2.0 * a3 * alpha
      t3 = a2/dt - a1*theta + a3 * theta * (-alpha-1)
C
      DO i=2,N
         S(1,i)=t1
         S(2,i)=t2
         S(3,i)=t3
      ENDDO
      S(3,2)   = 0.0D0
      S(1,N) = S(3,2)
C
C     Décomposition LU de S
C     ---------------------
      s1(2)   = S(2,2)
C
      DO i=3,N
         s2(i)   = S(3,i)/s1(i-1)
         s1(i)   = S(2,i)-s2(i)*S(1,i-1)
         WRITE(1,*)'S1(',i,')=',S1(i),';'
         WRITE(1,*)'S2(',i,')=',S2(i),';'
      ENDDO
C
      RETURN
      END


module pmmf_fic_case1
#include <messenger.h>
    use mod_kinds,      only: rk,ik
    use mod_constants,  only: ZERO, HALF, ONE, TWO, THREE, FOUR, FIVE, EIGHT, PI
    use type_prescribed_mesh_motion_function,  only: prescribed_mesh_motion_function_t
    implicit none
    private

    !>  Flow In Cylinder - Case1 prescribed motion.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   10/02/2019
    !!
    !-------------------------------------------------------------------------------
    type, extends(prescribed_mesh_motion_function_t), public :: fic_case1_pmmf
        private

    contains

        procedure   :: init
        procedure   :: compute_pos
        procedure   :: compute_vel

    end type fic_case1_pmmf
    !********************************************************************************

contains

    !>
    !!
    !!  @author Nathan A. Wukie
    !!  @date   10/02/2019
    !!
    !-------------------------------------------------------------------------
    subroutine init(self)
        class(fic_case1_pmmf),  intent(inout)  :: self

        ! Set function name
        call self%set_name("Flow In Cylinder - Case1")

    end subroutine init
    !*************************************************************************

    !>
    !!
    !!  @author Nathan A. Wukie
    !!  @date   10/02/2019
    !!
    !!
    !-----------------------------------------------------------------------------------------
    function compute_pos(self,time,node) result(val)
        class(fic_case1_pmmf),  intent(inout)   :: self
        real(rk),               intent(in)      :: time
        real(rk),               intent(in)      :: node(3)

        integer(ik) :: ivar
        real(rk)    :: val(3)

        real(rk)    :: alpha, x0, y0, x_ale, y_ale, &
                       xc, yc, height, theta

        alpha = time**TWO*(THREE-time)/FOUR

        if (time <= TWO) height = alpha
        if (time >  TWO) height = ONE
        theta = ZERO

        !Center of motion nodeinates
        xc = ZERO
        yc = ZERO

        !Get the reference frame coordinates of the grid point
        x0 = node(1)
        y0 = node(2)

        !Rotate about the center of motion
        x_ale =  cos(theta)*(x0-xc)+sin(theta)*(y0-yc) + xc
        y_ale = -sin(theta)*(x0-xc)+cos(theta)*(y0-yc) + yc

        !Translate vertically
        y_ale = y_ale + height

        val(1) = x_ale
        val(2) = y_ale
        val(3) = node(3)

    end function compute_pos
    !**********************************************************************************

    !>
    !!
    !!  @author Eric Wolf
    !!  @date   3/15/2017
    !!
    !!
    !-----------------------------------------------------------------------------------------
    function compute_vel(self,time,node) result(val)
        class(fic_case1_pmmf),  intent(inout)   :: self
        real(rk),               intent(in)      :: time
        real(rk),               intent(in)      :: node(3)

        integer(ik) :: ivar
        real(rk)    :: val(3)
        real(rk)    :: alpha, dalphadt, x0, y0, vx_ale, vy_ale, &
                       xc, yc, height, theta, dheightdt, dthetadt

        alpha = time**TWO*(THREE-time)/FOUR

        dalphadt = TWO*time*(THREE-time)/FOUR + &
                   time**TWO*(-ONE)/FOUR

        !Case 1
        height = alpha
        theta  = ZERO
        dheightdt = dalphadt
        dthetadt  = ZERO

        !Center of motion coordinates
        xc = ZERO
        yc = ZERO

        !Get the reference frame nodeinates of the grid point
        x0 = node(1)
        y0 = node(2)

        !Rotate about the center of motion
        vx_ale = -sin(theta)*dthetadt*(x0-xc)+cos(theta)*dthetadt*(y0-yc)
        vy_ale = -cos(theta)*dthetadt*(x0-xc)-sin(theta)*dthetadt*(y0-yc)

        !Translate vertically
        vy_ale = vy_ale + dheightdt

        val(1) = vx_ale
        val(2) = vy_ale
        val(3) = ZERO

    end function compute_vel
    !**********************************************************************************

end module pmmf_fic_case1


program gen_table
implicit none
!real,parameter :: delr=0.002,rcut=1.0
real, parameter :: delr=0.0005, rcut=10.0
real :: r
integer :: nbins,j

nbins=int( (rcut+1)/delr) + 1
open(unit=6,file='table_QA_QA.xvg')

do j=0,nbins
    r=delr*j
    ! for table_QA_QA
    write(6,*) r, 1/r, 1/(r*r), (-1.0)/(r**6), (-6.0)/(r**7), 1/(r**12), 12/(r**13)

    !! for table_QA_QB
    !IF (r <= 1.12246) THEN
    !    write(6,*) r*1.0D0, 1.0D0/r, 1.0D0/(r*r), (-4.0D0)/(r**6), (-24.0D0)/(r**7), 4.0D0/(r**12)+1.0D0, 48.0D0/(r**13)
    !ELSE
    !    write(6,*) r*1.0D0, 1.0D0/r, 1.0D0/(r*r), 0.0D0, 0.0D0, 0.0D0, 0.0D0
    !ENDIF
    !!  for table_QA_QB
end do

close(6)

End program


! Riemann solver in the transverse direction for the Euler equations
!  with a tracer variable.
! Split asdq (= A^* \Delta q, where * = + or -)
! into down-going flux difference bmasdq (= B^- A^* \Delta q)
!    and up-going flux difference bpasdq (= B^+ A^* \Delta q)

! Uses Roe averages and other quantities which were
! computed in rpn2eu and stored in the common block comroe.
!
subroutine rpt2(ixy,imp,maxm,meqn,mwaves,maux,mbc,mx,ql,qr,aux1,aux2,aux3,asdq,bmasdq,bpasdq)

    implicit none

    ! Input
    integer, intent(in) :: ixy, imp, maxm, meqn, mwaves, mbc, mx, maux
    real(kind=8), intent(in) :: ql(meqn, 1-mbc:maxm+mbc)
    real(kind=8), intent(in) :: qr(meqn, 1-mbc:maxm+mbc)
    real(kind=8), intent(in) :: aux1(maux, 1-mbc:maxm+mbc)
    real(kind=8), intent(in) :: aux2(maux, 1-mbc:maxm+mbc)
    real(kind=8), intent(in) :: aux3(maux, 1-mbc:maxm+mbc)
    real(kind=8), intent(in) :: asdq(meqn, 1-mbc:maxm+mbc)

    ! Output
    real(kind=8), intent(in out) :: bmasdq(meqn, 1-mbc:maxm+mbc)
    real(kind=8), intent(in out) :: bpasdq(meqn, 1-mbc:maxm+mbc)

    ! Local storage
    integer :: i, mw, mu, mv
    real(kind=8) :: a(4), waveb(5,4), sb(4), rho_sqrtl, rho_sqrtr, rho_sq2
    real(kind=8) :: u, v, u2v2, pl, pr, enth, c, g1c2, euv

    ! Common block - ideal gas constant
    real(kind=8) :: gamma, gamma1
    common /cparam/  gamma

    gamma1 = gamma - 1.d0

    ! Initialize output
    bmasdq = 0.d0
    bpasdq = 0.d0

    ! Normal and transverse direction indices
    if (ixy == 1) then
        mu = 2
        mv = 3
    else
        mu = 3
        mv = 2
    endif

    ! Primary loop over grid cell interfaces
    do i = 2-mbc, mx+mbc
        ! Roe averaged variables
        rho_sqrtl = dsqrt(qr(1,i-1))
        rho_sqrtr = dsqrt(ql(1,i))
        rho_sq2 = rho_sqrtl + rho_sqrtr
        u = (qr(mu,i-1) / rho_sqrtl + ql(mu,i) / rho_sqrtr) / rho_sq2
        v = (qr(mv,i-1) / rho_sqrtl + ql(mv,i) / rho_sqrtr) / rho_sq2
        u2v2 = u**2 + v**2

        pl = gamma1*(qr(4,i-1) - 0.5d0*(qr(2,i-1)**2 + qr(3,i-1)**2)/qr(1,i-1))
        pr = gamma1*(ql(4,i)   - 0.5d0*(ql(2,i)**2   + ql(3,i)**2)  /ql(1,i))
        enth = (((qr(4,i-1)+pl)/rho_sqrtl + (ql(4,i)+pr)/rho_sqrtr)) / rho_sq2

        c = sqrt(gamma1*(enth - 0.5d0*u2v2))
        g1c2 = gamma1 / c**2
        euv = enth - u2v2

        a(3) = g1c2 * (euv*asdq(1,i) + u*asdq(mu,i) + v*asdq(mv,i) - asdq(4,i))
        a(2) = asdq(mu,i) - u*asdq(1,i)
        a(4) = (asdq(mv,i) + (c-v)*asdq(1,i) - c*a(3)) / (2.d0*c)
        a(1) = asdq(1,i) - a(3) - a(4)

        waveb(1,1) = a(1)
        waveb(mu,1) = a(1)*u
        waveb(mv,1) = a(1)*(v-c)
        waveb(4,1) = a(1)*(enth - v*c)
        waveb(5,1) = 0.d0
        sb(1) = v - c

        waveb(1,2) = a(3)
        waveb(mu,2) = a(3)*u + a(2)
        waveb(mv,2) = a(3)*v
        waveb(4,2) = a(3)*0.5d0*u2v2 + a(2)*u
        waveb(5,2) = 0.d0
        sb(2) = v

        waveb(1,3) = a(4)
        waveb(mu,3) = a(4)*u
        waveb(mv,3) = a(4)*(v+c)
        waveb(4,3) = a(4)*(enth+v*c)
        waveb(5,3) = 0.d0
        sb(3) = v + c

        waveb(1,4) = 0.d0
        waveb(mu,4) = 0.d0
        waveb(mv,4) = 0.d0
        waveb(4,4) = 0.d0
        waveb(5,4) = asdq(5,i)
        sb(4) = v

        ! Compute the flux differences bmasdq and bpasdq
        do mw=1,4
            bmasdq(:,i) = bmasdq(:,i) + min(sb(mw), 0.d0) * waveb(:,mw)
            bpasdq(:,i) = bpasdq(:,i) + max(sb(mw), 0.d0) * waveb(:,mw)
        end do
    end do

end subroutine rpt2


!***********************************************************************
!                                                                      *
      SUBROUTINE QUAD(RESULT)
!                                                                      *
!   The argument result is an approximation  to the integral of F(R)   *
!   from  zero  to  infinity,  where the values of RP(I)*F(R(I)) are   *
!   tabulated in the array  TA(I). The integral in the interval zero   *
!   to R(J) is computed by use of an analytical fit                    *
!                                                                      *
!                                SIGMA                                 *
!                      F(R) = A R                                      *
!                                                                      *
!   A five-point  Closed  Newton-Cotes  formula (cf. F B Hildebrand,   *
!   Introduction to Numerical Analysis, second edition, McGraw-Hill,   *
!   New York, 1974, p 93)  is  used  to  compute the integral in the   *
!   interval  R(J:MTP).  The  contribution  from  the  tail  of  the   *
!   function beyond the last  tabular  point  (MTP) is assumed to be   *
!   negligible. The method uses  MTP+3  tabulation points. Array  TA   *
!   should therefore be dimensioned to at least  N+4 .                 *
!                                                                      *
!   No subroutines called.                                             *
!                                                                      *
!   Written by Farid A Parpia, at Oxford   Last updated: 06 Oct 1992   *
!                                                                      *
!***********************************************************************
!...Translated by Pacific-Sierra Research 77to90  4.3E  10:50:18   2/14/04
!...Modified by Charlotte Froese Fischer
!                     Gediminas Gaigalas  10/05/17
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      USE DEF_C
      USE GRID_C
      USE NCC_C
      USE TATB_C, ONLY: TA, MTP
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      REAL(DOUBLE) , INTENT(OUT) :: RESULT
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: MTPM1, I, IP1, LOC
      REAL(DOUBLE) :: TAI, TAIP1, QUOTT, FRIP1, FRI, RATIO, RIP1, RI, SIGMA
!-----------------------------------------------
!
!
!   Find first values that will permit computation of exponent
!
      MTPM1 = MTP - 1
      DO I = 2, MTPM1
!
         TAI = TA(I)
         IF (ABS(TAI) <= 0.D0) CYCLE
!
         IP1 = I + 1
         TAIP1 = TA(IP1)
         QUOTT = TAIP1/TAI
!
         IF (QUOTT <= 0.D0) CYCLE
!
!   Exponent from fit
!
         FRIP1 = TAIP1/RP(IP1)
         FRI = TAI/RP(I)
         RATIO = FRIP1/FRI
         RIP1 = R(IP1)
         RI = R(I)
         SIGMA = LOG(RATIO)/LOG(RIP1/RI)
!
!   Analytical integration and error estimate for interval r(1:i)
!
         FRI = RI*FRI
         RESULT = FRI/(SIGMA + 1.D0)
!
!   Set the tail to zero
!
         TA(MTP+1:3+MTP) = 0.D0
!
!   Newton-Cotes quadature for the remainder
!
         RESULT = RESULT + C1*TAI
         RESULT = RESULT + SUM(C2*(TA(IP1:MTP:4)+TA(IP1+2:MTP+2:4))+C3*TA(IP1+1&
            :MTP+1:4)+C4*TA(IP1+3:MTP+3:4))
         IF (MOD(MTP - I,4) == 0) RESULT = RESULT - C1*TA(MTP)
!
!   Test of result's accuracy; `decomment' to activate
!
!              ESTDER = 10.0D 00*RI*FRI
!              RATIO = ABS (ESTDER/RESULT)
!              IF (RATIO .GT. ACCY) PRINT (*,300) RATIO
!
         GO TO 4
!
      END DO
!
!   No value which will permit computation of exponent
!
      RESULT = 0.D0
!
    4 CONTINUE
      RETURN
!
  300 FORMAT(/,'QUAD: Estimated accuracy is ',1P,D10.3,/,&
         ' Decrease RNT or improve input data conditioning to',' ameliorate.'/)
      RETURN
!
      END SUBROUTINE QUAD


c
c-----------------------------------------------------------------------
c
c
      subroutine p17tru(x,y,rho,u,v,pr)
      implicit double precision(a-h,o-z)
      common /userdt/ cfl,gamma,gamma1,xprob,yprob,alpha,Re,iprob,
     .                ismp,gradThreshold
c
c     # For the point (x,y), compute the true solution at this point
c
       rhoinf = 1.d0
       pinf = 1.d0
       rm = .05d0
       vinf = rm * dsqrt(gamma*pinf/rhoinf)
       vinf2 = vinf * vinf
       einf = pinf / rhoinf / (gamma - 1.d0)
       ho = gamma * einf + vinf2 / 2.d0
c
c   a = cylinder radius
c   centerx,centery =  the center of the cyl.
c      a = .1923538406d0
       a =  1.000567d0
       centerx = 2.d0
       centery = 2.d0

       a2 = a * a
       xx = x - centerx
       yy = y - centery

	y2 = yy * yy
	r2 = xx**2 + yy**2
	r4 = r2 * r2

	u = vinf * (1.d0 + a2 / r2 * ( 2.d0 * y2 / r2 - 1.d0) )
	v = -2.d0 * vinf * a2 * xx * yy / r4
	vel2 = u*u + v*v

	pr = pinf + .5d0 * rhoinf * (vinf2 - vel2)
	rho = rhoinf

      return
      end


cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
cc                                                                    cc
cc                  mnspgr : spgrid test program                      cc
cc                                                                    cc
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c  ..local scalars..
      real del,ermax,erf,exr0,exr1,fp,pi,sum,r0,r1,one,ai,s
      integer i,ier,is,j,k,kwrk,lwrk,m,mu,mv,nc,nuest,nu,nvest,nv
c  ..local arrays..
      integer ider(4),iopt(3),iwrk(70),iw(25)
      real u(11),v(14),r(154),c(300),tu(25),tv(25),f(154),wk(100),
     * exact(154),err(14),sp(14),wrk(1500)
c  ..function references..
      real abs,atan2,tesspg
c  ..
c  set constants
      one = 1
      pi = atan2(0.,-one)
      del = pi*0.05
c we set up the number of u (latitude)-values of the grid.
      mu = 11
c we set up the u-coordinates of the grid.
      read(5,905)(iw(i),i=1,mu)
      do 10 i=1,mu
         ai = iw(i)
         u(i) = ai*del
  10  continue
c we set up the number of v (longitude)-values of the grid
      mv = 14
c we set up the v-coordinates of the grid.
      read(5,905)(iw(i),i=1,mv)
      do 20 i=1,mv
         ai = iw(i)
         v(i) = ai*del
  20  continue
c we fetch the data values at the grid points.
      m = mu*mv
      read(5,900) (r(i),i=1,m)
c we print the data values at the grid points. we also compute and print
c the exact value of the test function underlying the data.
      write(6,910)
      write(6,915) (j,j=1,mv,2)
      write(6,920)
      exr0 = tesspg(0.,0.)
      exr1 = tesspg(pi,0.)
      ermax = 0.
      sum = 0.
      l = 0
      do 40 i=1,mu
        l = (i-1)*mv+1
        k = 1
        do 30 j=1,7
          exact(l) = tesspg(u(i),v(k))
          erf = abs(exact(l)-r(l))
          sum = sum+erf
          if(erf.gt.ermax) ermax = erf
          sp(j) = exact(l)
          err(j) = r(l)
          l = l+2
          k = k+2
  30    continue
        write(6,925) i,(err(j),j=1,7)
        write(6,930) (sp(j),j=1,7)
  40  continue
      write(6,915) (j,j=2,mv,2)
      write(6,920)
      do 60 i=1,mu
        l = (i-1)*mv+2
        k = 2
        do 50 j=1,7
          exact(l) = tesspg(u(i),v(k))
          erf = abs(exact(l)-r(l))
          sum = sum+erf
          if(erf.gt.ermax) ermax = erf
          sp(j) = exact(l)
          err(j) = r(l)
          l = l+2
          k = k+2
  50    continue
        write(6,925) i,(err(j),j=1,7)
        write(6,930) (sp(j),j=1,7)
  60  continue
      ai = m
      sum = sum/ai
      write(6,935) sum,ermax
      write(6,940) exr0,exr1
c  we set up the dimension information
      nuest = 19
      nvest = 21
      kwrk = 70
      lwrk = 1500
c main loop for the different spline approximations
      do 300 is=1,6
        go to (110,120,130,140,150,160),is
c  we start computing a set of spline approximations with
c  only c0-continuity at the poles,
 110    iopt(2) = 0
        ider(2) = 0
        iopt(3) = 0
        ider(4) = 0
c  with no data values at the poles.
        ider(1) = -1
        ider(3) = -1
c  initialisation
        iopt(1) = 0
c  a large value for s for computing the least-squares polynomial
        s = 60.
        go to 200
c  iopt(1) = 1 from the second call on
 120    s = 0.05
        iopt(1) = 1
        go to 200
c  an interpolating spline
 130    s = 0.
        go to 200
c  a second set of approximations with c1-continuity at the poles
 140    iopt(2) = 1
        iopt(3) = 1
c  exact values at the poles.
        ider(1) = 1
        ider(3) = 1
        r0 = exr0
        r1 = exr1
c reinitialization
        iopt(1) = 0
        s = 0.05
        go to 200
c  vanishing derivatives at the poles
 150    ider(2) = 1
        ider(4) = 1
c reinitialization
        iopt(1) = 0
        go to 200
c finally we calculate the least-squares spline according to the current
c  set of knots
 160    iopt(1) = -1
 200    call spgrid(iopt,ider,mu,u,mv,v,r,r0,r1,s,nuest,nvest,
     *    nu,tu,nv,tv,c,fp,wrk,lwrk,iwrk,kwrk,ier)
c printing of the fitting results.
        if(iopt(1).ge.0) go to 210
        write(6,945)
        go to 220
 210    write(6,950) s
 220    write(6,955) iopt(2),iopt(3)
        if(ider(2).eq.1) write(6,960)
        if(ider(4).eq.1) write(6,965)
        write(6,970) fp,ier
        write(6,975) nu
        write(6,980)
        write(6,985) (tu(i),i=1,nu)
        write(6,990) nv
        write(6,980)
        write(6,985) (tv(i),i=1,nv)
        nc = (nu-4)*(nv-4)
        write(6,995)
        write(6,985) (c(i),i=1,nc)
c  evaluation of the spline approximation
        call bispev(tu,nu,tv,nv,c,3,3,u,mu,v,mv,f,wk,100,iw,25,ier)
        write(6,1000)
        write(6,915) (j,j=1,mv,2)
        write(6,920)
        ermax = 0.
        sum = 0.
        do 240 i=1,mu
          k = i
          do 230 j=1,mv
            sp(j) = f(k)
            err(j) = abs(exact(k)-f(k))
            sum = sum+err(j)
            if(err(j).gt.ermax) ermax = err(j)
            k = k+1
 230      continue
          if( (i/2)*2 .ne.i ) go to 240
          write(6,925) i,(sp(j),j=1,mv,2)
          write(6,930) (err(j),j=1,mv,2)
 240    continue
        sum = sum/ai
        write(6,935) sum,ermax
        write(6,1005) c(1),c(nc)
 300  continue
      stop
 900  format(7f8.3)
 905  format(14i3)
 910  format(49h1data value (exact function value) at grid points)
 915  format(8h0v(j),j=,3x,7(i2,6x))
 920  format(8h u(i),i=)
 925  format(1x,i5,7(2x,f6.3))
 930  format(7x,7(2h (,f5.3,1h)))
 935  format(19h0mean abs. error = ,f9.3,5x,18hmax. abs. error = ,f9.3)
 940  format(30h function values at the poles ,f7.3,5x,f7.3)
 945  format(21h0least-squares spline)
 950  format(25h0smoothing spline with s=,f7.2)
 955  format(1x,34horder of continuity at the poles =,2i5)
 960  format(1x,37hvanishing derivatives at the pole u=0)
 965  format(1x,38hvanishing derivatives at the pole u=pi)
 970  format(1x,23hsum squared residuals =,e15.6,5x,11herror flag=,i3)
 975  format(1x,42htotal number of knots in the u-direction =,i3)
 980  format(1x,22hposition of the knots )
 985  format(5x,8f9.4)
 990  format(1x,42htotal number of knots in the v-direction =,i3)
 995  format(23h0b-spline coefficients )
1000  format(50h0spline value (approximation error) at grid points)
1005  format(28h spline values at the poles ,f7.3,5x,f7.3)
      end
c
      real function tesspg(u,v)
c function program tesspg calculates the value of the test function
c underlying the data.
      real u,v,sin,cos
      tesspg = 2./(4.1+cos(3.*u)+3.*cos(v+v+u*0.25)*sin(u)**2)
      return
      end


program hip_dscal

  use iso_c_binding
  use hipfort
  use hipfort_check
  use hipfort_hipblas

  implicit none

  integer, parameter :: N = 10240;

  double precision, parameter :: alpha = 10.d0

  double precision,pointer,dimension(:) :: dx

  double precision,allocatable,target,dimension(:) :: hx
  double precision,allocatable,dimension(:) ::hx_scaled

  double precision :: error
  double precision, parameter :: error_max = 10*epsilon(error_max)

  type(c_ptr) :: hip_blas_handle = c_null_ptr

  integer :: i

  write(*,"(a)",advance="no") "-- Running test 'dscal' (Fortran 2008 interfaces) - "
  allocate(hx(N))
  allocate(hx_scaled(N))

  hx(:) = 10.d0

  hx_scaled = alpha*hx

  call hipblasCheck(hipblasCreate(hip_blas_handle))

  call hipCheck(hipMalloc(dx,shape(hx)))

   ! Transfer data from host to device memory
  call hipCheck(hipMemcpy(dx, hx, hipMemcpyHostToDevice))

  call hipblasCheck(hipblasDscal(hip_blas_handle, N, alpha, dx, 1))

  call hipCheck(hipDeviceSynchronize())

  ! Transfer data back to host memory
  call hipCheck(hipMemcpy(hx, dx, hipMemcpyDeviceToHost))

  call hipCheck(hipFree(dx))

  ! Verification
  do i = 1,N
     error = abs(hx(i) - hx_scaled(i) )
     if( error .gt. error_max ) then
        write(*,*) "FAILED! Error bigger than max! Error = ", error, " hx(i) = ", hx(i)
        call exit
     endif
  end do

  call hipblasCheck(hipblasDestroy(hip_blas_handle))

  deallocate(hx_scaled,hx)

  write(*,*) "PASSED!"

end program hip_dscal


Module m_mrgref
Integer, Parameter :: kdp = selected_real_kind(15)
public :: mrgref
private :: kdp
private :: R_mrgref, I_mrgref, D_mrgref
interface mrgref
  module procedure d_mrgref, r_mrgref, i_mrgref
end interface mrgref
contains

Subroutine D_mrgref (XVALT, IRNGT)
!   Ranks array XVALT into index array IRNGT, using merge-sort
! __________________________________________________________
!   This version is not optimized for performance, and is thus
!   not as difficult to read as some other ones.
!   Michel Olagnon - April 2000
! __________________________________________________________
! __________________________________________________________
      Real (kind=kdp), Dimension (:), Intent (In) :: XVALT
      Integer, Dimension (:), Intent (Out) :: IRNGT
! __________________________________________________________
!
      Integer, Dimension (:), Allocatable :: JWRKT
      Integer :: LMTNA, LMTNC
      Integer :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB
!
      NVAL = Min (SIZE(XVALT), SIZE(IRNGT))
      If (NVAL <= 0) Then
         Return
      End If
!
!  Fill-in the index array, creating ordered couples
!
      Do IIND = 2, NVAL, 2
         If (XVALT(IIND-1) < XVALT(IIND)) Then
            IRNGT (IIND-1) = IIND - 1
            IRNGT (IIND) = IIND
         Else
            IRNGT (IIND-1) = IIND
            IRNGT (IIND) = IIND - 1
         End If
      End Do
      If (Modulo (NVAL, 2) /= 0) Then
         IRNGT (NVAL) = NVAL
      End If
!
!  We will now have ordered subsets A - B - A - B - ...
!  and merge A and B couples into     C   -   C   - ...
!
      Allocate (JWRKT(1:NVAL))
      LMTNC = 2
      LMTNA = 2
!
!  Iteration. Each time, the length of the ordered subsets
!  is doubled.
!
      Do
         If (LMTNA >= NVAL) Exit
         IWRKF = 0
         LMTNC = 2 * LMTNC
         IWRK = 0
!
!   Loop on merges of A and B into C
!
         Do
            IINDA = IWRKF
            IWRKD = IWRKF + 1
            IWRKF = IINDA + LMTNC
            JINDA = IINDA + LMTNA
            If (IWRKF >= NVAL) Then
               If (JINDA >= NVAL) Exit
               IWRKF = NVAL
            End If
            IINDB = JINDA
!
!   Shortcut for the case when the max of A is smaller
!   than the min of B (no need to do anything)
!
            If (XVALT(IRNGT(JINDA)) <= XVALT(IRNGT(JINDA+1))) Then
               IWRK = IWRKF
               Cycle
            End If
!
!  One steps in the C subset, that we create in the final rank array
!
            Do
               If (IWRK >= IWRKF) Then
!
!  Make a copy of the rank array for next iteration
!
                  IRNGT (IWRKD:IWRKF) = JWRKT (IWRKD:IWRKF)
                  Exit
               End If
!
               IWRK = IWRK + 1
!
!  We still have unprocessed values in both A and B
!
               If (IINDA < JINDA) Then
                  If (IINDB < IWRKF) Then
                     If (XVALT(IRNGT(IINDA+1)) > XVALT(IRNGT(IINDB+1))) &
                    & Then
                        IINDB = IINDB + 1
                        JWRKT (IWRK) = IRNGT (IINDB)
                     Else
                        IINDA = IINDA + 1
                        JWRKT (IWRK) = IRNGT (IINDA)
                     End If
                  Else
!
!  Only A still with unprocessed values
!
                     IINDA = IINDA + 1
                     JWRKT (IWRK) = IRNGT (IINDA)
                  End If
               Else
!
!  Only B still with unprocessed values
!
                  IRNGT (IWRKD:IINDB) = JWRKT (IWRKD:IINDB)
                  IWRK = IWRKF
                  Exit
               End If
!
            End Do
         End Do
!
!  The Cs become As and Bs
!
         LMTNA = 2 * LMTNA
      End Do
!
!  Clean up
!
      Deallocate (JWRKT)
      Return
!
End Subroutine D_mrgref

Subroutine R_mrgref (XVALT, IRNGT)
!   Ranks array XVALT into index array IRNGT, using merge-sort
! __________________________________________________________
!   This version is not optimized for performance, and is thus
!   not as difficult to read as some other ones.
!   Michel Olagnon - April 2000
! __________________________________________________________
! _________________________________________________________
      Real, Dimension (:), Intent (In) :: XVALT
      Integer, Dimension (:), Intent (Out) :: IRNGT
! __________________________________________________________
!
      Integer, Dimension (:), Allocatable :: JWRKT
      Integer :: LMTNA, LMTNC
      Integer :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB
!
      NVAL = Min (SIZE(XVALT), SIZE(IRNGT))
      If (NVAL <= 0) Then
         Return
      End If
!
!  Fill-in the index array, creating ordered couples
!
      Do IIND = 2, NVAL, 2
         If (XVALT(IIND-1) < XVALT(IIND)) Then
            IRNGT (IIND-1) = IIND - 1
            IRNGT (IIND) = IIND
         Else
            IRNGT (IIND-1) = IIND
            IRNGT (IIND) = IIND - 1
         End If
      End Do
      If (Modulo (NVAL, 2) /= 0) Then
         IRNGT (NVAL) = NVAL
      End If
!
!  We will now have ordered subsets A - B - A - B - ...
!  and merge A and B couples into     C   -   C   - ...
!
      Allocate (JWRKT(1:NVAL))
      LMTNC = 2
      LMTNA = 2
!
!  Iteration. Each time, the length of the ordered subsets
!  is doubled.
!
      Do
         If (LMTNA >= NVAL) Exit
         IWRKF = 0
         LMTNC = 2 * LMTNC
         IWRK = 0
!
!   Loop on merges of A and B into C
!
         Do
            IINDA = IWRKF
            IWRKD = IWRKF + 1
            IWRKF = IINDA + LMTNC
            JINDA = IINDA + LMTNA
            If (IWRKF >= NVAL) Then
               If (JINDA >= NVAL) Exit
               IWRKF = NVAL
            End If
            IINDB = JINDA
!
!   Shortcut for the case when the max of A is smaller
!   than the min of B (no need to do anything)
!
            If (XVALT(IRNGT(JINDA)) <= XVALT(IRNGT(JINDA+1))) Then
               IWRK = IWRKF
               Cycle
            End If
!
!  One steps in the C subset, that we create in the final rank array
!
            Do
               If (IWRK >= IWRKF) Then
!
!  Make a copy of the rank array for next iteration
!
                  IRNGT (IWRKD:IWRKF) = JWRKT (IWRKD:IWRKF)
                  Exit
               End If
!
               IWRK = IWRK + 1
!
!  We still have unprocessed values in both A and B
!
               If (IINDA < JINDA) Then
                  If (IINDB < IWRKF) Then
                     If (XVALT(IRNGT(IINDA+1)) > XVALT(IRNGT(IINDB+1))) &
                    & Then
                        IINDB = IINDB + 1
                        JWRKT (IWRK) = IRNGT (IINDB)
                     Else
                        IINDA = IINDA + 1
                        JWRKT (IWRK) = IRNGT (IINDA)
                     End If
                  Else
!
!  Only A still with unprocessed values
!
                     IINDA = IINDA + 1
                     JWRKT (IWRK) = IRNGT (IINDA)
                  End If
               Else
!
!  Only B still with unprocessed values
!
                  IRNGT (IWRKD:IINDB) = JWRKT (IWRKD:IINDB)
                  IWRK = IWRKF
                  Exit
               End If
!
            End Do
         End Do
!
!  The Cs become As and Bs
!
         LMTNA = 2 * LMTNA
      End Do
!
!  Clean up
!
      Deallocate (JWRKT)
      Return
!
End Subroutine R_mrgref
Subroutine I_mrgref (XVALT, IRNGT)
!   Ranks array XVALT into index array IRNGT, using merge-sort
! __________________________________________________________
!   This version is not optimized for performance, and is thus
!   not as difficult to read as some other ones.
!   Michel Olagnon - April 2000
! __________________________________________________________
! __________________________________________________________
      Integer, Dimension (:), Intent (In)  :: XVALT
      Integer, Dimension (:), Intent (Out) :: IRNGT
! __________________________________________________________
!
      Integer, Dimension (:), Allocatable :: JWRKT
      Integer :: LMTNA, LMTNC
      Integer :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB
!
      NVAL = Min (SIZE(XVALT), SIZE(IRNGT))
      If (NVAL <= 0) Then
         Return
      End If
!
!  Fill-in the index array, creating ordered couples
!
      Do IIND = 2, NVAL, 2
         If (XVALT(IIND-1) < XVALT(IIND)) Then
            IRNGT (IIND-1) = IIND - 1
            IRNGT (IIND) = IIND
         Else
            IRNGT (IIND-1) = IIND
            IRNGT (IIND) = IIND - 1
         End If
      End Do
      If (Modulo (NVAL, 2) /= 0) Then
         IRNGT (NVAL) = NVAL
      End If
!
!  We will now have ordered subsets A - B - A - B - ...
!  and merge A and B couples into     C   -   C   - ...
!
      Allocate (JWRKT(1:NVAL))
      LMTNC = 2
      LMTNA = 2
!
!  Iteration. Each time, the length of the ordered subsets
!  is doubled.
!
      Do
         If (LMTNA >= NVAL) Exit
         IWRKF = 0
         LMTNC = 2 * LMTNC
         IWRK = 0
!
!   Loop on merges of A and B into C
!
         Do
            IINDA = IWRKF
            IWRKD = IWRKF + 1
            IWRKF = IINDA + LMTNC
            JINDA = IINDA + LMTNA
            If (IWRKF >= NVAL) Then
               If (JINDA >= NVAL) Exit
               IWRKF = NVAL
            End If
            IINDB = JINDA
!
!   Shortcut for the case when the max of A is smaller
!   than the min of B (no need to do anything)
!
            If (XVALT(IRNGT(JINDA)) <= XVALT(IRNGT(JINDA+1))) Then
               IWRK = IWRKF
               Cycle
            End If
!
!  One steps in the C subset, that we create in the final rank array
!
            Do
               If (IWRK >= IWRKF) Then
!
!  Make a copy of the rank array for next iteration
!
                  IRNGT (IWRKD:IWRKF) = JWRKT (IWRKD:IWRKF)
                  Exit
               End If
!
               IWRK = IWRK + 1
!
!  We still have unprocessed values in both A and B
!
               If (IINDA < JINDA) Then
                  If (IINDB < IWRKF) Then
                     If (XVALT(IRNGT(IINDA+1)) > XVALT(IRNGT(IINDB+1))) &
                    & Then
                        IINDB = IINDB + 1
                        JWRKT (IWRK) = IRNGT (IINDB)
                     Else
                        IINDA = IINDA + 1
                        JWRKT (IWRK) = IRNGT (IINDA)
                     End If
                  Else
!
!  Only A still with unprocessed values
!
                     IINDA = IINDA + 1
                     JWRKT (IWRK) = IRNGT (IINDA)
                  End If
               Else
!
!  Only B still with unprocessed values
!
                  IRNGT (IWRKD:IINDB) = JWRKT (IWRKD:IINDB)
                  IWRK = IWRKF
                  Exit
               End If
!
            End Do
         End Do
!
!  The Cs become As and Bs
!
         LMTNA = 2 * LMTNA
      End Do
!
!  Clean up
!
      Deallocate (JWRKT)
      Return
!
End Subroutine I_mrgref
end module m_mrgref


module internal
  use, intrinsic :: iso_fortran_env
  implicit none
contains

  ! swap `a` and `b`
  subroutine swap(a, b)
    integer(int64), intent(inout) :: a, b
    a = xor(a, b)
    b = xor(a, b)
    a = xor(a, b)
  end

  ! @param n `0 <= n`
  ! @return `i >>> n` in Java
  integer(int32) function urshift(i, n) result(res)
    integer(int32), intent(in) :: i
    integer(int32), intent(in) :: n
    integer(int32) :: m
    m = and(n, 31)
    if (m == 0) then
      res = i
    else
      res = rshift(ibclr(rshift(i, 1), 31), m - 1)
    end if
  end

  ! @param n `0 <= n`
  ! @return minimum non-negative `x` s.t. `n <= 2**x`
  integer(int32) function ceil_pow2(n) result(res)
    integer(int32), intent(in) :: n
    integer(int32) :: i
    i = n
    res = 0
    if (i == 0) return
    res = 1
    if (urshift(i, 16) == 0) then
      res = res + 16
      i = lshift(i, 16)
    end if
    if (urshift(i, 24) == 0) then
      res = res + 8
      i = lshift(i, 8)
    end if
    if (urshift(i, 28) == 0) then
      res = res + 4
      i = lshift(i, 4)
    end if
    if (urshift(i, 30) == 0) then
      res = res + 2
      i = lshift(i, 2)
    end if
    res = 32 - (res - urshift(i, 31))
  end

  ! @param n `0 <= n`
  ! @param m `1 <= m`
  ! @return `(x ** n) % m`
  pure elemental integer(int64) function pow_mod(x, n, m) result(res)
    integer(int64), intent(in) :: x, n, m
    integer(int64) :: y, k
    res = 0
    if (m == 1) return
    res = 1
    y = modulo(x, m)
    k = n
    do while (k > 0)
      if (btest(k, 0)) res = mod(res * y, m)
      y = mod(y * y, m)
      k = rshift(k, 1)
    end do
  end

  ! Reference:
  ! M. Forisek and J. Jancina,
  ! Fast Primality Testing for Integers That Fit into a Machine Word
  ! @param n `0 <= n`
  pure elemental logical function is_prime(n) result(res)
    integer(int64), intent(in) :: n
    integer(int64), parameter :: p(3) = (/2, 7, 61/)
    integer(int64) :: d, a, t, y
    integer(int32) :: i
    res = .false.
    if (n < 2) return
    res = .true.
    if (any(n == p)) return
    res = .false.
    if (.not.btest(n, 0)) return
    d = n - 1
    do while (.not.btest(d, 0))
      d = rshift(d, 1)
    end do
    do i = 1, 3
      a = p(i)
      t = d
      y = pow_mod(a, t, n)
      do while (t /= n - 1 .and. y /= 1 .and. y /= n - 1)
        y = mod(y * y, n)
        t = lshift(t, 1)
      end do
      if (y /= n - 1 .and. .not.btest(t, 0)) return
    end do
    res = .true.
  end

  ! @param b `1 <= b`
  ! @return pair(g, x) s.t. g = gcd(a, b), xa = g (mod b), 0 <= x < b / g
  function inv_gcd(a, b) result(res)
    integer(int64), intent(in) :: a, b
    integer(int64) :: res(2), s, t, u, m0, m1
    t = modulo(a, b)
    res = (/b, 0_8/)
    if (t == 0) return
    s = b
    m0 = 0
    m1 = 1
    do while (t > 0)
      u = s / t
      s = s - t * u
      m0 = m0 - m1 * u
      call swap(s, t)
      call swap(m0, m1)
    end do
    if (m0 < 0) m0 = m0 + b / s
    res = (/s, m0/)
  end

  ! Compile time primitive root
  ! @param m must be prime
  ! @return primitive root (and minimum in now)
  pure elemental integer(int64) function primitive_root(m) result(res)
    integer(int64), intent(in) :: m
    integer(int64) :: divs(20), x, i
    integer(int32) :: cnt
    res = 2
    select case (m)
    case (2)
      res = 1
    case (167772161)
      res = 3
    case (469762049)
      res = 3
    case (754974721)
      res = 11
    case (998244353)
      res = 3
    end select
    if (res /= 2) return
    divs = 0
    divs(1) = 2
    cnt = 1
    x = (m - 1) / 2
    do while (.not.btest(x, 0))
      x = rshift(x, 1)
    end do
    do i = 3, x
      if (i * i > x) exit
      if (mod(x, i) == 0) then
        cnt = cnt + 1
        divs(cnt) = i
        do while (mod(x, i) == 0)
          x = x / i
        end do
      end if
    end do
    if (x > 1) then
      cnt = cnt + 1
      divs(cnt) = x
    end if
    do
      if (all(pow_mod(res, (m - 1) / divs(1:cnt), m) /= 1)) return
      res = res + 1
    end do
  end
end module internal


      subroutine meemd(LXY,indata,An,Ns,Nesb,Nm,Nt,idum,rslt)
!-----------------------------------------------------------------------------
! This is a subroutine to decompose data(LXY) in terms of its EEMD component.
! When the added noise amplitude is zero (An=0) and the ensemble number
! is one (Nesb=0), the code degenerates to standard EMD
!
! In this code, the number of the oscillatory components is specified as an
! input, Nm. For most cases, automatic calculation, Nm can be set to log2(LXY)-2
!
! INPUT DATA:
!		indata(LXY)		input array with a length of LXY
!  		An 			amplitude of added noise
!               Ns                      fixed number of siftings
!  		Nesb 			number of ensemble members
!  		Nm 			number of mode in each decomposition
!               Nt                      Nm + 2 to deal with WRAPIT
!  		idum 			seed for the random number
! OUTPUT DATA:
!  		rslt(LXY, Nt) 	output rseults, which contains Nm+2 columns
!					The first column is the original indata;
!					The second column is the first component;
!					The third column is the second component;
!					and so on
!					The last column is the residue
!-------------------------------------------------------------------------------
      implicit none

      real :: An                                ! noise amplitude
      integer, intent(in) :: LXY, Nesb, Nm, Nt, Ns
      integer, intent(inout):: idum
      real, dimension(LXY), intent(in) :: indata
      real, dimension(LXY) :: ximf              ! data for sifting
      real, dimension(LXY) :: spmax             ! upper envelope, cubic spline
      real, dimension(LXY) :: spmin             ! lower envelope, cubic spline
      real, dimension(LXY) :: ave               ! the average of spmax and spmin
      real, dimension(LXY) :: remp              ! the input data for sifting
      real, dimension(LXY) :: rem               ! the remainder (remp-ximf)

      real, dimension(LXY,Nt) :: rslt           ! the final output data
      real, dimension(LXY,Nt) :: allmode        ! the results of a single EMD decomposition

      integer :: nmax, nmin                     ! numbers of maximum and minimum
      real, dimension(LXY) :: trend             ! linear trend of indata
      real :: std               ! standard deviation of the linearly detrended indata
      integer:: i,j,IE,im,ii
      real :: fNesb, gasdev

!  initialize the output
      rslt=0.0

!
!  ensemble EMD
!
!  *******************************************************
      do IE=1,Nesb
!  *******************************************************
!
        call standev(LXY,indata,trend, std)

!  inputted data + noise
        if(Nesb.eq.1) then
          ximf=indata
        else
          do i=1,LXY
            ximf(i)=indata(i)+An*std*gasdev(idum)
          enddo
        endif

!  save modified data
        do i=1,LXY
          allmode(i,1)=ximf(i)
        enddo

!  calculate modes
!       =======================================================
        do im=1,Nm
!       =======================================================
!
!  leave a copy of the input data before IMF is calculated
          remp=ximf
!
!  Sifting
!         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
          do ii=1,Ns
!         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

            call min_max(LXY,ximf,spmax,spmin,nmax,nmin)
            call natural_spline(spmax,LXY,nmax)
            call natural_spline(spmin,LXY,nmin)

            ave=(spmax+spmin)/2.0
            ximf=ximf-ave

!         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
          enddo                     ! siftings loop
!         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

          rem=remp-ximf

          do i=1,LXY
            allmode(i,im+1)=ximf(i)
          enddo

          ximf=rem

!       =======================================================
        enddo                        ! Modes loop
!       =======================================================

        do i=1,LXY
          allmode(i,Nt)=ximf(i)      ! store final residual as trend
        enddo

        do j=1,Nt
          do i=1,LXY
            rslt(i,j)=rslt(i,j)+allmode(i,j)   ! store and cumulate all IMFs
          enddo
        enddo

!     ---------------------------------------------------------
      enddo                         ! ensemble members loop
!     ---------------------------------------------------------

      fNesb=real(Nesb)
      rslt=rslt/fNesb               ! Take the ensemble mean

      end subroutine meemd

      function ran2(idum)
!---------------------------------------------------------------------
!  See NUMERICAL RECIPES for detail of the function under the same
!  name
!  PARAMETERS:
!       idum       : random seed
!---------------------------------------------------------------------
      implicit none

      real :: ran2
      integer, intent(inout) :: idum
      integer, parameter :: im1=2147483563, im2=2147483399, imm1=im1-1
      integer, parameter :: ia1=40014, ia2=40692, iq1=53668, iq2=52774
      integer, parameter :: ir1=12211, ir2=3791, ntab=32, ndiv=1+imm1/ntab
      real, parameter :: am=1./im1, eps=1.2e-7, rnmx=1.-eps
      integer :: idum2=123456789, iy=0, j, k
      integer, dimension(ntab) :: iv

      save iv,iy,idum2

      do j=1,ntab
        iv(j)=0
      enddo

      if(idum.le.0) then
        idum=max(-idum,1)
        idum2=idum
        do j=ntab+8,1,-1
          k=idum/iq1
          idum=ia1*(idum-k*iq1)-k*ir1
          if(idum.lt.0) idum=idum+im1
          if(j.le.ntab) iv(j)=idum
        enddo
        iy=iv(1)
      endif
      k=idum/iq1
      idum=ia1*(idum-k*iq1)-k*ir1
      if(idum.lt.0) idum=idum+im1
      k=idum2/iq2
      idum2=ia2*(idum2-k*iq2)-k*ir2
      if(idum2.lt.0) idum2=idum2+im2
      j=1+iy/ndiv
      iy=iv(j)-idum2
      iv(j)=idum
      if(iy.lt.1) iy=iy+imm1
      ran2=min(am*iy,rnmx)

      end function ran2

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

      FUNCTION GASDEV(IDUM)
!----------------------------------------------------------------------
!  Gaussian white noise generator using uniformly distributed white
!  noise generator
!----------------------------------------------------------------------

      implicit none
      real:: gasdev, ran2
      integer, intent(inout):: idum
      real :: v1, v2, gv1, gv2
      real, parameter :: pi=3.1415927

      V1=RAN2(IDUM)
      V2=RAN2(IDUM)

      gv1=sqrt(-2.0*log(v1))*cos(2.0*pi*v2)
      gv2=sqrt(-2.0*log(v2))*cos(2.0*pi*v1)

      gasdev=gv1

      END FUNCTION GASDEV

      subroutine min_max(LEX,ximf,spmax,spmin,nmax,nmin)
!------------------------------------------------------------------
!  This is a routine to define maxima and minima from series ximf.
!  All the extrema are defined as the corresponding values of
!  ximf in spmax and spmin. All non-extrema values in spmax and
!  spmin are defined as 1.0e31.
!------------------------------------------------------------------
      implicit none

      integer, intent(in):: LEX
      real, dimension(LEX), intent(in):: ximf
      real, dimension(LEX), intent(out):: spmax, spmin
      integer, intent(out):: nmax, nmin
      integer:: i

      nmax=0
      nmin=0

      spmax(1)=ximf(1)
      spmax(LEX)=ximf(LEX)
      spmin(1)=spmax(1)
      spmin(LEX)=spmax(LEX)

      nmax=2
      nmin=2

      do i=2,LEX-1
        if(ximf(i) > ximf(i-1) .and. ximf(i) >= ximf(i+1)) then
          spmax(i) = ximf(i)
          nmax = nmax+1
        else
          spmax(i)=1.0e31
        endif
        if(ximf(i) < ximf(i-1) .and. ximf(i) <= ximf(i+1)) then
          spmin(i)=ximf(i)
          nmin=nmin+1
        else
          spmin(i)=1.0e31
        endif
      enddo

      call endmax(LEX, spmax, nmax)
      call endmin(LEX, spmin, nmin)

      end subroutine min_max

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

      subroutine endmax(LEX, temp, nmax)
!--------------------------------------------------------------------
! This is a subroutine to determine end values of the upper envolope
! using the method described in Appendix B of Wu and Huang (2009,
! AADA, Vol. 1, pp1).
!--------------------------------------------------------------------
      implicit none

      integer, intent(in) :: nmax, LEX
      real, dimension(LEX), intent(inout):: temp
      real, dimension(nmax) :: exmax, X
      integer :: I, J, lend
      real :: slope1, slope2, tmp1, tmp2

      lend=nmax

      J=1
      DO I=1, LEX
        IF( temp(I).LT.1.0E30 ) THEN
          X(J)=float(I)
          exmax(J)=temp(I)
          J=J+1
        ENDIF
      ENDDO

      if (nmax >= 4) then
        slope1=(exmax(2)-exmax(3))/(X(2)-X(3))
        tmp1=slope1*(X(1)-X(2))+exmax(2)
        if(tmp1 > exmax(1)) then
          temp(1)=tmp1
        endif

        slope2=(exmax(lend-1)-exmax(lend-2))/(X(lend-1)-X(lend-2))
        tmp2=slope2*(X(lend)-X(lend-1))+exmax(lend-1)
        if(tmp2 > exmax(lend)) then
          temp(LEX)=tmp2
        endif
      endif

      end subroutine endmax

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

      subroutine endmin(LEX, temp, nmax)
!--------------------------------------------------------------------
! This is a subroutine to determine end values of the lower envolope
! using the method described in Appendix B of Wu and Huang (2009,
! AADA, Vol. 1, pp1).
!--------------------------------------------------------------------
      implicit none

      integer, intent(in) :: nmax, LEX
      real, dimension(LEX), intent(inout):: temp
      real, dimension(nmax) :: exmax, X
      integer :: I, J, lend
      real :: slope1, slope2, tmp1, tmp2

      lend=nmax

      J=1
      DO I=1, LEX
        IF( temp(I).LT.1.0E30 ) THEN
          X(J)=float(I)
          exmax(J)=temp(I)
          J=J+1
        ENDIF
      ENDDO

      if (nmax >= 4) then
        slope1=(exmax(2)-exmax(3))/(X(2)-X(3))
        tmp1=slope1*(X(1)-X(2))+exmax(2)
        if(tmp1 < exmax(1)) then
          temp(1)=tmp1
        endif

        slope2=(exmax(lend-1)-exmax(lend-2))/(X(lend-1)-X(lend-2))
        tmp2=slope2*(X(lend)-X(lend-1))+exmax(lend-1)
        if(tmp2 < exmax(lend)) then
          temp(LEX)=tmp2
        endif
      endif

      end subroutine endmin

      SUBROUTINE NATURAL_SPLINE(YA,LEX,N)
!----------------------------------------------------------------------
!  This is a program of cubic spline interpolation. The imported
!  series, YA have a length of LEX, with N numbers of value
!  not equal to 1.0E31. The program is to use the cubic line to
!  interpolate the values for the points other thatn these N
!  numbers.
!-----------------------------------------------------------------------

      implicit none

      integer, intent(in):: N, LEX
      real, dimension(LEX), intent(inout):: YA
      real, dimension(N):: Y, Y2
      integer, dimension(N):: LX
      integer:: J, I, KLO, KHI
      real:: YP1, YPN, H, A, B

!  The following code is to realocate the series of X(N), Y(N)

      J=1
      DO I=1, LEX
        IF( YA(I).LT.1.0E30 ) THEN
          LX(J)=I
          Y(J)=YA(I)
          J=J+1
        ENDIF
      ENDDO

!  The following code is used to calculate the second order derivative,
!  set the derivatives at both ends for a natural cubic spline.
      YP1=1.0E31
      YPN=1.0E31

      CALL SPLINE(LX,Y,N,YP1,YPN,Y2)

!  calculate the cubic spline
      DO I=2,N
        KLO=LX(I-1)
        KHI=LX(I)
        H=real(KHI-KLO)
        DO J=KLO+1,KHI-1
          A=REAL(KHI-J)/H
          B=REAL(J-KLO)/H
          YA(J)=A*Y(I-1)+B*Y(I)   &
                +((A*A*A-A)*Y2(I-1)+(B*B*B-B)*Y2(I))*(H*H)/6.0
        ENDDO
      ENDDO

      END SUBROUTINE NATURAL_SPLINE

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

      SUBROUTINE SPLINE(LX,Y,N,YP1,YPN,Y2)
!-----------------------------------------------------------------
!  see NUMEIRCAL RECIPES to find out meaning of each variables
!-----------------------------------------------------------------
      implicit none

      integer, intent(in) :: N, YP1, YPN
      integer, dimension(N), intent(in):: LX
      real, dimension(N) :: X, U
      real, dimension(N), intent(inout):: Y, Y2
      integer:: I, K
      real:: SIG, P, QN, UN

      DO I=1,N
        X(I)=real(LX(I))
      ENDDO

      Y2(1)=0.
      U(1)=0.

      DO I=2,N-1
        SIG=(X(I)-X(I-1))/(X(I+1)-X(I-1))
        P=SIG*Y2(I-1)+2.
        Y2(I)=(SIG-1.)/P
        U(I)=(6.*((Y(I+1)-Y(I))/(X(I+1)-X(I))-(Y(I)-Y(I-1)) &
             /(X(I)-X(I-1)))/(X(I+1)-X(I-1))-SIG*U(I-1))/P
      ENDDO

      QN=0.
      UN=0.

      Y2(N)=(UN-QN*U(N-1))/(QN*Y2(N-1)+1.)

      DO K=N-1,1,-1
        Y2(K)=Y2(K)*Y2(K+1)+U(K)
      ENDDO

      END SUBROUTINE SPLINE

      subroutine standev(nsize, indata, trend, std)
!-------------------------------------------------------------------
!  This is a program to obtain standard deviation of the linearly
!  detrended data
!
!  PARAMETERS:
!  nsize    :    indata size
!  indata   :    input data
!  trend    :    the linear trend of "indata"
!  std      :    standard deviation
!--------------------------------------------------------------------

      implicit none

      integer, intent(in) :: nsize
      real, dimension(nsize) :: indata
      real, dimension(nsize), intent(out):: trend
      real, intent(out) :: std
      real sigmaX, sigmaY, sigmaX2, sigmaXY, real_nsize, Xbar, Ybar, real_i
      integer :: i
      real :: trend_const, trend_slope, temp

      sigmaX = 0.0
      sigmaY = 0.0
      do i = 1, nsize
        sigmaX = sigmaX + real(i)
        sigmaY = sigmaY + indata(i)
      enddo

      real_nsize=real(nsize)

      Xbar=sigmaX/real_nsize
      Ybar=sigmaY/real_nsize

      sigmaX2 = 0.0
      sigmaXY = 0.0
      do i = 1, nsize
        real_i=real(i)
        sigmaX2 = sigmaX2+(real_i-xbar)*(real_i-xbar)
        sigmaXY = sigmaXY+(real_i-xbar)*(indata(i)-ybar)
      enddo

      trend_slope=sigmaXY/sigmaX2
      trend_const=Ybar-trend_slope*Xbar

      do i=1, nsize
        trend(i)= trend_const + trend_slope*real(i)
      enddo

      std=0.0

      do i=1,nsize
        temp= indata(i)-trend(i)
        std=std+temp*temp
      enddo
      std=std/real(nsize)
      std=sqrt(std)

      end subroutine standev