      parameter (Nx=360,Ny=180,Mrey=421,nweeks=52,nyrs=11)
      real sst(Nx*Ny),sstav(nweeks,Nx*Ny),sstanom(Nx*Ny)
      integer npts(nweeks,Nx*Ny)
      integer istart(nyrs)
      data istart/1,53,105,157,209,262,314,366,418,470,522/    ! 93-03   (97 has 53 weeks)
      nxy=Nx*Ny

      open(20,file='REYv2_sst_93-03',form='unformatted',access=
     *'direct',recl=Nx*Ny*4,status='old')

      DO iweek=1,52
        do iyr=	1,nyrs
	  irec=istart(iyr)+iweek-1
	    if(irec.le.Mrey)then
              read(20,rec=IREC)sst
              do ij=1,Nxy
		if(sst(ij).ne.-9999.)then
                  sstav(iweek,ij)=sstav(iweek,ij)+sst(ij)
	          npts(iweek,ij)=npts(iweek,ij)+1
		endif
              enddo
	    endif
	enddo
      ENDDO

      open(30,file='REYv2_sst_93-03_wklymean',form='unformatted',
     *     access='direct',recl=Nx*Ny*4,status='unknown')
      DO iweek=1,52
	do ij=1,Nxy
	  if(npts(iweek,ij).ne.0)then
	    sstav(iweek,ij)=sstav(iweek,ij)/npts(iweek,ij)
	  else
	    sstav(iweek,ij)=-9999.
	  endif
	enddo
	write(30,rec=iweek)(sstav(iweek,ij),ij=1,Nxy)
      ENDDO
      endfile(30)

      open(30,file='REYv2_sst_93-03_wklypanom',form='unformatted',
     *     access='direct',recl=Nx*Ny*4,status='unknown')
      DO iweek=1,52
        do iyr=	1,nyrs
	  irec=istart(iyr)+iweek-1
	    if(irec.le.Mrey)then
              read(20,rec=IREC)sst
              do ij=1,Nxy
		if(sst(ij).ne.-9999.)then
                  sstanom(ij)=sst(ij)-sstav(iweek,ij)
		else
		  sstanom(ij)=-9999.
		endif
              enddo
	    endif
	write(30,rec=irec)sstanom
	enddo
      ENDDO

      irec=261    ! 53rd week of 97
      read(30,rec=irec-1)sstanom
      read(30,rec=irec+1)sst
      do ij=1,Nxy
	if(sstanom(ij).ne.-9999..and.sst(ij).ne.-9999.)then
	  sstanom(ij)=(sstanom(ij)+sst(ij))/2.
	else
	  sstanom(ij)=-9999.
	endif
      enddo
      write(30,rec=irec)sstanom
      endfile(30)

      stop
      end


module hsmooth_mod
    implicit none
    integer :: m_polar = -1

    double precision, dimension(:), allocatable :: x0_polar,y0_polar
    double precision, dimension(:), allocatable :: r0_polar,r1_polar
    integer, dimension(:), allocatable :: n_polar

    double precision eps_disk

contains
    subroutine allocate_polar_arrays()
        implicit none

        if (m_polar .lt. 0) then
            write(6,*) 'hsmooth:allocate_polar_array : m_polar is not defined'
            stop
        endif

        allocate(x0_polar(m_polar), y0_polar(m_polar),r0_polar(m_polar), &
                 r1_polar(m_polar), n_polar(m_polar))
    end subroutine allocate_polar_arrays
end module hsmooth_mod

double precision function polar_interface(id,theta)
    implicit none

    double precision theta
    integer id

    double precision p, dpdt, d2pdt2

    call polar_interface_complete(id,theta, p, dPdt, d2pdt2)
    polar_interface = p

end function polar_interface

subroutine polar_interface_complete(id,theta, p, dPdtheta, d2Pdtheta2)
    use hsmooth_mod, only : r0_polar, r1_polar, n_polar
    implicit none

    double precision theta, P, dPdtheta, d2Pdtheta2
    integer id

    double precision r0, r1, n

    r0 = r0_polar(id)
    r1 = r1_polar(id)
    n = n_polar(id)

    p = r0*(1 + r1*cos(n*theta))
    dpdtheta   = r0*(-n*r1*sin(n*theta))
    d2Pdtheta2 = r0*(-n**2*r1*cos(n*theta))

end subroutine polar_interface_complete

double precision function Hsmooth(id,r,theta)
    use hsmooth_mod, only : eps_disk
    implicit none

    double precision r, theta
    integer id

    double precision p, polar_interface, a

    a = eps_disk

    P = polar_interface(id,theta)
    Hsmooth = (tanh((r-P)/a) + 1)/2.d0

end function Hsmooth

subroutine Hsmooth_grad(id,r,theta,grad_H)
    use hsmooth_mod, only : eps_disk
    implicit none

    double precision r, theta, grad_H(2)
    integer id

    double precision a, a2, sech, sech2, p, dpdt, dp2dt2

    if (r .eq. 0) then
        r = 1d-15
    endif

    a = eps_disk
    a2 = 2*a

    call polar_interface_complete(id,theta,P,dpdt,dp2dt2)

    sech2 = sech((r-P)/a)**2
    grad_H(1) = sech2/a2
    grad_H(2) = -dpdt*sech2/(a2*r)

end subroutine Hsmooth_grad

double precision function Hsmooth_laplacian(id,r,theta)
    use hsmooth_mod, only : eps_disk
    implicit none

    double precision r, theta
    integer id

    double precision sech, a, a2, r2, p, dpdt, d2pdt2
    double precision s1, s2, s3, s4, t, sech2, st

    if (r .eq. 0) then
        r = 1d-15
    endif

    a = eps_disk
    a2 = a**2
    r2 = r**2

    call polar_interface_complete(id,theta,p,dpdt,d2pdt2)

    sech2 = sech((r-p)/a)**2
    t = tanh((r-p)/a)
    st = t*sech2
    s1 = dpdt**2*st/a2
    s2 = d2pdt2*sech2/(2*a)
    s3 = st/a2
    s4 = sech2/(2*a*r)
    Hsmooth_laplacian = (-s1-s2)/r2 - s3 + s4

end function Hsmooth_laplacian


*DECK DXQMU
      SUBROUTINE DXQMU (NU1, NU2, MU1, MU2, THETA, X, SX, ID, PQA, IPQA,
     1   IERROR)
C***BEGIN PROLOGUE  DXQMU
C***SUBSIDIARY
C***PURPOSE  To compute the values of Legendre functions for DXLEGF.
C            Method: forward mu-wise recurrence for Q(MU,NU,X) for fixed
C            nu to obtain Q(MU1,NU,X), Q(MU1+1,NU,X), ..., Q(MU2,NU,X).
C***LIBRARY   SLATEC
C***CATEGORY  C3A2, C9
C***TYPE      DOUBLE PRECISION (XQMU-S, DXQMU-D)
C***KEYWORDS  LEGENDRE FUNCTIONS
C***AUTHOR  Smith, John M., (NBS and George Mason University)
C***ROUTINES CALLED  DXADD, DXADJ, DXPQNU
C***REVISION HISTORY  (YYMMDD)
C   820728  DATE WRITTEN
C   890126  Revised to meet SLATEC CML recommendations.  (DWL and JMS)
C   901019  Revisions to prologue.  (DWL and WRB)
C   901106  Corrected order of sections in prologue and added TYPE
C           section.  (WRB)
C   920127  Revised PURPOSE section of prologue.  (DWL)
C***END PROLOGUE  DXQMU
      DIMENSION PQA(*),IPQA(*)
      DOUBLE PRECISION DMU,NU,NU1,NU2,PQ,PQA,PQ1,PQ2,SX,X,X1,X2
      DOUBLE PRECISION THETA
C***FIRST EXECUTABLE STATEMENT  DXQMU
      IERROR=0
      MU=0
C
C        CALL DXPQNU TO OBTAIN Q(0.,NU1,X)
C
      CALL DXPQNU(NU1,NU2,MU,THETA,ID,PQA,IPQA,IERROR)
      IF (IERROR.NE.0) RETURN
      PQ2=PQA(1)
      IPQ2=IPQA(1)
      MU=1
C
C        CALL DXPQNU TO OBTAIN Q(1.,NU1,X)
C
      CALL DXPQNU(NU1,NU2,MU,THETA,ID,PQA,IPQA,IERROR)
      IF (IERROR.NE.0) RETURN
      NU=NU1
      K=0
      MU=1
      DMU=1.D0
      PQ1=PQA(1)
      IPQ1=IPQA(1)
      IF(MU1.GT.0) GO TO 310
      K=K+1
      PQA(K)=PQ2
      IPQA(K)=IPQ2
      IF(MU2.LT.1) GO TO 330
  310 IF(MU1.GT.1) GO TO 320
      K=K+1
      PQA(K)=PQ1
      IPQA(K)=IPQ1
      IF(MU2.LE.1) GO TO 330
  320 CONTINUE
