MODULE MOD_AKIMA_2D

   !!-----------------------------------------------------------------
   !!         A Method Of Bivariate Interpolation And Smooth
   !!            Surface Fitting Based On Local Procedures
   !!
   !!                        Hiroshi AKIMA, 1974
   !!
   !!  author={Akima, H.},
   !!  title={A Method of Bivariate Interpolation and Smooth Surface Fitting
   !!         Based on Local Procedures},
   !!  journal={Commun. ACM},
   !!  year={1974},
   !!  pages={18-20},
   !!  volume={17},
   !!  number={1}
   !!
   !!
   !!   AUTHORS:
   !!            Coded from scratch by Laurent BRODEAU, 2007
   !!
   !!            Stylish and more efficient method to solve the 16x16 linear system:
   !!            Jean-Michel Brankart, October 2010
   !!
   !!            Last update: Laurent Brodeau, June 2014
   !!
   !!            Contact: brodeau@gmail.com
   !!
   !!-----------------------------------------------------------------

   USE mod_manip, ONLY: FILL_EXTRA_BANDS, TEST_XYZ

   IMPLICIT NONE

   LOGICAL, PUBLIC, SAVE :: &
      &    l_first_call_akima   = .TRUE. , &  !: wether it is the first time or not that AKIMA_2D is called
      &    l_always_first_call  = .FALSE.

   INTEGER, DIMENSION(:,:,:), ALLOCATABLE, SAVE :: ixy_pos !: table storing source/target grids mapping

   PRIVATE

   PUBLIC :: AKIMA_2D

   REAL(8), PARAMETER :: repsilon = 1.E-9

   INTEGER, PARAMETER  :: nsys = 16 !: Dimmension of the linear sytem to solve

