c=======================================================================
c
c     Fichier d'utilitaires
c
c     sous-programmes pour les operations sur les matrices d'entiers
c     vectorisees, version turbo utilisant BLAS et LAPACK pour les
c     routines precedees de #
c
c=======================================================================
c
c     regles de nomination des sous-programmes :
c
c     1ere lettre : type d'operation
c                   A : arrangements
c                   C : conversion
c                   D : difference
c                   E : extremums
c                   I : initalisation
c                   K : kombien ?
c                   M : moyenne
c                   N : norme
c                   O : operations multiples
c                   P : produit
c                   R : transpose
c                   S : somme
c                   T : trace
c                   W : who ?
c                   X : produit scalaire
c                   Y : copie
c                   Z : symetrisation
c     lettres suivantes : operandes
c                   BOR: bornes
c                   CM : colonne d'une matrice
c                   D  : vecteur associe a une matrice diagonale
c                   I  : index
c                   EQ : equal
c                   EV : elements d'un vecteur
c                   GE : greater or equal
c                   GT : greater
c                   LE : lower or equal
c                   LM : ligne d'une matrice
c                   LT : lower
c                   M  : matrice (n*m)
c                   MAX: maximum
c                   MC : matrice carree (n*n)
c                   MCP: matrice carree partielle (n*n)
c                   MCT: matrice carree transposee (n*n)
c                   MD : matrice diagonale (n*n)
c                   MDS: matrice diagonale symetrique (n*(n+1)/2)
c                   MI : matrice d'entiers (n*m)
c                   MIN: minimum
c                   MP : matrice partielle (n*m)
c                   MS : matrice symetrique (n*(n+1)/2)
c                   MT : matrice transposee (m*n)
c                   OC : ordre croissant
c                   OD : ordre decroissant
c                   R  : fonction inverse (du meme nom sans"R")
c                   V  : vecteur (n)
c                   VI : vecteur d'entiers (n)
c                   VT : vecteur transpose (n)
c                   X  : scalaire
c
c        AVIOCI  : sort a vector of integers in increase order
c                  with index in old vector
c        AVIODI  : sort a vector of integers in decrease order
c                  with index in old vector
c        CMSIMCI : converting a vector of symmetric matrix of integers
c                  in vector of full square matrix of integers
c        CVIMDI  : converting a vector of integers
c                  in vectorized full diagonal matrix of integers
c        EMIBOR  : computing the minimum and maximum
c                  of a matrix of integers
c        EMIMAX  : computing the maximum of a matrix of integers
c        EMIMIN  : computing the minimum of a matrix of integers
c        EVIBOR  : computing the minimum and maximum
c                  of a vector of integers
c        EVIMAX  : computing the maximum of a vector of integers
c        EVIMIN  : computing the minimum of a vector of integers
c        IMI     : initialization at an integer of a matrix of integers
c        IMDI    : initialization at an integer of a diagonal matrix
c                  of integers
c        IVI     : initialization at an integer of a vector
c        KEVIEQ  : Computing how many elements of a vector
c                  of integer = value
c        SEVI    :  Sum of the element of vector.
c        WVIEQ   : who is equal to n in a vector ?
c                  gives a vector of indexes
c        WVIGE   : who is greater or equal than n in a vector ?
c                  gives a vector of indexes
c        WVIGT   : who is greater than n in a vector ?
c                  gives a vector of indexes
c        WVILE   : who is lower or equal than n in a vector ?
c                  gives a vector of indexes
c        WVILT   : who is lower than n in a vector ?
c                  gives a vector of indexes
c        YVI     : copy a vector of integers in a vector of integers
c        YVIP    : copy a part of a vector of integers
c                  in a vector of integers
c        YVXI  :   Initialization of a vector at an integer.
c
c=======================================================================
c
c     subroutine AVIOCI
c
c     Sorts a vector of integers in increase order and returns indices
c
c-----------------------------------------------------------------------
      SUBROUTINE AVIOCI ( nvect, vecin, vecout, ind )
c-----------------------------------------------------------------------
c
c     INPUT
c       nvect  : vector size                                     integer
c       vecin  : input vector (nvect)                            integer
c
c     OUTPUT
c       vecout : sorted vector (nvect)                           integer
c       ind    : indices (nvect)                                 integer
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
      INTEGER nvect, ind(*), vecin(*), vecout(*)
      INTEGER i, j, indic, nout, a
c
c-----------------------------------------------------------------------
c
      ind(1) = 1
      vecout(1) = vecin(1)
      IF (nvect .GT. 1) THEN
         nout = 2
         indic = 1
         DO i=2,nvect
            a = vecin(i)
c
c           recherche du rang
            indic = 1
            DO WHILE ( (indic.lt.nout) .and. (a.gt.vecout(indic)) )
               indic = indic + 1
            ENDDO
c
c           decalage
            DO j=nout,indic+1,-1
               vecout(j) = vecout(j-1)
               ind(j) = ind(j-1)
            ENDDO
            vecout(indic) = a
            ind(indic) = i
            nout = nout + 1
         ENDDO
      ENDIF
      RETURN
      END
c
c=======================================================================
c
c     subroutine AVIODI
c
c     Sorts a vector of integers (decrease order) and returns the
c     indices in old vector
c
c=======================================================================
c
c     INPUT
c            nvect  : size of the vector                         integer
c            vecin  : vector to sort (nvect)                     integer
c
c     OUTPUT
c            vecout : sorted vector (nvect)                      integer
c            index  : indices of vector elements                 integer
c                     in the old vector (nvect)
c
c-----------------------------------------------------------------------
c
      subroutine AVIODI ( nvect, vecin, vecout, index )
c
      implicit none
c
      integer nvect
      integer index(*)
      integer vecin(*), vecout(*)
c
      integer i, j, indic, nout, a
c
c-----------------------------------------------------------------------
c
      index(1) = 1
      vecout(1) = vecin(1)
      if (nvect.gt.1) then
         nout = 2
         indic = 1
         do i=2,nvect
            a = vecin(i)
c
c           recherche du rang
            indic = 1
            do while ( (indic.lt.nout) .and. (a.lt.vecout(indic)) )
               indic = indic + 1
            end do
c
c           decalage
            do j=nout,indic+1,-1
               vecout(j) = vecout(j-1)
               index(j) = index(j-1)
            end do
            vecout(indic) = a
            index(indic) = i
            nout = nout + 1
         end do
      endif
      return
      end
c
c=======================================================================
c
c     subroutine CMSIMCI
c
c     Converting a vector of symmetric matrix of integers
c     in vector of full square matrix of integers
c
c=======================================================================
c
c     INPUT
c            nmat   : size of square matrix mat                  integer
c            vects  : symmetric matrix as vect.(nmat*(nmat+1)/2) integer
c
c     OUTPUT
c            vect   : matrix as vector(nmat*nmat)                integer
c
c-----------------------------------------------------------------------
c
      subroutine CMSIMCI ( nmat, vects, vect)
c
      implicit none
c
      integer nmat, vects(*), vect(nmat,*)
c
      integer i, j, k
c
c-----------------------------------------------------------------------
c
      k = 0
      DO j=1,nmat
         DO i=1,j
            k = k + 1
            vect(i,j) = vects(k)
            IF (i .NE. j) vect(j,i) = vects(k)
         ENDDO
      ENDDO
      RETURN
      END
c
c=======================================================================
c
c     subroutine CVIMDI
c
c     Converting a vector of integers
c     in vectorized full diagonal matrix of integers
c
c=======================================================================
c
c     INPUT
c            nmat   : size of matrix dmat and vector vect        integer
c            vect   : vector(nmat)                               integer
c
c     OUTPUT
c            dmat   : diagonal matrix as vector(nmat*nmat)       integer
c
c-----------------------------------------------------------------------
c
      subroutine CVIMDI ( nmat, vect, dmat)
c
      implicit none
c
      integer nmat
      integer dmat(nmat,*), vect(*)
c
      integer i,j
c
c-----------------------------------------------------------------------
c
      do j=1,nmat
         do i=1,nmat
            dmat(i,j) = 0
         end do
         dmat(j,j) = vect(j)
      end do
      return
      end
c
c=======================================================================
c
c     subroutine EMIBOR
c
c     Computing the minimum and maximum of a vect. matrix of integers
c
c=======================================================================
c
c     INPUT :
c            nrow   : number of rows of the matrix               integer
c            mcol   : number of columns of the matrix            integer
c            mat    : matrix(nrow*mcol)                          integer
c
c     OUTPUT :
c            mmin   : minimum of the matrix                      integer
c            mmax   : maximum of the matrix                      integer
c
c-----------------------------------------------------------------------
c
      subroutine EMIBOR ( nrow, mcol, mat, mmin, mmax )
c
      implicit none
c
      integer nrow, mcol, mmin, mmax, mat(*)
c
      integer mcour, i
c
c-----------------------------------------------------------------------
c
      mmin = mat(1)
      mmax = mat(1)
      do i=2,nrow*mcol
         mcour = mat(i)
         if (mcour.lt.mmin) mmin = mcour
         if (mcour.gt.mmax) mmax = mcour
      end do
      return
      end
c
c=======================================================================
c
c     subroutine EMIMAX
c
c     Computing the maximum of a vectorized matrix of integers
c
c=======================================================================
c
c     INPUT
c            nrow   : number of rows of the matrix               integer
c            mcol   : number of columns of the matrix            integer
c            mat    : matrix(nrow*mcol)                          integer
c
c     OUTPUT
c            mmax   : maximum of the matrix                      integer
c
c-----------------------------------------------------------------------
c
      subroutine EMIMAX ( nrow, mcol, mat, mmax )
c
      implicit none
c
      integer nrow, mcol, mmax
      integer mat(*)
c
      integer i, mcour
c
c-----------------------------------------------------------------------
c
      mmax = mat(1)
      do i=2,nrow*mcol
         mcour = mat(i)
         if (mcour.gt.mmax) mmax = mcour
      end do
      return
      end
c
c=======================================================================
c
c     subroutine EMIMIN
c
c     Computing the minimum of a vectorized matrix of integers
c
c=======================================================================
c
c     INPUT
c            nrow   : number of rows of the matrix               integer
c            mcol   : number of columns of the matrix            integer
c            mat    : matrix(nrow*mcol)                          integer
c
c     OUTPUT
c            mmin   : minimum of the matrix                      integer
c
c-----------------------------------------------------------------------
c
      subroutine EMIMIN ( nrow, mcol, mat, mmin )
c
      implicit none
c
      integer nrow, mcol, mmin
      integer mat(*)
c
      integer i, mcour
c
c-----------------------------------------------------------------------
c
      mmin = mat(1)
      do i=2,nrow*mcol
         mcour = mat(i)
         if (mcour.lt.mmin) mmin = mcour
      end do
      return
      end
c
c=======================================================================
c
c     subroutine EVIBOR
c
c     Computing the minimum and maximum of a vector of integers
c
c=======================================================================
c
c     INPUT
c            nvect  : size of the vector                         integer
c            vect   : vector(nvect)                              integer
c
c     OUTPUT
c            vmin   : minimum of the vector                      integer
c            vmax   : maximum of the vector                      integer
c
c-----------------------------------------------------------------------
c
      subroutine EVIBOR ( nvect, vect, vmin, vmax )
c
      implicit none
c
      integer nvect, vmin, vmax
      integer vect(*)
c
      integer i, vcour
c
c-----------------------------------------------------------------------
c
      vmin = vect(1)
      vmax = vect(1)
      do i=2,nvect
         vcour = vect(i)
         if (vcour.lt.vmin) vmin = vcour
         if (vcour.gt.vmax) vmax = vcour
      end do
      return
      end
c
c=======================================================================
c
c     subroutine EVIMAX
c
c     Computing the maximum of a vector of integers
c
c=======================================================================
c
c     INPUT
c            nvect  : size of the vector                         integer
c            vect   : vector(nvect)                              integer
c
c     OUTPUT
c            vmax   : maximum of the vector                      integer
c
c-----------------------------------------------------------------------
c
      subroutine EVIMAX ( nvect, vect, vmax )
c
      implicit none
c
      integer nvect, vmax
      integer vect(*)
c
      integer i, vcour
c
c-----------------------------------------------------------------------
c
      vmax = vect(1)
      do i=2,nvect
         vcour = vect(i)
         if (vcour.gt.vmax) vmax = vcour
      end do
      return
      end
c
c=======================================================================
c
c     subroutine EVIMIN
c
c     Computing the minimum of a vector of integers
c
c=======================================================================
c
c     INPUT
c            nvect  : size of the vector                         integer
c            vect   : vector(nvect)                              integer
c
c     OUTPUT
c            vmin   : minimum of the vector                      integer
c
c-----------------------------------------------------------------------
c
      subroutine EVIMIN ( nvect, vect, vmin )
c
      implicit none
c
      integer nvect, vmin
      integer vect(*)
c
      integer i, vcour
c
c-----------------------------------------------------------------------
c
      vmin = vect(1)
      do i=2,nvect
         vcour = vect(i)
         if (vcour.lt.vmin) vmin = vcour
      end do
      return
      end
