subroutine setprob()
    implicit none

    double precision :: pi, pi2
    common /compi/ pi, pi2

    pi = 4.d0*datan(1.d0)
    pi2 = 2.d0*pi

end subroutine setprob


!*******************************************************************
!                                                                  *
      INTEGER FUNCTION ITTK (I, J, K)
!                                                                  *
!     CHESKED TRIANGULAR CONDITIONS FOR   I/2, J/2, K/2.           *
!     I+J>=K, I+K>=J, J+K>=I,                                      *
!     I/2+J/2+K/2 - WHOLE NUMBER                                   *
!     ITTK=1 -   IF NOT SATISFY                                    *
!     ITTK=0 -   IN OVER CASES                                     *
!                                                                  *
!   Written by G. Gaigalas,                                        *
!   Vilnius,  Lithuania                             December 1993  *
!   Transform to fortran 90/95 by G. Gaigalas       December 2012  *
!   The last modification made by G. Gaigalas       October  2017  *
!                                                                  *
!*******************************************************************
!
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER, INTENT(IN) :: I, J, K
!-----------------------------------------------
      ITTK = 0
      IF (IABS(I - J) > K) RETURN
      IF (I + J < K) RETURN
      IF (MOD(I + J + K,2) /= 0) RETURN
      ITTK = 1
      RETURN
      END FUNCTION ITTK


      DOUBLE PRECISION FUNCTION dln1mx(x)
C**********************************************************************
C
C     DOUBLE PRECISION FUNCTION DLN1MX(X)
C               Double precision LN(1-X)
C
C
C                              Function
C
C
C     Returns ln(1-x) for small x (good accuracy if x .le. 0.1).
C     Note that the obvious code of
C               LOG(1.0-X)
C     won't work for small X because 1.0-X loses accuracy
C
C
C                              Arguments
C
C
C     X --> Value for which ln(1-x) is desired.
C                                        X is DOUBLE PRECISION
C
C
C                              Method
C
C
C     If X > 0.1, the obvious code above is used ELSE
C     The Taylor series for 1-x is expanded to 20 terms.
C
C**********************************************************************
C     .. Scalar Arguments ..
      DOUBLE PRECISION x
C     ..
C     .. External Functions ..
      DOUBLE PRECISION dln1px
      EXTERNAL dln1px
C     ..
C     .. Executable Statements ..

      dln1mx = dln1px(-x)
      RETURN

      END


MODULE mdl_precision

! ---------------------------------------------------------------------------
! Purpose:
!  Module for setting the 'Precision Parameters' as global variables
! ---------------------------------------------------------------------------
! Dr. Thomas D. Papanikolaou                                        July 2015
! ---------------------------------------------------------------------------

      IMPLICIT NONE
      SAVE 			! Attention

! ---------------------------------------------------------------------------
! Real numbers precision
! ---------------------------------------------------------------------------
! 1.
      INTEGER, PARAMETER :: prec_s = selected_real_kind(6,37)
      INTEGER, PARAMETER :: prec_d = selected_real_kind(15,307)
      INTEGER, PARAMETER :: prec_q = selected_real_kind(15,307)
!      INTEGER, PARAMETER :: prec_q = selected_real_kind(33,4931)
!      INTEGER, PARAMETER :: prec_quadruple = selected_real_kind(33,4931)
! ---------------------------------------------------------------------------
! 2.
!  REAL (KIND=4) :: X ! SP
!  REAL (KIND=8) :: X ! DP
!  REAL (KIND=16) :: X ! QP
! ---------------------------------------------------------------------------
! 3.
!  integer, parameter :: SINGLE = REAL64
!  integer, parameter :: DOUBLE = REAL128
! ---------------------------------------------------------------------------
! 4. Attention: Old approach, to be avoided
!       REAL*4 :: pi
!       REAL*8 :: pi
!       REAL*16 :: pi
! ---------------------------------------------------------------------------

! ---------------------------------------------------------------------------
! Integer numbers precision
! ---------------------------------------------------------------------------
      INTEGER, PARAMETER :: prec_int1 = selected_int_kind(2)
      INTEGER, PARAMETER :: prec_int2 = selected_int_kind(4)
      INTEGER, PARAMETER :: prec_int4 = selected_int_kind(8)
      INTEGER, PARAMETER :: prec_int8 = selected_int_kind(18)

!   integer, parameter :: INT8    = selected_int_kind(2)
!   integer, parameter :: INT16   = selected_int_kind(4)
!   integer, parameter :: INT32   = selected_int_kind(18)
!   !  integer, parameter :: INT64   = selected_int_kind(18)
! ---------------------------------------------------------------------------

END


!!# MODULE <<FUN_NormEll1>>
MODULE FUN_NormEll1

!!## PURPOSE
!! Defines the $\ell^1$ norm of <A>, with optional weight <W>.

!!## DETAILS
!! The $\ell^1$ norm is a discrete norm of the form
!!
!! $$ \ell^1(A) = \sum_i | A_i | W_i  $$
!!
!! Where for example $A_i$ could be average values
!! $A_i = \frac{1}{\Delta x_i} \int_{a_i}^{b_i} A(x) dx$
!! and the weights $W_i = \Delta x_i$ returned from a finite
!! volume solution of a PDE.

!!## USAGE
!
!       s = NormEll1( A [,W] )
!

!!## REFERENCES
!
![1] Weisstein, Eric W. "L1-Norm." From MathWorld--A Wolfram Web Resource.
!    http://mathworld.wolfram.com/L1-Norm.html

!!## OWNER
![1] Wieselquist, William W. (william.wieselquist AT gmail.com)
!    July 8, 2006 - present

!!## EXTERNAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_Rsp,KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))

!!## DEFAULT IMPLICIT
IMPLICIT NONE

!!## DEFAULT ACCESS
PRIVATE

!!## NormEll1 PROCEDURE OVERLOADING
INTERFACE NormEll1
 MODULE PROCEDURE NormEll1_A1_Rsp
 MODULE PROCEDURE NormEll1_A2_Rsp
 MODULE PROCEDURE NormEll1_A3_Rsp
 MODULE PROCEDURE NormEll1_A4_Rsp
 MODULE PROCEDURE NormEll1_A5_Rsp
 MODULE PROCEDURE NormEll1_A6_Rsp
 MODULE PROCEDURE NormEll1_A7_Rsp

 MODULE PROCEDURE NormEll1_A1_Rdp
 MODULE PROCEDURE NormEll1_A2_Rdp
 MODULE PROCEDURE NormEll1_A3_Rdp
 MODULE PROCEDURE NormEll1_A4_Rdp
 MODULE PROCEDURE NormEll1_A5_Rdp
 MODULE PROCEDURE NormEll1_A6_Rdp
 MODULE PROCEDURE NormEll1_A7_Rdp
END INTERFACE
INTERFACE NormEll1
 MODULE PROCEDURE NormEll1_A1W1_Rsp
 MODULE PROCEDURE NormEll1_A2W2_Rsp
 MODULE PROCEDURE NormEll1_A3W3_Rsp
 MODULE PROCEDURE NormEll1_A4W4_Rsp
 MODULE PROCEDURE NormEll1_A5W5_Rsp
 MODULE PROCEDURE NormEll1_A6W6_Rsp
 MODULE PROCEDURE NormEll1_A7W7_Rsp

 MODULE PROCEDURE NormEll1_A1W1_Rdp
 MODULE PROCEDURE NormEll1_A2W2_Rdp
 MODULE PROCEDURE NormEll1_A3W3_Rdp
 MODULE PROCEDURE NormEll1_A4W4_Rdp
 MODULE PROCEDURE NormEll1_A5W5_Rdp
 MODULE PROCEDURE NormEll1_A6W6_Rdp
 MODULE PROCEDURE NormEll1_A7W7_Rdp
END INTERFACE

!!## PUBLIC ACCESS LIST
PUBLIC :: NormEll1

!## MODULE PROCEDURES
CONTAINS

!!### L-2 Norm for single precision
PURE FUNCTION NormEll1_A1_Rsp(A) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:)
REAL(KIND_R) :: s
!!--begin--
s = SUM( ABS( A ) )
!!--end--
END FUNCTION

PURE FUNCTION NormEll1_A2_Rsp(A) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:)
REAL(KIND_R) :: s
!!--begin--
s = SUM( ABS( A ) )
!!--end--
END FUNCTION

PURE FUNCTION NormEll1_A3_Rsp(A) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = SUM( ABS( A ) )
!!--end--
END FUNCTION

PURE FUNCTION NormEll1_A4_Rsp(A) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = SUM( ABS( A ) )
!!--end--
END FUNCTION

PURE FUNCTION NormEll1_A5_Rsp(A) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = SUM( ABS( A ) )
!!--end--
END FUNCTION

PURE FUNCTION NormEll1_A6_Rsp(A) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:,:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = SUM( ABS( A ) )
!!--end--
END FUNCTION

PURE FUNCTION NormEll1_A7_Rsp(A) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:,:,:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = SUM( ABS( A ) )
!!--end--
END FUNCTION

!!### L-2 Norm for double precision
PURE FUNCTION NormEll1_A1_Rdp(A) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:)
REAL(KIND_R) :: s
!!--begin--
s = SUM( ABS( A ) )
!!--end--
END FUNCTION

PURE FUNCTION NormEll1_A2_Rdp(A) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:)
REAL(KIND_R) :: s
!!--begin--
s = SUM( ABS( A ) )
!!--end--
END FUNCTION

PURE FUNCTION NormEll1_A3_Rdp(A) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = SUM( ABS( A ) )
!!--end--
END FUNCTION

PURE FUNCTION NormEll1_A4_Rdp(A) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = SUM( ABS( A ) )
!!--end--
END FUNCTION

PURE FUNCTION NormEll1_A5_Rdp(A) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = SUM( ABS( A ) )
!!--end--
END FUNCTION

PURE FUNCTION NormEll1_A6_Rdp(A) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:,:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = SUM( ABS( A ) )
!!--end--
END FUNCTION

PURE FUNCTION NormEll1_A7_Rdp(A) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:,:,:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = SUM( ABS( A ) )
!!--end--
END FUNCTION

!!### L-2 Norm for single precision
PURE FUNCTION NormEll1_A1W1_Rsp(A,W) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:),W(:)
REAL(KIND_R) :: s
!!--begin--
s = SUM( ABS( A*W ) )
!!--end--
END FUNCTION

PURE FUNCTION NormEll1_A2W2_Rsp(A,W) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:),W(:,:)
REAL(KIND_R) :: s
!!--begin--
s = SUM( ABS( A*W ) )
!!--end--
END FUNCTION

PURE FUNCTION NormEll1_A3W3_Rsp(A,W) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:),W(:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = SUM( ABS( A*W ) )
!!--end--
END FUNCTION

PURE FUNCTION NormEll1_A4W4_Rsp(A,W) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:,:),W(:,:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = SUM( ABS( A*W ) )
!!--end--
END FUNCTION

PURE FUNCTION NormEll1_A5W5_Rsp(A,W) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:,:,:),W(:,:,:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = SUM( ABS( A*W ) )
!!--end--
END FUNCTION

PURE FUNCTION NormEll1_A6W6_Rsp(A,W) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:,:,:,:),W(:,:,:,:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = SUM( ABS( A*W ) )
!!--end--
END FUNCTION

PURE FUNCTION NormEll1_A7W7_Rsp(A,W) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:,:,:,:,:),W(:,:,:,:,:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = SUM( ABS( A*W ) )
!!--end--
END FUNCTION

!!### L-2 Norm for double precision
PURE FUNCTION NormEll1_A1W1_Rdp(A,W) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:),W(:)
REAL(KIND_R) :: s
!!--begin--
s = SUM( ABS( A*W ) )
!!--end--
END FUNCTION

PURE FUNCTION NormEll1_A2W2_Rdp(A,W) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:),W(:,:)
REAL(KIND_R) :: s
!!--begin--
s = SUM( ABS( A*W ) )
!!--end--
END FUNCTION

