!*==cgeqrf.f90  processed by SPAG 7.51RB at 20:37 on  3 Mar 2022
!> \brief \b CGEQRF VARIANT: left-looking Level 3 BLAS version of the algorithm.
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!  Definition:
!  ===========
!
!       SUBROUTINE CGEQRF ( M, N, A, LDA, TAU, WORK, LWORK, INFO )
!
!       .. Scalar Arguments ..
!       INTEGER            INFO, LDA, LWORK, M, N
!       ..
!       .. Array Arguments ..
!       COMPLEX            A( LDA, * ), TAU( * ), WORK( * )
!       ..
!
!  Purpose
!  =======
!
!>\details \b Purpose:
!>\verbatim
!>
!> CGEQRF computes a QR factorization of a real M-by-N matrix A:
!> A = Q * R.
!>
!> This is the left-looking Level 3 BLAS version of the algorithm.
!>
!>\endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] M
!> \verbatim
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!> \endverbatim
!>
!> \param[in,out] A
!> \verbatim
!>          A is COMPLEX array, dimension (LDA,N)
!>          On entry, the M-by-N matrix A.
!>          On exit, the elements on and above the diagonal of the array
!>          contain the min(M,N)-by-N upper trapezoidal matrix R (R is
!>          upper triangular if m >= n); the elements below the diagonal,
!>          with the array TAU, represent the orthogonal matrix Q as a
!>          product of min(m,n) elementary reflectors (see Further
!>          Details).
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!> \endverbatim
!>
!> \param[out] TAU
!> \verbatim
!>          TAU is COMPLEX array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors (see Further
!>          Details).
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          WORK is COMPLEX array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!> \endverbatim
!>
!> \param[in] LWORK
!> \verbatim
!>          LWORK is INTEGER
!> \endverbatim
!> \verbatim
!>          The dimension of the array WORK. The dimension can be divided into three parts.
!> \endverbatim
!> \verbatim
!>          1) The part for the triangular factor T. If the very last T is not bigger
!>             than any of the rest, then this part is NB x ceiling(K/NB), otherwise,
!>             NB x (K-NT), where K = min(M,N) and NT is the dimension of the very last T
!> \endverbatim
!> \verbatim
!>          2) The part for the very last T when T is bigger than any of the rest T.
!>             The size of this part is NT x NT, where NT = K - ceiling ((K-NX)/NB) x NB,
!>             where K = min(M,N), NX is calculated by
!>                   NX = MAX( 0, ILAENV( 3, 'CGEQRF', ' ', M, N, -1, -1 ) )
!> \endverbatim
!> \verbatim
!>          3) The part for dlarfb is of size max((N-M)*K, (N-M)*NB, K*NB, NB*NB)
!> \endverbatim
!> \verbatim
!>          So LWORK = part1 + part2 + part3
!> \endverbatim
!> \verbatim
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!> \endverbatim
!>
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup variantsGEcomputational
!
!  Further Details
!  ===============
!>\details \b Further \b Details
!> \verbatim
!>
!>  The matrix Q is represented as a product of elementary reflectors
!>
!>     Q = H(1) H(2) . . . H(k), where k = min(m,n).
!>
!>  Each H(i) has the form
!>
!>     H(i) = I - tau * v * v'
!>
!>  where tau is a real scalar, and v is a real vector with
!>  v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),
!>  and tau in TAU(i).
!>
!> \endverbatim
!>
!  =====================================================================
      SUBROUTINE CGEQRF(M,N,A,Lda,Tau,Work,Lwork,Info)
      IMPLICIT NONE
!*--CGEQRF153
!
!  -- LAPACK computational routine (version 3.1) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      INTEGER Info , Lda , Lwork , M , N
!     ..
!     .. Array Arguments ..
      COMPLEX A(Lda,*) , Tau(*) , Work(*)
!     ..
!
!  =====================================================================
!
!     .. Local Scalars ..
      LOGICAL lquery
      INTEGER i , ib , iinfo , iws , j , k , lwkopt , nb , nbmin , nx , &
     &        lbwork , nt , llwork
!     ..
!     .. External Subroutines ..
      EXTERNAL CGEQR2 , CLARFB , CLARFT , XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC MAX , MIN
!     ..
!     .. External Functions ..
      INTEGER ILAENV
      REAL SCEIL
      EXTERNAL ILAENV , SCEIL
!     ..
!     .. Executable Statements ..

      Info = 0
      nbmin = 2
      nx = 0
      iws = N
      k = MIN(M,N)
      nb = ILAENV(1,'CGEQRF',' ',M,N,-1,-1)

!
!        Determine when to cross over from blocked to unblocked code.
!
      IF ( nb>1 .AND. nb<k ) nx = MAX(0,ILAENV(3,'CGEQRF',' ',M,N,-1,-1)&
     &                            )
!
!     Get NT, the size of the very last T, which is the left-over from in-between K-NX and K to K, eg.:
!
!            NB=3     2NB=6       K=10
!            |        |           |
!      1--2--3--4--5--6--7--8--9--10
!                  |     \________/
!               K-NX=5      NT=4
!
!     So here 4 x 4 is the last T stored in the workspace
!
      nt = k - SCEIL(REAL(k-nx)/REAL(nb))*nb

!
!     optimal workspace = space for dlarfb + space for normal T's + space for the last T
!
      llwork = MAX(MAX((N-M)*k,(N-M)*nb),MAX(k*nb,nb*nb))
      llwork = SCEIL(REAL(llwork)/REAL(nb))

      IF ( nt>nb ) THEN

         lbwork = k - nt
!
!         Optimal workspace for dlarfb = MAX(1,N)*NT
!
         lwkopt = (lbwork+llwork)*nb
         Work(1) = (lwkopt+nt*nt)

      ELSE

         lbwork = SCEIL(REAL(k)/REAL(nb))*nb
         lwkopt = (lbwork+llwork-nb)*nb
         Work(1) = lwkopt

      ENDIF

!
!     Test the input arguments
!
      lquery = (Lwork==-1)
      IF ( M<0 ) THEN
         Info = -1
      ELSEIF ( N<0 ) THEN
         Info = -2
      ELSEIF ( Lda<MAX(1,M) ) THEN
         Info = -4
      ELSEIF ( Lwork<MAX(1,N) .AND. .NOT.lquery ) THEN
         Info = -7
      ENDIF
      IF ( Info/=0 ) THEN
         CALL XERBLA('CGEQRF',-Info)
         RETURN
      ELSEIF ( lquery ) THEN
         RETURN
      ENDIF
!
!     Quick return if possible
!
      IF ( k==0 ) THEN
         Work(1) = 1
         RETURN
      ENDIF
!
      IF ( nb>1 .AND. nb<k ) THEN

         IF ( nx<k ) THEN
!
!           Determine if workspace is large enough for blocked code.
!
            IF ( nt<=nb ) THEN
               iws = (lbwork+llwork-nb)*nb
            ELSE
               iws = (lbwork+llwork)*nb + nt*nt
            ENDIF

            IF ( Lwork<iws ) THEN
!
!              Not enough workspace to use optimal NB:  reduce NB and
!              determine the minimum value of NB.
!
               IF ( nt<=nb ) THEN
                  nb = Lwork/(llwork+(lbwork-nb))
               ELSE
                  nb = (Lwork-nt*nt)/(lbwork+llwork)
               ENDIF

               nbmin = MAX(2,ILAENV(2,'CGEQRF',' ',M,N,-1,-1))
            ENDIF
         ENDIF
      ENDIF
!
      IF ( nb>=nbmin .AND. nb<k .AND. nx<k ) THEN
!
!        Use blocked code initially
!
         DO i = 1 , k - nx , nb
            ib = MIN(k-i+1,nb)
!
!           Update the current column using old T's
!
            DO j = 1 , i - nb , nb
!
!              Apply H' to A(J:M,I:I+IB-1) from the left
!
               CALL CLARFB('Left','Transpose','Forward','Columnwise',   &
     &                     M-j+1,ib,nb,A(j,j),Lda,Work(j),lbwork,A(j,i),&
     &                     Lda,Work(lbwork*nb+nt*nt+1),ib)

            ENDDO
!
!           Compute the QR factorization of the current block
!           A(I:M,I:I+IB-1)
!
            CALL CGEQR2(M-i+1,ib,A(i,i),Lda,Tau(i),                     &
     &                  Work(lbwork*nb+nt*nt+1),iinfo)

!
!              Form the triangular factor of the block reflector
!              H = H(i) H(i+1) . . . H(i+ib-1)
!
!
            IF ( i+ib<=N ) CALL CLARFT('Forward','Columnwise',M-i+1,ib, &
     &                                 A(i,i),Lda,Tau(i),Work(i),lbwork)
         ENDDO
      ELSE
         i = 1
      ENDIF
!
!     Use unblocked code to factor the last or only block.
!
      IF ( i<=k ) THEN

         IF ( i/=1 ) THEN

            DO j = 1 , i - nb , nb
!
!                Apply H' to A(J:M,I:K) from the left
!
               CALL CLARFB('Left','Transpose','Forward','Columnwise',   &
     &                     M-j+1,k-i+1,nb,A(j,j),Lda,Work(j),lbwork,    &
     &                     A(j,i),Lda,Work(lbwork*nb+nt*nt+1),k-i+1)
            ENDDO

            CALL CGEQR2(M-i+1,k-i+1,A(i,i),Lda,Tau(i),                  &
     &                  Work(lbwork*nb+nt*nt+1),iinfo)

         ELSE
!
!        Use unblocked code to factor the last or only block.
!
            CALL CGEQR2(M-i+1,N-i+1,A(i,i),Lda,Tau(i),Work,iinfo)

         ENDIF
      ENDIF

!
!     Apply update to the column M+1:N when N > M
!
      IF ( M<N .AND. i/=1 ) THEN
!
!         Form the last triangular factor of the block reflector
!         H = H(i) H(i+1) . . . H(i+ib-1)
!
         IF ( nt<=nb ) THEN
            CALL CLARFT('Forward','Columnwise',M-i+1,k-i+1,A(i,i),Lda,  &
     &                  Tau(i),Work(i),lbwork)
         ELSE
            CALL CLARFT('Forward','Columnwise',M-i+1,k-i+1,A(i,i),Lda,  &
     &                  Tau(i),Work(lbwork*nb+1),nt)
         ENDIF

!
!         Apply H' to A(1:M,M+1:N) from the left
!
         DO j = 1 , k - nx , nb

            ib = MIN(k-j+1,nb)

            CALL CLARFB('Left','Transpose','Forward','Columnwise',M-j+1,&
     &                  N-M,ib,A(j,j),Lda,Work(j),lbwork,A(j,M+1),Lda,  &
     &                  Work(lbwork*nb+nt*nt+1),N-M)

         ENDDO

         IF ( nt<=nb ) THEN
            CALL CLARFB('Left','Transpose','Forward','Columnwise',M-j+1,&
     &                  N-M,k-j+1,A(j,j),Lda,Work(j),lbwork,A(j,M+1),   &
     &                  Lda,Work(lbwork*nb+nt*nt+1),N-M)
         ELSE
            CALL CLARFB('Left','Transpose','Forward','Columnwise',M-j+1,&
     &                  N-M,k-j+1,A(j,j),Lda,Work(lbwork*nb+1),nt,      &
     &                  A(j,M+1),Lda,Work(lbwork*nb+nt*nt+1),N-M)
         ENDIF

      ENDIF

      Work(1) = iws
!
!     End of CGEQRF
!
      END SUBROUTINE CGEQRF


      real function pot(s,z)

      include 'commonblocks'

      real p

      r=sqrt(s*s+z*z)

      if(r.eq.0.) then
         pot = apot(1,0)/sqrt(4.*pi)
         return
      endif
      ihi=int(r/dr)+1
      if(ihi.lt.1) ihi=1
      if (ihi.gt.nr) ihi=nr
      r1=dr*(ihi-1)
      r2=dr*ihi
      t=(r-r1)/(r2-r1)
      tm1 = 1.0 - t
      if (r.eq.0.) then
         lmaxx=0
         costheta=0
      else
         costheta=z/r
         lmaxx=lmax
      endif
      p=0
      do l=lmaxx,0,-2
         p=p+plgndr1(l,costheta)*plcon(l)*
     +        (t*apot(l/2+1,ihi)+ tm1*apot(l/2+1,ihi-1))
      enddo
      if( idiskflag .eq. 1 ) then
         p = p + appdiskpot(s,z)
      endif
      pot=p

      return
      end

      SUBROUTINE polint(xa,ya,n,x,y,dy)
      INTEGER n,NMAX
      REAL dy,x,y,xa(n),ya(n)
      PARAMETER (NMAX=10)
      INTEGER i,m,ns
      REAL den,dif,dift,ho,hp,w,c(NMAX),d(NMAX)
      ns=1
      dif=abs(x-xa(1))
      do 11 i=1,n
        dift=abs(x-xa(i))
        if (dift.lt.dif) then
          ns=i
          dif=dift
        endif
        c(i)=ya(i)
        d(i)=ya(i)
11    continue
      y=ya(ns)
      ns=ns-1
      do 13 m=1,n-1
        do 12 i=1,n-m
          ho=xa(i)-x
          hp=xa(i+m)-x
          w=c(i+1)-d(i)
          den=ho-hp
          if(den.eq.0.)pause 'failure in polint'
          den=w/den
          d(i)=hp*den
          c(i)=ho*den
12      continue
        if (2*ns.lt.n-m)then
          dy=c(ns+1)
        else
          dy=d(ns)
          ns=ns-1
        endif
        y=y+dy
13    continue
      return
      END


module multigrid_levels
use kind_parameters
 implicit none

 type :: level_tag

 integer :: nx
 integer :: ny

 ! Property variables

 real(kind=dp), dimension(:,:), pointer :: rho, mu, kcond, cp, gammat, rho_uf, rho_vf, mu_uf, mu_vf, gammat_uf, gammat_vf

 ! Velocity variables

 real(kind=dp), dimension(:,:), pointer :: u, v, uf, vf
 real(kind=dp), dimension(:,:), pointer :: ap, aw, ae, as, an, bu, bv, b, d_u, d_v, fu, fv, auf_bar, avf_bar, f_uf, f_vf, su, sv, s_uf, s_vf
 real(kind=dp), dimension(:,:), pointer :: resu, resv, res_uf, res_vf

 ! Pressure correction variables

 real(kind=dp), dimension(:,:), pointer :: p, pc, p_uf, p_vf, pc_uf, pc_vf
 real(kind=dp), dimension(:,:), pointer :: app, awp, aep, asp, anp, bp, fp
 real(kind=dp), dimension(:,:), pointer :: respc

  ! Temperature variables