c
c=======================================================================
c
c     subroutine IMI
c
c     Initialization at an integer of a matrix of integers
c
c=======================================================================
c
c     INPUT
c            nlmat  : number of rows of the matrix mat           integer
c            ncmat  : number of columns of the matrix mat        integer
c            mat    : matrix to initialize vector(nlmat*ncmat)   integer
c            val    : value to initialize the matrix             integer
c
c     OUTPUT
c            mat    : matrix initialized vector(nlmat*ncmat)     integer
c
c-----------------------------------------------------------------------
c
      subroutine IMI ( nlmat, ncmat, mat, val )
c
      implicit none
c
      integer nlmat, ncmat, val
      integer mat(nlmat,*)
c
      integer i,j
c
c-----------------------------------------------------------------------
c
      do j=1,ncmat
         do i=1,nlmat
             mat(i,j) = val
         end do
      end do
      return
      end
c
c=======================================================================
c
c     subroutine IMDI
c
c     Initialization at an integer of a diagonal matrix of integers
c
c=======================================================================
c
c     INPUT
c            nmat   : size of diagonal matrix mat                integer
c            mat    : matrix to initialize vector(nmat*nmat)     integer
c            val    : value to initialize the matrix             integer
c
c     OUTPUT
c            mat    : diagonal matrix    vector(nmat*nmat)       integer
c
c-----------------------------------------------------------------------
c
      subroutine IMDI ( nmat, mat, val )
c
      implicit none
c
      integer nmat, val
      integer mat(nmat,*)
c
      integer i,j
c
c-----------------------------------------------------------------------
c
      do j=1,nmat
         do i=1,nmat
             if (i.eq.j) then
                mat(i,i) = val
             else
                mat(i,j) = 0
             end if
         end do
      end do
      return
      end
c
c=======================================================================
c
c     subroutine IVI
c
c     Initialization at an integer of a vector
c
c=======================================================================
c
c     INPUT
c            nvect  : size of the vector                         integer
c            vect   : vector to initialize (nvect)               integer
c            val    : value to initialize the vector             integer
c
c     OUTPUT
c            vect   : vector initialized (nvect)                 integer
c
c-----------------------------------------------------------------------
c
      subroutine IVI ( nvect, vect, val )
c
      implicit none
c
      integer nvect, val, vect(*)
c
      integer i
c
c-----------------------------------------------------------------------
c
      do i=1,nvect
          vect(i) = val
      end do
      return
      end
c
c=======================================================================
c
c     subroutine KEVIEQ  : Computing how many elements of a vector
c                          of integer = value
c
c=======================================================================
c
c     INPUT
c            nvect  : size of the vector                         integer
c            vect   : vector(nvect)                              integer
c            val    : value                                      integer
c
c     OUTPUT
c            sum    : sum of the elements of the vector          integer
c                     if vect(i) = value
c
c-----------------------------------------------------------------------
c
      subroutine KEVIEQ ( nvect, vect, val, sum )
c
      implicit none
c
      integer nvect, val, sum
      integer vect(*)
c
      integer i
c
c-----------------------------------------------------------------------
c
      sum = 0
      do i=1,nvect
         if ( vect(i).eq.val )  sum = sum + 1
      end do
      return
      end
c
c=======================================================================
c
c     subroutine SEVI: Sum of the elements of a vector.
c
c=======================================================================
c
c     INPUT
c            nvect  : size of the vector                         integer
c            vect   : vector(nvect)                              integer
c
c     OUTPUT
c            sum    : sum of the elements of the vector          integer
c
c-----------------------------------------------------------------------
c
      subroutine SEVI ( nvect, vect, sum )
c
      implicit none
c
      integer nvect, sum
      integer vect(*)
c
      integer i
c
c-----------------------------------------------------------------------
c
      sum = 0
      do i=1,nvect
         sum = sum + vect(i)
      end do
      return
      end
c
c=======================================================================
c
c     subroutine WVIEQ
c
c     who is equal at n in a vector ?
c     gives a vector of indexes
c
c=======================================================================
c
c     INPUT
c            nvect  : size of the vector                         integer
c            vect   : vector(nvect)                              integer
c            val    : value                                      integer
c
c     OUTPUT
c            nind   : size of the indexes vector (max : nvect)   integer
c            index  : index of elements = value, vector(nind)    integer
c
c-----------------------------------------------------------------------
c
      subroutine WVIEQ ( nvect, vect, val, nind, index )
c
      implicit none
c
      integer nvect, nind, val
      integer index(*), vect(*)
c
      integer i
c
c-----------------------------------------------------------------------
c
      nind = 0
      do i=1,nvect
         if ( vect(i).eq.val ) then
            nind = nind + 1
            index(nind) = i
         endif
      end do
      return
      end
c
c=======================================================================
c
c     subroutine WVIGE
c
c     who is greater or equal than n in a vector ?
c     gives a vector of indexes
c
c=======================================================================
c
c     INPUT
c            nvect  : size of the vector                         integer
c            vect   : vector(nvect)                              integer
c            val    : value                                      integer
c
c     OUTPUT
c            nind   : size of the indexes vector (max : nvect)   integer
c            index  : index of elements >= value, vector(nind)   integer
c
c-----------------------------------------------------------------------
c
      subroutine WVIGE ( nvect, vect, val, nind, index )
c
      implicit none
c
      integer nvect, nind, val
      integer index(*), vect(*)
c
      integer i
c
c-----------------------------------------------------------------------
c
      nind = 0
      do i=1,nvect
         if ( vect(i).ge.val ) then
            nind = nind + 1
            index(nind) = i
         endif
      end do
      return
      end
c
c=======================================================================
c
c     subroutine WVIGT
c
c     who is greater than n in a vector ?
c     gives a vector of indexes
c
c=======================================================================
c
c     INPUT
c            nvect  : size of the vector                         integer
c            vect   : vector(nvect)                              integer
c            val    : value                                      integer
c
c     OUTPUT
c            nind   : size of the indexes vector (max : nvect)   integer
c            index  : index of elements > value, vector(nind)    integer
c
c-----------------------------------------------------------------------
c
      subroutine WVIGT ( nvect, vect, val, nind, index )
c
      implicit none
c
      integer nvect, nind, val
      integer index(*), vect(*)
c
      integer i
c
c-----------------------------------------------------------------------
c
      nind = 0
      do i=1,nvect
         if ( vect(i).gt.val ) then
            nind = nind + 1
            index(nind) = i
         endif
      end do
      return
      end
c
c=======================================================================
c
c     subroutine WVILE
c
c     who is lower or equal than n in a vector ?
c     gives a vector of indexes
c
c=======================================================================
c
c     INPUT
c            nvect  : size of the vector                         integer
c            vect   : vector(nvect)                              integer
c            val    : value                                      integer
c
c     OUTPUT
c            nind   : size of the indexes vector (max : nvect)   integer
c            index  : index of elements =< value, vector(nind)   integer
c
c-----------------------------------------------------------------------
c
      subroutine WVILE ( nvect, vect, val, nind, index )
c
      implicit none
c
      integer nvect, nind, val
      integer index(*), vect(*)
c
      integer i
c
c-----------------------------------------------------------------------
c
      nind = 0
      do i=1,nvect
         if ( vect(i).le.val ) then
            nind = nind + 1
            index(nind) = i
         endif
      end do
      return
      end
c
c=======================================================================
c
c     subroutine WVILT
c
c     who is lower than n in a vector ?
c     gives a vector of indexes
c
c=======================================================================
c
c     INPUT
c            nvect  : size of the vector                         integer
c            vect   : vector(nvect)                              integer
c            val    : value                                      integer
c
c     OUTPUT
c            nind   : size of the indexes vector (max : nvect)   integer
c            index  : index of elements < value, vector(nind)    integer
c
c-----------------------------------------------------------------------
c
      subroutine WVILT ( nvect, vect, val, nind, index )
c
      implicit none
c
      integer nvect, nind, val
      integer index(*), vect(*)
c
      integer i
c
c-----------------------------------------------------------------------
c
      nind = 0
      do i=1,nvect
         if ( vect(i).lt.val ) then
            nind = nind + 1
            index(nind) = i
         endif
      end do
      return
      end
c
c=======================================================================
c
c     subroutine YVI
c
c     Copy a vector of integers in a vector of integers
c
c=======================================================================
c
c     INPUT
c            nvect  : size of the vector                         integer
c            vectin : input vector(nvect)                        integer
c
c     OUTPUT
c            vecout : output vector(nvect)                       integer
c
c-----------------------------------------------------------------------
c
      subroutine YVI ( nvect, vectin, vecout )
c
      implicit none
c
      integer nvect
      integer vectin(*), vecout(*)
c
      integer i
c
c-----------------------------------------------------------------------
c
      do i=1,nvect
          vecout(i) = vectin(i)
      end do
      return
      end
c
c=======================================================================
c
c     subroutine YVIP
c
c     Copy a part of a vector in a vector
c
c=======================================================================
c
c     INPUT
c            nin    : size of the input vector vecin             integer
c            vecin  : input vector (nin)                         integer
c            rfirst : first row of vecin to copy                 integer
c            nout   : size of the output vector vecout           integer
c            vecout : initial output vector (nout)               integer
c
c     OUTPUT
c            vecout : modified output vector (nout)              integer
c            info   : = 0 successful exit                        integer
c
c-----------------------------------------------------------------------
c
      subroutine YVIP ( nin, vecin, rfirst, nout, vecout, info )
c
      implicit none
c
      integer nin, nout, rfirst, info
      integer vecin(*), vecout(*)
c
      integer i
c
c-----------------------------------------------------------------------
c
c     initialization
      info = 0
      if ( rfirst+nout-1.le.nin ) then
         do i=1,nout
            vecout(i) = vecin(i+rfirst-1)
         end do
      else
         info = -2
      end if
      return
      end
c
c=======================================================================
c
c     subroutine YVXI
c
c     Initialization of a vector at an integer.
c
c-----------------------------------------------------------------------
      SUBROUTINE YVXI ( n, vect, vali)
c-----------------------------------------------------------------------
c
c     INPUT
c            n    : size of the input vector vecin             integer
c            vect  : input vector (nin)                         integer
c            vali  :                   integer
c
c     OUTPUT
c            vecout : modified output vector (nout)              integer
c            info   : = 0 successful exit                        integer
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
      INTEGER i, n, vect(*), vali
c
      DO i = 1,n
        vect(i) = vali
      ENDDO
      RETURN
      END


MODULE MATRICES

  USE CONSTANTS

  USE GREEN_RANKINE
  USE GREEN_WAVE

  IMPLICIT NONE

