MODULE fifthpanel

  USE precise, ONLY : defaultp

!! variable declarations

  IMPLICIT NONE    ! makes sure the compiler complains about
                   ! undeclared variables
  INTEGER, PARAMETER, PRIVATE :: WP=defaultp

CONTAINS

  FUNCTION cross_product( a, b ) RESULT (c)
    !
    ! Function to compute the cross product of two 3D vectors a and b.
    ! It will return a 3D vector.
    ! Usage: c = cross_product(a,b)
    !
    REAL(wp), DIMENSION(3) :: a, b, c

    c(1) = a(2)*b(3) - a(3)*b(2)
    c(2) = a(3)*b(1) - a(1)*b(3)
    c(3) = a(1)*b(2) - a(2)*b(1)

  END FUNCTION cross_product

  SUBROUTINE panelgeometry(corners, coordsys, cornerslocal, area, center )
    !!
    !! procedure to compute the geometric properties of a
    !! quadrilateral panel. The actual quadrilateral is replaced by
    !! a flat panel.
    !! Input are the four corner points (3D). The points must form
    !! an anti-clockwise sequence if viewed from inside the hull.
    !! The normal vector will then point inside the hull.
    !!
    !! Output:
    !!     coordsys: a 3x3 matrix containing the two tangent vectors
    !!               and the normal vector
    !!                  t1x   t2x   nx
    !!                  t1y   t2y   ny
    !!                  t1z   t2z   nz
    !!               i.e. coordsys(:,3) is the normal vector
    !!     cornerlocal: 2D - coordinates of the panel corners with
    !!                  respect to the panel center
    !!     area: the area of the panel
    !!     center: the 3D coordinates of the panel center
    !!
    INTEGER :: i

    INTEGER, DIMENSION(4), PARAMETER :: ip1 = (/ 2, 3, 4, 1 /)

    REAL(wp) :: area, dxi, deta
    REAL(wp) :: momentxi, momenteta, xic, etac

    REAL(wp), DIMENSION(3,4) :: corners   ! input, coordinates of
                                          ! the four corner points
    REAL(wp), DIMENSION(3) :: m1, m2, m3, m4 ! midpoints
    REAL(wp), DIMENSION(3) :: iv, jv, jvbar, nv ! temporary vectors
    REAL(wp), DIMENSION(3) :: center ! center of panel
    REAL(wp), DIMENSION(3,3) :: coordsys ! local coordinate system
    REAL(wp), DIMENSION(2,4) :: cornerslocal ! local coordinate system

    ! first we compute the midpoints of all four panel edges. The points
    ! m1 through m4 are situated on a plane even if the corners are not.
    m1(:) = 0.5*(corners(:,1)+corners(:,2))
    m2(:) = 0.5*(corners(:,2)+corners(:,3))
    m3(:) = 0.5*(corners(:,3)+corners(:,4))
    m4(:) = 0.5*(corners(:,4)+corners(:,1))

    ! second we compute a coordinate system local to the panel
    iv = m2-m4   ! first local coordinate vector
    iv = iv / SQRT(SUM(iv**2))  ! normalize to unit length

    jvbar = m3-m1 ! second temp. local coordinate vector

    ! Normal vector
    nv = cross_product( iv, jvbar )
    nv = nv / SQRT(SUM(nv**2))  ! normalize to unit length

    ! find second tangent vector which is perpendicular to nv and iv
    jv = cross_product( nv, iv )

    ! store the local coordinate system vectors in the matrix coordsys
    coordsys(:,1) = iv
    coordsys(:,2) = jv
    coordsys(:,3) = nv

    ! temporary origin
    center = 0.25*(m1+m2+m3+m4)

    ! corners in local (plane) coordinate system
    DO i = 1, 4
       ! xi component
       cornerslocal(1,i) = DOT_PRODUCT( (corners(:,i)-center), iv)
       ! eta component
       cornerslocal(2,i) = DOT_PRODUCT( (corners(:,i)-center), jv)
    END DO

    ! area and moment of panel. The equations are derived by means
    ! of the Stokes theorem.
    area = 0.
    momentxi = 0.  ! the moments are with respect to the panel tangent
                   ! vectors
    momenteta = 0.
    DO i = 1, 4
       dxi = cornerslocal(1,ip1(i))-cornerslocal(1,i) ! difference in xi
       deta = cornerslocal(2,ip1(i))-cornerslocal(2,i)! difference in eta

       area = area + deta*(cornerslocal(1,ip1(i))+cornerslocal(1,i))

       momentxi = momentxi + dxi * ( &
            cornerslocal(2,ip1(i))**2 &
               + cornerslocal(2,i)*cornerslocal(2,ip1(i)) &
                   + cornerslocal(2,i)**2 &
                       )
       momenteta = momenteta + deta * ( &
            cornerslocal(1,ip1(i))**2 &
               + cornerslocal(1,i)*cornerslocal(1,ip1(i)) &
                   + cornerslocal(1,i)**2 &
                       )
    END DO

    area = 0.5*area
    momentxi = -1./6.*momentxi
    momenteta = 1./6.*momenteta

    ! centroid
    IF (area > 0.0000000001) THEN
       ! We make sure that the panel is not degenerated with zero area
       xic = momenteta / area
       etac = momentxi / area
    ELSE
       xic = 0.
       etac = 0.
    ENDIF

    ! Correct the local coordinates of the corners to be measured from
    ! the true panel centroid.
    DO i = 1, 4
       cornerslocal(1,i) = cornerslocal(1,i) - xic
       cornerslocal(2,i) = cornerslocal(2,i) - etac
    END DO

    ! Finally move the centroid to its exact position
    center = center + xic*iv + etac*jv

  END SUBROUTINE panelgeometry

