!================================================================================
! Refinter - module for topography based locally refined SCVT grids
! Generates smooth density functions for Lloyd's method
!================================================================================
module refinter
    !parameters
    use constants, only: &
        pi, &
        datadir, &
        pio2, &
        pi2, &
        r8, &
        rad2deg, &
        deg2rad, &
        n_lat, &
        n_lon, &
        latmin, &
        latmax, &
        lonmin, &
        lonmax, &
        altdir, &
        nlat_alt, &
        nlon_alt
    implicit none

contains
    !--------------------------------------------------------------------------
    ! Compute the density function defined in 'Voronoi Tessellations and their application to
    !  climate and global modeling' by Lili Ju, Todd Ringler and Max Gunzburger
    !--------------------------------------------------------------------------
    real (r8) function densf(x) result(dens_f)
        real (r8), dimension(1:2), intent(in) :: x
        real (r8), dimension(1:3) :: p
        real (r8), dimension(1:3) :: pc
        real (r8) :: coslat
        real (r8) :: lat
        real (r8) :: lon
        real (r8) :: latc
        real (r8) :: lonc
        real (r8) :: gammas
        real (r8) :: epsilons
        real (r8) :: dists
        real (r8) :: maxdist
        real (r8) :: sx

        !Center of refined region

        latc=-20.0*pi/180._r8
        lonc=-60.0*pi/180._r8
        coslat = dcos (latc)
        pc(1) = coslat * dcos (lonc)
        pc(2) = coslat * dsin (lonc)
        pc(3) = dsin (latc)

        lat = x(1)
        lon = x(2)
        coslat = dcos (lat)
        p(1) = coslat * dcos (lon)
        p(2) = coslat * dsin (lon)
        p(3) = dsin (lat)

        !Distance to center
        dists = dsqrt((p(1)-pc(1))**2+(p(2)-pc(2))**2+(p(3)-pc(3))**2)
        !dists = dsqrt((lat-latc)**2+(lon-lonc)**2)
        !Density function parameters
        gammas = 3._r8
        epsilons = pi/12._r8
        maxdist = pi/6._r8
        !Distance to center metric
        sx=(dists-maxdist)/epsilons
        !Set density

        if(dists<=maxdist)then
            !Point close to the center
            dens_f=gammas**4
        elseif((dists<=maxdist+epsilons) .and. (dists>maxdist))then
            !Point in the transition
            dens_f=((1._r8-sx)*gammas+sx)**4
        else
            !Point far from the center
            dens_f=1
        end if
        !Normalization - Make it in [0,1]
        dens_f = dens_f/gammas**4
    end function densf

    !--------------------------------------------------------------------------
    ! Bilinear interpolation
    !--------------------------------------------------------------------------
    real (r8) function interpol_densf(p, densftable, xmin, xmax, ymin, ymax, nx, ny) result(ff)
        integer, intent(in) :: nx, ny
        real (r8), intent(in) :: xmin, xmax, ymin, ymax
        real (r8), dimension(1:2), intent(in) :: p
        real (r8), dimension(nx*ny,3), intent(in) :: densftable
        integer :: i, j
        integer :: i1, i2, j1, j2
        real (r8) :: f11, f12, f21, f22
        real (r8) :: x1, x2, y1, y2, x0, y0
        real (r8) :: dx, dy

        dx = (xmax-xmin)/(nx-1)
        dy = (ymax-ymin)/(ny-1)

        x0 = p(1)
        y0 = p(2)
        i1 = INT((x0 - xmin)/dx+1)
        i2 = CEILING((x0 - xmin)/dx+1)
        j1 = INT((y0 - ymin)/dy+1)
        j2 = CEILING((y0 - ymin)/dy+1)

        x1 = densftable((i1-1)*ny + 1, 1)
        y1 = densftable(j1,2)
        x2 = densftable((i2-1)*ny + 1,1)
        y2 = densftable(j2,2)

        f21 = densftable((i2-1)*ny + j1, 3)
        f12 = densftable((i1-1)*ny + j2, 3)
        f11 = densftable((i1-1)*ny + j1, 3)
        f22 = densftable((i2-1)*ny + j2, 3)

        if(x1 /= x2 .and. y1 /= y2) then
            ff = f11*(x2-x0)*(y2-y0)
            ff = ff + f21*(x0-x1)*(y2-y0)
            ff = ff + f12*(x2-x0)*(y0-y1)
            ff = ff + f22*(x0-x1)*(y0-y1)
            ff = ff/((x2-x1)*(y2-y1))
        else if (x1 == x2 .and. y1 /= y2 ) then
            ff = f11 + (f12-f11)*(y0-y1)/(y2-y1)        !linear interpolation
        else if (x1 /= x2 .and. y1 == y2 ) then
            ff = f11 + (f21-f11)*(x0-x1)/(x2-x1)    !linear interpolation
        else
            ff = f11
        end if

    end function interpol_densf

    !--------------------------------------------------------------------------
    ! Load earth elevation data from ETOPO
    ! Etopo data must be in the directory /altitude/
    !--------------------------------------------------------------------------
    subroutine earth_elevation(iunit, altitude_table)
        integer :: iunit
        real (r8), dimension(nlat_alt*nlon_alt,3), intent(inout) :: altitude_table
        integer :: i, j
        character (len=100) :: filename
        character (len=100) :: buffer

        filename = trim(altdir)//"elevation_table_720x1440.dat"

        print*,'Loading ETOPO data...'
        open(iunit, file=filename)
          read(iunit,*) buffer
          read(iunit,*) buffer
          read(iunit,*) buffer
          read(iunit,*) ((altitude_table  (i,j), j=1,3), i=1,nlat_alt*nlon_alt)
        close(iunit)

    end subroutine earth_elevation

    !--------------------------------------------------------------------------
    ! Defines smooth Andes density function in lat-lon grid and saves in
    ! altitude_table
    !--------------------------------------------------------------------------
    subroutine andes_density_table(altitude_table, iunit)
      real (r8), dimension(nlat_alt*nlon_alt,3), intent(inout) :: altitude_table
      integer, intent(in) :: iunit
      integer :: i, j, k, n, m, l
      integer :: old, new, aux
      real (r8) :: lat, lon, latc, lonc
      real (r8) :: dists, maxdist, gammas, epsilons
      real (r8), dimension(1:3) :: p
      real (r8), dimension(1:3) :: pc
      real (r8) :: coslat, a, b, c, sx, cutoff, alpha
      real (r8), dimension(:,:,:), allocatable  :: auxiliary_function
      real (r8), dimension(:,:,:), allocatable  :: topo
      real (r8) :: temp, dlat, dlon, lambda
      character (len=100) :: filename

      ! Load ETOPO data
      call earth_elevation(iunit, altitude_table)

      ! Allocation
      allocate (topo(nlat_alt, nlon_alt,0:1))
      allocate (auxiliary_function(nlat_alt, nlon_alt,0:1))

      ! Parameters
      ! Center of circular refinement region in lat-lon
      latc=-20._r8*deg2rad
      lonc=-70._r8*deg2rad

      ! Center of circular refinement region in R^3 coordinates
      coslat = dcos(latc)
      pc(1) = coslat*dcos(lonc)
      pc(2) = coslat*dsin(lonc)
      pc(3) = dsin(latc)

      !radius of circular refinement region
      !maxdist = 45._r8*deg2rad
      maxdist = 28._r8*deg2rad

      !width of transition zone
      epsilons = 15._r8*deg2rad

      gammas = 2._r8

      !Cut-off altitude
      cutoff = 500._r8

      !ETOPO lat-lon grid space
      dlat = pi/(nlat_alt-1)
      dlon = pi2/(nlon_alt-1)

      ! Saves the topography data
      k = 1
      do i = 1, nlat_alt
        do j = 1, nlon_alt
          topo(i,j,0) = altitude_table(k,3)
          k = k + 1
        end do
      end do

      print*,'Generating smooth density function based on Andes topography...'

      ! Defines an auxiliary function the defines a circular refinement centered in pc
      auxiliary_function = 0._r8
      do i = 1, nlat_alt
        lat = -pio2 + (i-1)*dlat
        do j = 1, nlon_alt
          lon = -pi + (j-1)*dlon
          !Point in R^3 coordinates
          coslat = dcos(lat)
          p(1) = coslat*dcos(lon)
          p(2) = coslat*dsin(lon)
          p(3) = dsin(lat)

          !Evaluates the R^3 distance
          dists = dsqrt((p(1)-pc(1))**2+(p(2)-pc(2))**2+(p(3)-pc(3))**2)

          !Point in circular region
          if(dists<=maxdist)then
            auxiliary_function(i,j,0) = 1._r8
           !Point in transition zone
           else if(dists<=maxdist+epsilons)then
             sx = (maxdist+epsilons-dists)/epsilons
             auxiliary_function(i,j,0) = sx
          endif
        enddo
      enddo

      ! Applies moving average smoothing method in the auxiliary_function data
      ! Uses a box centered in (i,j) with l^2 elements
      l = 55
      do i = l, nlat_alt-l
        do j = l, nlon_alt-l
          temp =  0._r8
          do m = 0, l-1
            do n = 0, l-1
              temp = temp + auxiliary_function(i-(l-1)/2+m, j-(l-1)/2+n,0)
            end do
          end do
          auxiliary_function(i,j,1) = temp/l**2
        end do
      end do

      !Normalizes the auxiliary data in [0,1]
      auxiliary_function(:,:,1) = auxiliary_function(:,:,1)/maxval(auxiliary_function(:,:,1))

      !Defines the non smooth Andes data
      do i = 1, nlat_alt
        lat = -pio2 + (i-1)*dlat
        do j = 1, nlon_alt
          lon = -pi + (j-1)*dlon

          !Set topography equal to zero if it is less than 500m or if the point (lat,lon)
          !is not close enough to be considered lying in the Andes
          if(topo(i,j,0)<=cutoff .or. lon*rad2deg>-62._r8 .or.lon*rad2deg<-82._r8 &
             .or.lat*rad2deg>15._r8 .or.lat*rad2deg<-55._r8)then
            topo(i,j,0) = 0._r8

          ! Removes Mount Roraima
          else if(lat*rad2deg > -5._r8 .and. lat*rad2deg < 10._r8 .and. lon*rad2deg > -68._r8 .and. lon*rad2deg < -50._r8 )then
            topo(i,j,0) = 0._r8
          end if

          ! In this case, we consider the point (lat,lon) lying in the Andes
          ! and the topography is defined equal to 1
          if(topo(i,j,0)>0._r8)then
            topo(i,j,0) = 1._r8
          endif
        enddo
      enddo

      ! Applies 500 iterations of Jacobi smoothing method in Andes topography data
      old = 0
      new = 1
      do k = 1, 500
        do i = 2, nlat_alt-1
          do j = 2, nlon_alt-1
            topo(i,j,new) = 0.25_r8*(topo(i+1,j,old)+topo(i-1,j,old)+topo(i,j+1,old)+topo(i,j-1,old))
          enddo
        enddo
        !Update
        aux = new
        new = old
        old = aux
      enddo

      !Normalizes the topography data in [0,1]
      topo(:,:,old) = topo(:,:,old)/maxval(topo(:,:,old))

      !Defines the density function in topo(:,:,old)
      lambda = 0.8_r8
      topo(:,:,old) = 1._r8/gammas**4 + (1._r8-1._r8/gammas**4)*(lambda*topo(:,:,old)+(1._r8-lambda)*auxiliary_function(:,:,1))

      filename = "topo.dat"
      open(4, file=filename)
        do i=1, nlat_alt
            write(4,*) topo(i,:,old)
        end do
      close(4)

      print*,(maxval(topo(:,:,old))/minval(topo(:,:,old)))**(0.25_r8),gammas
      !stop

      ! Update values in the table
      k = 1
      do i = 1, nlat_alt
        do j = 1, nlon_alt
            altitude_table(k,3) = topo(i,j,old)
            k = k + 1
        end do
      end do

      deallocate(topo,auxiliary_function)
    end subroutine andes_density_table

    !--------------------------------------------------------------------------
    ! Andes density function
    !--------------------------------------------------------------------------
    real (r8) function dens_andes(x, dens_table) result(densf)
        real (r8), dimension(1:2), intent(in) :: x
        real (r8), dimension(nlat_alt*nlon_alt,3), intent(in) :: dens_table
        real (r8) :: lat, lon

        lat = x(1)
        lon = x(2)
        lat = lat*rad2deg
        lon = lon*rad2deg
        densf = interpol_densf([lat,lon], dens_table, -90._r8, 90._r8, -180._r8, 180._r8, nlat_alt, nlon_alt)
    end function dens_andes

    !--------------------------------------------------------------------------
    ! Andes mountain topography - for shallow water tests
    ! - altitude_table stores the smooth Andes topography
    ! - Given x in lat/lon coordinates, this routine applies bilinear interpolation
    ! using altitude_table to estimate the topography value at x.
    !--------------------------------------------------------------------------
    real (r8) function smooth_andes_mountain(x, altitude_table) result(densf)
        real (r8), dimension(1:2), intent(in) :: x
        real (r8), dimension(nlat_alt*nlon_alt,3), intent(in) :: altitude_table
        real (r8) :: lat, lon

        lat = x(1)
        lon = x(2)
        lat = lat*rad2deg
        lon = lon*rad2deg

        densf = interpol_densf([lat,lon], altitude_table, -90._r8, 90._r8, -180._r8, 180._r8, nlat_alt, nlon_alt)
    end function smooth_andes_mountain

    !--------------------------------------------------------------------------
    ! Loads ETOPO data and generates a smooth Andes topography normalized
    ! in [0,1] in altitude_table applying Jacobi-like smoothing method.
    ! ETOPO data must be in the directory /altitude/
    !--------------------------------------------------------------------------
    subroutine generate_smooth_andes_mountain(altitude_table, iunit)
      real (r8), dimension(nlat_alt*nlon_alt,3), intent(inout) :: altitude_table
      integer, intent(in) :: iunit
      integer :: i, j, k
      integer :: old, new, aux
      real (r8) :: lat, lon
      real (r8) :: cutoff
      real (r8), dimension(:,:,:), allocatable  :: topo, topo2
      real (r8) :: dlat, dlon

      !Load ETOPO data
      call earth_elevation(iunit, altitude_table)

      !Allocate topography matrices
      allocate (topo(nlat_alt, nlon_alt,0:1))

      !Cut-off altitude
      cutoff = 500._r8

      !ETOPO lat-lon grid space
      dlat = pi/(nlat_alt-1)
      dlon = pi2/(nlon_alt-1)

      ! Saves the topography data
      k = 1
      do i = 1, nlat_alt
        do j = 1, nlon_alt
          topo(i,j,0) = altitude_table(k,3)
          k = k + 1
        end do
      end do

      print*,'Generating smooth Andes topography...'

      ! Define the non smooth Andes data
      do i = 1, nlat_alt
        lat = -pio2 + (i-1)*dlat
        do j = 1, nlon_alt
          lon = -pi + (j-1)*dlon

          !Set topography equal to zero if it is less than 500m or if the point (lat,lon)
          !is not close enough to be considered lying in the Andes
          if(topo(i,j,0)<=cutoff .or. lon*rad2deg>-62._r8 .or.lon*rad2deg<-82._r8 &
             .or.lat*rad2deg>15._r8 .or.lat*rad2deg<-55._r8)then
            topo(i,j,0) = 0._r8

          ! Remove Mount Roraima
          else if(lat*rad2deg > -5._r8 .and. lat*rad2deg < 10._r8 .and. lon*rad2deg > -68._r8 .and. lon*rad2deg < -50._r8 )then
            topo(i,j,0) = 0._r8
          end if

          ! In this case, we considered the point lying (lat,lon) in the Andes
          ! and the topography defined equal to 1
          if(topo(i,j,0)>0._r8)then
            topo(i,j,0) = 1._r8
          endif
        enddo
      enddo

      ! Apply 500 iterations of Jacobi smoothing method
      old = 0
      new = 1
      do k = 1, 500
        do i = 2, nlat_alt-1
          do j = 2, nlon_alt-1
            topo(i,j,new) = 0.25_r8*(topo(i+1,j,old)+topo(i-1,j,old)+topo(i,j+1,old)+topo(i,j-1,old))
          enddo
        enddo
        !Update
        aux = new
        new = old
        old = aux
      enddo

      !Normalize the topography data in [0,1]
      topo(:,:,old) = topo(:,:,old)/maxval(topo(:,:,old))

      ! Update values in the table
      k = 1
      do i = 1, nlat_alt
        do j = 1, nlon_alt
          altitude_table(k,3) = topo(i,j,old)
          k = k + 1
        end do
      end do

      deallocate(topo)
    end subroutine generate_smooth_andes_mountain

    !--------------------------------------------------------------------------
    ! Creates the table for interpolation
    !--------------------------------------------------------------------------
    subroutine densftable(filename, iunit)
        character (len=100), intent(in) :: filename
        integer, intent(in) :: iunit
        integer :: nx, ny
        integer :: i, j
        real (r8) :: xmin, xmax, ymin, ymax
        real (r8) :: dx, dy
        real (r8), dimension(1:n_lat)  :: x
        real (r8), dimension(1:n_lon)  :: y
        real (r8), allocatable  :: table(:,:)

        allocate(table(n_lat*n_lon, 3))
        xmin = latmin
        xmax = latmax
        ymin = lonmin
        ymax = lonmax
        nx = n_lat
        ny = n_lon

        !Creates the grid
        dx = (xmax-xmin)/(nx-1)
        dy = (ymax-ymin)/(ny-1)

        do i = 1, nx
            x(i) = xmin + (i-1)*dx
        end do

        do j = 1, ny
            y(j) = ymin + (j-1)*dy
        end do

        !!!
        do i = 1, nx
            do j = 1, ny
                table((i-1)*ny + j, 1) = x(i)
                table((i-1)*ny + j, 2) = y(j)
            end do
        end do

        do i = 1, nx*ny
            table(i,3) = densf([table(i,1), table(i,2)]) !exact value
        end do

        !Output data to a file
        open(iunit, file=filename)
        do i=1, nx*ny
           write(iunit,*) table(i,1), table(i,2), table(i,3)
        end do
        close(iunit)
        deallocate(table)
    end subroutine densftable