CONTAINS

  SUBROUTINE ADD_RANKINE_PART_TO_THE_MATRICES(                        &
      nb_faces_1,                                                     &
      centers_1, normals_1,                                           &
      nb_vertices_2, nb_faces_2,                                      &
      vertices_2, faces_2, centers_2, normals_2, areas_2, radiuses_2, &
      coeff,                                                          &
      S, K)

    INTEGER,                                     INTENT(IN) :: nb_faces_1, nb_faces_2, nb_vertices_2
    REAL(KIND=PRE), DIMENSION(nb_faces_1, 3),    INTENT(IN) :: centers_1, normals_1
    REAL(KIND=PRE), DIMENSION(nb_vertices_2, 3), INTENT(IN) :: vertices_2
    INTEGER,        DIMENSION(nb_faces_2, 4),    INTENT(IN) :: faces_2
    REAL(KIND=PRE), DIMENSION(nb_faces_2, 3),    INTENT(IN) :: centers_2, normals_2
    REAL(KIND=PRE), DIMENSION(nb_faces_2),       INTENT(IN) :: areas_2, radiuses_2

    REAL(KIND=PRE), INTENT(IN) :: coeff

    COMPLEX(KIND=PRE), DIMENSION(nb_faces_1, nb_faces_2), INTENT(INOUT) :: S
    COMPLEX(KIND=PRE), DIMENSION(nb_faces_1, nb_faces_2), INTENT(INOUT) :: K

    ! Local variables
    INTEGER :: I, J
    REAL(KIND=PRE)               :: SP1
    REAL(KIND=PRE), DIMENSION(3) :: VSP1

    DO I = 1, nb_faces_1
      !$OMP PARALLEL DO PRIVATE(J, SP1, VSP1)
      DO J = 1, nb_faces_2

        CALL COMPUTE_INTEGRAL_OF_RANKINE_SOURCE( &
          centers_1(I, :),                       &
          vertices_2(faces_2(J, :), :),          &
          centers_2(J, :),                       &
          normals_2(J, :),                       &
          areas_2(J),                            &
          radiuses_2(J),                         &
          SP1, VSP1                              &
          )

        ! Store into influence matrix
        S(I, J) = S(I, J) - coeff * SP1/(4*PI)                                ! Green function
        K(I, J) = K(I, J) - coeff * DOT_PRODUCT(normals_1(I, :), VSP1)/(4*PI) ! Gradient of the Green function

      END DO
      !$OMP END PARALLEL DO
    END DO

  END SUBROUTINE

  ! =====================================================================

  SUBROUTINE ADD_WAVE_PART_TO_THE_MATRICES(  &
      nb_faces_1, centers_1, normals_1,  &
      nb_faces_2, nb_quad_points,        &
      quad_points, quad_weights,         &
      wavenumber, depth,                 &
      XR, XZ, APD,                       &
      NEXP, AMBDA, AR,                   &
      coeff,                             &
      same_body,                         &
      S, K)

    ! Mesh data
    INTEGER,                                  INTENT(IN) :: nb_faces_1, nb_faces_2
    REAL(KIND=PRE), DIMENSION(nb_faces_1, 3), INTENT(IN) :: normals_1, centers_1

    INTEGER,                                                  INTENT(IN) :: nb_quad_points
    REAL(KIND=PRE), DIMENSION(nb_faces_2, nb_quad_points, 3), INTENT(IN) :: quad_points
    REAL(KIND=PRE), DIMENSION(nb_faces_2, nb_quad_points),    INTENT(IN) :: quad_weights

    REAL(KIND=PRE),                           INTENT(IN) :: wavenumber, depth

    ! Tabulated integrals
    REAL(KIND=PRE), DIMENSION(328),           INTENT(IN) :: XR
    REAL(KIND=PRE), DIMENSION(46),            INTENT(IN) :: XZ
    REAL(KIND=PRE), DIMENSION(328, 46, 2, 2), INTENT(IN) :: APD

    ! Prony decomposition for finite depth
    INTEGER,                                  INTENT(IN) :: NEXP
    REAL(KIND=PRE), DIMENSION(NEXP),          INTENT(IN) :: AMBDA, AR

    REAL(KIND=PRE), INTENT(IN) :: coeff

    ! Trick to save some time
    LOGICAL,                                  INTENT(IN) :: same_body

    ! Output
    COMPLEX(KIND=PRE), DIMENSION(nb_faces_1, nb_faces_2), INTENT(INOUT) :: S
    COMPLEX(KIND=PRE), DIMENSION(nb_faces_1, nb_faces_2), INTENT(INOUT) :: K

    ! Local variables
    INTEGER                         :: I, J, Q
    COMPLEX(KIND=PRE)               :: SP2
    COMPLEX(KIND=PRE), DIMENSION(3) :: VSP2_SYM, VSP2_ANTISYM

    IF ((SAME_BODY) .AND. (nb_quad_points == 1)) THEN
      ! If we are computing the influence of some cells upon themselves, the resulting matrices have some symmetries.
      ! This is due to the symmetry of the Green function, and the way the integral on the face is approximated.
      ! (More precisely, the Green function is symmetric and its derivative is the sum of a symmetric part and an anti-symmetric
      ! part.)

      DO I = 1, nb_faces_1
        !$OMP PARALLEL DO PRIVATE(J, SP2, VSP2_SYM, VSP2_ANTISYM)
        DO J = I, nb_faces_2

          IF (depth == INFINITE_DEPTH) THEN
            CALL WAVE_PART_INFINITE_DEPTH &
              (wavenumber,                &
              centers_1(I, :),            &
              quad_points(J, 1, :),       & ! centers_2(J, :),
              XR, XZ, APD,                &
              SP2, VSP2_SYM               &
              )
            VSP2_ANTISYM(:) = ZERO
          ELSE
            CALL WAVE_PART_FINITE_DEPTH   &
              (wavenumber,                &
              centers_1(I, :),            &
              quad_points(J, 1, :),       & ! centers_2(J, :),
              depth,                      &
              XR, XZ, APD,                &
              NEXP, AMBDA, AR,            &
              SP2, VSP2_SYM, VSP2_ANTISYM &
              )
          END IF

          S(I, J) = S(I, J) - coeff/(4*PI) * SP2 * quad_weights(J, 1)
          K(I, J) = K(I, J) - coeff/(4*PI) * &
            DOT_PRODUCT(normals_1(I, :), VSP2_SYM + VSP2_ANTISYM) * quad_weights(J, 1)

          IF (.NOT. I==J) THEN
            VSP2_SYM(1:2) = -VSP2_SYM(1:2)
            S(J, I) = S(J, I) - coeff/(4*PI) * SP2 * quad_weights(I, 1)
            K(J, I) = K(J, I) - coeff/(4*PI) * &
              DOT_PRODUCT(normals_1(J, :), VSP2_SYM - VSP2_ANTISYM) * quad_weights(I, 1)
          END IF

        END DO
        !$OMP END PARALLEL DO
      END DO

    ELSE
      ! General case: if we are computing the influence of a some cells on other cells, we have to compute all the coefficients.

      DO I = 1, nb_faces_1
        !$OMP PARALLEL DO PRIVATE(J, SP2, VSP2_SYM, VSP2_ANTISYM)
        DO J = 1, nb_faces_2
          DO Q = 1, nb_quad_points
            IF (depth == INFINITE_DEPTH) THEN
              CALL WAVE_PART_INFINITE_DEPTH &
                (wavenumber,                &
                centers_1(I, :),            &
                quad_points(J, Q, :),       &
                XR, XZ, APD,                &
                SP2, VSP2_SYM               &
                )
              VSP2_ANTISYM(:) = ZERO
            ELSE
              CALL WAVE_PART_FINITE_DEPTH   &
                (wavenumber,                &
                centers_1(I, :),            &
                quad_points(J, Q, :),       &
                depth,                      &
                XR, XZ, APD,                &
                NEXP, AMBDA, AR,            &
                SP2, VSP2_SYM, VSP2_ANTISYM &
                )
            END IF

            S(I, J) = S(I, J) - coeff/(4*PI) * SP2 * quad_weights(J, Q)
            K(I, J) = K(I, J) - coeff/(4*PI) * &
              DOT_PRODUCT(normals_1(I, :), VSP2_SYM + VSP2_ANTISYM) * quad_weights(J, Q)

          END DO
        END DO
        !$OMP END PARALLEL DO
      END DO
    END IF

  END SUBROUTINE

  ! =====================================================================

  SUBROUTINE BUILD_MATRICES(                          &
      nb_faces_1, centers_1, normals_1,               &
      nb_vertices_2, nb_faces_2, vertices_2, faces_2, &
      centers_2, normals_2, areas_2, radiuses_2,      &
      nb_quad_points, quad_points, quad_weights,      &
      wavenumber, depth,                              &
      coeffs,                                         &
      XR, XZ, APD,                                    &
      NEXP, AMBDA, AR,                                &
      same_body,                                      &
      S, K)

    ! Mesh data
    INTEGER,                                     INTENT(IN) :: nb_faces_1, nb_faces_2, nb_vertices_2
    REAL(KIND=PRE), DIMENSION(nb_faces_1, 3),    INTENT(IN) :: centers_1, normals_1
    REAL(KIND=PRE), DIMENSION(nb_vertices_2, 3), INTENT(IN) :: vertices_2
    INTEGER,        DIMENSION(nb_faces_2, 4),    INTENT(IN) :: faces_2
    REAL(KIND=PRE), DIMENSION(nb_faces_2, 3),    INTENT(IN) :: centers_2, normals_2
    REAL(KIND=PRE), DIMENSION(nb_faces_2),       INTENT(IN) :: areas_2, radiuses_2

    INTEGER,                                                  INTENT(IN) :: nb_quad_points
    REAL(KIND=PRE), DIMENSION(nb_faces_2, nb_quad_points, 3), INTENT(IN) :: quad_points
    REAL(KIND=PRE), DIMENSION(nb_faces_2, nb_quad_points),    INTENT(IN) :: quad_weights

    LOGICAL,                                  INTENT(IN) :: same_body

    REAL(KIND=PRE),                           INTENT(IN) :: wavenumber, depth

    REAL(KIND=PRE), DIMENSION(3) :: coeffs

    ! Tabulated integrals
    REAL(KIND=PRE), DIMENSION(328),           INTENT(IN) :: XR
    REAL(KIND=PRE), DIMENSION(46),            INTENT(IN) :: XZ
    REAL(KIND=PRE), DIMENSION(328, 46, 2, 2), INTENT(IN) :: APD

    ! Prony decomposition for finite depth
    INTEGER,                                  INTENT(IN) :: NEXP
    REAL(KIND=PRE), DIMENSION(NEXP),          INTENT(IN) :: AMBDA, AR

    ! Output
    COMPLEX(KIND=PRE), DIMENSION(nb_faces_1, nb_faces_2), INTENT(OUT) :: S
    COMPLEX(KIND=PRE), DIMENSION(nb_faces_1, nb_faces_2), INTENT(OUT) :: K

    ! Local variables
    INTEGER :: I
    REAL(KIND=PRE), DIMENSION(nb_faces_1, 3) :: reflected_centers_1, reflected_normals_1

    !!!!!!!!!!!!!!!!!!!!
    !  Initialization  !
    !!!!!!!!!!!!!!!!!!!!

    S(:, :) = CMPLX(0.0, 0.0, KIND=PRE)
    K(:, :) = CMPLX(0.0, 0.0, KIND=PRE)

    !!!!!!!!!!!!!!!!!!
    !  Rankine part  !
    !!!!!!!!!!!!!!!!!!

    IF (coeffs(1) .NE. ZERO) THEN
      CALL ADD_RANKINE_PART_TO_THE_MATRICES(                            &
        nb_faces_1,                                                     &
        centers_1, normals_1,                                           &
        nb_vertices_2, nb_faces_2,                                      &
        vertices_2, faces_2, centers_2, normals_2, areas_2, radiuses_2, &
        coeffs(1),                                                      &
        S, K)
    END IF

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !  Reflected Rankine part  !
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!

    IF (coeffs(2) .NE. ZERO) THEN

      IF (depth == INFINITE_DEPTH) THEN
        ! Reflection through free surface
        reflected_centers_1(:, 1:2) = centers_1(:, 1:2)
        reflected_centers_1(:, 3)   = -centers_1(:, 3)
      ELSE
        ! Reflection through sea bottom
        reflected_centers_1(:, 1:2) = centers_1(:, 1:2)
        reflected_centers_1(:, 3)   = -centers_1(:, 3) - 2*depth
      END IF

      reflected_normals_1(:, 1:2) = normals_1(:, 1:2)
      reflected_normals_1(:, 3)   = -normals_1(:, 3)

      CALL ADD_RANKINE_PART_TO_THE_MATRICES(                            &
        nb_faces_1,                                                     &
        reflected_centers_1, reflected_normals_1,                       &
        nb_vertices_2, nb_faces_2,                                      &
        vertices_2, faces_2, centers_2, normals_2, areas_2, radiuses_2, &
        coeffs(2),                                                      &
        S, K)

    END IF

    !!!!!!!!!!!!!!!
    !  Wave part  !
    !!!!!!!!!!!!!!!

    IF (coeffs(3) .NE. ZERO) THEN

      CALL ADD_WAVE_PART_TO_THE_MATRICES(  &
        nb_faces_1, centers_1, normals_1,  &
        nb_faces_2, nb_quad_points,        &
        quad_points, quad_weights,         &
        wavenumber, depth,                 &
        XR, XZ, APD,                       &
        NEXP, AMBDA, AR,                   &
        coeffs(3),                         &
        same_body,                         &
        S, K)

    END IF

    !!!!!!!!!!!!!

    IF (SAME_BODY) THEN
      DO I = 1, nb_faces_1
        K(I, I) = K(I, I) + 0.5
      END DO
    END IF

    RETURN

  END SUBROUTINE

  ! =====================================================================

END MODULE MATRICES


  SUBROUTINE boris
    !
    USE basic
    USE numerics
    USE tracers
    USE fields
    !
    IMPLICIT none
    !
    ! Moves a set of tracers in the Cartesian plane.  The tracers obey the entire Lorentz
    ! force law, which is implemented through the Boris algorithm (Birdsall/Langdon book).
    ! The technique gives the tracer coordinates in phase space, including all three
    ! velocities and positions.
    !
    ! When the new value of the tracer attributes are
    ! returned to the main program, the new values must be set up to be passed into the
    ! Boris integrator at the next step.

    DOUBLE PRECISION                                 :: A=0., t2=0., deltat_t2=0., tdt05=0.
    DOUBLE PRECISION, DIMENSION(ndim_tracer)         :: vminus,vprime,vplus,t,s,B

    B_cart=0.
    B=0.
    vminus=0.
    vprime=0.
    vplus=0.
    t=0.
    s=0.

    tdt05 = tracerdeltat*0.5

    pos_cart = tracer_pos_cart(:,tracerid)
    vel_cart = tracer_vel_cart(:,tracerid)

    CALL Efieldfind

    vminus = vel_cart + E_cart*tdt05 ! find v-minus, equation 7 in B&L book, pg 58 (Boris 1970)
    ! when the B field is parallel to the z axis...motion due to B is just rotation

    CALL Bfieldfind
    B = B_cart

    t(1) = B(1)*tdt05  ! definition of the t vector from Boris
    t(2) = B(2)*tdt05  ! factor of A comes from cylindrial to cartesian
    t(3) = B(3)*tdt05
    t2 = t(1)**2. + t(2)**2. + t(3)**2.
    deltat_t2 = tracerdeltat/(1.+t2) ! for quicker simplification of s
    s(1) = B(1)*deltat_t2
    s(2) = B(2)*deltat_t2
    s(3) = B(3)*deltat_t2

    vprime(1) = vminus(1) + t(3)*vminus(2) - t(2)*vminus(3) ! the next six lines are applicable when
    vprime(2) = vminus(2) + t(1)*vminus(3) - t(3)*vminus(1) ! B and v are in arbitrary directions ...
    vprime(3) = vminus(3) + t(2)*vminus(1) - t(1)*vminus(2) ! ... which is necessary because of the toroidal field

    vplus(1) = vminus(1) + s(3)*vprime(2) - s(2)*vprime(3)
    vplus(2) = vminus(2) + s(1)*vprime(3) - s(3)*vprime(1)
    vplus(3) = vminus(3) + s(2)*vprime(1) - s(1)*vprime(2)

    ! find the updated velocity, which will be accessible to the main program
    tracer_vel_cart(:,tracerid) = vplus + E_cart*tdt05  ! now this is the velocity to output after the rotation

    ! find the updated position, which will be accessible to the main program
    tracer_pos_cart(:,tracerid) = pos_cart + tracerdeltat*tracer_vel_cart(:,tracerid)

  END SUBROUTINE boris