! real(kind=dp), dimension(:,:), pointer :: t
! real(kind=dp), dimension(:,:), pointer :: apt, awt, aet, ast, ant, bt, ft
! real(kind=dp), dimension(:,:), pointer :: rest

 ! For storing previous mg iteration
 real(kind=dp), dimension(:,:), pointer :: uprev, vprev, pcprev, ufprev, vfprev

 ! Geometry variables

 real(kind=dp), dimension(:), pointer :: dx, dy
 real(kind=dp), dimension(:), pointer :: delx, dely
 real(kind=dp), dimension(:), pointer:: xp, yp

! Variables for unsteady calculations

 real(kind=dp), dimension(:,:), pointer:: ap_zero, apt_zero, u0, v0, t0, auf_zero, avf_zero, uf0, vf0, f_uvel, f_vvel

 ! Other variables

 real(kind=dp), dimension(:,:), pointer :: error_u, error_v, error_uf, error_vf

! For parallel variables

integer:: xi, xf

!Variables for level set method
real(kind=dp), dimension(:,:), pointer:: phi_x, phi_y, nv_x, nv_y, grad_phi, lambda, H_phi
real(kind=dp), dimension(:,:), pointer:: T, Tprev, T_exact, T_RK1, T_RK2, alpha_x, alpha_y, phi_sign, kappa, error_check

 end type level_tag

 integer:: num_level
 type(level_tag), dimension(:), allocatable:: mg_level

end module multigrid_levels


      SUBROUTINE FIT_X2WAVE(IND,X,NP,PARAM,Y1,DERIV)