C
C        FORWARD RECURRENCE IN MU TO OBTAIN
C                  Q(MU1,NU,X),Q(MU1+1,NU,X),....,Q(MU2,NU,X) USING
C             Q(MU+1,NU,X)=-2.*MU*X*SQRT(1./(1.-X**2))*Q(MU,NU,X)
C                               -(NU+MU)*(NU-MU+1.)*Q(MU-1,NU,X)
C
      X1=-2.D0*DMU*X*SX*PQ1
      X2=(NU+DMU)*(NU-DMU+1.D0)*PQ2
      CALL DXADD(X1,IPQ1,-X2,IPQ2,PQ,IPQ,IERROR)
      IF (IERROR.NE.0) RETURN
      CALL DXADJ(PQ,IPQ,IERROR)
      IF (IERROR.NE.0) RETURN
      PQ2=PQ1
      IPQ2=IPQ1
      PQ1=PQ
      IPQ1=IPQ
      MU=MU+1
      DMU=DMU+1.D0
      IF(MU.LT.MU1) GO TO 320
      K=K+1
      PQA(K)=PQ
      IPQA(K)=IPQ
      IF(MU2.GT.MU) GO TO 320
  330 RETURN
      END


program AOC

  integer :: ios, u = 42
  integer(kind=16) :: i, j, k, l, m, n
  integer, dimension(1000) :: d

  open(unit=u, file='day_7.txt', iostat=ios)
  read(u, *, iostat=ios) d

  n = -1

  do i = 1, 1000

     k = 0

     do j = 1, 1000
        if (d(j) > i) then
           l = d(j) - i
        else
           l = i - d(j)
        end if

        do m = 1, l
           k = k + m
        end do

     end do

     ! print*, "K", k, m

     if (n == -1 .or. k < n) then
        n = k
        print*, "A", n
     end if
  end do

  close(u)
end program AOC


C
      SUBROUTINE FFTRC  (A,N,X,IWK,WK)
C                                  SPECIFICATIONS FOR ARGUMENTS
      INTEGER            N,IWK(1)
      REAL*8             A(N),WK(1)
      COMPLEX*16         X(1)
C                                  SPECIFICATIONS FOR LOCAL VARIABLES
      INTEGER            ND2P1,ND2,I,MTWO,M,IMAX,ND4,NP2,K,NMK,J
      REAL*8             RPI,ZERO,ONE,HALF,THETA,TP,G(2),B(2),Z(2),AI,
     1                   AR
      COMPLEX*16         XIMAG,ALPH,BETA,GAM,S1,ZD
      EQUIVALENCE        (GAM,G(1)),(ALPH,B(1)),(Z(1),AR),(Z(2),AI),
     1                   (ZD,Z(1))
      DATA               ZERO/0.0D0/,HALF/0.5D0/,ONE/1.0D0/,IMAX/24/
      DATA               RPI/3.141592653589793D0/
C                                  FIRST EXECUTABLE STATEMENT
      IF (N .NE. 2) GO TO 5
C                                  N EQUAL TO 2
      ZD = DCMPLX(A(1),A(2))
      THETA = AR
      TP = AI
      X(2) = DCMPLX(THETA-TP,ZERO)
      X(1) = DCMPLX(THETA+TP,ZERO)
      GO TO 9005
    5 CONTINUE
C                                  N GREATER THAN 2
      ND2 = N/2
      ND2P1 = ND2+1
C                                  MOVE A TO X
      J = 1
      DO 6 I=1,ND2
         X(I) = DCMPLX(A(J),A(J+1))
         J = J+2
    6 CONTINUE
C                                  COMPUTE THE CENTER COEFFICIENT
      GAM = DCMPLX(ZERO,ZERO)
      DO 10 I=1,ND2
         GAM = GAM + X(I)
   10 CONTINUE
      TP = G(1)-G(2)
      GAM = DCMPLX(TP,ZERO)
C                                  DETERMINE THE SMALLEST M SUCH THAT
C                                  N IS LESS THAN OR EQUAL TO 2**M
      MTWO = 2
      M = 1
      DO 15 I=1,IMAX
         IF (ND2 .LE. MTWO) GO TO 20
         MTWO = MTWO+MTWO
         M = M+1
   15 CONTINUE
   20 IF (ND2 .EQ. MTWO) GO TO 25
C                                  N IS NOT A POWER OF TWO, CALL FFTCC
      CALL FFTCC (X,ND2,IWK,WK)
      GO TO 30
C                                  N IS A POWER OF TWO, CALL FFT2C
   25 CALL FFT2C (X,M,IWK)
   30 ALPH = X(1)
      X(1) = B(1) + B(2)
      ND4 = (ND2+1)/2
      IF (ND4 .LT. 2) GO TO 40
      NP2 = ND2 + 2
      THETA = RPI/ND2
      TP = THETA
      XIMAG = DCMPLX(ZERO,ONE)
C                                  DECOMPOSE THE COMPLEX VECTOR X
C                                  INTO THE COMPONENTS OF THE TRANSFORM
C                                  OF THE INPUT DATA.
      DO 35 K = 2,ND4
         NMK = NP2 - K
         S1 = DCONJG(X(NMK))
         ALPH = X(K) + S1
         BETA = XIMAG*(S1-X(K))
         S1 = DCMPLX(DCOS(THETA),DSIN(THETA))
         X(K) = (ALPH+BETA*S1)*HALF
         X(NMK) = DCONJG(ALPH-BETA*S1)*HALF
         THETA = THETA + TP
   35 CONTINUE
   40 CONTINUE
      X(ND2P1) = GAM
 9005 RETURN
      END


C
C
*+ image_addang

      subroutine image_addang(minirt,data,uv,centre,n_angle,r_1,r_2,
     *                        gate,flux,ndata,frac_area,status      )
C     --------------------------------------------------------------
C
C To calculate the average flux in elliptical annuli
C
C Given:
C   mini redtape of image
       integer     minirt(8)
C   image data
       real*4      data(*)
C   range on image to analyse
       integer     uv(4)
C   centre of circular region
       real*4      centre(2)
C   number of angular regions
       integer     n_angle
C   minimum and maximum angular extents
       real*4      r_1, r_2
C   value above which averaging is performed
       real*4      gate
C Returned:
C   results for each annulus
C     flux
       real*4      flux(n_angle)
C     number of data points
       integer     ndata(n_angle)
C     fraction of correct annular area found by cell averaging
       real*4      frac_area(n_angle)
C   error return code
       integer     status
C
C The distribution of flux on an image centred at a given location
C and in angular bins between radii r_1 and r_2 is determined.
C
C Local variables
C  counters and sums
      integer      iu, iv, n, uv_point(2)
      equivalence (uv_point(1), iu)
      equivalence (uv_point(2), iv)
      real*4       x, y, value, rsq, areaconst, a
      real*4       r2_1, r2_2
C  constant pi
      real*4       pi
      data         pi/3.14159265/

C check status on entry
      if (status.ne.0) return

C setup regions
      r2_1 = r_1**2
      r2_2 = r_2**2

C initialise arrays
      do n = 1,n_angle
        flux(n) = 0.0
        ndata(n) = 0
      end do

      do iv = uv(3),uv(4),-1
        do iu = uv(1),uv(2)
C .. find values
          call iuvval2(minirt,data,uv_point,value,status)
C .. find bin (n) containing point (x,y)
          x = float(iu) - centre(1)
          y = float(iv) - centre(2)
          rsq = x**2 + y**2
          if ( (rsq.ge.r2_1) .and. (rsq.le.r2_2)) then
             a = atan2(y,x)
             if (a.lt.0.0) then
                a = 2.0*pi + a
             endif
             n = (a/(2.0*pi)) * n_angle + 1
C .. add flux to correct bin
             if ((n.le.n_angle) .and. (abs(value).gt.gate)) then
               flux(n) = flux(n) + value
               ndata(n) = ndata(n) + 1
             end if
          endif
        end do
      end do

C normalize and calculate fractional areas
      areaconst = pi*(r2_2 - r2_1) / float( n_angle )
      do n = 1,n_angle
        if (ndata(n) .gt. 0 ) then
          flux(n) = flux(n)/float(ndata(n))
        else
          flux(n) = 0.0
        end if
        frac_area(n) = ndata(n)/areaconst
      end do
      call cmd_err(status,'image_addang',' ')
      end


      program smooth

c***********************************************************************
c
c     dl_poly utility for smoothing data in "xvgr" type file
c     format  x,y data sets separated by &
c     lines beginning "#" = comments
c     lines beginning "@TYPE xy" => x,y data follow on following lines
c
c     smoothing algorithm from Allen and Tildesley, p204
c     3rd degree, five point smooth.
c
c     copyright daresbury laboratory 1996
c     author t.forester     March 1996
c
c***********************************************************************

      implicit real*8(a-h,o-z)
      parameter (mxn = 10000)
      dimension x(mxn),y(mxn),ys(mxn)
      character*80 oneline

      write(*,*) ' name of input file '
      read(*,*) oneline

      open(10,file=oneline,form='formatted',status='old')

      write(*,*) ' name of output file '
      read(*,*) oneline

      open(11,file=oneline,form='formatted')

      write(*,*) 'number of smooth iterations ?'
      read(*,*) nsmooth
      nsmooth = max(1,nsmooth)

  101 read(10,'(a80)',end=100) oneline

      if(oneline(1:8).eq.'@TYPE xy') then

        write(11,'(a8)') oneline

        i = 1
   10   read(10,*,end=20,err=20) x(i),y(i)
        i=i+1
        goto 10

   20   nn = i-1

        do ismooth = 1,nsmooth

        if(nn.gt.5) then

          ys(1) = 1/7.d1*(69.d0*y(1)+4.d0*y(2)-6.d0*y(3)+4.d0*y(4)
     x       -y(5))

          ys(2) = 1/35.d0*(2.d0*y(1)+27.d0*y(2)+12.d0*y(3)-8.d0*y(4)
     x       +2.d0*y(5))

          do i = 3,nn-2

            ys(i) = 1.d0/35.d0*(-3.d0*y(i-2)+12.d0*y(i-1)+17.d0*y(i)
     x         +12.d0*y(i+1)-3.d0*y(i+2))

          enddo

          ys(nn) = 1/7.d1*(69.d0*y(nn)+4.d0*y(nn-1)-6.d0*y(nn-2)
     x       +4.d0*y(nn-3) -y(nn-4))

          ys(nn-1) = 1/35.d0*(2.d0*y(nn)+27.d0*y(nn-1)+12.d0*y(nn-2)
     x       -8.d0*y(nn-3)+2.d0*y(nn-4))

          do ii = 1,nn
            y(ii) = max(ys(ii),0.d0)
          enddo

        endif

        enddo