CONTAINS

   SUBROUTINE AKIMA_2D(k_ew_per, X10, Y10, Z1, X20, Y20, Z2,    icall)

      !!================================================================
      !!
      !! INPUT :     k_ew_per : east-west periodicity
      !!                        k_ew_per = -1  --> no periodicity
      !!                        k_ew_per >= 0  --> periodicity with overlap of k_ew_per points
      !!             X10   : 2D source longitude array (ni*nj) or (ni*1) (must be regular!)
      !!             Y10   : 2D source latitude  array (ni*nj) or (nj*1) (must be regular!)
      !!             Z1    : input field on source grid
      !!
      !!             X20   : 2D target longitude array (ni*nj) or (ni*1) (can be irregular)
      !!             Y20   : 2D target latitude  array (ni*nj) or (nj*1) (can be irregular)
      !!
      !! OUTPUT :
      !!             Z2    : input field on target grid
      !!
      !! input (optional)  : icall : if icall=1, will always force 'l_first_call_akima' to .TRUE.
      !!
      !!==============================================================================================

      !! Input/Output arguments
      !! ======================

      INTEGER,  INTENT(in)                 :: k_ew_per
      REAL(8), DIMENSION(:,:), INTENT(in)  :: X10, Y10
      REAL(4), DIMENSION(:,:), INTENT(in)  :: Z1
      REAL(8), DIMENSION(:,:), INTENT(in)  :: X20, Y20
      REAL(4), DIMENSION(:,:), INTENT(out) :: Z2
      INTEGER,       OPTIONAL, INTENT(in)  :: icall

      !! Local variables
      !! ===============

      INTEGER :: nx1, ny1, nx2, ny2, ji, jj

      INTEGER, PARAMETER :: n_extd = 4    ! source grid extension

      LOGICAL :: l_x_found, l_y_found

      INTEGER :: &
         &     ji1, jj1, ji2, jj2,   &
         &     ni1, nj1

      REAL(8), DIMENSION(nsys) ::  vpl

      REAL(8), DIMENSION(:,:,:), ALLOCATABLE ::  poly

      REAL(8), DIMENSION(:,:), ALLOCATABLE ::    &
         &    X1, Y1, X2, Y2,   &
         &    Z_in , lon_in , lat_in

      REAL(8), DIMENSION(:,:), ALLOCATABLE :: slpx, slpy, slpxy

      REAL(8) :: &
         &  px2, py2,  &
         &  min_lon1, max_lon1, min_lat1, max_lat1,   &
         &  min_lon2, max_lon2, min_lat2, max_lat2

      CHARACTER(len=2) :: ctype

      IF ( present(icall) ) THEN
         IF ( icall == 1 ) THEN
            l_first_call_akima = .TRUE.
            l_always_first_call  = .TRUE.
         END IF
      END IF

      !! Create 2D (ni*nj) arrays out of 1d (ni*1 and nj*1) arrays if needed:
      !! => TEST_XYZ tests if a 2D array is a true 2D array (NxM) or a fake (Nx1)
      !!    and returns '1d' if it is a fake 2D array

      ctype = TEST_XYZ(X10, Y10, Z1)
      nx1 = SIZE(Z1,1)
      ny1 = SIZE(Z1,2)
      ALLOCATE ( X1(nx1,ny1) , Y1(nx1,ny1) )
      IF ( ctype == '1d' ) THEN
         FORALL (jj = 1:ny1) X1(:,jj) = X10(:,1)
         FORALL (ji = 1:nx1) Y1(ji,:) = Y10(:,1)
      ELSE
         X1 = X10 ; Y1 = Y10
      END IF

      ctype = '00'
      ctype = TEST_XYZ(X20, Y20, Z2)
      nx2 = SIZE(Z2,1)
      ny2 = SIZE(Z2,2)
      ALLOCATE ( X2(nx2,ny2) , Y2(nx2,ny2) )
      IF ( ctype == '1d' ) THEN
         FORALL (jj=1:ny2) X2(:,jj) = X20(:,1)
         FORALL (ji=1:nx2) Y2(ji,:) = Y20(:,1)
      ELSE
         X2 = X20 ; Y2 = Y20
      END IF

      IF ( l_first_call_akima ) ALLOCATE ( ixy_pos(nx2, ny2, 2) )

      !! Extending the source 2D domain with a frame of 2 points:
      !!    We extend initial 2D array with a frame, adding n_extd points in each
      !!    dimension This is really needed specially for preserving good east-west
      !!    perdiodicity...

      ni1 = nx1 + n_extd  ;   nj1 = ny1 + n_extd

      ALLOCATE ( Z_in(ni1,nj1), lon_in(ni1,nj1), lat_in(ni1,nj1), &
         &       slpx(ni1,nj1),   slpy(ni1,nj1),  slpxy(ni1,nj1), &
         &       poly(ni1-1,nj1-1,nsys)    )

      CALL FILL_EXTRA_BANDS(k_ew_per, X1, Y1, REAL(Z1,8), lon_in, lat_in, Z_in)

      DEALLOCATE (X1, Y1)

      !! Computation of partial derivatives:
      CALL slopes_akima(k_ew_per, lon_in, lat_in, Z_in, slpx, slpy, slpxy)

      !! Polynome:
      CALL build_pol(lon_in, lat_in, Z_in, slpx, slpy, slpxy, poly)

      DEALLOCATE ( slpx, slpy, slpxy )

      !! Checking if the target grid does not overlap source grid :
      min_lon1 = minval(lon_in) ;  max_lon1 = maxval(lon_in)
      min_lat1 = minval(lat_in) ;  max_lat1 = maxval(lat_in)
      min_lon2 = minval(X2)     ;  max_lon2 = maxval(X2)
      min_lat2 = minval(Y2)     ;  max_lat2 = maxval(Y2)

      DO jj2 = 1, ny2

         DO ji2 = 1, nx2

            !! The coordinates of current target point are (px2,py2) :
            px2 = X2(ji2,jj2) ;  py2 = Y2(ji2,jj2)

            !! Checking if this belongs to source domain :
            IF (   ( (px2 >= min_lon1).AND.(px2 <= max_lon1)).AND.  &
               & ( (py2 >= min_lat1).and.(py2 <= max_lat1))  )   THEN

               !! Laboriuously scanning the entire source grid to find
               !! location of treated point
               !! Let's find the 4 points of source grid that surrounds (px2,py2)
               !! Only if this is  the first time step (storing into ixy_pos) :
               IF ( l_first_call_akima ) THEN

                  ji1 = 1 ; jj1 = 1

                  l_x_found = .FALSE. ;  l_y_found = .FALSE.

                  DO WHILE ( .NOT. (l_x_found .AND. l_y_found) )

                     l_x_found = .FALSE.

                     DO WHILE ( .NOT. l_x_found )

                        IF (ji1 < ni1) THEN

                           IF ((lon_in(ji1,jj1) <= px2).and.(lon_in(ji1+1,jj1) > px2)) THEN
                              l_x_found = .TRUE.
                           ELSE
                              ji1 = ji1+1
                           END IF

                        ELSE   ! ji1 = ni1
                           ji1 = ji1-1  ! we are at the top need to use former pol.
                           l_x_found = .TRUE.
                        END IF

                     END DO

                     l_y_found = .FALSE.

                     DO WHILE ( .NOT. l_y_found )

                        IF ( jj1 < nj1 ) THEN

                           IF ((lat_in(ji1,jj1) <= py2).and.(lat_in(ji1,jj1+1) > py2)) THEN
                              l_y_found = .TRUE.
                           ELSE
                              jj1 = jj1 + 1
                              l_x_found = .FALSE.
                              l_y_found = .TRUE. ! just so that we exit the loop on l_y_found
                           END IF

                        ELSE   ! jj1 == nj1
                           jj1 = nj1-1        ! we are using polynome at (ji,nj1-1)
                           l_y_found = .TRUE. ! for extreme right boundary
                        END IF

                     END DO

                  END DO

                  ixy_pos(ji2,jj2,:) = (/ ji1, jj1 /)

               ELSE

                  !! We know the right location from time = 1 :
                  ji1 = ixy_pos(ji2,jj2,1)
                  jj1 = ixy_pos(ji2,jj2,2)

               END IF  !* IF ( l_first_call_akima )

               !! It's time to interpolate!
               !! =========================

               px2 = px2 - lon_in(ji1,jj1)
               py2 = py2 - lat_in(ji1,jj1)
               vpl = poly(ji1,jj1,:)

               Z2(ji2,jj2) = REAL( pol_val(px2, py2, vpl) , 4)  ! back to real(4)

            ELSE
               Z2(ji2,jj2) = 0.  ! point is not on source domain!
            END IF

         END DO
      END DO

      !! Deallocation :
      DEALLOCATE ( Z_in , lon_in , lat_in, poly, X2, Y2 )

      l_first_call_akima = .FALSE.

      IF ( l_always_first_call ) THEN
         DEALLOCATE ( ixy_pos )
         l_first_call_akima = .TRUE.
      END IF

   END SUBROUTINE AKIMA_2D

   !! ########################
   !! LOCAL PRIVATE ROUTINES :
   !! ########################

   SUBROUTINE build_pol(ZX, ZY, ZF, sx, sy, sxy, XPLNM)

      !!==================================================================
      !!
      !! Compute the 16 coefficients of the polynomes used to interpolate
      !!
      !!==================================================================

      REAL(8), DIMENSION(:,:),   INTENT(in)  :: ZX, ZY, ZF, sx, sy, sxy
      REAL(8), DIMENSION(:,:,:), INTENT(out) :: XPLNM

      !! Local variables :
      !! -----------------
      REAL(8), DIMENSION(:), ALLOCATABLE :: VX
      INTEGER                  :: nx, ny, ji, jj

      REAL(8) :: &
         &   x, x2, x3, y, y2, y3, xy, &
         &   b1, b2, b3, b4, b5, b6, b7, b8, &
         &   b9, b10, b11, b12, b13, b14, b15, b16, &

         &   c1, c2, c3, c4, c5, c6, c7, c8, &
         &   c9, c10, c11, c12, c13, c14, c15, c16, c17, c18, &
         &   d1, d2, d3, d4, d5, d6, d7, d8, d9, &
         &   f1, f2, f3, f4, f5, f6

      nx = SIZE(ZF,1)
      ny = SIZE(ZF,2)

      ALLOCATE( VX(nsys) )

      DO jj=1, ny-1
         DO ji=1, nx-1

            VX(:) = 0.

            !! Local dx and dy :
            x = ZX(ji+1,jj) - ZX(ji,jj)
            y = ZY(ji,jj+1) - ZY(ji,jj)

            x2 = x*x ; x3 = x2*x
            y2 = y*y ; y3 = y2*y
            xy = x*y

            !! Vector B, value at each points, d/dx, d/dy and d2/dxdy :
            b1  =  ZF(ji,jj) ; b2  =  ZF(ji+1,jj) ;  b3  =  ZF(ji+1,jj+1) ; b4  =  ZF(ji,jj+1)
            b5  =  sx(ji,jj) ; b6  =  sx(ji+1,jj) ;  b7  =  sx(ji+1,jj+1) ; b8  =  sx(ji,jj+1)
            b9  =  sy(ji,jj) ; b10 =  sy(ji+1,jj) ;  b11 =  sy(ji+1,jj+1) ; b12 =  sy(ji,jj+1)
            b13 = sxy(ji,jj) ; b14 = sxy(ji+1,jj) ;  b15 = sxy(ji+1,jj+1) ; b16 = sxy(ji,jj+1)

            ! Linear System 16x16 to be solved ( A.X = B )
            ! ============================================
            !
            !     (/ 0.    0.    0.   0.   0.    0.    0.   0.  0.   0.   0.  0. 0.  0. 0. 1. /)
            !     (/ 0.    0.    0.   x^3  0.    0.    0.   x^2 0.   0.   0.  x  0.  0. 0. 1. /)
            !     (/ x^3*y^3 x^3*y^2 x^3*y x^3  x^2*y^3 x^2*y^2 x^2*y x^2 x*y^3 x*y^2 x*y x  y^3  y^2 y 1. /)
            !     (/ 0.    0.    0.   0.  0.    0.    0.   0. 0.   0.   0.  0. y^3  y^2 y  1. /)
            !     (/ 0.      0.      0.     0.   0.     0.     0.    0.  0. 0. 0. 1. 0. 0. 0. 0. /)
            !     (/ 0.      0.      0.     3*x^2 0.     0.     0.    2*x 0. 0. 0. 1. 0. 0. 0. 0. /)
            !     (/ 3*x^2*y^3 3*x^2*y^2 3*x^2*y 3*x^2 2*x*y^3 2*x*y^2 2*x*y 2*x y^3 y^2 y  1. 0. 0. 0. 0. /)
            ! A = (/ 0.      0.      0.     0.   0.     0.     0.    0.  y^3 y^2 y  1. 0. 0. 0. 0. /)
            !     (/ 0.      0.     0.  0. 0.      0.     0. 0. 0.     0.    0. 0. 0.   0.  1. 0. /)
            !     (/ 0.      0.     x^3  0. 0.      0.     x^2 0. 0.     0.    x  0. 0.   0.  1. 0. /)
            !     (/ 3*x^3*y^2 2*x^3*y x^3  0. 3*x^2*y^2 2*x^2*y x^2 0. 3*x*y^2 2*x*y x  0. 3*y^2 2*y 1. 0. /)
            !     (/ 0.      0.     0.   0. 0.     0.    0. 0. 0.    0.  0. 0. 3*y^2 2*y 1. 0. /)
            !     (/ 0.      0.     0.   0. 0.     0.    0.  0. 0.   0.  1. 0. 0. 0. 0. 0. /)
            !     (/ 0.      0.   3*x^2  0. 0.     0.    2*x 0. 0.   0.  1. 0. 0. 0. 0. 0. /)
            !     (/ 9*x^2*y^2 6*x^2*y 3*x^2 0. 6*x*y^2 4*x*y 2*x 0. 3*y^2 2*y 1. 0. 0. 0. 0. 0. /)
            !     (/ 0.      0.     0.   0. 0.     0.    0.  0. 3*y^2 2*y 1. 0. 0. 0. 0. 0. /)
            !
            ! X = (/ a33, a32, a31, a30, a23, a22, a21, a20, a13, a12, a11, a10, a03, a02, a01, a00 /)
            !
            ! B = (/  b1,  b2,  b3,  b4,  b5,  b6,  b7,  b8,  b9, b10, b11, b12, b13, b14, b15, b16 /)

            !! I keep Jean-Michel's comments in french cause I just love them,
            !! they are the soul of this code! They are followed my my english
            !! translation. Note that Jean-Michel's english is excellent but he
            !! just thought this would stay between us.
            !! /laurent

            !! 1) D'abord, calculer les 4 inconnues (du système à 16 éqs) qui
            !! dépendent directement des second membres bj (avant de faire la
            !! modification des bj):

            !! 1) First, calculate the 4 unknowns (of the 16-eq. system) that
            !! directly depend on second members bj, and do this before modifying
            !! bj :

            VX(11) = b13 ; VX(12) = b5 ; VX(15) = b9 ; VX(16) = b1

            !! 2) Ensuite, mettre à échelle les seconds membres bj
            !! (b1 à b4 restent inchangés):

            !! 2) Then, scale bj second members (b1 to b4 remain unchanged):

            b5  = x*b5   ; b6  = x*b6   ; b7  = x*b7   ; b8  = x*b8
            b9  = y*b9   ; b10 = y*b10  ; b11 = y*b11  ; b12 = y*b12
            b13 = xy*b13 ; b14 = xy*b14 ; b15 = xy*b15 ; b16 = xy*b16

            !! 3) Puis, résoudre le système avec x=1 et y=1 (ou bien utiliser ta
            !! solution symbolique avec x=1 et y=1), en remarquant que, dans ce
            !! cas particulier, certaines combinaisons apparaissent souvent, et
            !! qu'il vaut mieux les calculer d'abord:

            !! 3) Then, solve the system with x=1 and y=1, taking advantage of the
            !! fact, that in that particular case, some combinations are often
            !! appearing and that it is therefore better to calculate them before:

            !! a) Premierement:
            c1  = b1-b2     ; c2  = b3-b4     ; c3  = b5+b6
            c4  = b7+b8     ; c5  = b9-b10    ; c6  = b11-b12
            c7  = b13+b14   ; c8  = b15+b16   ; c9  = 2*b5+b6
            c10 = b7+2*b8   ; c11 = 2*b13+b14 ; c12 = b15+2*b16
            c13 = b5-b8     ; c14 = b1-b4     ; c15 = b13+b16
            c16 =  2*b13 + b16 ; c17 = b9+b12    ; c18 = 2*b9+b12

            !! b) Deuxiemement:
            d1 = c1+c2   ; d2 = c3-c4   ; d3 = c5-c6
            d4 = c7+c8   ; d5 = c9-c10  ; d6 = 2*c5-c6
            d7 = 2*c7+c8 ; d8 = c11+c12 ; d9 = 2*c11+c12

            !! c) Troisiemement:
            f1 = 2*d1+d2 ; f2 = 2*d3+d4 ; f3 = 2*d6+d7
            f4 = 3*d1+d5 ; f5 = 3*d3+d8 ; f6 = 3*d6+d9

            !! d) De sorte que la solution s'écrit simplement:
            !! d) So that the solution simply writes:
            VX(1)  = 2*f1+f2      ; VX(2)  = -(3*f1+f3) ; VX(3)  = 2*c5+c7
            VX(4)  = 2*c1+c3      ; VX(5)  = -(2*f4+f5) ; VX(6)  = 3*f4+f6
            VX(7)  = -(3*c5+c11)  ; VX(8)  = -(3*c1+c9) ; VX(9)  = 2*c13+c15
            VX(10) = -(3*c13+c16) ; VX(13) = 2*c14+c17  ; VX(14) = -(3*c14+c18)

            !! On remarque même que les seules mulitplications qui apparaissent
            !! sont des doublements ou des triplements, qu'on pourrait donc
            !! remplacer par des additions, par ex.: cc14=c14+c14, puis ccc14=cc14+c14,
            !! et donc résoudre le systeme simplifié sans aucune multiplication
            !! ni division, ce qui est tout de même assez émouvant :-)

            !! One can even notice that the only multiplications that show up are
            !! multiplications by 2 or by 3. It would therefore be possible to
            !! replace them by additions, for example: cc14=c14+c14, then
            !! ccc14=cc14+c14, and therefore solve the simplified system without
            !! any multiplication and division, which I found rather touching :-)

            !! 4) Et finalement, il ne reste plus qu'à remettre à échelle la solution:

            !! 4) Finally, all that remains to be done is to scale back the solution:

            VX(1)=VX(1)/(x3*y3) ; VX(2)=VX(2)/(x3*y2) ; VX(3)=VX(3)/(x3*y) ; VX(4)=VX(4)/x3
            VX(5)=VX(5)/(x2*y3) ; VX(6)=VX(6)/(x2*y2) ; VX(7)=VX(7)/(x2*y) ; VX(8)=VX(8)/x2
            VX(9)=VX(9)/(x*y3)  ; VX(10)=VX(10)/(x*y2); VX(13)=VX(13)/y3   ; VX(14)=VX(14)/y2

            !! Bien sûr, je n'ai pas vérifié et j'ai pu faire des erreurs de calcul
            !! ou de recopiage, mais le principe me semble bon, et on aboutit
            !! à un nombre d'opérations:
            !! Etape 2: 9x
            !! Etape 3: 45+, 26x (ou même simplement 69+)
            !! Etape 4: 8x, 12/
            !! Soit un total de: 45+, 43x, 12/ pour résoudre le systeme,
            !! au lieu de: 84+, 140x, 16/ pour la solution symbolique de SOSIE.
            !!
            !! Je suis conscient que ça ne sert sans doute pas à grand chose
            !! car le calcul n'est fait que pour chaque point de la grille de départ
            !! (si je comprends bien) et ce coût n'était probablement déjà plus dominant.
            !! Il était déjà largement dépassé (j'imagine) par le coût d'évaluation
            !! des polynômes aux noeuds de la grille d'arrivée, du moins quand
            !! sa résolution est beaucoup plus fine que celle de la grille de départ.

            !! Number of operations:
            !! Point 2: 9x
            !! Point 3: 45+, 26x (or even possibly 69+)
            !! Point 4: 8x, 12/
            !! A total of 45+,  43x and 12/ to solve the system
            !! Instead of 84+, 140x and 16/ for the original symbolic solution

            !! Storing the 16 coefficients of the polynome for point [ji,jj] :
            XPLNM(ji,jj,:) = VX(:)

         END DO
      END DO

      DEALLOCATE( VX )

   END SUBROUTINE build_pol

   FUNCTION pol_val(x, y, V)

      !!======================================================
      !!
      !! Give value of polynome pol_val(x,y), polynome coefficients
      !! are stored in to vector V
      !!
      !! Optimizing by using Horner's scheme (http://en.wikipedia.org/wiki/Horner_scheme)
      !!
      !!  "It has been shown that the Horner scheme is optimal,
      !!  in the sense that any algorithm to evaluate an arbitrary polynomial
      !!  must use at least as many operations.
      !!  That the number of additions required is minimal was shown
      !!  by Alexander Ostrowski in 1954; that the number of multiplications
      !!  is minimal by Victor Pan."
      !!
      !! => we perform the minimum number of multiplications possible: 15 !
      !!
      !! Big thanks to Jean-Michel Brankart (Jean-Michel.Brankart@hmg.inpg.fr) for
      !! adapting this scheme to Sosie.
      !!
      !!=====================================================================

      REAL(8)                              :: pol_val
      REAL(8), INTENT(in)                  :: x, y
      REAL(8), DIMENSION(nsys), INTENT(in) :: V

      REAL(8) :: p1, p2, p3, p4

      p1      = ( ( V(1)  * y + V(2)  ) * y + V(3)  ) * y + V(4)
      p2      = ( ( V(5)  * y + V(6)  ) * y + V(7)  ) * y + V(8)
      p3      = ( ( V(9)  * y + V(10) ) * y + V(11) ) * y + V(12)
      p4      = ( ( V(13) * y + V(14) ) * y + V(15) ) * y + V(16)
      pol_val = ( ( p1    * x + p2    ) * x + p3    ) * x + p4

   END FUNCTION pol_val

   SUBROUTINE slopes_akima(k_ew, XX, XY, XF, dFdX, dFdY, d2FdXdY)

      !! Slopes ~ partial derivatives of a field ZF according to Akima method
      !! given on a regular gird !!

      !!  k_ew : east-west periodicity on the source file/grid
      !!         k_ew = -1  --> no east-west periodicity (along x)
      !!         k_ew >= 0  --> east-west periodicity with overlap of k_ew points (along x)
      !! lulu

      INTEGER, INTENT(in) :: k_ew

      REAL(8), DIMENSION(:,:), INTENT(in)  :: XX, XY, XF
      REAL(8), DIMENSION(:,:), INTENT(out) :: dFdX, dFdY, d2FdXdY

      !! Local variables :
      REAL(8), DIMENSION(:,:), ALLOCATABLE :: ZX, ZY, ZF
      INTEGER :: nx, ny, ji, jj, ip1, ip2, jp1, jp2
      REAL(8) :: m1, m2, m3, m4, rx
      REAL(8) :: Wx2, Wx3, Wy2, Wy3
      REAL(8) :: d22, e22, d23, e23, d42, e32, d43, e33

      dFdX    = 0.
      dFdY    = 0.
      d2FdXdY = 0.

      nx = SIZE(XF,1) ; ny = SIZE(XF,2)

      !! Extended arrays with a frame of 2 points...
      ALLOCATE ( ZX(nx+4,ny+4), ZY(nx+4,ny+4), ZF(nx+4,ny+4) )

      CALL FILL_EXTRA_BANDS(k_ew, XX, XY, XF, ZX, ZY, ZF)

      !! Treating middle of array ( at least 2 points away from the bordures ) :
      !!------------------------------------------------------------------------

      DO jj=1, ny
         DO ji=1, nx

            ! Initialisation MB Problem when they are close to zero but not zero
            m1=0; m2=0; m3=0; m4=0; Wx2=0.; Wx3=0.; Wy2=0.; Wy3=0.

            ip1 = ji+1
            ip2 = ji+2
            jp1 = jj+1
            jp2 = jj+2

            !!   SLOPE / X :
            !!   ***********

            rx = ZX(ip1,jp2) - ZX(ji,  jp2)
            m1 = SIGN(1.d0 , rx) * MAX(ABS(rx),repsilon)
            m1 = (ZF(ip1,jp2) - ZF(ji,  jp2)) / m1

            rx = ZX(ip2,jp2) - ZX(ip1,jp2)
            m2 = SIGN(1.d0 , rx) * MAX(ABS(rx),repsilon)
            m2 = (ZF(ip2,jp2) - ZF(ip1,jp2)) / m2

            rx = ZX(ji+3,jp2) - ZX(ip2,jp2)
            m3 = SIGN(1.d0 , rx) * MAX(ABS(rx),repsilon)
            m3 = (ZF(ji+3,jp2) - ZF(ip2,jp2)) / m3

            rx = ZX(ji+4,jp2) - ZX(ji+3,jp2)
            m4 = SIGN(1.d0 , rx) * MAX(ABS(rx),repsilon)
            m4 = (ZF(ji+4,jp2) - ZF(ji+3,jp2)) / m4

            IF ( (m1 == m2).and.(m3 == m4) ) THEN
               dFdX(ji,jj) = 0.5*(m2 + m3)
            ELSE
               Wx2 = ABS(m4 - m3)
               Wx3 = ABS(m2 - m1)
               dFdX(ji,jj) = ( Wx2*m2 + Wx3*m3 ) / ( Wx2 + Wx3 )
            END IF

            !!   SLOPE / Y :
            !!   ***********
            rx = ZY(ip2,jp1) - ZY(ip2,jj  )
            m1 = SIGN(1.d0 , rx) * MAX(ABS(rx),repsilon)
            m1 = (ZF(ip2,jp1) - ZF(ip2,jj  )) / m1

            rx = ZY(ip2,jp2) - ZY(ip2,jp1)
            m2 = SIGN(1.d0 , rx) * MAX(ABS(rx),repsilon)
            m2 = (ZF(ip2,jp2) - ZF(ip2,jp1)) / m2

            rx = ZY(ip2,jj+3) - ZY(ip2,jp2)
            m3 = SIGN(1.d0 , rx) * MAX(ABS(rx),repsilon)
            m3 = (ZF(ip2,jj+3) - ZF(ip2,jp2)) / m3

            rx = ZY(ip2,jj+4) - ZY(ip2,jj+3)
            m4 = SIGN(1.d0 , rx) * MAX(ABS(rx),repsilon)
            m4 = (ZF(ip2,jj+4) - ZF(ip2,jj+3)) / m4

            IF ( (m1 == m2).and.(m3 == m4) ) THEN
               dFdY(ji,jj) = 0.5*(m2 + m3)
            ELSE
               Wy2 =  ABS(m4 - m3)
               Wy3 =  ABS(m2 - m1)
               dFdY(ji,jj) =   ( Wy2*m2 + Wy3*m3 ) / ( Wy2 + Wy3 )
            END IF

            !!   CROSS DERIVATIVE /XY :
            !!   **********************
            !! d22 = d(i-1,j-1) = [ z(i-1,j)-z(i-1,j-1) ] / [ y(j) - y(j-1) ]
            rx  = ZY(ip1,jp2) - ZY(ip1,jp1)
            d22 = SIGN(1.d0 , rx) * MAX(ABS(rx),repsilon)
            d22 = (ZF(ip1,jp2) - ZF(ip1,jp1)) / d22

            !! d23 = d(i-1 , j) = [ z(i-1,j+1)-z(i-1,j) ] / [ y(j+1) - y(j) ]
            rx  = ZY(ip1,jj+3) - ZY(ip1,jp2)
            d23 = SIGN(1.d0 , rx) * MAX(ABS(rx),repsilon)
            d23 = (ZF(ip1,jj+3) - ZF(ip1,jp2)) / d23

            !! d42 = d(i+1 , j-1) = [ z(i+1 , j) - z(i+1 , j-1) ] / [ y(j) - y(j-1) ]
            rx  = ZY(ji+3,jp2) - ZY(ji+3,jp1)
            d42 = SIGN(1.d0 , rx) * MAX(ABS(rx),repsilon)
            d42 = (ZF(ji+3,jp2) - ZF(ji+3,jp1)) / d42

            !! d43 = d(i+1 , j) = [ z(i+1 , j+1)-z(i+1 , j) ] / [ y(j+1) - y(j) ]
            rx = ZY(ji+3,jj+3) - ZY(ji+3,jp2)
            d43 = SIGN(1.d0 , rx) * MAX(ABS(rx),repsilon)
            d43 = (ZF(ji+3,jj+3) - ZF(ji+3,jp2)) / d43

            !! e22  = [ m2 - d22 ] / [ x(i) - x(i-1) ]
            rx  = ZX(ip2,jp1) - ZX(ip1,jp1)
            e22 = SIGN(1.d0 , rx) * MAX(ABS(rx),repsilon)
            e22 = ( m2 - d22 ) / e22

            !! e23  = [ m3 - d23 ] / [ x(i) - x(i-1) ]
            rx  = ZX(ip2,jp2) - ZX(ip1,jp2)
            e23 = SIGN(1.d0 , rx) * MAX(ABS(rx),repsilon)
            e23 = ( m3 - d23 ) / e23

            !! e32  = [ d42 - m2 ] / [ x(i+1) - x(i) ]
            rx  = ZX(ji+3,jp2) - ZX(ip2,jp2)
            e32 = SIGN(1.d0 , rx) * MAX(ABS(rx),repsilon)
            e32 = ( d42 - m2 ) / e32

            !! e33  = [ d43 - m3 ] / [ x(i+1) - x(i) ]
            rx  = ZX(ji+3,jp2) - ZX(ip2,jp2)
            e33 = SIGN(1.d0 , rx) * MAX(ABS(rx),repsilon)
            e33 = ( d43 - m3 ) / e33

            IF ( ((Wx2 == 0).and.(Wx3 == 0)).or.((Wy2 == 0).and.(Wy3 == 0)) ) THEN
               IF ( (Wx2 == 0).and.(Wx3 == 0) ) THEN
                  Wx2 = 1.  ; Wx3 = 1.
               END IF

               IF ( (Wy2 == 0).and.(Wy3 == 0) ) THEN
                  Wy2 = 1.  ; Wy3 = 1.
               END IF

            END IF

            d2FdXdY(ji,jj) = ( Wx2*(Wy2*e22 + Wy3*e23) + Wx3*(Wy2*e32 + Wy3*e33) )  &
               &           / ( (Wx2 + Wx3) * (Wy2 + Wy3) )

         END DO
      END DO

      DEALLOCATE ( ZX, ZY, ZF )

   END SUBROUTINE slopes_akima

END MODULE MOD_AKIMA_2D


program problem47
  use euler
  implicit none
  integer, parameter             :: window=4,maxprime=1000000
  integer*8                      :: i,j,k,distinct,nprimes
  integer*8, dimension(maxprime) :: primes

  nprimes=1
  do i=2,maxprime
     if (is_prime(i)) then
        primes(nprimes)=i
        nprimes=nprimes+1
     end if
  end do

  do i=1,huge(i) ! start of window of numbers
     do j=i,i+window-1 ! for each number in the window
        distinct=0
        do k=1,nprimes
           if (primes(k) > j) exit
           if (mod(j,primes(k)) == 0) distinct=distinct+1
           if (distinct > window) go to 1
        end do
        if (distinct < window) go to 1
     end do
     exit ! made it through all of the checks, answer found
1 end do

  print *, i

end program problem47


subroutine matrixc()

    use constants_module
    use arrays_module
    use matrix_module
    use var_module

    implicit none

    ! Local variables
    integer :: i
    real(kind=4) :: e(2, 2), st(2,2), a(2,2), f_mat(2, 2), g(2, 2), d(2)
    real(kind=4) :: cour, crmax, crmin, di, dim1, dip1, dkda, ei, ei1, eia, ter

    do i=1,ncomp
        u(i)=qp(i)/areap(i)
        c(i)=sqrt(grav*areap(i)/bo(i))

        e(1,1)=1.0
        if(abs(u(i) - c(i)) < TOLERANCE) then
            c(i)=c(i)+0.00001
        end if
        e(1,2)=-1.0/(u(i)-c(i))
        e(2,1)=1.0
        e(2,2)=-1.0/(u(i)+c(i))

        f_mat(1,1)=-(u(i)-c(i))/(2.0*c(i))
        f_mat(1,2)=(u(i)+c(i))/(2.0*c(i))
        f_mat(2,1)=-(u(i)*u(i)-c(i)*c(i))/(2.0*c(i))
        f_mat(2,2)=(u(i)*u(i)-c(i)*c(i))/(2.0*c(i))

        d(1)=abs(u(i)+c(i))
        d(2)=abs(u(i)-c(i))

        a(1,1)=e(1,1)*f_mat(1,1)*d(1)+e(2,1)*f_mat(1,2)*d(2)
        a(1,2)=e(1,2)*f_mat(1,1)*d(1)+e(2,2)*f_mat(1,2)*d(2)
        a(2,1)=e(1,1)*f_mat(2,1)*d(1)+e(2,1)*f_mat(2,2)*d(2)
        a(2,2)=e(1,2)*f_mat(2,1)*d(1)+e(2,2)*f_mat(2,2)*d(2)

        if(ots == 1) then
           dt(i)=cfl*dx(i)/max(d(1),d(2))
        else
           dt(i)=dtini
        endif

        ! Calculating dK/dA (eq 15)
        !ter=bo(i)+2.0*areap(i)/bo(i)
        !Nazmul
        ter=pere(i)
        !Nazmul: dkda is corrected according to October 1, 2019 meeting at NWC
        dkda=sk(i)*((5.0/3.0*areap(i)**(2.0/3.0)*ter)     &
                   -(2.0/3.0*areap(i)**(5.0/3.0)*dpda(i)))/(ter**(5.0/3.0))

        ! Matrix S (eq 14)
        st(1, 1)=0.0
        st(1, 2)=0.0 !CHANGE
        !st(1, 2)=1.0
        st(2, 1)=grav*areap(i)/bo(i)/bo(i)*dbdx(i)+gso(i)      &
                +f*2.0*grav*areap(i)*qp(i)*abs(qp(i))/co(i)**3.0*dkda
        !Nazmul: st(2,2) term is multiplied with a gravity
        st(2,2)=-2*f*qp(i)*grav*areap(i)/co(i)/co(i)

        ! cour == sigma
        if(i == 1) then
            cour=dt(i)
        else if(dx(i-1) < TOLERANCE) then
            cour=dt(i)
        else
            cour=dt(i)/dx(i-1)
        endif
        b11(i)=0.5-phi-theta*cour*a(1,1)+0.5*thes*st(1,1)*dt(i)
        b12(i)=-theta*cour*a(1,2)+0.5*thes*st(1,2)*dt(i)
        b21(i)=-theta*cour*a(2,1)+0.5*thes*st(2,1)*dt(i)
        b22(i)=0.5-phi-theta*cour*a(2,2)+0.5*thes*st(2,2)*dt(i)

        if(dx(i) < TOLERANCE) then
            cour=dt(i)
        else
            cour=dt(i)/dx(i)
            crmax=max(crmax,cour*max(d(1),d(2)))
            crmin=min(crmin,cour*max(d(1),d(2)))
        endif

        !Nazmul: *dt(i) is multiplied to all g matrix terms
        g(1,1)=0.5+phi+theta*cour*a(1,1)+0.5*thes*st(1,1)*dt(i)
        g(1,2)=theta*cour*a(1,2)+0.5*thes*st(1,2)*dt(i)
        g(2,1)=theta*cour*a(2,1)+0.5*thes*st(2,1)*dt(i)
        g(2,2)=0.5+phi+theta*cour*a(2,2)+0.5*thes*st(2,2)*dt(i)

        g11inv(i)= g(2,2)/(g(1,1)*g(2,2)-g(1,2)*g(2,1))
        g12inv(i)=-g(1,2)/(g(1,1)*g(2,2)-g(1,2)*g(2,1))
        g21inv(i)=-g(2,1)/(g(1,1)*g(2,2)-g(1,2)*g(2,1))
        g22inv(i)= g(1,1)/(g(1,1)*g(2,2)-g(1,2)*g(2,1))

        f1(i)=qp(i)
        f2(i)=qp(i)*qp(i)/areap(i)+grav*ci1(i)

        if(i >= 2 .and. i < ncomp) then
            dip1=areap(i+1)/bo(i+1)
            di=2*areap(i)/bo(i)
            dim1=areap(i-1)/bo(i-1)
            eps2(i)=alfa2*abs(dip1-di+dim1)/(dip1+di+dim1)
        endif
    end do
    eps2(1)=eps2(2)
    eps2(ncomp)=eps2(ncomp-1)

    do i=2,ncomp-1
        if(ityp(i).ne.1) then
            eps2(i)=eps2(i-1)
            eps2(i+1)=eps2(i+2)
        endif
    end do

    do i=ncomp-1,1,-1
        eps2(i+1)=max(eps2(i+1),eps2(i))
        ! u(i+1)=(u(i+1)+u(i))/2.0
        ! c(i+1)=(c(i+1)+c(i))/2.0
        eps4(i+1)=max(0.,alfa4-eps2(i+1)/(u(i+1)+c(i+1)))
        ! print *, 'corr',i,eps2(i)
    end do
    d1(1)=0.0
    d2(1)=0.0
    d1(ncomp)=0.0
    d2(ncomp)=0.0

    do i=2,ncomp-1
        d(1)=abs(u(i)+c(i))
        d(2)=abs(u(i)-c(i))
        ei=max(d(1),d(2))
        d(1)=abs(u(i-1)+c(i-1))
        d(2)=abs(u(i-1)-c(i-1))
        ei1=max(d(1),d(2))
        eia=(ei+ei1)/2.0
        if(ityp(i-1) /= 1) then
            d1(i)=0.0
            d2(i)=0.0
        elseif(i == 2 .or. i == (ncomp-1)) then
            d1(i)=eps2(i)*eia*(areap(i)-areap(i-1))
            d2(i)=eps2(i)*eia*(qp(i)-qp(i-1))
        else
          d1(i)=eps2(i)*eia*(areap(i)-areap(i-1))-eps4(i)*(areap(i+1)  &
                            -3*areap(i)+3*areap(i-1)-areap(i-2))
          d2(i)=eps2(i)*eia*(qp(i)-qp(i-1))-eps4(i)*(qp(i+1)-3*qp(i)   &
                            +3*qp(i-1)-qp(i-2))
        endif
        ! print *, 'corr',i,d1(i),d2(i),eps2(i),area(i+1),area(i)
    end do
    !print*, 'eps2_corr', (eps2(i), i=1, ncomp)

end subroutine matrixc


module poisson
  !====================================================================
  ! Main module for superconveregence analysis of Poisson equation
  ! Pedro Peixoto Oct 2018
  ! partially based on multigrid solver of
  ! Marline I. Silva - Sept 2014
  !=====================================================================

  !Global constants
  use constants, only: &
    datadir, &
    deg2rad, &
    eps, &
    erad, &
    i4, &
    pardir, &
    pi, &
    r8, &
    rad2deg

  !Data structures
  use datastruct, only:  &
    grid_structure, &
    scalar_field, &
    vector, &
    vector_field_cart

  !Spherical mesh routines
  use smeshpack, only: &
    alignind, &
    alignindlimit, &
    arcdistll, &
    arcintersec, &
    arclen, &
    cart2sph, &
    choleskydecomp, &
    choleskysolve, &
    convert_vec_sph2cart, &
    convijll, &
    convllij, &
    distortionhx, &
    error_norm_2, &
    error_norm_max, &
    gcircarcintersec, &
    getnearnode, &
    getnearnodes, &
    gettr, &
    getunit, &
    hxtr_intersec_areas, &
    modint, &
    norm, &
    ortogonalarc, &
    proj_vec_sphere, &
    sph2cart, &
    sphpolarea, &
    sqtriintersec, &
    vorbarycenter

  !Interpolation pack
  use interpack, only: &
    plot_scalarfield, &
    plot_cart_vectorfield, &
    plot_grad_vectorfield, &
    plot_scalarfield_sphgrid, &
    plot_vectorfield_sphgrid

  implicit none

  !Function for test
  integer (i4):: testfunc
  integer (i4):: testcase

  !Logical for other tests
  logical:: discretcentroid !Discretizations to centroids
  logical:: testgrad !Test gradient
  logical:: plots !Perform plots

  !Name for interpolation files
  character (len=128):: simulname
  character (len=128):: testcasename

  !SOR solver parameters
  real (r8):: w         !Relaxation parameter
  real (r8)::nrm_res    !Norm residue
  real (r8)::TOL        !Tolerance
  integer (i4):: numit  !max num of iterations

  !Helmholtz parameter
  logical :: ihelm=.true.

contains

  subroutine getsimulpars()
    !---------------------------------------------------
    ! GETSIMULPARS
    !    Reads simulation parameters from file named "poisson.par"
    !    Saves parameters on global variables
    !
    ! Pedro Peixoto Oct 2018
    !--------------------------------------------------

    !Mesh
    type(grid_structure) :: mesh

    !Buffer for strings
    character (len=300):: buffer

    !Flag for plots
    integer:: iplots

    !Flag for discretization to cell centroids
    integer:: idiscretcentroid

    !Parameters file
    character (len=256):: filename

    !Unit for input file
    integer (i4):: fileunit
    !integer :: error

    !Couters
    integer(i4)::i
    integer(i4)::j
    character (len=16):: atmp

    !Standard definition of the interpolation tests
    testfunc=1      !Non-div case 1
    plots=.true.   !Do plots or not

    w=1                   !Relaxation parameter
    tol=0.00000001        !Tolerance
    nrm_res=100           !Norm residue
    numit=20              !Maximum number of iterations

    !Standard interpolation parameters file
    filename=trim(pardir)//"poisson.par"

    print*,"Simulation parameters (file): ", trim(filename)
    print*
    call getunit(fileunit)

    !A parameters file already must exist
    open(fileunit,file=filename,status='old')

    read(fileunit,*)  buffer
    read(fileunit,*)  buffer
    read(fileunit,*)  testcase
    read(fileunit,*)  buffer
    read(fileunit,*)  testfunc
    read(fileunit,*)  buffer
    read(fileunit,*)  idiscretcentroid
    read(fileunit,*)  buffer
    read(fileunit,*)  iplots
    read(fileunit,*)  buffer
    read(fileunit,*)  w, numit, tol

    close(fileunit)

    !Set ploting parameter
    if(iplots==1)then
      plots=.true.
    else
      plots=.false.
    end if

    !Set discretization position (centroid?)
    if(idiscretcentroid==1)then
      discretcentroid=.true.
    else
      discretcentroid=.false.
    end if

    simulname="poisson"

    !Names depending on test cases
    select case(testcase)
      case(1) !Truncation errors
        simulname=trim(adjustl(trim(simulname)))//"_laptrunc"
        testcasename="laptrunc"
      case(2) !Poisson error
        simulname=trim(adjustl(trim(simulname)))//"_poiser"
        testcasename="poiser"
      case default
        simulname="_"
    end select

    !Test function (vector or scalar field)
    write(atmp,'(i8)') int(testfunc)
    simulname=trim(adjustl(trim(simulname)))//"_f"//trim(adjustl(trim(atmp)))

    print*, "Test case             : ", testcase, testcasename
    print*, "Function used         : ", testfunc
    print*, "Plots? (nplots)       : ", plots
    if(trim(testcasename)=="poiser")then
      print*, "Solver parameters (w,n,tol)   :", w, numit, tol
    end if

    print*

    print*, "Simulation Name for Plots: ", trim(simulname)
    print*

    return
  end subroutine getsimulpars

  subroutine poisson_main(mesh)
    !---------------------------------------------------
    ! poisson_main
    !    Main routine for test cases related to poisson superconv. analysis
    !
    ! Pedro Peixoto Oct 2018
    !--------------------------------------------------
    !Mesh
    type(grid_structure) :: mesh

    call getsimulpars()

    !Names depending on test cases
    select case(testcase)
      case(1) !Truncation errors
        call laplacian_truncation(mesh)
      case(2) !Poisson errors
        call poisson_error(mesh)
      case default
        print*, "ERROR on poisson_main: Don't know this testcase:", testcase
        stop
    end select

  end subroutine poisson_main

  !======================================================================
  !    LAPLACIAN TESTS
  !======================================================================
  subroutine laplacian_truncation(mesh)

    !Mesh
    type(grid_structure) :: mesh

    !Scalar fields
    type(scalar_field):: u !function to test
    type(scalar_field):: lap_ex !exact laplacian
    type(scalar_field):: lap, lapu !approximate laplacian
    type(scalar_field):: error !error
    type(scalar_field):: ergrad !error in gradient
    type(scalar_field):: eddif !distance between edge midpoints

    !Counters
    integer:: i
    integer:: j
    integer:: k

    !Errors
    logical:: ifile
    integer:: iunit
    real (r8)::  error2
    real (r8):: errormax
    real (r8):: errorgrad2
    real (r8):: errorgradsup
    real (r8):: maxeddif
    character (len=256):: filename

    !Aux
    real(r8):: p(1:3)
    real(r8):: gradex
    real(r8):: gradest

    print*
    print*,"Laplacian Truncation Analysis "
    print*

    !Scalars on hexagon centers (nodes) - Exact
    lap_ex%pos=0
    lap_ex%n=mesh%nv
    lap_ex%name="lap_ex"
    allocate(lap_ex%f(1:lap_ex%n))
    do i=1, mesh%nv
      !Laplacian on node
      p=mesh%v(i)%p
      !lap_ex%f(i)=lap_exact(p)

      !Laplacian on barycenter
      !p=mesh%hx(i)%b%p
      lap_ex%f(i)=lap_exact(p)
       !print "(i8, 4f16.8)", i, lap_ex%f(i), p
    end do

    !Edge displacement
    eddif%n=mesh%nv
    eddif%name="edgedif"
    eddif%pos=0
    allocate(eddif%f(1:mesh%nv))
    do i=1, mesh%nv
      eddif%f(i)=0._r8
      do j=1,mesh%v(i)%nnb
        k=mesh%v(i)%ed(j)
        eddif%f(i)=max(eddif%f(i), (arclen(mesh%ed(k)%c%p, mesh%edhx(k)%c%p)/ &
          mesh%edhx(k)%leng))
      end do
       !eddif%f(i)=eddif%f(i)/mesh%v(i)%nnb
    end do

    !Edge intersection maximum difference
    maxeddif=maxval(abs(eddif%f(1:eddif%n)))

    !Gradient error
    ergrad%n=mesh%nv
    ergrad%name="ergrad"
    ergrad%pos=0
    allocate(ergrad%f(1:mesh%nv))
    do i=1, mesh%nv
      ergrad%f(i)=0._r8
    end do

    !Laplacian error
    error%n=mesh%nv
    error%name="erlap"
    error%pos=0
    allocate(error%f(1:mesh%nv))

    !Test function - Scalars on hexagon centers (nodes)
    u%pos=0
    u%n=mesh%nv
    u%name="func"
    allocate(u%f(1:u%n))
    do i=1, mesh%nv
      !Function on node
      p=mesh%v(i)%p
      u%f(i)=f(p)
    end do

    !Calculate Numerical Laplacian
    lap%pos=0
    lap%n=mesh%nv
    lap%name="lap_est"
    allocate(lap%f(1:lap%n))
    do i=1, mesh%nv
      lap%f(i)=0._r8
      ergrad%f(i)=0._r8
      do j=1, mesh%v(i)%nnb
        !Edge index
        k=mesh%v(i)%ed(j)
        !Hexagonal edge midpoint
        p=mesh%edhx(k)%c%p
        !ExactGrad=ExactGradVector*NormalVectorEdge*CorrectionOutHx
        gradex=dot_product(df(p),mesh%edhx(k)%nr)*mesh%hx(i)%nr(j)
        !Estimated Gradient Normal component
        gradest=(u%f(mesh%v(i)%nb(j))-u%f(i))/mesh%ed(k)%leng
        !arclen(p, mesh%v(i)%p) + &
        !arclen(p, mesh%v(mesh%v(i)%nb(j))%p)

        !Maximum gradient error for cell
        ergrad%f(i)=max(abs(gradest-gradex), ergrad%f(i))
        !Updade Laplacian
        lap%f(i)=lap%f(i)+gradest*mesh%edhx(k)%leng
      end do
      lap%f(i)=lap%f(i)/mesh%hx(i)%areag
      !Error in laplacian
      error%f(i)=lap_ex%f(i)-lap%f(i)
       !print"(i4, 3f16.8)", i, lap%f(i), lap_ex%f(i), error%f(i)
    end do

    !Sanity check
    !call lap_u(mesh, u, lapu)
    !print*, "Sanity check:", sum(lapu%f-lap%f)

    !Global Errors
    error2=error_norm_2(lap%f, lap_ex%f, error%n)
    errormax=error_norm_max(lap%f, lap_ex%f, error%n)
    print*, "Error Lap (max, L2): ", errormax, error2

    !Global Errors for gradients
    errorgrad2=dsqrt(dot_product(ergrad%f,ergrad%f)/ergrad%n)
    errorgradsup=maxval(abs(ergrad%f(1:ergrad%n)))
    print*, "Error GRAD (max, L2): ", errorgradsup, errorgrad2
    print*

    ! Save error estimates
    !-------------------------------------------------------

    !For hexagonal methods
    filename=trim(datadir)//"lap_errors_"//trim(mesh%kind)// &
      "_"//trim(mesh%pos)//"_"//trim(mesh%optm)//".txt"
    call getunit(iunit)

    inquire(file=filename, exist=ifile)
    if(ifile)then
      open(iunit,file=filename, status='old', position='append')
    else
      open(iunit,file=filename, status='replace')
      write(iunit, '(a)') &
        " n    distance testfunc errormax error2 errorgradsup errorgrad2 maxeddif"
    end if

    write(iunit, '(i8, f18.8, i8, 5f22.12)') mesh%nv, mesh%meanvdist*rad2deg, &
      testfunc, errormax, error2, errorgradsup, errorgrad2, maxeddif

    close(iunit)

    ! Plot fields
    !-------------------------
    if(plots) then
      print*, "Plotting variables ... "

      lap_ex%name=trim(simulname)//"_exact"
      call plot_scalarfield(lap_ex, mesh)

      lap%name=trim(simulname)//"_est"
      call plot_scalarfield(lap, mesh)

      error%name=trim(simulname)//"_error"
      call plot_scalarfield(error, mesh)

      eddif%name=trim(simulname)//"_eddif"
      call plot_scalarfield(eddif, mesh)

      ergrad%name=trim(simulname)//"_ergrad"
      call plot_scalarfield(ergrad, mesh)

    end if

    return

  end subroutine laplacian_truncation

  !======================================================================
  !    POISSON TESTS
  !======================================================================

  !------------------------------------------------------------------------
  !  poisson_error
  !   solve equation -Lap(u)=g and calculate errors
  !
  !-----------------------------------------------------------------------
  subroutine poisson_error(mesh)

    !Mesh
    type(grid_structure) :: mesh

    !Scalar fields
    type(scalar_field):: g
    type(scalar_field):: u_exact
    type(scalar_field):: u
    type(scalar_field):: error
    type(scalar_field):: ergrad
    type(scalar_field):: eddif

    !Counters
    integer:: i
    integer:: j
    integer:: k

    !Errors
    logical:: ifile
    integer:: iunit
    real (r8)::  error2
    real (r8):: errormax
    real (r8):: errorgrad2
    real (r8):: errorgradsup
    real (r8):: maxeddif
    character (len=256):: filename

    !Aux
    real(r8):: p(1:3)
    real(r8):: gradex
    real(r8):: gradest

    print*
    print*,"Poisson Error Analysis "
    print*

    !Define variable for equation -Lap(u)=g
    !Scalars on hexagon centers (nodes) - Exact
    u_exact%pos=0
    u_exact%n=mesh%nv
    u_exact%name="u_exact"
    allocate(u_exact%f(1:u_exact%n))
    !Test function - Scalars on hexagon centers (nodes)
    ! Right hand side of equation - this is exact
    g%pos=0
    g%n=mesh%nv
    g%name="g"
    allocate(g%f(1:g%n))
    do i=1, mesh%nv
      !Laplacian on node
      p=mesh%v(i)%p
      !lap_ex%f(i)=lap_exact(p)

      !Laplacian on barycenter
      !p=mesh%hx(i)%b%p
      !This is the laqplacian of functions defined in routine f(p)
      ! The minus happens as we are solving -Lap(u)=g

      if(ihelm) then
        g%f(i)=-lap_exact(p)+f(p)
      else
        g%f(i)=-lap_exact(p)
      end if
      !Since lap_extact was built from manufactured solution, the exact solution must be f(p)
      u_exact%f(i)=f(p)
      !print "(i8, 4f16.8)", i, lap_ex%f(i), p
    end do

    !Calculate Numerical Laplacian
    u%pos=0
    u%n=mesh%nv
    u%name="u"
    allocate(u%f(1:u%n))

    !Solve poisson equation -Lap(u)=g
    call sor(mesh, g, u)

    !This solution does not necessarily has the correct average
    ! adjust to compare to analytic solution
    if (.not. ihelm) then
      u%f=u%f+sum(u_exact%f)/mesh%nv
    end if

    !Poisson solution error
    error%n=mesh%nv
    error%name="u_err"
    error%pos=0
    allocate(error%f(1:mesh%nv))

    !Calculate errors
    error%f=u%f-u_exact%f

    !Global Errors
    error2=error_norm_2(u%f, u_exact%f, error%n)
    errormax=error_norm_max(u%f, u_exact%f, error%n)
    print*, "Error Poisson (max, L2): ", errormax, error2

    ! Save error estimates
    !-------------------------------------------------------

    !For hexagonal methods
    filename=trim(datadir)//"poisson_errors_"//trim(mesh%kind)// &
      "_"//trim(mesh%pos)//"_"//trim(mesh%optm)//".txt"
    call getunit(iunit)

    inquire(file=filename, exist=ifile)
    if(ifile)then
      open(iunit,file=filename, status='old', position='append')
    else
      open(iunit,file=filename, status='replace')
      write(iunit, '(a)') &
        " n    distance  testfunc errormax error2"
    end if

    write(iunit, '(i8, f18.8, i8, 5f22.12)') mesh%nv, mesh%meanvdist*rad2deg, &
      testfunc, errormax, error2

    close(iunit)

    ! Plot fields
    !-------------------------
    if(plots) then
      print*, "Plotting variables ... "

      u_exact%name=trim(simulname)//"_exact"
      call plot_scalarfield(u_exact, mesh)

      u%name=trim(simulname)//"_est"
      call plot_scalarfield(u, mesh)

      error%name=trim(simulname)//"_error"
      call plot_scalarfield(error, mesh)

    end if

    return

  end subroutine poisson_error

  subroutine sor(mesh, g, u)
    !------------------------------------------------------------
    !SOR
    ! Relaxation Scheme - Weighted Gauss-Seidel (SOR)
    !
    !  return: "u" that approximates the solution of
    !         for equation -Lap(u)=g
    !------------------------------------------------------------
    type(grid_structure):: mesh  !Mesh
    type(scalar_field):: u     !Approximate value of the function on each grid point
    type(scalar_field):: g       !Independent term of equation
    type(scalar_field):: lapu       !Independent term of equation

    !Counters
    integer:: k
    integer:: i
    integer:: j

    real (r8):: ledhx     !Edge length
    real (r8):: lchx       !Distance between two neighboring centers
    real (r8):: lapoffdiag
    real (r8):: lapdiag
    real (r8):: res, res_old

    res_old=0.0
    u%f=0.0
    !For each iteration
    do k=1,numit

      !For each grid point
      do i=1,mesh%nv

        lapoffdiag=0_r8
        lapdiag=0_r8
        ledhx=0_r8
        lchx=0_r8

        !For each grid neighboring of i
        do j=1,mesh%v(i)%nnb

          !Edge length
          ledhx=mesh%edhx(mesh%v(i)%ed(j))%leng

          !Distance between two neighboring
          lchx=mesh%ed(mesh%v(i)%ed(j))%leng

          lapdiag=lapdiag+(ledhx/lchx)
          lapoffdiag=lapoffdiag+(ledhx/lchx)*(u%f(mesh%v(i)%nb(j)))
        enddo

        lapoffdiag=lapoffdiag!/mesh%hx(i)%areag
        lapdiag=lapdiag!/mesh%hx(i)%areag

        if(ihelm) then
          !Solution of  - lap u + u = f
          u%f(i)=(1-w)*u%f(i)+w*((lapoffdiag+mesh%hx(i)%areag*g%f(i))/(lapdiag+mesh%hx(i)%areag))
        else
          !Solution of  - lap u = f
          u%f(i)=(1-w)*u%f(i)+w*((lapoffdiag+mesh%hx(i)%areag*g%f(i))/(lapdiag))
        end if

        !para o problema -lap u+u =g
        !fap%f(i)=(1-w)*(fap%f(i))+w*((laptmp+g%f(i))/(laptmp1+1))

      enddo
      call lap_u(mesh, u, lapu)
      if(ihelm) then
        res=maxval(abs(g%f+lapu%f-u%f))
      else
        res=maxval(abs(g%f+lapu%f))
      end if
      if ( mod(k, int(mesh%nv/10)) == 0 ) print*, "iter:", k, "residue: ", res
      if ( res < tol .or. abs(res_old-res)<tol ) then
        print*, "Tolerance achieved"
        print*, "Iterations: ", k, " Residue: ", res
        exit
      end if
      res_old=res
    enddo
    print*, "Stopped due to max number of iterations"

    return
  end subroutine sor

  !-----------------------------------------------------------------------------------------
  !    FUNCTIONS FOR TESTS
  !-----------------------------------------------------------------------------------------

  function f(p)
    !-----------------------------------
    !  F - initial conditions for scalar fields
    !
    !   p is a point in cartesian coords
    !
    !  P. Peixoto - Feb2012
    !---------------------------------------------
    real (r8), intent(in) :: p(1:3)
    real (r8):: lon
    real (r8):: lat

    real (r8):: f

    !General parameters
    real (r8):: h1
    real (r8):: h2

    !Cosbell parameters
    real (r8):: b
    real (r8):: c
    real (r8):: r
    real (r8):: r1
    real (r8):: r2

    !Gaussian parameters
    real (r8), dimension(1:3) :: p1
    real (r8), dimension(1:3) :: p2
    real (r8):: b0

    !Center of bell, slot, hill
    real (r8):: lat1
    real (r8):: lon1
    real (r8):: lat2
    real (r8):: lon2

    !Wavelength of test function
    real (r8):: m
    real (r8):: n

    m=1
    n=1

    !convert to spherical coords
    call cart2sph ( p(1), p(2), p(3), lon, lat )

    if(testfunc>0 .and. testfunc <4)then
      !Deformational test functions
      lon1=-pi/(4._r8)
      lat1=0._r8
      lon2=pi/(4._r8)
      lat2=0._r8
    end if

    !scalar fields
    select case(testfunc)
      case(1) !Cosine bell
        b=0.1_r8
        c=1._r8 !0.9
        r=1._r8/2._r8
        r1= arcdistll(lon, lat, lon1, lat1)
        if(r1<r)then
          h1=(1._r8/2._r8)*(1._r8+dcos(pi*r1/r))
          f=b+c*h1
          return
        end if
        r2= arcdistll(lon, lat, lon2, lat2)
        if(r2<r)then
          h2=(1._r8/2._r8)*(1._r8+dcos(pi*r2/r))
          f=b+c*h2
          return
        end if
        f=b

      case(2) !Gaussian
        b0=5
        call sph2cart(lon1, lat1, p1(1), p1(2), p1(3))
        call sph2cart(lon2, lat2, p2(1), p2(2), p2(3))
        h1=dexp(-b0*norm(p-p1)**2)
        h2=dexp(-b0*norm(p-p2)**2)
        f=h1+h2

      case(3) !Non-smooth- Slotted cylinder
        b=0.1_r8
        c=1._r8 !0.9
        r=1._r8/2._r8
        f=b

        r1= arcdistll(lon, lat, lon1, lat1)
        if(r1<=r.and.abs(lon-lon1)>=r/(6._r8))then
          f=c
          return
        end if
        r2= arcdistll(lon, lat, lon2, lat2)
        if(r2<=r.and.abs(lon-lon2)>=r/(6._r8))then
          f=c
          return
        end if
        if(r1<=r.and.abs(lon-lon1) < r/(6._r8) .and. &
          (lat-lat1)<-(5._r8)*r/(12._r8))then
          f=c
          return
        end if
        if(r2<=r.and.abs(lon-lon2)<r/(6._r8).and. &
          (lat-lat2)>(5._r8)*r/(12._r8))then
          f=c
          return
        end if

      case(4) !Smooth Trigonometric
        f=((dcos(lat))**3)*((dsin(lon))**2)

      case(5) !Exponential
        f= (exp(p(1))+2*exp(p(2)+p(3)))/10

      case(6) !Linear in R3
        f=(1.0+2*p(1)+3*p(2)+4*p(3))/6.0

      case(7) !Constant 1
        f=1

      case(8) !Trigonom oscilation (beta of HR95)
        f=dcos(m * lon) * dcos(n * lat) ** 4
         !((dcos(lat))**4)*((dsin(lon))**7)

      case(9) !Du Gunzburg 2003
        f= exp(-5.0*(1.0-dsin(lat)))

      case default
        print*, "F error: unknown scalar field (testfunc)", testfunc
        stop
    end select

    return
  end function f

  function df(p)
    !-------------------------------------------
    !  Grad of function "f"
    ! used to test interpolations
    ! in cartesian coords
    ! Returns the gradient in cartesian coords
    !------------------------------------------
    real (r8):: df(1:3)
    real (r8):: p(1:3)
    real (r8):: vlat
    real (r8):: vlon
    real (r8):: lat
    real (r8):: lon

    !Wavelength of test function
    real (r8):: m
    real (r8):: n

    m=1
    n=1

    call cart2sph (p(1), p(2), p(3), lon, lat)
    df=0.

    select case(testfunc)
      case(1) !Cosine bell

      case(2) !Gaussian

      case(3) !Non-smooth- Slotted cylinder
        df=0
      case(4) !Smooth Trigonometric
        !f=((dcos(lat))**3)*((dsin(lon))**2)
        vlon=2*dsin(lon)*dcos(lon)*((dcos(lat))**2)
        vlat=-3*((dcos(lat))**2)*((dsin(lon))**2)*dsin(lat)
        call convert_vec_sph2cart(vlon, vlat, p, df)
      case(5) !Exponential
        !f= (exp(p(1))+2*exp(p(2)+p(3)))/10
        df(1)=exp(p(1))/10
        df(2)=exp(p(2)+p(3))/5
        df(3)=exp(p(2)+p(3))/5
      case(6) !Linear in R3
        !f=(1.0+2*p(1)+3*p(2)+4*p(3))/6.0
        df(1)=2./6.
        df(2)=3./6.
        df(3)=4./6.
      case(7) !Constant
        df=0
      case(8) !Oscilating trig (beta of HR95)
        vlon = -dsin(m*lon)*m*dcos(n*lat)**4 / dcos(lat)
        vlat = -4._r8*dcos(m*lon)*dcos(n*lat)**3 * dsin(n*lat)* n
        !vlon=7*(dsin(lon)**6)*dcos(lon)*((dcos(lat))**3)
        !vlat=-4*((dcos(lat))**3)*((dsin(lon))**7)*dsin(lat)
        call convert_vec_sph2cart(vlon, vlat, p, df)
      case(9)
        print*, "Warning: test not defined"
        vlon=0
        vlat=0
      case default
        print*, "DF error: unknown gradient for field (testfunc)", testfunc
        stop
    end select

    !Project vector to the sphere (if not already)
    df=proj_vec_sphere(df, p)

    return
  end function df

  function lap_exact(p)
    !-----------------------------------
    !  Laplacian of scalar field given in f()
    !
    !   p is a point in cartesian coords
    !---------------------------------------------
    real (r8), intent(in) :: p(1:3)
    real (r8):: lon
    real (r8):: lat

    real (r8):: lap_exact

    !Wavelength of test function
    real (r8):: m
    real (r8):: n

    !convert to spherical coords
    call cart2sph ( p(1), p(2), p(3), lon, lat )

    !Laplacian
    select case(testfunc)
      case(4) !Smooth Trigonometric
        lap_exact=dcos(lat) * (-5.0_r8 * dcos(lon) ** 2 + 7.0_r8 &
          - 12.0_r8 * dcos(lat)** 2 * dsin(lon) ** 2)
      case(7) !Constant 1
        lap_exact=0
      case (8) !Oscilat trig (beta of HR95)
        m=1
        n=1
        lap_exact = -dcos(m*lon)*dcos(n*lat)**2 * (m**2*dcos(n * lat) **2 &
          - 4._r8 * dsin(lat) * dcos(n*lat)*dsin(n*lat)*n*dcos(lat) &
          - 12._r8 * dcos(lat)** 2 * n** 2 + 16._r8*dcos(lat)**2 *dcos(n* lat)**2* n** 2) &
          / dcos(lat) ** 2
         !lap_exact= (dcos(lat)**2) * (dsin(lon) **5 )* &
         !    (33._r8 * dcos(lon) ** 2 + 9.0_r8 &
         !    - 20.0_r8 * dcos(lat)** 2 * dsin(lon) ** 2)
      case(9) !Du Gunz 2003
        lap_exact = f(p)*(25.0*dcos(lat)**2-10.0*dsin(lat))
      case default
        print*, "Laplacian (lap_exact) error: unknown scalar field (testfunc) :", testfunc
        stop
    end select

    return
  end function lap_exact

  function func(p)
    real (r8)::p(1:3)
    real(r8)::func
    real(r8)::lat
    real(r8)::lon
    real(r8)::m
    real(r8)::n

    m=1
    n=1

    !TESTE 1
    !func=(1+2*p(1)+3*p(2)+4*p(3))/6._r8

    !TESTE 2
    !func = (exp(p(1))+ 2*(exp(p(2)+p(3))))/10

    call cart2sph (p(1), p(2), p(3), lon, lat)
    !TESTE 3
    !func=((dcos(lat))**3)*((dsin(lon))**2)

    !TESTE 4
    func=dcos(m*lon)*dcos(n*lat)**4

    !TESTE 5
    !func=dsin(lat)

    !TESTE 6
    !func=dsin(3*lon)*((dcos(3*lat)))**4

    !TESTE 7
    !func=-(1/2)*((dcos(lat))**3)*dcos(3*lon)

    !TESTE 8
    !func=dcos(lat)*dcos(lon)

    return
  end function func

  !----------------------------------------------------------------
  !     Exact Laplacian of the preceding functions
  !----------------------------------------------------------------

  function lap_ext(p)
    real (r8)::p(1:3)
    real (r8):: lat
    real (r8)::lon
    real (r8)::m
    real (r8)::n
    real(r8)::lap_ext

    m=1
    n=1

    !Converte para coordenadas esféricas
    call cart2sph (p(1), p(2), p(3), lon, lat)

    !TESTE 1
    !lap_ext= (((3*dsin(lon)+2*dcos(lon))*(1-dcos(lat)**2+dsin(lat)**2))/6._r8*dcos(lat)) &
    !- 4._r8*dsin(lat)/3._r8

    !TESTE 2
    !lap_ext=(1.0_r8/10.0_r8*dcos(lat))*(2.0_r8*exp(dcos(lat)*dsin(lon)+dsin(lat))*(dcos(lat) &
    !*((dcos(lon))**2)-dsin(lon))+exp(dcos(lat)*dcos(lon))*(dcos(lat)*((dsin(lon))**2) &
    !-dcos(lon))-2.0_r8*dsin(lat)*exp(dcos(lat)*dsin(lon)+dsin(lat))*(dcos(lat)-dsin(lon) &
    !*dsin(lat))+dcos(lon)*((dsin(lat))**2)*exp(dcos(lat)*dcos(lon))) +0.1*(exp(dcos(lat) &
    !*dcos(lon))*(((dcos(lon))**2)*((dsin(lat))**2)-dcos(lon)*dcos(lat))+2.0_r8*exp(dcos(lat) &
    !*dsin(lon)+dsin(lat))*((dcos(lat)-dsin(lon)*(dsin(lat)))**2)-(dsin(lon)*dcos(lat) &
    !+dsin(lat)))

    !TESTE 3 (-lap u + u=f)
    !lap_ext=-dcos(lat)*(-5.0_r8*dcos(lon)**2+7.0_r8-12.0_r8*dcos(lat)**2*dsin(lon)**2)  &
    !    +((dcos(lat))**3)*((dsin(lon))**2)

    !-------------------------------------------------------------
    !TESTE 4
    ! lap_ext = -dcos(m*lon)*dcos(n*lat)**2 * (m**2*dcos(n * lat) **2 &
    !    - 4._r8 * dsin(lat) * dcos(n*lat)*dsin(n*lat)*n*dcos(lat) &
    !  -12._r8 * dcos(lat)**2*n**2+16._r8*dcos(lat)**2 *dcos(n* lat)**2* n**2)&
    !/dcos(lat)**2

    !TESTE 4 (-lap u +u =f)
    lap_ext = -(-dcos(m*lon)*dcos(n*lat)**2 * (m**2*dcos(n * lat) **2 &
      - 4._r8 * dsin(lat) * dcos(n*lat)*dsin(n*lat)*n*dcos(lat) &
      -12._r8 * dcos(lat)**2*n**2+16._r8*dcos(lat)**2 *dcos(n* lat)**2* n**2)&
      /dcos(lat)**2)   +  dcos(m*lon)*dcos(n*lat)**4

    !------------------------------------------------------------
    !TESTE 5
    !lap_ext=-2*dsin(lat)

    !TESTE 5 (-lap u+u=f)
    !lap_ext=2*dsin(lat)+dsin(lat)
    !----------------------------------------------------

    !TESTE 6
    !lap_ext=(-9*dsin(3*lon)*((dcos(3*lat))**4)/dcos(lat)**2) &
    ! -6*dsin(3*lon)*(dcos(lat))**2*(1-2*dcos(2*lat))**2*(2*dcos(2*lat) &
    !-2*dcos(4*lat)+13*dcos(6*lat)-7)

    !TESTE 7
    !lap_ext=0!6*(dcos(lat)**3)*(dcos(3*lon))

    !TESTE 8
    !lap_ext=0.0

    return
  end function lap_ext

  subroutine relaxac(mesh)
    !--------------------------------------------------------
    !RELAXAC test
    !
    ! Test for relaxation of the problem using the
    !  method of Jacobi.
    ! For this test we use the subroutine "relaxac_mult_cell"
    !---------------------------------------------------------

    type(grid_structure)::mesh               !Mesh
    type(scalar_field)::fexact      !Exact value of the function on each grid point
    type(scalar_field)::fap         !Approximate value of the function on each grid point
    type(scalar_field)::fap_aux         !Approximate value of the function on each grid point
    type(scalar_field)::resid       !Residue
    type(scalar_field)::faperro     !Error between the exact value and the approximate value of the function
    type(scalar_field)::g           !Independent term of equation
    type(scalar_field)::lap_ap      !Approximate value of the laplacian on each grid point
    !type(interpolable_meshes)::fap_aux       !Auxiliary vector

    !Couter
    integer::i

    !Norm errors on each grid level
    real(r8)::nrm2
    real(r8)::nrmmax
    real(r8)::nrmres

    !A parameters file must exist
    character(len=60)::filename
    character (len=300):: buffer
    integer::fileunit
    integer::iunit

    !Approximate value of the function on each grid point
    allocate(fap%f(1:mesh%nv))
    allocate(fap_aux%f(1:mesh%nv))

    !Exact value of the function on each grid point
    allocate(fexact%f(1:mesh%nv))

    !Residue
    allocate(resid%f(1:mesh%nv))

    !Independent term of equation
    allocate(g%f(1:mesh%nv))

    !Approximate value of the laplacian on each grid point
    allocate(lap_ap%f(1:mesh%nv))

    !Error between the exact value and the approximate value of the function
    allocate(faperro%f(1:mesh%nv))

    !For each grid point
    do i=1,mesh%nv
      fap%f(i)=0!inic(mesh%v(i)%p)                        !initial condition
      !initial condition
      fexact%f(i)=func(mesh%v(i)%p)    !Exact value
      g%f(i)=lap_ext(mesh%v(i)%p)      !Independent term
    enddo

    !Calculate approximate value of the function on each grid point
    call relaxac_mult_cell_GS(mesh,g,fap,numit,w)

    !Calculation of the residue after each iteration
    call lap_cell(mesh,lap_ap,fap)
    resid%f=g%f-lap_ap%f

    !Norm residue
    nrm_res=error_nrm_max(resid%f,mesh%nv)

    !Norm errors on each grid level

    nrm2=error_norm_2(fexact%f,fap%f,mesh%nv)
    nrmmax=error_norm_max(fexact%f,fap%f,mesh%nv)
    nrmres=nrm_res

    !Deallocate
    deallocate(fap%f,fexact%f,faperro%f,g%f,resid%f,lap_ap%f)

    !Write values on file
    filename=trim(datadir)//"NRM_ERRO_RELAXAC.txt"
    call getunit ( iunit )
    open(iunit, file=filename, status='replace')
    write(iunit,*) "nrm2, nrmmax"

    write(iunit,"(3f32.16)") nrm2, nrmmax

    close (iunit)

    return
  end subroutine relaxac

  !==========================================================================
  ! Subroutines for relaxation, interpolation and transfer residue
  !==========================================================================

  subroutine lap_u(mesh, u, lapu)
    !------------------------------------------------------------
    !LAP_U
    !calculation of the Laplacian each point of mesh.
    !------------------------------------------------------------
    !mesh
    type(grid_structure), intent(in)::mesh
    !value function
    type(scalar_field), intent(in):: u
    !Approximate value of the laplacian on each grid point
    type(scalar_field), intent(out)::lapu

    !counter
    integer::i
    integer::j
    integer::k

    !number points of mesh
    integer::n

    real(r8):: p(1:3)
    real (r8):: ledhx    !Edge length
    real (r8):: lchx      !Distance between two neighboring
    real (r8):: laptmp
    real (r8):: gradest

    allocate(lapu%f(1:u%n))
    lapu=u

    !Calculate Numerical Laplacian
    do i=1, mesh%nv
      lapu%f(i)=0._r8
      do j=1, mesh%v(i)%nnb
        !Edge index
        k=mesh%v(i)%ed(j)
        !Hexagonal edge midpoint
        p=mesh%edhx(k)%c%p
        !Estimated Gradient Normal component
        gradest=(u%f(mesh%v(i)%nb(j))-u%f(i))/mesh%ed(k)%leng
        !Updade Laplacian
        lapu%f(i)=lapu%f(i)+gradest*mesh%edhx(k)%leng
      end do
      lapu%f(i)=lapu%f(i)/mesh%hx(i)%areag
    end do

    return
  end subroutine lap_u

  subroutine lap_cell(mesh,lapc,fap)
    !------------------------------------------------------------
    !LAP_CELL
    !calculation of the Laplacian each point of mesh.
    !------------------------------------------------------------

    type(grid_structure)::mesh            !mesh
    !value function
    type(scalar_field)::fap
    !Approximate value of the laplacian on each grid point
    type(scalar_field)::lapc

    !counter
    integer::i
    integer::j
    integer::k

    !number points of mesh
    integer::n

    real (r8):: ledhx    !Edge length
    real (r8)::Lchx      !Distance between two neighboring
    real (r8)::laptmp

    !number points of the mesh
    n=mesh%nv

    !For each grid point
    do  i=1,n

      laptmp=0_r8
      ledhx=0_r8
      Lchx=0_r8

      !For each grid neighboring of i
      do j=1, mesh%v(i)%nnb

        !Edge index
        k=mesh%v(i)%ed(j)

        !Edge length
        ledhx=mesh%edhx(k)%leng

        !Distance between two neighboring
        Lchx=mesh%ed(k)%leng

        laptmp=laptmp+(ledhx/Lchx)*(fap%f(mesh%v(i)%nb(j))-fap%f(i))

      enddo

      !para o problema -lap f+f =g
      lapc%f(i)=-(laptmp/mesh%hx(i)%areag)+fap%f(i)

       !para o problema lap f =g
       !lapc%f(i)=laptmp

    enddo
    return
  end subroutine lap_cell

  subroutine relaxac_mult_cell(mesh,g,fap,fap_aux,numit, w)
    !------------------------------------------------------------
    !RELAXAC_MULT_CELL
    ! Relaxation Scheme - Weighted Jacobi
    !------------------------------------------------------------
    type(grid_structure)::mesh             !Mesh
    type(scalar_field)::fap_aux     !Auxiliary vector
    !Approximate value of the function on each grid point
    type(scalar_field)::fap
    !Independent term of equation
    type(scalar_field)::g

    !parameter of relaxation
    real(r8)::w

    !Conter
    integer::k
    integer::i
    integer::j

    !Number of Iterations
    integer::numit

    !number of grid points
    integer::n

    real (r8):: ledhx     !Edge length
    real (r8)::Lchx       !Distance between two neighboring
    real (r8)::laptmp
    real (r8)::laptmp1

    !number points of the mesh
    n=mesh%nv

    !For each iteration
    do k=1,numit

      !For each grid point
      do i=1,n

        laptmp=0_r8
        laptmp1=0_r8
        ledhx=0_r8
        Lchx=0_r8

        !For each grid neighboring of i
        do j=1,mesh%v(i)%nnb

          !Edge length
          ledhx=mesh%edhx(mesh%v(i)%ed(j))%leng

          !Distance between two neighboring
          !arclen(mesh%v(mesh%v(i)%nb(j))%p,mesh%v(i)%p)
          Lchx=mesh%ed(mesh%v(i)%ed(j))%leng

          laptmp1=laptmp1+(ledhx/Lchx)
          laptmp=laptmp+(ledhx/Lchx)*(fap%f(mesh%v(i)%nb(j)))

        enddo

        laptmp=laptmp/mesh%hx(i)%areag
        laptmp1=laptmp1/mesh%hx(i)%areag

        !problem -lap f+f =g
        fap_aux%f(i)=(1-w)*(fap%f(i))+w*((laptmp+g%f(i))/(laptmp1+1))

         !problem lap f =g
         !fap_aux%f(i)=(1-w)*fap%f(i)+w*((laptmp-g%f(i))/(laptmp1))

      enddo

      fap%f=fap_aux%f

    enddo

    return
  end subroutine relaxac_mult_cell

  subroutine relaxac_mult_cell_GS(mesh,g,fap,numit, w)
    !------------------------------------------------------------
    !RELAXAC_MULT_CELL
    ! Relaxation Scheme - Weighted Gauss-Seidel
    !------------------------------------------------------------
    type(grid_structure)::mesh  !Mesh
    type(scalar_field)::fap     !Approximate value of the function on each grid point
    type(scalar_field)::g       !Independent term of equation

    !parameter of relaxation
    real(r8)::w

    !Conter
    integer::k
    integer::i
    integer::j

    !Number of Iterations
    integer::numit

    !number of grid points
    integer::n

    real (r8):: ledhx     !Edge length
    real (r8)::Lchx       !Distance between two neighboring
    real (r8)::laptmp
    real (r8)::laptmp1

    !number points of the mesh
    n=mesh%nv

    !For each iteration
    do k=1,numit

      !For each grid point
      do i=1,n

        laptmp=0_r8
        laptmp1=0_r8
        ledhx=0_r8
        Lchx=0_r8

        !For each grid neighboring of i
        do j=1,mesh%v(i)%nnb

          !Edge length
          ledhx=mesh%edhx(mesh%v(i)%ed(j))%leng

          !Distance between two neighboring
          Lchx=mesh%ed(mesh%v(i)%ed(j))%leng
          laptmp1=laptmp1+(ledhx/Lchx)
          laptmp=laptmp+(ledhx/Lchx)*(fap%f(mesh%v(i)%nb(j)))
        enddo

        laptmp=laptmp/mesh%hx(i)%areag
        laptmp1=laptmp1/mesh%hx(i)%areag

        !para o problema lap f =g
        !fap%f(i)=(1-w)*fap%f(i)+w*((laptmp-g%f(i))/(laptmp1))

        !para o problema -lap f+f =g
        fap%f(i)=(1-w)*(fap%f(i))+w*((laptmp+g%f(i))/(laptmp1+1))

      enddo

    enddo

    return
  end subroutine relaxac_mult_cell_GS

  function error_nrm_max(f, n)
    !-------------------------------------------
    !Calcula o maximo valor absoluto
    !  do vetor f de tamanho n
    !-------------------------------------------
    integer (i4):: n
    real (r8), dimension(1:n), intent(in) :: f
    real (r8):: error_nrm_max

    error_nrm_max=maxval(abs(f(1:n)))

    return
  end function error_nrm_max

  function error_norm_g(f,n)
    !-------------------------------------------
    !Calcula a raiz quadrada da soma
    !  dos elementos do vetor f
    !-------------------------------------------
    integer (i4):: n
    real (r8), dimension(1:n), intent(in) :: f
    real (r8):: error_norm_g
    real (r8):: sum_sq
    integer::i

    sum_sq=0.0

    do i=1,n
      sum_sq=sum_sq+(f(i)**2)
    enddo

    error_norm_g=dsqrt(sum_sq)

    return
  end function error_norm_g

end module poisson


c
c
c
c     =================================================
      function zeroin(ax,bx,f,tol)
c     =================================================
      implicit double precision (a-h,o-z)
      external f
c
c      a zero of the function  f(x)  is computed in the interval ax,bx .
c      (Standard routine from netlib)
c
c  input..
c
c  ax     left endpoint of initial interval
c  bx     right endpoint of initial interval
c  f      function subprogram which evaluates f(x) for any x in
c         the interval  ax,bx
c  tol    desired length of the interval of uncertainty of the
c         final result ( .ge. 0.d0)
c
c
c  output..
c
c  zeroin abcissa approximating a zero of  f  in the interval ax,bx
c
c
c      it is assumed  that   f(ax)   and   f(bx)   have  opposite  signs
c  without  a  check.  zeroin  returns a zero  x  in the given interval
c  ax,bx  to within a tolerance  4*macheps*dabs(x) + tol, where macheps
c  is the relative machine precision.
c
c      this function subprogram is a slightly  modified  translation  of
c  the algol 60 procedure  zero  given in  richard brent, algorithms for
c  minimization without derivatives, prentice - hall, inc. (1973).
c
c
c
c  compute eps, the relative machine precision
c
      eps = 1.d0
   10 eps = eps/2.d0
      tol1 = 1.d0 + eps
      if (tol1 .gt. 1.d0) go to 10
c
c initialization
c
      a = ax
      b = bx
      fa = f(a)
      fb = f(b)
c
c begin step
c
   20 c = a
      fc = fa
      d = b - a
      e = d
   30 if (dabs(fc) .ge. dabs(fb)) go to 40
      a = b
      b = c
      c = a
      fa = fb
      fb = fc
      fc = fa
c
c convergence test
c
   40 tol1 = 2.d0*eps*dabs(b) + 0.5*tol
      xm = .5*(c - b)
      if (dabs(xm) .le. tol1) go to 90
      if (fb .eq. 0.d0) go to 90
c
c is bisection necessary
c
      if (dabs(e) .lt. tol1) go to 70
      if (dabs(fa) .le. dabs(fb)) go to 70
c
c is quadratic interpolation possible
c
      if (a .ne. c) go to 50
c
c linear interpolation
c
      s = fb/fa
      p = 2.d0*xm*s
      q = 1.d0 - s
      go to 60
c
c inverse quadratic interpolation
c
   50 q = fa/fc
      r = fb/fc
      s = fb/fa
      p = s*(2.d0*xm*q*(q - r) - (b - a)*(r - 1.d0))
      q = (q - 1.d0)*(r - 1.d0)*(s - 1.d0)
c
c adjust signs
c
   60 if (p .gt. 0.d0) q = -q
      p = dabs(p)
c
c is interpolation acceptable
c
      if ((2.d0*p) .ge. (3.d0*xm*q - dabs(tol1*q))) go to 70
      if (p .ge. dabs(0.5*e*q)) go to 70
      e = d
      d = p/q
      go to 80
c
c bisection
c
   70 d = xm
      e = d
c
c complete step
c
   80 a = b
      fa = fb
      if (dabs(d) .gt. tol1) b = b + d
      if (dabs(d) .le. tol1) b = b + dsign(tol1, xm)
      fb = f(b)
      if ((fb*(fc/dabs(fc))) .gt. 0.d0) go to 20
      go to 30
c
c done
c
   90 zeroin = b
      return
      end


*###[ ffxli2:
	subroutine ffxli2(xdilog,xlog,x,ier)
***#[*comment:***********************************************************
*									*
*	Computes the dilogarithm (Li2, Sp) for (real) x	to precision	*
*	precx. It is assumed that -1<=x<=1/2.  As it is available anyway*
*	log(1-x) = -Li1(x) is also passed.				*
*									*
*	Input:	x	(real)						*
*									*
*	Output: xdilog	(real)    Li2(x)				*
*		xlog	(real)    log(1-x) = -Li1(x)			*
*		ier	(integer) 0=OK, 1=num prob, 2=error		*
*									*
*	Calls:	log,dfflo1						*
*									*
***#]*comment:***********************************************************
*  #[ declarations:
	implicit none
*
*	arguments
*
	integer ier
	DOUBLE PRECISION xdilog,xlog,x
*
*	local variables
*
	integer ipi12
	DOUBLE PRECISION dfflo1,u,u2,a,ffbnd,
     +		xprec,bdn02,bdn05,bdn10,bdn15,bdn20
	DOUBLE COMPLEX zxdilo,zlog
	save xprec,bdn02,bdn05,bdn10,bdn15,bdn20
!$omp threadprivate(xprec,bdn02,bdn05,bdn10,bdn15,bdn20)
*
*	common blocks
*
	include 'ff.h'
*  #] declarations:
*  #[ initialisations:
	data xprec /-1./
	if ( xprec .ne. precx ) then
	    xprec = precx
	    bdn02 = ffbnd(1,2,bf)
	    bdn05 = ffbnd(1,5,bf)
	    bdn10 = ffbnd(1,10,bf)
	    bdn15 = ffbnd(1,15,bf)
	    bdn20 = ffbnd(1,19,bf)
	endif
*  #] initialisations:
*  #[ if the argument is too large...
	if ( x .lt. -1.5 .or. x .gt. .75 ) then
	    if ( ltest ) call fferr(29,ier)
	    call ffzxdl(zxdilo,ipi12,zlog,x,0,ier)
	    if ( DIMAG(zxdilo) .ne. 0 ) then
	    	call fferr(52,ier)
	    endif
	    xdilog = DBLE(zxdilo) + ipi12*pi12
	    xlog = DBLE(zlog)
	    return
	endif
*  #] if the argument is too large...
*  #[ exceptional cases:
	if ( x .eq. -1 ) then
	    xdilog = -pi12
	    xlog = log(x2)
	    return
	elseif ( x .eq. x05 ) then
	    xdilog = - xlg2**2/2 + pi12
	    xlog = - xlg2
	    return
	elseif ( abs(x) .lt. precx ) then
	    xdilog = x
	    xlog = -x
	    return
	endif
*  #] exceptional cases:
*  #[ calculate dilog:
	if ( abs(x) .lt. xloss ) then
	    xlog = dfflo1(x,ier)
	else
	    xlog = log(1-x)
	endif
	u = -xlog
	u2 = u*u
	a = abs(u2)
	if ( lwarn .and. a .gt. bdn20 ) then
	    call ffwarn(60,ier,precx,bf(20)*a**20)
	endif
	if ( a .gt. bdn15 ) then
	    xdilog = u2*(bf(16) + u2*(bf(17) + u2*(bf(18) +
     +		    u2*(bf(19) + u2*(bf(20))))))
	else
	    xdilog = 0
	endif
	if ( a .gt. bdn10 ) then
	    xdilog = u2*(bf(11) + u2*(bf(12) + u2*(bf(13) +
     +		    u2*(bf(14) + u2*(bf(15) + xdilog)))))
	endif
	if ( a .gt. bdn05 ) then
	    xdilog = u2*(bf(6) + u2*(bf(7) + u2*(bf(8) +
     +		    u2*(bf(9) + u2*(bf(10) + xdilog)))))
	endif
	if ( a .gt. bdn02 ) then
	    xdilog = u2*(bf(3) + u2*(bf(4) + u2*(bf(5) + xdilog)))
	endif
*	watch the powers of u.
	xdilog = u + u2*(bf(1) + u*(bf(2) + xdilog))
*  #] calculate dilog:
*###] ffxli2:
	end
*###[ ffzxdl:
	subroutine ffzxdl(zxdilo,ipi12,zlog,x,ieps,ier)
***#[*comment:***************************************************
*	Computes the dilogarithm (Li2, Sp) for any (real) x	*
*	to precision precx. If an error message is given add	*
*	more bf's. For x > 1 the imaginary part is		*
*	 -/+i*pi*log(x), corresponding to x+ieps.		*
*	The number of factors pi^2/12 is passed separately in	*
*	ipi12 for accuracy.  We also calculate log(1-x)		*
*	which is likely to be needed.				*
*								*
*	Input:	x	(real)					*
*		ieps	(integer,+/-1)				*
*								*
*	Output: zxdilo	(complex) the dilog mod factors pi2/12	*
*		ipi12	(integer) these factors			*
*		zlog	(complex) log(1-x)			*
*								*
*	Calls:	log,dfflo1					*
*								*
***#]*comment:***************************************************
*  #[ declarations:
	implicit none
*
*	arguments
*
	integer ipi12,ieps,ier
	DOUBLE PRECISION x
	DOUBLE COMPLEX zxdilo,zlog
*
*	local variables
*
	integer jsgn
	DOUBLE PRECISION fact,u,u2,dfflo1,ffbnd,a,xdilo,
     +		xprec,bdn02,bdn05,bdn10,bdn15,bdn20
	DOUBLE COMPLEX cy,cfact
	save xprec,bdn02,bdn05,bdn10,bdn15,bdn20
!$omp threadprivate(xprec,bdn02,bdn05,bdn10,bdn15,bdn20)
*
*	common blocks
*
	include 'ff.h'
*  #] declarations:
*  #[ initialisations:
	data xprec /-1./
	if ( xprec .ne. precx ) then
	    xprec = precx
	    bdn02 = ffbnd(1,2,bf)
	    bdn05 = ffbnd(1,5,bf)
	    bdn10 = ffbnd(1,10,bf)
	    bdn15 = ffbnd(1,15,bf)
	    bdn20 = ffbnd(1,19,bf)
	endif
*  #] initialisations:
*  #[ exceptional cases:
	if ( x .eq. 1) then
	    zxdilo = 0
	    zlog = -99999
	    ipi12 = 2
	    return
	elseif (x .eq. -1) then
	    zxdilo = 0
	    zlog = xlg2
	    ipi12 = -1
	    return
	elseif (x .eq. x05) then
	    zxdilo = - xlg2**2/2
	    zlog = -xlg2
	    ipi12 = 1
	    return
	elseif ( abs(x) .lt. precx ) then
	    zxdilo = x
	    zlog = -x
	    ipi12 = 0
	    return
	endif
*  #] exceptional cases:
*  #[ transform to (-1,.5):
	if (x .lt. -1) then
	    fact = log(-x)
	    cy = - fact**2/2
	    ipi12 = -2
	    if ( -x*xloss .gt. 1 ) then
		u = -dfflo1(1/x,ier)
	    else
		u = -log(1-1/x)
	    endif
	    zlog = log(1-x)
	    jsgn = -1
	elseif ( x .lt. x05) then
	    cy = 0
	    ipi12 = 0
	    if ( abs(x) .lt. xloss ) then
		zlog = dfflo1(x,ier)
	    else
		zlog = log(1-x)
	    endif
	    u = -DBLE(zlog)
	    jsgn = 1
	elseif ( x .le. 2 ) then
	    u = -log(x)
	    if ( abs(1-x) .lt. xalogm ) then
		if ( lwarn ) call ffwarn(64,ier,1-x,xalogm)
		cy = 0
	    elseif ( x .lt. 1 ) then
		zlog = log(1-x)
		cy = DBLE(u)*zlog
	    elseif ( ieps .gt. 0 ) then
		zlog = DCMPLX(log(x-1),-pi)
		cy = DBLE(u)*zlog
	    else
		zlog = DCMPLX(log(x-1),+pi)
		cy = DBLE(u)*zlog
	    endif
	    ipi12 = 2
	    jsgn = -1
	else
	    if ( ieps .gt. 0 ) then
		cfact = DCMPLX(log(x),-pi)
		zlog = DCMPLX(log(x-1),-pi)
	    else
		cfact = DCMPLX(log(x),+pi)
		zlog = DCMPLX(log(x-1),+pi)
	    endif
	    cy = - cfact**2/2
	    ipi12 = -2
	    if ( x*xloss .gt. 1 ) then
		u = -dfflo1(1/x,ier)
	    else
		u = -log(1-1/x)
	    endif
	    jsgn = -1
	endif
*  #] transform to (-1,.5):
*  #[ calculate dilog:
	if ( abs(u) .lt. xalog2 ) then
	    xdilo = u
	else
	u2 = u**2
	a = abs(u2)
	if ( lwarn .and. a .gt. bdn20 ) then
	    call ffwarn(66,ier,precx,bf(20)*a**20)
	endif
	if ( a .gt. bdn15 ) then
	    xdilo = u2*(bf(16) + u2*(bf(17) + u2*(bf(18) +
     +		    u2*(bf(19) + u2*(bf(20))))))
	else
	    xdilo = 0
	endif
	if ( a .gt. bdn10 ) then
	    xdilo = u2*(bf(11) + u2*(bf(12) + u2*(bf(13) +
     +		    u2*(bf(14) + u2*(bf(15) + xdilo)))))
	endif
	if ( a .gt. bdn05 ) then
	    xdilo = u2*(bf(6) + u2*(bf(7) + u2*(bf(8) +
     +		    u2*(bf(9) + u2*(bf(10) + xdilo)))))
	endif
	if ( a .gt. bdn02 ) then
	    xdilo = u2*(bf(3) + u2*(bf(4) + u2*(bf(5) + xdilo)))
	endif
*	watch the powers of u.
	xdilo = u + u2*(bf(1) + u*(bf(2) + xdilo))
	endif
	if(jsgn.eq.1)then
	    zxdilo =  DBLE(xdilo) + cy
	else
	    zxdilo = -DBLE(xdilo) + cy
	endif
*  #] calculate dilog:
*###] ffzxdl:
	end
*###[ zxfflg:
	DOUBLE COMPLEX function zxfflg(x,ieps,y,ier)
***#[*comment:***********************************************************
*									*
*	Calculate the complex logarithm of x.  The following cases	*
*	are treted separately:						*
*		|x| too small:		give warning and return 0	*
*					(for Absoft, Apollo DN300)	*
*		|x| < 0:		take sign according to ieps	*
*									*
***#]*comment:***********************************************************
*  #[ declarations:
*
*	arguments
*
	implicit none
	integer ieps,ier
	DOUBLE PRECISION x,y
*
*	local variables
*
	DOUBLE PRECISION xlog
*
*	common blocks
*
	include 'ff.h'
*  #] declarations:
*  #[ check input:
	if ( lwarn .and. abs(x-1) .lt. xloss ) then
	    call ffwarn(129,ier,abs(x-1),x1)
	endif
*  #] check input:
*  #[ calculations:
	if ( abs(x) .lt. xalogm ) then
	    if ( lwarn .and. x .ne. 0 ) call ffwarn(53,ier,x,xalogm)
	    zxfflg = 0
	elseif ( x .gt. 0 ) then
	    zxfflg = log(x)
	else
	    xlog = log(-x)
*	    checked imaginary parts 19-May-1988
	    if ( abs(ieps) .eq. 1 ) then
		if ( y*ieps .lt. 0 ) then
		    zxfflg = DCMPLX(xlog,-pi)
		else
		    zxfflg = DCMPLX(xlog,pi)
		endif
	    elseif ( ieps .eq. 2 ) then
		zxfflg = DCMPLX(xlog,-pi)
	    elseif ( ieps .eq. -2 ) then
		zxfflg = DCMPLX(xlog,+pi)
	    else
		call fferr(52,ier)
		zxfflg = DCMPLX(xlog,pi)
	    endif
	endif
*  #] calculations:
*###] zxfflg:
	end
*###[ dfflo1:
	DOUBLE PRECISION function dfflo1(x,ier)
***#[*comment:***************************************************
*	calculates log(1-x) for |x|<.14 in a faster way to ~15	*
*	significant figures.					*
***#]*comment:***************************************************
*  #[ declarations:
	implicit none
	integer ier
	DOUBLE PRECISION x,bdn01,bdn05,bdn10,bdn15,bdn19,xprec,
     +		xa,d1,xheck,ffbnd
	DOUBLE COMPLEX zxfflg
	save xprec,bdn01,bdn05,bdn10,bdn15,bdn19
!$omp threadprivate(xprec,bdn01,bdn05,bdn10,bdn15,bdn19)
	include 'ff.h'
*  #] declarations:
*  #[ initialisation:
	data xprec /-1./
	if ( xprec .ne. precx ) then
	    xprec = precx
*	    determine the boundaries for 1,5,10,15 terms
	    bdn01 = ffbnd(1,1,xninv)
	    bdn05 = ffbnd(1,5,xninv)
	    bdn10 = ffbnd(1,10,xninv)
	    bdn15 = ffbnd(1,15,xninv)
	    bdn19 = ffbnd(1,19,xninv)
	endif
*  #] initialisation:
*  #[ calculations:
	xa = abs(x)
	if ( xa .gt. bdn19 ) then
	    if ( lwarn .and. xa .lt. xloss ) call ffwarn(62,ier,x,x1)
	    if ( lwarn .and. 1-x.lt. xloss ) call ffwarn(132,ier,1-x,x1)
	    dfflo1 = DBLE(zxfflg(1-x,0,x0,ier))
	    return
	endif
	if ( xa .gt. bdn15 ) then
	    dfflo1 = x*( xninv(16) + x*( xninv(17) + x*( xninv(18) +
     +		x*( xninv(19) + x*( xninv(20) )))))
	else
	    dfflo1 = 0
	endif
	if ( xa .gt. bdn10 ) then
	    dfflo1 = x*( xninv(11) + x*( xninv(12) + x*( xninv(13) +
     +		x*( xninv(14) + x*( xninv(15) + dfflo1 )))))
	endif
	if ( xa .gt. bdn05 ) then
	    dfflo1 = x*( xninv(6) + x*( xninv(7) + x*( xninv(8) +
     +		x*( xninv(9) + x*( xninv(10) + dfflo1 )))))
	endif
	if ( xa .gt. bdn01 ) then
	    dfflo1 = x*( xninv(2) + x*( xninv(3) + x*( xninv(4) +
     +		x*( xninv(5) + dfflo1 ))))
	endif
	dfflo1 = - x*( xninv(1) + dfflo1 )
*  #] calculations:
*  #[ check output:
	if ( ltest ) then
	    d1 = log(1-x)
	    xheck = d1-dfflo1
	    if ( xloss*abs(xheck) .gt. precx ) print *,'dfflo1: error:',
     +		' answer is not OK',d1,dfflo1,xheck
	endif
*  #] check output:
*###] dfflo1:
	end
*###[ dfflo2:
	DOUBLE PRECISION function dfflo2(x,ier)
***#[*comment:***************************************************
*	calculates log(1-x)+x for |x|<.14 in a faster way to	*
*	~15 significant figures.				*
***#]*comment:***************************************************
*  #[ declarations:
	implicit none
	integer ier,ier0
	DOUBLE PRECISION x,bdn01,bdn05,bdn10,bdn15,bdn18,xprec,
     +		xa,d1,xheck,ffbnd,dfflo1
	save xprec,bdn01,bdn05,bdn10,bdn15,bdn18
!$omp threadprivate(xprec,bdn01,bdn05,bdn10,bdn15,bdn18)
	include 'ff.h'
*  #] declarations:
*  #[ initialisation:
	data xprec /-1./
	if ( xprec .ne. precx ) then
	    xprec = precx
*	    determine the boundaries for 1,5,10,15 terms
	    bdn01 = ffbnd(1,1,xninv(2))
	    bdn05 = ffbnd(1,5,xninv(2))
	    bdn10 = ffbnd(1,10,xninv(2))
	    bdn15 = ffbnd(1,15,xninv(2))
	    bdn18 = ffbnd(1,18,xninv(2))
	endif
*  #] initialisation:
*  #[ calculations:
	xa = abs(x)
	if ( xa .gt. bdn18 ) then
	    dfflo2 = dfflo1(x,ier) + x
	    if ( lwarn .and. abs(dfflo2).lt.xloss*abs(x) ) then
	    	call ffwarn(231,ier,dfflo2,x)
	    	if ( lwrite ) print *,'dfflo2: not enough terms, x = ',x
	    endif
	    return
	endif
	if ( xa .gt. bdn15 ) then
	    dfflo2 = x*( xninv(17) + x*( xninv(18) + x*( xninv(19) +
     +		x*( xninv(20) ))))
	else
	    dfflo2 = 0
	endif
	if ( xa .gt. bdn10 ) then
	    dfflo2 = x*( xninv(12) + x*( xninv(13) + x*( xninv(14) +
     +		x*( xninv(15) + x*( xninv(16) + dfflo2 )))))
	endif
	if ( xa .gt. bdn05 ) then
	    dfflo2 = x*( xninv(7) + x*( xninv(8) + x*( xninv(9) +
     +		x*( xninv(10) + x*( xninv(11) + dfflo2 )))))
	endif
	if ( xa .gt. bdn01 ) then
	    dfflo2 = x*( xninv(3) + x*( xninv(4) + x*( xninv(5) +
     +		x*( xninv(6) + dfflo2 ))))
	endif
	dfflo2 = - x**2*( xninv(2) + dfflo2 )
*  #] calculations:
*  #[ check output:
	if ( ltest ) then
	    ier0 = ier
	    d1 = dfflo1(x,ier0) + x
	    xheck = d1-dfflo2
	    if ( xloss*abs(xheck) .gt. precx ) print *,'dfflo2: error:',
     +		' answer is not OK',d1,dfflo2,xheck
	endif
*  #] check output:
*###] dfflo2:
	end
*###[ dfflo3:
	DOUBLE PRECISION function dfflo3(x,ier)
***#[*comment:***************************************************
*	calculates log(1-x)+x+x^2/2 for |x|<.14 in a faster 	*
*	way to ~15 significant figures.				*
***#]*comment:***************************************************
*  #[ declarations:
	implicit none
	integer ier,ier0
	DOUBLE PRECISION x,bdn01,bdn05,bdn10,bdn15,xprec,
     +		xa,d1,xheck,ffbnd,dfflo2
	save xprec,bdn01,bdn05,bdn10,bdn15
!$omp threadprivate(xprec,bdn01,bdn05,bdn10,bdn15)
	include 'ff.h'
*  #] declarations:
*  #[ initialisation:
	data xprec /-1./
	if ( xprec .ne. precx ) then
	    xprec = precx
*	    determine the boundaries for 1,5,10,15 terms
	    bdn01 = ffbnd(1,1,xninv(3))
	    bdn05 = ffbnd(1,5,xninv(3))
	    bdn10 = ffbnd(1,10,xninv(3))
	    bdn15 = ffbnd(1,15,xninv(3))
	endif
*  #] initialisation:
*  #[ calculations:
	xa = abs(x)
	if ( xa .gt. bdn15 ) then
	    dfflo3 = dfflo2(x,ier) + x**2/2
	    if ( lwarn .and. abs(dfflo3).lt.xloss*x**2/2 ) then
	    	call ffwarn(232,ier,dfflo3,x**2/2)
	    	if ( lwrite ) print *,'dfflo3: not enough terms, x = ',x
	    endif
	    return
	endif
	if ( xa .gt. bdn10 ) then
	    dfflo3 = x*( xninv(13) + x*( xninv(14) + x*( xninv(15) +
     +		x*( xninv(16) + x*( xninv(17) )))))
	else
	    dfflo3 = 0
	endif
	if ( xa .gt. bdn05 ) then
	    dfflo3 = x*( xninv(8) + x*( xninv(9) + x*( xninv(10) +
     +		x*( xninv(11) + x*( xninv(12) + dfflo3 )))))
	endif
	if ( xa .gt. bdn01 ) then
	    dfflo3 = x*( xninv(4) + x*( xninv(5) + x*( xninv(6) +
     +		x*( xninv(7) + dfflo3 ))))
	endif
	dfflo3 = - x**3*( xninv(3) + dfflo3 )
*  #] calculations:
*  #[ check output:
	if ( ltest ) then
	    ier0 = ier
	    d1 = dfflo2(x,ier0) + x**2/2
	    xheck = d1-dfflo3
	    if ( xloss*abs(xheck) .gt. precx ) print *,'dfflo3: error:',
     +		' answer is not OK',d1,dfflo3,xheck
	endif
*  #] check output:
*###] dfflo3:
	end
*###[ ffxl22:
	subroutine ffxl22(xl22,x,ier)
***#[*comment:***************************************************
*	calculates Li2(2-x) for |x|<.14 in a faster way to ~15	*
*	significant figures.					*
***#]*comment:***************************************************
*  #[ declarations:
	implicit none
	integer ier,ier0,ipi12p,init
	DOUBLE COMPLEX zli2,zdum
	DOUBLE PRECISION xl22,x,bdn01,bdn05,bdn10,bdn15,bdn20,bdn25,
     +		xprec,xa,xheck,ffbnd,dilog2(29)
	save xprec,bdn01,bdn05,bdn10,bdn15,bdn20,bdn25,init,dilog2
!$omp threadprivate(xprec,bdn01,bdn05,bdn10,bdn15,bdn20,bdn25,
!$omp&  init,dilog2)
	include 'ff.h'
	data xprec /-1./
	data init /0/

	if ( init .eq. 0 ) then
	    init = 1
* taylor(dilog(x-1),x,30);
	    dilog2( 1) = 0.d0
	    dilog2( 2) = 1/4.d0
	    dilog2( 3) = 1/6.d0
	    dilog2( 4) = 5/48.d0
	    dilog2( 5) = 1/15.d0
	    dilog2( 6) = 2/45.d0
	    dilog2( 7) = 13/420.d0
	    dilog2( 8) = 151/6720.d0
	    dilog2( 9) = 16/945.d0
	    dilog2(10) = 83/6300.d0
	    dilog2(11) = 73/6930.d0
	    dilog2(12) = 1433/166320.d0
	    dilog2(13) = 647/90090.d0
	    dilog2(14) = 15341/2522520.d0
	    dilog2(15) = 28211/5405400.d0
	    dilog2(16) = 10447/2306304.d0
	    dilog2(17) = 608/153153.d0
	    dilog2(18) = 19345/5513508.d0
	    dilog2(19) = 18181/5819814.d0
	    dilog2(20) = 130349/46558512.d0
	    dilog2(21) = 771079/305540235.d0
	    dilog2(22) = 731957/320089770.d0
	    dilog2(23) = 2786599/1338557220.d0
	    dilog2(24) = 122289917/64250746560.d0
	    dilog2(25) = 14614772/8365982625.d0
	    dilog2(26) = 140001721/87006219300.d0
	    dilog2(27) = 134354573/90352612350.d0
	    dilog2(28) = 774885169/562194032400.d0
	    dilog2(29) = 745984697/582272390700.d0
	endif
*  #] declarations:
*  #[ initialisation:
	if ( xprec .ne. precx ) then
	    xprec = precx
*	    determine the boundaries for 1,5,10,15,20 terms
	    bdn01 = ffbnd(2,1,dilog2)
	    bdn05 = ffbnd(2,5,dilog2)
	    bdn10 = ffbnd(2,10,dilog2)
	    bdn15 = ffbnd(2,15,dilog2)
	    bdn20 = ffbnd(2,20,dilog2)
	    bdn25 = ffbnd(2,25,dilog2)
*	    print *,'bdn01 = ',bdn01
*	    print *,'bdn25 = ',bdn25
*	    print *,'dilog2 = ',dilog2
	endif
*  #] initialisation:
*  #[ calculations:
	xa = abs(x)
	if ( xa .gt. bdn25 ) then
	    call ffwarn(230,ier,precx,dilog2(27)*xa**25)
	endif
	if ( xa .gt. bdn20 ) then
	    xl22 = x*( dilog2(22) + x*( dilog2(23) + x*( dilog2(24) +
     +		x*( dilog2(25) + x*( dilog2(26) )))))
	else
	    xl22 = 0
	endif
	if ( xa .gt. bdn15 ) then
	    xl22 = x*( dilog2(17) + x*( dilog2(18) + x*( dilog2(19) +
     +		x*( dilog2(20) + x*( dilog2(21) )))))
	endif
	if ( xa .gt. bdn10 ) then
	    xl22 = x*( dilog2(12) + x*( dilog2(13) + x*( dilog2(14) +
     +		x*( dilog2(15) + x*( dilog2(16) )))))
	endif
	if ( xa .gt. bdn05 ) then
	    xl22 = x*( dilog2(7) + x*( dilog2(8) + x*( dilog2(9) +
     +		x*( dilog2(10) + x*( dilog2(11) + xl22 )))))
	endif
	if ( xa .gt. bdn01 ) then
	    xl22 = x*( dilog2(3) + x*( dilog2(4) + x*( dilog2(5) +
     +		x*( dilog2(6) + xl22 ))))
	endif
	xl22 = - x**2*( dilog2(2) + xl22 )
*  #] calculations:
*  #[ check output:
	if ( ltest ) then
	    ier0 = 0
	    ipi12p = 0
	    call ffzxdl(zli2,ipi12p,zdum,2-x,1,ier0)
	    xheck = DBLE(zli2)-xl22 + (ipi12p-3)*pi12
	    if ( xloss*abs(xheck) .gt. precc*2.5 ) then
		print *,'xl22: error: answer is not OK',
     +			DBLE(zli2)+ipi12p*pi12,xl22+3*pi12,xheck
	    endif
	endif
*  #] check output:
*###] ffxl22:
	end


!  *********************************************************************
!  *                                                                   *
!  *                        subroutine corn3d                          *
!  *                                                                   *
!  *********************************************************************
!  Mixed Precision Version 1.2
!  Written by Gordon A. Fenton, TUNS, Aug. 2, 1993
!  Latest Update: Feb. 22, 1994
!
!  PURPOSE  creates the parameter matrices required for the corner cell
!           subdivisions of LAS3G.
!
!  Requires:
!   1) from libGAFsim:	DSIFA, DSISL, DCHOL2, DAXPY, DSWAP, DDOT, IDAMAX
!-----------------------------------------------------------------------------
      subroutine corn3d(R,ir,B,ib,S,is,CC,AC,iout,tol)
      real CC(28,*), AC(8,7,*)
      real*8 R(ir,*), B(ib,*), S(is,*)
      real*8 RC(8,8), DA(8), BB(7,7)
      integer ic(8,8), indx(8)
      data ic/14,15,17,18,23,24,26,27,                                    &
              13,14,16,17,22,23,25,26,                                    &
              11,12,14,15,20,21,23,24,                                    &
              10,11,13,14,19,20,22,23,                                    &
               5, 6, 8, 9,14,15,17,18,                                    &
               4, 5, 7, 8,13,14,16,17,                                    &
               2, 3, 5, 6,11,12,14,15,                                    &
               1, 2, 4, 5,10,11,13,14/

   1  format(a,a,a)
   2  format(a,e13.4)