!---------------------------------------------------!
! Copyright (c) 2017 Shunsuke A. Sato               !
! Released under the MIT license                    !
! https://opensource.org/licenses/mit-license.php   !
!---------------------------------------------------!
subroutine zwfn_jx
  use global_variables
  implicit none
  integer :: ix,iy
  real(dp) :: tmp
  complex(zp) :: ztmp
  complex(zp) :: ztmp_wfn_b(0-4:Nx+4,0-4:Nx+4)

  jx(:)=0d0

!  do ix = 0,Nx
!    tmp = 0d0
!    do iy = 0,Nx
!      tmp = tmp + wfn(ix,iy)**2
!    end do
!    rho(ix) = tmp
!  end do

  ztmp_wfn_b(:,:)=0d0
  ztmp_wfn_b(0:Nx,0:Nx) = zwfn(0:Nx,0:Nx)

  do ix = 0,Nx
    ztmp = 0d0
    do iy = 0,Nx
      ztmp = ztmp + conjg(zwfn(iy,ix)) * ( &
        + gN1*(ztmp_wfn_b(iy,ix+1) - ztmp_wfn_b(iy,ix-1)) &
        + gN2*(ztmp_wfn_b(iy,ix+2) - ztmp_wfn_b(iy,ix-2)) &
        + gN3*(ztmp_wfn_b(iy,ix+3) - ztmp_wfn_b(iy,ix-3)) &
        + gN4*(ztmp_wfn_b(iy,ix+4) - ztmp_wfn_b(iy,ix-4)) )
    end do
    jx(ix) = real(2d0 * ztmp /zI) !*dx/dx
  end do

  return
end subroutine zwfn_jx


C    Copyright(C) 1999-2020 National Technology & Engineering Solutions
C    of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C    NTESS, the U.S. Government retains certain rights in this software.
C
C    See packages/seacas/LICENSE for details

      SUBROUTINE DVOL3D( COORD, DISP, LSTSN, NSEG, DELVOL, NDIM, NUMNP)

C***********************************************************************

C     DESCRIPTION:
C       This routine computes the change in volume of a cavity formed
C       by the boundary of an element side set flag

C     FORMAL PARAMETERS:
C       COORD   REAL      Nodal Coordinates
C       DISP    REAL      Nodal Displacements
C       LSTSN   INTEGER   List of nodes on this boundary
C       LSTLEN  INTEGER   Length of node list
C       NSEG    INTEGER   Number of segments in this boundary
C       DELVOL  REAL      Change in volume of this cavity
C       NDIM   INTEGER   Number of Nodes

C     CALLED BY:

C***********************************************************************

      DIMENSION COORD(NUMNP, *), DISP(NUMNP, *), LSTSN(*)

      DELVOL = 0.0

      DO 100 KSEG = 1 , NSEG
         L = LSTSN(4*KSEG)
         K = LSTSN(4*KSEG - 1)
         J = LSTSN(4*KSEG - 2)
         I = LSTSN(4*KSEG - 3)

         Y1 = COORD(I,2)
         Y2 = COORD(J,2)
         Y3 = COORD(K,2)
         Y4 = COORD(L,2)

         Y5 = COORD(I,2) + DISP(I,2)
         Y6 = COORD(J,2) + DISP(J,2)
         Y7 = COORD(K,2) + DISP(K,2)
         Y8 = COORD(L,2) + DISP(L,2)

         Z1 = COORD(I,3)
         Z2 = COORD(J,3)
         Z3 = COORD(K,3)
         Z4 = COORD(L,3)

         Z5 = COORD(I,3) + DISP(I,3)
         Z6 = COORD(J,3) + DISP(J,3)
         Z7 = COORD(K,3) + DISP(K,3)
         Z8 = COORD(L,3) + DISP(L,3)

         Z24 = Z2 - Z4
         Z52 = Z5 - Z2
         Z45 = Z4 - Z5
         B11 = ( Y2*(Z6-Z3-Z45) + Y3*Z24 + Y4*(Z3-Z8-Z52)
     *         + Y5*(Z8-Z6-Z24) + Y6*Z52 + Y8*Z45 ) / 12.
         Z31 = Z3 - Z1
         Z63 = Z6 - Z3
         Z16 = Z1 - Z6
         B21 = ( Y3*(Z7-Z4-Z16) + Y4*Z31 + Y1*(Z4-Z5-Z63)
     *         + Y6*(Z5-Z7-Z31) + Y7*Z63 + Y5*Z16 ) / 12.
         Z42 = Z4 - Z2
         Z74 = Z7 - Z4
         Z27 = Z2 - Z7
         B31 = ( Y4*(Z8-Z1-Z27) + Y1*Z42 + Y2*(Z1-Z6-Z74)
     *         + Y7*(Z6-Z8-Z42) + Y8*Z74 + Y6*Z27 ) / 12.
         Z13 = Z1 - Z3
         Z81 = Z8 - Z1
         Z38 = Z3 - Z8
         B41 = ( Y1*(Z5-Z2-Z38) + Y2*Z13 + Y3*(Z2-Z7-Z81)
     *         + Y8*(Z7-Z5-Z13) + Y5*Z81 + Y7*Z38 ) / 12.
         Z86 = Z8 - Z6
         Z18 = Z1 - Z8
         Z61 = Z6 - Z1
         B51 = ( Y8*(Z4-Z7-Z61) + Y7*Z86 + Y6*(Z7-Z2-Z18)
     *         + Y1*(Z2-Z4-Z86) + Y4*Z18 + Y2*Z61 ) / 12.
         Z57 = Z5 - Z7
         Z25 = Z2 - Z5
         Z72 = Z7 - Z2
         B61 = ( Y5*(Z1-Z8-Z72) + Y8*Z57 + Y7*(Z8-Z3-Z25)
     *         + Y2*(Z3-Z1-Z57) + Y1*Z25 + Y3*Z72 ) / 12.
         Z68 = Z6 - Z8
         Z36 = Z3 - Z6
         Z83 = Z8 - Z3
         B71 = ( Y6*(Z2-Z5-Z83) + Y5*Z68 + Y8*(Z5-Z4-Z36)
     *         + Y3*(Z4-Z2-Z68) + Y2*Z36 + Y4*Z83 ) / 12.
         Z75 = Z7 - Z5
         Z47 = Z4 - Z7
         Z54 = Z5 - Z4
         B81 = ( Y7*(Z3-Z6-Z54) + Y6*Z75 + Y5*(Z6-Z1-Z47)
     *         + Y4*(Z1-Z3-Z75) + Y3*Z47 + Y1*Z54 ) / 12.

C Calculate volume of displaced element face

         VOL=  COORD(I,1)              * B11
     *      +  COORD(J,1)              * B21
     *      +  COORD(K,1)              * B31
     *      +  COORD(L,1)              * B41
     *      + (COORD(I,1) + DISP(I,1)) * B51
     *      + (COORD(J,1) + DISP(J,1)) * B61
     *      + (COORD(K,1) + DISP(K,1)) * B71
     *      + (COORD(L,1) + DISP(L,1)) * B81
         DELVOL = DELVOL + VOL
  100 CONTINUE

      RETURN
      END


  !! ----------------------------------------------------------------------- !!
  !>
  !! model size parameter setting
  !<
  !! --
  block

    !! For main grid

    nx = 1184
    ny = 529
    nt = 3600       !! in second [sec.]
    tint = 1         !! interval time of output waveform [sec.]

    dx = 89.1085/3.0 !! in second [sec.]
    dy = 89.1085/3.0 !! in second [sec.]
    dt = 0.5

    xbeg = 131.0761  !! in degree [deg.]
    ybeg = 31.2393   !! in degree [deg.]

    mov = 1          !! to create snapshot (0 for yes, 1 for no)
    zmax_out = 1     !! to create zmax output (0 for yes, 1 for no)

    !! For children grid

  !  ntg   = 1        !! nested grid (0 for yes, 1 for no)

  !  nx1   =
  !  ny1   =

  !  dx1   =
  !  dx2   =

  !  xbeg1 =          !! in degree [deg.]
  !  ybeg1 =          !! in degree [deg.]

  end block


      module mod_ppsw
c
c --- parts of ppsw.f in a module
c
c separate set of subroutines, adapted from WHOI CTD group
c     real function atg(s,t,p)
c     real function theta(s,t0,p0,pr)
c     function p80(dpth,xlat)
c
c n fofonoff & r millard
c
      contains

      real function atg(s,t,p)
c ****************************
c adiabatic temperature gradient deg c per decibar
c ref: bryden,h.,1973,deep-sea res.,20,401-408
c units:
c       pressure        p        decibars
c       temperature     t        deg celsius (ipts-68)
c       salinity        s        (ipss-78)
c       adiabatic       atg      deg. c/decibar
c checkvalue: atg=3.255976e-4 c/dbar for s=40 (ipss-78),
c t=40 deg c,p0=10000 decibars
      ds = s - 35.0
      atg = (((-2.1687e-16*t+1.8676e-14)*t-4.6206e-13)*p
     x+((2.7759e-12*t-1.1351e-10)*ds+((-5.4481e-14*t
     x+8.733e-12)*t-6.7795e-10)*t+1.8741e-8))*p
     x+(-4.2393e-8*t+1.8932e-6)*ds
     x+((6.6228e-10*t-6.836e-8)*t+8.5258e-6)*t+3.5803e-5
      end function atg

      real function theta(s,t0,p0,pr)
c ***********************************
c to compute local potential temperature at pr
c using bryden 1973 polynomial for adiabatic lapse rate
c and runge-kutta 4-th order integration algorithm.
c ref: bryden,h.,1973,deep-sea res.,20,401-408
c fofonoff,n.,1977,deep-sea res.,24,489-491
c units:
c       pressure        p0       decibars
c       temperature     t0       deg celsius (ipts-68)
c       salinity        s        (ipss-78)
c       reference prs   pr       decibars
c       potential tmp.  theta    deg celsius
c checkvalue: theta= 36.89073 c,s=40 (ipss-78),t0=40 deg c,
c p0=10000 decibars,pr=0 decibars
c
c      set-up intermediate temperature and pressure variables
      p=p0
      t=t0
c**************
      h = pr - p
      xk = h*atg(s,t,p)
      t = t + 0.5*xk
      q = xk
      p = p + 0.5*h
      xk = h*atg(s,t,p)
      t = t + 0.29289322*(xk-q)
      q = 0.58578644*xk + 0.121320344*q
      xk = h*atg(s,t,p)
      t = t + 1.707106781*(xk-q)
      q = 3.414213562*xk - 4.121320344*q
      p = p + 0.5*h
      xk = h*atg(s,t,p)
      theta = t + (xk-2.0*q)/6.0
      end function theta

c
c pressure from depth from saunder's formula with eos80.
c reference: saunders,peter m., practical conversion of pressure
c            to depth., j.p.o. , april 1981.
c r millard
c march 9, 1983
c check value: p80=7500.004 dbars;for lat=30 deg., depth=7321.45 meters
      real function p80(dpth,xlat)
      parameter pi=3.141592654
      plat=abs(xlat*pi/180.)
      d=sin(plat)
      c1=5.92e-3+d**2*5.25e-3
      p80=((1-c1)-sqrt(((1-c1)**2)-(8.84e-6*dpth)))/4.42e-6
      end function p80

      end module mod_ppsw


module Hexahedron3D20NodeM
  use UtilitiesM
  use DebuggerM

  use PointM
  use Quadrilateral3D8NodeM
  use NodePtrM

  use IntegratorM

  use GeometryM

  implicit none

  private
  public :: Hexahedron3D20NodeDT, hexahedron3D20Node

  type, extends(GeometryDT) :: Hexahedron3D20NodeDT
   contains
     procedure, public  :: init
     procedure, public  :: getLenght
     procedure, public  :: shapeFunc
     procedure, public  :: dShapeFunc
     procedure, public  :: jacobianAllNodes
     procedure, public  :: jacobianSomeNodes
     procedure, public  :: jacobianAtGPoints
     procedure, public  :: jacobianDetFromCoordAllNodes
     procedure, public  :: jacobianDetFromCoordSomeNodes
     procedure, public  :: jacobianDetFromJacobian
     procedure, public  :: jacobianDetAtGPointsFromCoord
     procedure, public  :: jacobianDetAtGPointsFromJacobian
     procedure, private :: valueShapeFuncAtGPoints
  end type Hexahedron3D20NodeDT

  interface hexahedron3D20Node
     procedure :: constructor
  end interface hexahedron3D20Node

  integer(ikind), parameter :: NNODE = 20