c
c     write out smoothed results

        do i=1,nn

          write(11,'(f8.4,1p,2e15.6)') x(i),y(i)

        enddo
        write(11,*) '&'

      else

        write(11,'(a80)') oneline
      endif

      goto 101

  100 continue
      end


!--------------------------------------------------------------------------------------
!
!Copyright (C) 2014 TopCoder Inc., All Rights Reserved.
!
!--------------------------------------------------------------------------------------

!   This module solves a boundary element method for a finite or infinite depth using
!   a three dimensional higher order method. The higher order method used is based on
!   B-Spline as described in the references given below.
!   The influence matrix is setup is solved using an SVD (Singular Value Decomposition) solver.
!   More specific description can be read in section 15.5 of reference R2.
!   Here the green function and derivative are computed using a series approximation and a tabulation
!   as previously done for the lower order panel method in Nemoh.
!   After solving the influence matrix, the potential at the boundary and at the given points in the fluid domain is
!   computed. The pressure at the centroid of each patch are computed and the forces are derived.
!   The main subroutine of this module is SOLVE_POTENTIAL_HIGH
!
!                       REFERENCES
!   R1:  A three dimensional higher order panel method based on
!        B-splines. http://dspace.mit.edu/bitstream/handle/1721.1/11127/34279481.pdf?sequence=1
!
!   R2 Wamit User Manual http://www.wamit.com/manualupdate/V70_manual.pdf
!
!   R3 A higher order panel method for large-amplitude simulation of bodies in waves.
!      Ph. D. Thesis http://dspace.mit.edu/bitstream/handle/1721.1/9708/42663926.pdf?sequence=1
!
!   R4 Fast Multipole Boundary Element Method: Theory and Applications in Engineering
!   https://books.google.bj/books?id=1p4SCnM5UIYC
!   http://www.amazon.com/Fast-Multipole-Boundary-Element-Method-ebook/dp/B002TRJ076
!
!   Contest Implementation of Higher Order Panel Methods version 1.0
!
!   @author yedtoss
!   @version 1.0

MODULE SOLVE_BEM_HIGH

    USE COM_VAR
    USE ELEMENTARY_FNS
    USE UTILITY
    USE gaussm3
    USE COMMON_TYPE
    USE GREEN_FUNCTION
    USE OUTPUT
    USE M_SOLVER
    implicit none