END MODULE fifthpanel


subroutine qinit(meqn,mbc,mx,xlower,dx,q,maux,aux)

    ! Set initial conditions for the q array.

    use geoclaw_module, only: sea_level
    use grid_module, only: xcell

    ! uncomment if any of these needed...
    !use geoclaw_module, only: dry_tolerance, grav

    implicit none

    integer, intent(in) :: meqn,mbc,mx,maux
    real(kind=8), intent(in) :: xlower,dx
    real(kind=8), intent(in) :: aux(maux,1-mbc:mx+mbc)
    real(kind=8), intent(inout) :: q(meqn,1-mbc:mx+mbc)

    !locals
    integer :: i

    real(kind=8) :: h0, eta, eta_star, x0, ampl, u, u_star, c, kappa, a

    x0 = -9.14d0   ! initial location of wave
    a = 0.259d0  ! dimensionless amplitude
    h0 = 0.218d0  ! depth for scaling
    ampl = a*h0  ! amplitude

    kappa = sqrt(3.d0*a / (4.d0*(a+1.d0)))
    c = sqrt(1.d0 + a)

    do i=1,mx
        eta = ampl / cosh(kappa*(xcell(i) - x0)/h0)**2
        eta_star = eta/h0
        u_star = c * eta_star/(1.d0 + eta_star)
        u = u_star * sqrt(9.81d0*h0)
        q(1,i) = max(sea_level, eta - aux(1,i))
        q(2,i) = q(1,i)*u

   enddo

end subroutine qinit


!CALL polysvd(kpp,strial,ptrial,SIZE(strial),cfnt(1:kpp))
      SUBROUTINE polysvd(nfitin,x,y,m,b)
! USAGE SVD regression of input vectors x, y of length m
! producess nfitin polynoimial coefficients b
      USE stel_kinds
      USE stel_constants
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER, INTENT(in) :: m, nfitin
      REAL (rprec), DIMENSION(m), INTENT(in) :: x,y
      REAL(rprec) ,DIMENSION(nfitin), INTENT(out) :: b
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      REAL (rprec) :: cutoff=1.e-7_dp
      REAL (rprec), DIMENSION(:,:), ALLOCATABLE
     1          :: amatrix, vv ,uu, wwd
      REAL (rprec), DIMENSION(:) , ALLOCATABLE :: ww
      REAL (rprec), DIMENSION(:), ALLOCATABLE, SAVE :: apar
      INTEGER , DIMENSION(:) , ALLOCATABLE :: pwr
      INTEGER ::  i, j, n=11
      n=nfitin
      ALLOCATE(amatrix(m,n))
      ALLOCATE(uu(m,n))
      ALLOCATE(pwr(n))
      ALLOCATE(apar(n))
      ALLOCATE(wwd(n,n))
      ALLOCATE(ww(n))
      ALLOCATE(vv(n,n))
      DO i=1,n
         pwr(i)=i-1
      ENDDO
! make amatrix
      DO i=1,m
         DO j=1,n
           IF(x(i).eq.0.) THEN
              amatrix(i,j)=zero
           ELSE
              amatrix(i,j)=x(i)**pwr(j)
           ENDIF
         ENDDO
      ENDDO
      uu=amatrix
      CALL svdcmp(uu,m,n,m,n,ww,vv) ! m rows > n columns
      DO i=1,n
         DO j=1,n
           wwd(i,j)=0  ! reset after matmul
         ENDDO
      ENDDO
      DO i=1,n
         wwd(i,i)=1/ww(i)
      ENDDO
      DO i= 1,SIZE(ww)
         IF(ww(i) .lt. cutoff) wwd(i,i)=0
      ENDDO
      apar=0.
      apar=matmul(vv,matmul(wwd,matmul(TRANSPOSE(uu),y)))
      b(1:n)=apar(1:n)
      DEALLOCATE(amatrix)
      DEALLOCATE(uu)
      DEALLOCATE(pwr)
      DEALLOCATE(apar)
      DEALLOCATE(wwd)
      DEALLOCATE(ww)
      DEALLOCATE(vv)
      END SUBROUTINE polysvd