end module refinter


      subroutine qnbd(indqn,simul,n,x,f,g,imp,io,zero,
     & napmax,itmax,epsf,epsg,epsx,df0,binf,bsup,nfac,
     & trav,ntrav,itrav,nitrav,izs,rzs,dzs)
c!but
c     code de minimisation d une fonction reguliere sous contraintes
c     de bornes , aux normes modulopt
c!origine
c     f. bonnans , inria , 1986
c!methode
c     principe de l algorithme : quasi-newton + projection
c     details dans le rapport inria n. 242,1983
c     cette version permet de tester plusieurs variantes de l algorithme
c     en modifiant certains parametres internes (cf comment dans le code)
c     taille memoire necessaire de l ordre de n**2/2
c     pour les problemes de grande taille le code gcbd est mieux adapte
c
c!sous programmes appeles
c     zqnbd   optimiseur effectif
c     proj    projection
c     calmaj  mise a jour du hessien
c     ajour mise a jour des facteurs de choleski
c     rlbd,satur   recherche lineaire avec bornes
c
c!liste d'appel
c
c     subroutine qnbd(indqn,simul,n,x,f,g,imp,io,zero,
c    & napmax,itmax,epsf,epsg,epsx,df0,binf,bsup,nfac,
c    & trav,ntrav,itrav,nitrav,izs,rzs,dzs)
c
c     indqn   indicateur de qnbd                                  es
c       en entree =1 standard
c                 =2 dh et indic initialises au debut de trav et itrav
c                    ifac,f,g initialises
c       en sortie
c        si < 0 incapacite de calculer un point meilleur que le point initial
c        si = 0 arret demande par l utilisateur
c        si > 0 on fournit un point meilleur que le point de depart
c        < -10 parametres d entree non convenables
c        = -6  arret lors du calcul de la direction de descente et iter=1
c        = -5  arret lors du calcul de l approximation du hessien  iter=1
c        = -3  anomalie de simul : indic negatif en un point ou
c              f et g ont ete precedemment calcules
c        = -2  echec de la recherche lineaire a la premiere iteration
c        = -1  f non definie au point initial
c        =  1  arret sur epsg
c        =  2            epsf
c        =  3            epsx
c        =  4            napmax
c        =  5            itmax
c        =  6  pente dans la direction opposee au gradient trop petite
c        =  7  arret lors du calcul de la direction de descente
c        =  8  arret lors du calcul de l approximation du hessien
c        = 10  arret par echec de la recherche lineaire , cause non precisee
c        = 11  idem avec indsim < 0
c        = 12            un pas trop petit proche d un pas trop grand
c                        ceci peut resulter d une erreur dans le gradient
c        = 13            trop grand nombre d appels dans une recherche lineaire
c     simul voir les normes modulopt
c     n dim de x                                                 e
c     binf,bsup bornes inf,sup,de dim n                          e
c     x variables a optimiser (controle)                          es
c     f valeur du critere                                         s
c     g gradient de f                                             s
c     zero  proche zero machine                                             e
c     napmax nombre maximum d appels de simul                               e
c     itmax nombre maximum d iterations de descente               e
c     itrav vect travail dim nitrav=2n , se decompose en indic et izig
c     nfac nombre de variables factorisees                  (e si indqn=2)  s
c     imp facteur d impression                                              e
c         varie de 0 (pas d impressions) a 3 (nombreuses impressions)
c     io numero du fichier de resultats                                     e
c     epsx vect dim n precision sur x                                       e
c     epsf critere arret sur f                                              e
c     epsg arret si sup a norm2(g+)/n                                       e
c     trav vect travail dim ntrav
c     il faut ntrav > n(n+1)/2 +6n
c     df0>0 decroissance f prevue     (prendre 1. par defaut)               e
c     izs,rzs,dzs : cf normes modulopt                                     es
c!
c     indications sur les variables internes a qnbd et zqnbd
c     izig  sert a la memorisation des contraintes (actif si izag>1)
c     si i ne change pas d ens on enleve 1 a izig  (positif)
c     sinon on ajoute izag
c     factorisation seulement si izig est nul
c     dh estimation hessien dim n(n+1)/2 rangee en troismorceaux es
c     indic(i) nouvel indice de l indice i
c     indic vect dim n ordre de rangement des indices                       es
c     pas necessaire de l initialiser si indqn=1
c
c     parametres de la recherche lineaire
c     amd,amf param. du test de wolfe .    (.7,.1)
c     napm nombre max d appels dans la rl  (=15)
c
      implicit double precision (a-h,o-z)
      real rzs(*)
      double precision dzs(*)
      dimension binf(n),bsup(n),x(n),g(n),epsx(n)
      dimension trav(ntrav),itrav(nitrav),izs(*)
      external simul