contains

    complex FUNCTION influence_dik(u, v, param)
        ! This function computes the function to be integrated according to equation 15.32 of reference R2
        ! It does not compute the integral. So to compute the formula of equation 15.32, it is expected to call
        ! a subrouting which will integrate this function. For example:
        ! qgss2d_simple(influence_dik, -1., 1., -1., 1., 3, param)
        ! Arguments
        ! u,v coordinate in parametric space of the integral
        ! param: common variables that contains useful variables
        !        param%j is the index of the source patch (corresponding to uf)
        !        param%k is the index of the basis function in the v direction for the source patch
        !        param%i is the index of the basis function in the u direction for the source patch
        !        param%jj is the index of the field patch (corresponding to u)
        !        param%kk is the index of the basis function in the v direction for the field patch
        !        param%ii is the index of the basis function in the u direction for the field patch

        REAL, INTENT(IN) :: u, v
        TYPE(ParamsCommonInf) :: param

        influence_dik = cmplx(GET_BSPLINE(u, param%SolverVar%KNOTS_U(param%j), param%i),0)

        influence_dik = influence_dik * GET_BSPLINE(v, param%SolverVar%KNOTS_V(param%j), param%k)

        IF(param%jj /= -1 .and. param%ii /= -1 .and. param%kk /= -1) THEN
            influence_dik = influence_dik * GET_BSPLINE(u, param%SolverVar%KNOTS_U(param%jj), param%ii)
            influence_dik = influence_dik * GET_BSPLINE(v, param%SolverVar%KNOTS_V(param%jj), param%kk)
        END IF

    END FUNCTION influence_dik

    complex FUNCTION influence_si(uf, vf, param)
        ! This function computes the function of the outer integral (including the inner integral) in equation 15.34
        ! of reference R2
        ! It does not compute the integral. So to compute the whole integral of equation 15.34, it is expected to call
        ! a subrouting which will integrate this function. For example:
        ! qgss2d_simple(influence_si, -1., 1., -1., 1., 3, param)
        ! Arguments
        ! uf,vf coordinate in parametric space of the outer integral (source point)
        ! param: common variables that contains useful variables
        !        param%j is the index of the source patch (corresponding to uf)
        !        param%k is the index of the basis function in the v direction for the source patch
        !        param%i is the index of the basis function in the u direction for the source patch
        !        param%jj is the index of the field patch (corresponding to u)
        !        param%kk is the index of the basis function in the v direction for the field patch
        !        param%ii is the index of the basis function in the u direction for the field patch

        REAL, INTENT(IN) :: uf, vf
        TYPE(ParamsCommonInf) :: param

        param%uf = uf
        param%vf = vf

        influence_si = cmplx(GET_BSPLINE(uf, param%SolverVar%KNOTS_U(param%j), param%i),0)

        influence_si = influence_si * GET_BSPLINE(vf, param%SolverVar%KNOTS_V(param%j), param%k)

        influence_si = influence_si * qgss2d_simple(influence_ugreen, -1., 1., -1., 1., 3, param)

    END FUNCTION influence_si

    complex FUNCTION influence_bigdik(uf, vf, param)
        ! This function computes the function of the outer integral (including the inner integral) in equation 15.33
        ! of reference R2
        ! It does not compute the integral. So to compute the whole integral of equation 15.33, it is expected to call
        ! a subrouting which will integrate this function. For example:
        ! qgss2d_simple(influence_bigdik, -1., 1., -1., 1., 3, param)
        ! Arguments
        ! uf,vf coordinate in parametric space of the outer integral (source point)
        ! param: common variables that contains useful variables
        !        param%j is the index of the source patch (corresponding to uf)
        !        param%k is the index of the basis function in the v direction for the source patch
        !        param%i is the index of the basis function in the u direction for the source patch
        !        param%jj is the index of the field patch (corresponding to u)
        !        param%kk is the index of the basis function in the v direction for the field patch
        !        param%ii is the index of the basis function in the u direction for the field patch

        REAL, INTENT(IN) :: uf, vf
        TYPE(ParamsCommonInf) :: param

        param%uf = uf
        param%vf = vf
        influence_bigdik = qgss2d_simple(influence_udgreen, -1., 1., -1., 1., 3, param)
        influence_bigdik = influence_bigdik * GET_BSPLINE(uf, param%SolverVar%KNOTS_U(param%j), param%i)
        influence_bigdik = influence_bigdik * GET_BSPLINE(vf, param%SolverVar%KNOTS_V(param%j), param%k)

    END FUNCTION influence_bigdik

    complex FUNCTION influence_ugreen(u, v, param)
        ! This function computes the function of the inner integral in equation 15.34 of reference R2
        ! It does not compute the integral. So to compute the whole integral of equation 15.34, it is expected to call
        ! a subrouting which will integrate this function. For example:
        ! qgss2d_simple(influence_ugreen, -1., 1., -1., 1., 3, param)
        ! Note that this function simultaneously computes the function of the integral at the right hand side
        ! of equation 15.29 of reference R2
        ! Arguments
        ! u,v coordinate in parametric space of the inner integral (field point)
        ! param: common variables that contains useful variables
        !        param%j is the index of the source patch (corresponding to uf)
        !        param%k is the index of the basis function in the v direction for the source patch
        !        param%i is the index of the basis function in the u direction for the source patch
        !        param%jj is the index of the field patch (corresponding to u)
        !        param%kk is the index of the basis function in the v direction for the field patch
        !        param%ii is the index of the basis function in the u direction for the field patch

        REAL, INTENT(IN) :: u, v
        REAL::  uf, vf
        INTEGER:: panel_idxf
        TYPE(ParamsCommonInf) :: param
        complex :: tmp
        REAL:: xx, yy, zz, XPO, YPO, ZPO

        panel_idxf = param%j

        IF(param%use_cartesian_coordinate == 1) THEN
            XPO = param%xx
            YPO = param%yy
            ZPO = param%zz
        ELSE
            uf = param%uf
            vf = param%vf
            CALL transform_uv_to_cartesian(panel_idxf, uf ,vf, XPO, YPO, ZPO)

        END IF

        CALL transform_uv_to_cartesian(param%jj, u ,v, xx, yy, zz)

        influence_ugreen = cmplx(compute_jacobian(param%jj, u, v), 0)
        tmp = compute_green_wave_part(param, u, v, XPO, YPO, ZPO, param%jj)
        tmp = tmp + compute_green_rankine_part(param, u, v, XPO, YPO, ZPO, param%jj)

        influence_ugreen = influence_ugreen * tmp * COMPUTE_NORMAL_POTENTIAL(param, param%jj, xx, yy, zz)
    end FUNCTION influence_ugreen

    complex FUNCTION influence_udgreen(u, v, param)
        ! This function computes the function of the inner integral in equation 15.33 of reference R2
        ! It does not compute the integral. So to compute the whole integral of equation 15.33, it is expected to call
        ! a subrouting which will integrate this function. For example:
        ! qgss2d_simple(influence_udgreen, -1., 1., -1., 1., 3, param)
        ! Note that this function simultaneously computes the function of the integral of the last term
        ! at the left hand side of equation 15.29 of reference R2 if param%compute_potential is not 0
        ! Arguments
        ! u,v coordinate in parametric space of the inner integral (field point)
        ! param: common variables that contains useful variables
        !        param%j is the index of the source patch (corresponding to uf)
        !        param%k is the index of the basis function in the v direction for the source patch
        !        param%i is the index of the basis function in the u direction for the source patch
        !        param%jj is the index of the field patch (corresponding to u)
        !        param%kk is the index of the basis function in the v direction for the field patch
        !        param%ii is the index of the basis function in the u direction for the field patch
        REAL, INTENT(IN) :: u, v
        REAL::  uf, vf, XPO, YPO, ZPO
        INTEGER:: panel_idxf
        TYPE(ParamsCommonInf) :: param
        complex :: tmp

        panel_idxf = param%j

        IF(param%use_cartesian_coordinate == 1) THEN
            XPO = param%xx
            YPO = param%yy
            ZPO = param%zz
        ELSE
            uf = param%uf
            vf = param%vf
            CALL transform_uv_to_cartesian(panel_idxf, uf ,vf, XPO, YPO, ZPO)

        END IF

        IF(param%compute_potential == 0) THEN
            influence_udgreen = cmplx(GET_BSPLINE(u, param%SolverVar%KNOTS_U(param%jj), param%ii), 0)
        ELSE
            influence_udgreen = COMPUTE_POTENTIAL_BOUNDARY_PATCH(param%jj, u, v, param%B, param)
        END IF
        influence_udgreen = influence_udgreen * GET_BSPLINE(v, param%SolverVar%KNOTS_V(param%jj), param%kk)
        influence_udgreen = influence_udgreen * compute_jacobian(param%jj, u, v)
        tmp = compute_dgreen_wave_part(param, u, v, XPO, YPO, ZPO, param%jj)
        tmp = tmp + compute_dgreen_rankine_part(param, u, v, XPO, YPO, ZPO, param%jj)

        influence_udgreen = influence_udgreen * tmp
    END FUNCTION

    SUBROUTINE transform_cartesian_to_uv(panel_idx, xx, yy, zz, u, v)
        ! This subroutine converts a cartesian coordinate to a parametric coordinate for a panel
        ! Currently it is a mock and expected to be change in later contest if needed.
        ! The current implementation does not use it. This function could be useful if we want
        ! to compute the potential at the boundary exactly without doing any integration (as currently).
        REAL :: u,v,xx,yy,zz, r, theta, rmin, rmax, tmp
        INTEGER:: panel_idx, M(4), I
        REAL, PARAMETER :: PI=4.*ATAN(1.)

        ! Getting index of the coordinate of the 4 vertices
        M(1) = M1(panel_idx)
        M(2) = M2(panel_idx)
        M(3) = M3 (panel_idx)
        M(4) = M4 (panel_idx)
        DO I = 1, 4

            tmp = sqrt(X(M(I))**2 + Y(M(I))**2)

            IF(I == 1 .or. tmp < rmin) THEN
                rmin = tmp
            END IF

            IF(I == 1 .or. tmp > rmax) THEN
                rmax = tmp
            END IF
        END DO

        r = sqrt(xx**2 + yy**2)
        theta = atan(yy/xx)
        v = theta/PI
        u = (r -rmin/2.0 -rmax/2.0)/(-rmin/2.0 + rmax/2.0)
    END SUBROUTINE transform_cartesian_to_uv

    SUBROUTINE transform_uv_to_cartesian(panel_idx, u ,v, xx, yy, zz)
        ! This subroutine converts a parametric coordinate to a cartesian coordinate
        ! It performs it using equations 2.49 and 2.46 (with alpha=4) of reference R4
        ! The generated u,v parametric coordinate are in the range -1, 1
        !  Arguments
        ! panel_idx (input):  The id of the panel where the coordinate belong to
        ! xx, yy, zz (input): The cartesian coordinates
        !  u,v (output): The parametric coordinate
        REAL :: u,v,xx,yy,zz, r, theta, rmin, rmax, tmp, N1, N2,   N3, N4
        INTEGER:: panel_idx, M(4), I
        REAL, PARAMETER :: PI=4.*ATAN(1.)

        ! Getting index of the coordinate of the 4 vertices
        M(1) = M1(panel_idx)
        M(2) = M2(panel_idx)
        M(3) = M3 (panel_idx)
        M(4) = M4 (panel_idx)

        N1 = (1-u)*(1-v)
        N2 = (1+u)*(1-v)
        N3 = (1+u)*(1+v)
        N4 = (1-u)*(1+v)

        xx = 0.25*N1*X(M(1)) + 0.25*N2*X(M(2)) + 0.25*N3*X(M(3)) + 0.25*N4*X(M(4))
        yy = 0.25*N1*Y(M(1)) + 0.25*N2*Y(M(2)) + 0.25*N3*Y(M(3)) + 0.25*N4*Y(M(4))
        zz=  0.25*N1*Z(M(1)) + 0.25*N2*Z(M(2)) + 0.25*N3*Z(M(3)) + 0.25*N4*Z(M(4))
    END SUBROUTINE transform_uv_to_cartesian

    REAL FUNCTION compute_jacobian(panel_idx, u, v)
        ! This function computes the Jacobian of the tranformation performed by the subroutine transform_uv_to_cartesian
        ! It performs it using equations 2.53 of reference R4
        !  Arguments
        ! panel_idx (input):  The id of the panel where the coordinate belong to
        !  u,v (input): The parametric coordinate in the range -1, 1
        REAL :: dxdu, dxdv, dydu, dydv, dzdu, dzdv ! Derivative of x,y,z with respect to u and so on
        REAL :: u,v,xx,yy,zz, r, theta, rmin, rmax, dN1du, dN1dv, dN2du, dN2dv, dN3du, dN3dv, dN4du, dN4dv
        REAL :: jx , jy, jz
        INTEGER:: panel_idx, M(4), I
        REAL, PARAMETER :: PI=4.*ATAN(1.)

        ! Getting index of the coordinate of the 4 vertices
        M(1) = M1(panel_idx)
        M(2) = M2(panel_idx)
        M(3) = M3 (panel_idx)
        M(4) = M4 (panel_idx)

        dN1du = -(1-v)
        dN1dv = -(1-u)
        dN2du = 1-v
        dN2dv = -(1+u)
        dN3du = (1+v)
        dN3dv = (1+u)
        dN4du = -(1+v)
        dN4dv = (1-u)

        dxdu = 0.25*dN1du*X(M(1)) + 0.25*dN2du*X(M(2)) + 0.25*dN3du*X(M(3)) + 0.25*dN4du*X(M(4))
        dxdv = 0.25*dN1dv*X(M(1)) + 0.25*dN2dv*X(M(2)) + 0.25*dN3dv*X(M(3)) + 0.25*dN4dv*X(M(4))

        dydu = 0.25*dN1du*Y(M(1)) + 0.25*dN2du*Y(M(2)) + 0.25*dN3du*Y(M(3)) + 0.25*dN4du*Y(M(4))
        dydv = 0.25*dN1dv*Y(M(1)) + 0.25*dN2dv*Y(M(2)) + 0.25*dN3dv*Y(M(3)) + 0.25*dN4dv*Y(M(4))

        dzdu = 0.25*dN1du*Z(M(1)) + 0.25*dN2du*Z(M(2)) + 0.25*dN3du*Z(M(3)) + 0.25*dN4du*Z(M(4))
        dzdv = 0.25*dN1dv*Z(M(1)) + 0.25*dN2dv*Z(M(2)) + 0.25*dN3dv*Z(M(3)) + 0.25*dN4dv*Z(M(4))

        jx = dydu*dzdv-dydv*dzdu
        jy = dxdv*dzdu-dxdu*dzdv
        jz=  dxdu*dydv-dxdv*dydu

        compute_jacobian = sqrt( jx**2 + jy**2 + jz**2)
    END FUNCTION compute_jacobian

    SUBROUTINE compute_green_derivative_wave_part(param, u, v, XPO, YPO, ZPO, panel_idx, green, dgreen)
        ! This subroutine computes the value of of wave part of the green function and it's derivative
        ! for the finite and infinite depth case
        ! Arguments
        ! param (input): common variables that contains useful variables
        !        See param definition for explanation of the member used here
        ! u, v (inputs): coordinate in parametric space of the field point
        ! XPO, YPO, ZPO (inputs): coordinate in cartesian of the source point
        ! panel_idx (input):  The field point panel
        ! green (output) The value of the wave part of the green function
        ! dgreen (output) The value of the derivative of the wave part of the green function
        complex :: green, dgreen
        REAL:: u,v,uf,vf
        INTEGER:: panel_idx
        INTEGER:: J
        REAL:: XPO,YPO,ZPO, xx, yy, zz
        TYPE(ParamsCommonInf) :: param
        REAL:: FS1(NFA,2),FS2(NFA,2)
        REAL:: VSX1(NFA,2),VSY1(NFA,2),VSZ1(NFA,2)
        REAL:: VSX2(NFA,2),VSY2(NFA,2),VSZ2(NFA,2)

        J = panel_idx

        CALL transform_uv_to_cartesian(panel_idx, u ,v, xx, yy, zz)

        IF((Depth .EQ. 0.) .OR. (param%AMH .GE. 20))  THEN ! infinite case
            CALL VVV(2, 2,J,XPO,YPO,ZPO, xx, yy, zz, param%SolverVar) ! finite part
            CALL VNV(2, J,XPO,YPO,ZPO, xx, yy, zz, param%SolverVar, green, dgreen)

        ELSE
            CALL VVV(2, 2,J,XPO,YPO,ZPO, xx, yy, zz, param%SolverVar)
            CALL VNVF(2, param%AM0,param%AMH,param%NEXP,J,XPO,YPO,ZPO, xx, yy, zz, param%SolverVar, green , dgreen)

        END IF
    END SUBROUTINE  compute_green_derivative_wave_part

    COMPLEX FUNCTION compute_green_wave_part(param, u, v, XPO, YPO, ZPO, panel_idx)
        ! This function computes the value of wave part of the green function
        ! for the finite and infinite depth case
        ! Arguments
        ! param (input): common variables that contains useful variables
        !        See param definition for explanation of the member used here
        ! u, v (inputs): coordinate in parametric space of the field point
        ! XPO, YPO, ZPO (inputs): coordinate in cartesian of the source point
        ! panel_idx (input):  The field point panel
        complex :: green, dgreen
        REAL:: u,v,uf,vf, XPO,YPO,ZPO
        INTEGER :: panel_idx
        TYPE(ParamsCommonInf) :: param

        CALL compute_green_derivative_wave_part(param, u, v, XPO, YPO, ZPO, panel_idx, green, dgreen)

        compute_green_wave_part = green

    END FUNCTION compute_green_wave_part

    COMPLEX FUNCTION compute_dgreen_wave_part(param, u, v, XPO, YPO, ZPO, panel_idx)
        ! This function computes the value of the derivative of the wave part of the green function
        ! for the finite and infinite depth case
        ! Arguments
        ! param (input): common variables that contains useful variables
        !        See param definition for explanation of the member used here
        ! u, v (inputs): coordinate in parametric space of the field point
        ! XPO, YPO, ZPO (inputs): coordinate in cartesian of the source point
        ! panel_idx (input):  The field point panel
        complex :: green, dgreen
        REAL:: u, v, uf, vf, XPO, YPO, ZPO
        INTEGER :: panel_idx
        TYPE(ParamsCommonInf) :: param

        CALL compute_green_derivative_wave_part(param, u, v, XPO, YPO, ZPO, panel_idx, green, dgreen)

        compute_dgreen_wave_part = dgreen

    END FUNCTION compute_dgreen_wave_part

    COMPLEX FUNCTION compute_dgreen_rankine_part(param, u, v, XPO, YPO, ZPO, panel_idx)
        ! This function computes the value of the derivative of the rankine part of the green function
        ! for the finite and infinite depth case
        ! Arguments
        ! param (input): common variables that contains useful variables
        !        See param definition for explanation of the member used here
        ! u, v (inputs): coordinate in parametric space of the field point
        ! XPO, YPO, ZPO (inputs): coordinate in cartesian of the source point
        ! panel_idx (input):  The field point panel
        complex :: green, dgreen
        REAL:: u,v,uf,vf
        REAL:: XPO,YPO,ZPO, xx, yy, zz, tmp
        INTEGER:: J
        INTEGER :: panel_idx
        TYPE(ParamsCommonInf) :: param

        J = panel_idx

        CALL transform_uv_to_cartesian(panel_idx, u ,v, xx, yy, zz)

        IF((Depth .EQ. 0.) .OR. (param%AMH .GE. 20))  THEN ! infinite case
            CALL VVV(2, 1,J,XPO,YPO,ZPO, xx, yy, zz, param%SolverVar) ! finite part

        ELSE
            CALL VVV(2, 2,J,XPO,YPO,ZPO, xx, yy, zz, param%SolverVar)

        END IF

        tmp = XN(J)*param%SolverVar%VSXP + YN(J)*param%SolverVar%VSYP + ZN(J)*param%SolverVar%VSZP

        compute_dgreen_rankine_part = cmplx(tmp, 0)

    END FUNCTION compute_dgreen_rankine_part

    COMPLEX FUNCTION compute_green_rankine_part(param, u, v, XPO, YPO, ZPO, panel_idx)
        ! This function computes the value of the rankine part of the green function
        ! for the finite and infinite depth case
        ! Arguments
        ! param (input): common variables that contains useful variables
        !        See param definition for explanation of the member used here
        ! u, v (inputs): coordinate in parametric space of the field point
        ! XPO, YPO, ZPO (inputs): coordinate in cartesian of the source point
        ! panel_idx (input):  The field point panel
        complex :: green, dgreen
        REAL:: u,v,uf,vf
        REAL:: XPO,YPO,ZPO, xx, yy, zz, tmp
        INTEGER:: J
        INTEGER :: panel_idx
        TYPE(ParamsCommonInf) :: param

        J = panel_idx

        CALL transform_uv_to_cartesian(panel_idx, u ,v, xx, yy, zz)

        IF((Depth .EQ. 0.) .OR. (param%AMH .GE. 20))  THEN ! infinite case
            CALL VVV(2, 1,J,XPO,YPO,ZPO, xx, yy, zz, param%SolverVar) ! finite part

        ELSE
            CALL VVV(2, 2,J,XPO,YPO,ZPO, xx, yy, zz, param%SolverVar)

        END IF

        compute_green_rankine_part = cmplx(param%SolverVar%FSP, 0)

    END FUNCTION compute_green_rankine_part

    COMPLEX FUNCTION COMPUTE_NORMAL_POTENTIAL(param, panel_idx, xx, yy, zz)
        ! Function to compute the normal potential at any point (xx, yy, zz) of a panel identified by panel_idx
        ! It is expected to replace the old NVEL variable for higher order panel method
        ! The old NVEL only contain the normal potential at the centroid of the panel

        REAL :: xx,yy,zz ! The coordinate of the point
        INTEGER :: panel_idx ! The panel id
        INTEGER :: i
        COMPLEX :: Phi,p,Vx,Vy,Vz
        TYPE(ParamsCommonInf) :: param ! The variable containing useful parameters
        REAL :: direction(3), axis(3)

        direction(1) = param%rad_case(param%rad_case_idx, 3)
        direction(2) = param%rad_case(param%rad_case_idx, 4)
        direction(3) = param%rad_case(param%rad_case_idx, 5)

        axis(1) = param%rad_case(param%rad_case_idx, 6)
        axis(2) = param%rad_case(param%rad_case_idx, 7)
        axis(3) = param%rad_case(param%rad_case_idx, 8)

        i = panel_idx

        IF (param%is_wave == 1) THEN
            CALL Compute_Wave(param%kwave,param%w,param%beta,xx,yy,zz,Phi,p,Vx,Vy,Vz,param%Environment)
            COMPUTE_NORMAL_POTENTIAL = Vx*param%Mesh%N(1,i)+Vy*param%Mesh%N(2,i)+Vz*param%Mesh%N(3,i)
        ELSE
            IF (int(param%rad_case(param%rad_case_idx, 2)) == 2 ) THEN
                IF(param%Mesh%cPanel(i) == int(param%rad_case(param%rad_case_idx, 1))) THEN

                    Vx = direction(2)*(zz - axis(3)) - direction(3)*(yy - axis(2))
                    Vy = direction(3)*(xx - axis(1)) - direction(1)*(zz - axis(3))
                    Vz = direction(1)*(yy - axis(2)) - direction(2)*(xx - axis(1))
                    COMPUTE_NORMAL_POTENTIAL = Vx*param%Mesh%N(1,i)+Vy*param%Mesh%N(2,i)+Vz*param%Mesh%N(3,i)

                ELSE
                    COMPUTE_NORMAL_POTENTIAL = param%NVEL(i)  ! cmplx(0, 0)
                END IF
            ELSE
                COMPUTE_NORMAL_POTENTIAL = param%NVEL(i)
            END IF
        END IF

    END FUNCTION COMPUTE_NORMAL_POTENTIAL

    SUBROUTINE SOLVE_POTENTIAL_HIGH(param, PRESSURE, PHI, MeshFS, Switch_FS,  Switch_Potential, NDS, Force, &
        & out_potential)
        !This subroutine solves a boundary element method for a finite or infinite depth using
        !   a three dimensional higher order method. The higher order method used is based on
        !   B-Spline.
        !   The influence matrix is setup using equation 15.30 of reference R2
        !   The corresponding linear system is solved using an SVD (Singular Value Decomposition) solver.
        !   More specific description can be read in section 15.5 of reference R2.
        !   Here the green function and derivative are computed using a series approximation and a tabulation
        !   as previously done for the lower order panel method in Nemoh.
        !   After solving the influence matrix, the potential at the boundary and at the given points in the fluid
        !   domain is computed. The pressure at the centroid of each patch are computed and the forces are derived.
        !  Arguments
        !  param (input/temporary vars): common variables that contains useful variables
        !        See param definition for explanation of the member used here
        !  PRESSURE (output) The array to contain the pressure at the centroid of each patch
        !  PHI (output) The array to contain the potential in the fluid domain of the given point
        !  MeshFS (input) Mesh structure used to get the points for which to compute the potential in the fluid
        !                 domain
        !  Switch_FS (input): Whether or not to compute the potential at the fluid domain
        !  Switch_Potential (input) : Whether or not to save the pressure
        !  NDS (input):  Array containing the nds at each center of a patch
        !  Force (output): Array to contain the computed dynamic forces
        !  out_potential (output): Array to contain the computed potential/pressure/centroid values

        COMPLEX, DIMENSION(:, :), ALLOCATABLE :: ZIJ
        COMPLEX, DIMENSION(:, :), ALLOCATABLE :: A
        COMPLEX, DIMENSION(:, :), ALLOCATABLE :: B
        complex :: tmp, tmp2
        COMPLEX, DIMENSION(:), POINTER :: ZPB,ZPS
        INTEGER :: I, J,  K,  II, JJ, KK, num, curx, cury
        TYPE(TempVar), POINTER :: SolverVar
        REAL AMH
        REAL :: u,v, tmpr
        COMPLEX,DIMENSION(:),ALLOCATABLE :: NVEL
        INTEGER :: NEXP
        TYPE(TMesh) :: MeshFS
        COMPLEX :: PRESSURE(:)
        COMPLEX :: PHI(:)
        INTEGER :: Switch_FS, Switch_Potential
        REAL,DIMENSION(:,:) :: NDS
        COMPLEX,DIMENSION(:) :: Force
        COMPLEX,PARAMETER :: CII=CMPLX(0.,1.)
        REAL :: out_potential(:)
        REAL, PARAMETER :: PI=4.*ATAN(1.)
        INTEGER, DIMENSION(:), ALLOCATABLE:: IPIV
        REAL, DIMENSION(:), ALLOCATABLE:: S, RWORK
        INTEGER:: INFO, RANK, LWORK
        COMPLEX, DIMENSION(:), ALLOCATABLE:: WORK

        TYPE(ParamsCommonInf), TARGET :: param

        SolverVar => param%SolverVar

        CALL COMPUTE_NEXP(param)

        ZPB => SolverVar%ZPB
        ZPS => SolverVar%ZPS

        CALL INITIALIZE_BEM_HIGH(param)

        LWORK = 2*min(SolverVar%Num_Unknows,SolverVar%Num_Unknows) + max(SolverVar%Num_Unknows, &
            & SolverVar%Num_Unknows,1) + 5

        ALLOCATE(WORK(LWORK))
        ALLOCATE(RWORK(5*min(SolverVar%Num_Unknows,  SolverVar%Num_Unknows)))
        ALLOCATE(ZIJ(SolverVar%Num_Unknows, SolverVar%Num_Unknows +1))
        ALLOCATE(IPIV(SolverVar%Num_Unknows))
        ALLOCATE(S(SolverVar%Num_Unknows))
        ALLOCATE(A(SolverVar%Num_Unknows, SolverVar%Num_Unknows))
        ALLOCATE(B(SolverVar%Num_Unknows, 1))

        ZIJ = cmplx(0., 0.)

        num = 0

        param%SolverVar = SolverVar

        param%use_cartesian_coordinate = 0
        param%compute_potential = 0

        ! Computing influence Matrix
        DO J=1,SolverVar%Num_Patches

            DO I=1,SolverVar%Num_Basis_U(J)

                DO K=1,SolverVar%Num_Basis_V(J)

                    curx = SolverVar%Panel_Idx(J) + I*K
                    param%j = J
                    param%i = I
                    param%k = K

                    ! dik Computing integral at equation 15.32 of reference R2
                    DO II = 1,SolverVar%Num_Basis_U(J)

                        DO KK=1,SolverVar%Num_Basis_V(J)

                            param%ii = II
                            param%jj = J
                            param%kk = KK

                            ! Using tmp to avoid long formula
                            tmp = qgss2d_simple(influence_dik, -1., 1., -1., 1., 3, param)
                            ZIJ(curx, SolverVar%Panel_Idx(J) + II*KK) = 2*PI*tmp

                        END DO

                    END DO

                    !! DIK Computing integral at equation 15.33 of reference R2
                    DO JJ=1,SolverVar%Num_Patches

                        DO II = 1,SolverVar%Num_Basis_U(JJ)

                            DO KK=1,SolverVar%Num_Basis_V(JJ)

                                cury = SolverVar%Panel_Idx(JJ) + II*KK
                                param%ii = II
                                param%jj = JJ
                                param%kk = KK

                                ! Using tmp to avoid long formulas
                                tmp = qgss2d_simple(influence_bigdik, -1., 1., -1., 1., 3, param)
                                ZIJ(curx, cury) = ZIJ(curx, cury) + tmp

                            END DO

                        END DO

                    END DO

                    !!  SI Computing integral at equation 15.34 of reference R2
                    cury = SolverVar%Num_Unknows + 1

                    param%jj = J

                    ZIJ(curx, cury) = qgss2d_simple(influence_si, -1., 1., -1., 1., 3, param)

                END DO

            END DO

        END DO

        ! Setting up matrix A and B of the linear equations Ax=B
        DO I = 1, SolverVar%Num_Unknows

            DO J=1, SolverVar%Num_Unknows

                A(I, J) = ZIJ(I,J)

            END DO

            B(I, 1) = ZIJ(I, SolverVar%Num_Unknows+1)

        END DO
        ! Computing influence matrix ended

        ! Solve the Matrix

        !------------------------------------------------!
        ! Solve this using a SVD decomposition, solving equation 15.30 of reference R2
        CALL CGELSS( SolverVar%Num_Unknows, SolverVar%Num_Unknows, 1, A, SolverVar%Num_Unknows, B, &
            & SolverVar%Num_Unknows, S, 1e-20, RANK, WORK, LWORK, RWORK, INFO )

        IF( INFO.GT.0 ) THEN
            WRITE(*,*)'The algorithm for computing the SVD failed to converge'
            WRITE(*,*)INFO, ' off-diagonal elements of an intermediate'
            WRITE(*,*)'bidiagonal form did not converge to zero.'
            STOP
        END IF

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

        ! Computing the boundary potential at the centroid of a panel/patch
        ! We can re-use the B-Spline formulation of the potential but we are using the general
        ! equation 15.29 of reference R2 to get it.
        ! In the higher order panel method we can get the potential at any point of a patch
        ! We are returning here only the potential at the centroid of a patch
        DO J=1,SolverVar%Num_Patches

            ! Commented, once the subroutine transform_cartesian_to_uv is not anymore mocked it could be use
            ! if needed
            !CALL transform_cartesian_to_uv(J, XG(J), YG(J), ZG(J), u, v) to re-enable here
            !ZPB(J) = COMPUTE_POTENTIAL_BOUNDARY_PATCH(J, u, v, B, param)
            ZPB(J) = COMPUTE_POTENTIAL_DOMAIN_HIGH(XG(J), YG(J), ZG(J), param, B)
            ZPS(J) = cmplx(0., 0.)

        END DO

        !       Assemble pressure at patches centroid
        DO J=1,SolverVar%Num_Patches
            PRESSURE(J)=RHO*CII*param%W*ZPB(J) !*AIRE(i)
        END DO

         !       Save free surface elevation
        IF (Switch_FS.EQ.1) THEN
            DO j=1,MeshFS%Npoints
                PHI(j) = COMPUTE_POTENTIAL_DOMAIN_HIGH(MeshFS%X(1,j),MeshFS%X(2,j),0.,param, B)
            END DO
        END IF

        !       Save output
        IF (Switch_Potential.EQ.1) THEN
            CALL SAVE_POTENTIAL(PRESSURE, out_potential)
        END IF

        !       Calculate force coefficients at centroid of panel
        DO i=1,param%n_integration
            DO j=1,param%NpanIsy
                Force(i)=Force(i)-PRESSURE(j)*NDS(i,j)
            END DO
        END DO

        ! Deallocate allocated arrays
        if (allocated(ZIJ)) deallocate(ZIJ)
        if (allocated(IPIV)) deallocate(IPIV)
        if (allocated(A)) deallocate(A)
        if (allocated(B)) deallocate(B)
        if (allocated(RWORK)) deallocate(RWORK)
        if (allocated(WORK)) deallocate(WORK)
        CALL DEALLOCATE_BEM_HIGH(param)

    END SUBROUTINE SOLVE_POTENTIAL_HIGH

    COMPLEX FUNCTION COMPUTE_POTENTIAL_BOUNDARY_PATCH(panel_idx, u, v, B, param)
        ! Compute potential at a given point in the boundary for a patch using equation 7.4 of reference R2
        ! It is only valid for the higher panel method
        ! Arguments (inputs)
        !panel_idx: The id of the panel of the given point
        ! u, v: The parametric coordinate
        ! B: Array, solution of the linear system. Contain the phi coefficients
        ! param: common variables that contains useful variables
        !        See param definition for explanation of the member used here
        INTEGER :: panel_idx, J,   I,   K ! The id of the patch/panels
        REAL :: xx, yy, zz ! The coordinate of a point in the domain of the given patch
        REAL:: tmpr
        INTEGER:: curx
        COMPLEX ::   tmp
        REAL :: u,v
        TYPE(ParamsCommonInf) :: param
        COMPLEX, DIMENSION(:, :), ALLOCATABLE :: B

        J = panel_idx

        tmp = cmplx(0., 0.)

        DO I=1, param%SolverVar%Num_Basis_U(J)

            DO K=1, param%SolverVar%Num_Basis_V(J)

                curx = param%SolverVar%Panel_Idx(J) + I*K

                tmpr = GET_BSPLINE(u, param%SolverVar%KNOTS_U(J), I)*GET_BSPLINE(v, param%SolverVar%KNOTS_U(J), K)

                tmp = tmp + B(curx, 1)*tmpr

            END DO

        END DO

        COMPUTE_POTENTIAL_BOUNDARY_PATCH = tmp

    END FUNCTION COMPUTE_POTENTIAL_BOUNDARY_PATCH

    COMPLEX FUNCTION COMPUTE_POTENTIAL_DOMAIN_HIGH(xx, yy, zz, param, B)
        ! Compute the potential at a given point in the fluid domain or in the boundary
        ! for the higher panel method
        ! Arguments
        ! xx,yy,zz: Cartesian coordinate of the given point
        ! B: Array, solution of the linear system. Contain the phi coefficients
        ! param: common variables that contains useful variables
        !        See param definition for explanation of the member used here
        TYPE(ParamsCommonInf) :: param
        COMPLEX :: tmp
        REAL :: xx, yy, zz ! The coordinate of a point in the domain of the given patch
        REAL :: uf,vf
        INTEGER:: J
        COMPLEX, DIMENSION(:, :), ALLOCATABLE :: B ! The solution to the linear system

        COMPUTE_POTENTIAL_DOMAIN_HIGH = cmplx(0, 0)

        param%use_cartesian_coordinate = 1
        param%compute_potential = 1
        param%B = B

        param%xx = xx
        param%yy = yy
        param%zz = zz

        DO J=1,param%SolverVar%Num_Patches

            param%jj = J

            tmp = qgss2d_simple(influence_ugreen, -1., 1., -1., 1., 3, param)

            tmp = tmp - qgss2d_simple(influence_udgreen, -1., 1., -1., 1., 3, param)

            COMPUTE_POTENTIAL_DOMAIN_HIGH = COMPUTE_POTENTIAL_DOMAIN_HIGH + tmp
        END DO

    END FUNCTION COMPUTE_POTENTIAL_DOMAIN_HIGH

    SUBROUTINE INITIALIZE_BEM_HIGH(param)
        ! This initializes the higher order panel method. It setups the common parameters.
        ! It computes the knot vectors, their length, the number of basis per patch
        ! param(input/output): common variables that contains useful variables
        !        See param definition for explanation of the member used here
        TYPE(ParamsCommonInf), TARGET :: param
        TYPE(TempVar), POINTER :: SolverVar
        INTEGER :: I,J, num
        REAL :: total

        SolverVar => param%SolverVar

        SolverVar%Num_Patches = IMX

        ALLOCATE(SolverVar%Num_Basis_U(IMX))
        ALLOCATE(SolverVar%Num_Basis_V(IMX))
        ALLOCATE(SolverVar%Panel_Idx(IMX))
        ALLOCATE(SolverVar%KNOTS_U(IMX))
        ALLOCATE(SolverVar%KNOTS_V(IMX))

        DO I = 1, SolverVar%Num_Patches
            SolverVar%Num_Basis_U(I) = param%NSPLIN + param%KSPLIN -1
            SolverVar%Num_Basis_V(I) = param%NSPLIN + param%KSPLIN -1
        END DO

        num = 0

        DO I = 1, SolverVar%Num_Patches

            SolverVar%Panel_Idx(I) = num

            num = num + SolverVar%Num_Basis_U(I)*SolverVar%Num_Basis_V(I)

        END DO

        SolverVar%Num_Unknows = num

        DO I = 1, SolverVar%Num_Patches

            SolverVar%KNOTS_U(I)%POLY_ORDER = param%KSPLIN
            SolverVar%KNOTS_V(I)%POLY_ORDER = param%KSPLIN

            SolverVar%KNOTS_V(I)%LENGTH = SolverVar%Num_Basis_V(I) + param%KSPLIN
            SolverVar%KNOTS_U(I)%LENGTH = SolverVar%Num_Basis_U(I) + param%KSPLIN

            ALLOCATE(SolverVar%KNOTS_V(I)%KNOTS(0:SolverVar%KNOTS_V(I)%LENGTH))
            ALLOCATE(SolverVar%KNOTS_U(I)%KNOTS(0:SolverVar%KNOTS_U(I)%LENGTH))

        END DO

        ! Computing knot vector as suggested in R1 page 195
        DO I = 1, SolverVar%Num_Patches

            total = SolverVar%KNOTS_V(I)%LENGTH + 1 -2*SolverVar%KNOTS_V(I)%POLY_ORDER

            DO J=0, SolverVar%KNOTS_V(I)%LENGTH

                IF (J < SolverVar%KNOTS_V(I)%POLY_ORDER) THEN
                    SolverVar%KNOTS_V(I)%KNOTS(J) = -1
                ELSE IF (SolverVar%KNOTS_V(I)%LENGTH-J < SolverVar%KNOTS_V(I)%POLY_ORDER) THEN
                    SolverVar%KNOTS_V(I)%KNOTS(J) = 1
                ELSE
                    SolverVar%KNOTS_V(I)%KNOTS(J) = -1+ 2.*real(J-SolverVar%KNOTS_V(I)%POLY_ORDER)/total

                END IF

            END DO

            total = SolverVar%KNOTS_U(I)%LENGTH + 1 -2*SolverVar%KNOTS_U(I)%POLY_ORDER

            DO J=0, SolverVar%KNOTS_U(I)%LENGTH

                IF (J < SolverVar%KNOTS_U(I)%POLY_ORDER) THEN
                    SolverVar%KNOTS_U(I)%KNOTS(J) = -1
                ELSE IF (SolverVar%KNOTS_U(I)%LENGTH-J < SolverVar%KNOTS_U(I)%POLY_ORDER) THEN
                    SolverVar%KNOTS_U(I)%KNOTS(J) = 1
                ELSE
                    SolverVar%KNOTS_U(I)%KNOTS(J) = -1+ 2.*real(J-SolverVar%KNOTS_U(I)%POLY_ORDER)/total

                END IF

            END DO

        END DO
    END SUBROUTINE INITIALIZE_BEM_HIGH

    SUBROUTINE DEALLOCATE_BEM_HIGH(param)
        ! This deallocates allocated data done in INITIALIZE_BEM_HIGH
        TYPE(ParamsCommonInf) :: param
        TYPE(TempVar), TARGET :: SolverVar
        INTEGER :: I,J

        SolverVar = param%SolverVar

        DEALLOCATE(SolverVar%Num_Basis_U)
        DEALLOCATE(SolverVar%Num_Basis_V)
        DEALLOCATE(SolverVar%Panel_Idx)

        DO I = 1, SolverVar%Num_Patches
            DEALLOCATE(SolverVar%KNOTS_V(I)%KNOTS)
            DEALLOCATE(SolverVar%KNOTS_U(I)%KNOTS)

        END DO

        DEALLOCATE(SolverVar%KNOTS_U)
        DEALLOCATE(SolverVar%KNOTS_V)

    END SUBROUTINE DEALLOCATE_BEM_HIGH