contains

  type(Hexahedron3D20NodeDT) function constructor(gaussOrder)
    implicit none
    integer(ikind), intent(in) :: gaussOrder
    call constructor%init(gaussOrder)
  end function constructor

  subroutine init(this, gaussOrder)
    implicit none
    class(Hexahedron3D20NodeDT), intent(inout) :: this
    integer(ikind)             , intent(in)    :: gaussOrder
    this%nNode = NNODE
    this%dim = 3
    this%integrator = integrator(gaussOrder, 'hexahedron')
    call this%valueShapeFuncAtGPoints()
    this%boundaryGeometry = quadrilateral3D8Node(gaussOrder)
  end subroutine init

  real(rkind) function getLenght(this, node)
    implicit none
    class(Hexahedron3D20NodeDT)                       , intent(inout) :: this
    class(NodePtrDT)           , dimension(this%nNode), intent(in)    :: node
    getLenght = 0._rkind !Pendiente
  end function getLenght

  function shapeFunc(this, point)
    implicit none
    class(Hexahedron3D20NodeDT), intent(inout)         :: this
    class(PointDT)             , intent(in)            :: point
    real(rkind)                , dimension(this%nNode) :: shapeFunc
    real(rkind)                                        :: u, v, w
    u = point%getx()
    v = point%gety()
    w = point%getz()
    shapeFunc(1)  = -(1._rkind/8._rkind)*(1-u)*(1-v)*(1-w)*(2+u+v+w)
    shapeFunc(2)  = -(1._rkind/8._rkind)*(1+u)*(1-v)*(1-w)*(2-u+v+w)
    shapeFunc(3)  = -(1._rkind/8._rkind)*(1+u)*(1+v)*(1-w)*(2-u-v+w)
    shapeFunc(4)  = -(1._rkind/8._rkind)*(1-u)*(1+v)*(1-w)*(2+u-v+w)
    shapeFunc(5)  = -(1._rkind/8._rkind)*(1-u)*(1-v)*(1+w)*(2+u+v-w)
    shapeFunc(6)  = -(1._rkind/8._rkind)*(1+u)*(1-v)*(1+w)*(2-u+v-w)
    shapeFunc(7)  = -(1._rkind/8._rkind)*(1+u)*(1+v)*(1+w)*(2-u-v-w)
    shapeFunc(8)  = -(1._rkind/8._rkind)*(1-u)*(1+v)*(1+w)*(2+u-v-w)

    shapeFunc(9)  =  (1._rkind/4._rkind)*(1-u)*(1+u)*(1-v)*(1-w)
    shapeFunc(10) =  (1._rkind/4._rkind)*(1+u)*(1-v)*(1+v)*(1-w)
    shapeFunc(11) =  (1._rkind/4._rkind)*(1+u)*(1-u)*(1+v)*(1-w)
    shapeFunc(12) =  (1._rkind/4._rkind)*(1-u)*(1-v)*(1+v)*(1-w)

    shapeFunc(13) =  (1._rkind/4._rkind)*(1-u)*(1-v)*(1-w)*(1+w)
    shapeFunc(14) =  (1._rkind/4._rkind)*(1+u)*(1-v)*(1-w)*(1+w)
    shapeFunc(15) =  (1._rkind/4._rkind)*(1+u)*(1+v)*(1-w)*(1+w)
    shapeFunc(16) =  (1._rkind/4._rkind)*(1-u)*(1+v)*(1-w)*(1+w)

    shapeFunc(17) =  (1._rkind/4._rkind)*(1-u)*(1+u)*(1-v)*(1+w)
    shapeFunc(18) =  (1._rkind/4._rkind)*(1+u)*(1-v)*(1+v)*(1+w)
    shapeFunc(19) =  (1._rkind/4._rkind)*(1-u)*(1+u)*(1+v)*(1+w)
    shapeFunc(20) =  (1._rkind/4._rkind)*(1-u)*(1-v)*(1+v)*(1+w)
  end function shapeFunc

  function dShapeFunc(this, point)
    implicit none
    class(Hexahedron3D20NodeDT), intent(inout)                  :: this
    class(PointDT)             , intent(in)                     :: point
    real(rkind)                , dimension(this%dim, this%nNode) :: dShapeFunc
    real(rkind)                                                  :: u, v, w
    u = point%getx()
    v = point%gety()
    w = point%getz()
    dShapeFunc(1,1)  =  (1._rkind/8._rkind)*(v-1)*(w-1)*(2*u+v+w+1)
    dShapeFunc(2,1)  =  (1._rkind/8._rkind)*(u-1)*(w-1)*(u+2*v+w+1)
    dShapeFunc(3,1)  =  (1._rkind/8._rkind)*(u-1)*(v-1)*(u+v+2*w+1)
    dShapeFunc(1,2)  = -(1._rkind/8._rkind)*(v-1)*(w-1)*(-2*u+v+w+1)
    dShapeFunc(2,2)  =  (1._rkind/8._rkind)*(u+1)*(w-1)*(u-2*v-w-1)
    dShapeFunc(3,2)  =  (1._rkind/8._rkind)*(u+1)*(v-1)*(u-v-2*w-1)
    dShapeFunc(1,3)  = -(1._rkind/8._rkind)*(v+1)*(w-1)*(2*u+v-w-1)
    dShapeFunc(2,3)  = -(1._rkind/8._rkind)*(u+1)*(w-1)*(u+2*v-w-1)
    dShapeFunc(3,3)  = -(1._rkind/8._rkind)*(u+1)*(v+1)*(u+v-2*w-1)
    dShapeFunc(1,4)  =  (1._rkind/8._rkind)*(v+1)*(w-1)*(-2*u+v-w-1)
    dShapeFunc(2,4)  = -(1._rkind/8._rkind)*(u-1)*(w-1)*(u-2*v+w+1)
    dShapeFunc(3,4)  = -(1._rkind/8._rkind)*(u-1)*(v+1)*(u-v+2*w+1)
    dShapeFunc(1,5)  = -(1._rkind/8._rkind)*(v-1)*(w+1)*(2*u+v-w+1)
    dShapeFunc(2,5)  = -(1._rkind/8._rkind)*(u-1)*(w+1)*(u+2*v-w+1)
    dShapeFunc(3,5)  = -(1._rkind/8._rkind)*(u-1)*(v-1)*(u+v-2*w+1)
    dShapeFunc(1,6)  =  (1._rkind/8._rkind)*(v-1)*(w+1)*(-2*u+v-w+1)
    dShapeFunc(2,6)  = -(1._rkind/8._rkind)*(u+1)*(w+1)*(u-2*v+w-1)
    dShapeFunc(3,6)  = -(1._rkind/8._rkind)*(u+1)*(v-1)*(u-v+2*w-1)
    dShapeFunc(1,7)  =  (1._rkind/8._rkind)*(v+1)*(w+1)*(2*u+v+w-1)
    dShapeFunc(2,7)  =  (1._rkind/8._rkind)*(u+1)*(w+1)*(u+2*v+w-1)
    dShapeFunc(3,7)  =  (1._rkind/8._rkind)*(u+1)*(v+1)*(u+v+2*w-1)
    dShapeFunc(1,8)  = -(1._rkind/8._rkind)*(v+1)*(w+1)*(-2*u+v+w-1)
    dShapeFunc(2,8)  =  (1._rkind/8._rkind)*(u-1)*(w+1)*(u-2*v-w+1)
    dShapeFunc(3,8)  =  (1._rkind/8._rkind)*(u-1)*(v+1)*(u-v-2*w+1)
    dShapeFunc(1,9)  = -(1._rkind/2._rkind)*u*(v-1)*(w-1)
    dShapeFunc(2,9)  = -(1._rkind/4._rkind)*(u-1)*(u+1)*(w-1)
    dShapeFunc(3,9)  = -(1._rkind/4._rkind)*(u-1)*(u+1)*(v-1)
    dShapeFunc(1,10) =  (1._rkind/4._rkind)*(v-1)*(v+1)*(w-1)
    dShapeFunc(2,10) =  (1._rkind/2._rkind)*(u+1)*v*(w-1)
    dShapeFunc(3,10) =  (1._rkind/4._rkind)*(u+1)*(v-1)*(v+1)
    dShapeFunc(1,11) =  (1._rkind/2._rkind)*u*(v+1)*(w-1)
    dShapeFunc(2,11) =  (1._rkind/4._rkind)*(u-1)*(u+1)*(w-1)
    dShapeFunc(3,11) =  (1._rkind/4._rkind)*(u-1)*(u+1)*(v+1)
    dShapeFunc(1,12) = -(1._rkind/4._rkind)*(v-1)*(v+1)*(w-1)
    dShapeFunc(2,12) = -(1._rkind/2._rkind)*(u-1)*v*(w-1)
    dShapeFunc(3,12) = -(1._rkind/4._rkind)*(u-1)*(v-1)*(v+1)

    dShapeFunc(1,17) =  (1._rkind/2._rkind)*u*(v-1)*(w+1)
    dShapeFunc(2,17) =  (1._rkind/4._rkind)*(u-1)*(u+1)*(w+1)
    dShapeFunc(3,17) =  (1._rkind/4._rkind)*(u-1)*(u+1)*(v-1)
    dShapeFunc(1,18) = -(1._rkind/4._rkind)*(v-1)*(v+1)*(w+1)
    dShapeFunc(2,18) = -(1._rkind/2._rkind)*(u+1)*v*(w+1)
    dShapeFunc(3,18) = -(1._rkind/4._rkind)*(u+1)*(v-1)*(v+1)
    dShapeFunc(1,19) = -(1._rkind/2._rkind)*u*(v+1)*(w+1)
    dShapeFunc(2,19) = -(1._rkind/4._rkind)*(u-1)*(u+1)*(w+1)
    dShapeFunc(3,19) = -(1._rkind/4._rkind)*(u-1)*(u+1)*(v+1)
    dShapeFunc(1,20) =  (1._rkind/4._rkind)*(v-1)*(v+1)*(w+1)
    dShapeFunc(2,20) =  (1._rkind/2._rkind)*(u-1)*v*(w+1)
    dShapeFunc(3,20) =  (1._rkind/4._rkind)*(u-1)*(v-1)*(v+1)

    dShapeFunc(1,13) = -(1._rkind/4._rkind)*(v-1)*(w-1)*(w+1)
    dShapeFunc(2,13) = -(1._rkind/4._rkind)*(u-1)*(w-1)*(w+1)
    dShapeFunc(3,13) = -(1._rkind/2._rkind)*(u-1)*(v-1)*w
    dShapeFunc(1,14) =  (1._rkind/4._rkind)*(v-1)*(w-1)*(w+1)
    dShapeFunc(2,14) =  (1._rkind/4._rkind)*(u+1)*(w-1)*(w+1)
    dShapeFunc(3,14) =  (1._rkind/2._rkind)*(u+1)*(v-1)*w
    dShapeFunc(1,15) = -(1._rkind/4._rkind)*(v+1)*(w-1)*(w+1)
    dShapeFunc(2,15) = -(1._rkind/4._rkind)*(u+1)*(w-1)*(w+1)
    dShapeFunc(3,15) = -(1._rkind/2._rkind)*(u+1)*(v+1)*w
    dShapeFunc(1,16) =  (1._rkind/4._rkind)*(v+1)*(w-1)*(w+1)
    dShapeFunc(2,16) =  (1._rkind/4._rkind)*(u-1)*(w-1)*(w+1)
    dShapeFunc(3,16) =  (1._rkind/2._rkind)*(u-1)*(v+1)*w
  end function dShapeFunc

  function jacobianAllNodes(this, pointToValue, node)
    implicit none
    class(Hexahedron3D20NodeDT), intent(inout)                     :: this
    class(PointDT)             , intent(in)                        :: pointToValue
    class(NodePtrDT)           , dimension(this%nNode), intent(in) :: node
    real(rkind)                , dimension(this%dim, this%dim)     :: jacobianAllNodes
    integer(ikind)                                                 :: i
    real(rkind)                , dimension(3, NNODE)               :: dsf
    jacobianAllNodes = 0._rkind
    dsf = this%dShapeFunc(pointToValue)
    do i = 1, this%nNode
       jacobianAllNodes(1,1) = jacobianAllNodes(1,1) + dsf(1,i)*node(i)%getx() !dx/d(xi)
       jacobianAllNodes(1,2) = jacobianAllNodes(1,2) + dsf(1,i)*node(i)%gety() !dy/d(xi)
       jacobianAllNodes(1,3) = jacobianAllNodes(1,3) + dsf(1,i)*node(i)%getz() !dz/d(xi)
       jacobianAllNodes(2,1) = jacobianAllNodes(2,1) + dsf(2,i)*node(i)%getx() !dx/d(eta)
       jacobianAllNodes(2,2) = jacobianAllNodes(2,2) + dsf(2,i)*node(i)%gety() !dy/d(eta)
       jacobianAllNodes(2,3) = jacobianAllNodes(2,3) + dsf(2,i)*node(i)%getz() !dz/d(eta)
       jacobianAllNodes(3,1) = jacobianAllNodes(3,1) + dsf(3,i)*node(i)%getx() !dx/d(zeta)
       jacobianAllNodes(3,2) = jacobianAllNodes(3,2) + dsf(3,i)*node(i)%gety() !dy/d(zeta)
       jacobianAllNodes(3,3) = jacobianAllNodes(3,3) + dsf(3,i)*node(i)%getz() !dz/d(zeta)
    end do
  end function jacobianAllNodes

  function jacobianSomeNodes(this, indexList, pointToValue, node)
    implicit none
    class(Hexahedron3D20NodeDT), intent(inout)                     :: this
    integer(ikind)             , dimension(:)         , intent(in) :: indexList
    class(PointDT)             , intent(in)                        :: pointToValue
    class(NodePtrDT)           , dimension(:)         , intent(in) :: node
    real(rkind)                , dimension(this%dim, this%dim)      :: jacobianSomeNodes
    integer(ikind)                                                  :: i
    real(rkind)                , dimension(3, NNODE)                :: dsf
    jacobianSomeNodes = 0._rkind
    dsf = this%dShapeFunc(pointToValue)
    do i = 1, size(node)
       jacobianSomeNodes(1,1) = jacobianSomeNodes(1,1) + dsf(1,indexList(i))*node(i)%getx() !dx/d(xi)
       jacobianSomeNodes(1,2) = jacobianSomeNodes(1,2) + dsf(1,indexList(i))*node(i)%gety() !dy/d(xi)
       jacobianSomeNodes(1,3) = jacobianSomeNodes(1,3) + dsf(1,indexList(i))*node(i)%getz() !dz/d(xi)
       jacobianSomeNodes(2,1) = jacobianSomeNodes(2,1) + dsf(2,indexList(i))*node(i)%getx() !dx/d(eta)
       jacobianSomeNodes(2,2) = jacobianSomeNodes(2,2) + dsf(2,indexList(i))*node(i)%gety() !dy/d(eta)
       jacobianSomeNodes(2,3) = jacobianSomeNodes(2,3) + dsf(2,indexList(i))*node(i)%getz() !dz/d(eta)
       jacobianSomeNodes(3,1) = jacobianSomeNodes(3,1) + dsf(3,indexList(i))*node(i)%getx() !dx/d(zeta)
       jacobianSomeNodes(3,2) = jacobianSomeNodes(3,2) + dsf(3,indexList(i))*node(i)%gety() !dy/d(zeta)
       jacobianSomeNodes(3,3) = jacobianSomeNodes(3,3) + dsf(3,indexList(i))*node(i)%getz() !dz/d(zeta)
    end do
  end function jacobianSomeNodes

  function jacobianAtGPoints(this, node)
    implicit none
    class(Hexahedron3D20NodeDT)                         , intent(inout) :: this
    class(NodePtrDT), dimension(this%nNode)             , intent(in)    :: node
    real(rkind), dimension(this%integrator%integTerms,this%dim,this%dim) :: jacobianAtGPoints
    integer(ikind)                                                      :: i, j
    real(rkind), dimension(this%integrator%integTerms,3,NNODE)          :: dsf
    jacobianAtGPoints = 0._rkind
    dsf = this%integrator%dShapeFunc
    do i = 1, this%integrator%integTerms
       do j = 1, this%nNode
          jacobianAtGPoints(i,1,1) = jacobianAtGPoints(i,1,1) + dsf(i,1,j)*node(j)%getx() !dx/d(xi)
          jacobianAtGPoints(i,1,2) = jacobianAtGPoints(i,1,2) + dsf(i,1,j)*node(j)%gety() !dy/d(xi)
          jacobianAtGPoints(i,1,3) = jacobianAtGPoints(i,1,3) + dsf(i,1,j)*node(j)%getz() !dz/d(xi)
          jacobianAtGPoints(i,2,1) = jacobianAtGPoints(i,2,1) + dsf(i,2,j)*node(j)%getx() !dx/d(eta)
          jacobianAtGPoints(i,2,2) = jacobianAtGPoints(i,2,2) + dsf(i,2,j)*node(j)%gety() !dy/d(eta)
          jacobianAtGPoints(i,2,3) = jacobianAtGPoints(i,2,3) + dsf(i,2,j)*node(j)%getz() !dz/d(eta)
          jacobianAtGPoints(i,3,1) = jacobianAtGPoints(i,3,1) + dsf(i,3,j)*node(j)%getx() !dx/d(zeta)
          jacobianAtGPoints(i,3,2) = jacobianAtGPoints(i,3,2) + dsf(i,3,j)*node(j)%gety() !dy/d(zeta)
          jacobianAtGPoints(i,3,3) = jacobianAtGPoints(i,3,3) + dsf(i,3,j)*node(j)%getz() !dz/d(zeta)
       end do
    end do
  end function jacobianAtGPoints

  real(rkind) function jacobianDetFromCoordAllNodes(this, pointToValue, node)
    implicit none
    class(Hexahedron3D20NodeDT), intent(inout)                   :: this
    class(PointDT)          , intent(in)                        :: pointToValue
    class(NodePtrDT)        , dimension(this%nNode), intent(in) :: node
    real(rkind)             , dimension(3,3)                    :: jacobian
    jacobian = this%jacobian(pointToValue, node)
    jacobianDetFromCoordAllNodes = jacobian(1,1)*jacobian(2,2)*jacobian(3,3) &
         + jacobian(1,2)*jacobian(2,3)*jacobian(3,1)        &
         + jacobian(1,3)*jacobian(2,1)*jacobian(3,2)        &
         - jacobian(3,1)*jacobian(2,2)*jacobian(1,3)        &
         - jacobian(2,1)*jacobian(1,2)*jacobian(3,3)        &
         - jacobian(1,1)*jacobian(3,2)*jacobian(2,3)
  end function jacobianDetFromCoordAllNodes

  real(rkind) function jacobianDetFromCoordSomeNodes(this, indexList, pointToValue, node)
    implicit none
    class(Hexahedron3D20NodeDT), intent(inout)            :: this
    integer(ikind)          , dimension(:), intent(in) :: indexList
    class(PointDT)          , intent(in)               :: pointToValue
    class(NodePtrDT)        , dimension(:), intent(in) :: node
    real(rkind)             , dimension(3,3)           :: jacobian
    jacobian = this%jacobian(indexList, pointToValue, node)
    jacobianDetFromCoordSomeNodes = jacobian(1,1)*jacobian(2,2)*jacobian(3,3) &
         + jacobian(1,2)*jacobian(2,3)*jacobian(3,1)        &
         + jacobian(1,3)*jacobian(2,1)*jacobian(3,2)        &
         - jacobian(3,1)*jacobian(2,2)*jacobian(1,3)        &
         - jacobian(2,1)*jacobian(1,2)*jacobian(3,3)        &
         - jacobian(1,1)*jacobian(3,2)*jacobian(2,3)
  end function jacobianDetFromCoordSomeNodes

  real(rkind) function jacobianDetFromJacobian(this, jacobian)
    implicit none
    class(Hexahedron3D20NodeDT)   , intent(inout) :: this
    real(rkind), dimension(:,:), intent(in)    :: jacobian
    jacobianDetFromJacobian = jacobian(1,1)*jacobian(2,2)*jacobian(3,3) &
         + jacobian(1,2)*jacobian(2,3)*jacobian(3,1)        &
         + jacobian(1,3)*jacobian(2,1)*jacobian(3,2)        &
         - jacobian(3,1)*jacobian(2,2)*jacobian(1,3)        &
         - jacobian(2,1)*jacobian(1,2)*jacobian(3,3)        &
         - jacobian(1,1)*jacobian(3,2)*jacobian(2,3)
  end function jacobianDetFromJacobian

  function jacobianDetAtGPointsFromCoord(this, node)
    implicit none
    class(Hexahedron3D20NodeDT)               , intent(inout)      :: this
    class(NodePtrDT), dimension(this%nNode), intent(in)         :: node
    real(rkind)     , dimension(this%integrator%integTerms)     :: jacobianDetAtGPointsFromCoord
    integer(ikind)                                              :: i
    real(rkind)     , dimension(this%integrator%integTerms,3,3) :: jacobian
    jacobian = this%jacobianAtGPoints(node)
    do i = 1, this%integrator%integTerms
       jacobianDetAtGPointsFromCoord(i) = jacobian(i,1,1)*jacobian(i,2,2)*jacobian(i,3,3) &
         + jacobian(i,1,2)*jacobian(i,2,3)*jacobian(i,3,1)        &
         + jacobian(i,1,3)*jacobian(i,2,1)*jacobian(i,3,2)        &
         - jacobian(i,3,1)*jacobian(i,2,2)*jacobian(i,1,3)        &
         - jacobian(i,2,1)*jacobian(i,1,2)*jacobian(i,3,3)        &
         - jacobian(i,1,1)*jacobian(i,3,2)*jacobian(i,2,3)
    end do
  end function jacobianDetAtGPointsFromCoord

  function jacobianDetAtGPointsFromJacobian(this, jacobian)
    implicit none
    class(Hexahedron3D20NodeDT)          , intent(inout) :: this
    real(rkind), dimension(:,:,:)        , intent(in) :: jacobian
    real(rkind), dimension(this%integrator%integTerms) :: jacobianDetAtGPointsFromJacobian
    integer(ikind)                                     :: i
    do i = 1, this%integrator%integTerms
       jacobianDetAtGPointsFromJacobian(i) = jacobian(i,1,1)*jacobian(i,2,2)*jacobian(i,3,3) &
         + jacobian(i,1,2)*jacobian(i,2,3)*jacobian(i,3,1)        &
         + jacobian(i,1,3)*jacobian(i,2,1)*jacobian(i,3,2)        &
         - jacobian(i,3,1)*jacobian(i,2,2)*jacobian(i,1,3)        &
         - jacobian(i,2,1)*jacobian(i,1,2)*jacobian(i,3,3)        &
         - jacobian(i,1,1)*jacobian(i,3,2)*jacobian(i,2,3)
    end do
  end function jacobianDetAtGPointsFromJacobian

  subroutine valueShapeFuncAtGPoints(this)
    implicit none
    class(Hexahedron3D20NodeDT), intent(inout) :: this
    integer(ikind)                             :: i
    integer(ikind)                             :: integTerms
    real(rkind)                                :: x
    real(rkind)                                :: y
    real(rkind)                                :: z
    integTerms = this%integrator%integTerms
    allocate(this%integrator%shapeFunc(integTerms, NNODE))
    allocate(this%integrator%dShapeFunc(integTerms, 3, NNODE))
    do i = 1, integTerms
       x = this%integrator%gPoint(i,1)
       y = this%integrator%gPoint(i,2)
       z = this%integrator%gPoint(i,3)
       this%integrator%shapeFunc(i, 1:NNODE) = this%shapeFunc(point(x, y, z))
       this%integrator%dShapeFunc(i, 1:3, 1:NNODE) = this%dShapeFunc(point(x, y, z))
    end do
  end subroutine valueShapeFuncAtGPoints