*
*  Module number:
*
*  Module name: FIT_X2WAVE
*
*  Keyphrase:
*  ----------
*       user defined function fit fitting
*
*  Description:
*  ------------
*
*
*  FORTRAN name: fit_x2wave.for
*
*  Keywords of accessed files and tables:
*  --------------------------------------
*
*
*  Subroutines Called:
*  -------------------
*
*
*  History:
*  --------
*  Version      Date        Author          Description
*       1       Nov 01  A. Alexov       Copy of user03.for from midas
*------------------------------------------------------------------------------
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C.VERSION: 1.0  ESO-FORTRAN Conversion, AA  16:03 - 20 DEC 1987
C.LANGUAGE: F77+ESOext
C
C.AUTHOR: M.R. Rosa (STECF)
C--------------------------------------------------------------
C The final FOS dispersion tan(SIN) including S distortion
C saved as tfb_user03.for
C
C
C Dependent: observed: y1 (diode position [0:512])
C Independent:        x  (lambda)
C
C Dispersion relation for FOS:
C
C Inverse:
C Full            y-y0 = f(lambda) ; y0 is optical axis on diode array
C Grating only    z-z0 = g(lambda) ; z0 is optical axis on cathode
C Digicon         y-y0 = d(z-z0)
C
C Forward:
C Full            lambda = f'(y-y0) ; y0 is optical axis on diode array
C Grating only    lambda = g'(z-z0) ; z0 is optical axis on cathode
C Digicon         z-z0   = d'(y-y0)
C
C 1)
C SIN for dispersion relations lambda = f(y); a=gra.const.=m/s
C c = half config angle; b = grating angle; d = y0; e=focal l.
C
C Inverse:  z = d + e * tan( b+c + arcsin (lambda/a - sin(b-c))]
C  + S-Distortion:
C   In extenso:   y-y0 = p(z-z0-r0) + q*abs(tan(s*(z-z0-r0))
C   Simplified:   y = o + p*z + q*abs(tan(s*(z-r0))
C     o = y0; p = linear scale factor; q = amplitude of distortion;
C     s = scale length of distortion; r0 = distance Digicon-optical axis;
C     r = r0+z0.
C
C Forward:
C  y --> z :  y = o + p*z + q*abs(tan(s*(z-r0))
C             z + q*abs(tan(s*(z-r0) = (y-o)/p
C             |q/p*tan(s*(z-r0)| << |z|  --> determine z by iteration
C
C  z --> lambda: z = d + e*tan(b+c + arcsin(lambda/a - sin(b-c)))
C                (z-d)/e = tan(b+c + arcsin(lambda/a - sin(b-c)))
C                arctan((z-d)/e) = b+c + arcsin(lambda/a - sin(b-c))
C                arcsin(lambda/a-sin(b-c))) = arctan((z-d)/e) -(b+c)
C                lambda = a*(sin(b-c) + sin(arctan((z-d)/e) -(b+c)))
C
      IMPLICIT NONE
      INTEGER NP,IND,ITER
      REAL X
      DOUBLE PRECISION Y1,PARAM(NP),DERIV(NP),S,T,U,V,W,XX
      DOUBLE PRECISION PI,Z,Z1,Z2,ZL,F,FL,RT,DZ,XP,SWAP

      DATA PI/3.1415926535897932384626433D0/
      DATA Z1,Z2/-100.0D0,600.0D0/
      XX     = DBLE(X)
C
C Obtain z at x for f(z) =  z + q*tan(s(z-r)) -(x-o)/p = 0
C We know that -52 < z < 578 (10% margin on 0-516)
C We know that |q*tan(s(z-r) - (x-o)/p| << |z|
C Function is smooth, so we use secant method and
C precalculate a bracket using zg = (x-o)/p
C We want final epsilon < 1E-5 * z
C
      XP = XX-PARAM(6)
      Z1 = XP/PARAM(7)+50.
      Z2 = XP/PARAM(7)-50.
 10   FL = Z1+( PARAM(8)*DTAN(PARAM(10)*(Z1-PARAM(9)))
     1         -XP)/PARAM(7)
      F  = Z2+( PARAM(8)*DTAN(PARAM(10)*(Z2-PARAM(9)))
     1         -XP)/PARAM(7)
C Pick bound with smaller function value as most recent guess
      IF(DABS(FL).LT.DABS(F)) THEN
        RT = Z1
        ZL = Z2
        SWAP = FL
        FL = F
        F = SWAP
      ELSE
        ZL = Z1
        RT = Z2
      ENDIF
C Secant loop
      ITER=0
 20   DZ = (ZL-RT)*F/(F-FL)
      ITER=1
      ZL = RT
      FL = F
      RT = RT+DZ
      F = RT+( PARAM(8)*DTAN(PARAM(10)*(RT-PARAM(9)))
     1         -XP)/PARAM(7)
C      IF(DABS(DZ).GE.1.0D-10.OR.F.NE.0.0D0) GOTO 20
      IF(DABS(DZ).GE.1.0D-10) GOTO 20

C We have a good guess of z
      Z = RT
C
      S      = PARAM(2)-PARAM(3)             ! b-c
      U      = (Z-PARAM(4))/PARAM(5)         !
      T      = DATAND(U)-PARAM(2)-PARAM(3)   ! arctand((z-d)/e) -(b+c))
      V      = PARAM(1)*DCOSD(S)         !
      W      = PARAM(1)*DCOSD(T)         !

      DERIV(1) = DSIND(S)+DSIND(T) !d/da = sin(b-c)+sin(arctan((z-d)/e)-(b+c))

C     lambda = a*(sin(b-c) + sin(arctan((z-d)/e) -(b+c)))
      Y1       = PARAM(1)*DERIV(1)

      DERIV(2) = V-W
      DERIV(3) = -V-W
      DERIV(4) = -W/(1.0D0-U*U)/PARAM(5)
      DERIV(5) = DERIV(4)*U
ccc      write(6,100) X,Z,Y1
ccc 100  FORMAT(1X,3F15.7)

      RETURN
      END


      subroutine runP_iii(k,i1,i2,i3,f,Gr,Shat4,N0)
      implicit none
      include 'pvDnames.f'
      include 'pvDv.f'
      include 'Darraydef.f'
      include 'Darrays.f'
      integer ep,N0,k,i1,i2,i3,np
      parameter(np=3)
      double precision f(np),Gr(np,np)
      double complex Shat4(np,z3max,-2:0)

      do ep=-2,0
      Dv(diii(z3(i1,i2,i3))+N0,ep)=
     . (Shat4(k,z3(i1,i2,i3),ep)
     . -2d0*delta(k,i1)*Dv(dzzii(z2(i2,i3))+N0,ep)
     . -2d0*delta(k,i2)*Dv(dzzii(z2(i1,i3))+N0,ep)
     . -2d0*delta(k,i3)*Dv(dzzii(z2(i1,i2))+N0,ep)
     . -Gr(k,1)*Dv(diiii(z4(1,i1,i2,i3))+N0,ep)
     . -Gr(k,2)*Dv(diiii(z4(2,i1,i2,i3))+N0,ep)
     . -Gr(k,3)*Dv(diiii(z4(3,i1,i2,i3))+N0,ep))/f(k)
      enddo

      return
      end


MODULE module_bl_gfs

CONTAINS

   SUBROUTINE BL_GFS(U3D,V3D,TH3D,T3D,QV3D,QC3D,QI3D,P3D,PI3D, &
                  RUBLTEN,RVBLTEN,RTHBLTEN, &
                  RQVBLTEN,RQCBLTEN,RQIBLTEN, &
                  CP,G,ROVCP,R,ROVG,P_QI,P_FIRST_SCALAR, &
                  dz8w,z,PSFC, &
                  UST,PBL,PSIM,PSIH, &
                  HFX,QFX,TSK,GZ1OZ0,WSPD,BR, &
                  DT,KPBL2D,EP1,KARMAN, &
                  ids,ide, jds,jde, kds,kde, &
                  ims,ime, jms,jme, kms,kme, &
                  its,ite, jts,jte, kts,kte )

      USE MODULE_GFS_MACHINE , ONLY : kind_phys

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde, &
                                        ims,ime, jms,jme, kms,kme, &
                                        its,ite, jts,jte, kts,kte, &
                                        P_QI,P_FIRST_SCALAR
      REAL, INTENT(IN) :: &
                                        CP, &
                                        DT, &
                                        EP1, &
                                        G, &
                                        KARMAN, &
                                        R, &
                                        ROVCP, &
                                        ROVG
      REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: &
                                        DZ8W, &
                                        P3D, &
                                        PI3D, &
                                        QC3D, &
                                        QI3D, &
                                        QV3D, &
                                        T3D, &
                                        TH3D, &
                                        U3D, &
                                        V3D, &
                                        Z
      REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: &
                                        RTHBLTEN, &
                                        RQCBLTEN, &
                                        RQIBLTEN, &
                                        RQVBLTEN, &
                                        RUBLTEN, &
                                        RVBLTEN
      REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: &
                                        BR, &
                                        GZ1OZ0, &
                                        HFX, &
                                        PSFC, &
                                        PSIM, &
                                        PSIH, &
                                        QFX, &
                                        TSK
      REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT) :: &
                                        PBL, &
                                        UST, &
                                        WSPD
      INTEGER, DIMENSION(ims:ime, jms:jme), INTENT(OUT) :: &
                                        KPBL2D
      REAL (kind=kind_phys), DIMENSION(its:ite, kts:kte) :: &
                                        DEL, &
                                        DU, &
                                        DV, &
                                        PHIL, &
                                        PRSL, &
                                        PRSLK, &
                                        T1, &
                                        TAU, &
                                        dishx, &
                                        U1, &
                                        V1
      REAL (kind=kind_phys), DIMENSION(its:ite, kts:kte+1) :: &
                                        PHII, &
                                        PRSI
      REAL (kind=kind_phys), DIMENSION(its:ite, kts:kte, 3) :: &
                                        Q1, &
                                        RTG
      REAL (kind=kind_phys), DIMENSION(its:ite) :: &
                                        DQSFC, &
                                        DTSFC, &
                                        DUSFC, &
                                        DVSFC, &
                                        EVAP, &
                                        FH, &
                                        FM, &
                                        HEAT, &
                                        HGAMQ, &
                                        HGAMT, &
                                        HPBL, &
                                        PSK, &
                                        QSS, &
                                        RBSOIL, &
                                        RCL, &
                                        XLAND1, &
                                        SPD1, &
                                        STRESS, &
                                        RO,rbcr, &
                                        TSEA
      REAL (kind=kind_phys) :: &
                                        CPM, &
                                        cpmikj, &
                                        DELTIM, &
                                        FMTMP, &
                                        RRHOX
      REAL, PARAMETER:: ALPHA=1.0
      INTEGER, DIMENSION( its:ite ) :: &
                                        KPBL
      INTEGER :: &
                                        I, &
                                        IM, &
                                        J, &
                                        K, &
                                        KM, &
                                        KTEM, &
                                        KTEP, &
                                        KX, &
                                        L, &
                                        NTRAC
   IM=ITE-ITS+1
   KX=KTE-KTS+1
   KTEM=KTE-1
   KTEP=KTE+1
   NTRAC=2
   DELTIM=DT
   IF (P_QI.ge.P_FIRST_SCALAR) NTRAC=3
   DO J=jts,jte
      DO i=its,ite
        RRHOX=(R*T3D(I,KTS,J)*(1.+EP1*QV3D(I,KTS,J)))/PSFC(I,J)
        CPM=CP*(1.+0.8*QV3D(i,kts,j))
        FMTMP=GZ1OZ0(i,j)-PSIM(i,j)
        PSK(i)=(PSFC(i,j)*.00001)**ROVCP
        FM(i)=FMTMP
        FH(i)=GZ1OZ0(i,j)-PSIH(i,j)
        TSEA(i)=TSK(i,j)
        QSS(i)=QV3D(i,kts,j)
        HEAT(i)=HFX(i,j)/CPM*RRHOX
        EVAP(i)=QFX(i,j)*RRHOX
        XLAND1(i) = 0.0
        STRESS(i)=KARMAN*KARMAN*WSPD(i,j)*WSPD(i,j)/(FMTMP*FMTMP)
        SPD1(i)=WSPD(i,j)
        PRSI(i,kts)=PSFC(i,j)*.001
        PHII(I,kts)=0.
        RCL(i)=1.
        RBSOIL(I)=BR(i,j)
      ENDDO
      DO k=kts,kte
        DO i=its,ite
          DV(I,K) = 0.
          DU(I,K) = 0.
          TAU(I,K) = 0.
          U1(I,K) = U3D(i,k,j)
          V1(I,K) = V3D(i,k,j)
          T1(I,K) = T3D(i,k,j)
          Q1(I,K,1) = QV3D(i,k,j)/(1.+QV3D(i,k,j))
          Q1(I,K,2) = QC3D(i,k,j)/(1.+QC3D(i,k,j))
          PRSL(I,K)=P3D(i,k,j)*.001
        ENDDO
      ENDDO
      DO k=kts,kte
        DO i=its,ite
          PRSLK(I,K)=(PRSL(i,k)*.01)**ROVCP
        ENDDO
      ENDDO
      DO k=kts+1,kte
        km=k-1
        DO i=its,ite
          DEL(i,km)=PRSL(i,km)/ROVG*dz8w(i,km,j)/T3D(i,km,j)
          PRSI(i,k)=PRSI(i,km)-DEL(i,km)
          PHII(I,K)=(Z(i,k,j)-Z(i,kts,j))*G
          PHIL(I,KM)=0.5*(Z(i,k,j)+Z(i,km,j)-2.*Z(i,kts,j))*G
        ENDDO
      ENDDO
      DO i=its,ite
        DEL(i,kte)=DEL(i,ktem)
        PRSI(i,ktep)=PRSI(i,kte)-DEL(i,ktem)
        PHII(I,KTEP)=PHII(I,KTE)+dz8w(i,kte,j)*G
        PHIL(I,KTE)=PHII(I,KTE)-PHIL(I,KTEM)+PHII(I,KTE)
      ENDDO
      IF (P_QI.ge.P_FIRST_SCALAR) THEN
        DO k=kts,kte
          DO i=its,ite
            Q1(I,K,3) = QI3D(i,k,j)/(1.+QI3D(i,k,j))
          ENDDO
        ENDDO
      ENDIF
      DO l=1,ntrac
        DO k=kts,kte
          DO i=its,ite
            RTG(I,K,L) = 0.
          ENDDO
        ENDDO
      ENDDO
      CALL MONINP(IM,IM,KX,NTRAC,DV,DU,TAU,RTG,U1,V1,T1,Q1, &
                  PSK,RBSOIL,FM,FH,TSEA,QSS,HEAT,EVAP,STRESS, &
                  SPD1,KPBL,PRSI,DEL,PRSL,PRSLK,PHII,PHIL,RCL, &
                  DELTIM,DUSFC,DVSFC,DTSFC,DQSFC,HPBL,HGAMT, &
                RBCR,HGAMQ,ALPHA)
      DO k=kts,kte
        DO i=its,ite
          RVBLTEN(I,K,J)=DV(I,K)
          RUBLTEN(I,K,J)=DU(I,K)
          RTHBLTEN(I,K,J)=TAU(I,K)/PI3D(I,K,J)
          RQVBLTEN(I,K,J)=RTG(I,K,1)/(1.-Q1(I,K,1))**2
          RQCBLTEN(I,K,J)=RTG(I,K,2)/(1.-Q1(I,K,2))**2
        ENDDO
      ENDDO
      IF (P_QI.ge.P_FIRST_SCALAR) THEN
        DO k=kts,kte
          DO i=its,ite
            RQIBLTEN(I,K,J)=RTG(I,K,3)/(1.-Q1(I,K,3))**2
          ENDDO
        ENDDO
      ENDIF
      DO i=its,ite
        UST(i,j)=SQRT(STRESS(i))
        WSPD(i,j)=SQRT(U3D(I,KTS,J)*U3D(I,KTS,J)+ &
                       V3D(I,KTS,J)*V3D(I,KTS,J))+1.E-9
        PBL(i,j)=HPBL(i)
        KPBL2D(i,j)=kpbl(i)
      ENDDO
    ENDDO
   END SUBROUTINE BL_GFS
   SUBROUTINE gfsinit(RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN, &
                      RQCBLTEN,RQIBLTEN,P_QI,P_FIRST_SCALAR, &
                      restart, &
                      allowed_to_read, &
                      ids, ide, jds, jde, kds, kde, &
                      ims, ime, jms, jme, kms, kme, &
                      its, ite, jts, jte, kts, kte )
   IMPLICIT NONE
   LOGICAL , INTENT(IN) :: allowed_to_read,restart
   INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, &
                                     ims, ime, jms, jme, kms, kme, &
                                     its, ite, jts, jte, kts, kte
   INTEGER , INTENT(IN) :: P_QI,P_FIRST_SCALAR
   REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) :: &
                                                         RUBLTEN, &
                                                         RVBLTEN, &
                                                         RTHBLTEN, &
                                                         RQVBLTEN, &
                                                         RQCBLTEN, &
                                                         RQIBLTEN
   INTEGER :: i, j, k, itf, jtf, ktf
   jtf=min0(jte,jde-1)
   ktf=min0(kte,kde-1)
   itf=min0(ite,ide-1)
   IF(.not.restart)THEN
     DO j=jts,jtf
     DO k=kts,ktf
     DO i=its,itf
        RUBLTEN(i,k,j)=0.
        RVBLTEN(i,k,j)=0.
        RTHBLTEN(i,k,j)=0.
        RQVBLTEN(i,k,j)=0.
        RQCBLTEN(i,k,j)=0.
     ENDDO
     ENDDO
     ENDDO
   ENDIF
   IF (P_QI .ge. P_FIRST_SCALAR .and. .not.restart) THEN
      DO j=jts,jtf
      DO k=kts,ktf
      DO i=its,itf
         RQIBLTEN(i,k,j)=0.
      ENDDO
      ENDDO
      ENDDO
   ENDIF
   IF (P_QI .ge. P_FIRST_SCALAR) THEN
      DO j=jts,jtf
      DO k=kts,ktf
      DO i=its,itf
         RQIBLTEN(i,k,j)=0.
      ENDDO
      ENDDO
      ENDDO
   ENDIF
   END SUBROUTINE gfsinit
      SUBROUTINE MONINP(IX,IM,KM,ntrac,DV,DU,TAU,RTG, &
     & U1,V1,T1,Q1, &
     & PSK,RBSOIL,FM,FH,TSEA,QSS,HEAT,EVAP,STRESS,SPD1,KPBL, &
     & PRSI,DEL,PRSL,PRSLK,PHII,PHIL,RCL,DELTIM, &
     & DUSFC,DVSFC,DTSFC,DQSFC,HPBL,HGAMT, &
           RBCR,HGAMQ,ALPHA)
      USE MODULE_GFS_MACHINE, ONLY : kind_phys
      USE MODULE_GFS_PHYSCONS, grav => con_g, RD => con_RD, CP => con_CP &
     &, HVAP => con_HVAP, ROG => con_ROG, FV => con_FVirt
      implicit none
      integer IX, IM, KM, ntrac, KPBL(IM)
      real(kind=kind_phys) DELTIM
      real :: ALPHA
      real(kind=kind_phys) DV(IM,KM), DU(IM,KM), &
     & TAU(IM,KM), RTG(IM,KM,ntrac), &
     & U1(IX,KM), V1(IX,KM), &
     & T1(IX,KM), Q1(IX,KM,ntrac), &
     & PSK(IM), RBSOIL(IM), &
     & FM(IM), FH(IM), &
     & TSEA(IM), QSS(IM), &
     & SPD1(IM), &
     & PRSI(IX,KM+1), DEL(IX,KM), &
     & PRSL(IX,KM), PRSLK(IX,KM), &
     & PHII(IX,KM+1), PHIL(IX,KM), &
     & RCL(IM), DUSFC(IM), &
     & dvsfc(IM), dtsfc(IM), &
     & DQSFC(IM), HPBL(IM), &
     & HGAMT(IM), hgamq(IM), RBCR(IM)
      integer i,iprt,is,iun,k,kk,kmpbl,lond
      real(kind=kind_phys) evap(IM), heat(IM), phih(IM), &
     & phim(IM), rbdn(IM), rbup(IM), &
     & the1(IM), stress(im), beta(im), &
     & the1v(IM), thekv(IM), thermal(IM), &
     & thesv(IM), ustar(IM), wscale(IM)
      real(kind=kind_phys) RDZT(IM,KM-1), &
     & ZI(IM,KM+1), ZL(IM,KM), &
     & DKO(IM,KM-1), &
     & AL(IM,KM-1), AD(IM,KM), &
     & AU(IM,KM-1), A1(IM,KM), &
     & A2(IM,KM), THETA(IM,KM), &
     & AT(IM,KM*(ntrac-1)),DKU(IM,KM-1),DKT(IM,KM-1)
      logical pblflg(IM), sfcflg(IM), stable(IM)
      real(kind=kind_phys) aphi16, aphi5, bet1, bvf2, &
     & cfac, conq, cont, conw, &
     & conwrc, dk, dkmax, dkmin, &
     & dq1, dsdz2, dsdzq, dsdzt, &
     & dsig, dt, dthe1, dtodsd, &
     & dtodsu, dw2, dw2min, g, &
     & gamcrq, gamcrt, gocp, gor, gravi, &
     & hol, pfac, prmax, prmin, prinv, &
     & prnum, qmin, qtend, &
     & rbint, rdt, rdz, rdzt1, &
     & ri, rimin, rl2, rlam, &
     & rone, rzero, sfcfrac, &
     & sflux, shr2, spdk2, sri, &
     & tem, ti, ttend, tvd, &
     & tvu, utend, vk, vk2, &
     & vpert, vtend, xkzo, zfac, &
     & zfmin, zk, tem1
      PARAMETER(g=grav)
      PARAMETER(GOR=G/RD,GOCP=G/CP)
      PARAMETER(CONT=1000.*CP/G,CONQ=1000.*HVAP/G,CONW=1000./G)
      PARAMETER(RLAM=150.,VK=0.4,VK2=VK*VK,PRMIN=1.0,PRMAX=4.)
      PARAMETER(DW2MIN=0.0001,DKMIN=1.0,DKMAX=1000.,RIMIN=-100.)
      PARAMETER(CFAC=7.8,PFAC=2.0,SFCFRAC=0.1)
      PARAMETER(QMIN=1.E-8,XKZO=1.0,ZFMIN=1.E-8,APHI5=5.,APHI16=16.)
      PARAMETER(GAMCRT=3.,GAMCRQ=0.)
      PARAMETER(RZERO=0.,RONE=1.)
      PARAMETER(IUN=84)
 601 FORMAT(1X,' MONINP LAT LON STEP HOUR ',3I6,F6.1)
 602 FORMAT(1X,'    K','        Z','        T','       TH', &
     & '      TVH','        Q','        U','        V', &
     & '       SP')
 603 FORMAT(1X,I5,8F9.1)
 604 FORMAT(1X,'  SFC',9X,F9.1,18X,F9.1)
 605 FORMAT(1X,'    K      ZL    SPD2   THEKV   THE1V' &
     & ,' THERMAL    RBUP')
 606 FORMAT(1X,I5,6F8.2)
 607 FORMAT(1X,' KPBL    HPBL      FM      FH   HGAMT', &
     & '   HGAMQ      WS   USTAR      CD      CH')
 608 FORMAT(1X,I5,9F8.2)
 609 FORMAT(1X,' K PR DKT DKU ',I5,3F8.2)
 610 FORMAT(1X,' K PR DKT DKU ',I5,3F8.2,' L2 RI T2', &
     & ' SR2  ',2F8.2,2E10.2)
      if (IX .lt. im) stop
      IPRT = 0
      IF(IPRT.EQ.1) THEN
      LOND = 0
      ELSE
      LOND = 0
      ENDIF
     do i=1,im
     RBCR(I) = 0.25
     enddo
      gravi = 1.0 / grav
      DT = 2. * DELTIM
      RDT = 1. / DT
      KMPBL = KM / 2
      do k=1,km
        do i=1,im
          zi(i,k) = phii(i,k) * gravi
          zl(i,k) = phil(i,k) * gravi
        enddo
      enddo
      do k=1,kmpbl
        do i=1,im
          theta(i,k) = t1(i,k) * psk(i) / prslk(i,k)
        enddo
      enddo
      DO K = 1,KM-1
        DO I=1,IM
          RDZT(I,K) = GOR * PRSI(I,K+1) / (PRSL(I,K) - PRSL(I,K+1))
        ENDDO
      ENDDO
      DO I = 1,IM
         DUSFC(I) = 0.
         DVSFC(I) = 0.
         DTSFC(I) = 0.
         DQSFC(I) = 0.
         HGAMT(I) = 0.
         HGAMQ(I) = 0.
         WSCALE(I) = 0.
         KPBL(I) = 1
         HPBL(I) = ZI(I,2)
         PBLFLG(I) = .TRUE.
         SFCFLG(I) = .TRUE.
         IF(RBSOIL(I).GT.0.0) SFCFLG(I) = .FALSE.
      ENDDO
      DO I=1,IM
         RDZT1 = GOR * prSL(i,1) / DEL(i,1)
         BETA(I) = DT*RDZT1/T1(I,1)
      ENDDO
      DO I=1,IM
         USTAR(I) = SQRT(STRESS(I))
      ENDDO
      DO I=1,IM
         THESV(I) = TSEA(I)*(1.+FV*MAX(QSS(I),QMIN))
         THE1(I) = THETA(I,1)
         THE1V(I) = THE1(I)*(1.+FV*MAX(Q1(I,1,1),QMIN))
         THERMAL(I) = THE1V(I)
      ENDDO
      DO I=1,IM
         STABLE(I) = .FALSE.
         RBUP(I) = RBSOIL(I)
      ENDDO
      DO K = 2, KMPBL
        DO I = 1, IM
          IF(.NOT.STABLE(I)) THEN
             RBDN(I) = RBUP(I)
             THEKV(I) = THETA(i,k)*(1.+FV*MAX(Q1(i,k,1),QMIN))
             SPDK2 = MAX(RCL(i)*(U1(i,k)*U1(i,k)+V1(i,k)*V1(i,k)),RONE)
             RBUP(I) = (THEKV(I)-THE1V(I))*(G*ZL(I,k)/THE1V(I))/SPDK2
             KPBL(I) = K
             STABLE(I) = RBUP(I).GT.RBCR(I)
          ENDIF
        ENDDO
      ENDDO
      DO I = 1,IM
         K = KPBL(I)
         IF(RBDN(I).GE.RBCR(I)) THEN
            RBINT = 0.
         ELSEIF(RBUP(I).LE.RBCR(I)) THEN
            RBINT = 1.
         ELSE
            RBINT = (RBCR(I)-RBDN(I))/(RBUP(I)-RBDN(I))
         ENDIF
         HPBL(I) = ZL(I,K-1) + RBINT*(ZL(I,K)-ZL(I,K-1))
         IF(HPBL(I).LT.ZI(I,KPBL(I))) KPBL(I) = KPBL(I) - 1
      ENDDO
      DO I=1,IM
           HOL = MAX(RBSOIL(I)*FM(I)*FM(I)/FH(I),RIMIN)
           IF(SFCFLG(I)) THEN
              HOL = MIN(HOL,-ZFMIN)
           ELSE
              HOL = MAX(HOL,ZFMIN)
           ENDIF
           HOL = HOL*HPBL(I)/ZL(I,1)*SFCFRAC
           IF(SFCFLG(I)) THEN
              TEM = 1.0 / (1. - APHI16*HOL)
              PHIH(I) = SQRT(TEM)
              PHIM(I) = SQRT(PHIH(I))
           ELSE
              PHIM(I) = (1.+APHI5*HOL)
              PHIH(I) = PHIM(I)
           ENDIF
           WSCALE(I) = USTAR(I)/PHIM(I)
           WSCALE(I) = MIN(WSCALE(I),USTAR(I)*APHI16)
           WSCALE(I) = MAX(WSCALE(I),USTAR(I)/APHI5)
      ENDDO
      DO I = 1,IM
         SFLUX = HEAT(I) + EVAP(I)*FV*THE1(I)
         IF(SFCFLG(I).AND.SFLUX.GT.0.0) THEN
           HGAMT(I) = MIN(CFAC*HEAT(I)/WSCALE(I),GAMCRT)
           HGAMQ(I) = MIN(CFAC*EVAP(I)/WSCALE(I),GAMCRQ)
           VPERT = HGAMT(I) + FV*THE1(I)*HGAMQ(I)
           VPERT = MIN(VPERT,GAMCRT)
           THERMAL(I) = THERMAL(I) + MAX(VPERT,RZERO)
           HGAMT(I) = MAX(HGAMT(I),RZERO)
           HGAMQ(I) = MAX(HGAMQ(I),RZERO)
         ELSE
           PBLFLG(I) = .FALSE.
         ENDIF
      ENDDO
      DO I = 1,IM
         IF(PBLFLG(I)) THEN
            KPBL(I) = 1
            HPBL(I) = ZI(I,2)
         ENDIF
      ENDDO
      DO I = 1, IM
         IF(PBLFLG(I)) THEN
            STABLE(I) = .FALSE.
            RBUP(I) = RBSOIL(I)
         ENDIF
      ENDDO
      DO K = 2, KMPBL
        DO I = 1, IM
          IF(.NOT.STABLE(I).AND.PBLFLG(I)) THEN
            RBDN(I) = RBUP(I)
            THEKV(I) = THETA(i,k)*(1.+FV*MAX(Q1(i,k,1),QMIN))
            SPDK2 = MAX(RCL(i)*(U1(i,k)*U1(i,k)+V1(i,k)*V1(i,k)),RONE)
            RBUP(I) = (THEKV(I)-THERMAL(I))*(G*ZL(I,k)/THE1V(I))/SPDK2
            KPBL(I) = K
            STABLE(I) = RBUP(I).GT.RBCR(I)
          ENDIF
        ENDDO
      ENDDO
      DO I = 1,IM
         IF(PBLFLG(I)) THEN
            K = KPBL(I)
            IF(RBDN(I).GE.RBCR(I)) THEN
               RBINT = 0.
            ELSEIF(RBUP(I).LE.RBCR(I)) THEN
               RBINT = 1.
            ELSE
               RBINT = (RBCR(I)-RBDN(I))/(RBUP(I)-RBDN(I))
            ENDIF
            HPBL(I) = ZL(I,K-1) + RBINT*(ZL(I,k)-ZL(I,K-1))
            IF(HPBL(I).LT.ZI(I,KPBL(I))) KPBL(I) = KPBL(I) - 1
            IF(KPBL(I).LE.1) PBLFLG(I) = .FALSE.
         ENDIF
      ENDDO
      DO K = 1, KMPBL
         DO I=1,IM
            IF(KPBL(I).GT.K) THEN
               PRINV = 1.0 / (PHIH(I)/PHIM(I)+CFAC*VK*.1)
               PRINV = MIN(PRINV,PRMAX)
               PRINV = MAX(PRINV,PRMIN)
               ZFAC = MAX((1.-(ZI(I,K+1)-ZL(I,1))/ &
     & (HPBL(I)-ZL(I,1))), ZFMIN)
               DKU(i,k) = XKZO + WSCALE(I)*VK*ZI(I,K+1) &
     & *ALPHA* ZFAC**PFAC
               DKT(i,k) = DKU(i,k)*PRINV
               DKO(i,k) = (DKU(i,k)-XKZO)*PRINV
               DKU(i,k) = MIN(DKU(i,k),DKMAX)
               DKU(i,k) = MAX(DKU(i,k),DKMIN)
               DKT(i,k) = MIN(DKT(i,k),DKMAX)
               DKT(i,k) = MAX(DKT(i,k),DKMIN)
               DKO(i,k) = MAX(RZERO, MIN(DKMAX, DKO(i,k)))
            ENDIF
         ENDDO
      ENDDO
      DO K = 1, KM-1
         DO I=1,IM
            IF(K.GE.KPBL(I)) THEN
               TI = 2.0 / (T1(i,k)+T1(i,K+1))
               RDZ = RDZT(I,K) * TI
               DW2 = RCL(i)*((U1(i,k)-U1(i,K+1))**2 &
     & + (V1(i,k)-V1(i,K+1))**2)
               SHR2 = MAX(DW2,DW2MIN)*RDZ**2
               TVD = T1(i,k)*(1.+FV*MAX(Q1(i,k,1),QMIN))
               TVU = T1(i,K+1)*(1.+FV*MAX(Q1(i,K+1,1),QMIN))
               BVF2 = G*(GOCP+RDZ*(TVU-TVD)) * TI
               RI = MAX(BVF2/SHR2,RIMIN)
               ZK = VK*ZI(I,K+1)
               RL2 = ZK*RLAM/(RLAM+ZK)
               DK = RL2*RL2*SQRT(SHR2)
               IF(RI.LT.0.) THEN
                  SRI = SQRT(-RI)
                  DKU(i,k) = XKZO + DK*(1+8.*(-RI)/(1+1.746*SRI))
                  tem = DK*(1+8.*(-RI)/(1+1.286*SRI))
                  DKT(i,k) = XKZO + tem
                  DKO(i,k) = tem
               ELSE
                  tem = DK/(1+5.*RI)**2
                  DKT(i,k) = XKZO + tem
                  DKO(i,k) = tem
                  PRNUM = 1.0 + 2.1*RI
                  PRNUM = MIN(PRNUM,PRMAX)
                  DKU(i,k) = (DKT(i,k)-XKZO)*PRNUM + XKZO
               ENDIF
               DKU(i,k) = MIN(DKU(i,k),DKMAX)
               DKU(i,k) = MAX(DKU(i,k),DKMIN)
               DKT(i,k) = MIN(DKT(i,k),DKMAX)
               DKT(i,k) = MAX(DKT(i,k),DKMIN)
               DKO(i,k) = MAX(RZERO, MIN(DKMAX, DKO(i,k)))
            ENDIF
         ENDDO
      ENDDO
      DO I=1,IM
         AD(I,1) = 1.
         A1(I,1) = T1(i,1) + BETA(i) * HEAT(I)
         A2(I,1) = Q1(i,1,1) + BETA(i) * EVAP(I)
      ENDDO
      DO K = 1,KM-1
        DO I = 1,IM
          DTODSD = DT/DEL(I,K)
          DTODSU = DT/DEL(I,K+1)
          DSIG = PRSL(I,K)-PRSL(I,K+1)
          RDZ = RDZT(I,K)*2./(T1(i,k)+T1(i,K+1))
          tem1 = DSIG * DKT(i,k) * RDZ
          IF(PBLFLG(I).AND.K.LT.KPBL(I)) THEN
             tem = 1.0 / HPBL(I)
             DSDZT = tem1 * (GOCP-HGAMT(I)*tem)
             DSDZQ = tem1 * (-HGAMQ(I)*tem)
             A2(I,k) = A2(I,k)+DTODSD*DSDZQ
             A2(I,k+1) = Q1(i,k+1,1)-DTODSU*DSDZQ
          ELSE
             DSDZT = tem1 * GOCP
             A2(I,k+1) = Q1(i,k+1,1)
          ENDIF
          DSDZ2 = tem1 * RDZ
          AU(I,k) = -DTODSD*DSDZ2
          AL(I,k) = -DTODSU*DSDZ2
          AD(I,k) = AD(I,k)-AU(I,k)
          AD(I,k+1) = 1.-AL(I,k)
          A1(I,k) = A1(I,k)+DTODSD*DSDZT
          A1(I,k+1) = T1(i,k+1)-DTODSU*DSDZT
        ENDDO
      ENDDO
      CALL TRIDIN(IM,KM,1,AL,AD,AU,A1,A2,AU,A1,A2)
      DO K = 1,KM
         DO I = 1,IM
            TTEND = (A1(I,k)-T1(i,k))*RDT
            QTEND = (A2(I,k)-Q1(i,k,1))*RDT
            TAU(i,k) = TAU(i,k)+TTEND
            RTG(I,k,1) = RTG(i,k,1)+QTEND
            DTSFC(I) = DTSFC(I)+CONT*DEL(I,K)*TTEND
            DQSFC(I) = DQSFC(I)+CONQ*DEL(I,K)*QTEND
         ENDDO
      ENDDO
      DO I=1,IM
         AD(I,1) = 1.0 + BETA(i) * STRESS(I) / SPD1(I)
         A1(I,1) = U1(i,1)
         A2(I,1) = V1(i,1)
      ENDDO
      DO K = 1,KM-1
        DO I=1,IM
          DTODSD = DT/DEL(I,K)
          DTODSU = DT/DEL(I,K+1)
          DSIG = PRSL(I,K)-PRSL(I,K+1)
          RDZ = RDZT(I,K)*2./(T1(i,k)+T1(i,k+1))
          DSDZ2 = DSIG*DKU(i,k)*RDZ*RDZ
          AU(I,k) = -DTODSD*DSDZ2
          AL(I,k) = -DTODSU*DSDZ2
          AD(I,k) = AD(I,k)-AU(I,k)
          AD(I,k+1) = 1.-AL(I,k)
          A1(I,k+1) = U1(i,k+1)
          A2(I,k+1) = V1(i,k+1)
        ENDDO
      ENDDO
      CALL TRIDI2(IM,KM,AL,AD,AU,A1,A2,AU,A1,A2)
      DO K = 1,KM
         DO I = 1,IM
            CONWRC = CONW*SQRT(RCL(i))
            UTEND = (A1(I,k)-U1(i,k))*RDT
            VTEND = (A2(I,k)-V1(i,k))*RDT
            DU(i,k) = DU(i,k)+UTEND
            DV(i,k) = DV(i,k)+VTEND
            DUSFC(I) = DUSFC(I)+CONWRC*DEL(I,K)*UTEND
            DVSFC(I) = DVSFC(I)+CONWRC*DEL(I,K)*VTEND
         ENDDO
      ENDDO
      if (ntrac .ge. 2) then
        DO I=1,IM
         AD(I,1) = 1.
        ENDDO
        do k = 2, ntrac
          is = (k-2) * km
          do i = 1, im
            AT(I,1+is) = Q1(i,1,k)
          enddo
        enddo
        DO K = 1,KM-1
          DO I = 1,IM
            DTODSD = DT/DEL(I,K)
            DTODSU = DT/DEL(I,K+1)
            DSIG = PRSL(I,K)-PRSL(I,K+1)
            RDZ = RDZT(I,K)*2./(T1(i,k)+T1(i,K+1))
            tem1 = DSIG * DKT(i,k) * RDZ
            DSDZ2 = tem1 * RDZ
            AU(I,k) = -DTODSD*DSDZ2
            AL(I,k) = -DTODSU*DSDZ2
            AD(I,k) = AD(I,k)-AU(I,k)
            AD(I,k+1) = 1.-AL(I,k)
          ENDDO
        ENDDO
        do kk = 2, ntrac
          is = (kk-2) * km
          do k = 1, km - 1
            do i = 1, im
              AT(I,k+1+is) = Q1(i,k+1,kk)
            enddo
          enddo
        enddo
        CALL TRIDIT(IM,KM,ntrac-1,AL,AD,AU,AT,AU,AT)
        do kk = 2, ntrac
          is = (kk-2) * km
          do k = 1, km
            do i = 1, im
              QTEND = (AT(I,K+is)-Q1(i,K,kk))*RDT
              RTG(i,K,kk) = RTG(i,K,kk) + QTEND
            enddo
          enddo
        enddo
      endif
      RETURN
      END SUBROUTINE MONINP
      SUBROUTINE TRIDI2(L,N,CL,CM,CU,R1,R2,AU,A1,A2)
      USE MODULE_GFS_MACHINE, ONLY : kind_phys
      implicit none
      integer k,n,l,i
      real(kind=kind_phys) fk
      real(kind=kind_phys) CL(L,2:N),CM(L,N),CU(L,N-1),R1(L,N),R2(L,N), &
     & AU(L,N-1),A1(L,N),A2(L,N)
      DO I=1,L
        FK = 1./CM(I,1)
        AU(I,1) = FK*CU(I,1)
        A1(I,1) = FK*R1(I,1)
        A2(I,1) = FK*R2(I,1)
      ENDDO
      DO K=2,N-1
        DO I=1,L
          FK = 1./(CM(I,K)-CL(I,K)*AU(I,K-1))
          AU(I,K) = FK*CU(I,K)
          A1(I,K) = FK*(R1(I,K)-CL(I,K)*A1(I,K-1))
          A2(I,K) = FK*(R2(I,K)-CL(I,K)*A2(I,K-1))
        ENDDO
      ENDDO
      DO I=1,L
        FK = 1./(CM(I,N)-CL(I,N)*AU(I,N-1))
        A1(I,N) = FK*(R1(I,N)-CL(I,N)*A1(I,N-1))
        A2(I,N) = FK*(R2(I,N)-CL(I,N)*A2(I,N-1))
      ENDDO
      DO K=N-1,1,-1
        DO I=1,L
          A1(I,K) = A1(I,K)-AU(I,K)*A1(I,K+1)
          A2(I,K) = A2(I,K)-AU(I,K)*A2(I,K+1)
        ENDDO
      ENDDO
      RETURN
      END SUBROUTINE TRIDI2
      SUBROUTINE TRIDIN(L,N,nt,CL,CM,CU,R1,R2,AU,A1,A2)
      USE MODULE_GFS_MACHINE, ONLY : kind_phys
      implicit none
      integer is,k,kk,n,nt,l,i
      real(kind=kind_phys) fk(L)
      real(kind=kind_phys) CL(L,2:N), CM(L,N), CU(L,N-1), &
     & R1(L,N), R2(L,N*nt), &
     & AU(L,N-1), A1(L,N), A2(L,N*nt), &
     & FKK(L,2:N-1)
      DO I=1,L
        FK(I) = 1./CM(I,1)
        AU(I,1) = FK(I)*CU(I,1)
        A1(I,1) = FK(I)*R1(I,1)
      ENDDO
      do k = 1, nt
        is = (k-1) * n
        do i = 1, l
          a2(i,1+is) = fk(I) * r2(i,1+is)
        enddo
      enddo
      DO K=2,N-1
        DO I=1,L
          FKK(I,K) = 1./(CM(I,K)-CL(I,K)*AU(I,K-1))
          AU(I,K) = FKK(I,K)*CU(I,K)
          A1(I,K) = FKK(I,K)*(R1(I,K)-CL(I,K)*A1(I,K-1))
        ENDDO
      ENDDO
      do kk = 1, nt
        is = (kk-1) * n
        DO K=2,N-1
          DO I=1,L
            A2(I,K+is) = FKK(I,K)*(R2(I,K+is)-CL(I,K)*A2(I,K+is-1))
          ENDDO
        ENDDO
      ENDDO
      DO I=1,L
        FK(I) = 1./(CM(I,N)-CL(I,N)*AU(I,N-1))
        A1(I,N) = FK(I)*(R1(I,N)-CL(I,N)*A1(I,N-1))
      ENDDO
      do k = 1, nt
        is = (k-1) * n
        do i = 1, l
          A2(I,N+is) = FK(I)*(R2(I,N+is)-CL(I,N)*A2(I,N+is-1))
        enddo
      enddo
      DO K=N-1,1,-1
        DO I=1,L
          A1(I,K) = A1(I,K) - AU(I,K)*A1(I,K+1)
        ENDDO
      ENDDO
      do kk = 1, nt
        is = (kk-1) * n
        DO K=n-1,1,-1
          DO I=1,L
            A2(I,K+is) = A2(I,K+is) - AU(I,K)*A2(I,K+is+1)
          ENDDO
        ENDDO
      ENDDO
      RETURN
      END SUBROUTINE TRIDIN
      SUBROUTINE TRIDIT(L,N,nt,CL,CM,CU,RT,AU,AT)
      USE MODULE_GFS_MACHINE, ONLY : kind_phys
      implicit none
      integer is,k,kk,n,nt,l,i
      real(kind=kind_phys) fk(L)
      real(kind=kind_phys) CL(L,2:N), CM(L,N), CU(L,N-1), &
     & RT(L,N*nt), &
     & AU(L,N-1), AT(L,N*nt), &
     & FKK(L,2:N-1)
      DO I=1,L
        FK(I) = 1./CM(I,1)
        AU(I,1) = FK(I)*CU(I,1)
      ENDDO
      do k = 1, nt
        is = (k-1) * n
        do i = 1, l
          at(i,1+is) = fk(I) * rt(i,1+is)
        enddo
      enddo
      DO K=2,N-1
        DO I=1,L
          FKK(I,K) = 1./(CM(I,K)-CL(I,K)*AU(I,K-1))
          AU(I,K) = FKK(I,K)*CU(I,K)
        ENDDO
      ENDDO
      do kk = 1, nt
        is = (kk-1) * n
        DO K=2,N-1
          DO I=1,L
            AT(I,K+is) = FKK(I,K)*(RT(I,K+is)-CL(I,K)*AT(I,K+is-1))
          ENDDO
        ENDDO
      ENDDO
      DO I=1,L
        FK(I) = 1./(CM(I,N)-CL(I,N)*AU(I,N-1))
      ENDDO
      do k = 1, nt
        is = (k-1) * n
        do i = 1, l
          AT(I,N+is) = FK(I)*(RT(I,N+is)-CL(I,N)*AT(I,N+is-1))
        enddo
      enddo
      do kk = 1, nt
        is = (kk-1) * n
        DO K=n-1,1,-1
          DO I=1,L
            AT(I,K+is) = AT(I,K+is) - AU(I,K)*AT(I,K+is+1)
          ENDDO
        ENDDO
      ENDDO
      RETURN
      END SUBROUTINE TRIDIT
      END MODULE module_bl_gfs


SUBROUTINE eop_rd (EOP_fname, EOP_sol, mjd , eop)

! ----------------------------------------------------------------------
! Subroutine:  eop_rd.f90
! ----------------------------------------------------------------------
! Purpose:
!  Read EOP (Earth Orientation Parameters) data based on the different solutions
!  that are available e.g. CO4, Rapid solutions, ultra-rapid
! ----------------------------------------------------------------------
! Input arguments:
! - EOP_fname:		EOP data file name
! - EOP_sol:		EOP solution type (see Note 1)
! - mjd:			Modified Julian Day number of the required date (in UTC)
!
! Output arguments:
! - eop:			Array of the EOP data for the input day
!   				eop = [MJD xp yp UT1_UTC LOD dX dY]  1x6 matrix
!   				MJD:     MJD referred to 0h in UTC time scale
!   				x,y:     Polar motion coordinates (arcsec)
!   				UT1_UTC: UT1-UTC difference (sec)
!					dX,dY:   Corrections to Precession-Nutation model (arcsec)
! ----------------------------------------------------------------------
! Note 1:
! Values of the EOP_sol input argument:
! 1. EOP_sol = 1 : refers to EOP data format of the C04 solution
!    			   provided by the IERS Earth Orientation Center
! 2. EOP_sol = 2 : refers to EOP data format of the daily solution (finals2000A.daily)
!    			   provided by the IERS Rapid Service/Prediction Center
! 3. EOP_sol = 3 : refers to EOP data format of the ultra-rapid products
!    			   provided by the IGS (per every 6 hours)
! ----------------------------------------------------------------------
! Dr. Thomas Papanikolaou, Geoscience Australia               March 2016
! ----------------------------------------------------------------------

      USE mdl_precision
      USE mdl_num
      use pod_yaml
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
! IN
      INTEGER (KIND = prec_int8), INTENT(IN) :: mjd
      INTEGER (KIND = prec_int1), INTENT(IN) :: EOP_sol
      CHARACTER (LEN=512), INTENT(IN) :: EOP_fname
! OUT
      REAL (KIND = prec_d), INTENT(OUT) :: eop(7)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------

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

! ----------------------------------------------------------------------
      IF (EOP_sol == EOP_C04T) THEN
         CALL eop_c04 (EOP_fname,mjd , eop)
      ELSE IF (EOP_sol == EOP_FAST) THEN
         CALL eop_finals2000A (EOP_fname,mjd , eop)
      ELSE IF (EOP_sol == EOP_SUPER_FAST) THEN
         !CALL erp_igu (EOP_fname,mjd , eop)
		 CALL eop_finals2000A (EOP_fname,mjd , eop)
      END IF
! ----------------------------------------------------------------------
!         PRINT *, "eop_rd.f90 eop", eop

END


MODULE SUB_Sort_quick
!!#### PURPOSE
!! Performs the standard Quick Sort algorithm
!! (or the simple Interchange Sort if the list is small)
!! on a list of integers, reals, or strings.

!!#### EXTERNAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_Rsp,KIND_Rdp,& !!((01-A-KND_IntrinsicTypes.f90))
              KIND_I1,KIND_I2,KIND_I4,KIND_I8,&
              KIND_S

!!#### DEFAULT IMPLICIT
IMPLICIT NONE

!!#### DEFAULT ACCESS
PRIVATE

!!#### LOCAL PARAMETERS
INTEGER,PARAMETER :: DEFAULT_max_simple_sort_size = 6

!!#### PROCEDURE OVERLOADING
INTERFACE Sort_quick
 MODULE PROCEDURE Sort_quick_Rsp
 MODULE PROCEDURE Sort_quick_Rdp
 MODULE PROCEDURE Sort_quick_I1
 MODULE PROCEDURE Sort_quick_I2
 MODULE PROCEDURE Sort_quick_I4
 MODULE PROCEDURE Sort_quick_I8
 MODULE PROCEDURE Sort_quick_S
END INTERFACE

!!#### PROCEDURE OVERLOADING
INTERFACE Sort_quick_
 MODULE PROCEDURE Sort_quick__Rsp
 MODULE PROCEDURE Sort_quick__Rdp
 MODULE PROCEDURE Sort_quick__I1
 MODULE PROCEDURE Sort_quick__I2
 MODULE PROCEDURE Sort_quick__I4
 MODULE PROCEDURE Sort_quick__I8
 MODULE PROCEDURE Sort_quick__S
END INTERFACE

!!#### PUBLIC ACCESS LIST
PUBLIC :: Sort_quick

CONTAINS

PURE SUBROUTINE Sort_quick_Rsp(list,order,max_simple_sort_size)
INTEGER,PARAMETER ::  KIND_R=KIND_Rsp
INCLUDE "03-A-SUB_Sort_quick_R.f90.hdr"
!!--begin--
INCLUDE "03-A-SUB_Sort_quick.f90.bdy"
!!--end--
END SUBROUTINE Sort_quick_Rsp

PURE SUBROUTINE Sort_quick_Rdp(list,order,max_simple_sort_size)
INTEGER,PARAMETER ::  KIND_R=KIND_Rdp
INCLUDE "03-A-SUB_Sort_quick_R.f90.hdr"
!!--begin--
INCLUDE "03-A-SUB_Sort_quick.f90.bdy"
!!--end--
END SUBROUTINE Sort_quick_Rdp

PURE SUBROUTINE Sort_quick_S(list,order,max_simple_sort_size)
INCLUDE "03-A-SUB_Sort_quick_S.f90.hdr"
!!--begin--
INCLUDE "03-A-SUB_Sort_quick.f90.bdy"
!!--end--
END SUBROUTINE Sort_quick_S

PURE SUBROUTINE Sort_quick_I1(list,order,max_simple_sort_size)
INTEGER,PARAMETER ::  KIND_I=KIND_I1
INCLUDE "03-A-SUB_Sort_quick_I.f90.hdr"
!!--begin--
INCLUDE "03-A-SUB_Sort_quick.f90.bdy"
!!--end--
END SUBROUTINE Sort_quick_I1

PURE SUBROUTINE Sort_quick_I2(list,order,max_simple_sort_size)
INTEGER,PARAMETER ::  KIND_I=KIND_I2
INCLUDE "03-A-SUB_Sort_quick_I.f90.hdr"
!!--begin--
INCLUDE "03-A-SUB_Sort_quick.f90.bdy"
!!--end--
END SUBROUTINE Sort_quick_I2

PURE SUBROUTINE Sort_quick_I4(list,order,max_simple_sort_size)
INTEGER,PARAMETER ::  KIND_I=KIND_I4
INCLUDE "03-A-SUB_Sort_quick_I.f90.hdr"
!!--begin--
INCLUDE "03-A-SUB_Sort_quick.f90.bdy"
!!--end--
END SUBROUTINE Sort_quick_I4

PURE SUBROUTINE Sort_quick_I8(list,order,max_simple_sort_size)
INTEGER,PARAMETER ::  KIND_I=KIND_I8
INCLUDE "03-A-SUB_Sort_quick_I.f90.hdr"
!!--begin--
INCLUDE "03-A-SUB_Sort_quick.f90.bdy"
!!--end--
END SUBROUTINE Sort_quick_I8

PURE RECURSIVE SUBROUTINE Sort_quick__Rsp( list , order , left_end , right_end , max_simple_sort_size_ )
INTEGER,PARAMETER ::  KIND_R=KIND_Rsp
INCLUDE "03-A-SUB_Sort_quick__R.f90.hdr"
!
INCLUDE "03-A-SUB_Sort_quick_.f90.bdy"
!
END SUBROUTINE

PURE RECURSIVE SUBROUTINE Sort_quick__Rdp( list , order , left_end , right_end , max_simple_sort_size_ )
INTEGER,PARAMETER ::  KIND_R=KIND_Rdp
INCLUDE "03-A-SUB_Sort_quick__R.f90.hdr"
!
INCLUDE "03-A-SUB_Sort_quick_.f90.bdy"
!
END SUBROUTINE

PURE RECURSIVE SUBROUTINE Sort_quick__I1( list , order , left_end , right_end , max_simple_sort_size_ )
INTEGER,PARAMETER ::  KIND_I=KIND_I1
INCLUDE "03-A-SUB_Sort_quick__I.f90.hdr"
!
INCLUDE "03-A-SUB_Sort_quick_.f90.bdy"
!
END SUBROUTINE

PURE RECURSIVE SUBROUTINE Sort_quick__I2( list , order , left_end , right_end , max_simple_sort_size_ )
INTEGER,PARAMETER ::  KIND_I=KIND_I2
INCLUDE "03-A-SUB_Sort_quick__I.f90.hdr"
!
INCLUDE "03-A-SUB_Sort_quick_.f90.bdy"
!
END SUBROUTINE

PURE RECURSIVE SUBROUTINE Sort_quick__I4( list , order , left_end , right_end , max_simple_sort_size_ )
INTEGER,PARAMETER ::  KIND_I=KIND_I4
INCLUDE "03-A-SUB_Sort_quick__I.f90.hdr"
!
INCLUDE "03-A-SUB_Sort_quick_.f90.bdy"
!
END SUBROUTINE

PURE RECURSIVE SUBROUTINE Sort_quick__I8( list , order , left_end , right_end , max_simple_sort_size_ )
INTEGER,PARAMETER ::  KIND_I=KIND_I8
INCLUDE "03-A-SUB_Sort_quick__I.f90.hdr"
!
INCLUDE "03-A-SUB_Sort_quick_.f90.bdy"
!
END SUBROUTINE

PURE RECURSIVE SUBROUTINE Sort_quick__S( list , order , left_end , right_end , max_simple_sort_size_ )
INCLUDE "03-A-SUB_Sort_quick__S.f90.hdr"
!
INCLUDE "03-A-SUB_Sort_quick_.f90.bdy"
!
END SUBROUTINE

END MODULE


program intrinsics_07
! Tests for kind()
integer, parameter :: sp = kind(0.0)
integer, parameter :: sp2 = kind(0.e0)
integer, parameter :: dp = kind(0.d0)
real(sp) :: a
real(dp) :: b
a = 5
b = a
end


module poisson_parameters
  use amr_parameters

  ! Convergence criterion for Poisson solvers
  real(dp)::epsilon=1.0D-4

  ! Type of force computation
  integer ::gravity_type=0

  ! Gravity parameters
  real(dp),dimension(1:10)::gravity_params=0.0

  ! Maximum level for CIC dark matter interpolation
  integer :: cic_levelmax=0

  ! Min level for CG solver
  ! level < cg_levelmin uses fine multigrid
  ! level >=cg_levelmin uses conjugate gradient
  integer :: cg_levelmin=999

  ! Gauss-Seidel smoothing sweeps for fine multigrid
  integer, parameter :: ngs_fine   = 2
  integer, parameter :: ngs_coarse = 2

  ! Number of multigrid cycles for coarse levels *in safe mode*
  !   1 is the fastest,
  !   2 is slower but can give much better convergence in some cases
  integer, parameter :: ncycles_coarse_safe = 1

end module poisson_parameters


module inflation
!$$$  module documentation block
!
! module: inflation           inflate posterior ensemble perturbations
!                             by an factor proportional to the amount
!                             the ensemble spread is reduced by the assimilation
!                             of observations.
!
! prgmmr: whitaker         org: esrl/psd               date: 2009-02-23
!
! abstract: posterior ensemble multiplicative inflation. The amount of
!  inflation is given at each analysis grid point by:
!
!  r = analpertwt*((stdev_prior-stdev_posterior)/stdev_posterior) + 1
!
!  where stdev_prior is the prior ensemble standard deviation,
!  stdev_posterior is posterior ensemble standard deviation
!  (before inflation), and r is inflation factor applied to each ensemble
!  member deviation from the ensemble mean.
!  if analpertwt=1, ensemble inflated so posterior standard deviation same as prior.
!  if analpertwt=0, there is no inflation.
!  analpertwt is a namelist parameter defined in module params.
!  The inflation factor can be different for each variable, level and horizontal
!  grid point and will in general be larger where observations are dense.
!
!  if the smoothing parameter (smoothparm) > 0, the estimated inflation
!  factor is smoothed using a Gaussian spectral filter with an efolding
!  scale of smoothparm.
!
!  The minimum and maximum values allowed can be controlled by the
!  namelist parameters covinflatemin and covinflatemax.
!
! Public Subroutines:
!  inflate_ens: apply inflation to the ensemble perturbations after
!   the EnKF analysis step.
!
! Public Variables: None
!
! Modules Used: mpisetup, params, kinds, covlocal, statevec, gridinfo, loadal
!
! program history log:
!   2009-02-23  Initial version.
! attributes:
!   language: f95
!
!$$$

use mpisetup
use params, only: analpertwtnh,analpertwtsh,analpertwttr,ndim,nanals,nlevs,ndim,&
                  latbound, delat, datapath, covinflatemax, save_inflation, &
                  covinflatemin, nlons, nlats, smoothparm, nbackgrounds, nvars
use kinds, only: r_single, i_kind
use constants, only: one, zero, rad2deg, deg2rad
use covlocal, only: latval
use statevec, only: anal_chunk, anal_chunk_prior
use gridinfo, only: latsgrd, logp, npts, nvarhumid
use loadbal, only: indxproc, numptsperproc, npts_max
use smooth_mod, only: smooth

implicit none

private
public :: inflate_ens

contains

subroutine inflate_ens()

integer(i_kind),parameter :: ndiag = 3
!  Currently 3 diagnostic areas (ndiag =3)
!  Area 1 northern hemisphere
!  Area 2 southern hemisphere
!  Area 3 tropics

real(r_single) sprdmin, sprdmax, sprdmaxall, &
  sprdminall, deglat,analpertwt, fsprd, asprd
real(r_single),dimension(ndiag) :: sumcoslat,suma,suma2,sumi,sumf,sumitot,sumatot, &
     sumcoslattot,suma2tot,sumftot
real(r_single) fnanalsml,coslat
integer(i_kind) i,nn,iunit,ierr,nb
character(len=500) filename
real(r_single), allocatable, dimension(:,:) :: tmp_chunk2,covinfglobal

! if no inflation called for, do nothing.
if (abs(analpertwtnh) < 1.e-5_r_single .and. &
    abs(analpertwttr) < 1.e-5_r_single .and. &
    abs(analpertwtsh) < 1.e-5_r_single) return

fnanalsml = one/(real(nanals-1,r_single))

nbloop: do nb=1,nbackgrounds ! loop over time levels in background

! if analpertwtnh<0 use 'relaxation-to-prior' ensemble inflation,
! as first described in:
! Zhang, F., C. Snyder, and J. Sun, 2004: Tests of an ensemble
! Kalman Filter for convective-scale data assim-imilation:
! Impact of initial estimate and observations.
! Mon. Wea. Rev., 132, 1238-1253.
if (analpertwtnh < 0) then
   do nn=1,ndim
    do i=1,numptsperproc(nproc+1)
      deglat = rad2deg*latsgrd(indxproc(nproc+1,i))
      ! coefficent can be different in NH, TR, SH.
      analpertwt = &
        latval(deglat,abs(analpertwtnh),abs(analpertwttr),abs(analpertwtsh))
      anal_chunk(:,i,nn,nb) = analpertwt*anal_chunk_prior(:,i,nn,nb) +&
        (one-analpertwt)*anal_chunk(:,i,nn,nb)
    end do
   end do
   cycle nbloop
end if

! adaptive posterior inflation based upon ratio of posterior to prior spread.
allocate(tmp_chunk2(npts_max,ndim))
tmp_chunk2 = covinflatemin

! compute inflation.
sumf = zero
suma = zero
sumcoslat = zero
sprdmax = -9.9e31_r_single
sprdmin = 9.9e31_r_single

do nn=1,ndim
 do i=1,numptsperproc(nproc+1)
   deglat = rad2deg*latsgrd(indxproc(nproc+1,i))

   ! compute stdev of prior and posterior.
   asprd = sum(anal_chunk(:,i,nn,nb)**2)*fnanalsml
   fsprd = sum(anal_chunk_prior(:,i,nn,nb)**2)*fnanalsml

   ! inflation proportional to posterior stdev reduction
   ! if analpertwt=1, ensemble inflated so posterior stdev same as prior.
   ! if analpertwt=0, no inflation.
   ! coefficent can be different in NH, TR, SH.
   analpertwt = latval(deglat,analpertwtnh,analpertwttr,analpertwtsh)
   fsprd = max(fsprd,tiny(fsprd))
   asprd = max(asprd,tiny(asprd))

   ! area mean surface pressure posterior and prior spread.
   ! (this diagnostic only makes sense for grids that are regular in longitude)
   if (nn == ndim) then
      coslat=cos(latsgrd(indxproc(nproc+1,i)))
      if (fsprd > sprdmax) sprdmax = fsprd
      if (fsprd < sprdmin) sprdmin = fsprd
      if (deglat > latbound) then
         suma(1) = suma(1) + asprd*coslat
         sumf(1) = sumf(1) + fsprd*coslat
         sumcoslat(1) = sumcoslat(1) + coslat
      else if (deglat < -latbound) then
         suma(2) = suma(2) + asprd*coslat
         sumf(2) = sumf(2) + fsprd*coslat
         sumcoslat(2) = sumcoslat(2) + coslat
      else
         suma(3) = suma(3) + asprd*coslat
         sumf(3) = sumf(3) + fsprd*coslat
         sumcoslat(3) = sumcoslat(3) + coslat
      end if
   end if

   fsprd = sqrt(fsprd); asprd = sqrt(asprd)
   ! clip values to avoid NaNs.
   asprd = max(asprd,tiny(asprd))
   fsprd = max(fsprd,tiny(fsprd))
   tmp_chunk2(i,nn) = analpertwt*((fsprd-asprd)/asprd) + 1.0

   ! min/max inflation set by covinflatemin/covinflatemax.
   tmp_chunk2(i,nn) = max(covinflatemin,min(tmp_chunk2(i,nn),covinflatemax))

 end do
end do

iunit = 88 ! inflation output file (used if save_inflation=.true.)
filename = trim(adjustl(datapath))//"covinflate.dat"
if (smoothparm .gt. zero) then
   ! inflation smoothing.
   ! (warning: this requires a lot of memory)
   allocate(covinfglobal(npts,ndim))
   covinfglobal=zero
   do i=1,numptsperproc(nproc+1)
      covinfglobal(indxproc(nproc+1,i),:) = tmp_chunk2(i,:)
   end do
   !call mpi_allreduce(mpi_in_place,covinfglobal,npts*ndim,mpi_real4,mpi_sum,mpi_comm_world,ierr)
   do nn=1,ndim
     call mpi_allreduce(mpi_in_place,covinfglobal(1,nn),npts,mpi_real4,mpi_sum,mpi_comm_world,ierr)
   enddo
   call smooth(covinfglobal)
   where (covinfglobal < covinflatemin) covinfglobal = covinflatemin
   where (covinfglobal > covinflatemax) covinfglobal = covinflatemax
   do i=1,numptsperproc(nproc+1)
      tmp_chunk2(i,:) = covinfglobal(indxproc(nproc+1,i),:)
   end do
   if(nproc == 0)then
      if(nvars>0) then
         print *,'min/max var 1 inflation = ',minval(covinfglobal(:,1:nlevs)),maxval(covinfglobal(:,1:nlevs))
         print *,'min/max var 2 inflation = ',minval(covinfglobal(:,nlevs+1:2*nlevs)),maxval(covinfglobal(:,nlevs+1:2*nlevs))
         print *,'min/max var 3 inflation = ',minval(covinfglobal(:,2*nlevs+1:3*nlevs)),maxval(covinfglobal(:,2*nlevs+1:3*nlevs))
         if (nvarhumid .gt. 0) then
         print *,'min/max spfh inflation = ',minval(covinfglobal(:,(nvarhumid-1)*nlevs+1:nvarhumid*nlevs)),&
              maxval(covinfglobal(:,(nvarhumid-1)*nlevs+1:nvarhumid*nlevs))
         endif
      endif
      print *,'min/max ps inflation = ',minval(covinfglobal(:,ndim)),maxval(covinfglobal(:,ndim))
      ! write out inflation.
      if (save_inflation) then
         open(iunit,form='unformatted',file=filename,access='direct',recl=npts*ndim*4)
         write(iunit,rec=1) covinfglobal
         close(iunit)
      endif
   end if
   deallocate(covinfglobal)
else if (save_inflation) then
   allocate(covinfglobal(npts,ndim))
   covinfglobal=zero
   do i=1,numptsperproc(nproc+1)
      covinfglobal(indxproc(nproc+1,i),:) = tmp_chunk2(i,:)
   end do
   do nn=1,ndim
     call mpi_allreduce(mpi_in_place,covinfglobal(1,nn),npts,mpi_real4,mpi_sum,mpi_comm_world,ierr)
   enddo
   if (nproc == 0) then
      open(iunit,form='unformatted',file=filename,access='direct',recl=npts*ndim*4)
      write(iunit,rec=1) covinfglobal
      close(iunit)
      deallocate(covinfglobal)
   endif
end if

suma2 = zero
sumi = zero

! apply inflation.
do nn=1,ndim
 do i=1,numptsperproc(nproc+1)

   ! inflate posterior perturbations.
   anal_chunk(:,i,nn,nb) = tmp_chunk2(i,nn)*anal_chunk(:,i,nn,nb)

   ! area mean surface pressure posterior spread, inflation.
   ! (this diagnostic only makes sense for grids that are regular in longitude)
   if (nn == ndim) then
      coslat=cos(latsgrd(indxproc(nproc+1,i)))
      deglat = rad2deg*latsgrd(indxproc(nproc+1,i))
      if (deglat > latbound) then
         suma2(1) = suma2(1) + &
         sum(anal_chunk(:,i,nn,nb)**2)*coslat*fnanalsml
         sumi(1) = sumi(1) + tmp_chunk2(i,nn)*coslat
      else if (deglat < -latbound) then
         suma2(2) = suma2(2) + &
         sum(anal_chunk(:,i,nn,nb)**2)*coslat*fnanalsml
         sumi(2) = sumi(2) + tmp_chunk2(i,nn)*coslat
      else
         suma2(3) = suma2(3) + &
         sum(anal_chunk(:,i,nn,nb)**2)*coslat*fnanalsml
         sumi(3) = sumi(3) + tmp_chunk2(i,nn)*coslat
      end if
   end if

 end do
end do

deallocate(tmp_chunk2)

! collect statistics of area mean inflation, posterior and prior standard deviation for ps.
call mpi_reduce(sprdmin,sprdminall,1,mpi_real4,mpi_min,0,mpi_comm_world,ierr)
call mpi_reduce(sprdmax,sprdmaxall,1,mpi_real4,mpi_max,0,mpi_comm_world,ierr)
call mpi_reduce(sumf,sumftot,ndiag,mpi_real4,mpi_sum,0,mpi_comm_world,ierr)
call mpi_reduce(sumi,sumitot,ndiag,mpi_real4,mpi_sum,0,mpi_comm_world,ierr)
call mpi_reduce(suma,sumatot,ndiag,mpi_real4,mpi_sum,0,mpi_comm_world,ierr)
call mpi_reduce(suma2,suma2tot,ndiag,mpi_real4,mpi_sum,0,mpi_comm_world,ierr)
call mpi_reduce(sumcoslat,sumcoslattot,ndiag,mpi_real4,mpi_sum,0,mpi_comm_world,ierr)
if (nproc == 0) then
   do i=1,ndiag
      if (sumcoslattot(i) .gt. 1.E-6 .and. sumftot(i) .gt. 1.E-6) then
         sumftot(i) = sqrt(sumftot(i)/sumcoslattot(i))
      else
         sumftot(i)=-99.0
      endif
      if (sumcoslattot(i) .gt. 1.E-6 .and. sumatot(i) .gt. 1.E-6) then
         sumatot(i) = sqrt(sumatot(i)/sumcoslattot(i))
      else
         sumatot(i)=-99.0
      endif
      if (sumcoslattot(i) .gt. 1.E-6 .and. suma2tot(i) .gt. 1.E-6) then
         suma2tot(i) = sqrt(suma2tot(i)/sumcoslattot(i))
      else
         suma2tot(i)=-99.0
      endif
      if (sumcoslattot(i) .gt. 1.E-6 .and. sumitot(i) .gt. 1.E-6) then
         sumitot(i) = sumitot(i)/sumcoslattot(i)
      else
         sumitot(i)=-99.0
      endif
   end do
   print *,'global ps prior std. dev min/max = ',sqrt(sprdminall),sqrt(sprdmaxall)
! NH first.
   if (sumcoslattot(1) .gt. tiny(sumcoslattot(1))) then
   print *,'NH mean ps prior standard deviation = ',sumftot(1)
   print *,'NH mean ps posterior standard deviation (before inflation)= ',sumatot(1)
   print *,'NH mean ps posterior standard deviation (after inflation) = ',suma2tot(1)
   print *,'NH mean ps inflation = ',sumitot(1)
   endif

! now SH.
   if (sumcoslattot(2) .gt. tiny(sumcoslattot(2))) then
   print *,'SH mean ps prior standard deviation = ',sumftot(2)
   print *,'SH mean ps posterior standard deviation (before inflation)= ',sumatot(2)
   print *,'SH mean ps posterior standard deviation (after inflation) = ',suma2tot(2)
   print *,'SH mean ps inflation = ',sumitot(2)
   endif
! now tropics.
   if (sumcoslattot(3) .gt. tiny(sumcoslattot(3))) then
   print *,'TR mean ps prior standard deviation = ',sumftot(3)
   print *,'TR mean ps posterior standard deviation (before inflation)= ',sumatot(3)
   print *,'TR mean ps posterior standard deviation (after inflation) = ',suma2tot(3)
   print *,'TR mean ps inflation = ',sumitot(3)
   endif
end if

end do nbloop ! end loop over time levels in background

end subroutine inflate_ens

end module inflation


      COMPLEX FUNCTION FBAR(P)
C
C     FBAR IS SOMMERFELD ATTENUATION FUNCTION FOR NUMERICAL DISTANCE P
C
      COMPLEX Z,ZS,SUM,POW,TERM,P,FJ
      DIMENSION FJX(2)
      EQUIVALENCE (FJ,FJX)
      DATA TOSP/1.128379167/,ACCS/1.E-12/,SP/1.772453851/,FJX/0.,1./
      Z=FJ*CSQRT(P)
      IF (CABS(Z).GT.3.) GO TO 3
C
C     SERIES EXPANSION
C
      ZS=Z*Z
      SUM=Z
      POW=Z
      DO 1 I=1,100
      POW=-POW*ZS/FLOAT(I)
      TERM=POW/(2.*I+1.)
      SUM=SUM+TERM
      TMS=REAL(TERM*CONJG(TERM))
      SMS=REAL(SUM*CONJG(SUM))
      IF (TMS/SMS.LT.ACCS) GO TO 2
1     CONTINUE
2     FBAR=1.-(1.-SUM*TOSP)*Z*CEXP(ZS)*SP
      RETURN
C
C     ASYMPTOTIC EXPANSION
C
3     IF (REAL(Z).GE.0.) GO TO 4
      MINUS=1
      Z=-Z
      GO TO 5
4     MINUS=0
5     ZS=.5/(Z*Z)
      SUM=(0.,0.)
      TERM=(1.,0.)
      DO 6 I=1,6
      TERM=-TERM*(2.*I-1.)*ZS
6     SUM=SUM+TERM
      IF (MINUS.EQ.1) SUM=SUM-2.*SP*Z*CEXP(Z*Z)
      FBAR=-SUM
      RETURN
      END


!
! Apodisation_Utility
!
! Module containing apodisation function routines.
!
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, 31-Oct-2006
!                       paul.vandelst@noaa.gov
!

MODULE Apodisation_Utility

  ! -----------------
  ! Environment setup
  ! -----------------
  ! Module usage
  USE Type_Kinds           , ONLY: fp
  USE Fundamental_Constants, ONLY: PI
  USE SPC_IFG_Utility      , ONLY: ComputeNSPC, &
                                   ComputeMeanDelta
  ! Disable implicit typing
  IMPLICIT NONE

  ! ----------
  ! Visibility
  ! ----------
  ! Everything is default private
  PRIVATE
  ! Parameters
  PUBLIC :: BARTLETT
  PUBLIC :: WELCH
  PUBLIC :: CONNES
  PUBLIC :: COSINE
  PUBLIC :: HAMMING
  PUBLIC :: HANNING
  PUBLIC :: NORTONBEER_WEAK
  PUBLIC :: NORTONBEER_MEDIUM
  PUBLIC :: NORTONBEER_STRONG
  PUBLIC :: BLACKMANHARRIS_3
  PUBLIC :: BLACKMANHARRIS_4
  PUBLIC :: BLACKMANHARRIS_4M
  PUBLIC :: BEER
  PUBLIC :: STRONGBEER
  PUBLIC :: HAPPGENZEL
  ! Procedures
  PUBLIC :: Apodisation_Function
  PUBLIC :: Apodisation_Utility_Version

  ! ----------
  ! Parameters
  ! ----------
  CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = &
  ! Message string length
  INTEGER, PARAMETER :: ML = 256
  ! Literal constants
  REAL(fp), PARAMETER :: ZERO      = 0.0_fp
  REAL(fp), PARAMETER :: POINT5    = 0.5_fp
  REAL(fp), PARAMETER :: ONE       = 1.0_fp
  REAL(fp), PARAMETER :: ONEPOINT5 = 1.5_fp
  REAL(fp), PARAMETER :: TWO       = 2.0_fp
  REAL(fp), PARAMETER :: TEN       = 10.0_fp
  ! Apodisation function coefficients
  !...Hamming apodfn coefficients
  REAL(fp), PARAMETER :: POINT46   = 0.46_fp
  REAL(fp), PARAMETER :: POINT54   = 0.54_fp
  !...Norton-Beer apodfn coefficients
  REAL(fp), PARAMETER :: NBC_WEAK(0:2)   = (/ 0.384093_fp, -0.087577_fp, 0.703484_fp /)
  REAL(fp), PARAMETER :: NBC_MEDIUM(0:2) = (/ 0.152442_fp, -0.136176_fp, 0.983734_fp /)
  REAL(fp), PARAMETER :: NBC_STRONG(0:3) = (/ 0.045335_fp,  ZERO       , 0.554883_fp, 0.399782_fp /)
  !...Blackman-Harris apodfn coefficients
  REAL(fp), PARAMETER :: BHC_3(0:2)  = (/ 0.42323_fp, 0.49755_fp, 0.07922_fp /)
  REAL(fp), PARAMETER :: BHC_4(0:3)  = (/ 0.35875_fp, 0.48829_fp, 0.14128_fp, 0.01168_fp /)
  REAL(fp), PARAMETER :: BHC_4M(0:3) = (/ 0.355766_fp, 0.487395_fp, 0.144234_fp, 0.012605_fp /)
  ! Apodisation function type values
  INTEGER,  PARAMETER :: BARTLETT          = 1
  INTEGER,  PARAMETER :: WELCH             = 2
  INTEGER,  PARAMETER :: CONNES            = 3
  INTEGER,  PARAMETER :: COSINE            = 4
  INTEGER,  PARAMETER :: HAMMING           = 5
  INTEGER,  PARAMETER :: HANNING           = 6
  INTEGER,  PARAMETER :: NORTONBEER_WEAK   = 7
  INTEGER,  PARAMETER :: NORTONBEER_MEDIUM = 8
  INTEGER,  PARAMETER :: NORTONBEER_STRONG = 9
  INTEGER,  PARAMETER :: BLACKMANHARRIS_3  = 10
  INTEGER,  PARAMETER :: BLACKMANHARRIS_4  = 11
  INTEGER,  PARAMETER :: BLACKMANHARRIS_4M = 12
  INTEGER,  PARAMETER :: BEER       = WELCH
  INTEGER,  PARAMETER :: STRONGBEER = CONNES
  INTEGER,  PARAMETER :: HAPPGENZEL = HAMMING

CONTAINS

!##################################################################################
!##################################################################################
!##                                                                              ##
!##                           ## PUBLIC MODULE ROUTINES ##                       ##
!##                                                                              ##
!##################################################################################
!##################################################################################

!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       Apodisation_Function
!
! PURPOSE:
!       Pure function to compute various apodisation functions.
!
! CALLING SEQUENCE:
!       y = Apodisation_Function(x, aType=aType, xMax=xMax)
!
! INPUTS:
!       x:      The regularly-spaced optical delay values for which the
!               apodisation function is to be computed.
!               UNITS:      centimetres.
!               TYPE:       REAL(fp)
!               DIMENSION:  Rank-1
!               ATTRIBUTES: INTENT(IN)
!
! OPTIONAL INPUTS:
!       aType:  Set this argument to the defined parameter values to
!               select the type of apodisation function.
!               If == BARTLETT          for Bartlett apodisation
!                  == WELCH             for Welch apodisation
!                  == CONNES            for Connes apodisation (DEFAULT)
!                  == COSINE            for Cosine apodisation
!                  == HAMMING           for Hamming apodisation
!                  == HANNING           for Hanning apodisation
!                  == NORTONBEER_WEAK   for weak Norton-Beer apodisation
!                  == NORTONBEER_MEDIUM for medium Norton-Beer apodisation
!                  == NORTONBEER_STRONG for strong Norton-Beer apodisation
!                  == BLACKMANHARRIS_3  for Blackman-Harris 3-term
!                  == BLACKMANHARRIS_4  for Blackman-Harris 4-term
!                  == BLACKMANHARRIS_4M for Blackman-Harris modified 4-term
!                  == BEER        alias for WELCH
!                  == STRONGBEER  alias for CONNES
!                  == HAPPGENZEL  alias for HAMMING
!               UNITS:      N/A
!               TYPE:       INTEGER
!               DIMENSION:  Scalar
!               ATTRIBUTES: INTENT(IN), OPTIONAL
!
!       xMax:   The maximum optical delay to use in calculating the
!               apodisation function.
!               - For x > xMax, the apodisation function is set to zero.
!               - If not specified MAXVAL(ABS(x)) is used.
!               UNITS:      centimetres
!               TYPE:       REAL(fp)
!               DIMENSION:  Scalar
!               ATTRIBUTES: INTENT(IN), OPTIONAL
!
! FUNCTION RESULT:
!       y:      Apodisation function.
!               UNITS:      N/A
!               TYPE:       REAL(fp)
!               DIMENSION:  Same as input x.
!
! COMMENTS:
!       The formulae for the above apodisation functions are taken from:
!
!         Weisstein, Eric W. "Apodization Function."
!         From MathWorld--A Wolfram Web Resource.
!         http://mathworld.wolfram.com/ApodizationFunction.html
!
!       and
!
!         Naylor,D.A. and M.K. Tahic, "Apodizing functions for Fourier
!         transform spectroscopy, J.Opt.Soc.Am.A 24(11):3644-3648, 2007
!
!:sdoc-:
!--------------------------------------------------------------------------------

  PURE FUNCTION Apodisation_Function( &
    x    , &
    aType, &
    xMax ) &
  RESULT(y)
    ! Arguments
    REAL(fp),           INTENT(IN) :: x(:)
    INTEGER,  OPTIONAL, INTENT(IN) :: aType
    REAL(fp), OPTIONAL, INTENT(IN) :: xMax
    ! Function result
    REAL(fp) :: y(SIZE(x))
    ! Local variables
    INTEGER  :: local_aType
    REAL(fp) :: local_xMax
    REAL(fp) :: tolerance
    REAL(fp) :: xnorm(SIZE(x))
    INTEGER :: i, n
    REAL(fp) :: nbc(0:3), bhc(0:3)

    ! Set the apodisation function type
    local_aType = -1 ! Force default
    IF ( PRESENT(aType) ) local_aType = aType

    ! Set the maximum optical path delay
    IF ( PRESENT(xMax) ) THEN
      local_xMax = ABS(xMax)
    ELSE
      local_xMax = MAXVAL(ABS(x))
    END IF

    ! Compute the normalised optical path delay
    xNorm = ABS(x)/local_xMax

    ! Compute apodisation function for +ve delays. The default
    ! apodisation function is CONNES
    SELECT CASE(local_aType)
      !...Some standard functions
      CASE(BARTLETT); y = ONE - xNorm
      CASE(WELCH)   ; y = ONE - xNorm**2
      CASE(COSINE)  ; y = COS(POINT5*PI*xNorm)
      CASE(HAMMING) ; y = POINT54 + (POINT46*COS(PI*xNorm))
      CASE(HANNING) ; y = POINT5*(ONE + COS(PI*xNorm))

      !...Norton-Beer series
      CASE(NORTONBEER_WEAK, NORTONBEER_MEDIUM, NORTONBEER_STRONG)
        SELECT CASE(local_aType)
          CASE(NORTONBEER_WEAK)  ; n = 2; nbc(0:n) = NBC_WEAK(0:n)
          CASE(NORTONBEER_MEDIUM); n = 2; nbc(0:n) = NBC_MEDIUM(0:n)
          CASE(NORTONBEER_STRONG); n = 3; nbc(0:n) = NBC_STRONG(0:n)
        END SELECT
        y = nbc(0)
        DO i = 1, n
          y = y + nbc(i)*(ONE - xNorm**2)**i
        END DO

      !...Blackman-Harris series
      CASE(BLACKMANHARRIS_3, BLACKMANHARRIS_4, BLACKMANHARRIS_4M)
        SELECT CASE(local_aType)
          CASE(BLACKMANHARRIS_3) ; n = 2; bhc(0:n) = BHC_3(0:n)
          CASE(BLACKMANHARRIS_4) ; n = 3; bhc(0:n) = BHC_4(0:n)
          CASE(BLACKMANHARRIS_4M); n = 3; bhc(0:n) = BHC_4M(0:n)
        END SELECT
        y = bhc(0)
        DO i = 1, n
          y = y + bhc(i)*COS(REAL(i,fp)*PI*xNorm)
        END DO

      !...Default is CONNES
      CASE DEFAULT  ; y = (ONE - xNorm**2)**2
    END SELECT

    ! Set out-of-bounds apodisation to zero
    tolerance = ComputeMeanDelta(x)/TEN
    WHERE ( ABS(x) > local_xMax+tolerance ) y = ZERO

  END FUNCTION Apodisation_Function

!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       Apodisation_Utility_Version
!
! PURPOSE:
!       Subroutine to return the module version information.
!
! CALLING SEQUENCE:
!       CALL Apodisation_Utility_Version( Id )
!
! OUTPUTS:
!       Id:   Character string containing the version Id information
!             for the module.
!             UNITS:      N/A
!             TYPE:       CHARACTER(*)
!             DIMENSION:  Scalar
!             ATTRIBUTES: INTENT(OUT)
!
!:sdoc-:
!--------------------------------------------------------------------------------

  SUBROUTINE Apodisation_Utility_Version( Id )
    CHARACTER(*), INTENT(OUT) :: Id
    Id = MODULE_VERSION_ID
  END SUBROUTINE Apodisation_Utility_Version

END MODULE Apodisation_Utility


module Dg_allDs
	! contains functions that compute the derivatives of the plastic potentials dg/dsigma
	! of the material model
	! and one main (model-indepenent) function that calls all dg/dsigma functions of the model
	! and returns the derivative vectors as an array

	use constants
	use material_info
	use derived_types
	use yf_all, only: comp_tsaiwu_tensors

    implicit none

contains

	function DgDs(sigma, alpha, yield_flags)
		! computes the derivatives (gradient vectors) of the plastic potentials
		! with respect to sigma
		! in case of multi surface plasticity the gradients of all plastic potentials
		! of the model must be computed in this subroutine
		implicit none

		! --------------------------------------------------------------------------
		! passed variables
		real(kind=dbl), dimension(6), intent(in) :: sigma					! stress vector
		real(kind=dbl), dimension(:), intent(in) :: alpha					! internal variables vector
		logical, dimension(:), intent(in) :: yield_flags			! active yield functions vector

		! return variable
		real(kind=dbl), dimension(6, n_yf) :: DgDs						! results array

		! internal variable
		! --------------------------------------------------------------------------

		! --------------------------------------
		! computation of all gradient vector (modified leon, ...)
		! --------------------------------------

		if (yield_flags(1) .eqv. .false.) then		! check if first yield function is active and if not skip computation of derivatives
			! first yield function is active
			! compute gradient vector of first plastic potential (mod leon)
			! and assign it to the first line of DgDsigma array

			DgDs(:,1) = Dg_1Ds(sigma, alpha)		! first plastic potential

		end if

!		if (yield_flags(2) .eqv. .false.) then		! check if second yield function is active and if not skip computation of derivatives
!			! second yield function is active
!			! compute gradient vector of second plastic potential (mod leon cut off)
!			! and assign it to the second line of DgDsigma array
!			DgDs(:,2) = Dg_2Ds(sigma, alpha)
!
!		end if

	end function DgDs

	function Dg_1Ds(sigma, alpha)
		! computes the gradient vector dg/dsigma for the first plastic potential g
		! derivatives of the tsaiwu yield function (associated flow rule) for the present case

		implicit none

		! --------------------------------------------------------------------------
		! return variable
		real(kind=dbl), dimension(6) :: Dg_1Ds

		! passed variables
		real(kind=dbl), dimension(6), intent(in) :: sigma						! stress vector
		real(kind=dbl), dimension(:), intent(in) :: alpha						! internal variables vector

		! internal variables
		real(kind=dbl), dimension(6) :: struc_vec				! transversely isotropic tsai-wu structural vector
		real(kind=dbl), dimension(6,6) :: struc_matrix			! transversely isotropic tsai-wu structural matrix
		! --------------------------------------------------------------------------

		! compute structural vector and matrix
		call comp_tsaiwu_tensors(struc_vec, struc_matrix)

		! compute tsaiwu gradient vector
		Dg_1Ds = struc_vec + 2._dbl*matmul(struc_matrix, sigma)

	end function Dg_1Ds

end module Dg_allDs


c
c
c
c     =====================================================
       subroutine qinit(meqn,mbc,mx,my,mz,xlower,ylower,zlower,
     &                  dx,dy,dz,q,maux,aux)
c     =====================================================
c
c     # Set initial conditions for q.
c
       implicit double precision (a-h,o-z)
c
       dimension   q(meqn,1-mbc:mx+mbc,1-mbc:my+mbc,1-mbc:mz+mbc)
       dimension aux(maux,1-mbc:mx+mbc,1-mbc:my+mbc,1-mbc:mz+mbc)
c
c
      do 215 i=1,mx
        xcell = xlower + (i-0.5d0)*dx
        do 210 j=1,my
          ycell = ylower + (j-0.5d0)*dy
          do 205 k=1,mz
            zcell = zlower + (k-0.5d0)*dz
	          r = dsqrt(xcell**2 + ycell**2 + zcell**2)
	          rho = 1.d0 + 10.0d0*dexp(-20*(r-0.0d0)**2)
	          q(1,i,j,k) = rho
	          q(2,i,j,k) = 0.d0
	          q(3,i,j,k) = 0.d0
	          q(4,i,j,k) = 0.d0
	          q(5,i,j,k) = rho
205       continue
210     continue
215   continue

      return
      end


module mod_param

 use decomp_2d

 implicit none

 !---- Parallelization ----!
 !                         !
 ! 2D (xy) decomposition   !

 integer, parameter :: ndims = 2
 integer, dimension(ndims), parameter :: dims = (/1,8/)

 !---- Discretization ----!
 !                        !
 ! wall normal: z or k    !
 ! streamwise:  y or j    !
 ! spanwise:    x or i    !

 !integer, parameter :: cellpD = 32  ! cells per diameter (droplet)
 !integer, parameter :: ktot = cellpD*3  ! total number of cells
 !integer, parameter :: jtot = cellpD*4
 !integer, parameter :: itot = cellpD*4

 integer, parameter :: ktot = 96, jtot = ktot, itot = 4, cellpD = 32  ! for some 2D tests

 integer, parameter :: imax = itot/dims(1), jmax = jtot/dims(2), kmax = ktot   ! process internal cells
 integer, parameter :: i1   = imax+1,       j1   = jmax+1,       k1   = kmax+1
 integer, parameter :: it1  = itot+1,       jt1  = jtot+1,       kt1  = ktot+1

 real, parameter :: lz = ktot/(cellpD*1.)  ! domain size
 real, parameter :: ly = jtot/(cellpD*1.)
 real, parameter :: lx = itot/(cellpD*1.)

 real, parameter :: dxi = itot/lx, dyi = jtot/ly, dzi = ktot/lz
 real, parameter :: dx  = 1./dxi,  dy  = 1./dyi,  dz  = 1./dzi  ! grid spacing

 real, parameter :: NarrowBand_1 = 3.*dz      ! cut-off band (not used)
 real, parameter :: NarrowBand_2 = 6.*dz      ! advection band (level set)

 !---- Constants ----!
 !                   !

 real, parameter :: timestep = 5e-4, CFL = timestep/dz

 real, parameter :: v_bulk_desired = 1.  ! desired streamwise bulk (mean) velocity
 real, parameter :: pi = acos(-1.), picon = acos(-1.)

 !---- Material Properties ----!
 !                             !
 ! non-dimensional             !
 ! reference phase: 1          !

 real, parameter :: miu1 = 1., rho1 = 1. ! DON'T change (by definition)
 real, parameter :: miu2 = miu1*1.e-1
 real, parameter :: rho2 = rho1*10.

 real :: rho_avr
 real, parameter :: rho0 = min(rho1,rho2)  ! constant density in FFT solver (Dodd & Ferrante)

 !---- Non-Dimensionalization ----!
 !                                !

 real, parameter :: Re  = 1e1	        ! Reynolds number = rho1*U*L/mu1
 real, parameter :: We  = 1e0      	! Weber number = rho1*U^2*L/sigma
 real, parameter :: iFr = 0.		! Froud number = U^2/gL, iFr is its inverse

 real, parameter :: visc = 1./Re	! 1/Re in the Navier-Stokes
 real, parameter :: Ca = We*visc	! Capillary number = sigma/(miu*U)
 real, parameter :: Reb = lz*Re	        ! rescale Re by lz (useless, kept for historical reasons)

 real, dimension(3), parameter :: g_unit = (/0.,0.,0./)
 ! unit vector of gravatational acceleration eg. /0.,0.,-1./

 !-----  Output Settings -----!
 !                            !
 ! output ? every iout? steps !

 integer, parameter :: ioutchk = 20, iout1d = 1/1
 integer, parameter :: iout2d  = 4000, iout3d = 10000
 integer, parameter :: ioutfld = 50000

 !---- Flow Field Settings ----!
 !                             !

 logical, parameter :: solveNS = .true.
 logical, parameter :: TwoD = .true.  ! 2D in y-z plane (dummy periodicity in x)
 logical, parameter :: ns_np = .true.  ! no-slip/no-penetration in z-dir
 logical, parameter :: constPoi = .true.  ! constant bulk flow (effective only if BC_in_y = Periodic)
 logical, parameter :: Riblet = .false.  ! internal Cartesian walls (stress IBM)
 logical, parameter :: stop_at_steady = .false.  ! check steady state (u,v,w,p) and stop if so

 character(len=3), parameter :: iniu = 'poi'
 !
 ! Initial velocity field:
 !
 ! 'zer' --> zero velocity everywhere
 ! 'uni' --> uniform streamwise flow
 ! 'poi' --> channel Poiseuille flow
 ! 'cou' --> plane Couette flow
 ! 'sep' --> Serpentine 2D deformation vortex
 ! 'rot' --> 2D rigid-body rotation, not working
 ! '2lc' --> 2-parallel-mixing-layer (w/ wall normal noise)
 ! 'log' --> logarithmic profile + random noise
 ! 'fld' --> load and initialize from fld_init in datadir
 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

 character(len=8), parameter :: BC_in_y = 'Periodic'
 !
 ! Boundary condition in the y direction,
 ! which determines the pressure solver.
 !
 ! 'Periodic' --> periodic
 ! 'InOut'    --> inflow/outflow
 ! 'OutOut'   --> outflow/outflow (open boundaries)
 ! 'Walls'    --> two walls
 ! (By default, x is periodic, z is wall-bounded)
 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

 character(len=8), parameter :: BC_in_z = 'Dirichl'
 !
 ! Boundary condition in the z direction:
 !
 ! 'Dirichl' --> Dirichlet BC (prescribed velocity)
 ! 'shr-drv' --> shear-driven (mixed Dirichlet & Neumann)
 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

 character(len=5), parameter :: NS_conv = 'CNTR2'
 !
 ! Spatial discretization for the NS convective terms:
 !
 ! 'CNTR2' --> 2nd order central difference
 ! 'WENO5' --> 5th order Weighted ENO
 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

 character(len=3), parameter :: surface_tension_method = 'GFM'
 !
 ! Computation of surface tension:
 !
 ! 'CSF' --> Continuum Surface Force
 ! 'GFM' --> Ghost Fluid Method
 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

 character(len=3), parameter :: NS_diff_discretization = 'del'
 !
 ! Spatial discretization for the NS diffusion terms:
 !
 ! 'del' --> Dirac delta formulation (some smearing)
 ! 'GFM' --> Ghost fluid method (inaccurate and unrobust)
 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

 !---- Level Set Settings ----!
 !                            !

 logical, parameter :: solveLS = .true.
 logical, parameter :: re_initialization = .true.
 logical, parameter :: mass_correction = .true.
 logical, parameter :: attractive = .false.  ! MLS-GFM depletion attraction
 logical, parameter :: Contact_line = .false.
 logical, parameter :: open_end_in_y = .false.  ! if not enclosed

 integer, parameter :: lmax = 2  ! number of multiple level sets

 character(len=3), parameter :: inil = 'mpc'
 !
 ! Initial level set field:
 !
 ! 'zal' --> Zalesak's disk
 ! 'elp' --> Distorted ellipse
 ! '2lc' --> 2-parallel-mixing-layer
 ! 'sin' --> small amplitute sin-wave
 ! 'mpc' --> multiple pancakes (MLS) in y-z plane
 ! 'mdp' --> multiple spherical droplets (MLS)
 ! 'hdm' --> Hadamard's solution for a spherical droplet
 ! 'pan','2pc','3pc' --> 1 or 2 or 3 pancake(s) (SLS) in y-z plane
 ! 'drp','2dp','3dp' --> 1 or 2 or 3 spherical droplet(s) (SLS)
 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

 !----  Miscenalleous  ----!
 !                         !

 character(len=5), parameter :: datadir = 'data/'
 character(len=5), parameter :: partdir = 'part/'

end module mod_param

module mod_param_ls
  !
  ! More settings for level set
  !~~~~~~~~~~~~~~~~~~~~~~~~~~~~

  implicit none

  !-- Advection --!
  !               !
  character(len=3), parameter :: ls_adv_time = 'RK3'
  !
  ! Temporal integration of level set advection:
  !
  ! 'RK2' --> 2nd order mid-point Runge-Kutta
  ! 'RK3' --> 3rd order SSP Runge-Kutta
  !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

  character(len=8), parameter :: ls_adv_space = 'HOUC5'
  !
  ! Spatial discretization of level set gradient:
  !
  ! 'HOUC5'    --> 5th order High-Order Upstream Central
  ! 'HOUC5rib' --> HOUC5 for Riblet
  ! 'WENO5'    --> 5th order Weighted ENO
  ! 'mWENO5c'  --> Modified WENO5 (conservative form)
  ! 'mWENO5nc' --> Modified WENO5 (non-conservative)
  ! 'semiLag'  --> Semi-Lagrangian (NOT recommended)
  !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

  !-- Reinitialization --!
  !                      !
  integer, parameter :: reinit_step = 20
  ! Frequency of reinitialization (depends on CFL, marching speed = 1)

  integer, parameter :: reinit_iter_max = 1
  ! Maximum number of reinitialization iterations (pseudo time steps)

  character(len=3), parameter :: ls_reinit_time = 'RK3'
  !
  ! Temporal integration of level set reinitialization:
  !
  ! 'EU1' --> 1st order forward Euler
  ! 'RK2' --> 2nd order mid-point Runge-Kutta
  ! 'RK3' --> 3rd order SSP Runge-Kutta
  !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

  character(len=6), parameter :: ls_reinit_space = 'WENO5'
  !
  ! Spatial discretization of level set gradient:
  !
  ! 'RUSM1'  --> 1st order subcell fix by Russo & Smereka
  ! 'RUSM2'  --> 2nd order subcell fix by Russo & Smereka
  ! 'RUSM4'  --> 4th order subcell fix by Russo & Smereka (NOT working)
  ! 'WENO5'  --> 5th order Weighted ENO (classical)
  ! 'WENO5z' --> WENO5-Z (Brazil)
  !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

  !-- Mass correction --!
  !                     !
  integer, parameter :: inflate_step = 1*reinit_step
  character(len=4), parameter :: ispeed_dependence = 'curv'
  !                                         !
  ! Dependence of the correction velocity:  !
  !                                         !
  ! 'unfm' --> uniform                      !
  ! 'curv' --> proportional to curvature    !
  !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!
  character(len=6), parameter :: i_space = 'HOUC5'
  !
  ! Spatial discretization of level set gradient:
  !
  ! 'HOUC5' --> 5th order High-Order Upstream Central
  ! 'WENO5' --> 5th order Weighted ENO
  !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

end module mod_param_ls


*DECK DBDIFF
      SUBROUTINE DBDIFF (L, V)
C***BEGIN PROLOGUE  DBDIFF
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DBSKIN
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (BDIFF-S, DBDIFF-D)
C***AUTHOR  Amos, D. E., (SNLA)
C***DESCRIPTION
C
C     DBDIFF computes the sum of B(L,K)*V(K)*(-1)**K where B(L,K)
C     are the binomial coefficients.  Truncated sums are computed by
C     setting last part of the V vector to zero. On return, the binomial
C     sum is in V(L).
C
C***SEE ALSO  DBSKIN
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   820601  DATE WRITTEN
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C***END PROLOGUE  DBDIFF
C
      INTEGER I, J, K, L
      DOUBLE PRECISION V
      DIMENSION V(*)
C***FIRST EXECUTABLE STATEMENT  DBDIFF
      IF (L.EQ.1) RETURN
      DO 20 J=2,L
        K = L
        DO 10 I=J,L
          V(K) = V(K-1) - V(K)
          K = K - 1
   10   CONTINUE
   20 CONTINUE
      RETURN
      END