end MODULE SOLVE_BEM_HIGH


c---------------------------------------------------------------------
c---------------------------------------------------------------------

       subroutine  txinvr

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c block-diagonal matrix-vector multiplication
c---------------------------------------------------------------------

       include 'header.h'

       integer i, j, k
       double precision t1, t2, t3, ac, ru1, uu, vv, ww, r1, r2, r3,
     >                  r4, r5, ac2inv

!HPF$ INDEPENDENT
       do    k = 1, nz2
          do    j = 1, ny2
             do    i = 1, nx2

                ru1 = rho_i(i,j,k)
                uu = us(i,j,k)
                vv = vs(i,j,k)
                ww = ws(i,j,k)
                ac = speed(i,j,k)
c                ac2inv = ainv(i,j,k)*ainv(i,j,k)
                ac2inv = 1.0d0 / ( ac*ac )

                r1 = rhs(1,i,j,k)
                r2 = rhs(2,i,j,k)
                r3 = rhs(3,i,j,k)
                r4 = rhs(4,i,j,k)
                r5 = rhs(5,i,j,k)

                t1 = c2 * ac2inv * ( qs(i,j,k)*r1 - uu*r2  -
     >                  vv*r3 - ww*r4 + r5 )
                t2 = bt * ru1 * ( uu * r1 - r2 )
                t3 = ( bt * ru1 * ac ) * t1

                rhs(1,i,j,k) = r1 - t1
                rhs(2,i,j,k) = - ru1 * ( ww*r1 - r4 )
                rhs(3,i,j,k) =   ru1 * ( vv*r1 - r3 )
                rhs(4,i,j,k) = - t2 + t3
                rhs(5,i,j,k) =   t2 + t3

             end do
          end do
       end do

       return
       end


