!--------------------------------------------------------------------------------------------------!
!   CP2K: A general program to perform molecular dynamics simulations                              !
!   Copyright (C) 2000 - 2018  CP2K developers group                                               !
!--------------------------------------------------------------------------------------------------!

! **************************************************************************************************
!> \brief Collection of simple mathematical functions and subroutines
!> \par History
!>      FUNCTION angle updated and FUNCTION dihedral angle added; cleaned
!>      (13.03.2004,MK)
!> \author MK (15.11.1998)
! **************************************************************************************************
MODULE mathlib

   USE kinds,                           ONLY: default_string_length,&
                                              dp
   USE mathconstants,                   ONLY: euler,&
                                              fac
   IMPLICIT NONE

   PRIVATE

   REAL(KIND=dp), PARAMETER             :: eps_geo = 1.0E-6_dp

   ! Public functions

   PUBLIC :: angle, &
             det_3x3, &
             inv_3x3

   INTERFACE det_3x3
      MODULE PROCEDURE det_3x3_1, det_3x3_2
   END INTERFACE

CONTAINS

! **************************************************************************************************
!> \brief  Calculation of the angle between the vectors a and b.
!>         The angle is returned in radians.
!> \param a ...
!> \param b ...
!> \return ...
!> \date    14.10.1998
!> \author  MK
!> \version 1.0
! **************************************************************************************************
   FUNCTION angle(a, b) RESULT(angle_ab)

      REAL(KIND=dp), DIMENSION(:), INTENT(IN)            :: a, b
      REAL(KIND=dp)                                      :: angle_ab

      REAL(KIND=dp)                                      :: length_of_a, length_of_b
      REAL(KIND=dp), DIMENSION(SIZE(a, 1))               :: a_norm, b_norm

      length_of_a = SQRT(DOT_PRODUCT(a, a))
      length_of_b = SQRT(DOT_PRODUCT(b, b))

      IF ((length_of_a > eps_geo) .AND. (length_of_b > eps_geo)) THEN
         a_norm(:) = a(:)/length_of_a
         b_norm(:) = b(:)/length_of_b
         angle_ab = ACOS(MIN(MAX(DOT_PRODUCT(a_norm, b_norm), -1.0_dp), 1.0_dp))
      ELSE
         angle_ab = 0.0_dp
      END IF

   END FUNCTION angle

! **************************************************************************************************
!> \brief   Returns the determinante of the 3x3 matrix a.
!> \param a ...
!> \return ...
!> \date    13.03.2004
!> \author  MK
!> \version 1.0
! **************************************************************************************************
   FUNCTION det_3x3_1(a) RESULT(det_a)
      REAL(KIND=dp), DIMENSION(3, 3), INTENT(IN)         :: a
      REAL(KIND=dp)                                      :: det_a

      det_a = a(1, 1)*(a(2, 2)*a(3, 3)-a(2, 3)*a(3, 2))+ &
              a(1, 2)*(a(2, 3)*a(3, 1)-a(2, 1)*a(3, 3))+ &
              a(1, 3)*(a(2, 1)*a(3, 2)-a(2, 2)*a(3, 1))

   END FUNCTION det_3x3_1

! **************************************************************************************************
!> \brief   Returns the determinante of the 3x3 matrix a given by its columns.
!> \param a1 ...
!> \param a2 ...
!> \param a3 ...
!> \return ...
!> \date    13.03.2004
!> \author  MK
!> \version 1.0
! **************************************************************************************************
   FUNCTION det_3x3_2(a1, a2, a3) RESULT(det_a)
      REAL(KIND=dp), DIMENSION(3), INTENT(IN)            :: a1, a2, a3
      REAL(KIND=dp)                                      :: det_a

      det_a = a1(1)*(a2(2)*a3(3)-a3(2)*a2(3))+ &
              a2(1)*(a3(2)*a1(3)-a1(2)*a3(3))+ &
              a3(1)*(a1(2)*a2(3)-a2(2)*a1(3))

   END FUNCTION det_3x3_2

! **************************************************************************************************
!> \brief   Returns the inverse of the 3 x 3 matrix a.
!> \param a ...
!> \return ...
!> \date    13.03.2004
!> \author  MK
!> \version 1.0
! **************************************************************************************************
   FUNCTION inv_3x3(a) RESULT(a_inv)

      REAL(KIND=dp), DIMENSION(3, 3), INTENT(IN)         :: a
      REAL(KIND=dp), DIMENSION(3, 3)                     :: a_inv

      REAL(KIND=dp)                                      :: det_a

      det_a = 1.0_dp/det_3x3(a)

      a_inv(1, 1) = (a(2, 2)*a(3, 3)-a(3, 2)*a(2, 3))*det_a
      a_inv(2, 1) = (a(2, 3)*a(3, 1)-a(3, 3)*a(2, 1))*det_a
      a_inv(3, 1) = (a(2, 1)*a(3, 2)-a(3, 1)*a(2, 2))*det_a

      a_inv(1, 2) = (a(1, 3)*a(3, 2)-a(3, 3)*a(1, 2))*det_a
      a_inv(2, 2) = (a(1, 1)*a(3, 3)-a(3, 1)*a(1, 3))*det_a
      a_inv(3, 2) = (a(1, 2)*a(3, 1)-a(3, 2)*a(1, 1))*det_a

      a_inv(1, 3) = (a(1, 2)*a(2, 3)-a(2, 2)*a(1, 3))*det_a
      a_inv(2, 3) = (a(1, 3)*a(2, 1)-a(2, 3)*a(1, 1))*det_a
      a_inv(3, 3) = (a(1, 1)*a(2, 2)-a(2, 1)*a(1, 2))*det_a

   END FUNCTION inv_3x3

END MODULE mathlib


*> \brief \b SGETSLS
*
*  Definition:
*  ===========
*
*       SUBROUTINE SGETSLS( TRANS, M, N, NRHS, A, LDA, B, LDB,
*     $                     WORK, LWORK, INFO )
*
*       .. Scalar Arguments ..
*       CHARACTER          TRANS
*       INTEGER            INFO, LDA, LDB, LWORK, M, N, NRHS
*       ..
*       .. Array Arguments ..
*       REAL               A( LDA, * ), B( LDB, * ), WORK( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> SGETSLS solves overdetermined or underdetermined real linear systems
*> involving an M-by-N matrix A, using a tall skinny QR or short wide LQ
*> factorization of A.  It is assumed that A has full rank.
*>
*>
*>
*> The following options are provided:
*>
*> 1. If TRANS = 'N' and m >= n:  find the least squares solution of
*>    an overdetermined system, i.e., solve the least squares problem
*>                 minimize || B - A*X ||.
*>
*> 2. If TRANS = 'N' and m < n:  find the minimum norm solution of
*>    an underdetermined system A * X = B.
*>
*> 3. If TRANS = 'T' and m >= n:  find the minimum norm solution of
*>    an undetermined system A**T * X = B.
*>
*> 4. If TRANS = 'T' and m < n:  find the least squares solution of
*>    an overdetermined system, i.e., solve the least squares problem
*>                 minimize || B - A**T * X ||.
*>
*> Several right hand side vectors b and solution vectors x can be
*> handled in a single call; they are stored as the columns of the
*> M-by-NRHS right hand side matrix B and the N-by-NRHS solution
*> matrix X.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] TRANS
*> \verbatim
*>          TRANS is CHARACTER*1
*>          = 'N': the linear system involves A;
*>          = 'T': the linear system involves A**T.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*>          M is INTEGER
*>          The number of rows of the matrix A.  M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of columns of the matrix A.  N >= 0.
*> \endverbatim
*>
*> \param[in] NRHS
*> \verbatim
*>          NRHS is INTEGER
*>          The number of right hand sides, i.e., the number of
*>          columns of the matrices B and X. NRHS >=0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*>          A is REAL array, dimension (LDA,N)
*>          On entry, the M-by-N matrix A.
*>          On exit,
*>          A is overwritten by details of its QR or LQ
*>          factorization as returned by SGEQR or SGELQ.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A.  LDA >= max(1,M).
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*>          B is REAL array, dimension (LDB,NRHS)
*>          On entry, the matrix B of right hand side vectors, stored
*>          columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS
*>          if TRANS = 'T'.
*>          On exit, if INFO = 0, B is overwritten by the solution
*>          vectors, stored columnwise:
*>          if TRANS = 'N' and m >= n, rows 1 to n of B contain the least
*>          squares solution vectors.
*>          if TRANS = 'N' and m < n, rows 1 to N of B contain the
*>          minimum norm solution vectors;
*>          if TRANS = 'T' and m >= n, rows 1 to M of B contain the
*>          minimum norm solution vectors;
*>          if TRANS = 'T' and m < n, rows 1 to M of B contain the
*>          least squares solution vectors.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*>          LDB is INTEGER
*>          The leading dimension of the array B. LDB >= MAX(1,M,N).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          (workspace) REAL array, dimension (MAX(1,LWORK))
*>          On exit, if INFO = 0, WORK(1) contains optimal (or either minimal
*>          or optimal, if query was assumed) LWORK.
*>          See LWORK for details.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*>          LWORK is INTEGER
*>          The dimension of the array WORK.
*>          If LWORK = -1 or -2, then a workspace query is assumed.
*>          If LWORK = -1, the routine calculates optimal size of WORK for the
*>          optimal performance and returns this value in WORK(1).
*>          If LWORK = -2, the routine calculates minimal size of WORK and
*>          returns this value in WORK(1).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0:  successful exit
*>          < 0:  if INFO = -i, the i-th argument had an illegal value
*>          > 0:  if INFO =  i, the i-th diagonal element of the
*>                triangular factor of A is zero, so that A does not have
*>                full rank; the least squares solution could not be
*>                computed.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date June 2017
*
*> \ingroup realGEsolve
*
*  =====================================================================
      SUBROUTINE SGETSLS( TRANS, M, N, NRHS, A, LDA, B, LDB,
     $                    WORK, LWORK, INFO )