!							extract R
      do 10 j = 1, 8
         do 10 i = 1, j
            RC(i,j) = R(ic(i,8), ic(j,8))
  10  continue
!							factorize R
      call dsifa(RC,8,8,indx,ierr)
      if( ierr .ne. 0 ) then
         write(iout,1)'Error: unable to factorize corner covariance matrix in CORN3D.'
         stop
      endif
!							for each corner...
      do 70 nc = 1, 8
!							make a copy of S
         do 50 j = 1, 7
            do 20 i = 1, 8
               DA(i) = S(ic(i,nc),j)
  20        continue
!							and solve for A
            call dsisl(RC,8,8,indx,DA)
!							store in real*4
            do 30 i = 1, 8
               AC(i,j,nc) = DA(i)
  30        continue
!							update B
            do 40 i = 1, j
               BB(i,j) = B(i,j)                                           &
                       - S(ic(1,nc),i)*DA(1) - S(ic(2,nc),i)*DA(2)        &
                       - S(ic(3,nc),i)*DA(3) - S(ic(4,nc),i)*DA(4)        &
                       - S(ic(5,nc),i)*DA(5) - S(ic(6,nc),i)*DA(6)        &
                       - S(ic(7,nc),i)*DA(7) - S(ic(8,nc),i)*DA(8)
  40        continue
  50     continue