*DECK ALNREL
      FUNCTION ALNREL (X)
C***BEGIN PROLOGUE  ALNREL
C***PURPOSE  Evaluate ln(1+X) accurate in the sense of relative error.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C4B
C***TYPE      SINGLE PRECISION (ALNREL-S, DLNREL-D, CLNREL-C)
C***KEYWORDS  ELEMENTARY FUNCTIONS, FNLIB, LOGARITHM
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C ALNREL(X) evaluates ln(1+X) accurately in the sense of relative
C error when X is very small.  This routine must be used to
C maintain relative error accuracy whenever X is small and
C accurately known.
C
C Series for ALNR       on the interval -3.75000D-01 to  3.75000D-01
C                                        with weighted error   1.93E-17
C                                         log weighted error  16.72
C                               significant figures required  16.44
C                                    decimal places required  17.40
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  CSEVL, INITS, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770401  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C***END PROLOGUE  ALNREL
      DIMENSION ALNRCS(23)
      LOGICAL FIRST
      SAVE ALNRCS, NLNREL, XMIN, FIRST
      DATA ALNRCS( 1) /   1.0378693562 743770E0 /
      DATA ALNRCS( 2) /   -.1336430150 4908918E0 /
      DATA ALNRCS( 3) /    .0194082491 35520563E0 /
      DATA ALNRCS( 4) /   -.0030107551 12753577E0 /
      DATA ALNRCS( 5) /    .0004869461 47971548E0 /
      DATA ALNRCS( 6) /   -.0000810548 81893175E0 /
      DATA ALNRCS( 7) /    .0000137788 47799559E0 /
      DATA ALNRCS( 8) /   -.0000023802 21089435E0 /
      DATA ALNRCS( 9) /    .0000004164 04162138E0 /
      DATA ALNRCS(10) /   -.0000000735 95828378E0 /
      DATA ALNRCS(11) /    .0000000131 17611876E0 /
      DATA ALNRCS(12) /   -.0000000023 54670931E0 /
      DATA ALNRCS(13) /    .0000000004 25227732E0 /
      DATA ALNRCS(14) /   -.0000000000 77190894E0 /
      DATA ALNRCS(15) /    .0000000000 14075746E0 /
      DATA ALNRCS(16) /   -.0000000000 02576907E0 /
      DATA ALNRCS(17) /    .0000000000 00473424E0 /
      DATA ALNRCS(18) /   -.0000000000 00087249E0 /
      DATA ALNRCS(19) /    .0000000000 00016124E0 /
      DATA ALNRCS(20) /   -.0000000000 00002987E0 /
      DATA ALNRCS(21) /    .0000000000 00000554E0 /
      DATA ALNRCS(22) /   -.0000000000 00000103E0 /
      DATA ALNRCS(23) /    .0000000000 00000019E0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  ALNREL
      IF (FIRST) THEN
         NLNREL = INITS (ALNRCS, 23, 0.1*R1MACH(3))
         XMIN = -1.0 + SQRT(R1MACH(4))
      ENDIF
      FIRST = .FALSE.
