!========================================================================
!
!                          T o m o f a s t - x
!                        -----------------------
!
!              Main authors: Vitaliy Ogarko, Roland Martin,
!                   Jeremie Giraud, Dimitri Komatitsch.
!
! (c) CNRS, France, and University of Western Australia. January 2018
!
! The full text of the license is available in file "LICENSE".
!
!========================================================================

module m_matmul

  use global_typedefs, only: CUSTOM_REAL
  use utils, only: enforce_pb

  implicit none

  private

  public :: periodic_and_matmul
  private :: matmult

contains

! DG DG and DK DK to RM RM: it would be nice to have a similar routine in this file called defect()
! DG DG and DK DK to RM RM: that computes r=b-Ax. But unfortunately, this is not possible,
! DG DG and DK DK to RM RM: without having this routine perform the MPI_sendreceive() internally,
! DG DG and DK DK to RM RM: which means code restructuring, and then the benefit of not moving
! DG DG and DK DK to RM RM: an array twice through memory would be lost anyway???

!======================================================================================
! Computes only the local (at current CPU) part of r = Ax.
!
! NOTE 1: Arrays A and x have both intent 'in'. Therefore we split this function from
! periodic_and_matmul() where x has intent 'inout'. This potentially allows compiler for
! better optimization/vectorization of the loop.
!
! NOTE 2: The outer values (i,j,k=0, i=nr+1 etc) of r array should be set (zero out)
! outside this subroutine once and for all. Since having r = 0 inside the subroutine is
! too expensive (takes ~5% of the total CPU time).
!======================================================================================
pure subroutine matmult(A, x, r, nr, ntheta, nzlocal)
  integer, intent(in) :: nr, ntheta, nzlocal
  ! Vitaliy checked with callgrind and Allinea profilers that if we use assumed-shape arrays here,
  ! then it slows down the performance.
  real(kind=CUSTOM_REAL), intent(in) :: A(nr, ntheta, nzlocal, 7)
  real(kind=CUSTOM_REAL), intent(in) :: x(0:nr+1, 0:ntheta+1, 0:nzlocal+1)
  real(kind=CUSTOM_REAL), intent(out) :: r(0:nr+1, 0:ntheta+1, 0:nzlocal+1)

  ! Loop variables.
  integer i, j, k

  ! General multiplication: all BC's are included in a(i,j,k,:) coefficients.
  ! Vitaliy checked that this loop is vectorized by GNU compiler (gcc 4.9.3),
  ! by looking at the output with the flag -fopt-info-vec-optimized=vec.info.
  ! Also checked that the inner loop is vectorized by Intel compiler.
  do k = 1, nzlocal
    do j = 1, ntheta
      do i = 1, nr
        r(i, j, k) = a(i, j, k, 3) * x(i, j, k) + &
                     a(i, j, k, 2) * x(i - 1, j, k) + a(i, j, k, 4) * x(i + 1, j, k) + &
                     a(i, j, k, 1) * x(i, j - 1, k) + a(i, j, k, 5) * x(i, j + 1, k) + &
                     a(i, j, k, 6) * x(i, j, k - 1) + a(i, j, k, 7) * x(i, j, k + 1)
      enddo
    enddo
  enddo

end subroutine matmult

!======================================================================================
! Enforces periodic condition in theta on the x vector,
! then computes only the local part of r = Ax.
!======================================================================================
pure subroutine periodic_and_matmul(A, x, r, nr, ntheta, nzlocal)
  integer, intent(in) :: nr, ntheta, nzlocal
  ! Vitaliy checked with callgrind and Allinea profilers that if we use assumed-shape arrays here,
  ! then it slows down the performance.
  real(kind=CUSTOM_REAL), intent(in) :: A(nr, ntheta, nzlocal, 7)
  real(kind=CUSTOM_REAL), intent(inout) :: x(0:nr+1, 0:ntheta+1, 0:nzlocal+1)
  real(kind=CUSTOM_REAL), intent(out) :: r(0:nr+1, 0:ntheta+1, 0:nzlocal+1)

  ! Enforce periodic condition in theta on the x vector.
  call enforce_pb(nr, ntheta, nzlocal, x)

  ! Compute the local part of r = Ax.
  call matmult(A, x, r, nr, ntheta, nzlocal)

end subroutine periodic_and_matmul

end module m_matmul


MODULE spherical_harmonics
  INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND ( 14, 200 )
CONTAINS
  FUNCTION dlegendre (x, l, m) RESULT (dplm)
  SELECT CASE ( l )
  CASE ( 0 )
    dplm = 0.0_dp
  CASE ( 1 )
    dplm = 1.0_dp
  CASE DEFAULT
    IF ( mm > 0 ) THEN
      dpmm = -m
      DO im = 1, mm
        dpmm = -dpmm
      END DO
      IF ( l == mm + 1 ) THEN
        DO il = mm + 2, l
          dpll = dpmm
        END DO
        dplm = dpll
      END IF
    END IF
  END SELECT
  END FUNCTION dlegendre
END MODULE spherical_harmonics


module RectangularChGeometryModule
  use KindModule, only: DP, I4B
  use BaseGeometryModule, only: BaseGeometryType
  use ConstantsModule, only: DZERO, DEM5
  use SmoothingModule,  only: sCubicSaturation
  implicit none
  private
  public :: RectangularChGeometryType

  type, extends(BaseGeometryType) :: RectangularChGeometryType
    real(DP) :: width  = DZERO
    real(DP) :: length = DZERO
  contains
    procedure :: surface_area
    procedure :: top_width_wet
    procedure :: surface_area_wet
    procedure :: area_wet
    procedure :: perimeter_wet
    procedure :: set_attribute
    procedure :: init
    procedure :: print_attributes
  end type RectangularChGeometryType

  contains

  function surface_area(this)
! ******************************************************************************
! area_wet -- return surface area
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- modules
    use ConstantsModule, only: DTWO, DPI, DZERO
    ! -- return
    real(DP) :: surface_area
    ! -- dummy
    class(RectangularChGeometryType) :: this
! ------------------------------------------------------------------------------
    !
    ! -- Calculate surface area
    surface_area = this%width * this%length
    !
    ! -- Return
    return
  end function surface_area

  function top_width_wet(this, depth)
! ******************************************************************************
! area_wet -- return wetted surface area
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- modules
    use ConstantsModule, only: DTWO, DPI, DZERO
    ! -- return
    real(DP) :: top_width_wet
    ! -- dummy
    class(RectangularChGeometryType) :: this
    real(DP), intent(in) :: depth
    ! -- local
    real(DP) :: sat
! ------------------------------------------------------------------------------
    !
    ! -- Calculate surface area
    sat = sCubicSaturation(DEM5, DZERO, depth, DEM5)
    top_width_wet = this%width * sat
    !
    ! -- Return
    return
  end function top_width_wet

  function surface_area_wet(this, depth)
! ******************************************************************************
! area_wet -- return wetted surface area
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- modules
    use ConstantsModule, only: DTWO, DPI, DZERO
    ! -- return
    real(DP) :: surface_area_wet
    ! -- dummy
    class(RectangularChGeometryType) :: this
    real(DP), intent(in) :: depth
    ! -- local
    real(DP) :: top_width
! ------------------------------------------------------------------------------
    !
    ! -- Calculate surface area
    top_width = this%top_width_wet(depth)
    surface_area_wet = top_width * this%length
    !
    ! -- Return
    return
  end function surface_area_wet

  function area_wet(this, depth)
! ******************************************************************************
! area_wet -- return wetted area
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- modules
    use ConstantsModule, only: DTWO, DPI, DZERO
    ! -- return
    real(DP) :: area_wet
    ! -- dummy
    class(RectangularChGeometryType) :: this
    real(DP), intent(in) :: depth
! ------------------------------------------------------------------------------
    !
    ! -- Calculate area
    area_wet = depth * this%width
    !
    ! -- Return
    return
  end function area_wet

  function perimeter_wet(this, depth)
! ******************************************************************************
! perimeter_wet -- return wetted perimeter
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- modules
    use ConstantsModule, only: DTWO, DPI
    ! -- return
    real(DP) :: perimeter_wet
    ! -- dummy
    class(RectangularChGeometryType) :: this
    real(DP), intent(in) :: depth
! ------------------------------------------------------------------------------
    !
    ! -- Calculate wetted perimeter
    !perimeter_wet = DTWO * depth + this%width
    perimeter_wet = this%width
    !
    ! -- return
    return
  end function perimeter_wet

  subroutine set_attribute(this, line)
! ******************************************************************************
! set_attribute -- set a parameter for this rectangular channel object
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- module
    use InputOutputModule, only: urword
    use ConstantsModule, only: LINELENGTH
    use SimModule, only: ustop, store_error, count_errors
    ! -- dummy
    class(RectangularChGeometryType) :: this
    character(len=LINELENGTH) :: errmsg
    character(len=*), intent(inout) :: line
    ! -- local
    integer(I4B) :: lloc, istart, istop, ival
    real(DP) :: rval
! ------------------------------------------------------------------------------
    !
    ! -- should change this and set id if uninitialized or store it
    lloc=1
    call urword(line, lloc, istart, istop, 2, ival, rval, 0, 0)
    this%id = ival

    ! -- Parse the attribute
    call urword(line, lloc, istart, istop, 1, ival, rval, 0, 0)
    select case(line(istart:istop))
    case('NAME')
      call urword(line, lloc, istart, istop, 1, ival, rval, 0, 0)
      this%name = line(istart:istop)
    case('WIDTH')
      call urword(line, lloc, istart, istop, 3, ival, rval, 0, 0)
      this%width = rval
    case('LENGTH')
      call urword(line, lloc, istart, istop, 3, ival, rval, 0, 0)
      this%length = rval
    case default
      write(errmsg,'(4x,a,a)') &
        '****ERROR. UNKNOWN RECTANGULAR CHANNEL GEOMETRY ATTRIBUTE: ', &
                               line(istart:istop)
      call store_error(errmsg)
      call ustop()
    end select
    !
    ! -- return
    return
  end subroutine set_attribute

  subroutine init(this, id, name, width, length)
! ******************************************************************************
! init -- initialize this rectangular channel object
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- dummy
    class(RectangularChGeometryType) :: this
    integer(I4B), intent(in) :: id
    character (len=*), intent(in) :: name
    real(DP), intent(in) :: width
    real(DP), intent(in) :: length
! ------------------------------------------------------------------------------
    !
    ! -- initialize rectangular channel object using passed variables
    this%geo_type = 'RECTANGULAR CH'
    this%id = id
    this%name = name
    this%width = width
    this%length = length
    !
    ! -- return
    return
  end subroutine init

  subroutine print_attributes(this, iout)
! ******************************************************************************
! print_attributes -- print the attributes for this object
! *****************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- dummy
    class(RectangularChGeometryType) :: this
    ! -- local
    integer(I4B), intent(in) :: iout
    ! -- formats
    character(len=*), parameter :: fmtnm = "(4x,a,a)"
    character(len=*), parameter :: fmttd = "(4x,a,1(1PG15.6))"
    character(len=*), parameter :: fmtline = "(4x,36('-'))"
    character(len=*), parameter :: fmtend = "(4x)"
! ------------------------------------------------------------------------------
    !
    ! -- call parent to print parent attributes
    call this%BaseGeometryType%print_attributes(iout)
    !
    ! -- Print specifics of this geometry type
    write(iout, fmttd) 'WIDTH = ', this%width
    write(iout, fmttd) 'LENGTH = ', this%length
    write(iout, fmtline)
    write(iout, fmtend)
    !
    ! -- return
    return
  end subroutine print_attributes

end module RectangularChGeometryModule


!======================================================================!
  SUBROUTINE Prec1(N,NONZ,A,Acol,Arow,Adia,D,prec)
!----------------------------------------------------------------------!
!   Solves the linear systems of equations by a precond. CG Method.    !
!----------------------------------------------------------------------!
!------------------------------[Modules]-------------------------------!
  USE par_mod
!----------------------------------------------------------------------!
  IMPLICIT NONE
!-----------------------------[Parameters]-----------------------------!
  INTEGER  :: N, NONZ

  REAL     :: A(NONZ)
  INTEGER  :: Acol(N+1),Adia(N)
  INTEGER  :: Arow(NONZ)
  REAL     :: D(N)

  INTEGER  :: prec
!-------------------------------[Locals]-------------------------------!
  REAL     :: sum1
  INTEGER  :: i, j, k
!--------------------------------[CVS]---------------------------------!
!  $Id: Prec1.f90,v 1.9 2008/12/10 15:29:38 IUS\mhadziabdic Exp $
!  $Source: /home/IUS/mhadziabdic/.CVSROOT/T-Rex/Process/Prec1.f90,v $
!======================================================================!