!							Cholesky Decomposition
         call dchol2( BB, 7, 7, rerr )
         if( rerr .gt. tol ) then
            write(iout,1)'Warning: Cholesky decomposition of corner covariance matrix BB'
            write(iout,2)'         has maximum relative error of ',rerr
         endif
!							store in real*4
         ii = 0
         do 60 j = 1, 7
         do 60 i = 1, j
            ii = ii + 1
            CC(ii,nc) = BB(i,j)
  60     continue
  70  continue

      return
      end


*DECK PPVAL
      FUNCTION PPVAL (LDC, C, XI, LXI, K, IDERIV, X, INPPV)
C***BEGIN PROLOGUE  PPVAL
C***PURPOSE  Calculate the value of the IDERIV-th derivative of the
C            B-spline from the PP-representation.
C***LIBRARY   SLATEC
C***CATEGORY  E3, K6
C***TYPE      SINGLE PRECISION (PPVAL-S, DPPVAL-D)
C***KEYWORDS  B-SPLINE, DATA FITTING, INTERPOLATION, SPLINES
C***AUTHOR  Amos, D. E., (SNLA)
C***DESCRIPTION
C
C     Written by Carl de Boor and modified by D. E. Amos
C
C     Abstract
C         PPVAL is the PPVALU function of the reference.
C
C         PPVAL calculates (at X) the value of the IDERIV-th
C         derivative of the B-spline from the PP-representation
C         (C,XI,LXI,K).  The Taylor expansion about XI(J) for X in
C         the interval XI(J) .LE. X .LT. XI(J+1) is evaluated, J=1,LXI.
C         Right limiting values at X=XI(J) are obtained.  PPVAL will
C         extrapolate beyond XI(1) and XI(LXI+1).
C
C         To obtain left limiting values (left derivatives) at XI(J),
C         replace LXI by J-1 and set X=XI(J),J=2,LXI+1.
C
C     Description of Arguments
C         Input
C          LDC     - leading dimension of C matrix, LDC .GE. K
C          C       - matrix of dimension at least (K,LXI) containing
C                    right derivatives at break points XI(*).
C          XI      - break point vector of length LXI+1
C          LXI     - number of polynomial pieces
C          K       - order of B-spline, K .GE. 1
C          IDERIV  - order of the derivative, 0 .LE. IDERIV .LE. K-1
C                    IDERIV=0 gives the B-spline value
C          X       - argument, XI(1) .LE. X .LE. XI(LXI+1)
C          INPPV   - an initialization parameter which must be set
C                    to 1 the first time PPVAL is called.
C
C         Output
C          INPPV   - INPPV contains information for efficient process-
C                    ing after the initial call and INPPV must not
C                    be changed by the user.  Distinct splines require
C                    distinct INPPV parameters.
C          PPVAL   - value of the IDERIV-th derivative at X
C
C     Error Conditions
C         Improper input is a fatal error
C
C***REFERENCES  Carl de Boor, Package for calculating with B-splines,
C                 SIAM Journal on Numerical Analysis 14, 3 (June 1977),
C                 pp. 441-472.
C***ROUTINES CALLED  INTRV, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   800901  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  PPVAL
C
      INTEGER I, IDERIV, INPPV, J, K, LDC, LXI, NDUMMY
      REAL C, DX, FLTK, X, XI
      DIMENSION XI(*), C(LDC,*)