!      PROGRAM driver
! TESTED against IDL with this PARAMETER set. Results agree.
!      USE stel_kinds
!      USE stel_constants
!      INTEGER, PARAMETER :: ns=50, kpp=5
!      REAL(rprec), DIMENSION(ns) :: s, y
!      REAL(rprec), DIMENSION(kpp) :: b
!      DO i=1,ns
!       s(i)=one*(i-1)/(ns-1)
!      ENDDO
!      y=COS(s*pio2)**2
!      CALL polysvd(kpp,s,y,SIZE(s),b)
!      WRITE(6,109)b
!      WRITE(6,109)s
!      WRITE (6,109)y
!109   FORMAT(/,'    =[',3(x,1pe14.6,1h,),'$')
!      END PROGRAM


! if you load the wrong library type LP vs. ILP it will say invalid parameter 8
! https://software.intel.com/en-us/mkl-developer-reference-fortran-gemm

program intel_gemm

use blas95, only: gemm
use,intrinsic :: iso_fortran_env, only: dp=>real64

IMPLICIT NONE (type, external)

real(dp) ALPHA, BETA
INTEGER          M, K, N, I, J
PARAMETER        (M=2000, K=200, N=1000)
real(dp) A(M,K), B(K,N), C(M,N)

PRINT *, "Initializing data for matrix multiplication C=A*B for "
PRINT '(a,I5,a,I5,a,I5,a,I5,a,/)', " matrix A(",M," x",K, ") and matrix B(", K," x", N, ")"

ALPHA = 1
BETA = 0

PRINT '(A,/)', "Intializing matrix data"

forall (I = 1:M, J = 1:K)  A(I,J) = (I-1) * K + J

forall (I = 1:K, J = 1:N)  B(I,J) = -((I-1) * N + J)

C(:,:) = 0

PRINT *, "Computing matrix product using Intel(R) MKL GEMM subroutine"
CALL GEMM(A,B,C)
PRINT '(A,/)', "Computations completed."

PRINT *, "Top left corner of matrix A:"
PRINT '(6(F12.0,1x),/)', ((A(I,J), J = 1,MIN(K,6)), I = 1,MIN(M,6))

PRINT *, "Top left corner of matrix B:"
PRINT '(6(F12.0,1x),/)', ((B(I,J),J = 1,MIN(N,6)), I = 1,MIN(K,6))

PRINT *, "Top left corner of matrix C:"
PRINT '(6(ES12.4,1x),/)', ((C(I,J), J = 1,MIN(N,6)), I = 1,MIN(M,6))

END program


      real             function SRANR(ALPHA)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 1994-10-20 SRANR Krogh  Changes to use M77CON
c>> 1994-06-24 SRANR CLL Changed common to use RANC[D/S]1 & RANC[D/S]2.
c>> 1992-03-16 CLL
c>> 1991-11-26 CLL Reorganized common. Using RANCM[A/D/S].
c>> 1991-11-22 CLL Added call to RAN0, and SGFLAG in common.
c>> 1991-01-15 CLL Reordered common contents for efficiency.
C>> 1990-01-23 CLL  Making names in common same in all subprogams.
C>> 1987-04-22 SRANR  Lawson  Initial code.
c        Returns one pseudorandom number from the Rayleigh distribution
c     with parameter, ALPHA, which should be positive.
c     If U is random, uniform on [0, 1], the Rayleigh variable is given
c     by                   SRANR = ALPHA * sqrt(-2.0 * log(U))
c     This variable has    mean = ALPHA * sqrt(Pi/2)
c     and                  variance = (2 - Pi/2) * ALPHA**2
c     Code based on subprogram written for JPL by Stephen L. Ritchie,
c     Heliodyne Corp. and Wiley R. Bunton, JPL, 1969.
c     Adapted to Fortran 77 for the JPL MATH77 library by C. L. Lawson &
c     S. Y. Chiu, JPL, Apr 1987.
c     ------------------------------------------------------------------
c--S replaces "?": ?RANR, ?RANUA, RANC?1, RANC?2, ?PTR, ?NUMS, ?GFLAG
C     RANCS1 and RANCS2 are common blocks.
c     Calls RAN0 to initialize SPTR and SGFLAG.
c     ------------------------------------------------------------------
      integer M
      parameter(M = 97)
      real                SNUMS(M), ALPHA, MTWO
      parameter(MTWO = -2.0E0)
      common/RANCS2/SNUMS
      integer SPTR
      logical SGFLAG
      common/RANCS1/SPTR, SGFLAG
      save  /RANCS1/, /RANCS2/, FIRST
      logical FIRST
      data    FIRST / .true. /