!->>>
!      INTEGER c
!      do c=1,N
!        write(*,*) 'Cell: ', c
!        write(*,*) 'Width: ', Acol(c+1)-Acol(c)
!        write(*,'(3I7)') Acol(c), Adia(c), Acol(c+1)-1
!        write(*,*) 'Diag: ', A(Adia(c))
!        write(*,'(25F15.9)') ( A(j),     j=Acol(c),Acol(c+1)-1 )
!        write(*,'(25I7)') ( Arow(j), j=Acol(c),Acol(c+1)-1 )
!        write(*,*) '- - - - - - - - - - - - - - - - - - - - - - -'
!      end do

!+++++++++++++++++++++++++!
!     preconditioning     !
!+++++++++++++++++++++++++!

!----- 1) diagonal preconditioning -----!
!     => Parallelized                   !
  if(prec == 1) then
    do i=1,N
      D(i)=A(Adia(i))
    end do

!----- 2) incomplete cholesky preconditioning -----!
  else if(prec == 2) then
    do i=1,N
      sum1=A(Adia(i))
      do j=Acol(i), Adia(i)-1         ! only lower traingular
        k=Arow(j)
        sum1= sum1- D(k) * A(j)*A(j)
      end do
      D(i) = 1.0 / sum1                 ! BUG ?
    end do

!----- .) no preconditioning -----!
!     => Parallelized             !
  else
    do i=1,N
      D(i)=1.0
    end do
  end if

  END SUBROUTINE Prec1