c
      if(imp.ge.1)write(io,1010)
1010  format(' *********** qnbd ****************')
c
c
c     parametres caracteristiques de l algorithme
c     si les parametres sont nuls l algorithme est celui du rr 242
c     ig=1 test sur grad(i) pour relach var
c     in=1 limite le nombre de factorisations par iter a n/10
c     irel=1 test sur decroissance grad pour rel a iter courante
c     epsrel taux de decroissance permettant le relachement (cf irit)
c     iact blocage variables dans ib (gestion contraintes actives)
c     ieps1 =1 eps1 egal a zero
c     note eps1 correspond a eps(xk)
      ig=0
      in=0
      irel=1
      epsrel=.50d+0
      izag=0
      iact=1
      ieps1=0
c
c     decoupage du vecteur trav
      n1=(n*(n+1))/2 +1
      n2=n1+n
      n3=n2+n
      n4=n3+n
      n5=n4+n-1
      if(ntrav.lt.n5) then
         if(imp.gt.0)write(io,110)ntrav,n5
110      format(' qnbd : ntrav=',i8,' devrait valoir ',i8)
         indqn=-11
         return
      endif
      ni1=n+1
      if(nitrav.lt.2*n) then
         ni2=2*n
         if(imp.gt.0)write(io,111)nitrav,ni2
111      format(' qnbd : nitrav=',i8,'devrait valoir',i8)
         indqn=-12
         return
      endif
      call zqnbd(indqn,simul,trav(1),n,binf,bsup,x,f,g,zero,napmax,
     &itmax,itrav,itrav(ni1),nfac,imp,io,epsx,epsf,epsg,trav(n1),
     &trav(n2),trav(n3),trav(n4),df0,ig,in,irel,izag,iact,
     &epsrel,ieps1,izs,rzs,dzs)
      return
      end


      subroutine sedist(dslost)
c****************************************************************
c                                                               *
c  This subroutine is called from SR SEDSEG and creats a re-    *
c  presentative hillslope profile(sediment load, x-distance,    *
c  delta x) from overland flow elements.                        *
c                                                               *
c****************************************************************
c****************************************************************
c                                                               *
c  Argument                                                     *
c    dslost                                                     *
c                                                               *
c****************************************************************
c
      include 'pmxhil.inc'
      include 'pmxpln.inc'
      include 'pmxpts.inc'
      include 'pmxslp.inc'
      include 'pmxseg.inc'
c
c****************************************************************
c                                                               *
c   Common Blocks                                               *
c                                                               *
c****************************************************************
c
      include 'cdist.inc'
c
      include 'csedld.inc'
c
c*********************************************************************
c                                                                    *
c sedld variables updated                                            *
c   ysdist    :                                                      *
c                                                                    *
c*********************************************************************
c
      include 'cslope.inc'
      include 'cstruc.inc'
c
c
c
c****************************************************************
c                                                               *
c   sedld variables updated                                     *
c       dstot(mxpts),stdist(mxpts),delxx(mxplan)                 *
c                                                               *
c****************************************************************
c
c****************************************************************
c                                                               *
c   local variables                                             *
c     kk   :                                                    *
c     ytot :                                                    *
c     i    :                                                    *
c     k    :                                                    *
c     ydist :                                                   *
c     xdist :                                                   *
c     dist  :                                                   *
c                                                               *
c****************************************************************
c
      real xdist(mxplan,101), dslost(mxplan,100), ydist(mxplan,101),
     1     dist, ytot
      integer i, j, k, kk, ll
c
c****************************************************************
c
      kk = 0
      ytot = 0.
c
c     Correction added 4/3/90 by dcf
c
      if (nplane.gt.1) then
        do 10 i = 2, nplane
          ytot = ytot + slplen(i) * avgslp(i)
   10   continue
      end if
c
c
      do 40 i = 1, nplane
c
c
c       Change to delxx made by dcf 7/6/90 to reduce array size
c       from 1000 to 10.
c
c
        delxx(i) = slplen(i) / 100.0
c
c
        do 30 k = 2, 101
          ll = k - 1
          dist = 0.0
          do 20 j = 1, i
            if (i.ne.j) then
              dist = slplen(i-j) + dist
            end if
   20     continue
          ydist(i,k) = ytot + slplen(i) * avgslp(i) * y(k,i)
          xdist(i,k) = dist + (slplen(i)/100.0) * float(k-1)
          kk = kk + 1
          dstot(kk) = dslost(i,ll)
          stdist(kk) = xdist(i,k)
          ysdist(kk) = ydist(i,k)
c       delxx(kk)=slplen(i)/100.0
   30   continue
        if (i.ne.nplane) ytot = ytot - slplen(i+1) * avgslp(i+1)
   40 continue
c
      return
      end


          SUBROUTINE get_grid_dims(nproc,nprow,npcol)
! ...     This subroutine factorizes the number of processors (NPROC)
! ...     into NPROW and NPCOL,  that are the sizes of the 2D processors mesh.
            integer nproc,nprow,npcol
            integer sqrtnp,i
            sqrtnp = INT( SQRT( DBLE(nproc) ) + 1 )
            DO i=1,sqrtnp
              IF(MOD(nproc,i).EQ.0) nprow = i
            END DO
            npcol = nproc/nprow
            RETURN
          END SUBROUTINE


      SUBROUTINE CGETRF( M, N, A, LDA, IPIV, INFO )
      IMPLICIT NONE
*
*  -- LAPACK routine (version 3.X) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     May 2008
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
*     ..
*     .. Array Arguments ..
      INTEGER            IPIV( * )
      COMPLEX            A( LDA, * )
*     ..
*
*  Purpose
*  =======
*
*  CGETRF computes an LU factorization of a general M-by-N matrix A
*  using partial pivoting with row interchanges.
*
*  The factorization has the form
*     A = P * L * U
*  where P is a permutation matrix, L is lower triangular with unit
*  diagonal elements (lower trapezoidal if m > n), and U is upper
*  triangular (upper trapezoidal if m < n).
*
*  This code implements an iterative version of Sivan Toledo's recursive
*  LU algorithm[1].  For square matrices, this iterative versions should
*  be within a factor of two of the optimum number of memory transfers.
*
*  The pattern is as follows, with the large blocks of U being updated
*  in one call to DTRSM, and the dotted lines denoting sections that
*  have had all pending permutations applied:
*
*   1 2 3 4 5 6 7 8
*  +-+-+---+-------+------
*  | |1|   |       |
*  |.+-+ 2 |       |
*  | | |   |       |
*  |.|.+-+-+   4   |
*  | | | |1|       |
*  | | |.+-+       |
*  | | | | |       |
*  |.|.|.|.+-+-+---+  8
*  | | | | | |1|   |
*  | | | | |.+-+ 2 |
*  | | | | | | |   |
*  | | | | |.|.+-+-+
*  | | | | | | | |1|
*  | | | | | | |.+-+
*  | | | | | | | | |
*  |.|.|.|.|.|.|.|.+-----
*  | | | | | | | | |
*
*  The 1-2-1-4-1-2-1-8-... pattern is the position of the last 1 bit in
*  the binary expansion of the current column.  Each Schur update is
*  applied as soon as the necessary portion of U is available.
*
*  [1] Toledo, S. 1997. Locality of Reference in LU Decomposition with
*  Partial Pivoting. SIAM J. Matrix Anal. Appl. 18, 4 (Oct. 1997),
*  1065-1081. http://dx.doi.org/10.1137/S0895479896297744
*
*  Arguments
*  =========
*
*  M       (input) INTEGER
*          The number of rows of the matrix A.  M >= 0.
*
*  N       (input) INTEGER
*          The number of columns of the matrix A.  N >= 0.
*
*  A       (input/output) COMPLEX array, dimension (LDA,N)
*          On entry, the M-by-N matrix to be factored.
*          On exit, the factors L and U from the factorization
*          A = P*L*U; the unit diagonal elements of L are not stored.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,M).
*
*  IPIV    (output) INTEGER array, dimension (min(M,N))
*          The pivot indices; for 1 <= i <= min(M,N), row i of the
*          matrix was interchanged with row IPIV(i).
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value
*          > 0:  if INFO = i, U(i,i) is exactly zero. The factorization
*                has been completed, but the factor U is exactly
*                singular, and division by zero will occur if it is used
*                to solve a system of equations.
*
*  =====================================================================
*
*     .. Parameters ..
      COMPLEX            ONE, NEGONE
      REAL               ZERO
      PARAMETER          ( ONE = (1.0E+0, 0.0E+0) )
      PARAMETER          ( NEGONE = (-1.0E+0, 0.0E+0) )
      PARAMETER          ( ZERO = 0.0E+0 )