PURE FUNCTION NormEll1_A3W3_Rdp(A,W) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:),W(:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = SUM( ABS( A*W ) )
!!--end--
END FUNCTION

PURE FUNCTION NormEll1_A4W4_Rdp(A,W) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:,:),W(:,:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = SUM( ABS( A*W ) )
!!--end--
END FUNCTION

PURE FUNCTION NormEll1_A5W5_Rdp(A,W) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:,:,:),W(:,:,:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = SUM( ABS( A*W ) )
!!--end--
END FUNCTION

PURE FUNCTION NormEll1_A6W6_Rdp(A,W) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:,:,:,:),W(:,:,:,:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = SUM( ABS( A*W ) )
!!--end--
END FUNCTION

PURE FUNCTION NormEll1_A7W7_Rdp(A,W) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
REAL(KIND_R),INTENT(IN) :: A(:,:,:,:,:,:,:),W(:,:,:,:,:,:,:)
REAL(KIND_R) :: s
!!--begin--
s = SUM( ABS( A*W ) )
!!--end--
END FUNCTION

END MODULE


ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c SUBROUTINE INTEGRATE
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      subroutine integrate(z_w,q,z_iso,iqu,iql,L,M,N)

      implicit none
      integer L, M, N
      real*8 z_w(N+1,M,L)
      real*8 z_iso(M,L)
      real*8 q(N,M,L)
      real*8 iqu(M,L)
      real*8 iql(M,L)
cf2py intent(out) iqu
cf2py intent(out) iql
      integer i, j, k
      real*8 dz(N)
      real*8 dzp

      do i=1,L
        do j=1,M
          do k=1,N
            dz(k)=z_w(k+1,j,i)-z_w(k,j,i)
          enddo
          iqu(j,i)=0.0
          iql(j,i)=0.0
          do k=1,N
            if (z_w(k,j,i).gt.z_iso(j, i)) then
              iqu(j,i) = iqu(j,i) + dz(k)*q(k,j,i)
            else if (z_w(k+1,j,i).gt.(z_iso(j,i))) then
              dzp = z_w(k+1,j,i) - z_iso(j,i)
              iqu(j,i) = iqu(j,i) + dzp*q(k,j,i)
              dzp = z_iso(j,i) - z_w(k,j,i)
              iql(j,i) = iql(j,i) + dzp*q(k,j,i)
            else
              iql(j,i) = iql(j,i) + dz(k)*q(k,j,i)
            endif
          enddo
        enddo
      enddo

      return
      end

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c SUBROUTINE SURFACE
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      subroutine surface(z, q, q0, z_iso, L, M, N)
c Assume q is sorted

      implicit none
      integer L, M, N
      real*8 z(N,M,L)
      real*8 q(N,M,L)
      real*8 q0(M,L)
      real*8 z_iso(M,L)
cf2py intent(out) z_iso
      integer i, j, k
      real*8 dz, dq, dq0

      do i=1,L
        do j=1,M
          z_iso(j,i)=1.0d20 ! default value - isoline not in profile
          do k=1,N-1
            if ( (q(k,j,i).lt.q0(j,i).and.q(k+1,j,i).gt.q0(j,i)).or.
     &           (q(k,j,i).gt.q0(j,i).and.q(k+1,j,i).lt.q0(j,i)) ) then
              dz = z(k+1,j,i) - z(k,j,i)
              dq = q(k+1,j,i) - q(k,j,i)
              dq0 = q0(j,i) - q(k,j,i)
              z_iso(j,i) = z(k,j,i) + dz*dq0/dq
            endif
          enddo
        enddo
      enddo

      return
      end

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c SUBROUTINE ZSLICE
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      subroutine zslice (z,f3d,depths,f2d,vinterp,L,M,N)

      implicit none
      integer L, M, N, vinterp
      real*8 depths(M,L)
      real*8 f3d(N,M,L), z(N,M,L)
      real*8 f2d(M,L)
cf2py intent(out) f2d
      integer i, j, k
      real*8 zk(N), fk(N)
      real*8 wk(N), dfdz(N)

c  Linear Interpolation.
      if (vinterp.eq.0) then
        do i=1,L
          do j=1,M
            do k=1,N
              fk(k)=f3d(k,j,i)
              zk(k)=z(k,j,i)
            enddo
            if ((zk(1).le.depths(j,i)).and.(depths(j,i).le.zk(N))) then
              call lintrp (N,zk,fk,1,depths(j,i),f2d(j,i))
            else
              f2d(j,i)=1.0d20
            endif
          enddo
        enddo
c  Cubic spline interpolation.
      else if (vinterp.eq.1) then
        do i=1,L
          do j=1,M
            do k=1,N
              fk(k)=f3d(k,j,i)
              zk(k)=z(k,j,i)
            enddo
            call spline (zk,fk,N,1.0d30,1.0d30,wk)
            if ((zk(1).le.depths(j,i)).and.(depths(j,i).le.zk(N))) then
              call splint (zk,fk,wk,N,depths(j,i),f2d(j,i),dfdz)
            else
              f2d(j,i)=1.0d20
            endif
          enddo
        enddo
      endif

      return
      end

      subroutine lintrp (n,x,y,ni,xi,yi)
c
c=======================================================================
c  Copyright (c) 1996 Rutgers University                             ===
c=======================================================================
c                                                                    ===
c  Given arrays X and Y of length N, which tabulate a function,      ===
c  Y = F(X),  with the Xs  in ascending order, and given array       ===
c  XI of lenght NI, this routine returns a linear interpolated       ===
c  array YI.                                                         ===
c                                                                    ===
c=======================================================================
c
c-----------------------------------------------------------------------
c  Define local variable.
c-----------------------------------------------------------------------
c
      implicit none
      integer i, ii, j, n, ni
      real*8 d1, d2
      real*8 x(n), y(n), xi(ni), yi(ni)
c
c-----------------------------------------------------------------------
c  Begin executable code.
c-----------------------------------------------------------------------
c
      do 30 j=1,ni
        if (xi(j).le.x(1)) then
          ii=1
          yi(j)=y(1)
        elseif (xi(j).ge.x(n))then
          yi(j)=y(n)
        else
          do 10 i=1,n-1
            if ((x(i).lt.xi(j)).and.(xi(j).le.x(i+1))) then
              ii=i
              goto 20
            endif
 10       continue
 20       d1=xi(j)-x(ii)
          d2=x(ii+1)-xi(j)
          yi(j)=(d1*y(ii+1)+d2*y(ii))/(d1+d2)
        endif
 30   continue
      return
      end

      subroutine spline (x,y,n,yp1,ypn,y2)
c
c=======================================================================
c  Copyright (c) 1996 Rutgers University                             ===
c=======================================================================
c                                                                    ===
c  Given X, Y of length N containing a tabulated function,  Y=f(X),  ===
c  with the Xs  in ascending order,  and given values  Yp1 and  Ypn  ===
c  for the first derivative of the interpolating function at points  ===
c  1 and N, respectively this routine returns an array Y2 of length  ===
c  N  which contains the  second  derivatives of the  interpolating  ===
c  function at the tabulated points X.  If Yp1 and/or Ypn are equal  ===
c  to  1.0E+30  or larger,  the routine  is  signalled  to  set the  ===
c  corresponding boundary condition for a natural spline, with zero  ===
c  second derivative on that boundary.                               ===
c                                                                    ===
c  Reference :                                                       ===
c                                                                    ===
c  Press, W.H, B.P. Flannery, S.A. Teukolsky, and W.T. Vetterling,   ===
c        1986: Numerical Recipes, the art of scientific computing.   ===
c        Cambridge University Press.                                 ===
c                                                                    ===
c=======================================================================
c
c-----------------------------------------------------------------------
c  Define global data.
c-----------------------------------------------------------------------
c
      real*8 cm1,cm3,c0,c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c20,c25,c50,
     &     c90,c100,c180,c200,c255,c300,c360,c366,c500,c1000,c5000,
     &     c10000,c1em9,c1em10,c1em12,c1em20,c1ep30,p006,p009,p035,
     &     p015,p012,p08,p06,p5,p25,p75,p98,r3,r10,r20,r33,r35,r40,
     &     r50,r80,r100,r200,r250,r400,r1000
      real*8 day2sec,deg2rad,grav,cm2m,m2cm,m2km,pi,rad2deg,re,root2,
     &     sec2day,spval0,spval1,spval2,spvgeo
c
      parameter (cm1=-1.0,cm3=-3.0,c0=0.0,c1=1.0,c2=2.0,c3=3.0,c4=4.0,
     &           c5=5.0,c6=6.0,c7=7.0,c8=8.0,c9=9.0,c10=10,c11=11.0,
     &           c20=20.0,c25=25.0,c50=50.0,c90=90.0,c100=100.0,
     &           c180=180.0,c200=200.0,c255=255.0,c300=300.0,c360=360.0,
     &           c366=366.0,c500=500,c1000=1000.0,c5000=5000.0,
     &           c10000=10000.0,c1em9=1.0e-9,c1em10=1.0e-10,
     &           c1em12=1.0e-12,c1em20=1.0e-20,c1ep30=1.0e+30,
     &           p006=0.006,p009=0.009,p012=0.012,p015=0.015,p035=0.035,
     &           p06=0.06,p08=0.08,p5=0.5,p25=0.25,p75=0.75,p98=0.98,
     &           r3=c1/c3,r10=0.1,r20=0.05,r33=c1/33.0,r35=c1/35.0,
     &           r40=0.025,r50=0.02,r80=0.0125,r100=0.01,r200=0.005,
     &           r250=0.004,r400=0.0025,r1000=0.001)
      parameter (day2sec=86400.0,cm2m=r100,grav=9.8,m2cm=c100,
     &           m2km=r1000,pi=3.14159265358979323846,re=637131500.0,
     &           root2=1.41421356237309504880,sec2day=c1/86400.0,
     &           spvgeo=999.0,spval0=0.99e+35,spval1=1.0e+35,
     &           spval2=0.99e+30)
      parameter (deg2rad=pi/c180,rad2deg=c180/pi)

c
c-----------------------------------------------------------------------
c  Define local data.  Change NMAX as desired to be the largest
c  anticipated value of N.
c-----------------------------------------------------------------------
c
      integer i, k, n, nmax
      parameter (nmax=10000)
      real*8 p, qn, sig, un, ypn, yp1
      real*8 x(n), y(n), y2(n), u(nmax)
c
c-----------------------------------------------------------------------
c  Begin excutable code.
c-----------------------------------------------------------------------
c
      if (n.gt.nmax) then
        print 10, n,nmax
 10     format(/' SPLINE: underdimensioned array, N, NMAX = ',2i5)
        call crash ('SPLINE',1)
      endif
c
c  The lower boundary condition is set either to be "natural" or else
c  to have a specified first derivative.
c
      if (yp1.gt.spval2) then
        y2(1)=c0
        u(1)=c0
      else
        y2(1)=-p5
        u(1)=(c3/(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1)
      endif
c
c  This is the decomposition loop of the tridiagonal algorithm. Y2 and
c  U are used for temporary storage of the decomposition factors.
c
      do i=2,n-1
        sig=(x(i)-x(i-1))/(x(i+1)-x(i-1))
        p=sig*y2(i-1)+c2
        y2(i)=(sig-c1)/p
        u(i)=(c6*((y(i+1)-y(i))/(x(i+1)-x(i))-
     &           (y(i)-y(i-1))/(x(i)-x(i-1)))/
     &           (x(i+1)-x(i-1))-sig*u(i-1))/p
      enddo
c
c  The upper boundary condition is set either to be "natural" or else
c  to have a specified first derivative.
c
      if (ypn.gt.spval2) then
        qn=c0
        un=c0
      else
        qn=p5
        un=(c3/(x(n)-x(n-1)))*(ypn-(y(n)-y(n-1))/(x(n)-x(n-1)))
      endif
      y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+c1)
c
c  This is the back-substitution loop of the tridiagonal algorithm.
c
      do k=n-1,1,-1
        y2(k)=y2(k)*y2(k+1)+u(k)
      enddo
      return
      end

      subroutine splint (x,y,y2,n,xx,yy,dydx)
c
c=======================================================================
c  Copyright (c) 1996 Rutgers University                             ===
c=======================================================================
c                                                                    ===
c  Given arrays X and Y of length N, which tabulate a function,      ===
c  Y=f(X), with the Xs  in ascending order, and given the array      ===
c  Y2 which contains the second derivative of the interpolating      ===
c  function  at the  tabulated points X as computed  by routine      ===
c  SPLINE, and given a value  XX, this routine returns a cubic-      ===
c  spline interpolated value YY.                                     ===
c                                                                    ===
c  Reference :                                                       ===
c                                                                    ===
c  Press, W.H, B.P. Flannery, S.A. Teukolsky, and W.T. Vetterling,   ===
c         1986: Numerical Recipes, the art of scientific computing.  ===
c         Cambridge University Press.                                ===
c                                                                    ===
c  Modified by H.G. Arango (1989) to output the first derivative     ===
c  DYDX at a given value XX.                                         ===
c                                                                    ===
c=======================================================================
c
c-----------------------------------------------------------------------
c  Define global data.
c-----------------------------------------------------------------------
c
      implicit none
      real*8 cm1,cm3,c0,c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c20,c25,c50,
     &     c90,c100,c180,c200,c255,c300,c360,c366,c500,c1000,c5000,
     &     c10000,c1em9,c1em10,c1em12,c1em20,c1ep30,p006,p009,p035,
     &     p015,p012,p08,p06,p5,p25,p75,p98,r3,r10,r20,r33,r35,r40,
     &     r50,r80,r100,r200,r250,r400,r1000
      real*8 day2sec,deg2rad,grav,cm2m,m2cm,m2km,pi,rad2deg,re,root2,
     &     sec2day,spval0,spval1,spval2,spvgeo
c
      parameter (cm1=-1.0,cm3=-3.0,c0=0.0,c1=1.0,c2=2.0,c3=3.0,c4=4.0,
     &           c5=5.0,c6=6.0,c7=7.0,c8=8.0,c9=9.0,c10=10,c11=11.0,
     &           c20=20.0,c25=25.0,c50=50.0,c90=90.0,c100=100.0,
     &           c180=180.0,c200=200.0,c255=255.0,c300=300.0,c360=360.0,
     &           c366=366.0,c500=500,c1000=1000.0,c5000=5000.0,
     &           c10000=10000.0,c1em9=1.0e-9,c1em10=1.0e-10,
     &           c1em12=1.0e-12,c1em20=1.0e-20,c1ep30=1.0e+30,
     &           p006=0.006,p009=0.009,p012=0.012,p015=0.015,p035=0.035,
     &           p06=0.06,p08=0.08,p5=0.5,p25=0.25,p75=0.75,p98=0.98,
     &           r3=c1/c3,r10=0.1,r20=0.05,r33=c1/33.0,r35=c1/35.0,
     &           r40=0.025,r50=0.02,r80=0.0125,r100=0.01,r200=0.005,
     &           r250=0.004,r400=0.0025,r1000=0.001)
      parameter (day2sec=86400.0,cm2m=r100,grav=9.8,m2cm=c100,
     &           m2km=r1000,pi=3.14159265358979323846,re=637131500.0,
     &           root2=1.41421356237309504880,sec2day=c1/86400.0,
     &           spvgeo=999.0,spval0=0.99e+35,spval1=1.0e+35,
     &           spval2=0.99e+30)
      parameter (deg2rad=pi/c180,rad2deg=c180/pi)

c
c-----------------------------------------------------------------------
c  Define local data.
c-----------------------------------------------------------------------
c
      integer k, khi, klo, n
      real*8 a, b, c, d, dydx, e, f, h, xx, yy
      real*8 x(n), y(n), y2(n)
c
c-----------------------------------------------------------------------
c  Begin executable code.
c-----------------------------------------------------------------------
c
c  Found the right place of XX in the table by means of bisection.
c
      klo=1
      khi=n
  10  if ((khi-klo).gt.1) then
        k=(khi+klo)/2
        if(x(k).gt.xx) then
          khi=k
        else
          klo=k
        endif
        goto 10
      endif
c
c  KLO and KHI now bracket the input value XX.
c
      h=x(khi)-x(klo)
      if (h.eq.c0) then
        print *, ' SPLINT: bad X input, they must be distinct.'
        call crash ('SPLINT',1)
      endif
c
c  Evaluate cubic spline polynomial.
c
      a=(x(khi)-xx)/h
      b=(xx-x(klo))/h
      c=(a*a*a-a)*(h*h)/c6
      d=(b*b*b-b)*(h*h)/c6
      e=(c3*(a*a)-c1)*h/c6
      f=(c3*(b*b)-c1)*h/c6
      yy=a*y(klo)+b*y(khi)+c*y2(klo)+d*y2(khi)
      dydx=(y(khi)-y(klo))/h-e*y2(klo)+f*y2(khi)
      return
      end

      subroutine crash (string,ierr)
      integer ierr
      character*(*) string

      if (string(1:4).eq.'DONE') then
        print 10, string
  10    format(a)
        ierr=0
      else
        print 20, string
  20    format(/,' Execution abnormally terminated in module: ',a,/)
        ierr=1
      endif
      return
      end


!--------------------------------------------------------------------
!
!
! PURPOSE
!
! This subroutine gets initial data for nonlinear sine-Gordon equation
! in 2 dimensions
! u_{tt}-u_{xx}-u_{yy}=-sin(u)
!
! The boundary conditions are u(x=-Lx*\pi,y)=u(x=Lx*\pi,y),
!     u(x,y=-Ly*\pi)=u(x,y=Ly*\pi)
! The initial condition is u=0.5*exp(-x^2-y^2)
!
! AUTHORS
!
! B. Cloutier, B.K. Muite, P. Rigge
! 4 June 2012
!
! INPUT
!
! .. Parameters ..
!  Nx                         = number of modes in x - power of 2 for FFT
!  Ny                         = number of modes in y - power of 2 for FFT
! .. Vectors ..
!  x                          = x locations
!  y                          = y locations
!
! OUTPUT
!
! .. Arrays ..
!  u                          = initial solution
!  uold                       = approximate solution based on time derivative of
!                                     initial solution
!
! LOCAL VARIABLES
!
! .. Scalars ..
!  i                          = loop counter in x direction
!  j                          = loop counter in y direction
!
! REFERENCES
!
! ACKNOWLEDGEMENTS
!
! ACCURACY
!
! ERROR INDICATORS AND WARNINGS
!
! FURTHER COMMENTS
! Check that the initial iterate is consistent with the
! boundary conditions for the domain specified
!--------------------------------------------------------------------
! External routines required
!
! External libraries required
! OpenMP library
SUBROUTINE initialdata(Nx,Ny,x,y,u,uold)
  USE omp_lib
  IMPLICIT NONE
  INTEGER(KIND=4), INTENT(IN)                        :: Nx,Ny
  REAL(KIND=8), DIMENSION(1:NX), INTENT(IN)          :: x
  REAL(KIND=8), DIMENSION(1:NY), INTENT(IN)          :: y
  REAL(KIND=8), DIMENSION(1:NX,1:NY), INTENT(OUT)    :: u,uold
  INTEGER(kind=4)                                    :: i,j
  !$OMP PARALLEL DO PRIVATE(j) SCHEDULE(static)
  DO j=1,Ny
     u(1:Nx,j)=0.5d0*exp(-1.0d0*(x(1:Nx)**2 +y(j)**2))
  END DO
  !$OMP END PARALLEL DO
  !$OMP PARALLEL DO PRIVATE(j) SCHEDULE(static)
  DO j=1,Ny
     uold(1:Nx,j)=0.5d0*exp(-1.0d0*(x(1:Nx)**2 +y(j)**2))
  END DO
  !$OMP END PARALLEL DO
END SUBROUTINE initialdata


      SUBROUTINE DGEFA(A, LDA, N, IPVT, INFO)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
!...Translated by Pacific-Sierra Research 77to90  4.3E  21:52:17  11/14/01
!...Switches:
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE idamax_I
      USE dscal_I
      USE daxpy_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER , INTENT(IN) :: LDA
      INTEGER , INTENT(IN) :: N
      INTEGER , INTENT(OUT) :: INFO
      INTEGER , INTENT(OUT) :: IPVT(1)
      REAL(DOUBLE)  :: A(LDA,1)
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: J, K, KP1, L, NM1
      REAL(DOUBLE) :: T
!-----------------------------------------------
!
!     DGEFA FACTORS A DOUBLE PRECISION MATRIX BY GAUSSIAN ELIMINATION.
!
!     DGEFA IS USUALLY CALLED BY DGECO, BUT IT CAN BE CALLED
!     DIRECTLY WITH A SAVING IN TIME IF  RCOND  IS NOT NEEDED.
!     (TIME FOR DGECO) = (1 + 9/N)*(TIME FOR DGEFA) .
!
!     ON ENTRY
!
!        A       DOUBLE PRECISION(LDA, N)
!                THE MATRIX TO BE FACTORED.
!
!        LDA     INTEGER
!                THE LEADING DIMENSION OF THE ARRAY  A .
!
!        N       INTEGER
!                THE ORDER OF THE MATRIX  A .
!
!     ON RETURN
!
!        A       AN UPPER TRIANGULAR MATRIX AND THE MULTIPLIERS
!                WHICH WERE USED TO OBTAIN IT.
!                THE FACTORIZATION CAN BE WRITTEN  A = L*U  WHERE
!                L  IS A PRODUCT OF PERMUTATION AND UNIT LOWER
!                TRIANGULAR MATRICES AND  U  IS UPPER TRIANGULAR.
!
!        IPVT    INTEGER(N)
!                AN INTEGER VECTOR OF PIVOT INDICES.
!
!        INFO    INTEGER
!                = 0  NORMAL VALUE.
!                = K  IF  U(K,K) .EQ. 0.0 .  THIS IS NOT AN ERROR
!                     CONDITION FOR THIS SUBROUTINE, BUT IT DOES
!                     INDICATE THAT DGESL OR DGEDI WILL DIVIDE BY ZERO
!                     IF CALLED.  USE  RCOND  IN DGECO FOR A RELIABLE
!                     INDICATION OF SINGULARITY.
!
!     LINPACK. THIS VERSION DATED 08/14/78 .
!     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
!
!     SUBROUTINES AND FUNCTIONS
!
!     BLAS DAXPY,DSCAL,IDAMAX
!
!     INTERNAL VARIABLES
!
!
!
!     GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING
!
      INFO = 0
      NM1 = N - 1
      IF (NM1 >= 1) THEN
         DO K = 1, NM1
            KP1 = K + 1
!
!        FIND L = PIVOT INDEX
!
            L = IDAMAX(N - K + 1,A(K,K),1) + K - 1
            IPVT(K) = L
!
!        ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED
!
            IF (A(L,K) /= 0.0D0) THEN
!
!           INTERCHANGE IF NECESSARY
!
               IF (L /= K) THEN
                  T = A(L,K)
                  A(L,K) = A(K,K)
                  A(K,K) = T
               ENDIF
!
!           COMPUTE MULTIPLIERS
!
               T = -1.0D0/A(K,K)
               CALL DSCAL (N - K, T, A(K+1,K), 1)
!
!           ROW ELIMINATION WITH COLUMN INDEXING
!
               DO J = KP1, N
                  T = A(L,J)
                  IF (L /= K) THEN
                     A(L,J) = A(K,J)
                     A(K,J) = T
                  ENDIF
                  CALL DAXPY (N - K, T, A(K+1,K), 1, A(K+1,J), 1)
               END DO
            ELSE
               INFO = K
            ENDIF
         END DO
      ENDIF
      IPVT(N) = N
      IF (A(N,N) == 0.0D0) INFO = N
      RETURN
      END SUBROUTINE DGEFA


submodule(forlab) forlab_randn
    !! Version: experimental
    !!
    !! Discussion:
    !! ----
    !! https://fortran-lang.discourse.group/t/fortran-function-return-value-polymorphism/1350/5
    use forlab_kinds
    implicit none
contains
    !! Default versions
    module procedure randn_0_default
        real(dp) :: u, v, s
        do
            u = 2.d0*randu() - 1.d0
            v = 2.d0*randu() - 1.d0
            s = u*u + v*v
            if ((s > 0.d0) .and. (s < 1.d0)) exit
        end do
        randn_0_default = u*sqrt(-2.0d0*log(s)/s)

        return
    end procedure

    module procedure randn_1_default
        integer :: i
        allocate (randn_1_default (dim1))
        do i = 1, dim1
            randn_1_default (i) = randn_0_default()
        end do

        return
    end procedure

    module procedure randn_2_default
        integer :: i, j
        allocate (randn_2_default (dim1, dim2))
        do i = 1, dim1
            do j = 1, dim2
                randn_2_default (i, j) = randn_0_default()
            end do
        end do

        return
    end procedure

    module procedure randn_3_default
        integer :: i, j, k
        allocate (randn_3_default (dim1, dim2, dim3))
        do i = 1, dim1
            do j = 1, dim2
                do k = 1, dim3
                    randn_3_default (i, j, k) = randn_0_default()
                end do
            end do
        end do

        return
    end procedure

    !! Multi-precision versions
    module procedure randn_0_sp
        real(sp) :: u, v, s

        do
            u = 2._sp*randu(flag) - 1._sp
            v = 2._sp*randu(flag) - 1._sp
            s = u*u + v*v
            if ((s > 0._sp) .and. (s < 1._sp)) exit
        end do
        randn_0_sp = u*sqrt(-2.0_sp*log(s)/s)

        return
    end procedure

    module procedure randn_0_dp
        real(dp) :: u, v, s

        do
            u = 2._dp*randu(flag) - 1._dp
            v = 2._dp*randu(flag) - 1._dp
            s = u*u + v*v
            if ((s > 0._dp) .and. (s < 1._dp)) exit
        end do
        randn_0_dp = u*sqrt(-2.0_dp*log(s)/s)

        return
    end procedure

    module procedure randn_0_qp
        real(qp) :: u, v, s

        do
            u = 2._qp*randu(flag) - 1._qp
            v = 2._qp*randu(flag) - 1._qp
            s = u*u + v*v
            if ((s > 0._qp) .and. (s < 1._qp)) exit
        end do
        randn_0_qp = u*sqrt(-2.0_qp*log(s)/s)

        return
    end procedure

    module procedure randn_1_sp
        integer :: i

        allocate (randn_1_sp (dim1))
        do i = 1, dim1
            randn_1_sp (i) = randn_0_sp (flag)
        end do

        return
    end procedure

    module procedure randn_1_dp
        integer :: i

        allocate (randn_1_dp (dim1))
        do i = 1, dim1
            randn_1_dp (i) = randn_0_dp (flag)
        end do

        return
    end procedure

    module procedure randn_1_qp
        integer :: i

        allocate (randn_1_qp (dim1))
        do i = 1, dim1
            randn_1_qp (i) = randn_0_qp (flag)
        end do

        return
    end procedure

    module procedure randn_2_sp
        integer :: i, j

        allocate (randn_2_sp (dim1, dim2))
        do i = 1, dim1
            do j = 1, dim2
                randn_2_sp (i, j) = randn_0_sp (flag)
            end do
        end do

        return
    end procedure

    module procedure randn_2_dp
        integer :: i, j

        allocate (randn_2_dp (dim1, dim2))
        do i = 1, dim1
            do j = 1, dim2
                randn_2_dp (i, j) = randn_0_dp (flag)
            end do
        end do

        return
    end procedure

    module procedure randn_2_qp
        integer :: i, j

        allocate (randn_2_qp (dim1, dim2))
        do i = 1, dim1
            do j = 1, dim2
                randn_2_qp (i, j) = randn_0_qp (flag)
            end do
        end do

        return
    end procedure

    module procedure randn_3_sp
        integer :: i, j, k

        allocate (randn_3_sp (dim1, dim2, dim3))
        do i = 1, dim1
            do j = 1, dim2
                do k = 1, dim3
                    randn_3_sp (i, j, k) = randn_0_sp (flag)
                end do
            end do
        end do

        return
    end procedure

    module procedure randn_3_dp
        integer :: i, j, k

        allocate (randn_3_dp (dim1, dim2, dim3))
        do i = 1, dim1
            do j = 1, dim2
                do k = 1, dim3
                    randn_3_dp (i, j, k) = randn_0_dp (flag)
                end do
            end do
        end do

        return
    end procedure

    module procedure randn_3_qp
        integer :: i, j, k

        allocate (randn_3_qp (dim1, dim2, dim3))
        do i = 1, dim1
            do j = 1, dim2
                do k = 1, dim3
                    randn_3_qp (i, j, k) = randn_0_qp (flag)
                end do
            end do
        end do

        return
    end procedure

end submodule


*DECK SCHUD
      SUBROUTINE SCHUD (R, LDR, P, X, Z, LDZ, NZ, Y, RHO, C, S)
C***BEGIN PROLOGUE  SCHUD
C***PURPOSE  Update an augmented Cholesky decomposition of the
C            triangular part of an augmented QR decomposition.
C***LIBRARY   SLATEC (LINPACK)
C***CATEGORY  D7B
C***TYPE      SINGLE PRECISION (SCHUD-S, DCHUD-D, CCHUD-C)
C***KEYWORDS  CHOLESKY DECOMPOSITION, LINEAR ALGEBRA, LINPACK, MATRIX,
C             UPDATE
C***AUTHOR  Stewart, G. W., (U. of Maryland)
C***DESCRIPTION
C
C     SCHUD updates an augmented Cholesky decomposition of the
C     triangular part of an augmented QR decomposition.  Specifically,
C     given an upper triangular matrix R of order P, a row vector
C     X, a column vector Z, and a scalar Y, SCHUD determines a
C     unitary matrix U and a scalar ZETA such that
C
C
C                              (R  Z)     (RR   ZZ )
C                         U  * (    )  =  (        ) ,
C                              (X  Y)     ( 0  ZETA)
C
C     where RR is upper triangular.  If R and Z have been
C     obtained from the factorization of a least squares
C     problem, then RR and ZZ are the factors corresponding to
C     the problem with the observation (X,Y) appended.  In this
C     case, if RHO is the norm of the residual vector, then the
C     norm of the residual vector of the updated problem is
C     SQRT(RHO**2 + ZETA**2).  SCHUD will simultaneously update
C     several triplets (Z,Y,RHO).
C     For a less terse description of what SCHUD does and how
C     it may be applied, see the LINPACK guide.
C
C     The matrix U is determined as the product U(P)*...*U(1),
C     where U(I) is a rotation in the (I,P+1) plane of the
C     form
C
C                       (     C(I)      S(I) )
C                       (                    ) .
C                       (    -S(I)      C(I) )
C
C     The rotations are chosen so that C(I) is real.
C
C     On Entry
C
C         R      REAL(LDR,P), where LDR .GE. P.
C                R contains the upper triangular matrix
C                that is to be updated.  The part of R
C                below the diagonal is not referenced.
C
C         LDR    INTEGER.
C                LDR is the leading dimension of the array R.
C
C         P      INTEGER.
C                P is the order of the matrix R.
C
C         X      REAL(P).
C                X contains the row to be added to R.  X is
C                not altered by SCHUD.
C
C         Z      REAL(LDZ,NZ), where LDZ .GE. P.
C                Z is an array containing NZ P-vectors to
C                be updated with R.
C
C         LDZ    INTEGER.
C                LDZ is the leading dimension of the array Z.
C
C         NZ     INTEGER.
C                NZ is the number of vectors to be updated.
C                NZ may be zero, in which case Z, Y, and RHO
C                are not referenced.
C
C         Y      REAL(NZ).
C                Y contains the scalars for updating the vectors
C                Z.  Y is not altered by SCHUD.
C
C         RHO    REAL(NZ).
C                RHO contains the norms of the residual
C                vectors that are to be updated.  If RHO(J)
C                is negative, it is left unaltered.
C
C     On Return
C
C         RC
C         RHO    contain the updated quantities.
C         Z
C
C         C      REAL(P).
C                C contains the cosines of the transforming
C                rotations.
C
C         S      REAL(P).
C                S contains the sines of the transforming
C                rotations.
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  SROTG
C***REVISION HISTORY  (YYMMDD)
C   780814  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  SCHUD
      INTEGER LDR,P,LDZ,NZ
      REAL RHO(*),C(*)
      REAL R(LDR,*),X(*),Z(LDZ,*),Y(*),S(*)
C
      INTEGER I,J,JM1
      REAL AZETA,SCALE
      REAL T,XJ,ZETA
C
C     UPDATE R.
C
C***FIRST EXECUTABLE STATEMENT  SCHUD
      DO 30 J = 1, P
         XJ = X(J)
C
C        APPLY THE PREVIOUS ROTATIONS.
C
         JM1 = J - 1
         IF (JM1 .LT. 1) GO TO 20
         DO 10 I = 1, JM1
            T = C(I)*R(I,J) + S(I)*XJ
            XJ = C(I)*XJ - S(I)*R(I,J)
            R(I,J) = T
   10    CONTINUE
   20    CONTINUE
C
C        COMPUTE THE NEXT ROTATION.
C
         CALL SROTG(R(J,J),XJ,C(J),S(J))
   30 CONTINUE
C
C     IF REQUIRED, UPDATE Z AND RHO.
C
      IF (NZ .LT. 1) GO TO 70
      DO 60 J = 1, NZ
         ZETA = Y(J)
         DO 40 I = 1, P
            T = C(I)*Z(I,J) + S(I)*ZETA
            ZETA = C(I)*ZETA - S(I)*Z(I,J)
            Z(I,J) = T
   40    CONTINUE
         AZETA = ABS(ZETA)
         IF (AZETA .EQ. 0.0E0 .OR. RHO(J) .LT. 0.0E0) GO TO 50
            SCALE = AZETA + RHO(J)
            RHO(J) = SCALE*SQRT((AZETA/SCALE)**2+(RHO(J)/SCALE)**2)
   50    CONTINUE
   60 CONTINUE
   70 CONTINUE
      RETURN
      END


      Subroutine GenDiagonalize(N,H,S,E,C)
!     Solve Symmetric Generalized Eigenvalue Problem H.C = E S.C
      Implicit None
      Integer*4 i,j,k,N,LWork, Info
      Real*8 H(N,N),S(N,N),E(N),C(N,N)
      Real*8 T(N,N),Hortho(N,N),Fac
      Real*8 VL(N,N),VR(N,N),Sig(N),Work(30*N+30)

!     Build T=S^-1/2
      LWork=30*N+30; T=S
      Call DGeSVD('A','A',N,N,T,N,Sig,VL,N,VR,N,Work,LWork,Info)
      T=0d0
      Do k=1,N
         If(Sig(k)>1d-8) Then
            Fac=1d0/Sqrt(Sig(k))
            Do i=1,N; Do j=1,N
               T(i,j)=T(i,j)
     $              +VL(j,k)*Fac*VR(k,i)
            End Do; End Do
         End If
      End Do

!     HOrtho=S^{-1/2}.H.S^{-1/2}
      HOrtho=MatMuL(T,MatMul(H,T))

!     Diagonalize HOrtho
      Call DSyEV('V','U',N,HOrtho,N,E,Work,LWork,i)

!     Convert Coefficients back to nonorthogonal basis
!      C=MatMul(T,HOrtho)
!     Leave Coefficients in Orthogonal basis
      C=HOrtho

      End Subroutine

      Subroutine SVDInverse(N,A,Ainv)
!     Compute the Pseudo-Inverse of A by SVD
      Implicit None
      Integer*4 i,j,k,N,LWork,Info
      Real*8 A(N,N),Ainv(N,N)
      Real*8 VL(N,N),VR(N,N),S(N),Work(30*N+30)
      Real*8 Zero, One

      Zero=0d0; One=1d0; LWork=30*N+30

      Ainv=A
      Call DGeSVD('A','A',N,N,Ainv,N,S,VL,N,VR,N,Work,LWork,Info)
      Ainv=Zero
      Do i=1,N; Do j=1,N; Do k=1,N
         If(S(k)>1d-8) Ainv(i,j)=Ainv(i,j)
     $        +VL(j,k)/S(k)*VR(k,i)
      End Do; End Do; End Do

      End Subroutine

      Subroutine GetDet(N,A,Det)
C     Computes the Determinant of a general NxN matrix
      Implicit None
      Integer*4 N,LWork, Info, i
      Real*8 A(N,N),B(N,N),Det
      Real*8 Vl(N,N),Vr(N,N),Wi(N),Wr(N),Work(10*N+10)
      Complex*16 W(N),III, X

      LWork=10*N+10; Info=0; III=(0d0,1d0)
      B=A

      Call DGeEV('V','V',N,B,N,Wr,Wi,Vl,N,Vr,N,Work,LWork,Info)

      W=Wr+III*Wi; X=(1d0,0d0)
C     Compute Determinant
      Do i=1,N; X=X*W(i); End Do

      Det=X
      End Subroutine

      Integer*4 Function MyMod(N,M)
C     Computes N mod M with my preferred rounding.
      Integer*4 M,N,I

      I=N
      Do While (.not.(I.le.M.and.I.gt.0))
         If(N.gt.M)I=I-M
         If(N.le.0)I=I+M
      End Do

      MyMod=I

      End Function

      Subroutine ExpMat(N,D,U)
!     U=Exp(D)
      Implicit None
      Integer*4 i,j,k,N
      Real*8 U(N,N), D(N,N), D1(N,N), D2(N,N), D3(N,N)

!     Build exp(D/4096) to near-machine precision
      U=0d0; Do i=1,N; U(i,i)=1d0; End Do
      D1=D/4096d0; D2=MatMul(D1,D1); D3=MatMul(D2,D1)
      U=U+D1+D2/2d0+D3/6d0

!     Multiply repeatedly to get up to full U
      Do i=1,6
         D1=MatMul(U,U);
         U=MatMul(D1,D1)
      End Do

      End Subroutine

      Subroutine LogQ(N,U,D)
!     Take the Log of a rotation matrix
!        U=exp(D)  with D real and skew-symmetric
!        Note: this doesn't deal with rotation+inversion
      Implicit None
      Integer*4 i,j,k,N, LWork, iUnit
      Real*8 U(N,N), D(N,N), Tmp(N,N), W(N,N), LogW(N,N)
      Real*8 WR(N),WI(N), VL(N,N), VR(N,N)
      Real*8 Work(10*N+10),eps

!     Diagonalize U
      Tmp=U; LWork=10*N+10; eps=1d-8
      Call DGeEV('V','V',N,Tmp,N,WR,WI,VL,N,VR,N,Work,LWork,i)

!     Check for eigenvalues of -1
      Do i=1,N;
         If(Abs(WI(i)).lt.1d-8.and. WR(i).lt.0d0)
     $        Write(6,*)'##Error! Inversion in U Matrix',i,WR(i)
      End Do

!     Fix Up Normalization of Eigenvectors
      Do i=1,N
         If(Abs(WI(i)).gt.eps) VL(:,i)=VL(:,i)*Sqrt(2d0)
         If(Abs(WI(i)).gt.eps) VR(:,i)=VR(:,i)*Sqrt(2d0)
      End Do

!     Take Log of W in canonical form (series of 2x2 real blocks)
!     Unless WR is 1, in which case the order gets messed up.
      LogW=0d0
      i=1
      Do While(i<N)
         If(Abs(WI(i)).gt. eps) Then
            LogW(i,i+1)=sign(acos(WR(i)),WI(i))
            LogW(i+1,i)=-LogW(i,i+1)
            i=i+2
         Else
            LogW(i,i)=0d0
            i=i+1
         End If
      End Do

!     D=V.LogW.V^{dagger}
      D=MatMul(VL,MatMul(LogW,Transpose(VL)))

!!     Check that This worked
!      Call ExpMat(N,D,Tmp)
!      Do i=1,N
!         Do j=1,N
!            If(Abs(U(i,j)-Tmp(i,j)).gt.1d-6)
!     $           Write(6,*)i,j,U(i,j),Tmp(i,j)
!         End Do
!      End Do

      End Subroutine
      Subroutine Diagonalize(N,A,Eigs,U,ierr)
      Implicit None
      Integer N,ierr,LWork
      Real*8 A(N,N),Eigs(N),U(N,N),Work(15*N+10)
! Get Eigenvalues and eigenvectors of a Real Symmetric Matrix

      LWork=15*N+10; U=A
      Call DSyEV('V','U',N,U,N,Eigs,Work,LWork,ierr)

      end subroutine

      Subroutine DgeMatMul(L,M,N,Y,Z,X,alpha,beta)
      Implicit None
!  X(L,N)= alpha*Y(L,M)*Z(M,N)+beta*(X(L,N)

      Integer*4 L,M,N
      Real*8 Y(L,M),Z(M,N),X(L,N),alpha,beta

!  ( transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc )

      Call Dgemm('N','N',L,N,M,alpha,Y(1,1),L,Z(1,1),M,beta,X(1,1),L)

      Return
      End Subroutine

      Subroutine Axb(N,LDA,A,b,M,ierr)
      Implicit None
! Solves Ax=b in the most stable way possible
      Integer*4 N,LDA,M,Ipiv(N),IWork(N),ierr
      Real*8 A(LDA,N),b(N,M)
      Real*8 AF(N,N),R(N),C(N),X(N,M),Rcond,Ferr,Berr,Work(4*N)
      Character*1 EQ
      Real*8 zero,one,two,three,four
      Data zero,one,two,three,four /0.0d0,1.0d0,2.0d0,3.0d0,4.0d0/

! Clear out all the temporary arrays
      Ipiv=0; IWork=0
      AF=zero; R=zero; C=zero; X=zero; Rcond=zero; Ferr=zero
      Berr=zero; Work=zero

!  Solve  Ax=b
!    In the first spot:
!     'N' - no equilibration
!     'E' - equilibrate A

      Call DGeSVX('N','N',N,M,A,LDA,AF,N,Ipiv,EQ,R,
     $               C,B,N,X,N,Rcond,Ferr,Berr,Work,IWork,ierr)

! Put the result back in b
      b=x

      Return
      End

      Real*8 Function factorial(n)
      Implicit None
! factorial - computes n!

      Integer*4 i,n

      factorial=1.0d0
      Do i=1,n
        factorial=factorial*i
      End Do

      Return
      End Function


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
Code below here possibly deprecated...
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

function poisson2D(rho,Vminx1,Vmaxx1,Vminx2,Vmaxx2,dx1,perflag)

!------------------------------------------------------------
!-------SOLVE POISSONS'S EQUATION IN 2D USING MUMPS.  THIS MAY
!-------BE USED BY SOME OF THE UNIT TEST PROGRAMS, BUT I FORGET...
!------------------------------------------------------------

real(wp), dimension(:,:), intent(in) :: rho
real(wp), dimension(:), intent(in) :: Vminx1,Vmaxx1
real(wp), dimension(:), intent(in) :: Vminx2,Vmaxx2
real(wp), intent(in) :: dx1
!    real(wp), dimension(:), intent(in) :: dx2 !! I guess this is assumed to be teh same as dx1???
logical, intent(in) :: perflag

integer :: ix1,ix2,lx1,lx2
integer :: lPhi, lent
integer :: iPhi,ient
integer, dimension(:), allocatable :: ir,ic
real(wp), dimension(:), allocatable :: M
real(wp), dimension(:), allocatable :: b
real(wp) :: tstart,tfin

#if REALBITS==32
type (SMUMPS_STRUC) mumps_par
#else
type (DMUMPS_STRUC) mumps_par
#endif
real(wp), dimension(size(rho,1),size(rho,2)) :: poisson2D

if (myid==0) then
!------------------------------------------------------------
!-------DEFINE A MATRIX USING SPARSE STORAGE (CENTRALIZED
!-------ASSEMBLED MATRIX INPUT, SEE SECTION 4.5 OF MUMPS USER
!-------GUIDE).
!------------------------------------------------------------
lx1=size(rho,1)
lx2=size(rho,2)
lPhi=lx1*lx2
lent=5*(lx1-2)*(lx2-2)+2*lx1+2*(lx2-2)
allocate(ir(lent),ic(lent),M(lent),b(lPhi))

!LOAD UP MATRIX ELEMENTS
M(:)=0.0
b=pack(rho,.true.)           !boundaries overwritten later
ient=1
do ix2=1,lx2
 do ix1=1,lx1
   iPhi=lx1*(ix2-1)+ix1     !linear index referencing Phi(ix1,ix2) as a column vector.  Also row of big matrix

   if (ix1==1) then          !BOTTOM GRID POINTS + CORNER
     ir(ient)=iPhi
     ic(ient)=iPhi
     M(ient)=1.0
     b(iPhi)=Vminx1(ix2)
     ient=ient+1
   elseif (ix1==lx1) then    !TOP GRID POINTS + CORNER
     ir(ient)=iPhi
     ic(ient)=iPhi
     M(ient)=1.0
     b(iPhi)=Vmaxx1(ix2)
     ient=ient+1
   elseif (ix2==1) then      !LEFT BOUNDARY
     ir(ient)=iPhi
     ic(ient)=iPhi
     M(ient)=1.0
     b(iPhi)=Vminx2(ix1)
     ient=ient+1
   elseif (ix2==lx2) then    !RIGHT BOUNDARY
     ir(ient)=iPhi
     ic(ient)=iPhi
     M(ient)=1.0
     b(iPhi)=Vmaxx2(ix1)
     ient=ient+1
   else                      !INTERIOR
     !ix1,ix2-1 grid point in ix1,ix2 equation
     ir(ient)=iPhi
     ic(ient)=iPhi-lx1
     M(ient)=1.0
     ient=ient+1

     !ix1-1,ix2 grid point
     ir(ient)=iPhi
     ic(ient)=iPhi-1
     M(ient)=1.0
     ient=ient+1

     !ix1,ix2 grid point
     ir(ient)=iPhi
     ic(ient)=iPhi
     M(ient)=-4.0
     ient=ient+1

     !ix1+1,ix2 grid point
     ir(ient)=iPhi
     ic(ient)=iPhi+1
     M(ient)=1.0
     ient=ient+1

     !ix1,ix2+1 grid point
     ir(ient)=iPhi
     ic(ient)=iPhi+lx1
     M(ient)=1.0
     ient=ient+1
   end if
 end do
end do

!CORRECT FOR DX /= 1
b=b*dx1**2
end if

!FIRE UP MUMPS
mumps_par%COMM = MPI_COMM_WORLD
mumps_par%JOB = -1
mumps_par%SYM = 0
mumps_par%PAR = 1
#if REALBITS==32
call SMUMPS(mumps_par)
#else
call DMUMPS(mumps_par)
#endif

call quiet_mumps(mumps_par)

!LOAD OUR PROBLEM (ROOT ONLY)
if ( myid == 0 ) then
 mumps_par%N=lPhi
 mumps_par%NZ=lent
 allocate( mumps_par%IRN ( mumps_par%NZ ) )
 allocate( mumps_par%JCN ( mumps_par%NZ ) )
 allocate( mumps_par%A( mumps_par%NZ ) )
 allocate( mumps_par%RHS ( mumps_par%N  ) )
 mumps_par%IRN=ir
 mumps_par%JCN=ic
 mumps_par%A=M
 mumps_par%RHS=b
 deallocate(ir,ic,M,b)     !clear memory before solve begins!!!

 if (perflag) then       !used cached permutation
   allocate(mumps_par%PERM_IN(mumps_par%N))
   mumps_par%PERM_IN=mumps_perm
   mumps_par%ICNTL(7)=1
 end if
end if

!SOLVE OUR PROBLEM (ALL WORKERS NEED TO SEE THIS CALL)
mumps_par%JOB = 6
call cpu_time(tstart)
#if REALBITS==32
call SMUMPS(mumps_par)
#else
call DMUMPS(mumps_par)
#endif

!> check if Mumps error occurred
if (mumps_par%INFO(1) < 0 .or. mumps_par%INFOG(1) < 0) then
 write(stderr, *) 'Gemini:potential_mumps:poisson2D  MUMPS ERROR: details:'
 write(stderr, *) 'Mumps Error: INFO(1)',mumps_par%INFO(1),'INFO(2)',mumps_par%INFO(2)
 write(stderr, *) 'Mumps Error: INFOG(1)',mumps_par%INFOG(1),'INFOG(2)',mumps_par%INFOG(2)
 error stop
endif

call cpu_time(tfin)
if (debug) print *, 'Solve took ',tfin-tstart,' seconds...'

!STORE PERMUTATION USED, SAVE RESULTS, CLEAN UP MUMPS ARRAYS
!(can save ~25% execution time and improves scaling with openmpi
! ~25% more going from 1-2 processors)
if ( myid == 0 ) then
 mumps_perm=mumps_par%SYM_PERM
 poisson2D=reshape(mumps_par%RHS/dx1**2,[lx1,lx2])

 deallocate( mumps_par%IRN )
 deallocate( mumps_par%JCN )
 deallocate( mumps_par%A   )
 deallocate( mumps_par%RHS )
end if

mumps_par%JOB = -2
#if REALBITS==32
call SMUMPS(mumps_par)
#else
call DMUMPS(mumps_par)
#endif

end function poisson2D

function elliptic3D_curv(srcterm,sig0,sigP,sigH,Vminx1,Vmaxx1,Vminx2,Vmaxx2,Vminx3,Vmaxx3, &
                 x,flagdirich,perflag,it)

!------------------------------------------------------------
!-------SOLVE IONOSPHERIC POTENTIAL EQUATION IN 3D USING MUMPS
!-------ASSUME THAT WE ARE RESOLVING THE POTENTIAL ALONG THE FIELD
!-------LINE.  THIS IS MOSTLY INEFFICIENT/UNWORKABLE FOR MORE THAN 1M
!-------GRID POINTS.
!------------------------------------------------------------

real(wp), dimension(:,:,:), intent(in) :: srcterm,sig0,sigP,sigH
real(wp), dimension(:,:), intent(in) :: Vminx1,Vmaxx1
real(wp), dimension(:,:), intent(in) :: Vminx2,Vmaxx2
real(wp), dimension(:,:), intent(in) :: Vminx3,Vmaxx3
type(curvmesh), intent(in) :: x
integer, intent(in) :: flagdirich
logical, intent(in) :: perflag
integer, intent(in) :: it

real(wp), dimension(1:size(srcterm,1),1:size(srcterm,2),1:size(srcterm,3)) :: gradsigP2,gradsigP3
real(wp), dimension(1:size(srcterm,1),1:size(srcterm,2),1:size(srcterm,3)) :: gradsigH2,gradsigH3
real(wp), dimension(1:size(srcterm,1),1:size(srcterm,2),1:size(srcterm,3)) :: gradsig01
real(wp), dimension(1:size(srcterm,1),1:size(srcterm,2),1:size(srcterm,3)) :: Ac,Bc,Cc,Dc,Ec,Fc

integer :: ix1,ix2,ix3,lx1,lx2,lx3
integer :: lPhi,lent
integer :: iPhi,ient
integer, dimension(:), allocatable :: ir,ic
real(wp), dimension(:), allocatable :: M
real(wp), dimension(:), allocatable :: b
real(wp) :: tstart,tfin

#if REALBITS==32
type (SMUMPS_STRUC) mumps_par
#else
type (DMUMPS_STRUC) mumps_par
#endif

real(wp), dimension(size(srcterm,1),size(srcterm,2),size(srcterm,3)) :: elliptic3D_curv

!ONLY ROOT NEEDS TO ASSEMBLE THE MATRIX
if (myid==0) then
 lx1=size(sig0,1)
 lx2=size(sig0,2)
 lx3=size(sig0,3)
 lPhi=lx1*lx2*lx3

 lent=7*(lx1-2)*(lx2-2)*(lx3-2)                                                 !interior entries
 lent=lent+2*(lx1-2)*(lx2-2)+2*(lx2-2)*(lx3-2)+2*(lx1-2)*(lx3-2)                !6 faces of cube
 lent=lent+4*(lx1-2)+4*(lx2-2)+4*(lx3-2)                                        !12 edges
 lent=lent+8                                                                    !8 corners, now we have total nonzero entries
 lent=lent+lx2*lx3                                                              !entries to deal with Neumann conditions on bottom
 if (flagdirich==0) then                                                        !more entries if Neumann on top
   lent=lent+lx2*lx3
 end if

 allocate(ir(lent),ic(lent),M(lent),b(lPhi))

 if (debug) print *, 'MUMPS will attempt a solve of size:  ',lx1,lx2,lx3
 if (debug) print *, 'Total unknowns and nonzero entries in matrix:  ',lPhi,lent

 !COMPUTE AUXILIARY COEFFICIENTS
 if (debug) print *, 'Prepping coefficients for elliptic equation...'
 gradsig01=grad3D1(sig0,x,1,lx1,1,lx2,1,lx3)
 gradsigP2=grad3D2(sigP,x,1,lx1,1,lx2,1,lx3)
 gradsigP3=grad3D3(sigP,x,1,lx1,1,lx2,1,lx3)
 gradsigH2=grad3D2(sigH,x,1,lx1,1,lx2,1,lx3)
 gradsigH3=grad3D3(sigH,x,1,lx1,1,lx2,1,lx3)

 Ac=sigP; Bc=sigP; Cc=sig0;
 Dc=gradsigP2+gradsigH3
 Ec=gradsigP3-gradsigH2
 Fc=gradsig01

 !------------------------------------------------------------
 !-------DEFINE A MATRIX USING SPARSE STORAGE (CENTRALIZED
 !-------ASSEMBLED MATRIX INPUT, SEE SECTION 4.5 OF MUMPS USER
 !-------GUIDE).
 !------------------------------------------------------------
 !LOAD UP MATRIX ELEMENTS
 M(:)=0d0
 b=pack(srcterm,.true.)           !boundaries overwritten later
 ient=1
 do ix3=1,lx3
   do ix2=1,lx2
   do ix1=1,lx1
     iPhi=lx1*lx2*(ix3-1)+lx1*(ix2-1)+ix1     !linear index referencing Phi(ix1,ix3) as a column vector.  Also row of big matrix

     if (ix1==1) then          !BOTTOM GRID POINTS + CORNER, USE NEUMANN HERE, PRESUMABLY ZERO
       ir(ient)=iPhi
       ic(ient)=iPhi
       M(ient)=-1d0
       ient=ient+1
       ir(ient)=iPhi
       ic(ient)=iPhi+1
       M(ient)=1d0
!            b(iPhi)=Vminx1(ix3)
       b(iPhi)=0d0    !force bottom current to zero
       ient=ient+1
     elseif (ix1==lx1) then    !TOP GRID POINTS + CORNER
       if (flagdirich/=0) then
         ir(ient)=iPhi
         ic(ient)=iPhi
         M(ient)=1d0
         b(iPhi)=Vmaxx1(ix2,ix3)
         ient=ient+1
       else
         ir(ient)=iPhi
         ic(ient)=iPhi-1
         M(ient)=-1d0/x%dx1(lx1)
         ient=ient+1
         ir(ient)=iPhi
         ic(ient)=iPhi
         M(ient)=1d0/x%dx1(lx1)
         b(iPhi)=Vmaxx1(ix2,ix3)
         ient=ient+1
       end if
     elseif (ix2==1) then      !LEFT BOUNDARY
       ir(ient)=iPhi
       ic(ient)=iPhi
       M(ient)=1.0
       b(iPhi)=Vminx2(ix1,ix3)
       ient=ient+1
     elseif (ix2==lx2) then    !RIGHT BOUNDARY
       ir(ient)=iPhi
       ic(ient)=iPhi
       M(ient)=1.0
       b(iPhi)=Vmaxx2(ix1,ix3)
       ient=ient+1
     elseif (ix3==1) then
       ir(ient)=iPhi
       ic(ient)=iPhi
       M(ient)=1.0
       b(iPhi)=Vminx3(ix1,ix2)
       ient=ient+1
     elseif (ix3==lx3) then
       ir(ient)=iPhi
       ic(ient)=iPhi
       M(ient)=1.0
       b(iPhi)=Vmaxx3(ix1,ix2)
       ient=ient+1
     else                      !INTERIOR
       !ix1,ix2,ix3-1 grid point in ix1,ix2,ix3 equation
       ir(ient)=iPhi
       ic(ient)=iPhi-lx1*lx2
       M(ient)=Bc(ix1,ix2,ix3)/x%dx3all(ix3)/x%dx3iall(ix3)-Ec(ix1,ix2,ix3)/(x%dx3all(ix3+1)+x%dx3all(ix3))
       ient=ient+1

       !ix1,ix2-1,ix3
       ir(ient)=iPhi
       ic(ient)=iPhi-lx1
       M(ient)=Ac(ix1,ix2,ix3)/x%dx2(ix2)/x%dx2i(ix2)-Dc(ix1,ix2,ix3)/(x%dx2(ix2+1)+x%dx2(ix2))
       ient=ient+1

       !ix1-1,ix2,ix3
       ir(ient)=iPhi
       ic(ient)=iPhi-1
       M(ient)=Cc(ix1,ix2,ix3)/x%dx1(ix1)/x%dx1i(ix1)-Fc(ix1,ix2,ix3)/(x%dx1(ix1+1)+x%dx1(ix1))
       ient=ient+1

       !ix1,ix2,ix3
       ir(ient)=iPhi
       ic(ient)=iPhi
       M(ient)=-1d0*Ac(ix1,ix2,ix3)*(1d0/x%dx2(ix2+1)/x%dx2i(ix2)+1d0/x%dx2(ix2)/x%dx2i(ix2))- &
                    Bc(ix1,ix2,ix3)*(1d0/x%dx3all(ix3+1)/x%dx3iall(ix3)+1d0/x%dx3all(ix3)/x%dx3iall(ix3))- &
                    Cc(ix1,ix2,ix3)*(1d0/x%dx1(ix1+1)/x%dx1i(ix1)+1d0/x%dx1(ix1)/x%dx1i(ix1))
       ient=ient+1

       !ix1+1,ix2,ix3
       ir(ient)=iPhi
       ic(ient)=iPhi+1
       M(ient)=Cc(ix1,ix2,ix3)/x%dx1(ix1+1)/x%dx1i(ix1)+Fc(ix1,ix2,ix3)/(x%dx1(ix1+1)+x%dx1(ix1))
       ient=ient+1

       !ix1,ix2+1,ix3
       ir(ient)=iPhi
       ic(ient)=iPhi+lx1
       M(ient)=Ac(ix1,ix2,ix3)/x%dx2(ix2+1)/x%dx2i(ix2)+Dc(ix1,ix2,ix3)/(x%dx2(ix2+1)+x%dx2(ix2))
       ient=ient+1

       !ix1,ix2,ix3+1
       ir(ient)=iPhi
       ic(ient)=iPhi+lx1*lx2
       M(ient)=Bc(ix1,ix2,ix3)/x%dx3all(ix3+1)/x%dx3iall(ix3)+Ec(ix1,ix2,ix3)/(x%dx3all(ix3+1)+x%dx3all(ix3))
       ient=ient+1
     end if
   end do
 end do
 end do
end if
if (debug) print *, 'Number of entries used:  ',ient-1

! INIT MUMPS

mumps_par%COMM = MPI_COMM_WORLD
mumps_par%JOB = -1
mumps_par%SYM = 0
mumps_par%PAR = 1

#if REALBITS==32
call SMUMPS(mumps_par)
#else
call DMUMPS(mumps_par)
#endif

call quiet_mumps(mumps_par)

!LOAD OUR PROBLEM
if ( myid==0 ) then
 mumps_par%N=lPhi
 mumps_par%NZ=lent
 allocate( mumps_par%IRN ( mumps_par%NZ ) )
 allocate( mumps_par%JCN ( mumps_par%NZ ) )
 allocate( mumps_par%A( mumps_par%NZ ) )
 allocate( mumps_par%RHS ( mumps_par%N  ) )
 mumps_par%IRN=ir
 mumps_par%JCN=ic
 mumps_par%A=M
 mumps_par%RHS=b
 deallocate(ir,ic,M,b)     !clear memory before solve begins!!!

 if (perflag .and. it/=1) then       !used cached permutation
   allocate(mumps_par%PERM_IN(mumps_par%N))
   mumps_par%PERM_IN=mumps_perm
   mumps_par%ICNTL(7)=1
 end if
end if

!SOLVE (ALL WORKERS NEED TO SEE THIS CALL)
mumps_par%JOB = 6
#if REALBITS==32
call SMUMPS(mumps_par)
#else
call DMUMPS(mumps_par)
#endif

!> check if Mumps error occurred
if (mumps_par%INFO(1) < 0 .or. mumps_par%INFOG(1) < 0) then
 write(stderr, *) 'Gemini:potential_mumps:elliptic3D_curv  MUMPS ERROR: details:'
 write(stderr, *) 'Mumps Error: INFO(1)',mumps_par%INFO(1),'INFO(2)',mumps_par%INFO(2)
 write(stderr, *) 'Mumps Error: INFOG(1)',mumps_par%INFOG(1),'INFOG(2)',mumps_par%INFOG(2)
 error stop
endif

!STORE PERMUTATION USED, SAVE RESULTS, CLEAN UP MUMPS ARRAYS
!(can save ~25% execution time and improves scaling with openmpi
! ~25% more going from 1-2 processors)
if ( myid==0 ) then
 if (debug) print *, 'Now organizing results...'

 if (perflag .and. it==1) then
   allocate(mumps_perm(mumps_par%N))     !we don't have a corresponding deallocate statement
   mumps_perm=mumps_par%SYM_PERM
 end if

 elliptic3D_curv=reshape(mumps_par%RHS,[lx1,lx2,lx3])

 if (debug) print *, 'Now attempting deallocations...'

 deallocate( mumps_par%IRN )
 deallocate( mumps_par%JCN )
 deallocate( mumps_par%A   )
 deallocate( mumps_par%RHS )
end if

mumps_par%JOB = -2
#if REALBITS==32
call SMUMPS(mumps_par)
#else
call DMUMPS(mumps_par)
#endif

end function elliptic3D_curv


program test_simpson_3d
        use numerical_integration
        implicit none
        integer, parameter :: dp = selected_real_kind(14)
        integer, parameter :: num_pts = 2
        integer :: i, j, k

        real(kind=dp), dimension(num_pts) :: x, y, z
        real(kind=dp) :: fvals(num_pts,num_pts,num_pts), z1(num_pts,num_pts), &
z2(num_pts), z3

        x =  [ (float(i)/num_pts, i=1,num_pts) ]
        y =  [ (float(i)/num_pts, i=1,num_pts) ]
        z =  [ (float(i)/num_pts, i=1,num_pts) ]

        do i=1, num_pts
                do j=1,num_pts
                        z1(i, j) =  f(x(i), y(j), z)
                end do
        end do

!        write(*,*) f(x, y, z)

contains

       elemental function f(x,y,z)
               implicit none
               real(kind=dp), intent(in) ::  x,y,z
               real(kind=dp) :: r, f

               r = sqrt(x*x + y*y + z*z)
               f = r

       end function f

end program test_simpson_3d


! Program showcasing the array reducing functions like ALL, COUNT and ANY

program arrayReduction

   real, dimension(3,2) :: a
   a = reshape( (/5,9,6,10,8,12/), (/3,2/) )

   Print *, all(a>5)
   Print *, any(a>5)
   Print *, count(a>5)
   Print *, all(a>=5 .and. a<10)

end program arrayReduction


PROGRAM MANYBODYHUBBARD

  USE ATOMIC_PROPERTIES
  USE TYPES
  USE SUBINTERFACE
  USE SUBINTERFACE_LAPACK
  USE FLOQUETINITINTERFACE
  USE ARRAYS

  IMPLICIT NONE
  TYPE(MODE),       DIMENSION(:),   ALLOCATABLE :: FIELDS
  TYPE(ATOM)                                       ID
  INTEGER,          DIMENSION(:),   ALLOCATABLE :: MODES_NUM
  INTEGER                                          TOTAL_FREQUENCIES,D_BARE_UP,D_BARE_DOWN,D_BARE
  INTEGER                                          INFO,m,INDEX0,r
  DOUBLE PRECISION, DIMENSION(:),   ALLOCATABLE :: ENERGY,E_FLOQUET,E_BARE
  COMPLEX*16,       DIMENSION(:,:), ALLOCATABLE :: H_J,H_U,U_F,H_BARE
  DOUBLE PRECISION, DIMENSION(:,:), ALLOCATABLE :: P_AVG
  INTEGER         , DIMENSION(:,:), ALLOCATABLE :: states_occ,STATES_OCC_UP,STATES_OCC_DOWN
  DOUBLE PRECISION                              :: T1,T2

  INTEGER index,N_SITES,i_,N_BODIES_UP, N_BODIES_DOWN,N_BODIES_SPINS(2),D_BARE_SPINS(2),M_
  DOUBLE PRECISION t,u,t_driv,omega,D_H

  OPEN(UNIT=3,FILE="ManybodyHubbard_Fermions.dat",ACTION="WRITE")

  INFO          = 0
  N_BODIES_UP   = 2 ! PARTICLES WITH SPIN UP
  N_BODIES_DOWN = 3 ! PARTICLES WITH SPIN DOWN
  N_SITES       = 5
  D_BARE_UP     = D_H(N_SITES,N_BODIES_UP,'F')   ! D_H EVALUATES THE NUMBER OF STATES
  D_BARE_DOWN   = D_H(N_SITES,N_BODIES_DOWN,'F')  ! D_H EVALUATES THE NUMBER OF STATES OF DO

  D_BARE = D_BARE_UP*D_BARE_DOWN ! TOTAL STATES
  write(*,*) '# Number of lattice sites:         ', N_SITES
  write(*,*) '# Number of part. with spin up:    ', N_BODIES_UP
  write(*,*) '# Number of part. with spin down:  ', N_BODIES_DOWN
  write(*,*) '# Number of states spin up         ', D_BARE_UP
  write(*,*) '# Number of states spin down       ', D_BARE_down
  write(*,*) '# Number of states Fermionic states', D_BARE
  write(*,*)
  write(*,*)
  CALL FLOQUETINIT(ID,'lattice',0.1d1*D_BARE,INFO)

  ALLOCATE(E_BARE(D_BARE))             ! STORE THE ENERGY SPECTRUM
  ALLOCATE(H_BARE(D_BARE,D_BARE))      ! STORE THE BARE HAMILTONIAN
  ALLOCATE(H_J(D_BARE,D_BARE))         ! STORE THE TUNNENING MATRIX
  ALLOCATE(H_U(D_BARE,D_BARE))         ! STORES THE ONSITE INTERACTION
  ALLOCATE(MODES_NUM(2))               ! NUMBER OF DRIVING MODES
  ALLOCATE(STATES_OCC_UP(D_BARE_UP,N_SITES)) ! STORES THE STATES USING OCCUPATION NUMBER SPIN UP
  ALLOCATE(STATES_OCC_DOWN(D_BARE_DOWN,N_SITES)) ! STORES THE STATES USING OCCUPATION NUMBER SPINS DOWN
  ALLOCATE(STATES_OCC(D_BARE_UP+D_BARE_DOWN,N_SITES)) ! STORES THE STATES USING OCCUPATION NUMBER ALL SPINS

  ! CREATE THE BASIS OF STATES FOR EACH SPIN ORIENTATION
  CALL Manybody_basis(D_BARE_UP  ,N_SITES,N_BODIES_UP,  'F',STATES_OCC_UP,INFO)
  CALL Manybody_basis(D_BARE_DOWN,N_SITES,N_BODIES_DOWN,'F',STATES_OCC_DOWN,INFO)
  !CALL write_matrix_int(states_occ_UP)
  !CALL write_matrix_int(states_occ_DOWN)

  D_BARE_SPINS(1) = D_BARE_UP
  D_BARE_SPINS(2) = D_BARE_DOWN

  N_BODIES_SPINS(1) = N_BODIES_UP
  N_BODIES_SPINS(2) = N_BODIES_DOWN

  STATES_OCC(1:D_BARE_UP,:)                       = STATES_OCC_UP
  STATES_OCC(D_BARE_UP+1:D_BARE_UP+D_BARE_DOWN,:) = STATES_OCC_DOWN

!  ! EVALUATE THE TUNNELING TERM OF THE HAMILTONIAN
  CALL Tunneling_F(D_BARE_SPINS,N_SITES,N_BODIES_SPINS,STATES_OCC,H_J,INFO)
  !CALL WRITE_MATRIX(ABS(H_J))

!  !! EVALUATE THE ON-SITE INTERACTION HAMILTONIAN
  CALL Onsite_twobody_F(D_BARE_SPINS,N_SITES,N_BODIES_SPINS,STATES_OCC,H_U,INFO)
  !CALL WRITE_MATRIX(abs(h_u))

  !NOW DEFINE THE DRIVING
  MODES_NUM(1) = 1 !(STATIC FIELD)
  MODES_NUM(2) = 1 !(DRIVING BY ONE HARMONIC)
!
  TOTAL_FREQUENCIES = SUM(MODES_NUM,1)
  ALLOCATE(FIELDS(TOTAL_FREQUENCIES))
  DO m=1,TOTAL_FREQUENCIES
     ALLOCATE(FIELDS(m)%V(D_BARE,D_BARE))
     FIELDS(m)%V = 0.0
  END DO

  ! HUBBARD MODEL PARAMETERS
  t      = 1.0
  u      = 0.5

  !DRIVING PARAMETERS
  t_driv = 0.2
  omega  = 1.0

  ! DEFINE THE TOTAL STATIC HAMILTONIAN USIING THE TUNNELING AND ON-SITE INTERACTIONS
  FIELDS(1)%V         = -t*H_J + u*H_U
  FIELDS(1)%omega     = 0
  FIELDS(1)%N_Floquet = 0

  ! DEFINE THE DRIVING TERM OF THE HAMILTONIAN.
  FIELDS(2)%V         = t_driv*H_J
  FIELDS(2)%omega     = omega
  FIELDS(2)%N_Floquet = 2

  write(*,*) '# Hubbard parameters (t,u):',t,u
  write(*,*) '# Driving parameters (t_driving,omega,N_Floquet):',t_driv,omega,FIELDS(2)%N_Floquet
  write(*,*) '# Floquet spectrum as a function of the driving frequency (first column))'

  ! EVALUATE THE SPECTRUM OF THE STATIC HAMILTONIAN
  H_BARE = FIELDS(1)%V
  CALL LAPACK_FULLEIGENVALUES(H_BARE,D_BARE,E_BARE,INFO)
  M_=32
  DO m=1,M_ ! SCAN DRIVING FREQUENCY
    FIELDS(2)%omega     = 0.1 + (m-1)*1.0/M_
    CALL MULTIMODEFLOQUETMATRIX(ID,size(modes_num,1),total_frequencies,MODES_NUM,FIELDS,INFO)
!  !CALL WRITE_MATRIX(ABS(H_FLOUET()))
!
    ALLOCATE(E_FLOQUET(SIZE(H_FLOQUET,1)))
    ALLOCATE(U_F(SIZE(H_FLOQUET,1),SIZE(H_FLOQUET,1)))
    E_FLOQUET = 0.0
!
    CALL LAPACK_FULLEIGENVALUES(H_FLOQUET,SIZE(H_FLOQUET,1),E_FLOQUET,INFO)
    U_F = H_FLOQUET ! FOURIER DECOMPOSITION OF THE STATES DRESSED BY MODE NUMBER
    WRITE(3,*) FIELDS(2)%omega,E_FLOQUET
    DEALLOCATE(H_FLOQUET)
    DEALLOCATE(E_FLOQUET)
    DEALLOCATE(U_F)

  END DO

END PROGRAM MANYBODYHUBBARD


      program similarity
* similarity solution of compressible laminar boundary layer
*
* everything is dimensional
*
************************************************************************
* Tue Feb 27 17:14:12 MST 2001

c f77 -o similarity -r8 similarity.f
c
c f77 -o similarity -r8 -g -DEBUG:div_check=3:subscript_check=ON
c -DEBUG:trap_uninitialized=ON:verbose_runtime=ON similarity.f
c
c ftnchek similarity.f

      parameter (ny=10000) ! integration steps
      parameter (no=  10) ! output every no profile point
      dimension f(0:ny),fp(0:ny),fpp(0:ny),g(0:ny),gp(0:ny)

c length of boundary layer
c Re= 17,25E-6  Re=pe/te/rgas
      re_x     =  300790.

      ue       = 0.11495E+03 ! [m/s]5
      te       = 2.73E+02 ! [K]
      pe       = 101325.0 ! [N/m^2]
      re       = 1.29 ! [Kg/m^3]
c p=rho*R*T
c.....for air:
C     rgas     = 0.28702224E+03 ! [J/(kgK)]
      rgas     = pe/te/re
c.....for pure nitrogen:
c     rgas     = 0.28812511E+03 ! [J/(kgK)]
      gam      = 1.4
      prandtl  = 0.72

* maximum number of iterations, abortion criterion
      irelax   = 100
      tol      = 1.03e-06
* maximum eta
      etamax   = 20.

      rhoe     = pe/(rgas*te)
      vise     = computemu(1.,te,1.)
      print *,'vise= ',vise
      cp       = gam*rgas/(gam-1.)
      rhovise  = rhoe*vise
      rrhovise = 1./rhovise
      ue2rhe   = ue**2/(cp*te)
      reue     = rhoe*ue
      he       = rgas/(gam-1.)*te+0.5*ue**2+pe/rhoe
      xi       = re_x*vise**2
      deta     = etamax/float(ny)
      fac1     = sqrt(2.*xi)/ue*deta
      fac2     = reue/vise

* adiabatic wall flat plate BCs
      f (0)    = 0.
      fp(0)    = 0.
      gp(0)    = 0.
* initial guess (incompressible, laminar BL, adiabatic wall temperature condition)
      g(0)     = 1.02
      fpp(0)   =  0.47
C     fpp(0)   = 0.5
C     g(0)     = 1+sqrt(prandtl)*ue**2/(gam*rgas*te)*0.5*(gam-1.)
* deltas
      dfpp     = fpp(0)*1.e-5
      dg       =   g(0)*1.e-5
      do i=1,irelax
         call integrat(f,fp,fpp,g,gp,vise,rgas,prandtl,
     &        rrhovise,te,pe,deta,ue2rhe,ny)
         fpe    = fp(ny)
         ge     =  g(ny)
         err=max(abs(fpe-1.),abs(ge-1.))
         print '(a,i5,a,e12.5)','it ',i,' err= ',err
         if (err.lt.tol) goto 1
C        if (i.eq.2) goto 1
         fpp(0) = fpp(0)+dfpp ! delta in fpp direction
         call integrat(f,fp,fpp,g,gp,vise,rgas,prandtl,
     &        rrhovise,te,pe,deta,ue2rhe,ny)
         fpefp  = fp(ny)
         gefp   =  g(ny)
         fpp(0) = fpp(0)-dfpp
         g(0)   = g(0)+dg     ! delta in g direction
         call integrat(f,fp,fpp,g,gp,vise,rgas,prandtl,
     &        rrhovise,te,pe,deta,ue2rhe,ny)
         fpegp  = fp(ny)
         gegp   =  g(ny)
         g(0)   = g(0)-dg
* new guess
         dfpdg   = (fpegp-fpe)/dg
         dfpdfpp = (fpefp-fpe)/dfpp
         dgdg    = ( gegp- ge)/dg
         dgdfpp  = ( gefp- ge)/dfpp
         rjac    = 1./(dfpdg*dgdfpp-dfpdfpp*dgdg)
         ddg     = rjac*( dgdfpp*(1.-fpe)-dfpdfpp*(1.-ge))
         ddfpp   = rjac*(-dgdg  *(1.-fpe)+dfpdg  *(1.-ge))
         fpp(0)  = fpp(0)+ddfpp
         g(0)    = g(0)  +ddg
         print *,'g(0),fpp(0)',g(0),fpp(0)
      enddo
      print '(a)','no convergence in simlarity'
      stop
 1    continue
      print '(a)','analytical BL solution to similarity.dat'
      open(99,file='Ma5_chris.dat',status='unknown',
     & form='formatted')
      print '(a)','output format: y,eta,p,rho,T,u,dudy'
      print '(a)','               1   2 3   4 5 6'
      write(99,'(A)') 'TITLE="BOUNDARY-LAYER"'
      write(99,'(A)') 'VARIABLES = x,y,z , Eta , rho , T, u, v'
      write(99,'(A)') 'ZONE T="T",I= 1,J=12,K=1'
      eta=0.
      y=0.
      adelta1 = 0.
      atheta  = 0.
      adelta3 = 0.
      addelta = 0.
      atw=g(0)*te
      arw=pe/(rgas*atw)
      hw=rgas/(gam-1.)*atw+pe/arw
      uulast=-1.e30
      do n=0,ny
         uu=fp(n)*ue
         if (abs((uu-uulast)/uu).le.tol) goto 2
         uulast=uu
         tt=g(n)*te
         rho=pe/(rgas*tt)
         if (mod(n,no).eq.0) then
          write(99,'(8(e12.5))')1.0,y,1.0,eta,rho,tt,uu
         endif
         eta=eta+deta
         dy=fac1/rho
         y=y+dy
         hh=rgas/(gam-1.)*tt+0.5*uu**2+pe/rho
         rruu=rho*uu
         adelta1 = adelta1 +           (1.-rruu/reue    )*dy
         atheta  = atheta  + rruu/reue*(1.-  uu/  ue    )*dy
         adelta3 = adelta3 + rruu/reue*(1.- (uu/  ue)**2)*dy
         addelta = addelta + rruu/reue*((hh-he)/(hw-he) )*dy
      enddo
 2    continue
      close(99)
      readelta1 = fac2*adelta1
      reatheta  = fac2*atheta
      readelta3 = fac2*adelta3
      readdelta = fac2*addelta
      avisw     = vise*computemu(atw,te,vise)
      acf=sqrt(2.)*arw*avisw/(rhovise*sqrt(re_x))*fpp(0)
      print '(a,e12.5)','T_w [K]   = ',atw
      print '(a,e12.5)','c_F       = ',acf
      print '(a,e12.5)','Re_delta1 = ',readelta1
      print '(a,e12.5)','Re_theta  = ',reatheta
      print '(a,e12.5)','Re_delta3 = ',readelta3
      print '(a,e12.5)','Re_Delta  = ',readdelta
      print '(a,e12.5)','H         = ',readelta1/reatheta
      print '(a,e12.5)','H_32      = ',readelta3/reatheta
      print '(a,e12.5)','deta      = ',deta

      end

      subroutine integrat(f,fp,fpp,g,gp,vise,rgas,prandtl,
     &     rrhovise,te,pe,deta,ue2rhe,ny)
      dimension f(0:ny),fp(0:ny),fpp(0:ny),g(0:ny),gp(0:ny)
      real p1,p2,p3

      p1=deta/24.
      p2=13.*p1
      p3=deta/3.

      t    = te*g(0)
      rho  = pe/(rgas*t)
      vis  = vise*computemu(t/te,te,vise)
      c    = rho*vis*rrhovise
      rc   = 1./c
      cold = c
      dcde = (c - cold)/deta
      rhs    = rc*(fpp(0)*dcde + f(0)*fpp(0))
      fpp(1) = fpp(0) - deta*rhs
      rhs    = rc*( gp(0)*dcde + prandtl*(f(0)*gp(0) +
     &     c*ue2rhe*fpp(0)**2) )
      gp(1)  = gp(0)  - deta*rhs
      fp(1)=fp(0)+p1*(9.*fpp(0)+19.*fpp(1)-5.*fpp(2)+fpp(3))
      f (1)=f (0)+p1*(9.*fp (0)+19.*fp (1)-5.*fp (2)+fp (3))
      g (1)=g (0)+p1*(9.*gp (0)+19.*gp (1)-5.*gp (2)+gp (3))
      do n=2,ny-1
         t    = te*g(n-1)
         rho  = pe/(rgas*t)
         vis  = vise*computemu(t/te,te,vise)
         c    = rho*vis*rrhovise
         rc   = 1./c
         dcde = (c - cold)/deta
         cold = c
         rhs    = rc*(fpp(n-1)*dcde + f(n-1)*fpp(n-1))
         fpp(n) = fpp(n-1) - deta*rhs
         rhs    = rc*( gp(n-1)*dcde + prandtl*(f(n-1)*gp(n-1) +
     &        c*ue2rhe*fpp(n-1)**2) )
         gp(n)  = gp(n-1)  - deta*rhs
         fp(n)  = fp(n-1) + deta*fpp(n)
         f (n)  = f (n-1) + deta*fp (n)
         g (n)  = g (n-1) + deta*gp (n)
      enddo
      t    = te*g(ny-1)
      rho  = pe/(rgas*t)
      vis  = vise*computemu(t/te,te,vise)
      c    = rho*vis*rrhovise
      rc   = 1./c
      dcde = (c - cold)/deta
      cold = c
      rhs    = rc*(fpp(ny-1)*dcde + f(ny-1)*fpp(ny-1))
      fpp(ny) = fpp(ny-1) - deta*rhs
      rhs    = rc*( gp(ny-1)*dcde + prandtl*(f(ny-1)*gp(ny-1) +
     &     c*ue2rhe*fpp(ny-1)**2) )
      gp(ny)  = gp(ny-1)  - deta*rhs
      fp(ny)=fp(ny-2)+p3*(fpp(ny-2)+4.*fpp(ny-1)+fpp(ny))
      f (ny)=f (ny-2)+p3*(fp (ny-2)+4.*fp (ny-1)+fp (ny))
      g (ny)=g (ny-2)+p3*(gp (ny-2)+4.*gp (ny-1)+gp (ny))

      end

      function computemu(temp,temp_0,rmu_0)

      parameter (t1=40.,t2=110.4,c1=6.80689413e-8,c2=14.458e-7)

      t_dim=temp*temp_0

      if (t_dim.gt.t2) then
         computemu=c2*sqrt(t_dim)*t_dim/(t_dim+t2)
      elseif (t_dim.gt.t1) then
         computemu=c1*t_dim
      else
         computemu=c1*t1
      endif

      computemu=computemu/rmu_0

      end


!------------------------------------------------------------
!------------------------------------------------------------
!     pla :     Plant's Model of Bursting Nerve Cells
!------------------------------------------------------------
!------------------------------------------------------------

      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 VI,VK,VL,VCa,gK,gL,Kp,Kc,rho,txT,zeta,gi,gP,gT
      DOUBLE PRECISION V,xT,xK,yI,c,a,b,Vs,am,ah,an,bm,bh,bn,si,sK
      DOUBLE PRECISION txK,tyI,zI,sT

       VI=30
       VK=-75
       VL=-40
       VCa=140
       gK=0.3
       gL=0.003
       Kp=0.5
       Kc=0.0085
       rho=0.0003
       txT=235
       zeta=1

       gI=PAR(1)
       gP=PAR(2)
       gT=PAR(3)

       V =U(1)
       xT=U(2)
       xK=U(3)
       yI=U(4)
       c =U(5)

       a=127/(VI-VK)
       b=(115*VK+12*VI)/(VI-VK)
       Vs=a*V-b

       am=0.1*(50-Vs)/(DEXP((50-Vs)/10)-1)
       ah=0.07*DEXP((25-Vs)/20)
       an=0.01*(55-Vs)/(DEXP((55-Vs)/10)-1)
       bm=4*DEXP((25-Vs)/18)
       bh=1./(DEXP((55-Vs)/10)+1)
       bn=0.125*DEXP((45-Vs)/80)

       sI=am/(am+bm)
       sK=an/(an+bn)
       txK=12.5/(an+bn)
       tyI=12.5/(ah+bh)
       zI=ah/(ah+bh)
       sT=1./(DEXP(0.15*(-50-V))+1)

       F(1)=  (gI*sI**3*yI + gT*xT) * (VI-V)                            &
            + (gK*xK**4 + gP*c/(Kp+c)) * (VK-V)                         &
            + gL * (VL-V)
       F(2)=  (sT-xT) / (txT*zeta)
       F(3)=  (sK-xK) / (txK*zeta)
       F(4)=  (zI-yI) / (tyI*zeta)
       F(5)=  rho * (Kc*xT*(VCa-V) - c)

      END SUBROUTINE FUNC

      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 gI,gP,gT

       gI=50.
       gP=0.03
       gT=0.01

       PAR(1)=gI
       PAR(2)=gP
       PAR(3)=gT

       U(1)=-2.329601E+00
       U(2)= 9.992162E-01
       U(3)= 7.373314E-01
       U(4)= 6.135948E-03
       U(5)= 1.208853E+00

      END SUBROUTINE STPNT

      SUBROUTINE BCND
      END SUBROUTINE BCND

      SUBROUTINE ICND
      END SUBROUTINE ICND

      SUBROUTINE FOPT
      END SUBROUTINE FOPT

      SUBROUTINE PVLS
      END SUBROUTINE PVLS


! ###########################################################
! #                                                         #
! #  Author :      Robert. J. D. Spurr                      #
! #                                                         #
! #  Address :     RT Solutions, Inc.                       #
! #                9 Channing Street                        #
! #                Cambridge, MA 02138, USA                 #
! #                                                         #
! #  Tel:          (617) 492 1183                           #
! #  Email :        rtsolutions@verizon.net                 #
! #                                                         #
! #  This Version :   3.7 F90                               #
! #  Release Date :   June 2014                             #
! #                                                         #
! #       NEW: THERMAL SUPPLEMENT INCLUDED     (3.2)        #
! #       NEW: OUTGOING SPHERICITY CORRECTION  (3.2)        #
! #       NEW: TOTAL COLUMN JACOBIANS          (3.3)        #
! #       VLIDORT COMPATIBILITY                (3.4)        #
! #       THREADED/OPTIMIZED F90 code          (3.5)        #
! #       EXTERNAL SS / NEW I/O STRUCTURES     (3.6)        #
! #                                                         #
! #       Surface-leaving, BRDF Albedo-scaling     (3.7)    #
! #       Taylor series, BBF Jacobians, ThreadSafe (3.7)    #
! #                                                         #
! ###########################################################

!    #####################################################
!    #                                                   #
!    #   This Version of LIDORT comes with a GNU-style   #
!    #   license. Please read the license carefully.     #
!    #                                                   #
!    #####################################################

! ###############################################################
! #                                                             #
! # Auxiliary subroutines for Surface-Leaving                   #
! #                                                             #
! #               * Sleave_GAULEG                               #
! #               * HOMEGROWN_ERRFUNC                           #
! #                                                             #
! ###############################################################

      MODULE sleave_sup_aux_m

      PUBLIC
      CONTAINS

SUBROUTINE Sleave_GAULEG(X1,X2,X,W,N)

      IMPLICIT NONE
      INTEGER  , parameter:: fpk = SELECTED_REAL_KIND(15)

      INTEGER  , intent(in)  :: N
      REAL(fpk), intent(in)  :: X1, X2
      REAL(fpk), intent(out) :: X(N),W(N)

      INTEGER     :: I, M, J
      REAL(fpk)   :: XM,XL,P1,P2,P3,PP,Z,Z1
      REAL(fpk), PARAMETER :: EPS = 3.0D-14

      M=(N+1)/2
      XM=0.5D0*(X2+X1)
      XL=0.5D0*(X2-X1)

      DO I=1,M
            Z=DCOS(3.141592654D0*(I-.25D0)/(N+.5D0))
            Z1 = 0.0d0
            DO WHILE (DABS(Z-Z1).GT.EPS)
                  P1=1.D0
                  P2=0.D0
                  DO J=1,N
                        P3=P2
                        P2=P1
                        P1=((2.D0*J-1.D0)*Z*P2-(J-1.D0)*P3)/J
                  ENDDO
                  PP=N*(Z*P1-P2)/(Z*Z-1.D0)
                  Z1=Z
                  Z=Z1-P1/PP
            ENDDO
            X(I)=XM-XL*Z
            X(N+1-I)=XM+XL*Z
            W(I)=2.D0*XL/((1.D0-Z*Z)*PP*PP)
            W(N+1-I)=W(I)
      ENDDO
      RETURN
      END SUBROUTINE Sleave_GAULEG

!

      SUBROUTINE HOMEGROWN_ERRFUNC ( X )

      IMPLICIT NONE

      integer, parameter :: fpk = SELECTED_REAL_KIND(15)

      REAL(fpk), intent(inout) :: x

! Returns the complementary error function erfc(x) with fractional error
! everywhere less than 1.2 * 10^7.

      REAL(fpk) :: t,z,xin

      z = abs(x) ; xin = x
      t = 1.d0/(1.d0+0.5d0*z)
      x = t*dexp(-z*z-1.26551223d0+t*(1.00002368d0+t*(.37409196d0+ &
              t*(.09678418d0+t*(-.18628806d0+t*(.27886807d0+t* &
              (-1.13520398d0+t*(1.48851587d0+t*(-.82215223d0+t* &
              .17087277d0)))))))))
      if ( xin .lt. 0.d0 ) x = 2.d0 - x

      return
      END SUBROUTINE HOMEGROWN_ERRFUNC

!  End module

      END MODULE sleave_sup_aux_m


      SUBROUTINE sla_PREC (EP0, EP1, RMATP)
*+
*     - - - - -
*      P R E C
*     - - - - -
*
*  Form the matrix of precession between two epochs (IAU 1976, FK5)
*  (double precision)
*
*  Given:
*     EP0    dp         beginning epoch
*     EP1    dp         ending epoch
*
*  Returned:
*     RMATP  dp(3,3)    precession matrix
*
*  Notes:
*
*     1)  The epochs are TDB (loosely ET) Julian epochs.
*
*     2)  The matrix is in the sense   V(EP1)  =  RMATP * V(EP0)
*
*     3)  Though the matrix method itself is rigorous, the precession
*         angles are expressed through canonical polynomials which are
*         valid only for a limited time span.  There are also known
*         errors in the IAU precession rate.  The absolute accuracy
*         of the present formulation is better than 0.1 arcsec from
*         1960AD to 2040AD, better than 1 arcsec from 1640AD to 2360AD,
*         and remains below 3 arcsec for the whole of the period
*         500BC to 3000AD.  The errors exceed 10 arcsec outside the
*         range 1200BC to 3900AD, exceed 100 arcsec outside 4200BC to
*         5600AD and exceed 1000 arcsec outside 6800BC to 8200AD.
*         The SLALIB routine sla_PRECL implements a more elaborate
*         model which is suitable for problems spanning several
*         thousand years.
*
*  References:
*     Lieske,J.H., 1979. Astron.Astrophys.,73,282.
*      equations (6) & (7), p283.
*     Kaplan,G.H., 1981. USNO circular no. 163, pA2.
*
*  Called:  sla_DEULER
*
*  P.T.Wallace   Starlink   23 August 1996
*
*  Copyright (C) 1996 Rutherford Appleton Laboratory
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program 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 General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 59 Temple Place, Suite 330,
*    Boston, MA  02111-1307  USA
*
*-

      IMPLICIT NONE

      DOUBLE PRECISION EP0,EP1,RMATP(3,3)

*  Arc seconds to radians
      DOUBLE PRECISION AS2R
      PARAMETER (AS2R=0.484813681109535994D-5)

      DOUBLE PRECISION T0,T,TAS2R,W,ZETA,Z,THETA

*  Interval between basic epoch J2000.0 and beginning epoch (JC)
      T0 = (EP0-2000D0)/100D0

*  Interval over which precession required (JC)
      T = (EP1-EP0)/100D0

*  Euler angles
      TAS2R = T*AS2R
      W = 2306.2181D0+(1.39656D0-0.000139D0*T0)*T0

      ZETA = (W+((0.30188D0-0.000344D0*T0)+0.017998D0*T)*T)*TAS2R
      Z = (W+((1.09468D0+0.000066D0*T0)+0.018203D0*T)*T)*TAS2R
      THETA = ((2004.3109D0+(-0.85330D0-0.000217D0*T0)*T0)
     :        +((-0.42665D0-0.000217D0*T0)-0.041833D0*T)*T)*TAS2R

*  Rotation matrix
      CALL sla_DEULER('ZYZ',-ZETA,THETA,-Z,RMATP)

      END