*
*  -- LAPACK driver routine (version 3.7.1) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     June 2017
*
*     .. Scalar Arguments ..
      CHARACTER          TRANS
      INTEGER            INFO, LDA, LDB, LWORK, M, N, NRHS
*     ..
*     .. Array Arguments ..
      REAL               A( LDA, * ), B( LDB, * ), WORK( * )
*
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE
      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            LQUERY, TRAN
      INTEGER            I, IASCL, IBSCL, J, MINMN, MAXMN, BROW,
     $                   SCLLEN, MNK, TSZO, TSZM, LWO, LWM, LW1, LW2,
     $                   WSIZEO, WSIZEM, INFO2
      REAL               ANRM, BIGNUM, BNRM, SMLNUM, TQ( 5 ), WORKQ( 1 )
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      REAL               SLAMCH, SLANGE
      EXTERNAL           LSAME, ILAENV, SLABAD, SLAMCH, SLANGE
*     ..
*     .. External Subroutines ..
      EXTERNAL           SGEQR, SGEMQR, SLASCL, SLASET,
     $                   STRTRS, XERBLA, SGELQ, SGEMLQ
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          REAL, MAX, MIN, INT
*     ..
*     .. Executable Statements ..
*
*     Test the input arguments.
*
      INFO = 0
      MINMN = MIN( M, N )
      MAXMN = MAX( M, N )
      MNK   = MAX( MINMN, NRHS )
      TRAN  = LSAME( TRANS, 'T' )
*
      LQUERY = ( LWORK.EQ.-1 .OR. LWORK.EQ.-2 )
      IF( .NOT.( LSAME( TRANS, 'N' ) .OR.
     $    LSAME( TRANS, 'T' ) ) ) THEN
         INFO = -1
      ELSE IF( M.LT.0 ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -6
      ELSE IF( LDB.LT.MAX( 1, M, N ) ) THEN
         INFO = -8
      END IF
*
      IF( INFO.EQ.0 ) THEN
*
*     Determine the block size and minimum LWORK
*
       IF( M.GE.N ) THEN
         CALL SGEQR( M, N, A, LDA, TQ, -1, WORKQ, -1, INFO2 )
         TSZO = INT( TQ( 1 ) )
         LWO  = INT( WORKQ( 1 ) )
         CALL SGEMQR( 'L', TRANS, M, NRHS, N, A, LDA, TQ,
     $                TSZO, B, LDB, WORKQ, -1, INFO2 )
         LWO  = MAX( LWO, INT( WORKQ( 1 ) ) )
         CALL SGEQR( M, N, A, LDA, TQ, -2, WORKQ, -2, INFO2 )
         TSZM = INT( TQ( 1 ) )
         LWM  = INT( WORKQ( 1 ) )
         CALL SGEMQR( 'L', TRANS, M, NRHS, N, A, LDA, TQ,
     $                TSZM, B, LDB, WORKQ, -1, INFO2 )
         LWM = MAX( LWM, INT( WORKQ( 1 ) ) )
         WSIZEO = TSZO + LWO
         WSIZEM = TSZM + LWM
       ELSE
         CALL SGELQ( M, N, A, LDA, TQ, -1, WORKQ, -1, INFO2 )
         TSZO = INT( TQ( 1 ) )
         LWO  = INT( WORKQ( 1 ) )
         CALL SGEMLQ( 'L', TRANS, N, NRHS, M, A, LDA, TQ,
     $                TSZO, B, LDB, WORKQ, -1, INFO2 )
         LWO  = MAX( LWO, INT( WORKQ( 1 ) ) )
         CALL SGELQ( M, N, A, LDA, TQ, -2, WORKQ, -2, INFO2 )
         TSZM = INT( TQ( 1 ) )
         LWM  = INT( WORKQ( 1 ) )
         CALL SGEMLQ( 'L', TRANS, N, NRHS, M, A, LDA, TQ,
     $                TSZM, B, LDB, WORKQ, -1, INFO2 )
         LWM  = MAX( LWM, INT( WORKQ( 1 ) ) )
         WSIZEO = TSZO + LWO
         WSIZEM = TSZM + LWM
       END IF
*
       IF( ( LWORK.LT.WSIZEM ).AND.( .NOT.LQUERY ) ) THEN
          INFO = -10
       END IF
*
      END IF
*
      IF( INFO.NE.0 ) THEN
        CALL XERBLA( 'SGETSLS', -INFO )
        WORK( 1 ) = REAL( WSIZEO )
        RETURN
      END IF
      IF( LQUERY ) THEN
        IF( LWORK.EQ.-1 ) WORK( 1 ) = REAL( WSIZEO )
        IF( LWORK.EQ.-2 ) WORK( 1 ) = REAL( WSIZEM )
        RETURN
      END IF
      IF( LWORK.LT.WSIZEO ) THEN
        LW1 = TSZM
        LW2 = LWM
      ELSE
        LW1 = TSZO
        LW2 = LWO
      END IF
*
*     Quick return if possible
*
      IF( MIN( M, N, NRHS ).EQ.0 ) THEN
           CALL SLASET( 'FULL', MAX( M, N ), NRHS, ZERO, ZERO,
     $                  B, LDB )
           RETURN
      END IF
*
*     Get machine parameters
*
       SMLNUM = SLAMCH( 'S' ) / SLAMCH( 'P' )
       BIGNUM = ONE / SMLNUM
       CALL SLABAD( SMLNUM, BIGNUM )
*
*     Scale A, B if max element outside range [SMLNUM,BIGNUM]
*
      ANRM = SLANGE( 'M', M, N, A, LDA, WORK )
      IASCL = 0
      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
*
*        Scale matrix norm up to SMLNUM
*
         CALL SLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO )
         IASCL = 1
      ELSE IF( ANRM.GT.BIGNUM ) THEN
*
*        Scale matrix norm down to BIGNUM
*
         CALL SLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO )
         IASCL = 2
      ELSE IF( ANRM.EQ.ZERO ) THEN
*
*        Matrix all zero. Return zero solution.
*
         CALL SLASET( 'F', MAXMN, NRHS, ZERO, ZERO, B, LDB )
         GO TO 50
      END IF