*     ..
*     .. Local Scalars ..
      REAL               SFMIN, PIVMAG
      COMPLEX            TMP
      INTEGER            I, J, JP, NSTEP, NTOPIV, NPIVED, KAHEAD
      INTEGER            KSTART, IPIVSTART, JPIVSTART, KCOLS
*     ..
*     .. External Functions ..
      REAL               SLAMCH
      INTEGER            ICAMAX
      LOGICAL            SISNAN
      EXTERNAL           SLAMCH, ICAMAX, SISNAN
*     ..
*     .. External Subroutines ..
      EXTERNAL           CTRSM, CSCAL, XERBLA, CLASWP
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN, IAND, ABS
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'CGETRF', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( M.EQ.0 .OR. N.EQ.0 )
     $   RETURN
*
*     Compute machine safe minimum
*
      SFMIN = SLAMCH( 'S' )
*
      NSTEP = MIN( M, N )
      DO J = 1, NSTEP
         KAHEAD = IAND( J, -J )
         KSTART = J + 1 - KAHEAD
         KCOLS = MIN( KAHEAD, M-J )
*
*        Find pivot.
*
         JP = J - 1 + ICAMAX( M-J+1, A( J, J ), 1 )
         IPIV( J ) = JP

!        Permute just this column.
         IF (JP .NE. J) THEN
            TMP = A( J, J )
            A( J, J ) = A( JP, J )
            A( JP, J ) = TMP
         END IF

!        Apply pending permutations to L
         NTOPIV = 1
         IPIVSTART = J
         JPIVSTART = J - NTOPIV
         DO WHILE ( NTOPIV .LT. KAHEAD )
            CALL CLASWP( NTOPIV, A( 1, JPIVSTART ), LDA, IPIVSTART, J,
     $           IPIV, 1 )
            IPIVSTART = IPIVSTART - NTOPIV;
            NTOPIV = NTOPIV * 2;
            JPIVSTART = JPIVSTART - NTOPIV;
         END DO

!        Permute U block to match L
         CALL CLASWP( KCOLS, A( 1,J+1 ), LDA, KSTART, J, IPIV, 1 )

!        Factor the current column
         PIVMAG = ABS( A( J, J ) )
         IF( PIVMAG.NE.ZERO .AND. .NOT.SISNAN( PIVMAG ) ) THEN
               IF( PIVMAG .GE. SFMIN ) THEN
                  CALL CSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 )
               ELSE
                 DO I = 1, M-J
                    A( J+I, J ) = A( J+I, J ) / A( J, J )
                 END DO
               END IF
         ELSE IF( PIVMAG .EQ. ZERO .AND. INFO .EQ. 0 ) THEN
            INFO = J
         END IF

!        Solve for U block.
         CALL CTRSM( 'Left', 'Lower', 'No transpose', 'Unit', KAHEAD,
     $        KCOLS, ONE, A( KSTART, KSTART ), LDA,
     $        A( KSTART, J+1 ), LDA )
!        Schur complement.
         CALL CGEMM( 'No transpose', 'No transpose', M-J,
     $        KCOLS, KAHEAD, NEGONE, A( J+1, KSTART ), LDA,
     $        A( KSTART, J+1 ), LDA, ONE, A( J+1, J+1 ), LDA )
      END DO

!     Handle pivot permutations on the way out of the recursion
      NPIVED = IAND( NSTEP, -NSTEP )
      J = NSTEP - NPIVED
      DO WHILE ( J .GT. 0 )
         NTOPIV = IAND( J, -J )
         CALL CLASWP( NTOPIV, A( 1, J-NTOPIV+1 ), LDA, J+1, NSTEP,
     $        IPIV, 1 )
         J = J - NTOPIV
      END DO

!     If short and wide, handle the rest of the columns.
      IF ( M .LT. N ) THEN
         CALL CLASWP( N-M, A( 1, M+KCOLS+1 ), LDA, 1, M, IPIV, 1 )
         CALL CTRSM( 'Left', 'Lower', 'No transpose', 'Unit', M,
     $        N-M, ONE, A, LDA, A( 1,M+KCOLS+1 ), LDA )
      END IF

      RETURN
*
*     End of CGETRF
*
      END


program demo_expression
use M_calculator,      only : iclen_calc
use M_calculator, only : expression
implicit none
character(len=iclen_calc) ::  outlin0
doubleprecision :: outval
integer :: ierr, ilen
   call expression('A=3.4**5    ',outval,outlin0,ierr,ilen)
   write(*,*)'value of expression is ',outval
   write(*,*)'string representation of value is ',trim(outlin0)
   write(*,*)'error flag value is ',ierr
   write(*,*)'length of expression is ',ilen
end program demo_expression