c
c     file resc2cr.f
c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1999 by UCAR                 .
c  .                                                             .
c  .       UNIVERSITY CORPORATION for ATMOSPHERIC RESEARCH       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                      MUDPACK version 5.0                    .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c     subroutine resc2cr(nx,ny,work,res)
c
c
c ... author and specialist
c
c          John C. Adams (National Center for Atmospheric Research)
c          email: johnad@ucar.edu, phone: 303-497-1213
c
c ... For MUDPACK 5.0 information, visit the website:
c     (http://www.scd.ucar.edu/css/software/mudpack)
c
c
c ... purpose
c
c
c     subroutine resc2cr computes the fine grid residual in the nx by ny array
c     res after calling cud2cr or cuh2cr.  if
c
c          l * p = f
c
c     is the n by n (n = nx*ny) block tri-diagonal linear system resulting
c     from the pde discretization (done internally in cud2cr or cuh2cr) and
c     phi is the approximation to p obtained by calling cud2cr or cuh2cr,
c     then resc2cr computes the nx by ny residual array
c
c          res = f - l * phi.
c
c     one of the vector norms of res,
c
c          || res ||
c
c     can be computed as a "measure" of how well phi satisfies the
c     discretization equations.  for example, the following statements
c     will compute the location and size of the maximum residual in res
c     on cray computers:
c
c          ij = isamax(nx*ny,res,1)
c
c          jmax = (ij-1)/nx + 1
c
c          imax = ij - (jmax-1)*nx
c
c          resmax = abs(res(imax,jmax))
c
c
c *** please note:
c
c          let pe be the exact continuous solution to the elliptic pde
c          evaluated on the nx by ny discretization grid
c
c          let p be the exact solution to the linear discretization
c
c          let phi be the approximation to p generated by the mudpack solver
c
c     then discretization level error is defined by the condition
c
c          || phi - p || < || p - pe ||.
c                        =
c
c     a common measure of multigrid efficieny is that discretization level
c     error is reached in one full multigrid cycle (see references [2,9] in
c     the mudpack file "readme").  this can happen before the residual is
c     reduced to the level of roundoff error.  consequently, || res || is
c     a conservative measure of accuracy which can be wasteful if multi-
c     grid cycles are executed until it reaches the level of roundoff error.
c
c     || res || can be used to estimate the convergence rate of multigrid
c     iteration.  let r(n) be the residual and e(n) be the error after
c     executing n cycles.  they are related by the residual equation
c
c          l * e(n) = r(n).
c
c     it follows that the ratio
c
c          || r(n+1) || / || r(n) ||
c
c     estimates
c
c          || e(n+1) || / || e(n) ||
c
c     which in turn estimates the convergence rate
c
c          c = max || e(k+1) || / || e(k) ||.
c               k
c
c     notice
c                         n
c          || e(n) || <  c  || e(0) ||.
c
c
c ... assumptions (see cuh2cr.d or cud2cr.d)
c
c     (1) nx,ny have the same values as iparm(10),iparm(11) (used
c         to set the fine grid resolution when calling cud2cr or cuh2cr)
c
c     (2) work is the same argument used in calling cud2cr or cuh2cr.
c
c     (3) work has not changed since the last call to cud2cr or cuh2cr.
c
c     if these assumptions are not true then resc2cr cannot compute the
c     residual in res. (3) assures a copy of the last approximation phi
c     is contained in work.
c
      subroutine resc2cr(nx,ny,work,res)
      implicit none
      integer nx,ny,ic
      real work(*),res(nx,ny)
c
c     set pointer for fine grid coefficients in work
c
      ic = 1+(nx+2)*(ny+2)
      call rec2cr(nx,ny,work,work(ic),res)
      return
      end

      subroutine rec2cr(nx,ny,phi,cof,res)
c
c     compute residual
c
      implicit none
      integer nx,ny,i,j
      real phi(0:nx+1,0:ny+1),cof(nx,ny,10),res(nx,ny)
      do j=1,ny
	do i=1,nx
	  res(i,j) = cof(i,j,10) - (cof(i,j,9)*phi(i,j) +
     +               cof(i,j,1)*phi(i+1,j) + cof(i,j,2)*phi(i+1,j+1) +
     +               cof(i,j,3)*phi(i,j+1) + cof(i,j,4)*phi(i-1,j+1) +
     +               cof(i,j,5)*phi(i-1,j) + cof(i,j,6)*phi(i-1,j-1) +
     +               cof(i,j,7)*phi(i,j-1) + cof(i,j,8)*phi(i+1,j-1) )
	end do
      end do
      return
      end


c     program DRDSORT
c>>   1994-10-19 DRDSORT  Krogh  Changes to use M77CON
c>>   1989-06-13 DRDSORT  CLL Changed "dranua (r" to "dranua (d"
c>>   1988-11-20 DRDSORT  Snyder  Initial code.
c--D replaces "?": DR?SORT, ?SORT, ?SORTP, ?RANUA
c
c     Test driver for DSORT and DSORTP.
c
c     Construct an array of 1000 random numbers using DRANUA.
c     Sort it using DSORTP.
c     Check whether it is in order.
c     Sort it using DSORT.
c     Check whether it is in order.
c
      logical OK
      integer I, P(1:1000)
      double precision X(1:1000)
c
c     Generate 1000 random numbers
      call dranua (x, 1000)
c     Sort them using DSORTP.  Assume the sort will work.
      ok=.TRUE.
      call dsortp (x,1,1000,p)
c     Check the order.
      do 10 i = 2, 1000
         if (x(p(i)).lt.x(p(i-1))) ok=.FALSE.
   10 continue
c     Print the results.
      if(ok)then
         print *,'DSORTP succeeded'
      else
         print *,'DSORTP failed'
      end if
c     Sort them using DSORT.  Assume the sort will work.
      ok=.TRUE.
      call dsort (x,1,1000)
c     Check the order.
      do 20 i = 2, 1000
         if (x(i).lt.x(i-1)) ok=.FALSE.
   20 continue
c     Print the results.
      if(ok)then
         print *,'DSORT succeeded'
      else
         print *,'DSORT failed'
      end if
c
      end


      subroutine clawpack46_tag4refinement(mx,my,mbc,meqn,
     &      xlower,ylower,dx,dy,blockno,q,refine_threshold,
     &      init_flag,tag_for_refinement)
      implicit none

      integer mx,my, mbc, meqn, tag_for_refinement, init_flag
      integer blockno
      double precision xlower, ylower, dx, dy
      double precision refine_threshold
      double precision q(1-mbc:mx+mbc,1-mbc:my+mbc,meqn)

      integer i,j, mq
      double precision xc,yc, qmin, qmax,qx,qy

      tag_for_refinement = 0

c     # Refine based only on first variable in system.
      qmin = 0.025d0
      qmax = 0.975d0
      do mq = 1,meqn
         do i = 1,mx
            do j = 1,my
               qx = (q(i+1,j,1)-q(i-1,j,1))/(2*dx)
               qy = (q(i,j+1,1)-q(i,j-1,1))/(2*dy)
               if (abs(qx) .gt. refine_threshold .or.
     &               abs(qy) .gt. refine_threshold) then
                  tag_for_refinement = 1
                  return
               endif
c              # Tag grid if at least one value is in [qmin,qmax]
c               if (q(i,j,1) .gt. qmin
c     &               .and. q(i,j,1) .lt. qmax) then
c                  tag_for_refinement = 1
c                  return
c               endif
            enddo
         enddo
      enddo

      end


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


C     Calls the fortran program bsplpp that converts
C     B-form coeff to pp form.
C     simplified version with no repeated knots
C     coef = mexbsplpp(knots,fknots)
C     knots(l+7), fknots(l+3)

C     The gateway routine
      subroutine mexFunction(nlhs, plhs, nrhs, prhs)

      integer mxGetM, mxGetN, mxGetPr
      integer mxIsNumeric, mxCreateDoubleMatrix
      integer plhs(*), prhs(*)
      integer knots_pr, fknots_pr, coef_pr
      integer nlhs, nrhs
      integer m, n, size1, size2, k, l,sizecoef
      real*8 knots(1000), fknots(1000), coef(4,1000),scrtch(4,4)
      real*8 break(1000),bcoef(1000),mxGetScalar

C     Check for proper number of arguments.
      if(nrhs .ne. 2) then
         call mexErrMsgTxt('Two vectors input required.')
      elseif(nlhs .ne. 1) then
         call mexErrMsgTxt('One output required.')
      endif

C     Get the sizes of input arrays.
      m = mxGetM(prhs(1))
      n = mxGetN(prhs(1))
      size1 = m*n
      m = mxGetM(prhs(2))
      n = mxGetN(prhs(2))
      size2 = m*n
      n = size2
      l = n - 3

C     Column * row should be smaller than 1000.
      if(size1.gt.1000 .or. size2.gt.1000) then
         call mexErrMsgTxt('Row * column must be <= 1000.')
      endif

C     Check to ensure the input is a number.
      if(mxIsNumeric(prhs(1)) .eq. 0) then
         call mexErrMsgTxt('Input must be a number.')
      endif

C     Create matrix for the return argument.
      plhs(1) = mxCreateDoubleMatrix(4, l , 0)
      coef_pr = mxGetPr(plhs(1))

C     Copy input vectors to knots and fknots
      knots_pr = mxGetPr(prhs(1))
      fknots_pr = mxGetPr(prhs(2))
      call mxCopyPtrToReal8(knots_pr, knots, size1)
      call mxCopyPtrToReal8(fknots_pr, fknots, size2)

C     Call the computational subroutine.
      k = 4
      call bsplpp(knots,fknots,size2,k,scrtch,break,coef,l)

C     Load the data into coef_pr, which is the output to MATLAB.
      sizecoef = 4*(n-3)
      call mxCopyReal8ToPtr(coef, coef_pr, sizecoef)
      return
      end


      SUBROUTINE MA02CZ( N, KL, KU, A, LDA )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the pertranspose of a central band of a square matrix.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the square matrix A.  N >= 0.
C
C     KL      (input) INTEGER
C             The number of subdiagonals of A to be pertransposed.
C             0 <= KL <= N-1.
C
C     KU      (input) INTEGER
C             The number of superdiagonals of A to be pertransposed.
C             0 <= KU <= N-1.
C
C     A       (input/output) COMPLEX*16 array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain a square matrix whose central band formed from
C             the KL subdiagonals, the main diagonal and the KU
C             superdiagonals will be pertransposed.
C             On exit, the leading N-by-N part of this array contains
C             the matrix A with its central band (the KL subdiagonals,
C             the main diagonal and the KU superdiagonals) pertransposed
C             (that is the elements of each antidiagonal appear in
C             reversed order). This is equivalent to forming P*B'*P,
C             where B is the matrix formed from the central band of A
C             and P is a permutation matrix with ones down the secondary
C             diagonal.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= max(1,N).
C
C     CONTRIBUTOR
C
C     A. Varga, German Aerospace Center,
C     DLR Oberpfaffenhofen, March 1998.
C     Complex version: V. Sima, Research Institute for Informatics,
C     Bucharest, Nov. 2008.
C
C     REVISIONS
C
C     -
C
C    ******************************************************************
C
C     .. Scalar Arguments ..
      INTEGER          KL, KU, LDA, N
C     .. Array Arguments ..
      COMPLEX*16       A(LDA,*)
C     .. Local Scalars ..
      INTEGER          I, I1, LDA1
C     .. External Subroutines ..
      EXTERNAL         ZSWAP
C     .. Intrinsic Functions ..
      INTRINSIC        MIN
C     .. Executable Statements ..
C
C     Quick return if possible.
C
      IF( N.LE.1 )
     $   RETURN
C
      LDA1 = LDA + 1
C
C     Pertranspose the KL subdiagonals.
C
      DO 10 I = 1, MIN( KL, N-2 )
         I1 = (N-I) / 2
         IF( I1.GT.0 )
     $      CALL ZSWAP( I1, A(I+1,1), LDA1, A(N-I1+1,N-I1+1-I), -LDA1 )
   10 CONTINUE
C
C     Pertranspose the KU superdiagonals.
C
      DO 20 I = 1, MIN( KU, N-2 )
         I1 = (N-I) / 2
         IF( I1.GT.0 )
     $      CALL ZSWAP( I1, A(1,I+1), LDA1, A(N-I1+1-I,N-I1+1), -LDA1 )
   20 CONTINUE
C
C     Pertranspose the diagonal.
C
      I1 = N / 2
      IF( I1.GT.0 )
     $   CALL ZSWAP( I1, A(1,1), LDA1, A(N-I1+1,N-I1+1), -LDA1 )
C
      RETURN
C *** Last line of MA02CZ ***
      END


program to_f_the_ineffable
   use, intrinsic :: ieee_arithmetic
   integer :: i
   real dimension(2) :: y, x = (/ 30, ieee_value(y,ieee_positive_inf) /)

   do i = 1, 2
      if (ieee_support_datatype(x(i))) then
         if (ieee_is_finite(x(i))) then
            print *, 'x(',i,') is finite'
         else
            print *, 'x(',i,') is infinite'
         end if

      else
         print *, 'x(',i,') is not in an IEEE-supported format'
      end if
   end do
end program to_f_the_ineffable


PROGRAM GENERATE_DELAUNAY_DATA
! Generate test data to be interpolated by Delaunay.
IMPLICIT NONE

! PROBLEM DIMENSIONS:
! ADJUST VALUES D AND N TO GENERATE PROBLEMS OF VARYING SIZE.
!-----------------------------------------------------------!
INTEGER, PARAMETER :: D=20, N=500
!-----------------------------------------------------------!

! Get real precision.
INTEGER, PARAMETER :: DP = SELECTED_REAL_KIND(15, 307)
! Local variables.
REAL(KIND=DP) :: A(D), B(D) ! Temp arrays for storing output.
INTEGER :: I ! Loop index.
!INTEGER, ALLOCATABLE :: SEED(:)

! Initialize random seed.
CALL RANDOM_SEED()

! Store output in file deldata.txt below.
OPEN(D, FILE='deldata.txt')
WRITE(D, *) D, N, 1, 0
B(1:D) = 0.0_DP
! Begin generating data points at random.
DO I = 1, N
   CALL RANDOM_NUMBER(A)
   WRITE(D, *) A(1:D)
   B(1:D) = B(1:D) + A(1:D)
END DO
! Get an interior point for interpolation.
B(1:D) = B(1:D) / REAL(N, KIND=DP)
WRITE(D, *) B(1:D)
CLOSE(D)

END PROGRAM GENERATE_DELAUNAY_DATA


!==============================================================================
module ModHeatEq
  ! This is a "module" subprogram.
  ! Modules are ways to share values and subroutines across many parts
  ! of a larger F90 code.
  ! This contains methods and variables to solve the heat equation for a simple
  ! initial condition.

  ! Begin the initialization/declaration part of the code.

  ! This ensures that NO values are implicitly declared.
  ! ALWAYS include implicit none!!!
  implicit none
  save  ! "save" can be used to ensure that variables retain their values
  ! between calls to this module.  If you don't "save", variables are
  ! reset between calls to this subprogram.

  ! Variable declarations.
  ! Statically typed- variable meanings can't change within any part
  ! of the program!
  logical :: DoTest = .true.
  integer :: nT, nX
  real    :: dt, dx, tLimit=0.2, xLim(2) = (/0,1/)

  ! If you don't know how big an array is upon declaration, we need to
  ! make them allocatable. This means we allocate their size at run time.
  real, allocatable :: Domain_II(:,:)
  real, allocatable :: xGrid(:), tGrid(:)

  ! Constants: the parameter attribute means they can't change their values.
  real, parameter :: cDiffusion = 1.0

  ! The "contains" statement says "everything below this point has access to
  ! the module variables and all functions/subroutines below can be shared
  ! through the module".
contains

  !============================================================================
  subroutine run_simulation
    ! Advance our simulation from the initial condition to the end of the time
    ! range.  This should only be called AFTER the simulation domain has
    ! been initialized using "init_sim".

    ! Note our local variable declarations that are not recognized elsewhere
    ! within the module.
    integer :: j
    real    :: r
    !------------------------------------------------------------------------
    write(*,*) 'Beginning Simulation.'

    ! Check for stability:
    if( .not.IsStable(dT, dx, cDiffusion) ) then
       ! If we're not stable, we need to tell the user and
       ! end the program.  Create a well formatted message:
       write(*,"(a,f10.8,' >',f10.8)")'ERROR: Stability criterion not met! ', &
            dt, (dx**2.0/(2*cDiffusion**2.0))
       stop  ! The stop statement ends the whole program!
    end if

    ! Integrate!
    write(*,*) '...integrating...'
    ! Calculate a coefficient...
    r= cDiffusion**2.0 * dt / dx**2.0

    ! For each point from now until the second to last time,
    ! calculate the next state.  See the full PDF for details.
    do j=1, nT-1
       ! Note the ampersand is the line continuation marker.
       Domain_II(2:nX-1,j+1) = (1.0-2.0*r) * Domain_II(2:nX-1, j) + &
            r * (Domain_II(1:nx-2,j) + Domain_II(3:nx,j))
    end do

    ! Write results to file.  We do this by calling an external subroutine
    ! (see write2d.f90).  Note the ampersand is the line continuation marker.
    call write2d('results.txt', nX, nT, Domain_II, &
         xGrid, tGrid, 'NMUM Chapter 10 Example 3')

  end subroutine run_simulation

  !============================================================================
  logical function IsStable(dt, dx, c)
    ! Given a dt, dx, and a diffusion coefficient, c, determine if the
    ! simulation is stable.  Return a logical indicating the result.

    ! Functions have 0 or more inputs but only ONE output.  The output
    ! is the variable declared with the function name (i.e., "IsStable").
    ! IsStable is sent back to caller, e.g., x = IsStable(dt, dx, c).

    real, intent(in) :: dt, dx, c
    !------------------------------------------------------------------------

    ! Note how we use the name of the function as a variable inside the function
    IsStable = .true.
    if ( dt > (dx**2.0/(2.0*c**2.0)) ) IsStable=.false.

    ! We don't need a "return" statement.  Functions return only one value
    ! every time.

  end function IsStable

  !============================================================================
  subroutine init_sim(DxIn, DtIn)

    ! Subroutines have 0 or more inputs and 0 or more outputs.  We must use
    ! variable attributes to set the "intent" of the variables.  Are they
    ! input, output, or both?  Inputs CAN NOT be changed within the
    ! subroutine!  This is a good way to prevent mistakes and is a good
    ! habit!

    ! Set up the simulation.
    ! Note that for all inputs and outputs, we need to set their
    ! intent. intent(in) are values that cannot be edited/changed inside
    ! the subroutine.  intent(out) are returned to the caller.
    ! intent(inout) are inputs that *can* be changed.  Pick carefully!
    real, intent(in) :: DxIn, DtIn

    ! We also need just one integer.
    integer:: i
    !------------------------------------------------------------------------
    write(*,*) '...initializing simulation...'

    ! Set dx, dt based on inputs.  Because we cannot change our inputs, we
    ! copy them to new memory locations.
    dx = DxIn
    dt = DtIn

    ! Determine size of arrays.  "ceiling" rounds to the next highest integer.
    nX = ceiling( (xLim(2)-xLim(1))/dx + 1.0 )
    nT = ceiling( tLimit/dt +  1.0 )

    if(DoTest) write(*,*) '   Grid size (nX, nT) = ', nX, nT

    ! Now that we know size of arrays, allocate our arrays.
    allocate(Domain_II(nX, nT))
    allocate(xGrid(nX))
    allocate(tGrid(nT))

    ! It's usually a good idea to fill matrices with zeros.
    ! Make a habit of doing this.
    Domain_II = 0
    xGrid     = 0

    ! Set up grid and initial conditions.
    ! See PDF for details.
    do i=1, nX
       xGrid(i)       = (i-1) * dx
       Domain_II(i,1) = 4.0*xGrid(i) - 4.0*xGrid(i)**2.0
    end do

    ! Create time grid.
    do i=1, nT
       tGrid(i) = real(i-1) * dT
    end do

    ! We are ready to go!

  end subroutine init_sim

  !============================================================================
  subroutine finalize_sim
    ! Finalize the simulation by deallocating arrays.  This is a good habit!

    !------------------------------------------------------------------------
    deallocate(Domain_II)
    deallocate(xGrid)
    deallocate(tGrid)

    ! ALWAYS deallocate your arrays!  Otherwise, you will get memory leaks.

    write(*,*)'Finished simulation.  Produced ', nX*nT, ' points.'
  end subroutine finalize_sim

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

end module ModHeatEq
!==============================================================================


module reader

  implicit none
  public

  integer, parameter :: dp = kind(1.d0)

contains

  subroutine sq_file(filename, npoints, q, sq)

    character (len = *), intent(in) :: filename
    integer, intent(in)             :: npoints

    real (dp), dimension(npoints), intent(out) :: q
    real (dp), dimension(npoints), intent(out) :: sq

    integer :: n, nd, np

    open (unit = 20, file = filename, form = 'formatted', &
          action = 'read', status = 'old')

    do n = 1, npoints
       read(unit = 20, *) nd, np, q(n), sq(n)
    end do

    close (unit = 20, status = 'keep')
    return

  end subroutine sq_file

  !---------------------------------------------------------------------------
  !
  !  sq_theory
  !
  !  We have S(q) = kT / (A + kappa q^2)
  !
  !  with a correction to q^2 (from Markus)
  !  q^2 = -(1/3) (2*(cos(q_x)*cos(q_y)) + 4*(cos(q_x) + cos(q_y)) - 10)
  !
  !  Our parameters: A = 9.4e-04, B=0.01, K=0.0001, kT = 5e-05
  !
  !---------------------------------------------------------------------------

  subroutine sq_theory(filename)

    character (len = *), intent(in) :: filename

    integer, parameter   :: npoints = 100
    real (dp), parameter :: a = 0.00094
    real (dp), parameter :: kappa = 0.0001
    real (dp), parameter :: kt = 0.00005

    integer   :: n
    real (dp) :: q, qsq, sq

    open (unit = 20, file = filename, form = 'formatted', &
          action = 'write', status = 'new')

    do n = 1, npoints
       q = 4.0*n*atan(1.d0)/npoints
       qsq = q*q ! naive value
       qsq = -(1.0/3.0)*(2.0*(cos(q)*1.0) + 4.0*(cos(q) + 1.0) - 10.0)
       sq = kt / (a + kappa*qsq)
       write(unit = 20, fmt = '2(1x,e14.7)') q, sq
    end do

    close (unit = 20, status = 'keep')
    return

  end subroutine sq_theory

end module reader

program average

  use reader
  implicit none

  integer, parameter :: n = 32
  integer               np

  real (dp), dimension(n) :: sqtot
  real (dp), dimension(n) :: q, sq

  sqtot(:) = 0.0d0

  call sq_file('sq045.dat', n, q, sq)
  sqtot(:) = sqtot(:) + sq(:)

  call sq_file('sq050.dat', n, q, sq)
  sqtot(:) = sqtot(:) + sq(:)

  call sq_file('sq055.dat', n, q, sq)
  sqtot(:) = sqtot(:) + sq(:)

  call sq_file('sq060.dat', n, q, sq)
  sqtot(:) = sqtot(:) + sq(:)

  call sq_file('sq065.dat', n, q, sq)
  sqtot(:) = sqtot(:) + sq(:)

  call sq_file('sq070.dat', n, q, sq)
  sqtot(:) = sqtot(:) + sq(:)

  call sq_file('sq075.dat', n, q, sq)
  sqtot(:) = sqtot(:) + sq(:)

  call sq_file('sq080.dat', n, q, sq)
  sqtot(:) = sqtot(:) + sq(:)

  call sq_file('sq085.dat', n, q, sq)
  sqtot(:) = sqtot(:) + sq(:)

  call sq_file('sq090.dat', n, q, sq)
  sqtot(:) = sqtot(:) + sq(:)

  call sq_file('sq095.dat', n, q, sq)
  sqtot(:) = sqtot(:) + sq(:)

  call sq_file('sq100.dat', n, q, sq)
  sqtot(:) = sqtot(:) + sq(:)

  sqtot(:) = sqtot(:) / 12.0

  ! final result

  open (unit = 20, file = 'sqav.dat', form = 'formatted', &
        action = 'write', status = 'new')

  do np = 1, 25
     write (unit = 20, fmt = '(2(1x,e14.7))') q(np), sq(np)
  end do

  close (unit = 20, status = 'keep')

  call sq_theory('sqth.dat')
  stop

end program average


      PROGRAM xcorrel
C     driver for routine correl
      INTEGER N,N2
      REAL PI
      PARAMETER(N=64,N2=128,PI=3.1415927)
      INTEGER i,j
      REAL cmp,data1(N),data2(N),ans(N2)
      do 11 i=1,N
        data1(i)=0.0
        if ((i.gt.(N/2-N/8)).and.(i.lt.(N/2+N/8))) data1(i)=1.0
        data2(i)=data1(i)
11    continue
      call correl(data1,data2,N,ans)
C     calculate directly
      write(*,'(/1x,t4,a,t13,a,t25,a/)') 'n','CORREL','Direct Calc.'
      do 13 i=0,16
        cmp=0.0
        do 12 j=1,N
          cmp=cmp+data1(mod(i+j-1,N)+1)*data2(j)
12      continue
        write(*,'(1x,i3,3x,f12.6,f15.6)') i,ans(i+1),cmp
13    continue
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xcorrel.for


!
! wavy - A spectral ocean wave modeling and development framework
! Copyright (c) 2017, Wavebit Scientific LLC
! All rights reserved.
!
! Licensed under the BSD-3-clause license. See LICENSE for details.

module mod_aerodynamic_drag

use mod_precision,only:ik => intkind,rk => realkind

implicit none

private

! Public constants
public :: charnockParameter_C1955
public :: charnockParameter_G1977
public :: charnockParameter_W1980

! Public functions
public :: charnockParameter
public :: dragCoefficient_AMV2012
public :: dragCoefficient_DW1962
public :: dragCoefficient_LP1981
public :: dragCoefficient_LY2004
public :: dragCoefficient_TY2001
public :: dragCoefficient_Y1988
public :: dragCoefficient_YT1996
public :: dragCoefficientFromRoughnessLength
public :: dragCoefficientFromFrictionVelocity
public :: skinFrictionVelocity
public :: windAtReferenceHeight

! Named constants
real(kind=rk),parameter :: charnockParameter_C1955 = 0.0120_rk
real(kind=rk),parameter :: charnockParameter_G1977 = 0.0144_rk
real(kind=rk),parameter :: charnockParameter_W1980 = 0.0185_rk

contains

!-------------------------------------------------------------------------------
pure elemental function charnockParameter(z0,ustar,grav) result(alpha)
  !! Returns the Charnock parameter $\alpha$ based on input roughness
  !! length [m], friction velocity [m/s], and gravitational
  !! acceleration [m/s^2].
  !!
  !! TODO add reference
  real(kind=rk),intent(in) :: z0
    !! Roughness length [m]
  real(kind=rk),intent(in) :: ustar
    !! Friction velocity [m/s]
  real(kind=rk),intent(in) :: grav
    !! Gravitational acceleration [m/s^2]
  real(kind=rk) :: alpha
    !! Charnock parameter
  alpha = grav * z0 / ustar**2
endfunction charnockParameter
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
pure elemental function dragCoefficient_AMV2012(wspd) result(cd)
  !! Returns the drag coefficient given the input wind speed at 10 m,
  !! based on Andreas, Maahrt, and Vickers (2012).
  !!
  !! TODO add reference
  real(kind=rk),intent(in) :: wspd
    !! Wind speed at 10 m height [m/s]
  real(kind=rk) :: cd
    !! Drag coefficient
  real(kind=rk) :: ustar
  if(wspd <= 9)then
    ustar = 5.13e-3_rk + 2.83e-2_rk*wspd
  else
    ustar = -2.43e-1_rk + 5.831e-2_rk*wspd
  endif
  cd = dragCoefficientFromFrictionVelocity(ustar,wspd)
endfunction dragCoefficient_AMV2012
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
pure elemental function dragCoefficient_DW1962(wspd) result(cd)
  !! Returns the drag coefficient given the input wind speed at 10 m,
  !! based on Deacon and Webb (1962).
  !!
  !! TODO add reference
  real(kind=rk),intent(in) :: wspd
    !! Wind speed at 10 m height [m/s]
  real(kind=rk) :: cd
    !! Drag coefficient
  cd = (1._rk+0.05_rk*wspd)*1e-3_rk
endfunction dragCoefficient_DW1962
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
pure elemental function dragCoefficient_LP1981(wspd) result(cd)
  !! Returns the drag coefficient given the input wind speed at 10 m,
  !! based on Large and Pond (1981).
  !!
  !! TODO add reference
  real(kind=rk),intent(in) :: wspd
    !! Wind speed at 10 m height [m/s]
  real(kind=rk) :: cd
    !! Drag coefficient
  if(wspd > 11)then
    cd = (0.49_rk+0.065_rk*wspd)*1e-3_rk
  else
    cd = 1.2e-3_rk
  endif
endfunction dragCoefficient_LP1981
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
pure elemental function dragCoefficient_LY2004(wspd) result(cd)
  !! Returns the drag coefficient given the input wind speed at 10 m,
  !! based on Large and Yeager (2004).
  !!
  !! TODO add reference
  real(kind=rk),intent(in) :: wspd
    !! Wind speed at 10 m height [m/s]
  real(kind=rk) :: cd
    !! Drag coefficient
  cd = (0.142_rk + 0.076_rk*wspd + 2.7_rk/wspd)*1e-3_rk
endfunction dragCoefficient_LY2004
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
pure elemental function dragCoefficient_TY2001(significant_height,&
  dominant_wavelength,vonkarman) result(cd)
  !! Returns the drag coefficient given the input significant wave height and
  !! dominant wavelength, based on Taylor and Yelland (2001).
  !!
  !! TODO add reference
  real(kind=rk),intent(in) :: significant_height
    !! Significant wave height [m]
  real(kind=rk),intent(in) :: dominant_wavelength
    !! Dominant wavelength [m]
  real(kind=rk),intent(in) :: vonkarman
    !! Von Karman constant
  real(kind=rk) :: cd
    !! Drag coefficient
  cd = dragCoefficientFromRoughnessLength(1.2e3_rk * significant_height&
     * (significant_height/dominant_wavelength)**4.5_rk,vonkarman)
endfunction dragCoefficient_TY2001
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
pure elemental function dragCoefficient_Y1988(wspd) result(cd)
  !! Returns the drag coefficient given the input wind speed at 10 m,
  !! based on Yelland et al. (1988).
  !!
  !! TODO add reference
  real(kind=rk),intent(in) :: wspd
    !! Wind speed at 10 m height [m/s]
  real(kind=rk) :: cd
    !! Drag coefficient
  cd = (0.5_rk+0.071_rk*wspd)*1e-3_rk
endfunction dragCoefficient_Y1988
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
pure elemental function dragCoefficient_YT1996(wspd) result(cd)
  !! Returns the drag coefficient given the input wind speed at 10 m,
  !! based on Yelland and Taylor (1996).
  !!
  !! TODO add reference
  real(kind=rk),intent(in) :: wspd
    !! Wind speed at 10 m height [m/s]
  real(kind=rk) :: cd
    !! Drag coefficient
  if(wspd < 11)then
    cd = (0.29_rk+3.1_rk/wspd+7.7_rk/wspd**2)*1e-3_rk
  else
    cd = (0.6_rk+0.070_rk*wspd)*1e-3_rk
  endif
endfunction dragCoefficient_YT1996
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
pure elemental function dragCoefficientFromFrictionVelocity(ustar,wspd)&
  result(cd)
  !! Returns the drag coefficient given the input friction velocity and wind
  !! speed.
  real(kind=rk),intent(in) :: ustar
    !! Friction velocity [m/s]
  real(kind=rk),intent(in) :: wspd
    !! Wind speed [m/s]
  real(kind=rk) :: cd
    !! Drag coefficient
  cd = (ustar/wspd)**2
endfunction dragCoefficientFromFrictionVelocity
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
pure elemental function dragCoefficientFromRoughnessLength(z0,vonkarman)&
  result(cd)
  !! Returns the drag coefficient given the input von Karman constant
  !! and roughness length.
  !!
  !! TODO add reference
  real(kind=rk),intent(in) :: z0
    !! Aerodynamic roughness length [m]
  real(kind=rk),intent(in) :: vonkarman
    !! Von Karman constant
  real(kind=rk) :: cd
    !! Drag coefficient
  cd = (vonkarman/log(10/z0))**2
endfunction dragCoefficientFromRoughnessLength
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
pure elemental real(kind=rk)function skinFrictionVelocity(wspd,height,&
  viscosity,vonkarman) result(ustar)
  !! Computes the friction velocity for a smooth flow over the flat wall,
  !! given input wind speed [m/s], height of input wind [m], air viscosity
  !! [m^2/s], and Von Karman constant.
  real(kind=rk),intent(in) :: wspd
    !! Wind speed at input height above the surface [m/s]
  real(kind=rk),intent(in) :: height
    !! Height of input wind [m]
  real(kind=rk),intent(in) :: viscosity
    !! Viscosity [m^2/s]
  real(kind=rk),intent(in) :: vonkarman
    !! Von Karman constant
  real(kind=rk) :: z0 ! roughness length
  real(kind=rk) :: ustar_old
  integer :: n
  z0 = 0.001_rk
  ustar_old = 1e-2_rk
  do
    ustar = vonkarman*wspd/log(height/z0)
    if(abs(ustar-ustar_old) < 1e-3_rk)then
      return
    endif
    z0 = 0.132_rk*viscosity/ustar
  enddo
endfunction skinFrictionVelocity
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
pure elemental real(kind=rk) function windAtReferenceHeight(input_wspd,&
  input_height,reference_height,ustar,vonkarman) result(wspd)
  !! Computes the wind speed at reference height, given input wind speed [m/s],
  !! height of input wind [m] at input height, friction velocity [m/s], and
  !! Von Karman constant.
  real(kind=rk),intent(in) :: input_wspd
    !! Wind speed at input height above the surface [m/s]
  real(kind=rk),intent(in) :: input_height
    !! Height of input wind [m]
  real(kind=rk),intent(in) :: reference_height
    !! Reference height [m]
  real(kind=rk),intent(in) :: ustar
    !! Friction velocity [m/s]
  real(kind=rk),intent(in) :: vonkarman
    !! Von Karman constant
  wspd = input_wspd+ustar/vonkarman*log(reference_height/input_height)
endfunction windAtReferenceHeight
!-------------------------------------------------------------------------------
endmodule mod_aerodynamic_drag


!----------------------------------------------------------------------
!----------------------------------------------------------------------
!   fsh :     Heteroclinic orbits : a saddle-node copnnection
!----------------------------------------------------------------------
!----------------------------------------------------------------------
! Parameter assignment:
!
!           PAR(1)           :                   (unused)
!           PAR(2)           : c                 (wave speed)
!           PAR(4)           : eps-1        1    (radius)
!           PAR(11)          : period
!           PAR(12)          : mu-1              (eigenvalue  at 1)
!           PAR(13) , PAR(14): v(1)    , v(2)    (eigenvector at 1)
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------

      SUBROUTINE FUNC(NDIM,U,ICP,PAR,IJAC,F,DFDU,DFDP)
!     ---------- ----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM, ICP(*), IJAC
      DOUBLE PRECISION, INTENT(IN) :: U(NDIM), PAR(*)
      DOUBLE PRECISION, INTENT(OUT) :: F(NDIM)
      DOUBLE PRECISION, INTENT(INOUT) :: DFDU(NDIM,NDIM), DFDP(NDIM,*)

      DOUBLE PRECISION PERIOD,DUMMY(1)
      INTEGER I

       CALL FFFF(2,U,ICP,PAR,IJAC,F,DUMMY)
       PERIOD=PAR(11)
       DO I=1,NDIM
         F(I)=PERIOD*F(I)
       ENDDO

      END SUBROUTINE FUNC

      SUBROUTINE FFFF(NDM,U,ICP,PAR,IJAC,F,DFDU)
!     ---------- ----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDM, ICP(*), IJAC
      DOUBLE PRECISION, INTENT(IN) :: U(NDM), PAR(*)
      DOUBLE PRECISION, INTENT(OUT) :: F(NDM)
      DOUBLE PRECISION, INTENT(INOUT) :: DFDU(NDM,NDM)

      DOUBLE PRECISION C

       C=PAR(2)
       F(1)= U(2)
       F(2)= C*U(2) - U(1) * (1-U(1))

      IF(IJAC.EQ.0)RETURN

       DFDU(1,1)= 0
       DFDU(1,2)= 1

       DFDU(2,1)= -1 + 2*U(1)
       DFDU(2,2)= C

      END SUBROUTINE FFFF

      SUBROUTINE STPNT(NDIM,U,PAR,T)
!     ---------- -----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM
      DOUBLE PRECISION, INTENT(INOUT) :: U(NDIM),PAR(*)
      DOUBLE PRECISION, INTENT(IN) :: T

      DOUBLE PRECISION PERIOD, C, EP1, D, RMU1, V11, V12

      IF(T==0)THEN
!       Set the starting period, wave speed, and radius
        PERIOD=0.01
        C=11.
        EP1=0.001
        D = SQRT(C**2+4)
        PAR(2)= C
        PAR(4)= EP1
        PAR(11)= PERIOD
        PAR(12)= (C-D)/2
        PAR(13) =    1./SQRT(1+PAR(12)**2)
        PAR(14)=PAR(12)/SQRT(1+PAR(12)**2)
       ENDIF

       C     =PAR(2)
       EP1   =PAR(4)
       PERIOD=PAR(11)
       D=SQRT(C**2+4)
       RMU1= (C-D)/2
       V11 =  1./SQRT(1+RMU1**2)
       V12 =RMU1/SQRT(1+RMU1**2)

       U(1)=1-EP1*V11
       U(2)= -EP1*V12

      END SUBROUTINE STPNT

      SUBROUTINE BCND(NDIM,PAR,ICP,NBC,U0,U1,FB,IJAC,DBC)
!     ---------- ----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM, ICP(*), NBC, IJAC
      DOUBLE PRECISION, INTENT(IN) :: PAR(*), U0(NDIM), U1(NDIM)
      DOUBLE PRECISION, INTENT(OUT) :: FB(NBC)
      DOUBLE PRECISION, INTENT(INOUT) :: DBC(NBC,*)
! Local
      INTEGER, PARAMETER :: NDM=2
      DOUBLE PRECISION V1(NDM),G1(NDM),DGDU1(NDM,NDM)

      V1(1)=U1(1) + PAR(4)*PAR(13)
      V1(2)=U1(2) + PAR(4)*PAR(14)

      CALL FFFF(NDM,V1,ICP,PAR,1,G1,DGDU1)

      FB(1)= DGDU1(1,1)*PAR(13) + DGDU1(1,2)*PAR(14)- PAR(12)*PAR(13)
      FB(2)= DGDU1(2,1)*PAR(13) + DGDU1(2,2)*PAR(14)- PAR(12)*PAR(14)
      FB(3)= PAR(13)**2 + PAR(14)**2 -1
      FB(4)= G1(1)
      FB(5)= G1(2)

      END SUBROUTINE BCND

      SUBROUTINE ICND(NDIM,PAR,ICP,NINT,U,UOLD,UDOT,UPOLD,FI,IJAC,DINT)
!     ---------- ----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM, ICP(*), NINT, IJAC
      DOUBLE PRECISION, INTENT(IN) :: PAR(*)
      DOUBLE PRECISION, INTENT(IN) :: U(NDIM), UOLD(NDIM), UDOT(NDIM), UPOLD(NDIM)
      DOUBLE PRECISION, INTENT(OUT) :: FI(NINT)
      DOUBLE PRECISION, INTENT(INOUT) :: DINT(NINT,*)
! Local
      INTEGER, PARAMETER :: NDM=2
      DOUBLE PRECISION F(NDM),F0(NDM),DFDU(NDM,NDM),DUMMY(1)

      CALL FFFF(NDM,U   ,ICP,PAR,1,F ,DFDU)
      CALL FFFF(NDM,UOLD,ICP,PAR,0,F0,DUMMY)

       FI(1)= ( F(1) - F0(1) ) * ( DFDU(1,1)*F(1) + DFDU(1,2)*F(2) ) &
            + ( F(2) - F0(2) ) * ( DFDU(2,1)*F(1) + DFDU(2,2)*F(2) )

      END SUBROUTINE ICND

      SUBROUTINE FOPT
      END SUBROUTINE FOPT

      SUBROUTINE PVLS
      END SUBROUTINE PVLS


program newton_testdriver

use phys_consts, only: wp
use meshobj_dipole, only : qp2rtheta

implicit none (type, external)

real(wp),dimension(1) :: q,p,phi
real(wp) :: r=0,theta=0
real(wp) :: rcorrect=0,thetacorrect=0

! test the conversion of a single point
q(1)=-0.35615504
p(1)=1.2790947
phi(1)=3.14
rcorrect=6803179.761800971_wp
thetacorrect=1.9891332403471418_wp
call qp2rtheta(q(1),p(1),r,theta)
print*, 'solution:  r=',r,'; theta=',theta
print*, 'known good solution:  r=',rcorrect,'; theta=',thetacorrect

if (r-rcorrect>1e4_wp .or. theta-thetacorrect>1e-4_wp) then
  error stop ' Excessive error in coordinate conversion!'
end if

end program newton_testdriver


      MODULE m_diff
C   ******************************************************************  WAB07620
C   *                                                                *  WAB07630
C   *    <SUBROUTINE DIFF> DIFFERENTIATES THE POTENTIAL <V> IN THE   *  WAB07640
C   *    FIRST <N> NET POINTS.                                       *  WAB07650
C   *    <DX> IS THE INCREMENT IN THE LOGARITHMIC NET.               *  WAB07660
C   *    THE RESULT IS STORED IN <VM>.                               *  WAB07670
C   *                                                                *  WAB07680
C   ******************************************************************  WAB07690
      CONTAINS
      SUBROUTINE diff(
     >                mrad,v,dx,n,
     <                vm)

      IMPLICIT NONE

C     .. Scalar Arguments ..
      INTEGER, INTENT (IN) :: mrad,n
      REAL   , INTENT (IN) :: dx
C     ..
C     .. Array Arguments ..
      REAL   , INTENT (IN) ::   v(mrad)
      REAL   , INTENT (OUT)::  vm(mrad)
C     ..
C     .. Local Scalars ..
      INTEGER i,nm2
C     ..
      nm2 = n - 2
      vm(1) = v(1)
      vm(2) = ((6.0*v(3)+6.6666666667*v(5)+1.20*v(7))-
     +        (2.450*v(2)+7.50*v(4)+3.750*v(6)+1.0/6.0*v(8)))/dx

      DO i = 3,nm2
         vm(i) = ((v(i-2)+8.0*v(i+1))- (8.0*v(i-1)+v(i+2)))/12.0/dx
      ENDDO

      vm(n-1) = (v(n)-v(n-2))/2.0/dx
      vm(n) = (v(n-2)/2.0-2.0*v(n-1)+1.50*v(n))/dx

      END SUBROUTINE diff
      END MODULE m_diff


c    # ----------------------------------------------------------------
c    # This file contains routines which accumulate fluxes, waves
c    # and add corrections to coarse grid at edges of both same size
c    # grids and coarse/fine interfaces.
c    #
c    # 1. clawpack46_time_sync_store_flux (before step update)
c    # 2. clawpack46_time_sync_accumulate_waves (after step update)
c    # 3. clawpack46_fort_time_sync_f2c ()
c    # 4. clawpack46_fort_time_sync_copy
c    # ----------------------------------------------------------------

c     # -----------------------------------------------------------------
c     # Called BEFORE step update.  This stores the value of the flux
c     # function at cell centers.  At k=0, the flux at the the first interior
c     # interior cell is stored;  At k=1, the flux evaluated in the
c     # ghost cell is stored;    If there is no flux function, we should
c     # set up a dummy function that returns zero.
c     #
c     # These will be stored for each grid and used to compute
c     # corrections.
c     # -----------------------------------------------------------------
      subroutine clawpack46_time_sync_store_flux(mx,my,mbc,meqn,
     &     maux, blockno, patchno, dt,el0, el1, el2, el3,q, aux,
     &     flux0,flux1,flux2,flux3,
     &     rpn2_cons,qvec,auxvec_center,auxvec_edge, flux)

      implicit none

      integer mx,my,mbc,meqn, maux, blockno, patchno
      double precision dt

      double precision el0(my), el1(my), el2(mx), el3(mx)

      double precision flux0(my,meqn,0:1)
      double precision flux1(my,meqn,0:1)
      double precision flux2(mx,meqn,0:1)
      double precision flux3(mx,meqn,0:1)

      double precision q(1-mbc:mx+mbc,1-mbc:my+mbc,meqn)
      double precision aux(1-mbc:mx+mbc,1-mbc:my+mbc,maux)

      double precision qvec(meqn),flux(meqn)
      double precision auxvec_center(maux), auxvec_edge(maux)

      integer i,j,k,m, idir, iface

      idir = 0
      do j = 1,my
c        # left side k=0 = in; k=1 = out
         do k = 0,1
            iface = k
            do m = 1,maux
c              # Cell centered values;  Each cell-centered value
c              # will be projected onto edge between interior and
c              # exterior cell.
               auxvec_center(m) = aux(1-k,j,m)

c              # Use this array to get edge values between interior
c              # and exterior cells.
               auxvec_edge(m) = aux(1,j,m)
            enddo

c     #     Pass in q at interior cell (k=0) or exterior cell (k=1)
            do m = 1,meqn
               qvec(m) = q(1-k,j,m)
            enddo
            call rpn2_cons(meqn,maux,idir,iface,qvec,
     &           auxvec_center,auxvec_edge,flux)
            do m = 1,meqn
               flux0(j,m,k) = flux0(j,m,k) + dt*el0(j)*flux(m)
            enddo
         enddo

c     #  right side 0 = in; 1 = out
         do k = 0,1
            iface = 1-k    !! face of the cell
            do m = 1,maux
c              # Cell centered values
               auxvec_center(m) = aux(mx+k,j,m)

c              # Edge between ghost cell and interior cell
               auxvec_edge(m) = aux(mx+1,j,m)
            enddo

            do m = 1,meqn
               qvec(m) = q(mx+k,j,m)
            enddo

            call rpn2_cons(meqn,maux,idir,iface,qvec,
     &           auxvec_center,auxvec_edge,flux)
            do m = 1,meqn
               flux1(j,m,k) = flux1(j,m,k) + dt*el1(j)*flux(m)
            enddo
         enddo
      enddo

      idir = 1
      do i = 1,mx
c     # bottom side 0 = in; 1 = out0
         do k = 0,1
            iface = k + 2
            do m = 1,maux
c              # Cell centered values
               auxvec_center(m) = aux(i,1-k,m)

c              # Edge between ghost cell and interior cell
               auxvec_edge(m) = aux(i,1,m)
            enddo
            do m = 1,meqn
               qvec(m) = q(i,1-k,m)
            enddo
            call rpn2_cons(meqn,maux,idir,iface,qvec,
     &           auxvec_center, auxvec_edge,flux)
            do m = 1,meqn
               flux2(i,m,k) = flux2(i,m,k) + dt*el2(i)*flux(m)
            enddo
         enddo

c        # Top side 0 = in; 1 = out
         do k = 0,1
            iface = 3-k
            do m = 1,maux
c              # Cell centered values
               auxvec_center(m) = aux(i,my+k,m)

c              # Edge between ghost cell and interior cell
               auxvec_edge(m) = aux(i,my+1,m)
            enddo
            do m = 1,meqn
               qvec(m) = q(i,my+k,m)
            enddo
            call rpn2_cons(meqn,maux,idir,iface,qvec,
     &           auxvec_center,auxvec_edge, flux)
            do m = 1,meqn
               flux3(i,m,k) = flux3(i,m,k) + dt*el3(i)*flux(m)
            enddo
         enddo
      enddo

      end

c    # -----------------------------------------------------------------
c    # This is called AFTER the step update.   This accumulates plus and
c    # minus waves, scaled by dt*edge_length.  This scaling takes care
c    # of any division by 2 or 4.
c    # -----------------------------------------------------------------
      subroutine clawpack46_time_sync_accumulate_waves(mx,my,
     &                                                 mbc,meqn,
     &      dt, dx,dy, patchno,
     &      el0, el1, el2, el3,
     &      fp,fm,gp,gm,
     &      fp_left,fp_right,
     &      fm_left,fm_right,
     &      gp_bottom,gp_top,
     &      gm_bottom,gm_top)

      implicit none

      integer mx,my,mbc,meqn,patchno
      double precision dt,dx,dy

      double precision fp(1-mbc:mx+mbc,1-mbc:my+mbc,meqn)
      double precision fm(1-mbc:mx+mbc,1-mbc:my+mbc,meqn)
      double precision gp(1-mbc:mx+mbc,1-mbc:my+mbc,meqn)
      double precision gm(1-mbc:mx+mbc,1-mbc:my+mbc,meqn)

      double precision fp_left(my,meqn),fp_right(my,meqn)
      double precision fm_left(my,meqn),fm_right(my,meqn)

      double precision gp_bottom(mx,meqn),gp_top(mx,meqn)
      double precision gm_bottom(mx,meqn),gm_top(mx,meqn)

      double precision el0(my), el1(my), el2(mx), el3(mx)

      integer i,j,m

c     # In flux2, fp = -apdq.  Then the update is
c     # written as -(fm-fp) = (fp-fm) = -(apdq+amdq)
c     # We change the sign back here so that we can write
c     # the update as fp=apdq, fm = amdq.

c     # NOTE : Fluxes have already been scaled by gamma, e.g.
c     # x-face-length/dy or y-face-length/dx. To get scaling
c     # by physical length, we just need to multiply by
c     # dx or dy.

      do j = 1,my
         do m = 1,meqn
            fp_left(j,m)  = fp_left(j,m) - dt*dy*fp(1,j,m)
            fm_left(j,m)  = fm_left(j,m) + dt*dy*fm(1,j,m)

            fp_right(j,m) = fp_right(j,m)-dt*dy*fp(mx+1,j,m)
            fm_right(j,m) = fm_right(j,m)+dt*dy*fm(mx+1,j,m)
         enddo
      enddo

      do i = 1,mx
         do m = 1,meqn
            gp_bottom(i,m) = gp_bottom(i,m) - dt*dx*gp(i,1,m)
            gm_bottom(i,m) = gm_bottom(i,m) + dt*dx*gm(i,1,m)

            gp_top(i,m) = gp_top(i,m) - dt*dx*gp(i,my+1,m)
            gm_top(i,m) = gm_top(i,m) + dt*dx*gm(i,my+1,m)
         enddo
      enddo

      return

      end

c    # -----------------------------------------------------------------
c    # Add fine grid corrections to coarse grid.
c    # -----------------------------------------------------------------

      subroutine clawpack46_fort_time_sync_f2c (mx,my,mbc,meqn,
     &                                          idir, iface_coarse,
     &                                          coarse_blockno,
     &                                          fine_blockno,
     &                                          normal_match,
     &                                          area0, area1,
     &                                          area2, area3,
     &                                          qcoarse,
     &                                          fpthis0,fmthis1,
     &                                          gpthis2,gmthis3,
     &                                          fmfine0, fpfine1,
     &                                          gmfine2, gpfine3,
     &                                          efthis0, efthis1,
     &                                          efthis2, efthis3,
     &                                          eff0, eff1, eff2, eff3,
     &                                          qfine_dummy,
     &                                          transform_cptr)

      implicit none

      integer mx,my,mbc,meqn,idir,iface_coarse
      integer coarse_blockno, fine_blockno, normal_match

      double precision qcoarse(1-mbc:mx+mbc,1-mbc:my+mbc,meqn)

c     # Double number of ghost cells so they map to whole coarse
c     # grid cells
      double precision qfine_dummy(1-2*mbc:mx+2*mbc,
     &                              1-2*mbc:my+2*mbc,meqn)

      double precision area0(my), area1(my), area2(mx), area3(mx)

      double precision fpthis0(my,meqn)
      double precision fmthis1(my,meqn)
      double precision gpthis2(mx,meqn)
      double precision gmthis3(mx,meqn)

      double precision fmfine0(my,meqn)
      double precision fpfine1(my,meqn)
      double precision gmfine2(mx,meqn)
      double precision gpfine3(mx,meqn)

      double precision eff0(my,meqn,0:1)
      double precision eff1(my,meqn,0:1)
      double precision eff2(mx,meqn,0:1)
      double precision eff3(mx,meqn,0:1)

      double precision efthis0(my,meqn,0:1)
      double precision efthis1(my,meqn,0:1)
      double precision efthis2(mx,meqn,0:1)
      double precision efthis3(mx,meqn,0:1)

      integer*8 transform_cptr

      double precision fm,fp,gm,gp,ef

      integer i, j, ic, jc, ii1, ii2, jj1, jj2, ii, jj
      integer i2(0:3), j2(0:3), mq
      double precision deltac, areac

      integer a(2,2), f(2), sc, nm

      logical fc46_skip_this_grid

      call fclaw2d_clawpatch_build_transform(transform_cptr,a,f)

c     # This is here to test the normal_match value; eventually, it
c     # should go away.

      if (idir .eq. 0) then
        sc = (a(1,1) + a(2,1))/2
      else
        sc = (a(1,2) + a(2,2))/2
      endif

c     # Ignore call to normal_match in calling routine
      if (normal_match .eq. 0) then
          nm = -1
      else
          nm = 1
      endif
c      nm = sc
      if (sc .ne. nm) then
          write(6,*) 'time_sync : Normal match does not match'
          write(6,*) 'sc = ', sc
          write(6,*) 'normal_match = ', nm
          write(6,*) a(1,1), a(2,1), a(1,2),a(2,2)
          stop
      endif

c     # We do not know which edge will be used, or how it will be used
c     # so we fill in data at every edge.  Use double the number of
c     # ghost cells so that data aligns with coarse grid ghost cells.
      do mq = 1,meqn
         do j = 1,my/2
            jj1 = 2*(j-1) + 1
            jj2 = 2*(j-1) + 2
            fm = fmfine0(jj1,mq) + fmfine0(jj2,mq)
            ef = eff0(jj1,mq,1) + eff0(jj2,mq,1)
            do jj = jj1,jj2
                do ii = -1,0
                    qfine_dummy(ii,jj,mq)  = fm
                    qfine_dummy(ii-2,jj,mq) = ef
                enddo
            enddo

            fp = fpfine1(jj1,mq) + fpfine1(jj2,mq)
            ef = eff1(jj1,mq,1) + eff1(jj2,mq,1)
            do jj = jj1,jj2
                do ii = 1,2
                    qfine_dummy(mx+ii,jj,mq) = fp
                    qfine_dummy(mx+ii+2,jj,mq) = ef
                enddo
            enddo
         enddo

         do i = 1,mx/2
            ii1 = 2*(i-1) + 1
            ii2 = 2*(i-1) + 2
            gm = gmfine2(ii1,mq) + gmfine2(ii2,mq)
            ef = eff2(ii1,mq,1) + eff2(ii2,mq,1)
            do ii = ii1,ii2
                do jj = -1,0
                    qfine_dummy(ii,jj,mq)  = gm
                    qfine_dummy(ii,jj-2,mq) = ef
                enddo
            enddo
            gp = gpfine3(ii1,mq) + gpfine3(ii2,mq)
            ef = eff3(ii1,mq,1) + eff3(ii2,mq,1)
            do ii = ii1,ii2
                do jj = 1,2
                    qfine_dummy(ii,my+jj,mq) = gp
                    qfine_dummy(ii,my+jj+2,mq) = ef
                enddo
            enddo

         enddo
      enddo

      if (idir .eq. 0) then
c         # sign change ('sc') to account for normals at 0-1
c         # patch faces which may point in a different direction.
c         # First column is A*[1;0]
          sc = (a(1,1) + a(2,1))/2
          deltac = 0
          areac = 1
          do mq = 1,meqn
              do jc = 1,my
                  if (iface_coarse .eq. 0) then
                      ic = 1
                      call fclaw2d_clawpatch_transform_face_half(ic,jc,
     &                     i2,j2,transform_cptr)
                      deltac = 0
                      areac = area0(jc)
                      if (.not. fc46_skip_this_grid(idir,i2,j2,mx,my))
     &                    then
                          fp = qfine_dummy(i2(0),j2(0),mq)
                          call
     &                fclaw2d_clawpatch_transform_face_half(ic+1,jc,
     &                         i2,j2,transform_cptr)
c                         # Check for validity?
                          ef = sc*qfine_dummy(i2(0),j2(0),mq)
                          deltac = (ef-efthis0(jc,mq,0))-
     &                            (fp-fpthis0(jc,mq))
                      endif
                  elseif (iface_coarse .eq. 1) then
                      ic = mx
                      call
     &         fclaw2d_clawpatch_transform_face_half(ic,jc,i2,j2,
     &                      transform_cptr)
                      deltac = 0
                      areac = area1(jc)
                      if (.not. fc46_skip_this_grid(idir,i2,j2,mx,my))
     &                 then
                          fm = qfine_dummy(i2(0),j2(0),mq)

                          call
     &       fclaw2d_clawpatch_transform_face_half(ic-1,jc,
     &                          i2,j2,transform_cptr)
                          ef = sc*qfine_dummy(i2(0),j2(0),mq)

                          deltac = (efthis1(jc,mq,0)-ef)-
     &                             (fm-fmthis1(jc,mq))
                      endif
                  endif
                  qcoarse(ic,jc,mq) = qcoarse(ic,jc,mq) + deltac/areac
              enddo
          enddo
      else
c         # sign change ('sc') to account for normals at 2-3
c         # patch faces which may point in a different direction.
c         # Second column is A*[0;1]
          sc = (a(1,2) + a(2,2))/2
          deltac = 0
          areac = 1
          do mq = 1,meqn
              do ic = 1,mx
                  if (iface_coarse .eq. 2) then
                      jc = 1
                      call
     &     fclaw2d_clawpatch_transform_face_half(ic,jc,i2,j2,
     &                      transform_cptr)
                      deltac = 0
                      areac = area2(ic)
                      if (.not. fc46_skip_this_grid(idir,i2,j2,mx,my))
     &                  then
                          gp = qfine_dummy(i2(0),j2(0),mq)
                          call
     &      fclaw2d_clawpatch_transform_face_half(ic,jc+1,
     &                         i2,j2,transform_cptr)
                          ef = sc*qfine_dummy(i2(0),j2(0),mq)

                          deltac = (ef-efthis2(ic,mq,0))-
     &                        (gp-gpthis2(ic,mq))
                      endif
                  else if (iface_coarse .eq. 3) then
                      jc = my
                      call
     &       fclaw2d_clawpatch_transform_face_half(ic,jc,i2,j2,
     &                      transform_cptr)
                      deltac = 0
                      areac = area3(ic)
                      if (.not. fc46_skip_this_grid(idir,i2,j2,mx,my))
     &                 then
                          gm = qfine_dummy(i2(0),j2(0),mq)
                          call
     &         fclaw2d_clawpatch_transform_face_half(ic,jc-1,
     &                          i2,j2,transform_cptr)
                          ef = sc*qfine_dummy(i2(0),j2(0),mq)

                         deltac = (efthis3(ic,mq,0)-ef)-
     &                            (gm-gmthis3(ic,mq))
                      endif
                  endif
                  qcoarse(ic,jc,mq) = qcoarse(ic,jc,mq) + deltac/areac
                  if (jc .eq. 1) then
c                    write(6,'(2I5, 2E24.16)') ic,jc,deltac,deltac/areac
                  endif
              enddo
          enddo
      endif

      end

c    # -----------------------------------------------------------------
c    # Add wave corrections at same level interfaces.  This accounts for
c    # metric mismatches that can occur at block boundaries.
c    # -----------------------------------------------------------------
      subroutine clawpack46_fort_time_sync_samesize(mx,my,mbc,meqn,
     &                                          idir, this_iface,
     &                                          this_blockno,
     &                                          neighbor_blockno,
     &                                          area0, area1,
     &                                          area2, area3,
     &                                          qthis,
     &                                          fpthis0,fmthis1,
     &                                          gpthis2,gmthis3,
     &                                          fmneighbor0,
     &                                          fpneighbor1,
     &                                          gmneighbor2,
     &                                          gpneighbor3,
     &                                          efthis0,
     &                                          efthis1,
     &                                          efthis2,
     &                                          efthis3,
     &                                          efneighbor0,
     &                                          efneighbor1,
     &                                          efneighbor2,
     &                                          efneighbor3,
     &                                          qthis_dummy,
     &                                          transform_cptr)

      implicit none

      integer mx,my,mbc,meqn,idir
      integer this_iface, this_blockno, neighbor_blockno

      double precision qthis(1-mbc:mx+mbc,1-mbc:my+mbc,meqn)

      double precision qthis_dummy(1-mbc:mx+mbc,1-mbc:my+mbc,meqn)

      double precision area0(my), area1(my), area2(mx), area3(mx)

      double precision fpthis0(my,meqn)
      double precision fmthis1(my,meqn)
      double precision gpthis2(mx,meqn)
      double precision gmthis3(mx,meqn)

      double precision fmneighbor0(my,meqn)
      double precision fpneighbor1(my,meqn)
      double precision gmneighbor2(mx,meqn)
      double precision gpneighbor3(mx,meqn)

c     # These store flux evaluations f(q) at the first layer of ghost
c     # cells and the first interior row/column.  Interior values are
c     # stored at the '0' index; ghost layer stored at the '1' index.
      double precision efthis0(my,meqn,0:1)
      double precision efthis1(my,meqn,0:1)
      double precision efthis2(mx,meqn,0:1)
      double precision efthis3(mx,meqn,0:1)

      double precision efneighbor0(my,meqn,0:1)
      double precision efneighbor1(my,meqn,0:1)
      double precision efneighbor2(mx,meqn,0:1)
      double precision efneighbor3(mx,meqn,0:1)

      double precision delta, area

      integer a(2,2), f(2), sc

      double precision fp,fm,gp,gm,ef

      integer*8 transform_cptr

      integer i,j,mq
      integer i1,j1, i2, j2

      call fc46_build_transform_samesize(transform_cptr,a,f)

      idir = this_iface/2

      do mq = 1,meqn
         do j = 1,my
             qthis_dummy(0,j,mq)  = fmneighbor0(j,mq)
             qthis_dummy(-1,j,mq) = efneighbor0(j,mq,1)

             qthis_dummy(mx+1,j,mq) = fpneighbor1(j,mq)
             qthis_dummy(mx+2,j,mq) = efneighbor1(j,mq,1)
         enddo

         do i = 1,mx
             qthis_dummy(i,0,mq)  = gmneighbor2(i,mq)
             qthis_dummy(i,-1,mq) = efneighbor2(i,mq,1)

             qthis_dummy(i,my+1,mq) = gpneighbor3(i,mq)
             qthis_dummy(i,my+2,mq) = efneighbor3(i,mq,1)
         enddo
      enddo

      if (idir .eq. 0) then
c         # Get sign change to account for possible mismatch in normals
          sc = a(1,1) + a(2,1)
          do mq = 1,meqn
              do j = 1,my
                  j1 = j
                  if (this_iface .eq. 0) then
c                     # Exchange at low side of 'this' grid in
c                     # x-direction (idir == 0)
                      i1 = 1
                      call
     &       fclaw2d_clawpatch_transform_face(i1,j1,i2,j2,
     &                      transform_cptr)
                      fp = qthis_dummy(i2,j2,mq)
                      call
     &       fclaw2d_clawpatch_transform_face(i1+1,j1,i2,j2,
     &                      transform_cptr)
                      ef = sc*qthis_dummy(i2,j2,mq)

                      delta = (ef-efthis0(j1,mq,0))-(fp-fpthis0(j1,mq))
                      area = area0(j1)

                  else
                      i1 = mx
                      call
     &       fclaw2d_clawpatch_transform_face(i1,j1,i2,j2,
     &                      transform_cptr)
                      fm = qthis_dummy(i2,j2,mq)
                      call
     &       fclaw2d_clawpatch_transform_face(i1-1,j1,i2,j2,
     &                      transform_cptr)
                      ef = sc*qthis_dummy(i2,j2,mq)

                      delta = (efthis1(j1,mq,0)-ef)-(fm-fmthis1(j1,mq))
                      area = area1(j1)

                  endif
                  qthis(i1,j1,mq) = qthis(i1,j1,mq) + 0.5*delta/area
              enddo
          enddo
      else
c         # Get sign change ('sc') to account for possible
c         # mismatch in direction of normal vectors
          sc = a(1,2) + a(2,2)
          do mq = 1,meqn
              do i = 1,mx
c                 # Exchange at high side of 'this' grid in
c                 # y-direction (idir == 1)
                  i1 = i
                  if (this_iface .eq. 2) then
                      j1 = 1
                      call fclaw2d_clawpatch_transform_face(i1,j1,
     &                 i2,j2,transform_cptr)
                      gp = qthis_dummy(i2,j2,mq)
                      call fclaw2d_clawpatch_transform_face(i1,j1+1,
     &                      i2,j2,transform_cptr)
                      ef = sc*qthis_dummy(i2,j2,mq)

                      delta = (ef-efthis2(i1,mq,0))-(gp-gpthis2(i1,mq))
                      area = area2(i1)

                  else
c                     # Coarse grid is bottom grid; fine is top grid
c                     # efc3(0) is flux stored in the coarse grid
c                     # interior cell.
                      j1 = my
                      call fclaw2d_clawpatch_transform_face(i1,j1,
     &                        i2,j2,transform_cptr)
c                      write(6,*) this_iface, i1, j1, i2, j2
                      gm = qthis_dummy(i2,j2,mq)
                      call fclaw2d_clawpatch_transform_face(i1,j1-1,
     &                         i2,j2,transform_cptr)
                      ef = sc*qthis_dummy(i2,j2,mq)

                     delta = (efthis3(i1,mq,0)-ef)-(gm-gmthis3(i1,mq))
                     area = area3(i1)

                  endif
                  qthis(i1,j1,mq) = qthis(i1,j1,mq) + 0.5*delta/area
              enddo
          enddo
      endif
      end

      logical function fc46_skip_this_grid(idir,i2,j2,mx,my)
      implicit none

      integer idir, i2(0:3), j2(0:3), mx,my
      integer m
      logical fc46_is_valid_correct

      fc46_skip_this_grid = .false.
      do m = 0,3
          if (.not. fc46_is_valid_correct(idir,i2(m),j2(m),mx,my)) then
              fc46_skip_this_grid = .true.
              exit
          endif
      enddo

      end

      logical function fc46_is_valid_correct(idir,i,j,mx,my)
      implicit none

      integer i,j,mx,my, idir
      logical i1, j1

      i1 = 1 .le. i .and. i .le. mx
      j1 = 1 .le. j .and. j .le. my

c     # At least one of the above should be true.
      fc46_is_valid_correct = xor(i1,j1)

      end

      subroutine fc46_build_transform_samesize(transform_ptr,a,f)
      implicit none

      integer a(2,2)
      integer*8 transform_ptr
      integer f(2)
      integer icn, jcn
      integer i1,j1

c     # Assume index mapping fclaw2d_transform_face has the
c     # the form
c     #
c     #       T(ic,jc) = A*(ic,jc) + F = (icn,jcn)
c     #
c     # where (ic,jc) is the coarse grid index, and (icn,jcn)
c     # is the neighbor grid index.
c     #
c     # We can recover coefficients A(2,2) with the following
c     # calls to T.

      i1 = 0
      j1 = 0
      call fclaw2d_clawpatch_transform_face(i1,j1,icn,jcn,
     &      transform_ptr)
      f(1) = icn
      f(2) = jcn

      i1 = 1
      j1 = 0
      call fclaw2d_clawpatch_transform_face(i1,j1,icn,jcn,
     &      transform_ptr)
      a(1,1) = icn - f(1)
      a(2,1) = jcn - f(2)

      i1 = 0
      j1 = 1
      call fclaw2d_clawpatch_transform_face(i1,j1,icn,jcn,
     &      transform_ptr)
      a(1,2) = icn - f(1)
      a(2,2) = jcn - f(2)

      end


      FUNCTION DLARAN(ISEED)
      IMPLICIT NONE
!  DLARAN returns a random real number from a uniform (0,1)
!  distribution.

      INTEGER   ::         ISEED( 4 )
      REAL      ::      DLARAN

!      INTEGER     ::       M1, M2, M3, M4
      integer, PARAMETER   ::  M1 = 494, M2 = 322, M3 = 2508, M4 = 2549

 !!     real       ::   ONE = 1.0D+0
REAL :: ONE
INTEGER, parameter         ::   IPW2 = 4096
      real ::   R
!      PARAMETER        ::  ( IPW2 = 4096, R = ONE / IPW2 )

      INTEGER          ::  IT1, IT2, IT3, IT4
      real ::  DLAR

!!    INTRINSIC        ::  DBLE, MOD

    ONE = 1.0d0
    R=ONE / IPW2

      IT4 = ISEED( 4 )*M4
      IT3 = IT4 / IPW2
      IT4 = IT4 - IPW2*IT3
      IT3 = IT3 + ISEED( 3 )*M4 + ISEED( 4 )*M3
      IT2 = IT3 / IPW2
      IT3 = IT3 - IPW2*IT2
      IT2 = IT2 + ISEED( 2 )*M4 + ISEED( 3 )*M3 + ISEED( 4 )*M2
      IT1 = IT2 / IPW2
      IT2 = IT2 - IPW2*IT1
      IT1 = IT1 + ISEED( 1 )*M4 + ISEED( 2 )*M3 + ISEED( 3 )*M2 +&
           ISEED( 4 )*M1
      IT1 = MOD( IT1, IPW2 )
!
!     return updated seed
!
      ISEED( 1 ) = IT1
      ISEED( 2 ) = IT2
      ISEED( 3 ) = IT3
      ISEED( 4 ) = IT4
!
!     convert 48-bit integer to a real number in the interval (0,1)
!
      DLAR = R*( DBLE( IT1 )+R*( DBLE( IT2 )+R*( DBLE( IT3 )+R*&
              ( DBLE( IT4 ) ) ) ) )

   !!   DLARAN=REAL(DLAR,KIND=8)
       dlaran=dlar
      RETURN
!
!     End of DLARAN
!
      END


  ! Copyright 2020 University of Warwick

  ! Licensed under the Apache License, Version 2.0 (the "License");
  ! you may not use this file except in compliance with the License.
  ! You may obtain a copy of the License at

  !    http://www.apache.org/licenses/LICENSE-2.0

  ! Unless required by applicable law or agreed to in writing, software
  ! distributed under the License is distributed on an "AS IS" BASIS,
  ! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
  ! See the License for the specific language governing permissions and
  ! limitations under the License.

MODULE radiative

  USE shared_data
  USE boundary

  IMPLICIT NONE

  PRIVATE

  PUBLIC :: rad_losses, user_defined_heating

  INTEGER, PARAMETER :: n = 7   !set the number of temperature boundaries used in Q(T)
  INTEGER, PARAMETER  :: kmax = n - 1
  REAL(num), DIMENSION(:), ALLOCATABLE :: t_boundary, pow, psi
  INTEGER, DIMENSION(:), ALLOCATABLE :: alpha
  REAL(num), DIMENSION(:), ALLOCATABLE :: yk, qk, ratios
  REAL(num) :: cool, ratio

CONTAINS

  SUBROUTINE setup_loss_function
    ! In this subroutine specify the radiative loss Q(T) = psi_k * T^alpha_k
    ! This must be piecewise polynomial with kmax=n-1 regions
    ! bounded by n temperatures.
    ! Q(T) must be in S.I.
    ! In the energy equation this would appear as a pressure cooling through
    ! dp/dt = -(gamma-1) n_e n_H Q(T)
    ! Only in this form for T~>10^4 so fully ionised and n_H=n_e

    REAL(num) :: frac

    t_boundary(:) = (/0.02_num, 0.0398_num, 0.0794_num, 0.251_num, 0.562_num, 1.995_num, 10.0_num/) * 1e6_num

    !Define power for polynomial fit.
    !Alpha is defined as integer but RTV has one none
    !integer power so have integer alpha array and real pow array defined below.
    !The interger array is needed as alpha=1 is a special case.
    frac = -2.0_num / 3.0_num
    alpha(:) = (/0, 2, 0, -2, 0, 0/)
    pow(:) = REAL(alpha, num) + (/0.0_num, 0.0_num, 0.0_num, 0.0_num, 0.0_num, frac/)

    !Usually specify RTV in cgs
    psi(:) = (/-21.85_num, -31.0_num, -21.2_num, -10.4_num, -21.94_num, -17.73_num/)
    psi = 10**psi
    !Convert to SI
    psi = 1.e-13_num * psi

  END SUBROUTINE setup_loss_function

  SUBROUTINE user_defined_heating
    ! Use this to define any heating needed on each timestep
    ! This is a dumb example so change to the heating needed
    ! This example specifies the heating rate (heat_in) in S.I. then
    ! converts to Lare units

    REAL(num), DIMENSION(:,:), ALLOCATABLE :: heat_in

    ALLOCATE (heat_in(-1:nx+2, -1:ny+2))

    ! Specify heating in S.I. units W/m^3
    DO iy = 1, ny
      DO ix = 1, nx
        heat_in(ix,iy) = 0.1_num * EXP(-xc(ix)**2 -yc(iy)**2)
      END DO
    END DO
    ! Convert to internal Lare units
    heat_in = heat_in * time_norm**3 / (rho_norm * L_norm)

    energy(:,:) = energy(:,:) + heat_in * dt / rho(:,:)
    CALL energy_bcs

  END SUBROUTINE user_defined_heating

  SUBROUTINE rad_losses

    LOGICAL :: first_call = .TRUE.

    IF (first_call) THEN
      first_call = .FALSE.
      ALLOCATE (t_boundary(1:n), alpha(1:kmax), pow(1:kmax), psi(1:kmax))
      ALLOCATE (yk(1:n), qk(1:n), ratios(1:n))
      CALL setup_loss_function
      CALL set_exact_integration_arrays
    END IF

    CALL exact_intergation_method
    CALL energy_bcs

  END SUBROUTINE rad_losses

  SUBROUTINE exact_intergation_method

    REAL(num) :: temp_si, inverse_t_cool, yt, fac
    INTEGER :: i, k

    DO ix = 1, nx
      DO iy = 1, ny

        temp_si = 0.5_num * temp_norm * energy(ix,iy) * (gamma - 1.0_num)

        k = -1
        DO i = 1, kmax
          IF (temp_si > t_boundary(i) .AND. temp_si <= t_boundary(i+1)) THEN
            k = i
            EXIT
          END IF
        END DO
        IF (k .LT. 0) CYCLE

        IF (alpha(k) .NE. 1) THEN
          fac = 1.0_num / (1.0 - pow(k))
          yt = yk(k) + fac * ratios(k) * (1.0_num - (t_boundary(k)/temp_si)**(pow(k)-1.0_num))
        ELSE
          yt = yk(k) + ratios(k) * LOG((t_boundary(k)/temp_si))
        END IF

        inverse_t_cool = cool * rho(ix,iy)
        yt = yt +  dt * inverse_t_cool *  time_norm

        k = -1
        DO i = 1, kmax
          IF ((yt > yk(i) .AND. yt <= yk(i+1)) .OR. (yt < yk(i) .AND. yt >= yk(i+1))) THEN
            k = i
            EXIT
          END IF
        END DO
        IF (k .LT. 0) THEN
          temp_si = t_boundary(1)
          energy(ix,iy) = temp_si * 2.0_num / (gamma - 1.0_num) / temp_norm
          CYCLE
        ENDIF

        IF (alpha(k) .NE. 1) THEN
          fac = 1.0_num / (1.0 - pow(k))
          temp_si = t_boundary(k) * (1.0_num - (1.0_num - pow(k)) / ratios(k) * (yt - yk(k)))**fac
        ELSE
          temp_si = t_boundary(k) * EXP((yt - yk(k)) / ratios(k))
        END IF

        energy(ix,iy) = temp_si * 2.0_num / (gamma - 1.0_num) / temp_norm

      END DO
    END DO

  END SUBROUTINE exact_intergation_method

  SUBROUTINE set_exact_integration_arrays
    ! Define arrays used in Townsend exact integration method
    ! Here qk = Lambda_k from Townsend

    REAL(num) :: fac
    INTEGER :: k

    DO k = 1, kmax
      qk(k) = psi(k) * t_boundary(k)**pow(k)
    END DO
    qk(n) = qk(n-1) * (t_boundary(n)/t_boundary(n-1))**pow(n-1)

    ratio = qk(n) / t_boundary(n)
    cool = 0.5_num * ratio * (gamma - 1.0_num) * rho_norm / (kb_si * mf * mh_si)
    DO k = 1, n
      ratios(k) = ratio * (t_boundary(k) / qk(k))
    END DO

    yk(n) = 0.0_num
    DO k = kmax, 1, -1
      IF (alpha(k) .NE. 1) THEN
        fac = 1.0_num / (1.0 - pow(k))
        yk(k) = yk(k+1) - fac * ratios(k) * (1.0_num - (t_boundary(k)/t_boundary(k+1))**(pow(k)-1.0_num))
      ELSE
        yk(k) = yk(k+1) - ratios(k) * LOG((t_boundary(k)/t_boundary(k+1)))
      END IF
    END DO

  END SUBROUTINE set_exact_integration_arrays

END MODULE radiative


! 2017, S.A. Sato, Modified the format of the code
!
! ----------------------------------------------------------------------------
! Numerical diagonalization of 3x3 matrcies
! Copyright (C) 2006  Joachim Kopp
! ----------------------------------------------------------------------------
! This library is free software; you can redistribute it and/or
! modify it under the terms of the GNU Lesser General Public
! License as published by the Free Software Foundation; either
! version 2.1 of the License, or (at your option) any later version.
!
! This library is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
! Lesser General Public License for more details.
!
! You should have received a copy of the GNU Lesser General Public
! License along with this library; if not, write to the Free Software
! Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
! ----------------------------------------------------------------------------
!
!
! ----------------------------------------------------------------------------
     SUBROUTINE ZHETRD3(A, Q, D, E)
! ----------------------------------------------------------------------------
! Reduces a hermitian 3x3 matrix to real tridiagonal form by applying
! (unitary) Householder transformations:
!            [ D[1]  E[1]       ]
!    A = Q . [ E[1]  D[2]  E[2] ] . Q^T
!            [       E[2]  D[3] ]
! The function accesses only the diagonal and upper triangular parts of
! A. The access is read-only.
! ---------------------------------------------------------------------------
! Dependencies:
!   SQRABS()
! ---------------------------------------------------------------------------
!     .. Arguments ..
      COMPLEX(8)       A(3,3)
      COMPLEX(8)       Q(3,3)
      DOUBLE PRECISION D(3)
      DOUBLE PRECISION E(2)

!     .. Parameters ..
      INTEGER          N
      PARAMETER        ( N = 3 )

!     .. Local Variables ..
      COMPLEX*16       U(N), P(N)
      COMPLEX*16       OMEGA, F
      DOUBLE PRECISION K, H, G
      INTEGER          I, J

!     .. External Functions ..
      DOUBLE PRECISION SQRABS
      EXTERNAL         SQRABS

!     Initialize Q to the identitity matrix
!     --- This loop can be omitted if only the eigenvalues are desired ---
      DO 10 I = 1, N
        Q(I,I) = 1.0D0
        DO 11, J = 1, I-1
          Q(I, J) = 0.0D0
          Q(J, I) = 0.0D0
   11   CONTINUE
   10 CONTINUE

!     Bring first row and column to the desired form
      H = SQRABS(A(1,2)) + SQRABS(A(1,3))
      IF (DREAL(A(1,2)) .GT. 0.0D0) THEN
        G = -SQRT(H)
      ELSE
        G = SQRT(H)
      END IF
      E(1)  = G
      F     = G * A(1,2)
      U(2)  = DCONJG(A(1,2)) - G
      U(3)  = DCONJG(A(1,3))

      OMEGA = H - F
      IF (DREAL(OMEGA) .GT. 0.0D0) THEN
        OMEGA = 0.5D0 * (1.0D0 + DCONJG(OMEGA)/OMEGA) / DREAL(OMEGA)
        K     = 0.0D0
        DO 20 I = 2, N
          F    = DCONJG(A(2,I))*U(2) + A(I,3)*U(3)
          P(I) = OMEGA * F
          K    = K + DREAL(DCONJG(U(I)) * F)
  20    CONTINUE
        K = 0.5D0 * K * SQRABS(OMEGA)

        DO 30 I = 2, N
          P(I) = P(I) - K * U(I)
  30    CONTINUE

        D(1) = DREAL(A(1,1))
        D(2) = DREAL(A(2,2)) - 2.0D0 * DREAL(P(2) * DCONJG(U(2)))
        D(3) = DREAL(A(3,3)) - 2.0D0 * DREAL(P(3) * DCONJG(U(3)))

!       Store inverse Householder transformation in Q
!       --- This loop can be omitted if only the eigenvalues are desired ---
        DO 40, J = 2, N
          F = OMEGA * DCONJG(U(J))
          DO 41 I = 2, N
            Q(I,J) = Q(I,J) - F * U(I)
   41     CONTINUE
   40   CONTINUE

!       Calculated updated A(2, 3) and store it in F
        F = A(2, 3) - P(2) * DCONJG(U(3)) - U(2) * DCONJG(P(3))
      ELSE
        DO 50 I = 1, N
          D(I) = DREAL(A(I, I))
  50    CONTINUE
        F = A(2, 3)
      END IF

!     Make (23) element real
      E(2) = ABS(F)
!     --- This IF-statement can be omitted if only the eigenvalues are desired ---
      IF (E(2) .NE. 0.0D0) THEN
        F = DCONJG(F) / E(2)
        DO 60 I = 2, N
          Q(I, 3) = Q(I, 3) * F
  60    CONTINUE
      END IF

      END SUBROUTINE
! End of subroutine ZHETRD3


program map_core

  use write_in_file, only: write_iteration
  use nrtype

  implicit none
  double precision, dimension(:, :), allocatable :: map
  double precision, dimension(:, :), allocatable :: polynom
  integer :: err_map, err_polynom
  integer :: i, j
  integer :: pix_num = 8
  integer :: legendre_num = 4
  double precision :: theta
  integer :: j_map
  double precision :: my_PI = 4.d0 * datan(1.d0)
  integer :: m, l
  real :: ran_num

  ! Allocation
  allocate(map(1:pix_num, 1:pix_num/2), stat=err_map)
  if (err_map /= 0) print *, "map: Allocation request denied"

  allocate(polynom(0:legendre_num, 0:legendre_num), stat=err_polynom)
  if (err_polynom /= 0) print *, "polynom: Allocation request denied"
  ! -

  ! Initialization
  do i = 1, pix_num, 1
    do j = 1, pix_num/2, 1
      map(i, j) = 0.d0
    end do
  end do

  do i = 0, legendre_num, 1
    do j = 0, legendre_num, 1
      polynom(i, j) = 0.d0
    end do
  end do
  ! -

  j_map = 2
  theta = 2.d0 * my_PI * (j_map - 1) / pix_num

  polynom(0, 0) = 1.d0 / sqrt(4.d0 * my_PI)

  do m = 0, legendre_num - 1, 1
    polynom(m + 1, m + 1) = -polynom(m, m)*dsin(theta)*sqrt(2.d0*m+3.d0)/sqrt(2.d0*m+2.d0)
  end do
  do m = 0, legendre_num - 1, 1
    polynom(m, m + 1) = polynom(m, m)*dcos(theta)*sqrt(2.d0*m+3.d0)
  end do
  do m = 0, legendre_num - 2, 1
    do l = m + 2, legendre_num, 1
      polynom(m, l) = ((2.d0*l-1.d0)*dsqrt((l-m)*(2.d0*l+1.d0)) &
      /sqrt((l+m)*(2.d0*l-1.d0))*polynom(m, l-1)*dcos(theta)-(l+m-1.d0) &
      *sqrt((l-m)*(l-1.d0-m)*(2.d0*l+1.d0)) /sqrt((l+m)*(l-1.d0+m) &
      *(2.d0*l-3.d0))*polynom(m, l-2))/(l-m)
    end do
  end do
  do m = 1, legendre_num, 1
    do l = m, legendre_num, 1
      polynom(m, l) = polynom(m, l) * sqrt(2.d0)
    end do
  end do

  ! write(*, *) polynom(:, 2)

  ! Deallocation
  if (allocated(polynom)) deallocate(polynom, stat=err_polynom)
  if (err_polynom /= 0) print *, "polynom: Deallocation request denied"

  if (allocated(map)) deallocate(map, stat=err_map)
  if (err_map /= 0) print *, "map: Deallocation request denied"
  ! -

  do i = 1, 10, 1
    call ran1_s(ran_num)
    write(*, *) ran_num
  end do

end program map_core


      REAL FUNCTION CLA_GBRPVGRW( N, KL, KU, NCOLS, AB, LDAB, AFB,
     $                            LDAFB )
*
*     -- LAPACK routine (version 3.2)                                 --
*     -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and --
*     -- Jason Riedy of Univ. of California Berkeley.                 --
*     -- November 2008                                                --
*
*     -- LAPACK is a software package provided by Univ. of Tennessee, --
*     -- Univ. of California Berkeley and NAG Ltd.                    --
*
      IMPLICIT NONE
*     ..
*     .. Scalar Arguments ..
      INTEGER            N, KL, KU, NCOLS, LDAB, LDAFB
*     ..
*     .. Array Arguments ..
      COMPLEX            AB( LDAB, * ), AFB( LDAFB, * )
*     ..
*     .. Local Scalars ..
      INTEGER            I, J, KD
      REAL               AMAX, UMAX, RPVGRW
      COMPLEX            ZDUM
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN, REAL, AIMAG
*     ..
*     .. Statement Functions ..
      REAL               CABS1
*     ..
*     .. Statement Function Definitions ..
      CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )
*     ..
*     .. Executable Statements ..
*
      RPVGRW = 1.0
*
      KD = KU + 1
      DO J = 1, NCOLS
         AMAX = 0.0
         UMAX = 0.0
         DO I = MAX( J-KU, 1 ), MIN( J+KL, N )
            AMAX = MAX( CABS1( AB( KD+I-J, J ) ), AMAX )
         END DO
         DO I = MAX( J-KU, 1 ), J
            UMAX = MAX( CABS1( AFB( KD+I-J, J ) ), UMAX )
         END DO
         IF ( UMAX /= 0.0 ) THEN
            RPVGRW = MIN( AMAX / UMAX, RPVGRW )
         END IF
      END DO
      CLA_GBRPVGRW = RPVGRW
      END FUNCTION