*
      BROW = M
      IF ( TRAN ) THEN
        BROW = N
      END IF
      BNRM = SLANGE( 'M', BROW, NRHS, B, LDB, WORK )
      IBSCL = 0
      IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
*
*        Scale matrix norm up to SMLNUM
*
         CALL SLASCL( 'G', 0, 0, BNRM, SMLNUM, BROW, NRHS, B, LDB,
     $                INFO )
         IBSCL = 1
      ELSE IF( BNRM.GT.BIGNUM ) THEN
*
*        Scale matrix norm down to BIGNUM
*
         CALL SLASCL( 'G', 0, 0, BNRM, BIGNUM, BROW, NRHS, B, LDB,
     $                INFO )
         IBSCL = 2
      END IF
*
      IF ( M.GE.N ) THEN
*
*        compute QR factorization of A
*
        CALL SGEQR( M, N, A, LDA, WORK( LW2+1 ), LW1,
     $              WORK( 1 ), LW2, INFO )
        IF ( .NOT.TRAN ) THEN
*
*           Least-Squares Problem min || A * X - B ||
*
*           B(1:M,1:NRHS) := Q**T * B(1:M,1:NRHS)
*
          CALL SGEMQR( 'L' , 'T', M, NRHS, N, A, LDA,
     $                 WORK( LW2+1 ), LW1, B, LDB, WORK( 1 ), LW2,
     $                 INFO )
*
*           B(1:N,1:NRHS) := inv(R) * B(1:N,1:NRHS)
*
          CALL STRTRS( 'U', 'N', 'N', N, NRHS,
     $                  A, LDA, B, LDB, INFO )
          IF( INFO.GT.0 ) THEN
            RETURN
          END IF
          SCLLEN = N
        ELSE
*
*           Overdetermined system of equations A**T * X = B
*
*           B(1:N,1:NRHS) := inv(R**T) * B(1:N,1:NRHS)
*
            CALL STRTRS( 'U', 'T', 'N', N, NRHS,
     $                   A, LDA, B, LDB, INFO )
*
            IF( INFO.GT.0 ) THEN
               RETURN
            END IF
*
*           B(N+1:M,1:NRHS) = ZERO
*
            DO 20 J = 1, NRHS
               DO 10 I = N + 1, M
                  B( I, J ) = ZERO
   10          CONTINUE
   20       CONTINUE
*
*           B(1:M,1:NRHS) := Q(1:N,:) * B(1:N,1:NRHS)
*
            CALL SGEMQR( 'L', 'N', M, NRHS, N, A, LDA,
     $                   WORK( LW2+1 ), LW1, B, LDB, WORK( 1 ), LW2,
     $                   INFO )
*
            SCLLEN = M
*
         END IF
*
      ELSE
*
*        Compute LQ factorization of A
*
         CALL SGELQ( M, N, A, LDA, WORK( LW2+1 ), LW1,
     $               WORK( 1 ), LW2, INFO )
*
*        workspace at least M, optimally M*NB.
*
         IF( .NOT.TRAN ) THEN
*
*           underdetermined system of equations A * X = B
*
*           B(1:M,1:NRHS) := inv(L) * B(1:M,1:NRHS)
*
            CALL STRTRS( 'L', 'N', 'N', M, NRHS,
     $                   A, LDA, B, LDB, INFO )
*
            IF( INFO.GT.0 ) THEN
               RETURN
            END IF
*
*           B(M+1:N,1:NRHS) = 0
*
            DO 40 J = 1, NRHS
               DO 30 I = M + 1, N
                  B( I, J ) = ZERO
   30          CONTINUE
   40       CONTINUE
*
*           B(1:N,1:NRHS) := Q(1:N,:)**T * B(1:M,1:NRHS)
*
            CALL SGEMLQ( 'L', 'T', N, NRHS, M, A, LDA,
     $                   WORK( LW2+1 ), LW1, B, LDB, WORK( 1 ), LW2,
     $                   INFO )
*
*           workspace at least NRHS, optimally NRHS*NB
*
            SCLLEN = N
*
         ELSE
*
*           overdetermined system min || A**T * X - B ||
*
*           B(1:N,1:NRHS) := Q * B(1:N,1:NRHS)
*
            CALL SGEMLQ( 'L', 'N', N, NRHS, M, A, LDA,
     $                   WORK( LW2+1 ), LW1, B, LDB, WORK( 1 ), LW2,
     $                   INFO )
*
*           workspace at least NRHS, optimally NRHS*NB
*
*           B(1:M,1:NRHS) := inv(L**T) * B(1:M,1:NRHS)
*
            CALL STRTRS( 'Lower', 'Transpose', 'Non-unit', M, NRHS,
     $                   A, LDA, B, LDB, INFO )
*
            IF( INFO.GT.0 ) THEN
               RETURN
            END IF
*
            SCLLEN = M
*
         END IF
*
      END IF
*
*     Undo scaling
*
      IF( IASCL.EQ.1 ) THEN
        CALL SLASCL( 'G', 0, 0, ANRM, SMLNUM, SCLLEN, NRHS, B, LDB,
     $               INFO )
      ELSE IF( IASCL.EQ.2 ) THEN
        CALL SLASCL( 'G', 0, 0, ANRM, BIGNUM, SCLLEN, NRHS, B, LDB,
     $               INFO )
      END IF
      IF( IBSCL.EQ.1 ) THEN
        CALL SLASCL( 'G', 0, 0, SMLNUM, BNRM, SCLLEN, NRHS, B, LDB,
     $               INFO )
      ELSE IF( IBSCL.EQ.2 ) THEN
        CALL SLASCL( 'G', 0, 0, BIGNUM, BNRM, SCLLEN, NRHS, B, LDB,
     $               INFO )
      END IF
*
   50 CONTINUE
      WORK( 1 ) = REAL( TSZO + LWO )
      RETURN
*
*     End of SGETSLS
*
      END


c===========================================================================
       function topointegral(xim,xcell,xip,yjm,ycell,yjp,
     &                   xxlow,yylow,dxx,dyy,mxx,myy,zz,intmethod)
c===========================================================================

c###########################################################################
c     topointegral integrates a surface over a rectangular region
c     that is the intersection with a Cartesion grid (of topography data)
c     the surface integrated is defined by a piecewise bilinear through the
c     nodes of the Cartesian grid.

c      The rectangular intersection has coords:
c      xim <= x <= xip, yjm <= y <= yjp, with center (x,y) = (xcell, ycell)
c
c      The Cartesian grid has coords:
c      xxlow <= x <= xxhi, yylow <= y <= yyhi, with grid cell size dxx by dyy
c      and mxx by myy cells.
c
c                                                written by David L. George
c                                                Seattle, WA 7/16/08
c###########################################################################

      use geoclaw_module

      implicit double precision (a-h,o-z)
      double precision zz(1:mxx,1:myy)

c     # initialize:
      theintegral = 0.d0

      xxhi=xxlow+(mxx-1)*dxx
      yyhi=yylow+(myy-1)*dyy

c========TEST FOR SMALL ROUNDING ERROR==========
      if ((xim-xxlow).lt.0.d0.or.(xip-xxhi).gt.0.d0) then
         xim=dmax1(xxlow,xim)
         xip=dmin1(xxhi,xip)
         endif

      if ((yjm-yylow).lt.0.d0.or.(yjp-yyhi).gt.0.d0) then
         yjm=dmax1(yylow,yjm)
         yjp=dmin1(yyhi,yjp)
         endif
c=========================================

      dx=xip-xim
      dy=yjp-yjm

c=============INTEGRATE PIECEWISE BILINEAR OVER RECTANGULAR REGION====
      if (intmethod.eq.1) then !use bilinear method

c         don't waste time looping through the entire grid
c         just find indices that include the rectangular region

         djjstart=(yjm-yylow)/dyy
         jjstart=idint(djjstart)+1

         diistart=(xim-xxlow)/dxx
         iistart=idint(diistart)+1

         diiend=(xip-xxlow)/dxx
         iiend=ceiling(diiend) + 1

         djjend=(yjp-yylow)/dyy
         jjend=ceiling(djjend)+1

         iistart=max(iistart,1)
         jjstart=max(jjstart,1)
         iiend=min(mxx,iiend)
         jjend=min(myy,jjend)

         do jj=jjstart,jjend-1
            y1=yylow + (jj-1.d0)*dyy
            y2=yylow + (jj)*dyy