C
      IF (X .LE. (-1.0)) CALL XERMSG ('SLATEC', 'ALNREL', 'X IS LE -1',
     +   2, 2)
      IF (X .LT. XMIN) CALL XERMSG ('SLATEC', 'ALNREL',
     +   'ANSWER LT HALF PRECISION BECAUSE X TOO NEAR -1', 1, 1)
C
      IF (ABS(X).LE.0.375) ALNREL = X*(1. -
     1  X*CSEVL (X/.375, ALNRCS, NLNREL))
      IF (ABS(X).GT.0.375) ALNREL = LOG (1.0+X)
C
      RETURN
      END


module smooth_mod

! model dependent smoothing of inflation estimate.
! This version is for GEOS, expects data to be on global lat-lon grids
! Isotropic spectral smoothing (gaussian) is used.

use mpisetup
use params, only:  ndim, nlons, nlats, smoothparm
use kinds, only:  r_kind, i_kind, r_single
use gridinfo, only: npts, ntrunc
use constants, only: zero

implicit none

private
public :: smooth

contains

subroutine smooth(grids)
! horizontal smoothing of 2d grids.
! version for equally-spaced lat/lon grids with poles.
! when called, grids contains unsmoothed grids on
! root task.  on return, grids on root will contain
! smoothed grids.
! smoothing controlled by parameter smoothparm.
use specmod, only: sptez_s, init_spec_vars, jcap, isinitialized
implicit none
integer(i_kind) np,ierr,m,nmdim,nm,nn,n,delta,npmax
real(r_single), intent(inout) :: grids(npts,ndim) ! there are ndim 2d grids.
real(r_single) smoothfact ! smoothing parameter.
real(r_kind) reggrd(nlons*nlats)
real(r_kind), allocatable, dimension(:) :: specdat
integer(i_kind) n1(0:numproc-1),n2(0:numproc-1)
if(ntrunc<=0) return
delta = ndim/numproc
if (delta*numproc < ndim) delta = delta + 1
npmax = 0
do np=0,numproc-1
   n1(np) = 1 + np*delta
   n2(np) = (np+1)*delta
   if (n2(np) > ndim) n2(np) = ndim
   if (n1(np) > ndim .and. npmax == 0) npmax = np-1