C***FIRST EXECUTABLE STATEMENT  PPVAL
      PPVAL = 0.0E0
      IF(K.LT.1) GO TO 90
      IF(LDC.LT.K) GO TO 80
      IF(LXI.LT.1) GO TO 85
      IF(IDERIV.LT.0 .OR. IDERIV.GE.K) GO TO 95
      I = K - IDERIV
      FLTK = I
      CALL INTRV(XI, LXI, X, INPPV, I, NDUMMY)
      DX = X - XI(I)
      J = K
   10 PPVAL = (PPVAL/FLTK)*DX + C(J,I)
      J = J - 1
      FLTK = FLTK - 1.0E0
      IF (FLTK.GT.0.0E0) GO TO 10
      RETURN
C
C
   80 CONTINUE
      CALL XERMSG ('SLATEC', 'PPVAL', 'LDC DOES NOT SATISFY LDC.GE.K',
     +   2, 1)
      RETURN
   85 CONTINUE
      CALL XERMSG ('SLATEC', 'PPVAL', 'LXI DOES NOT SATISFY LXI.GE.1',
     +   2, 1)
      RETURN
   90 CONTINUE
      CALL XERMSG ('SLATEC', 'PPVAL', 'K DOES NOT SATISFY K.GE.1', 2,
     +   1)
      RETURN
   95 CONTINUE
      CALL XERMSG ('SLATEC', 'PPVAL',
     +   'IDERIV DOES NOT SATISFY 0.LE.IDERIV.LT.K', 2, 1)
      RETURN
      END