end module Hexahedron3D20NodeM


      Real Function Cinf(y,fin,Istat)
C Calculates C_\infty from a table.
C Input: y = deviation, fin = fraction of the range
C Output: Cinf=C_\infty(y,fin), Istat = return status code
C Istat  Meaning
C   0    Result interpolated from table ymintable.in
C   1    Result extrapolated from f0=.01 (lowest f in the table)
C   2    y especially low.  Returns Cinf=1.
C   3    y especially high.  Returns Cinf=0.
C   4    Result estimated using derfc (not implemented)
C   5    failure: fin > 1
C   6    failure: fin < 1.E-10
      Implicit none
      Integer Nf,Nmin,Ntrials,Ntable,If,Ibin,Istat
      Real y,ytemp,f,ylow,yhigh,flog,Table(2000,100),FNf,
     1 fbin,ybin,dfbin,dIbin,dy,fin,f0/.01/
      Logical first/.true./
      Common/Cinfcom/Nf,Ntable,ylow,yhigh,dy,FNf,Table
      If(first) Then
       first=.false.
       Open(50,file='ymintable.txt',status='OLD',form='FORMATTED')
       Read(50,5) ylow,yhigh,Nmin,Nf,NTable,Ntrials
 5     Format(2F9.5,3I5,I9)
       Do If=1,Nf
          Read(50,10) (Table(Ibin,If),Ibin=1,Ntable)
 10       Format(10F9.6)
       EndDo
       dy=(yhigh-ylow)/float(Ntable)
       FNf=float(Nf)
       Close(50)
      EndIf
      Istat=0 ! Default for success
      Cinf=1. ! Default for failure
      f=fin
      If(f.gt.1.) Then
         Istat=4
         Return
      EndIf
      If(f.lt.1.E-10) Then
         Istat=5
         Return
      EndIf
      If(f.lt.0.01) Then
         Istat=1
         f=f0
      EndIf
      flog=log(f)
      ytemp=y*(1. - 0.3*flog) - 1.7*flog
      If(ytemp.lt.ylow) Then
         Istat=2
         Cinf=1.
         Return
      Elseif(ytemp.gt.yhigh) Then
         Istat=3
         Cinf=0.
         Return
      EndIf
      fbin=f*FNf
      If=fbin
      If(If.lt.1) If=1