c     ------------------------------------------------------------------
      if(FIRST) then
         FIRST = .false.
         call RAN0
      endif
c
      SPTR = SPTR - 1
      if(SPTR .eq. 0) then
         call SRANUA(SNUMS, M)
         SPTR = M
      endif
      SRANR = ALPHA * sqrt(MTWO * log(SNUMS(SPTR)))
      return
      end


C$Procedure      PARTOF ( Parabolic time of flight )

      SUBROUTINE PARTOF ( MA, D )

C$ Abstract
C
C     Solve the time of flight equation MA = D + (D**3) / 3
C     for the parabolic eccentric anomaly D, given mean anomaly.
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     CONIC
C
C$ Declarations

      DOUBLE PRECISION      MA
      DOUBLE PRECISION      D

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     MA         I   Mean anomaly at epoch.
C     D          O   Parabolic eccentric anomaly.
C
C$ Detailed_Input
C
C     MA          is the parabolic mean anomaly of an orbiting body at
C                 some epoch t,
C
C                                         3  1/2
C                       MA = (t-T) (mu/(2q ))
C
C                 where T is the time of periapsis passage, mu is
C                 the gravitational parameter of the primary body,
C                 and q is the perifocal distance.
C
C$ Detailed_Output
C
C     D           is the corresponding parabolic anomaly. This is the
C                 solution to the time of flight equation
C
C                                 3
C                       MA = D + D / 3
C
C$ Parameters
C
C      None.
C
C$ Exceptions
C
C     None.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     Iterate to solve
C
C                            3
C           f(D,MA,p) = D + D / 3 - MA = 0
C
C$ Examples
C
C     ELLTOF, HYPTOF, and PARTOF are used by CONICS.
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     [1] Roger Bate, Fundamentals of Astrodynamics, Dover, 1971.
C
C$ Author_and_Institution
C
C     I.M. Underwood  (JPL)
C     W.L. Taber      (JPL)
C
C$ Version
C
C-    SPICELIB Version 2.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 2.0.0, 19-APR-1991 (WLT)
C
C        A write statement left over from debugging days was removed.
C
C-    SPICELIB Version 1.0.0, 31-JAN-1990 (IMU)
C
C-&

C$ Index_Entries
C
C     parabolic time of flight
C
C-&

C$ Revisions
C
C-    SPICELIB Version 2.0.0, 19-APR-1991 (WLT)
C
C        A write statement left over from debugging days was removed.
C
C-    Beta Version 1.0.1, 27-JAN-1989 (IMU)
C
C        Examples section completed.
C
C-&

C
C     SPICELIB functions
C
      LOGICAL               RETURN
      DOUBLE PRECISION      DCBRT

C
C     Local parameters
C
      DOUBLE PRECISION      TOL
      PARAMETER           ( TOL = 1.D-13 )

C
C     Local variables
C
      DOUBLE PRECISION      M
      DOUBLE PRECISION      FN
      DOUBLE PRECISION      DERIV
      DOUBLE PRECISION      DERIV2
      DOUBLE PRECISION      CHANGE

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

C
C     If the mean anomaly is zero, the eccentric anomaly is also zero
C     (by inspection). If the mean anomaly is negative, we can pretend
C     that it's positive (by symmetry).
C

      IF ( MA .EQ. 0.D0 ) THEN
         D = 0.D0
         CALL CHKOUT ( 'PARTOF' )
         RETURN
      ELSE
         M = ABS ( MA )
      END IF

C
C     We need an initial guess for the eccentric anomaly D. The function
C     is well behaved, so just about any guess will do.
C
      D = DCBRT ( 3.D0 * M )

C
C     Use the Newton second-order method,
C
C                                           2
C          F    = F  - (f/f')*(1 + f*f''/2f' )
C           i+1    i
C
C     where
C
C                     3
C          f   = D + D / 3 - M
C
C                     2
C          f'  = 1 + D
C
C
C          f'' = 2 D
C

      CHANGE = 1.D0

      DO WHILE ( ABS ( CHANGE ) .GT. TOL )

         FN     = D    + D**3/3.D0 - M
         DERIV  = 1.D0 + D**2
         DERIV2 = 2.D0 * D

         CHANGE = (FN/DERIV) * ( 1.D0 + (FN*DERIV2) / (2.D0*DERIV**2) )
         D      = D - CHANGE

      END DO

      IF ( MA .LT. 0.D0 ) THEN
         D = -D
      END IF

      CALL CHKOUT ( 'PARTOF' )
      RETURN
      END