enddo
! spectrally smooth the grids
! bcast out to all procs.
if (nproc <= npmax) then
  if (.not. isinitialized) call init_spec_vars(nlons,nlats,ntrunc,0)
  do nn=1,ndim
    if (nn < n1(nproc) .or. nn > n2(nproc)) grids(:,nn)=zero
  enddo
  nmdim = (ntrunc+1)*(ntrunc+2)/2
  allocate(specdat(2*nmdim))
  do nn=n1(nproc),n2(nproc)
     reggrd = grids(:,nn)
     call sptez_s(specdat,reggrd,-1)
     nm = 1
     do m=0,ntrunc
        do n=m,ntrunc
           smoothfact = exp(-(float(n)/smoothparm)**2)
           specdat(nm) = smoothfact*specdat(nm)
           specdat(nm+1) = smoothfact*specdat(nm+1)
           nm = nm + 2
        enddo
     enddo
     call sptez_s(specdat,reggrd,1)
     grids(:,nn) = reggrd
  enddo !nn=1,ndim
  deallocate(specdat)
else ! np > npmax
  grids = zero
end if
do nn=1,ndim
  call mpi_allreduce(mpi_in_place,grids(1,nn),npts,mpi_real4,mpi_sum,mpi_comm_world,ierr)
enddo
end subroutine smooth
end module smooth_mod


      SUBROUTINE anneal(x,y,iorder,ncity)
      INTEGER ncity,iorder(ncity)
      REAL x(ncity),y(ncity)
CU    USES irbit1,metrop,ran3,revcst,revers,trncst,trnspt
      INTEGER i,i1,i2,idec,idum,iseed,j,k,nlimit,nn,nover,nsucc,n(6),
     *irbit1
      REAL de,path,t,tfactr,ran3,alen,x1,x2,y1,y2
      LOGICAL ans
      alen(x1,x2,y1,y2)=sqrt((x2-x1)**2+(y2-y1)**2)
      nover=100*ncity
      nlimit=10*ncity
      tfactr=0.9
      path=0.0
      t=0.5
      do 11 i=1,ncity-1
        i1=iorder(i)
        i2=iorder(i+1)
        path=path+alen(x(i1),x(i2),y(i1),y(i2))
11    continue
      i1=iorder(ncity)
      i2=iorder(1)
      path=path+alen(x(i1),x(i2),y(i1),y(i2))
      idum=-1
      iseed=111
      do 13 j=1,100
        nsucc=0
        do 12 k=1,nover
1         n(1)=1+int(ncity*ran3(idum))
          n(2)=1+int((ncity-1)*ran3(idum))
          if (n(2).ge.n(1)) n(2)=n(2)+1
          nn=1+mod((n(1)-n(2)+ncity-1),ncity)
          if (nn.lt.3) goto 1
          idec=irbit1(iseed)
          if (idec.eq.0) then
            n(3)=n(2)+int(abs(nn-2)*ran3(idum))+1
            n(3)=1+mod(n(3)-1,ncity)
            call trncst(x,y,iorder,ncity,n,de)
            call metrop(de,t,ans)
            if (ans) then
              nsucc=nsucc+1
              path=path+de
              call trnspt(iorder,ncity,n)
            endif
          else
            call revcst(x,y,iorder,ncity,n,de)
            call metrop(de,t,ans)
            if (ans) then
              nsucc=nsucc+1
              path=path+de
              call revers(iorder,ncity,n)
            endif
          endif
          if (nsucc.ge.nlimit) goto 2
12      continue
2       write(*,*)
        write(*,*) 'T =',t,' Path Length =',path
        write(*,*) 'Successful Moves: ',nsucc
        t=t*tfactr
        if (nsucc.eq.0) return
13    continue
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/anneal.for