program fshapes
!(LICENSE:PD)
!
!@(#)  This program shows some of the simple primitives.
!
use M_draw
implicit none
integer :: ix
integer :: iy
integer :: idum
character(len=50) :: device

   print*,'Enter output device:'
   read(*,'(a)')device
   if(device.eq.'x11')then
      write(*,*)'enter position'
      read(*,*)ix,iy
      call prefposition(ix,iy)
      call prefsize(500,500)
   endif
   call vinit(device)
!
! the two lines below clear the screen to white if we have
! colours. Color is ignored on a monochrome device so in that case
! screen will be cleared to its background color, normally black.
!
   call color(D_BLACK)
   call clear()
!
! set the screen to be 2.0 units wide and 2.0 units wide, with
! the drawable coordinates going from -1.0 to 1.0.
!
   call ortho2(-1.0, 1.0, -1.0, 1.0)
!
! set the text size. After this call no characters in the
! current font will be wider than 0.1 or higher than 0.1 in
! world units. As the window is currently 2.0 units wide and
! 2.0 units high text will be about one twentieth of the screen
! size.
!
   call textsize(0.1, 0.1)

   call color(D_MAGENTA)
!
! okay, so we want to draw in the range -1 to 1, but we
! only want to draw in the top lefthand corner of the
! screen. The call to viewport allows us to do this. As
! viewport always takes screen coordinates, which are
! always in the range of -1 to 1 we can change
! the viewport to somewhere else on the screen
! by giving a range in -1 to 1.
!
   call viewport(-1.0, 0.0, 0.0, 1.0)
!
! write out a heading
!
   call move2(-0.9, -0.5)
   call drawstr('rect')
!
! draw a rectangle around the points (-0.2, -0.2), (-0.2, 0.2),
! (0.3, 0.2), and (0.3, -0.2).
!
   call rect(-0.2, -0.2, 0.3, 0.2)

   call color(D_BLUE)
!
! now we want to draw in the top right corner of the screen
!
   call viewport(0.0, 1.0, 0.0, 1.0)

   call move2(-0.9, -0.5)
   call drawstr('circle')
!
! draw a circle of radius 0.4 around the point (0.0, 0.0)
!
   call circle(0.0, 0.0, 0.4)

   call color(D_GREEN)
!
! draw in bottom left corner
!
   call viewport(-1.0, 0.0, -1.0, 0.0)

   call move2(-0.9, -0.5)
   call drawstr('ellipse')
!
! To draw an ellipse we change the aspect ratio so it is no longer
! 1 and call circle. In this case we use ortho2 to make the square
! viewport appear to be higher than it is wide. Alternatively you
! could use arc to construct one.
!
! The call to pushmatrix saves the current viewing transformation.
! After the ortho2 has been done, we restore the current viewing
! transformation with a call to popmatrix. (Otherwise everything
! after the call to ortho would come out looking squashed as the
! world aspect ratio is no longer 1).
!
   call pushmatrix()
   call ortho2(-1.0, 1.0, -1.0, 2.0)
   call circle(0.0, 0.5, 0.4)
   call popmatrix()

   call color(D_RED)
!
! now draw in bottom right corner
!
   call viewport(0.0, 1.0, -1.0, 0.0)

   call move2(-0.9, -0.5)
   call drawstr('arc')
!
! draw an arc centered at (0.0, 0.0), radius of 0.4. 0.0 is the start
! angle and 90.0 is the end angle of the arc being drawn. So this
! draws a quarter circle.
!
   call arc(0.0, 0.0, 0.4, 0.0, 90.0)

   idum=getkey()

   call vexit()

end program fshapes


program loop_label
implicit none
integer, parameter :: n = 5
real               :: x(n,n)
integer            :: i,j,ineg,jneg
call random_number(x)
x = x - 0.1
ineg = 0
jneg = 0
! find location of first negative element in x,
! traversing by row
iloop: do i=1,n
   do j=1,n
      if (x(i,j) < 0.0) then
         ineg = i
         jneg = j
         exit iloop
      end if
   end do
end do iloop
print "(a,2i3)","first negative value at ",ineg,jneg
print*,"x ="
do i=1,n
   print "(*(1x,f5.2))", x(i,:)
end do
end program loop_label
! sample output:
! first negative value at   3  4
!  x =
!   0.85  0.64  0.82  0.13  0.65
!   0.17  0.14  0.23  0.83  0.59
!   0.41  0.27  0.89 -0.06  0.06
!   0.58  0.63  0.10  0.17  0.87
!   0.32  0.74  0.70  0.75  0.28


MODULE integers

  USE ISO_C_BINDING
  IMPLICIT NONE

CONTAINS

  FUNCTION add_ints1(a,b) RESULT(y)
    INTEGER ( KIND = 1 ) , INTENT(in) :: a
    INTEGER(1), INTENT(in) :: b
    INTEGER*1 :: y
    y = a+b
  END FUNCTION add_ints1

  FUNCTION add_ints2(a,b) RESULT(y)
    INTEGER*2, INTENT(in) :: a,b
    INTEGER(KIND=2  ) :: y
    y = a+b
  END FUNCTION add_ints2

  FUNCTION add_ints4(a,b) RESULT(y)
    INTEGER (KIND  =4), INTENT(in) :: a
    INTEGER, INTENT(in) :: b
    INTEGER :: y
    y = a+b
  END FUNCTION add_ints4

  FUNCTION add_ints8(a,b) RESULT(y)
    INTEGER (KIND= 8), INTENT(in) :: a
    INTEGER*8, INTENT(in) :: b
    INTEGER(8) :: y
    y = a+b
  END FUNCTION add_ints8

  FUNCTION add_ints_byval(a,b) RESULT(y)
    INTEGER, INTENT(in), VALUE :: a, b
    INTEGER :: y
    y = a + b
  END FUNCTION add_ints_byval

  ! Test lower case parsing:

  function add_ints1_lower(a,b) result(y)
    integer ( kind = 1 ) , intent(in) :: a
    integer ( 1), intent(in) :: b
    integer*1 :: y
    y = a+b
  end function add_ints1_lower

  function add_ints2_lower(a,b) result(y)
    integer*2, intent(in) :: a,b
    integer(KIND=2  ) :: y
    y = a+b
  end function add_ints2_lower

  function add_ints4_lower(a,b) result(y)
    integer (kind  =4), intent(in) :: a
    integer, intent(in) :: b
    integer :: y
    y = a+b
  end function add_ints4_lower

  FUNCTION add_iso_ints(a,b) RESULT(y)
    INTEGER (C_INT) , INTENT(in) :: a, b
    INTEGER (C_INT) :: y
    y = a+b
  END FUNCTION add_iso_ints

  FUNCTION add_iso_longs(a,b) RESULT(y)
    INTEGER (C_LONG) , INTENT(in) :: a, b
    INTEGER (C_LONG) :: y
    y = a+b
  END FUNCTION add_iso_longs

END MODULE integers


! Copyright 2017, UT-Battelle, LLC
!
! SPDX-License-Identifier: BSD-3-Clause
! License-Filename: LICENSE
program test_TpetraMultiVector
#include "ForTrilinosTpetra_config.hpp"
#include "FortranTestUtilities.h"
  use iso_fortran_env
  use, intrinsic :: iso_c_binding
  use forteuchos
  use fortpetra

  implicit none
  type(TeuchosComm) :: comm
  integer(global_size_type), parameter :: invalid = -1
  character(len=256), parameter :: FILENAME="test_tpetra_multivector.f90"

  SETUP_TEST()

#ifdef HAVE_MPI
  comm = create_TeuchosComm(MPI_COMM_WORLD); FORTRILINOS_CHECK_IERR()
#else
  comm = create_TeuchosComm(); FORTRILINOS_CHECK_IERR()
#endif

  ADD_SUBTEST_AND_RUN(TpetraMultiVector_ZeroScaleUpdate)
  ADD_SUBTEST_AND_RUN(TpetraMultiVector_CountNormInf)
  ADD_SUBTEST_AND_RUN(TpetraMultiVector_Norm2)
  ADD_SUBTEST_AND_RUN(TpetraMultiVector_ReplaceMap)
  ADD_SUBTEST_AND_RUN(TpetraMultiVector_Reciprocal)
  ADD_SUBTEST_AND_RUN(TpetraMultiVector_Abs)
  ADD_SUBTEST_AND_RUN(TpetraMultiVector_Description)
  ADD_SUBTEST_AND_RUN(TpetraMultiVector_MeanValue)
  ADD_SUBTEST_AND_RUN(TpetraMultiVector_Multiply)
  ADD_SUBTEST_AND_RUN(TpetraMultiVector_Basic)
  ADD_SUBTEST_AND_RUN(TpetraMultiVector_Reduce)
  ADD_SUBTEST_AND_RUN(TpetraMultiVector_ReplaceGlobalValue)
  ADD_SUBTEST_AND_RUN(TpetraMultiVector_ReplaceLocalValue)
  ADD_SUBTEST_AND_RUN(TpetraMultiVector_Get1dCopy)

  ! TODO: The following tests have only skeletons
  !ADD_SUBTEST_AND_RUN(TpetraMultiVector_offsetViewNonConst)

  ! The following methods are deprecated
  !ADD_SUBTEST_AND_RUN(TpetraMultiVector_normWeighted)

  ! The following methods are listed as "may change or disappear at any time"
  !ADD_SUBTEST_AND_RUN(TpetraMultiVector_setCopyOrView)
  !ADD_SUBTEST_AND_RUN(TpetraMultiVector_getCopyOrView)
  !ADD_SUBTEST_AND_RUN(TpetraMultiVector_removeEmptyProcessesInPlace)

  call comm%release()

  TEARDOWN_TEST()

contains

  ! -----------------------------ZeroScaleUpdate------------------------------ !
  FORTRILINOS_UNIT_TEST(TpetraMultiVector_ZeroScaleUpdate)
    integer :: i
    type(TpetraMap) :: map
    type(TpetraMultiVector) :: A, B, A2, C
    integer(size_type), parameter :: num_vecs=2, num_local=2, LDA=2
    integer(local_ordinal_type) :: lclrow
    logical(bool_type) :: zeroout
    real(scalar_type), parameter :: zero=0., one=1., two=2., four=4., negone=-1.
    real(scalar_type) :: norms(num_vecs), zeros(num_vecs), values(6)
    integer(global_ordinal_type) :: gblrow, num_global

    zeros = zero

    map = create_TpetraMap(invalid, num_local, comm); TEST_IERR()

    ! values = {1, 1, 2, 2, 4, 4}
    ! values(1:4) = {1, 1, 2, 2} = [1 2]
    !                            = [1 2]
    ! values(3:)  = {2, 2, 4, 4} = [2 4]
    !                            = [2 4]
    ! a multivector A constructed from the first
    ! has values .5 of a multivector B constructed from the second
    ! then 2*A - B = 0
    ! we test both scale(), both update(), and norm()
    values = [one, one, two, two, four, four]

    ! TODO: Multivec create to take array, not ArrayView
    A = create_TpetraMultiVector(map, values(1:4), LDA, num_vecs); TEST_IERR()
    B = create_TpetraMultiVector(map, values(3:), LDA, num_vecs); TEST_IERR()

    !
    !      [.... ....]
    ! A == [ones ones]
    !      [.... ....]
    !
    !      [.... ....]
    ! B == [twos twos]
    !      [.... ....]
    !
    !   set A2 = A
    !   scale it by 2 in situ
    !   check that it equals B: subtraction in situ
    A2 = create_TpetraMultiVector(A, TeuchosCopy); TEST_IERR()
    call A2%scale(two)
    call A2%update(negone, B, one)
    call A2%norm1(norms)
    TEST_FLOATING_ARRAY_EQUALITY(norms, zeros, epsilon(zero))
    call A2%release()

    ! set A2 = A
    ! check that it equals B: scale, subtraction in situ
    A2 = create_TpetraMultiVector(A, TeuchosCopy); TEST_IERR()
    call A2%update(negone, B, two)
    call A2%norm1(norms)
    TEST_FLOATING_ARRAY_EQUALITY(norms, zeros, epsilon(zero))
    call A2%release()

    ! set C random
    ! set it to zero by combination with A,B
    zeroout = .false.
    C = create_TpetraMultiVector(map, num_vecs, zeroout); TEST_IERR()
    call C%randomize()
    call C%update(negone, B, two, A, zero)
    call C%norm1(norms)
    TEST_FLOATING_ARRAY_EQUALITY(norms, zeros, epsilon(zero))
    call C%release()

    ! set C random
    ! scale it ex-situ
    ! check that it equals B: subtraction in situ
    C = create_TpetraMultiVector(map, num_vecs, zeroout); TEST_IERR()
    call C%scale(two, A)
    call C%update(one, B, negone)
    call C%norm1(norms)
    TEST_FLOATING_ARRAY_EQUALITY(norms, zeros, epsilon(zero))
    call C%release()

    ! Clean up
    call A%release(); TEST_IERR()
    call B%release(); TEST_IERR()
    call map%release(); TEST_IERR()

  END_FORTRILINOS_UNIT_TEST(TpetraMultiVector_ZeroScaleUpdate)

  ! ----------------------------CountNormInf---------------------------------- !
  FORTRILINOS_UNIT_TEST(TpetraMultiVector_CountNormInf)
    type(TpetraMap) :: map
    type(TpetraMultiVector) :: Vec
    integer(size_type), parameter :: num_vecs=3, num_local=2, LDA=2
    real(scalar_type) :: values(num_vecs*num_local), answer(num_vecs), norms(num_vecs)

    OUT0("Starting CountNormInf")

    ! create a Map
    map = create_TpetraMap(invalid, num_local, comm); TEST_IERR()
    ! values = {0, 0, 1, 1, 2, 2} = [0 1 2]
    !                               [0 1 2]
    ! normInf(values) = [0 1 2]
    ! over all procs, this is [0 1 2]
    values(:) = [0., 0., 1., 1., 2., 2.]
    Vec = create_TpetraMultiVector(map, values, LDA, num_vecs); TEST_IERR()
    answer(:) = [0., 1., 2.]

    ! do the dots
    call Vec%normInf(norms)

    call Vec%release()
    call map%release()

    ! check the answers
    TEST_FLOATING_ARRAY_EQUALITY(norms, answer, epsilon(answer(1)))

    OUT0("Finished CountNormInf!")

  END_FORTRILINOS_UNIT_TEST(TpetraMultiVector_CountNormInf)

  ! --------------------------------Norm2------------------------------------- !
  FORTRILINOS_UNIT_TEST(TpetraMultiVector_Norm2)
    type(TpetraMap) :: map
    type(TpetraMultiVector) :: Vec
    real(scalar_type), parameter :: zero=0.
    integer(size_type), parameter :: num_vecs=7, num_local=13
    real(scalar_type) :: norms_rand(num_vecs), norms_zero(num_vecs)

    OUT0("Starting Norm2")

    ! create a Map
    map = create_TpetraMap(invalid, num_local, comm); TEST_IERR()

    Vec = create_TpetraMultiVector(map, num_vecs); TEST_IERR()
    call Vec%randomize(); TEST_IERR()

    ! Take the norms, they should not be zero
    call Vec%norm2(norms_rand)

    ! Zero the vector
    call Vec%putScalar(zero)

    ! Take the norms, they should be zero
    call Vec%norm2(norms_zero)

    ! Check the answers
    TEST_FLOATING_ARRAY_INEQUALITY(norms_rand, zero, epsilon(zero))
    TEST_FLOATING_ARRAY_EQUALITY(norms_zero, zero, epsilon(zero))

    call Vec%release()
    call map%release()

    OUT0("Finished Norm2!")

  END_FORTRILINOS_UNIT_TEST(TpetraMultiVector_Norm2)

  ! -----------------------------Reciprocal----------------------------------- !
  FORTRILINOS_UNIT_TEST(TpetraMultiVector_Reciprocal)
    type(TpetraMap) :: map
    type(TpetraMultiVector) :: A, B
    integer(size_type), parameter :: num_vecs=2, num_local=10
    real(scalar_type) :: dots(num_vecs)
    real(scalar_type), parameter :: one=1., five=5.

    OUT0("Starting Reciprocal")

    ! create a Map
    map = create_TpetraMap(invalid, num_local, comm); TEST_IERR()

    A = create_TpetraMultiVector(map, num_vecs); TEST_IERR()
    B = create_TpetraMultiVector(map, num_vecs); TEST_IERR()
    call A%putScalar(five); TEST_IERR()
    call B%reciprocal(A); TEST_IERR()

    ! Take the dots, they should one
    call A%dot(B, dots)

    ! Check the answers
    TEST_FLOATING_ARRAY_EQUALITY(dots, one*num_local*comm%getSize(), epsilon(one))

    call A%release()
    call B%release()
    call map%release()

    OUT0("Finished Reciprocal!")

  END_FORTRILINOS_UNIT_TEST(TpetraMultiVector_Reciprocal)

  ! --------------------------------ReplaceMap-------------------------------- !
  FORTRILINOS_UNIT_TEST(TpetraMultiVector_ReplaceMap)
    type(TpetraMultiVector) :: Obj
    type(TpetraMap) :: map1, map2
    integer(size_type), parameter :: num_vecs=1
    integer(global_ordinal_type) :: num_global

    OUT0("Starting ReplaceMap")
    ! NOTE: This test only tests the interface does not throw.
    ! It does not test correctness
    num_global = 4 * comm%getSize()
    map1 = create_TpetraMap(num_global, comm); TEST_IERR()

    num_global = 5 * comm%getSize()
    map2 = create_TpetraMap(num_global, comm); TEST_IERR()

    Obj = create_TpetraMultiVector(map1, num_vecs); TEST_IERR()

    call Obj%replaceMap(map2); TEST_IERR()

    call map1%release(); TEST_IERR()
    call map2%release(); TEST_IERR()

    call Obj%release(); TEST_IERR()

    OUT0("Finished ReplaceMap")

  END_FORTRILINOS_UNIT_TEST(TpetraMultiVector_ReplaceMap)

  ! ----------------------------------Abs------------------------------------- !
  FORTRILINOS_UNIT_TEST(TpetraMultiVector_Abs)
    integer :: i
    type(TpetraMap) :: map
    type(TpetraMultiVector) :: A, B, A2
    integer(size_type), parameter :: num_vecs=2, num_local=10
    real(scalar_type), parameter :: zero=0., one=1., negone=-1.
    real(scalar_type) :: norms(num_vecs)

    OUT0("Starting Abs")
    map = create_TpetraMap(invalid, num_local, comm); TEST_IERR()

    A = create_TpetraMultiVector(map, num_vecs); TEST_IERR()
    B = create_TpetraMultiVector(map, num_vecs); TEST_IERR()
    call A%putScalar(negone); TEST_IERR()
    call A%abs(B)

    !   set A2 = A
    !   scale it by 2 in situ
    !   check that it equals B: subtraction in situ
    A2 = create_TpetraMultiVector(A, TeuchosCopy); TEST_IERR()
    call A2%update(one, B, one)
    call A2%norm1(norms)
    TEST_FLOATING_ARRAY_EQUALITY(norms, zero, epsilon(zero))

    call A2%release()
    call B%release()
    call A%release()
    call map%release()

    OUT0("Finished Abs")

  END_FORTRILINOS_UNIT_TEST(TpetraMultiVector_Abs)

! --------------------------------description--------------------------------- !
  FORTRILINOS_UNIT_TEST(TpetraMultiVector_Description)
    type(TpetraMap) :: map
    type(TpetraMultiVector) :: Vec
    character(kind=C_CHAR, len=:), allocatable :: description
    integer(size_type), parameter :: num_vecs=2, num_local=10
    integer(global_ordinal_type) :: num_global
    map = create_TpetraMap(invalid, num_local, comm); TEST_IERR()
    Vec = create_TpetraMultiVector(map, num_vecs)
    description = Vec%description(); TEST_IERR()
    call Vec%release(); TEST_IERR()
  END_FORTRILINOS_UNIT_TEST(TpetraMultiVector_Description)

  ! --------------------------------MeanValue--------------------------------- !
  FORTRILINOS_UNIT_TEST(TpetraMultiVector_MeanValue)
    type(TpetraMap) :: map
    type(TpetraMultiVector) :: Vec
    integer(size_type), parameter :: num_vecs=2, num_local=2, LDA=2
    real(scalar_type) :: values(4), means(num_vecs), answer(num_vecs)

    OUT0("Starting MeanValue")

    map = create_TpetraMap(invalid, num_local, comm); TEST_IERR()

    ! values = {2, 6, 3, 1} = [2 3]
    !                         [6 1]
    values(:) = [2., 6., 3., 1.]

    Vec = create_TpetraMultiVector(map, values, LDA, num_vecs); TEST_IERR()

    !means = create_xxx(); TEST_IERR()
    call Vec%meanValue(means); TEST_IERR()

    answer = [4., 2.]
    TEST_FLOATING_ARRAY_EQUALITY(means, answer, epsilon(means(1)))

    call Vec%release(); TEST_IERR()
    call map%release(); TEST_IERR()

    OUT0("Finished MeanValue")

  END_FORTRILINOS_UNIT_TEST(TpetraMultiVector_MeanValue)

  ! ---------------------------------Multiply--------------------------------- !
  FORTRILINOS_UNIT_TEST(TpetraMultiVector_Multiply)
    type(TpetraMap) :: map2n, map3n, lmap2, lmap3
    type(TpetraMultiVector) :: mv3nx2, mv3nx3, mv2x2, mv2x3, mv3x2, mv3x3
    real(scalar_type), parameter :: S0=0., S1=1.
    integer(size_type), parameter :: n2=2, n3=3
    integer(int_type) :: num_images
    integer(global_size_type) :: num_global
    real(scalar_type) :: check(9)

    OUT0("Starting Multiply")

    map2n = create_TpetraMap(invalid, n2, comm); TEST_IERR()
    map3n = create_TpetraMap(invalid, n3, comm); TEST_IERR()

    lmap2 = create_TpetraMap(n2, comm, TpetraLocallyReplicated); TEST_IERR()
    lmap3 = create_TpetraMap(n3, comm, TpetraLocallyReplicated); TEST_IERR()

    mv3nx2 = create_TpetraMultiVector(map3n, n2)
    mv3nx3 = create_TpetraMultiVector(map3n, n3)

    mv2x2 = create_TpetraMultiVector(lmap2, n2)
    mv2x3 = create_TpetraMultiVector(lmap2, n3)
    mv3x2 = create_TpetraMultiVector(lmap3, n2)
    mv3x3 = create_TpetraMultiVector(lmap3, n3)

    num_images = comm%getSize()
    check = 3 * num_images

    call mv2x2%multiply(TEUCHOSCONJ_TRANS,TEUCHOSNO_TRANS,S1,mv3nx2,mv3nx2,S0); TEST_IERR()
    call mv2x3%multiply(TEUCHOSCONJ_TRANS,TEUCHOSNO_TRANS,S1,mv3nx2,mv3nx3,S0); TEST_IERR()
    call mv3x2%multiply(TEUCHOSCONJ_TRANS,TEUCHOSNO_TRANS,S1,mv3nx3,mv3nx2,S0); TEST_IERR()
    call mv3x3%multiply(TEUCHOSCONJ_TRANS,TEUCHOSNO_TRANS,S1,mv3nx3,mv3nx3,S0); TEST_IERR()

    !a = fortran array view of the data
    !n = size of a
    !TEST_FLOATING_ARRAY_EQUALITY(a, check(1:n), epsilon(a(1)))

    OUT0("Finished Multiply!")

  END_FORTRILINOS_UNIT_TEST(TpetraMultiVector_Multiply)

  ! --------------------------------Basic------------------------------------- !
  FORTRILINOS_UNIT_TEST(TpetraMultiVector_Basic)
    type(TpetraMap) :: map
    type(TpetraMultiVector) :: Vec
    integer(size_type), parameter :: num_vecs=12, num_local=2
    map = create_TpetraMap(invalid, num_local, comm); TEST_IERR()
    Vec = create_TpetraMultiVector(map, num_vecs); TEST_IERR()

    TEST_EQUALITY(Vec%getNumVectors(), num_vecs)
    TEST_EQUALITY(Vec%getLocalLength(), num_local)
    TEST_EQUALITY(Vec%getGlobalLength(), num_local*comm%getSize())
    TEST_EQUALITY(Vec%getStride(), num_local)
    TEST_ASSERT(Vec%isConstantStride())

    call Vec%release(); TEST_IERR()
    call map%release(); TEST_IERR()
  END_FORTRILINOS_UNIT_TEST(TpetraMultiVector_Basic)

  ! ----------------------------------Reduce---------------------------------- !
  FORTRILINOS_UNIT_TEST(TpetraMultiVector_Reduce)
    type(TpetraMap) :: map
    type(TpetraMultiVector) :: Vec
    integer(global_size_type) :: num_global
    integer(size_type), parameter :: num_vecs=1, num_local=2
    real(scalar_type), parameter :: two=2.
    OUT0("Starting Reduce")
    num_global = num_local * comm%getSize()
    map = create_TpetraMap(num_global, comm, TpetraLocallyReplicated); TEST_IERR()
    Vec = create_TpetraMultiVector(map, num_vecs); TEST_IERR()
    call Vec%putScalar(two); TEST_IERR()
    call Vec%reduce(); TEST_IERR()
    call Vec%release(); TEST_IERR()
    call map%release(); TEST_IERR()
    OUT0("Finished Reduce!")
  END_FORTRILINOS_UNIT_TEST(TpetraMultiVector_Reduce)

  ! ----------------------------replaceGlobalValue---------------------------- !
  FORTRILINOS_UNIT_TEST(TpetraMultiVector_ReplaceGlobalValue)
    integer :: i
    type(TpetraMap) :: map
    type(TpetraMultiVector) :: Vec, OneV
    integer(size_type) :: col
    integer(size_type), parameter :: num_vecs=2, num_local=4
    integer(local_ordinal_type) :: lclrow
    real(scalar_type) :: value, expected, dots(num_vecs)
    real(scalar_type), parameter :: one=1.
    integer(global_ordinal_type) :: gblrow, num_global
    OUT0("Starting replaceGlobalValue")
    num_global = num_local * comm%getSize()
    map = create_TpetraMap(num_global, comm); TEST_IERR()

    Vec = create_TpetraMultiVector(map, num_vecs); TEST_IERR()
    OneV = create_TpetraMultiVector(map, num_vecs); TEST_IERR()
    call OneV%putScalar(one); TEST_IERR()

    do lclrow = 1, num_local
      gblrow = map%getGlobalElement(lclrow)
      value = real(gblrow, kind=scalar_type)
      do col = 1, num_vecs
        call Vec%replaceGlobalValue(gblrow, col, value); TEST_IERR()
      end do
    end do

    call Vec%dot(OneV, dots)
    expected = real(num_global * (num_global + 1) / 2., kind=scalar_type)
    TEST_FLOATING_EQUALITY(dots(1), dots(2), epsilon(dots(2)))
    TEST_FLOATING_EQUALITY(expected, dots(1), epsilon(dots(2)))

    call Vec%release(); TEST_IERR()
    call OneV%release(); TEST_IERR()
    call map%release(); TEST_IERR()

    OUT0("Finished replaceGlobalValue!")

  END_FORTRILINOS_UNIT_TEST(TpetraMultiVector_ReplaceGlobalValue)

  ! ----------------------------ReplaceLocalValue----------------------------- !
  FORTRILINOS_UNIT_TEST(TpetraMultiVector_ReplaceLocalValue)
    type(TpetraMap) :: map
    type(TpetraMultiVector) :: Vec, OneV
    integer(size_type) :: col
    integer(local_ordinal_type) :: lclrow
    integer(size_type), parameter :: num_vecs=2, num_local=4
    real(scalar_type) :: value, dots(num_vecs), expected
    real(scalar_type), parameter :: one=1.
    OUT0("Starting ReplaceLocalValue")

    map = create_TpetraMap(invalid, num_local, comm); TEST_IERR()
    Vec = create_TpetraMultiVector(map, num_vecs); TEST_IERR()
    OneV = create_TpetraMultiVector(map, num_vecs); TEST_IERR()
    call OneV%putScalar(one)

    do lclrow = 1, num_local
      value = real(lclrow, kind=scalar_type)
      do col = 1, num_vecs
        call Vec%replaceLocalValue(lclrow, col, value); TEST_IERR()
      end do
    end do

    call Vec%dot(OneV, dots)
    expected = real(comm%getSize() * (num_local * (num_local + 1)) / 2., kind=scalar_type)
    TEST_FLOATING_EQUALITY(dots(1), dots(2), epsilon(dots(2)))
    TEST_FLOATING_EQUALITY(expected, dots(1), epsilon(dots(2)))

    call Vec%release(); TEST_IERR()
    call OneV%release(); TEST_IERR()
    call map%release()

    OUT0("Finished ReplaceLocalValue!")

  END_FORTRILINOS_UNIT_TEST(TpetraMultiVector_ReplaceLocalValue)

  ! --------------------------------Get1dCopy--------------------------------- !
  FORTRILINOS_UNIT_TEST(TpetraMultiVector_Get1dCopy)
    type(TpetraMap) :: map
    type(TpetraMultiVector) :: Vec
    integer(size_type) :: lda
    real(scalar_type), allocatable :: a(:)
    integer(size_type), parameter :: num_vecs=2, num_local=4
    real(scalar_type), parameter :: one=1.
    OUT0("Starting Get1dCopy")
    map = create_TpetraMap(invalid, num_local, comm); TEST_IERR()
    Vec = create_TpetraMultiVector(map, num_vecs); TEST_IERR()
    call Vec%putScalar(one); TEST_IERR()
    allocate(a(num_vecs*num_local*comm%getSize()))
    a = 0.
    lda = num_local*comm%getSize()
    call Vec%Get1dCopy(a, lda); TEST_IERR()
    call Vec%release(); TEST_IERR()

    TEST_FLOATING_ARRAY_EQUALITY(a, one, epsilon(one))
    deallocate(a)

    OUT0("Finished Get1dCopy!")

  END_FORTRILINOS_UNIT_TEST(TpetraMultiVector_Get1dCopy)

  ! ----------------------------offsetViewNonConst---------------------------- !
  FORTRILINOS_UNIT_TEST(TpetraMultiVector_offsetViewNonConst)
    type(TpetraMultiVector) :: Obj
    type(TpetraMap) :: submap
    integer(size_type) :: offset

    success = .false.

    !submap = create_TpetraMap(); TEST_IERR()
    offset = 0
    !Obj = create_TpetraMultiVector(); TEST_IERR()
    !fresult = Obj%offsetViewNonConst(submap, offset); TEST_IERR()
    !call submap%release(); TEST_IERR()
    !call Obj%release(); TEST_IERR()

    write(*,*) 'offsetViewNonConst: Test not yet implemented'

  END_FORTRILINOS_UNIT_TEST(TpetraMultiVector_offsetViewNonConst)

  ! -------------------------------normWeighted------------------------------- !
  FORTRILINOS_UNIT_TEST(TpetraMultiVector_normWeighted)
    type(TpetraMultiVector) :: Obj
    type(TpetraMultiVector) :: weights
    real(scalar_type) :: norms(1)

    success = .false.

    !weights = create_xxx(); TEST_IERR()
    !norms = create_xxx(); TEST_IERR()
    !Obj = create_TpetraMultiVector(); TEST_IERR()
    !call Obj%normWeighted(weights, norms); TEST_IERR()
    !call weights%release(); TEST_IERR()
    !call norms%release(); TEST_IERR()
    !call Obj%release(); TEST_IERR()

    write(*,*) 'normWeighted: Test not yet implemented'

  END_FORTRILINOS_UNIT_TEST(TpetraMultiVector_normWeighted)

  ! -----------------------removeEmptyProcessesInPlace------------------------ !
  FORTRILINOS_UNIT_TEST(TpetraMultiVector_removeEmptyProcessesInPlace)
    type(TpetraMultiVector) :: Obj
    type(TpetraMap) :: newmap

    success = .false.

    !newmap = create_TpetraMap(); TEST_IERR()
    !Obj = create_TpetraMultiVector(); TEST_IERR()
    !call Obj%removeEmptyProcessesInPlace(newmap); TEST_IERR()
    !call newmap%release(); TEST_IERR()
    !call Obj%release(); TEST_IERR()

    write(*,*) 'removeEmptyProcessesInPlace: Test not yet implemented'

  END_FORTRILINOS_UNIT_TEST(TpetraMultiVector_removeEmptyProcessesInPlace)

  ! ------------------------------setCopyOrView------------------------------- !
  FORTRILINOS_UNIT_TEST(TpetraMultiVector_setCopyOrView)
    type(TpetraMultiVector) :: Obj
    integer(kind(TeuchosDataAccess)) :: copyorview

    success = .false.

    copyorview = TeuchosCopy
    !Obj = create_TpetraMultiVector(); TEST_IERR()
    !call Obj%setCopyOrView(copyorview); TEST_IERR()
    !call Obj%release(); TEST_IERR()

    write(*,*) 'setCopyOrView: Test not yet implemented'

  END_FORTRILINOS_UNIT_TEST(TpetraMultiVector_setCopyOrView)

  ! ------------------------------getCopyOrView------------------------------- !
  FORTRILINOS_UNIT_TEST(TpetraMultiVector_getCopyOrView)
    type(TpetraMultiVector) :: Obj

    success = .false.

    !Obj = create_TpetraMultiVector(); TEST_IERR()
    !fresult = Obj%getCopyOrView(); TEST_IERR()
    !call Obj%release(); TEST_IERR()

    write(*,*) 'getCopyOrView: Test not yet implemented'

    END_FORTRILINOS_UNIT_TEST(TpetraMultiVector_getCopyOrView)

end program test_TpetraMultiVector


! Copyright (c) 2015 Alex Kramer <kramer.alex.kramer@gmail.com>
! See the LICENSE.txt file in the top-level directory of this distribution
!
! Global variables / numerical constants
module globvars
  use iso_fortran_env, only: real32, real64, int32

  implicit none

  ! Single precision real type / formatting
  integer(int32), parameter :: sp = real32
  real(sp), parameter :: sp_epsilon = epsilon(0.0_sp)
  character(*), parameter :: sp_format_raw = "es16.8e3"
  character(*), parameter :: sp_format = "("//sp_format_raw//")"

  ! Double precision real type / formatting
  integer(int32), parameter :: dp = real64
  real(dp), parameter :: dp_epsilon = epsilon(0.0_dp)
  character(*), parameter :: dp_format_raw = "es25.16e3"
  character(*), parameter :: dp_format = "("//dp_format_raw//")"

  ! Integer single precision type / formatting
  integer(int32), parameter :: ip = int32
  character(*), parameter :: ip_format = "(i0)"
  character(*), parameter :: ip_format_raw = "i0"

  ! Useful numbers
  real(dp), parameter :: pi_dp = 4.0_dp * atan(1.0_dp)
  real(dp), parameter :: e_dp = exp(1.0_dp)
  complex(dp), parameter :: j_dp = (0.0_dp, 1.0_dp)

  real(sp), parameter :: pi_sp = real(pi_dp, kind=sp)
  real(sp), parameter :: e_sp = real(e_dp, kind=sp)
  complex(sp), parameter :: j_sp = cmplx(j_dp, kind=sp)

end module globvars


PROGRAM main

  USE mo_kind,        ONLY: dp, sp, i4
  USE mo_integrate,   ONLY: int_regular
  use mo_ansi_colors, only: color, c_red, c_green

  IMPLICIT NONE

  INTEGER(i4), PARAMETER  :: nn = 9
  REAL(dp), DIMENSION(nn) :: dat
  REAL(sp), DIMENSION(nn) :: sat
  INTEGER(i4)             :: ii
  real(sp)                :: stmp
  real(dp)                :: dtmp

  LOGICAL :: isgood

  Write(*,*) ''
  Write(*,*) 'Test mo_integrate.f90'

  ! Double precision
  forall(ii=1:nn) dat(ii) = ii
  isgood = .true.
  dtmp   = int_regular(dat)
  isgood = isgood .and. (nint(dtmp) == 40)

  if (isgood) then
     write(*,*) 'mo_integrate double precision ', color('o.k.', c_green)
  else
     write(*,*) 'mo_integrate double precision ', color('failed!', c_red)
  endif

  ! Double precision
  forall(ii=1:nn) sat(ii) = ii
  isgood = .true.
  stmp   = int_regular(sat)
  isgood = isgood .and. (nint(stmp) == 40)

  if (isgood) then
     write(*,*) 'mo_integrate single precision ', color('o.k.', c_green)
  else
     write(*,*) 'mo_integrate single precision ', color('failed!', c_red)
  endif

END PROGRAM main


c     # ------------------------------------------------------------
c     # Streamfunction, velocity components and derivatives
c     #
c     # Stream function depends on these global variables
c     #         example (0=incompressible; 1=compressible)
c     #         mapping (0=torus; 1=twisted torus)
c     # ------------------------------------------------------------
      double precision function torus_psi(xc1,yc1)
      implicit none

      double precision xc1, yc1

      double precision pi, pi2
      common /compi/ pi

      double precision alpha
      common /torus_comm/ alpha

      double precision revs_per_s
      common /stream_comm/ revs_per_s

      integer mapping
      common /mapping_comm/ mapping

      integer example
      common /example_comm/ example

      double precision psi

      pi2 = 2*pi

c     # Velocity is described in terms of a stream function.  This
c     # approach depends on the mapping.

      if (example .eq. 0) then

c         # Rigid body rotation
          if (mapping .eq. 0 .or. mapping .eq. 2) then
              psi = (pi2*revs_per_s)*
     &                alpha*(pi2*yc1 + alpha*sin(pi2*yc1))
          elseif (mapping .eq. 1) then
              psi = (pi2*revs_per_s)*alpha*
     &                  (pi2*(xc1+yc1) + alpha*sin(pi2*(xc1+yc1)))
          endif
      else

          write(6,'(A,A)') '(psi.f) Non-rigid body rotation not ',
     &               'defined in terms of a streamfunction'
          stop
      endif
      torus_psi = psi

      end

      subroutine torus_psi_derivs(xc1,yc1,psi_xi, psi_eta)
      implicit none

      double precision xc1, yc1
      double precision psi_xi, psi_eta

      double precision pi, pi2
      common /compi/ pi

      double precision alpha
      common /torus_comm/ alpha

      double precision revs_per_s
      common /stream_comm/ revs_per_s

      integer mapping
      common /mapping_comm/ mapping

      integer example
      common /example_comm/ example

      pi2 = 2*pi

      if (example .eq. 0) then
          if (mapping .eq. 0) then
c             # psi = (pi2*revs_per_s)*alpha*(pi2*yc1 + alpha*sin(pi2*yc1))
              psi_xi = 0
              psi_eta = (pi2)**2*revs_per_s*alpha*(1 +
     &                    alpha*cos(pi2*yc1))
          elseif (mapping .eq. 1) then
c             # psi = (pi2*revs_per_s)*alpha*(pi2*(xc1+yc1) + alpha*sin(pi2*(xc1+yc1)))
              psi_xi = (pi2)**2*revs_per_s*alpha*(1 +
     &           alpha*cos(pi2*(xc1+yc1)))
              psi_eta = (pi2)**2*revs_per_s*alpha*(1 +
     &           alpha*cos(pi2*(xc1+yc1)))

          endif
      else
         write(6,'(A,A)') '(psi.f) : Velocity not defined in terms',
     &                    'of a stream function'
         stop
      endif

      end

      subroutine torus_basic_map(xc1,yc1,u1,u2,coderiv1,
     &                           coderiv2,tau1,tau2)

      implicit none
      double precision xc1, yc1, u1, u2, tau1(3), tau2(3)
      double precision coderiv1(2), coderiv2(2)
      double precision u11, u22, u12, u21
      double precision torus_dot

      double precision pi
      common /compi/ pi

      integer example
      common /example_comm/ example

      integer mapping, map_save
      common /mapping_comm/ mapping

      double precision revs_per_s
      common /stream_comm/ revs_per_s

      double precision alpha
      common /torus_comm/ alpha

      double precision s
      integer k

      map_save = mapping
      mapping = 0
      if (example .eq. 0) then
c         # Rigid body rotation
c         # Counter clockwise?
          u1 = revs_per_s
          u2 = 0

c             # Compute covariant derivatives
          u11 = 0
          u21 = 0
          call torus_covariant_derivative(xc1,yc1,1,u1,u2,
     &                                    u11,u21,coderiv1)

          u12 = 0
          u22 = 0
          call torus_covariant_derivative(xc1,yc1,2,u1,u2,
     &                                    u12,u22,coderiv2)

          call torus_covariant_basis(xc1,yc1,tau1,tau2)

      elseif (example .eq. 1) then
      endif

      mapping = map_save
      end

      subroutine torus_velocity_components(xc1,yc1,u1,u2,coderiv1,
     &                                     coderiv2)
      implicit none

      double precision xc1, yc1, u1, u2
      double precision coderiv1(2), coderiv2(2)
      double precision coderiv01(2), coderiv02(2)
      double precision t1(3), t2(3), s1(3), s2(3)
      double precision m11, m12, m21, m22, v1, v2, det
      double precision minv11, minv22, minv12, minv21
      double precision u11, u22, u12, u21
      double precision torus_dot

      double precision xp,yp,zp,xc2, yc2
      integer blockno_dummy

      integer*8 cont, get_context

      double precision pi
      common /compi/ pi

      integer example
      common /example_comm/ example

      integer mapping
      common /mapping_comm/ mapping

      double precision revs_per_s
      common /stream_comm/ revs_per_s

      double precision alpha
      common /torus_comm/ alpha

      double precision s
      integer k

      cont = get_context()

      if (example .eq. 0) then
c         # Rigid body rotation
          if (mapping .eq. 0) then
c             # Counter clockwise?
              call  torus_basic_map(xc1,yc1,u1,u2,coderiv1,
     &                              coderiv2,t1,t2)
          elseif (mapping .eq. 1) then
c             # Twisted torus

c             # First, invert map to get (xc,yc) for this point in
c             # the regular torus map.
c             # Do not map (xc1,yc1) to brick, since mapping was done above
              blockno_dummy = -1
              call fclaw2d_map_c2m(cont,blockno_dummy,xc1,yc1,xp,yp,zp)
              call mapc2m_torus_invert(xp,yp,zp,xc2,yc2,alpha)

              call  torus_basic_map(xc2,yc2,v1,v2,coderiv01,
     &                              coderiv02,t1,t2)

              call torus_contravariant_basis(xc1,yc1,s1,s2)

c             # Tensor to handle change of basis
              m11 = torus_dot(t1,s1)
              m12 = torus_dot(t2,s1)
              m21 = torus_dot(t1,s2)
              m22 = torus_dot(t2,s2)

              u1 = m11*v1 + m12*v2
              u2 = m21*v1 + m22*v2

c             # Compute covariant derivatives.  Use mapping=0 basis
c             # and transform
              coderiv1(1) = m11*coderiv01(1) + m12*coderiv01(2)
              coderiv1(2) = m21*coderiv01(1) + m22*coderiv01(2)

              coderiv2(1) = m11*coderiv02(1) + m12*coderiv02(2)
              coderiv2(2) = m21*coderiv02(1) + m22*coderiv02(2)

c              write(6,100) coderiv01(1), coderiv01(2),
c     &                 coderiv02(1), coderiv02(2)
c              write(6,100) coderiv1(1), coderiv1(2),
c     &                 coderiv2(1), coderiv2(2)
c              write(6,*) ' '
100           format(4F24.16)

          endif

      elseif (example .eq. 1) then
c         # Some other velocity field (div u not necessarily zero)
          if (mapping .eq. 0) then
c             # Velocity field with divergence
              s = sqrt(2.d0)
              u1 = s*cos(8*pi*xc1)
              u2 = s*sin(8*pi*yc1)

c             # Compute covariant derivatives
              u11 = -8*pi*s*sin(8*pi*xc1)
              u21 = 0
              call torus_covariant_derivative(xc1,yc1,1,u1,u2,
     &                                        u11,u21,coderiv1)

              u12 = 0
              u22 = 8*pi*s*cos(8*pi*xc1)
              call torus_covariant_derivative(xc1,yc1,2,u1,u2,
     &                                        u12,u22,coderiv2)

              call torus_covariant_basis(xc1,yc1,t1,t2)

          elseif (mapping .eq. 1) then
c             #  velocity components defined in terms of twisted torus
          endif
      endif

      end