c           # the array zz is indexed from north to south: jjz is the actual index
c           # of interest in the array zz
            jjz1= myy-jj+1
            jjz2= jjz1-1

            do ii=iistart,iiend-1
               x1=xxlow + (ii-1.d0)*dxx
               x2=xxlow + (ii)*dxx

               z11 = zz(ii,jjz1)
               z12 = zz(ii,jjz2)
               z21 = zz(ii+1,jjz1)
               z22 = zz(ii+1,jjz2)

               if (icoordsys.eq.1) then !cartesian rectangle
                  theintegral = theintegral + bilinearintegral(
     &                                         xim,xip,yjm,yjp,
     &                                         x1,x2,y1,y2,
     &                                         dxx,dyy,
     &                                         z11,z12,z21,z22)
                elseif (icoordsys.eq.2) then !integrate on surface of sphere
                  theintegral = theintegral + bilinearintegral_s(
     &                                         xim,xip,yjm,yjp,
     &                                         x1,x2,y1,y2,
     &                                         dxx,dyy,
     &                                         z11,z12,z21,z22,
     &                                         Rearth,pi)
                else
                  write(*,*)  'TOPOINTEGRAL: icoordsys error'
                  endif
               enddo
            enddo

      else
         write(*,*) 'TOPOINTEGRAL: only intmethod = 1,2 is supported'
         endif

      topointegral= theintegral
      return
      end function


! =================================================
!   Initialize global variables.
! =================================================

subroutine init_global_vars()

    use physical_def
    use coordinates
    implicit none

    real*8    :: L
    integer*4 :: I, J

    ! Init coordinates
    dx = Lx/Nx
    dy = Ly/Ny
    do I = 1, Nx
        do J = 1, Ny
            x(I,J) = (I - 0.5)*dx
            y(I,J) = (J - 0.5)*dy
        end do
    end do

    ! Non-dimensionalize scalars
    L   = .5*(Lx + Ly)
    dx_ = dx/L
    dy_ = dy/L
    x_  = x/L
    y_  = y/L
    Lx_ = Lx/L
    Ly_ = Ly/L
    qw_ = qw*L/lbd/(Tn - Ts)
    qe_ = qe*L/lbd/(Tn - Ts)

end subroutine


FUNCTION AIRTOVAC(lam)

  !convert wavelengths from air to vac
  !see Morton (1991 Ap.J. Suppl. 77, 119)
  !this code was adapted from the IDL routine airtovac.pro

  USE sps_vars; USE sps_utils, ONLY : locate
  IMPLICIT NONE

  INTEGER :: vv,nn
  REAL(SP), DIMENSION(:), INTENT(in) :: lam
  REAL(SP), DIMENSION(SIZE(lam)) :: airtovac,fact,sigma2

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

  nn = SIZE(lam)

  !Convert to wavenumber squared
  sigma2(1:nn) = (1E4/lam(1:nn) )**2.

  !Compute conversion factor
  fact(1:nn) = 1.D0 + 6.4328D-5 + 2.94981D-2/(146.d0 - sigma2(1:nn)) + &
       2.5540D-4/( 41.d0 - sigma2(1:nn))

  !no conversion for wavelengths <2000A
  IF (lam(1).LT.2000.D0) THEN
     vv = MIN(MAX(locate(lam(1:nn),2000.D0),1),nn)
     fact(1:vv) = 1.0
  ENDIF

  !Convert wavelength
  airtovac(1:nn) = lam(1:nn)*fact(1:nn)

END FUNCTION AIRTOVAC

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

FUNCTION VACTOAIR(lam)

  !convert wavelengths from air to vac
  !see Morton (1991 Ap.J. Suppl. 77, 119)
  !this code was adapted from the IDL routine vactoair.pro

  USE sps_vars; USE sps_utils, ONLY : locate
  IMPLICIT NONE

  INTEGER :: vv,nn
  REAL(SP), DIMENSION(:), INTENT(in) :: lam
  REAL(SP), DIMENSION(SIZE(lam)) :: vactoair,fact

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

  nn = SIZE(lam)

  fact(1:nn) = 1.D0 + 2.735182D-4 + 131.4182/lam(1:nn)**2 + &
       2.76249D8/lam(1:nn)**4

  !no conversion for wavelengths <2000A
   IF (lam(1).LT.2000.D0) THEN
     vv = MIN(MAX(locate(lam(1:nn),2000.D0),1),nn)
     fact(1:vv) = 1.0
  ENDIF

  !Convert wavelengths
  vactoair(1:nn) = lam(1:nn)/fact(1:nn)

END FUNCTION VACTOAIR


!file: glasso_p.f90
subroutine glasso_p(Omega, Sigma, & !output
                    Sigma_pre, lambda, & !inputs :: data and parameter
                    ths_lasso, max_iter_lasso, &
                    p, dim_Sigma, dim_dep) !inputs :: dimensions
    implicit none

    !inputs :: dimensions
    integer, intent(in) :: p, dim_Sigma, dim_dep

    !inputs :: data and parameter
    real(8), dimension(dim_Sigma, dim_Sigma), intent(in) :: Sigma_pre, lambda

    !inputs :: opt. parameters
    integer, intent(in) :: max_iter_lasso
    real(8), intent(in) :: ths_lasso

!f2py integer optional, intent(in) :: max_iter = 100
!f2py real(8) optional, intent(in) :: ths = 0.001

    !in/outputs
    real(8), dimension(dim_Sigma, dim_Sigma) :: Omega, Sigma

!f2py intent(inplace) Omega
!f2py intent(inplace) Sigma

    ! local variables
    integer :: q
    integer, dimension(dim_Sigma-1) :: notp
    integer, dimension(dim_dep) :: depp
    real(8), dimension(dim_dep) :: beta
    real(8), dimension(dim_Sigma, dim_Sigma) :: IOmega_notp

    notp = pack((/(q,q=1,dim_Sigma)/), (/(q,q=1,dim_Sigma)/)/=p)
    depp = pack((/(q,q=1,dim_Sigma)/), &
                (lambda(p,:)>=0) .and. ((/(q,q=1,dim_Sigma)/)/=p))

    IOmega_notp = 0
    IOmega_notp(notp,notp) = &
        Sigma(notp,notp) - matmul(reshape(Sigma(notp,p), (/dim_Sigma-1,1/)), &
                                  reshape(Sigma(p,notp), (/1,dim_Sigma-1/)) / Sigma(p,p))

    Sigma(p,p) = Sigma_pre(p,p) + lambda(p,p)

    beta = Omega(p,depp)
    call lasso(beta, Sigma(p,p) * IOmega_notp(depp,depp), - Sigma_pre(p,depp), &
               lambda(p,depp), ths_lasso, max_iter_lasso, dim_dep)

    Omega(p,:) = 0
    Omega(:,p) = 0
    Omega(p,depp) = beta
    Omega(depp,p) = beta

    Sigma(notp,p) = matmul(IOmega_notp(notp, depp), - beta * Sigma(p,p))
    Sigma(p,notp) = Sigma(notp, p)

    Omega(p,p) = (1 - dot_product(Omega(p, depp), Sigma(p, depp))) / Sigma(p,p)

    Sigma(notp,notp) = IOmega_notp(notp,notp) &
        + matmul(reshape(Sigma(notp,p), (/dim_Sigma-1,1/)), &
                 reshape(Sigma(p,notp), (/1,dim_Sigma-1/)) / Sigma(p,p))

end subroutine glasso_p


C$Procedure    DLATDR ( Derivative of latitudinal w.r.t. rectangular )

      SUBROUTINE DLATDR ( X, Y, Z, JACOBI )
      IMPLICIT NONE