C      If(If.gt.Nf-2) If=Nf-2
      If(If.gt.Nf-1) If=Nf-1
      dfbin=fbin-Float(If)
      ybin=(ytemp-ylow)/dy
      Ibin=ybin
      If(Ibin.lt.2) Ibin=2
      If(Ibin.gt.Ntable-1) Ibin=Ntable-1
      dIbin=ybin-Float(Ibin)
C To check the following interpolation formula, verify that it gives
C the correct 4 table entries when dfbin is close to 0 and 1 and when
C dIbin is close to 0 and 1.  Table(Ibin,If)=Cinf evaluated at
C ytemp=ylow+dy*Ibin, f=If/FNf.
      Cinf=(1.-dfbin)*(dIbin*Table(Ibin+1,If)+(1.-dIbin)*Table(Ibin,If))
     1    +dfbin*(dIbin*Table(Ibin+1,If+1)+(1.-dIbin)*Table(Ibin,If+1))
      If(Istat.eq.1) Cinf=Cinf**((1./fin - 0.94)/(1./f0 - 0.94))
      Return
      End


 SUBROUTINE cuate8(a,t)
 !***********************************************************************
 !
 !     extracts cuaternion from an ortogonal matrix (SPURRIER algorithm)
 !     and calculates natural rotation vector
 !
 !***********************************************************************
 IMPLICIT NONE
 REAL    (kind=8) a(3,3),t(3)
 INTEGER (kind=4) i,j,k
 REAL    (kind=8) traza,m,q0,q(3)

 !     cuaternion extraction

 traza = a(1,1)+a(2,2)+a(3,3)
 m = MAX(traza,a(1,1),a(2,2),a(3,3))
 IF(m <= traza) THEN
   q0   = SQRT(1d0+traza)/2d0
   q(1) = (a(3,2)-a(2,3))/4d0/q0
   q(2) = (a(1,3)-a(3,1))/4d0/q0
   q(3) = (a(2,1)-a(1,2))/4d0/q0
 ELSE
   IF(m <= a(1,1)) THEN
     i = 1
     j = 2
     k = 3
   ELSE IF(m <= a(2,2)) THEN
     i = 2
     j = 3
     k = 1
   ELSE
     i = 3
     j = 1
     k = 2
   END IF
   q(i) = SQRT(a(i,i)/2d0+(1d0-traza)/4d0)
   q(j) = (a(j,i)+a(i,j))/4d0/q(i)
   q(k) = (a(k,i)+a(i,k))/4D0/q(i)
   q0   = (a(k,j)-a(j,k))/4d0/q(i)
   IF(q0 < 0) THEN
     q  = -q
     q0 = -q0
   END IF
 END IF

 !     calculates the rotation vector

 IF(q0 < 0.99D+0) THEN
   m = 2*ACOS(q0)/SQRT(1d0-q0**2)
   t = q*m
 ELSE
   t = q/q0*2D0
 END IF
 RETURN
 END SUBROUTINE cuate8


fac = lambda (n) if n <= 1 then 1 else n * fac(n-1);

print(fac(20));


SUBROUTINE stiff3(km,coord,ym,pr)
 IMPLICIT NONE
!
!      analytical stiffness matrix of a 3-node triangle in plane strain
!
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 INTEGER::i,j
 REAL(iwp),INTENT(IN)::coord(3,2),ym,pr
 REAL(iwp),INTENT(OUT)::km(6,6)
 REAL(iwp)::x1,y1,x2,y2,x3,y3,cf
 REAL(iwp)::d1=1._iwp,d2=2._iwp,d3=3._iwp,d4=4._iwp,d5=5._iwp,d6=6._iwp
 x1=coord(1,1)
 y1=coord(1,2)
 x2=coord(2,1)
 y2=coord(2,2)
 x3=coord(3,1)
 y3=coord(3,2)
cf=ym/(d1+pr)/(-d1+d2*pr)/(-x1*y2+x1*y3-x2*y3+y1*x2-y1*x3+y2*x3)/d4
!-----------------------------------------------------------------------
 km(1,1)=(-d2*y2**2+d4*y2*y3-d2*y3**2+d2*pr*y2**2-d4*pr*y2*y3+            &
   d2*pr*y3**2-x2**2+d2*x2**2*pr+d2*x2*x3-d4*x2*x3*pr-x3**2+d2*x3**2*pr)*cf
 km(1,2)=(x2-x3)*(y2-y3)*cf
 km(1,3)=-(d2*y2*y3-d2*y2*y1-d2*y3**2+d2*y3*y1-d2*pr*y2*y3+d2*pr*y2*y1+   &
   d2*pr*y3**2-d2*pr*y3*y1-x2*x1+d2*x2*x1*pr+x2*x3-d2*x2*x3*pr+x3*x1-     &
   d2*x3*x1*pr-x3**2+d2*x3**2*pr)*cf
 km(1,4)=-(d2*pr*x1*y2-d2*pr*x1*y3-d2*pr*y2*x3-x2*y3+d2*x2*y3*pr+y1*x2-   &
   d2*y1*x2*pr+y3*x3-y1*x3+d2*y1*x3*pr)*cf
 km(1,5)=-(d2*y2*y1-d2*y2**2-d2*y3*y1+d2*y2*y3-d2*pr*y2*y1+d2*pr*y2**2+   &
   d2*pr*y3*y1-d2*pr*y2*y3+x2*x1-d2*x2*x1*pr-x2**2+d2*x2**2*pr-x3*x1+     &
   d2*x3*x1*pr+x2*x3-d2*x2*x3*pr)*cf
 km(1,6)=(d2*pr*x1*y2-d2*pr*x1*y3+d2*x2*y3*pr+y1*x2-d2*y1*x2*pr-y2*x2-    &
   y1*x3+d2*y1*x3*pr+y2*x3-d2*pr*y2*x3)*cf
!-----------------------------------------------------------------------
 km(2,2)=(-d2*x2**2+d4*x2*x3-d2*x3**2+d2*x2**2*pr-d4*x2*x3*pr+d2*x3**2*pr-&
   y2**2+d2*pr*y2**2+d2*y2*y3-d4*pr*y2*y3-y3**2+d2*pr*y3**2)*cf
 km(2,3)=(d2*x2*y3*pr-d2*y1*x2*pr+d2*y1*x3*pr-x1*y2+d2*pr*x1*y2+y2*x3-    &
   d2*pr*y2*x3+x1*y3-d2*pr*x1*y3-y3*x3)*cf
 km(2,4)=-(-d2*x2*x1+d2*x2*x3+d2*x3*x1-d2*x3**2+d2*x2*x1*pr-d2*x2*x3*pr-  &
   d2*x3*x1*pr+d2*x3**2*pr+y2*y3-d2*pr*y2*y3-y2*y1+d2*pr*y2*y1-y3**2+     &
   d2*pr*y3**2+y3*y1-d2*pr*y3*y1)*cf
 km(2,5)=(d2*y1*x2*pr-d2*y1*x3*pr+d2*pr*y2*x3+x1*y2-d2*pr*x1*y2-y2*x2-    &
   x1*y3+d2*pr*x1*y3+x2*y3-d2*x2*y3*pr)*cf
 km(2,6)=(-d2*x2*x1+d2*x2**2+d2*x3*x1-d2*x2*x3+d2*x2*x1*pr-d2*x2**2*pr-   &
   d2*x3*x1*pr+d2*x2*x3*pr-y2*y1+d2*pr*y2*y1+y2**2-d2*pr*y2**2+y3*y1-     &
   d2*pr*y3*y1-y2*y3+d2*pr*y2*y3)*cf
!-----------------------------------------------------------------------
 km(3,3)=(-d2*y3**2+d4*y3*y1-d2*y1**2+d2*pr*y3**2-d4*pr*y3*y1+d2*pr*y1**2-&
   x1**2+d2*x1**2*pr+d2*x3*x1-d4*x3*x1*pr-x3**2+d2*x3**2*pr)*cf
 km(3,4)=(x1-x3)*(-y3+y1)*cf
 km(3,5)=-(d2*y3*y1-d2*y2*y3-d2*y1**2+d2*y2*y1-d2*pr*y3*y1+d2*pr*y2*y3+   &
   d2*pr*y1**2-d2*pr*y2*y1-x1**2+d2*x1**2*pr+x2*x1-d2*x2*x1*pr+x3*x1-     &
   d2*x3*x1*pr-x2*x3+d2*x2*x3*pr)*cf
 km(3,6)=-(-d2*pr*x1*y3+d2*x2*y3*pr-d2*y1*x2*pr+y1*x1-x1*y2+d2*pr*x1*y2-  &
   y1*x3+d2*y1*x3*pr+y2*x3-d2*pr*y2*x3)*cf
!-----------------------------------------------------------------------
 km(4,4)=(-d2*x1**2+d4*x3*x1-d2*x3**2+d2*x1**2*pr-d4*x3*x1*pr+d2*x3**2*pr-&
   y3**2+d2*pr*y3**2+d2*y3*y1-d4*pr*y3*y1-y1**2+d2*pr*y1**2)*cf
 km(4,5)=(d2*pr*x1*y2+d2*y1*x3*pr-d2*pr*y2*x3+x1*y3-d2*pr*x1*y3-x2*y3+    &
   d2*x2*y3*pr-y1*x1+y1*x2-d2*y1*x2*pr)*cf
 km(4,6)=-(-d2*x1**2+d2*x2*x1+d2*x3*x1-d2*x2*x3+d2*x1**2*pr-d2*x2*x1*pr-  &
   d2*x3*x1*pr+d2*x2*x3*pr+y3*y1-d2*pr*y3*y1-y2*y3+d2*pr*y2*y3-y1**2+     &
   d2*pr*y1**2+y2*y1-d2*pr*y2*y1)*cf
!-----------------------------------------------------------------------
 km(5,5)=(-d2*y1**2+d4*y2*y1-d2*y2**2+d2*pr*y1**2-d4*pr*y2*y1+d2*pr*y2**2-&
   x1**2+d2*x1**2*pr+d2*x2*x1-d4*x2*x1*pr-x2**2+d2*x2**2*pr)*cf
 km(5,6)=(x1-x2)*(y1-y2)*cf
!-----------------------------------------------------------------------
 km(6,6)=(-d2*x1**2+d4*x2*x1-d2*x2**2+d2*x1**2*pr-d4*x2*x1*pr+d2*x2**2*pr-&
   y1**2+d2*pr*y1**2+d2*y2*y1-d4*pr*y2*y1-y2**2+d2*pr*y2**2)*cf
!-----------------------------LOWER TRIANGLE----------------------------
 km(2,1)=km(1,2)
 km(3,1)=km(1,3)
 km(3,2)=km(2,3)
 km(4,1)=km(1,4)
 km(4,2)=km(2,4)
 km(4,3)=km(3,4)
 km(5,1)=km(1,5)
 km(5,2)=km(2,5)
 km(5,3)=km(3,5)
 km(5,4)=km(4,5)
 km(6,1)=km(1,6)
 km(6,2)=km(2,6)
 km(6,3)=km(3,6)
 km(6,4)=km(4,6)
 km(6,5)=km(5,6)
RETURN
END SUBROUTINE stiff3


subroutine ringbf(xbf,f)
use param
implicit none
real(dp):: xbf(3),f(3),r(2),ftemp(3)
xbf=xbf/rsat
cyl(1)=dsqrt(xbf(1)*xbf(1)+xbf(2)*xbf(2))
cyl(2)=datan2(xbf(2),xbf(1))
cyl(3)=xbf(3)
cyl(4)=xbf(1)
cyl(5)=xbf(2)
cyl(6)=xbf(3)
!write(*,*)cyl

f=0.d0
!D ring
call ring_force(ringd/rsat,ftemp)
!write(*,*)ftemp
f=f+ftemp

!C ring
call ring_force(ringc/rsat,ftemp)
!write(*,*)ftemp
f=f+ftemp

!B ring
call ring_force(ringb/rsat,ftemp)
!write(*,*)ftemp
f=f+ftemp

!A ring
call ring_force(ringa/rsat,ftemp)
!write(*,*)ftemp
f=f+ftemp

end subroutine ringbf

subroutine ring_force(rthrea,f)
!完成单个环的引力积分
!xbf    土星固定系坐标
!rthrea 环的内径和外径(归一化)
!f		固定系坐标下的受力

use param
implicit none
!real*8,parameter:: pi=dacos(-1.d0)
integer,parameter::MAXTRI=500,MEVALS=60000
real*8:: f(3),rthrea(2)
REAL*8:: X(3,2),Y(3,2),DATA(10*MAXTRI),RES,ERR,theta1,theta2
INTEGER IWORK(3*MAXTRI),NU,ND,NEVALS,IFLAG,i,j,k
EXTERNAL intx,inty,intz
!id(1)=i
!id(2)=j
!id(3)=k
!print*,id
theta1=-pi
theta2=pi
X(1,1)=rthrea(1)
Y(1,1)=theta1
X(2,1)=rthrea(2)
Y(2,1)=theta1
X(3,1)=rthrea(2)
Y(3,1)=theta2
X(1,2)=rthrea(1)
Y(1,2)=theta1
X(2,2)=rthrea(2)
Y(2,2)=theta2
X(3,2)=rthrea(1)
Y(3,2)=theta2