C$ Abstract
C
C     This routine computes the Jacobian of the transformation from
C     rectangular to latitudinal coordinates.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     COORDINATES
C     DERIVATIVES
C     MATRIX
C
C$ Declarations

      DOUBLE PRECISION      X
      DOUBLE PRECISION      Y
      DOUBLE PRECISION      Z
      DOUBLE PRECISION      JACOBI ( 3, 3 )

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     X          I   X-coordinate of point.
C     Y          I   Y-coordinate of point.
C     Z          I   Z-coordinate of point.
C     JACOBI     O   Matrix of partial derivatives.
C
C$ Detailed_Input
C
C     X,
C     Y,
C     Z          are the rectangular coordinates of the point at
C                which the Jacobian of the map from rectangular
C                to latitudinal coordinates is desired.
C
C$ Detailed_Output
C
C     JACOBI     is the matrix of partial derivatives of the conversion
C                between rectangular and latitudinal coordinates.  It
C                has the form
C
C                    .-                              -.
C                    |  dr/dx     dr/dy     dr/dz     |
C                    |  dlong/dx  dlong/dy  dlong/dz  |
C                    |  dlat/dx   dlat/dy   dlat/dz   |
C                    `-                              -'
C
C               evaluated at the input values of X, Y, and Z.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1) If the input point is on the z-axis ( X and Y = 0 ), the
C        Jacobian is undefined.  The error SPICE(POINTONZAXIS)
C        will be signaled.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     When performing vector calculations with velocities it is
C     usually most convenient to work in rectangular coordinates.
C     However, once the vector manipulations have been performed
C     it is often desirable to convert the rectangular representations
C     into latitudinal coordinates to gain insights about phenomena
C     in this coordinate frame.
C
C     To transform rectangular velocities to derivatives of coordinates
C     in a latitudinal system, one uses the Jacobian of the
C     transformation between the two systems.
C
C     Given a state in rectangular coordinates
C
C          ( x, y, z, dx, dy, dz )
C
C     the corresponding latitudinal coordinate derivatives are given by
C     the matrix equation:
C
C                         t          |                     t
C        (dr, dlong, dlat)   = JACOBI|        * (dx, dy, dz)
C                                    |(x,y,z)
C
C     This routine computes the matrix
C
C              |
C        JACOBI|
C              |(x, y, z)
C
C$ Examples
C
C     Suppose one is given the bodyfixed rectangular state of an object
C     ( x(t), y(t), z(t), dx(t), dy(t), dz(t) ) as a function of time t.
C
C     To find the derivatives of the coordinates of the object in
C     bodyfixed latitudinal coordinates, one simply multiplies the
C     Jacobian of the transformation from rectangular to latitudinal
C     (evaluated at x(t), y(t), z(t) ) by the rectangular velocity
C     vector of the object at time t.
C
C     In code this looks like:
C
C        C
C        C     Load the rectangular velocity vector vector RECV.
C        C
C              RECV(1) = DX_DT ( T )
C              RECV(3) = DY_DT ( T )
C              RECV(2) = DZ_DT ( T )
C
C        C
C        C     Determine the Jacobian of the transformation from
C        C     rectangular to latitudinal at the rectangular
C        C     coordinates at time T.
C        C
C              CALL DLATDR ( X(T), Y(T), Z(T), JACOBI )
C
C        C
C        C     Multiply the Jacobian on the right by the rectangular
C        C     velocity to obtain the latitudinal coordinate
C        C     derivatives LATV.
C        C
C              CALL MXV ( JACOBI, RECV, LATV )
C
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     W.L. Taber     (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.0, 16-JUL-2001 (WLT)
C
C-&

C$ Index_Entries
C
C     Jacobian of latitudinal w.r.t. rectangular coordinates
C
C-&

C$ Revisions
C
C     None.
C
C-&

C
C     SPICELIB functions
C
      LOGICAL          RETURN

C
C     Local variables
C
      DOUBLE PRECISION      RECTAN  ( 3 )
      DOUBLE PRECISION      R
      DOUBLE PRECISION      LONG
      DOUBLE PRECISION      LAT
      DOUBLE PRECISION      INJACB  ( 3, 3 )

C
C     Standard SPICE error handling.
C
      IF ( RETURN () ) THEN
         RETURN
      ELSE
         CALL CHKIN ( 'DLATDR' )
      END IF

C
C     There is a singularity of the Jacobian for points on the z-axis.
C
      IF ( ( X .EQ. 0 ) .AND. ( Y .EQ. 0 ) ) THEN

         CALL SETMSG ( 'The Jacobian of the transformation from '     //
     .                 'rectangular to latitudinal coordinates '      //
     .                 'is not defined for points on the z-axis.'      )
         CALL SIGERR ( 'SPICE(POINTONZAXIS)'                           )
         CALL CHKOUT ( 'DLATDR'                                        )
         RETURN

      END IF

C
C     We will get the Jacobian of the transformation from rectangular
C     to latitudinal coordinates by implicit differentiation.
C
C     First move the X,Y and Z coordinates into a vector.
C
      CALL VPACK  ( X, Y, Z, RECTAN )

C
C     Convert from rectangular to latitudinal coordinates.
C
      CALL RECLAT ( RECTAN, R, LONG, LAT  )

C
C     Get the Jacobian of the transformation from latitudinal to
C     rectangular coordinates at R, LONG, LAT.
C
      CALL DRDLAT ( R, LONG, LAT, INJACB )

C
C     Now invert INJACB to get the Jacobian of the transformation from
C     rectangular to latitudinal coordinates.
C
      CALL INVORT ( INJACB, JACOBI )

      CALL CHKOUT ( 'DLATDR' )
      RETURN
      END


subroutine dgemv(trans, m, n, alpha, A, lda, x, incx, beta, y, incy)
! Simplified DGEMV that does
!     y := A*x
! We follow the BLAS signature for compatibility.  For more,
! see http://netlib.org/blas/.
  implicit none
  ! input/output
  character*1, intent(in)         :: trans
  integer, intent(in)             :: m, n, lda, incx, incy
  double precision, intent(in)    :: alpha, beta
  double precision, intent(in)    :: A(m, n)
  double precision, intent(in)    :: x(n)
  double precision, intent(inout) :: y(m)
  ! local
  integer :: i, j
  ! do y = A*x
  do i = 1, n
    do j = 1, n
      y(i) = y(i) + A(i, j) * x(j)
    end do
  end do
end subroutine dgemv


! Check that parameters are correct intercepted.
! Constants with comma separations are commonly
! used, for instance Pi = 3._dp
subroutine foo_compound_int(x)
  implicit none
  integer, parameter :: ii = selected_int_kind(9)
  integer(ii), intent(inout) :: x
  dimension x(3)
  integer(ii), parameter :: three = 3_ii
  integer(ii), parameter :: two = 2_ii
  integer(ii), parameter :: six = three * 1_ii * two

  x(1) = x(1) + x(2) + x(3) * six
  return
end subroutine


! Copyright (C) 2017-2019 Matthieu Ancellin
! See LICENSE file at <https://github.com/mancellin/libDelhommeau>
MODULE INITIALIZE_GREEN_WAVE

  USE CONSTANTS

  IMPLICIT NONE

  PUBLIC :: EXP_E1
  PUBLIC :: INITIALIZE_TABULATED_INTEGRALS
  PUBLIC :: FF

CONTAINS

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

  FUNCTION EXP_E1(ZZ)
    ! Estimation of exp(z)·E1(z) where E1(z) = ∫_z^∞ exp(-t)/t dt
    ! See p.367 of G. Delhommeau thesis (referenced as [Del]).

    ! This routine is only used in the following subroutine to compute the tabulated integrals

    ! The computation is done is single precision.

    COMPLEX(KIND=PRE),      INTENT(IN)  :: ZZ
    COMPLEX(KIND=PRE)                   :: EXP_E1
    COMPLEX(KIND=KIND(1e0))             :: G, Y, Z

    Z = CMPLX(ZZ, KIND=KIND(1e0))
    IF (REAL(Z) < -16.0) THEN                                      ! Case 1 p. 368 in [Del]
      Y = 1./Z
      G = Y*(1.+Y*(-1.+Y*(2.+Y*(-6.+Y*(24.+Y*(-120.))))))
    ELSE IF (ABS(AIMAG(Z)) > 10.0) THEN                            ! Case 3 p. 368 in [Del]
      G = 0.711093/(Z+0.415775)+0.278518/(Z+2.29428)+0.010389/(Z+6.2900)
    ELSE IF (REAL(Z) > -0.5) THEN                                  ! Case 2 p. 368 in [Del]
      G = -(LOG(Z)*(.1E+01+Z*(0.23721365E+00+Z*(0.206543E-01+Z*(0.763297E-03+     &
        Z*0.97087007E-05))))+0.5772156649E+00*(0.99999207E+00+                    &
        Z*(-0.149545886E+01+Z*(0.41806426E-01+Z*(-0.3000591E-01+                  &
        Z*(0.19387339E-02+Z*(-0.51801555E-03)))))))/(0.1E+01+                     &
        Z*(-0.76273617E+00+Z*(0.28388363E+00+Z*(-0.66786033E-01+Z*(0.12982719E-01 &
        +Z*(-0.8700861E-03+Z*0.2989204E-03))))))
    ELSE                                                           ! Case 4 p. 369 in [Del]
      IF (AIMAG(Z) < 0) THEN
        G = ((((((( (1.000000, 1.3935496E-06)*Z+ (15.82958, -20.14222))   &
          *Z+ (-70.52863, -227.9511))*Z+ (-985.4221, -226.6272))*Z        &
          + (-1202.318, 1580.907))*Z+ (953.2441, 1342.447))*Z             &
          + (417.3716, -196.6665))*Z+ (-9.881266, -24.24952))/            &
          (((((((( (1.000000, 0.0000000E+00)*Z+ (16.83184, -20.14481))*Z  &
          + (-55.66969, -248.1167))*Z+ (-1068.640, -434.4707))*Z          &
          + (-2082.250, 1522.471))*Z+ (383.3455, 2730.378))*Z             &
          + (1216.791, 351.7189))*Z+ (115.3926, -161.2647))*Z             &
          + (-3.777369, -4.510900))
      ELSE
        G = ((((((( (1.000000, -1.3935496E-06)*Z+ (15.82958, 20.14222))   &
          *Z+ (-70.52863, 227.9511))*Z+ (-985.4221, 226.6272))*Z          &
          + (-1202.318, -1580.907))*Z+ (953.2441, -1342.447))*Z           &
          + (417.3716, 196.6665))*Z+ (-9.881266, 24.24952))/              &
          (((((((( (1.000000, 0.0000000E+00)*Z+ (16.83184, 20.14481))*Z   &
          + (-55.66969, 248.1167))*Z+ (-1068.640, 434.4707))*Z            &
          + (-2082.250, -1522.471))*Z+ (383.3455, -2730.378))*Z           &
          + (1216.791, -351.7189))*Z+ (115.3926, 161.2647))*Z             &
          + (-3.777369, 4.510900))
      END IF
    END IF
    EXP_E1 = CMPLX(G, KIND=PRE)

  END FUNCTION EXP_E1

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

  SUBROUTINE INITIALIZE_TABULATED_INTEGRALS(NB_POINTS_X, NB_POINTS_Z, NB_INTEGRATION_POINTS, X, Z, TABULATION)
    ! Compute the tabulated integrals for the wave part of the Green function.
    ! These tables are independant of the mesh and of the frequency.
    ! They are only initialised once at the beginning of the program.

    ! References:
    ! [1] Delhommeau, Amélioration des codes de calcul de diffraction-radiation, 2èmes journées de l'hydrodynamique, 1989
    ! [2] Babarit and Delhommeau, Theoretical and numerical aspects of the open source BEM solver NEMOH, EWTEC 2015
    ! [3] Xie et al., Comparison of existing methods for the calculation of the infinite water depth free-surface Green
    !                 function for the wave-structure interaction problem, Applied Ocean Research, 2018

    ! Inputs
    INTEGER, INTENT(IN) :: NB_POINTS_X     != 328
    INTEGER, INTENT(IN) :: NB_POINTS_Z     != 46
    INTEGER, INTENT(IN) :: NB_INTEGRATION_POINTS

    ! Outputs
    REAL(KIND=PRE), DIMENSION(NB_POINTS_X),                    INTENT(OUT) :: X
    REAL(KIND=PRE), DIMENSION(NB_POINTS_Z),                    INTENT(OUT) :: Z
    REAL(KIND=PRE), DIMENSION(NB_POINTS_X, NB_POINTS_Z, 2, 2), INTENT(OUT) :: TABULATION

    ! Local variables
    INTEGER :: I, J, K
    REAL(KIND=PRE) :: THETA(NB_INTEGRATION_POINTS), CQT(NB_INTEGRATION_POINTS)
    REAL(KIND=PRE) :: COSTHETA
    COMPLEX(KIND=PRE) :: JZETA, ZETA, EXPZETA

    ! Initialize Z axis
    DO J = 1, NB_POINTS_Z
      Z(J) = -AMIN1(10**(J/5.0-6), 10**(J/8.0-4.5), 16.)
    END DO

    ! Initialize X axis
    X(1) = 0.0
    DO I = 2, NB_POINTS_X
      IF (I < 40) THEN
        X(I) = AMIN1(10**((I-1.0)/5-6), 4.0/3.0 + ABS(I-32)/3.0)
      ELSE
        X(I) = 4.0/3.0 + ABS(I-32)/3.0
      ENDIF
    END DO

    ! Initialize THETA and CQT for the integration between -pi/2 and pi/2 with the Simpson rule.
    DO K = 1, NB_INTEGRATION_POINTS
      THETA(K) = -PI/2 + (K-1.0)/(NB_INTEGRATION_POINTS-1.0)*PI  ! The 1.0 are here on purpose to force the recasting of K and NB_INTEGRATION_POINTS as floats.
      IF ((K == 1) .OR. (K == NB_INTEGRATION_POINTS)) THEN
        CQT(K) = PI/(3*(NB_INTEGRATION_POINTS-1))
      ELSEIF (MOD(K,2)==0) THEN
        CQT(K) = 4.0/(3*(NB_INTEGRATION_POINTS-1))*PI
      ELSE
        CQT(K) = 2.0/(3*(NB_INTEGRATION_POINTS-1))*PI
      ENDIF
    ENDDO

    ! Compute tabulation
    TABULATION(:, :, :, :) = 0.0
    DO I = 1, NB_POINTS_X
      DO J = 1, NB_POINTS_Z
        DO K = 1, NB_INTEGRATION_POINTS
          COSTHETA = COS(THETA(K))
          ZETA = CMPLX(Z(J), X(I)*COSTHETA, KIND=PRE)
          IF (REAL(ZETA) <= -30.0) THEN
            EXPZETA = (0.0, 0.0)
          ELSE
            EXPZETA = EXP(ZETA)
          ENDIF
          IF (AIMAG(ZETA) < 0) THEN
            JZETA = EXP_E1(ZETA) - II*PI*EXPZETA
          ELSE
            JZETA = EXP_E1(ZETA) + II*PI*EXPZETA
          END IF
          TABULATION(I, J, 1, 1) = TABULATION(I, J, 1, 1) + CQT(K)*COSTHETA*AIMAG(JZETA - 1.0/ZETA) ! D_1 in [1, 2, 3]
          TABULATION(I, J, 2, 1) = TABULATION(I, J, 2, 1) + CQT(K)*COSTHETA*AIMAG(EXPZETA)          ! D_2 in [1, 2, 3]
#ifdef XIE_CORRECTION
          TABULATION(I, J, 1, 2) = TABULATION(I, J, 1, 2) + CQT(K)*REAL(JZETA)                      ! Z_1 in [3]
#else
          TABULATION(I, J, 1, 2) = TABULATION(I, J, 1, 2) + CQT(K)*REAL(JZETA - 1.0/ZETA)           ! Z_1 in [1, 2]
#endif
          TABULATION(I, J, 2, 2) = TABULATION(I, J, 2, 2) + CQT(K)*REAL(EXPZETA)                    ! Z_2 in [1, 2, 3]
        END DO
      END DO
    END DO

    RETURN

  END SUBROUTINE INITIALIZE_TABULATED_INTEGRALS

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

  FUNCTION FF(XTT, AK, AM)
    ! A function that will be Prony-decomposed for the finite-depth Green function.
    ! See the method "find_best_exponential_decomposition" in green_functions/delhommeau.py.

    ! Input
    REAL(KIND=PRE), INTENT(IN) :: XTT, AK, AM

    ! Local variables
    REAL(KIND=PRE) :: COEF, TOL, A, B, C, D, E, F, FF

    COEF = (AM+AK)**2/(AM**2-AK**2+AK)

    TOL = MAX(0.1, 0.1*AM)
    IF (ABS(XTT-AM) > TOL) THEN
      FF = (XTT+AK)*EXP(XTT)/(XTT*SINH(XTT)-AK*COSH(XTT)) - COEF/(XTT-AM) - 2
    ELSE
      A = AM - TOL
      B = AM
      C = AM + TOL
      D = (A+AK)*EXP(A)/(A*SINH(A)-AK*COSH(A)) - COEF/(A-AM) - 2
      E = COEF/(AM+AK)*(AM+AK+1)               - (COEF/(AM+AK))**2*AM - 2
      F = (C+AK)*EXP(C)/(C*SINH(C)-AK*COSH(C)) - COEF/(C-AM) - 2
      FF = D*(XTT-B)*(XTT-C)/((A-B)*(A-C)) + &
           E*(XTT-C)*(XTT-A)/((B-C)*(B-A)) + &
           F*(XTT-A)*(XTT-B)/((C-A)*(C-B))
    ENDIF

    RETURN
  END FUNCTION FF

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

END MODULE INITIALIZE_GREEN_WAVE


C++--------------------------------------------------------------------
C COORD_SCHMIDT
C Quick program to obtain the approximative (very approximative...)
C coordinates from a schmidt plate when the centre is known.
C--------------------------------------------------------------------
	PROGRAM COORD_SCHMIDT
	PRINT *,' X AND Y IN MM FROM THE BOTTOM LEFT HAND CORNER ?'
	PRINT *,'          (REALS)'
	READ(5,*) X,Y
	PRINT *,' R.A. AND DEC. OF THE CENTER OF THE PLATE ?'
	PRINT *,'          (FORMAT: H,MN,S,D,MN,S    ...INTEGERS)'
	READ(5,*) IRAC0,IRAC1,IRAC2,IDEC0,IDEC1,IDEC2
	RAC0=FLOAT(IRAC0)
	RAC1=FLOAT(IRAC1)
	RAC2=FLOAT(IRAC2)
	DEC0=FLOAT(IDEC0)
	DEC1=FLOAT(IDEC1)
	DEC2=FLOAT(IDEC2)

C Conversion into arcseconds
	RAC00=((RAC0*60.+RAC1)*60.+RAC2)*15.
	DEC00=(DEC0*60.+DEC1)*60.+DEC2
	WORK=DEC00/3600.
	SCALEX=67.1/COSD(WORK)
	IF(SCALEX.LT.0.)SCALEX=-1.*SCALEX
	PRINT *,' SCALE IN X:',SCALEX
	SCALEY=67.1
	DELTAX=(X-172.5)*SCALEX
	DELTAY=(Y-172.5)*SCALEY
	PRINT *,' OFFSET IN X AND Y:',DELTAX,DELTAY
	PRINT *,'(IN ARCSECONDS)'
C
	RA00=RAC00-DELTAX
	DE00=DEC00+DELTAY
	PRINT *,' VALUES OF RA00 AND DE00:',RA00,DE00
C Output: conversion to hours, mn, sec
	RA00=RA00/15.
	WORK1=RA00/3600.
	IRA0=IFIX(WORK1)
	WORK2=(WORK1-FLOAT(IFIX(WORK1)))*60.
	IRA1=IFIX(WORK2)
	RA2=(WORK2-FLOAT(IFIX(WORK2)))*60.
C Output: conversion to degrees ' "
	WORK1=DE00/3600.
	IF(DE00.LT.0.)WORK1=-1.*WORK1
	IDE0=IFIX(WORK1)
	IF(DE00.LT.0.)IDE0=-1*IDE0
	WORK2=(WORK1-FLOAT(IFIX(WORK1)))*60.
	IDE1=IFIX(WORK2)
	DE2=(WORK2-FLOAT(IFIX(WORK2)))*60.
C
	PRINT 100,IRA0,IRA1,RA2,IDE0,IDE1,DE2
100	FORMAT(' RIGHT ASCENSION :',4X,I3,' H ',2X,I3,' MN  ',
     1	F5.2,' S',/,
     1	' DECLINATION :',8X,I3,' DEG',X,I3,' MN  ',
     1	F5.2,' S')
	STOP
	END


c$Header: /data/petsun4/data1/src_solaris/librms/RCS/determ12.f,v 1.1 2007/06/19 22:34:50 avi Exp $
c$Log: determ12.f,v $
c Revision 1.1  2007/06/19  22:34:50  avi
c Initial revision
c
      real*4 function determ12(a,det)
      real*4 a(4,4)

      det=+a(1,1)*(a(2,2)*a(3,3)-a(2,3)*a(3,2))
     &    -a(1,2)*(a(2,1)*a(3,3)-a(2,3)*a(3,1))
     &    +a(1,3)*(a(2,1)*a(3,2)-a(2,2)*a(3,1))

      determ12 = det
      return
      end


      REAL FUNCTION INTG8(F,A,B,DX)	!Integrate function F.
       EXTERNAL F	!Some function of one parameter.
       REAL A,B		!Bounds.
       REAL DX		!Step.
       INTEGER N	!A counter.
        INTG8 = F(A) + F(B)	!Get the ends exactly.
        N = (B - A)/DX		!Truncates. Ignore A + N*DX = B chances.
        DO I = 1,N		!Step along the interior.
          INTG8 = INTG8 + F(A + I*DX)	!Evaluate the function.
        END DO			!On to the next.
        INTG8 = INTG8/(N + 2)*(B - A)	!Average value times interval width.
      END FUNCTION INTG8	!This is not a good calculation!

      FUNCTION TRIAL(X)		!Some user-written function.
       REAL X
        TRIAL = 1 + X		!This will do.
      END FUNCTION TRIAL	!Not the name of a library function.

      PROGRAM POKE
      INTRINSIC SIN	!Thus, not an (undeclared) ordinary variable.
      EXTERNAL TRIAL	!Likewise, but also, not an intrinsic function.
      REAL INTG8	!Don't look for the result in an integer place.
       WRITE (6,*) "Result=",INTG8(SIN,  0.0,8*ATAN(1.0),0.01)
       WRITE (6,*) "Linear=",INTG8(TRIAL,0.0,1.0,        0.01)
      END


! -*- mode: F90; mode: font-lock; column-number-mode: true -*-
! ------------------------------------------------------------------------------
! $Id$
! ------------------------------------------------------------------------------
! Module functions
! ------------------------------------------------------------------------------
! Code area 9: general
! ------------------------------------------------------------------------------

!!****h* Conquest/functions *
!!  NAME
!!   functions
!!  PURPOSE
!!   Collects mathematical functions in one module
!!  AUTHOR
!!   D.R.Bowler
!!  CREATION DATE
!!   2016/02/09
!!  MODIFICATION HISTORY
!!  SOURCE
!!
module functions

  implicit none

  ! -------------------------------------------------------
  ! RCS ident string for object file id
  ! -------------------------------------------------------
  character(len=80), private :: RCSid = "$Id$"
  !!***

contains

  ! -----------------------------------------------------------
  ! Function erfc
  ! -----------------------------------------------------------

  !!****f* DiagModle/erfc *
  !!
  !!  NAME
  !!   erfc
  !!  USAGE
  !!   erfc(x)
  !!  PURPOSE
  !!   Calculated the complementary error function to rounding-error
  !!   based on erfc() in ewald_module
  !!   accuracy
  !!  INPUTS
  !!   real(double) :: x, argument of complementary error function
  !!  AUTHOR
  !!   Iain Chapman/Lianeng Tong
  !!  CREATION DATE
  !!   2001 sometime/2010/07/26
  !!  MODIFICATION HISTORY
  !!   2016/02/09 08:14 dave
  !!    Moved to functions module from DiagModule
  !!  SOURCE
  !!
  real(double) function erfc(x)

    use datatypes
    use numbers,  only: RD_ERR, one, zero, half, two
    use GenComms, only: cq_abort

    implicit none

    real(double), parameter :: erfc_delta = 1.0e-12_double, &
         erfc_gln = 0.5723649429247447e0_double, &
         erfc_fpmax = 1.e30_double
    integer, parameter:: erfc_iterations = 10000

    real(double), intent(in) :: x

    ! local variables
    real(double) :: y, y2
    real(double) :: ap, sum, del
    real(double) :: an, b, c, d, h
    integer :: i

    if(x < zero) then
       y = -x
    else
       y = x
    end if
    ! This expects y^2
    y2 = y*y
    if(y<RD_ERR) then
       erfc = one
       return
    end if
    if (y2 < 2.25_double) then
       ap = half
       sum = two
       del = sum
       do i = 1, erfc_iterations
          ap = ap + 1.0_double
          del = del * y2 / ap
          sum = sum + del
          if (abs(del) < abs(sum) * erfc_delta) exit
       end do
       erfc = one - sum * exp(-y2 + half * log(y2) - erfc_gln)
    else
       b = y2 + half
       c = erfc_fpmax
       d = one / b
       sum = d
       do i = 1, erfc_iterations
          an = - i * (i - half)
          b = b + two
          d = an * d + b
          c = b + an / c
          d = one / d
          del = d * c
          sum = sum * del
          if (abs(del - one) < erfc_delta) exit
       end do
       erfc = sum * exp(-y2 + half * log(y2) - erfc_gln)
    end if
    if (x < zero) erfc = two - erfc
    return
  end function erfc
  !!***

!!****f* functions/j0 *
!!
!!  NAME
!!   j0
!!  USAGE
!!
!!  PURPOSE
!!   Calculates 0th-order Bessel function
!! INPUTS
!!   x
!! OUTPUTS
!!
!!  USES
!!
!!  AUTHOR
!!   N. Watanabe (Mizuho) with TM, DRB
!!  CREATION DATE
!!   2014
!!  MODIFICATION HISTORY
!!   2015/11/09 17:28 dave
!!    - Moved into pseudo_tm_module
!!   2016/02/09 08:23 dave
!!    Moved into functions module
!!  SOURCE
!!
  function j0( x )

    use datatypes
    use numbers, only: very_small, one_sixth, one

    implicit none

    real(double) :: x
    real(double) :: j0

    if( x<very_small ) then
       j0 = one - one_sixth*x*x
    else
       j0 = sin(x)/x
    endif
  end function j0
!!***

!!****f* functions/j1 *
!!
!!  NAME
!!   j1
!!  USAGE
!!
!!  PURPOSE
!!   1st order bessel function with provision for very small numbers
!!  INPUTS
!!
!!
!!  USES
!!
!!  AUTHOR
!!   NW (Mizuho) with TM and DRB
!!  CREATION DATE
!!   Mid 2014
!!  MODIFICATION HISTORY
!!   2016/02/09 08:24 dave
!!    Moved to functions module
!!  SOURCE
!!
  function j1x( x )

    use datatypes
    use numbers

    implicit none

    real(double) :: x
    real(double) :: j1x

    if( x<very_small ) then
       j1x = one_third - one/30.0_double*x*x
    else
       j1x = (sin(x)-x*cos(x))/(x*x*x)
    endif
  end function j1x
!!***

end module functions


Module statistical_data_mod
!
  Use kind_parameters_mod
!
  Implicit None
!
  Private
  Public Statistical_Data
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
  Type Statistical_Data
!
     Private
     Real(KIND=rkind), Allocatable, Dimension(:) :: data
     Real(KIND=rkind)                            ::  median,          mean,          variance,          std_dev,          skewness,          kurtosis
     Logical                                     :: Dmedian=.false., Dmean=.false., Dvariance=.false., Dstd_dev=.false., Dskewness=.false., Dkurtosis=.false.
!
  Contains
!
     Procedure :: set_data, clear_data
     Procedure :: get_elemental_data, get_array_data
!
     Procedure, Private :: Statistical_Median
     Procedure, Private :: Statistical_Mean
     Procedure, Private :: Statistical_Variance
     Procedure, Private :: Statistical_Std_Dev
     Procedure, Private :: Statistical_Skewness
     Procedure, Private :: Statistical_Kurtosis
!
     Generic :: get_data     => get_elemental_data, get_array_data
!
     Generic :: get_median   => Statistical_Median
     Generic :: get_mean     => Statistical_Mean
     Generic :: get_variance => Statistical_Variance
     Generic :: get_std_dev  => Statistical_Std_Dev
     Generic :: get_skewness => Statistical_Skewness
     Generic :: get_kurtosis => Statistical_Kurtosis
!
  End Type Statistical_Data
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
  Interface
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
     Module Function Statistical_Median ( this ) Result ( median )
       Implicit None
       Class ( Statistical_Data ) ,Intent(inout) :: this
       Real(KIND=rkind)                          :: median
     End Function Statistical_Median
!
     Module Function Statistical_Mean ( this ) Result ( mean )
       Implicit None
       Class ( Statistical_Data ) ,Intent(inout) :: this
       Real(KIND=rkind)                          :: mean
     End Function Statistical_Mean
!
     Module Function Statistical_Variance ( this, mean ) Result ( variance )
       Implicit None
       Class ( Statistical_Data ), Intent(inout) :: this
       Real(KIND=rkind), Optional, Intent(in)    :: mean
       Real(KIND=rkind)                          :: variance
     End Function Statistical_Variance
!
     Module Function Statistical_Std_Dev ( this, mean ) Result ( std_dev )
       Implicit None
       Class ( Statistical_Data ), Intent(inout) :: this
       Real(KIND=rkind), Optional, Intent(in)    :: mean
       Real(KIND=rkind)                          :: std_dev
     End Function Statistical_Std_Dev
!
     Module Function Statistical_Skewness ( this, mean, std_dev ) Result ( skewness )
       Implicit None
       Class ( Statistical_Data ), Intent(inout) :: this
       Real(KIND=rkind), Optional, Intent(in)    :: mean
       Real(KIND=rkind), Optional, Intent(in)    :: std_dev
       Real(KIND=rkind)                          :: skewness
     End Function Statistical_Skewness
!
     Module Function Statistical_Kurtosis ( this, mean, std_dev ) Result ( kurtosis )
       Implicit None
       Class ( Statistical_Data ), Intent(inout) :: this
       Real(KIND=rkind), Optional, Intent(in)    :: mean
       Real(KIND=rkind), Optional, Intent(in)    :: std_dev
       Real(KIND=rkind)                          :: kurtosis
     End Function Statistical_Kurtosis
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
     Module Subroutine set_data ( this, array )
       Implicit None
       Class ( Statistical_Data ),     Intent(inout) :: this
       Real(KIND=rkind), Dimension(:), Intent(in)    :: array
     End Subroutine set_data
!
     Module Subroutine clear_data ( this )
       Implicit None
       Class ( Statistical_Data ), Intent(inout) :: this
     End Subroutine clear_data
!
     Module Function get_elemental_data ( this, d ) Result ( data )
       Implicit None
       Class ( Statistical_Data ), Intent(inout) :: this
       Integer(KIND=ikind),        Intent(in)    :: d
       Real   (KIND=rkind)                       :: data
     End Function get_elemental_data
!
     Module Function get_array_data ( this ) Result ( data )
       Implicit None
       Class ( Statistical_Data ), Intent(inout)   :: this
       Real(KIND=rkind), Allocatable, Dimension(:) :: data
     End Function get_array_data
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
  End Interface
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
End Module statistical_data_mod