!NU=0
!ND=0
!IFLAG=1
!CALL TWODQ(intx,2,X,Y,1.E-08,1,MAXTRI,MEVALS,f(1),ERR,NU,ND, NEVALS,IFLAG,DATA,IWORK)
!PRINT*,ERR,NEVALS,IFLAG
f(1)=0.d0
NU=0
ND=0
IFLAG=1
CALL TWODQ(inty,2,X,Y,1.E-08,1,MAXTRI,MEVALS,f(2),ERR,NU,ND, NEVALS,IFLAG,DATA,IWORK)
!PRINT*,ERR,NEVALS,IFLAG
NU=0
ND=0
IFLAG=1
CALL TWODQ(intz,2,X,Y,1.E-08,1,MAXTRI,MEVALS,f(3),ERR,NU,ND, NEVALS,IFLAG,DATA,IWORK)
!PRINT*,ERR,NEVALS,IFLAG
end subroutine ring_force

real*8 FUNCTION intx(t,theta)
use param
implicit none
real*8 t,theta,r(3),nr(3),dtemp
r(1)=t*dcos(theta)-cyl(4)
r(2)=t*dsin(theta)-cyl(5)
r(3)=-cyl(6)
call UNORM ( r, nr, dtemp )
!write(*,*)nr
intx=t*nr(1)/(cyl(3)**2+t**2+cyl(1)**2-2.d0*cyl(1)*t*dcos(cyl(2)-theta))
RETURN
END FUNCTION intx

real*8 FUNCTION inty(t,theta)
use param
implicit none
real*8 t,theta,r(3),nr(3),dtemp
r(1)=t*dcos(theta)-cyl(4)
r(2)=t*dsin(theta)-cyl(5)
r(3)=-cyl(6)
call UNORM ( r, nr, dtemp )
inty=t*nr(2)/(cyl(3)**2+t**2+cyl(1)**2-2.d0*cyl(1)*t*dcos(cyl(2)-theta))
RETURN
END FUNCTION inty

real*8 FUNCTION intz(t,theta)
use param
implicit none
real*8 t,theta,r(3),nr(3),dtemp
r(1)=t*dcos(theta)-cyl(4)
r(2)=t*dsin(theta)-cyl(5)
r(3)=-cyl(6)
call UNORM ( r, nr, dtemp )
intz=t*nr(3)/(cyl(3)**2+t**2+cyl(1)**2-2.d0*cyl(1)*t*dcos(cyl(2)-theta))
RETURN
END FUNCTION intz


!      HotCross Distribution - Version 1.0
!      tag: subroutine ../vents2/lavelle/NewCross/viscosity3d.f - version 6.4.97
!           version that kills vertical smag contribution

       subroutine viscosity3d

       use viscosity_module    !deprecated, ss => ai
       use grid_module
       use velocity_module
       use tracer_module
       use constants_module
       use signals_module
       include 'array_size.inc'

       real coef, Rf, eps30
       real s11,s12,s22,s33,s13,s23
       integer i,j,k

!           write(6,*) cs_h, cs_v; stop
            ls =   sqrt(dx * dy)
            coef = ismag_h * (cs_h * ls)**2
            eps30 = 1.0e-30

            ss = 0

!$OMP PARALLEL  DO

       do   k =  1 , nz
       do   j =  1 , ny
       do   i =  1 , nx

!2014 revision

              s11 =  ( um(i,j,k) - um(i-1,j,k) ) / dx
              s22 =  ( vm(i,j,k) - vm(i,j-1,k) ) / dy
! this is du/dy + dv/dx calculated over 2 grid cells and averaged over 2 columns/rows
!              s12 =  0.25 * ( um(i,j+1,k) + um(i-1,j+1,k) - um(i,j-1,k) - um(i-1,j-1,k)  ) / dy
!     &             + 0.25 * ( vm(i+1,j,k) + vm(i+1,j-1,k) - vm(i-1,j,k) - vm(i-1,j-1,k)  ) / dx
              s33 = ( wm(i,j,k) - wm(i,j, k-1) ) / dz

! this is (du/dy + dv/dx)/2 calculated over 2 grid cells and averaged over 2 columns/rows
              s12 =  0.25 * ( ( um(i,j+1,k) + um(i-1,j+1,k) - um(i,j-1,k) - um(i-1,j-1,k)  ) / dy
     &                      + ( vm(i+1,j,k) + vm(i+1,j-1,k) - vm(i-1,j,k) - vm(i-1,j-1,k)  ) / dx ) / 2.0d0

              ss(i,j,k) = 2.0d0*(s11**2) + 2.0d0*(s22**2) + 4.0d0*(s12**2) + 2.0d0*(s33**2)

!             ss(i,j,k) = ( ( um(i,j,k) - um(i-1,j,k) ) / dx ) **2  + ( ( vm(i,j,k) - vm(i,j-1,k) ) / dy ) **2
!     &                + ( ( um(i,j+1,k) + um(i-1,j+1,k) - um(i,j-1,k) - um(i-1,j-1,k)  ) / dy / 4.0d0
!     &                +   ( vm(i+1,j,k) + vm(i+1,j-1,k) - vm(i-1,j,k) - vm(i-1,j-1,k)  ) / dx / 4.0d0 ) **2 / 2.0d0
!     &                +  ( ( wm(i,j+1,k) + wm(i,j+1,k-1) - wm(i,j-1,k) - wm(i,j-1,k-1)  ) / dy / 4.0d0 ) **2 / 2.0d0
!     &                +  ( ( wm(i+1,j,k) + wm(i+1,j,k-1) - wm(i-1,j,k) - wm(i-1,j,k-1)  ) / dx / 4.0d0) **2 / 2.0d0

!old             epsh(i,j,k) =  (2.0d0*ss(i,j,k) )
!old              ss(i,j,k ) =  coef * sqrt(2.0d0* ss(i,j,k) + eps30 )
!                epsh(i,j,k) = (epsh(i,j,k) * (ss(i,j,k) + axmin)  !epsh now = AH*S_H^2

              epsh(i,j,k) = ss(i,j,k)  !store S_H^2
              ss(i,j,k ) =  coef * sqrt( ss(i,j,k) + eps30)   !ss now =  mixing coefficient AH without axmin
              epsh(i,j,k) = epsh(i,j,k) * (ss(i,j,k) + axmin)  ! epsh now = S_H^2*A_H

!2014 Revision

       enddo;enddo;enddo

!$OMP END PARALLEL DO

            !call stat_3d(epsh,0, nx+1,0,ny+1,0,nz+1)

            ls =   dz
          coef = ismag_v * (cs_v * ls)**2

!$OMP PARALLEL  DO

      do k =  1 , nz
      do j =  1 , ny
      do i =  1 , nx

! 2014 revision

! this is (du/dz + dw/dx)/2 calculated over 2 grid cells and averaged over 2 columns/rows
         S13 = 0.25 * ( ( um(i,j,k-1) + um(i-1,j,k-1) - um(i,j,k+1) - um(i-1,j,k+1) ) / dz
     &             +    ( wm(i+1,j,k) + wm(i+1,j,k-1) - wm(i-1,j,k) - wm(i-1,j,k-1) ) / dx )/2.0d0

! this is (dv/dz + dw/dy)/2 calculated over 2 grid cells and averaged over 2 columns/rows
         S23 = 0.25 * ( ( vm(i,j,k-1) + vm(i,j-1,k-1) - vm(i,j,k+1) - vm(i,j-1,k+1) ) / dz
     &            +     ( wm(i,j+1,k) + wm(i,j+1,k-1) - wm(i,j-1,k) - wm(i,j-1,k-1) ) / dy )/2.0d0

         ss_v(i,j,k) =  4.0d0*(s13**2) + 4.0d0*(s23**2)

!     &         + ( ( wm(i,j,k) - wm(i,j, k-1) ) / dz ) **2

!     &         +  (( (vm(i,j,k-1) + vm(i,j-1,k-1) + vm(i,j,k) + vm(i,j-1,k))
!     &             - (vm(i,j,k) + vm(i,j-1,k) + vm(i,j,k+1) + vm(i,j-1,k+1) ) ) / dz / 4.0
!     &            ) **2 / 2.0

!     &         +  (( (um(i,j,k-1) + um(i-1,j,k-1)+ um(i,j,k) + um(i-1,j,k))
!     &              - (um(i,j,k) + um(i-1,j,k) + um(i,j,k+1) + um(i-1,j,k+1) )  ) / dz / 4.0
!     &            ) **2 / 2.0

! this the density gradient calculated over 2 grid cells
         Ri(i,j,k) = - g * ( ( rhop(i,j,k-1) + rho_bkg(k-1) ) - ( rhop(i,j,k+1) + rho_bkg(k+1) ) ) / 2.0d0
     &            / dz / rho0 / (ss_v(i,j,k) + eps30)

         Rf = 3  ! put as Prandtl number for now

        epsv(i,j,k)  =  ss_v(i,j,k)
!        ss_v(i,j,k) =  coef * sqrt( ss_v(i,j,k) + eps30 )* sqrt ( 1.0 + eps - 0.167 )

!  !Di Iorio Eq. 13:
!            epsv(i,j,k)  =   ss_v(i,j,k)    !here epsv temporarily represents S_V^2
!  !Di Iorio Eq. 8:
            ss_v(i,j,k) =  coef * sqrt( ss_v(i,j,k)+eps30 )*csqrt( 1.0 + eps - Ri(i,j,k)/Rf ) !now ss_v is vertical mixing coef without azmin
!  !Di Iorio Eq. 13: dissipation = S_V^2 * A_V
            epsv(i,j,k)  =  epsv(i,j,k) * (ss_v(i,j,k)+azmin)  !Di Iorio Eq. 13

!           epsv(i,j,k)  =  (coef * sqrt ( 2.0d0 * ss_v(i,j,k) ) * sqrt ( 1.0 + eps - Rf ) + azmin ) * ss_v(i,j,k)

!2104 revision

      enddo;enddo;enddo

!$OMP END PARALLEL DO

                do k = 1, nz
                do j = 1, ny

                   ss(0,j,k)   = ss(1,j,k) * bcondx + ( 1 - bcondx ) * ss(nx,j,k)
                   ss(nx+1,j,k)= ss(nx,j,k) * bcondx + ( 1 - bcondx ) * ss(1,j,k)

                enddo;enddo

                do   k = 1, nz
                do   i = 1 , nx

                   ss(i,0,k) = ss(i,1,k) * bcondy + ( 1 - bcondy ) * ss(i,ny,k)
                   ss(i,ny+1,k) = ss(i,ny,k)  * bcondy + ( 1 - bcondy ) * ss(i,1,k)

                enddo;enddo

                do  j = 1, ny
                do  i = 1, nx

                   ss_v(i,j,0) = ss_v(i,j,1)
                   ss_v(i,j,nz+1) = ss_v(i,j,nz)

                enddo;enddo

                return

                end


Calculate the Hofstadter Q-sequence, using a big array rather than recursion.
      INTEGER ENUFF
      PARAMETER (ENUFF = 100000)
      INTEGER Q(ENUFF)	!Lots of memory these days.

      Q(1) = 1		!Initial values as per the definition.
      Q(2) = 1
      Q(3:) = -123456789!This will surely cause trouble!
      DO I = 3,ENUFF	!For values beyond the second,
        Q(I) = Q(I - Q(I - 1)) + Q(I - Q(I - 2))	!Reach back according to the last two values.
      END DO
Cast forth results as per the specification.
      WRITE (6,1) Q(1:10)		!Should be 1 1 2 3 3 4 5 5 6 6...
    1 FORMAT ("First ten values:",10I2)	!Known to be one-digit numbers.
      WRITE (6,*) "Q(1000) =",Q(1000)	!Should be 502.
      WRITE (6,3) ENUFF,COUNT(Q(2:ENUFF) < Q(1:ENUFF - 1))	!Please don't create a temporary array!
    3 FORMAT ("Count of those elements 2:",I0,
     1 " which are less than their predecessor: ",I0)	!Should be 49798.
Curry favour by allowing enquiries.
   10 WRITE (6,11) ENUFF
   11 FORMAT ("Nominate an index (in 1:",I0,"): ",$)	!Obviously, the $ says don't start a new line.
      READ (5,*,END = 999, ERR = 999) I	!Ask for a number, with precautions.
      IF (I.GT.0 .AND. I.LE.ENUFF) THEN	!A good number, but, within range?
        WRITE (6,12) I,Q(I)		!Yes. Reveal the requested value.
   12   FORMAT ("Q(",I0,") = ",I0)	!This should do.
        GO TO 10			!And ask again.
      END IF		! WHILE read(5,*) i & i > 0 & i < enuff DO write(6,*) "Q(",i,")=",Q(i);
Closedown.
  999 WRITE (6,*) "Bye."
      END