C     LAST UPDATE 10/12/92
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE SVDCMP(A,M,N,MP,NP,W,V)
      IMPLICIT NONE
C
C Purpose: Given a matrix A with logical dimensions M by N and physical
C          dimensions MP by NP, this routine computes its singular value
C          decomposition, A = U.W.V(T). The matrix U replaces A on output.
C          The diagonal matrix of singular values W is output as a
C          vector W . The matrix V (not transpose(V)) is output as V. M
C          must be greater than or equal to N; if it is smaller, then A
C          should be filled up to square with zero rows.
C
      INTEGER M,N,MP,NP
      REAL A(MP,NP),W(NP),V(NP,NP)
C
C Calls   0:
C Called by:
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C Local variables:
C
      INTEGER NMAX
      PARAMETER(NMAX=5000)
      REAL RV1(NMAX)
      REAL S,F,G,H,C,X,Y,Z,ANORM,SCALE,TOL
      PARAMETER(TOL=1.0E-06)
      INTEGER I,J,K,L,NM,ITS,JJ
C
C---------------------------------------------------------------------
      G = 0.0
      SCALE = 0.0
      ANORM = 0.0
      DO 150 I=1,N
         L = I + 1
         RV1(I) = SCALE*G
         G = 0.0
         S = 0.0
         SCALE = 0.0
         IF(I.LE.M)THEN
            DO 10 K=I,M
               SCALE = SCALE + ABS(A(K,I))
 10         CONTINUE
            IF(ABS(SCALE).GT.0.0)THEN
               DO 20 K=I,M
                  A(K,I) = A(K,I)/SCALE
                  S = S + A(K,I)*A(K,I)
 20            CONTINUE
               F = A(I,I)
               G = -SIGN(SQRT(S),F)
               H = F*G - S
               A(I,I) = F - G
               IF(I.NE.N)THEN
                  DO 50 J=L,N
                     S = 0.0
                     DO 30 K=I,M
                        S = S + A(K,I)*A(K,J)
 30                  CONTINUE
                     F = S/H
                     DO 40 K=I,M
                        A(K,J) = A(K,J) + F*A(K,I)
 40                  CONTINUE
 50               CONTINUE
               ENDIF
               DO 60 K=I,M
                  A(K,I) = SCALE*A(K,I)
 60            CONTINUE
            ENDIF
         ENDIF
         W(I) = SCALE*G
         G = 0.0
         S = 0.0
         SCALE = 0.0
         IF((I.LE.M).AND.(I.NE.N))THEN
            DO 70 K=L,N
               SCALE = SCALE + ABS(A(I,K))
 70         CONTINUE
            IF(ABS(SCALE).GT.0.0)THEN
               DO 80 K=L,N
                  A(I,K) = A(I,K)/SCALE
                  S = S + A(I,K)*A(I,K)
 80            CONTINUE
               F = A(I,L)
               G = -SIGN(SQRT(S),F)
               H = F*G - S
               A(I,L) = F - G
               DO 90 K=L,N
                  RV1(K) = A(I,K)/H
 90            CONTINUE
               IF(I.NE.M)THEN
                  DO 130 J=L,M
                     S = 0.0
                     DO 110 K=L,N
                        S = S + A(J,K)*A(I,K)
 110                 CONTINUE
                     DO 120 K=L,N
                        A(J,K) = A(J,K) + S*RV1(K)
 120                 CONTINUE
 130              CONTINUE
               ENDIF
               DO 140 K=L,N
                  A(I,K) = SCALE*A(I,K)
 140           CONTINUE
            ENDIF
         ENDIF
         ANORM = MAX(ANORM,(ABS(W(I))+ABS(RV1(I))))
 150  CONTINUE
      DO 220 I=N,1,-1
         IF(I.LT.N)THEN
            IF(ABS(G).GT.0.0)THEN
               DO 160 J=L,N
                  V(J,I) = (A(I,J)/A(I,L))/G
 160           CONTINUE
               DO 190 J=L,N
                  S = 0.0
                  DO 170 K=L,N
                     S = S + A(I,K)*V(K,J)
 170              CONTINUE
                  DO 180 K=L,N
                     V(K,J) = V(K,J) + S*V(K,I)
 180              CONTINUE
 190           CONTINUE
            ENDIF
            DO 210 J=L,N
               V(I,J) = 0.0
               V(J,I) = 0.0
 210        CONTINUE
         ENDIF
         V(I,I) = 1.0
         G = RV1(I)
         L = I
 220  CONTINUE
      DO 290 I=N,1,-1
         L = I + 1
         G = W(I)
         IF(I.LT.N)THEN
            DO 230 J=L,N
               A(I,J) = 0.0
 230        CONTINUE
         ENDIF
         IF(ABS(G).GT.0.0)THEN
            G = 1.0/G
            IF(I.NE.N)THEN
               DO 260 J=L,N
                  S = 0.0
                  DO 240 K=L,M
                     S = S + A(K,I)*A(K,J)
 240              CONTINUE
                  F = (S/A(I,I))*G
                  DO 250 K=I,M
                     A(K,J) = A(K,J) + F*A(K,I)
 250              CONTINUE
 260           CONTINUE
            ENDIF
            DO 270 J=I,M
               A(J,I) = A(J,I)*G
 270        CONTINUE
         ELSE
            DO 280 J=I,M
               A(J,I) = 0.0
 280        CONTINUE
         ENDIF
         A(I,I) = A(I,I) + 1.0
 290  CONTINUE
      DO 390 K=N,1,-1
         DO 380 ITS=1,50
            DO 310 L=K,1,-1
               NM = L - 1
               IF((ABS(RV1(L))+ANORM).LT.(1.0+TOL)*ANORM) GOTO 2
               IF((ABS(W(NM))+ANORM).LT.(1.0+TOL)*ANORM) GOTO 1
 310        CONTINUE
 1          C = 0.0
            S = 1.0
            DO 330 I=L,K
               F = S*RV1(I)
               RV1(I) = C*RV1(I)
               IF((ABS(F)+ANORM).LT.(1.0+TOL)*ANORM) GOTO 2
               G = W(I)
               H = SQRT(F*F+G*G)
               W(I) = H
               H = 1.0/H
               C = G*H
               S = -F*H
               DO 320 J=1,M
                  Y = A(J,NM)
                  Z = A(J,I)
                  A(J,NM) = Y*C + Z*S
                  A(J,I) = -Y*S + Z*C
 320           CONTINUE
 330        CONTINUE
 2          Z = W(K)
            IF(L.EQ.K)THEN
               IF(Z.LT.0.0)THEN
                  W(K) = -Z
                  DO 340 J=1,N
                     V(J,K) = -V(J,K)
 340              CONTINUE
               ENDIF
               GOTO 3
            ENDIF
            IF(ITS.EQ.50)WRITE(6,1000)
            X = W(L)
            NM = K - 1
            Y = W(NM)
            G = RV1(NM)
            H = RV1(K)
            F = ((Y-Z)*(Y+Z)+(G-H)*(G+H))/(2.0*H*Y)
            G = SQRT(F*F+1.0)
            F = ((X-Z)*(X+Z)+H*((Y/(F+SIGN(G,F)))-H))/X
            C = 1.0
            S = 1.0
            DO 370 J=L,NM
               I = J + 1
               G = RV1(I)
               Y = W(I)
               H = S*G
               G = G*C
               Z = SQRT(F*F+H*H)
               RV1(J) = Z
               C = F/Z
               S = H/Z
               F = X*C + G*S
               G = -X*S + G*C
               H = Y*S
               Y = Y*C
               DO 350 JJ=1,N
                  X = V(JJ,J)
                  Z = V(JJ,I)
                  V(JJ,J) = X*C + Z*S
                  V(JJ,I) = Z*C - X*S
 350           CONTINUE
               Z = SQRT(F*F+H*H)
               W(J) = Z
               IF(ABS(Z).GT.0.0)THEN
                  Z = 1.0/Z
                  C = F*Z
                  S = H*Z
               ENDIF
               F = C*G + S*Y
               X = C*Y - S*G
               DO 360 JJ=1,M
                  Y = A(JJ,J)
                  Z = A(JJ,I)
                  A(JJ,J) = Y*C + Z*S
                  A(JJ,I) = Z*C - Y*S
 360           CONTINUE
 370        CONTINUE
            RV1(L) = 0.0
            RV1(K) = F
            W(K) = X
 380     CONTINUE
 3       CONTINUE
 390  CONTINUE
      RETURN
 1000 FORMAT(1X,'GSSVD: Warning - no convergence in 50 iterations')
      END


!! This applies general non-homogeneous boundary conditions by
!! modifying the right hand side side with non-zero corrections.
!!
!! If cons_check == 0 :  Apply inhomogeneous boundary conditions
!! If cons_check == 1 :  Sum up fluxes around the boundary
!!
!! The general boundary conditions can be written as
!!
!!        a(x,y)*q(x,y) + b(x,y)*q_n(x,y) = g(x,y)
!!
!! on the boundary of a square domain.  Below, we only implement the
!! case a = 1 or b = 1 (but not both).  This can be easily modified following
!! the comments below.
!!
!! The approach below requires that the term
!!
!!        (a(x,y)/2.d0 + b(x,y)/h)
!!
!! where h = dx or h = dy, is non-zero.
!!

subroutine heat_fort_apply_bc(blockno, mx, my,mbc,mfields,xlower,ylower, &
    dx,dy,t,intersects_bc,bctype,rhs,g_bc,cons_check,flux_sum)

    implicit none

    integer blockno, mx,my,mbc,mfields,intersects_bc(0:3),bctype(0:3)
    integer cons_check
    double precision xlower,ylower,dx,dy,t,g_bc, flux_sum(mfields)
    double precision rhs(1-mbc:mx+mbc,1-mbc:my+mbc,mfields)

    !! Dummy arrays needed to apply boundary conditions
    double precision qh(1-mbc:mx+mbc,1-mbc:my+mbc,mfields)
    double precision beta(1-mbc:mx+mbc,1-mbc:my+mbc,3)

    integer i,j, m, iface, idir, i1, ig, ic, j1, jg, jc
    double precision d, h, x, y, g
    double precision a,b
    double precision flux(0:3)
    double precision uI, dI
    integer count

    logical ccheck

    ccheck = cons_check .ne. 0

    do m = 1,mfields

        !! Homogeneous array;  this is overkill - we don't need the entire array.
        do i = 1-mbc,mx+mbc
            do j = 1-mbc,my+mbc
                qh(i,j,m) = 0
            end do
        end do

        do iface = 0,3
            if (intersects_bc(iface) .ne. 0) then
                idir = iface/2   !! direction : 0 or 1

                !! customize this for more general boundary conditions
                if (bctype(iface) .eq. 1) then
                    a = 1
                    b = 0
                elseif (bctype(iface) .eq. 2) then
                    a = 0
                    b = 1
                endif

                if (idir == 0) then
                    h = dx
                else
                    h = dy
                endif

                !! Discretize the boundary conditions as :
                !!
                !!     a*(qI + qg)/2 + b*(qg - qI)/ds = g
                !!
                !! where gI is the interior q values and qg is
                !! the ghost cell value.  Solve for qg :
                !!
                !!     qg = (g - d1*qI)/d2
                !!
                !!     d1 = (a/2 - b/h)
                !!     d2 = (a/2 + b/h)  !! == d in code below
                !!
                !! Here, we set qg = g/d2
                dI = (a/2.d0 - b/h)  !! Needed for cons check
                d = (a/2.d0 + b/h)
                if (d .eq. 0) then
                    write(6,*) 'heat_fort_apply_bc : ill-defined BCs'
                    stop
                endif

                if (idir .eq. 0) then
                    if (iface .eq. 0) then
                        ic = 1  !! cell center
                        i1 = 1
                        ig = 0
                    elseif (iface .eq. 1) then
                        ic = mx  !! cell center
                        i1 = mx+1
                        ig = mx+1
                    endif
                    !! location at interface
                    x = xlower + (i1 - 1)*dx

                    do j = 1,my
                        y = ylower + (j-0.5)*dy

                        !! inhomogeneity
                        g = g_bc(iface,t,x,y)

                        !! Assume uI == 0
                        uI = 0
                        if (ccheck) then
                            uI = rhs(ic,j,m)
                        endif
                        qh(ig,j,m) = (g - dI*uI)/d
                    end do
                elseif (idir .eq. 1) then
                    if (iface .eq. 2) then
                        jc = 1
                        j1 = 1
                        jg = 0
                    elseif (iface .eq. 3) then
                        jc = my
                        j1 = my+1
                        jg = my+1
                    endif
                    !! location at interface
                    y = ylower + (j1 - 1)*dy

                    do i = 1,mx
                        x = xlower + (i-0.5)*dx

                        !! inhomogeneity
                        g = g_bc(iface,t,x,y)

                        uI = 0
                        if (ccheck) then
                            uI = rhs(i,jc,m)
                        endif

                        qh(i,jg,m) = (g - dI*uI)/d
                    end do
                endif
            endif
        end do

        !! Ghost cells now all filled in.  Now apply variable coefficent
        !! Laplace operator

        if (intersects_bc(0) .ne. 0) then
            do j = 1,my
                if (ccheck) then
                    flux(0) = (rhs(1,j,m) - qh(0,j,m))/dx
                    flux_sum(m) = flux_sum(m) - flux(0)*dy
                else
                    flux(0) = (qh(1,j,m) - qh(0,j,m))/dx
                    rhs(1,j,m) = rhs(1,j,m) - (-flux(0)/dx)
                endif
            end do
        endif

        if (intersects_bc(1) .ne. 0) then
            do j = 1,my
                if (ccheck) then
                    flux(1) = (qh(mx+1,j,m) - rhs(mx,j,m))/dx
                    flux_sum(m) = flux_sum(m) + flux(1)*dy
                else
                    flux(1) = (qh(mx+1,j,m) - qh(mx,j,m))/dx
                    rhs(mx,j,m) = rhs(mx,j,m) - (flux(1)/dx)
                endif
            end do
        endif

        if (intersects_bc(2) .ne. 0) then
            do i = 1,mx
                if (ccheck) then
                    flux(2) = (rhs(i,1,m) - qh(i,0,m))/dy
                    flux_sum(m) = flux_sum(m) - flux(2)*dx
                else
                    flux(2) = (qh(i,1,m) - qh(i,0,m))/dy
                    rhs(i,1,m) = rhs(i,1,m) - (-flux(2)/dy)
                endif
            end do
        endif

        if (intersects_bc(3) .ne. 0) then
            do i = 1,mx
                if (ccheck) then
                    flux(3) = (qh(i,my+1,m) - rhs(i,my,m))/dy
                    flux_sum(m) = flux_sum(m) + flux(3)*dx
                else
                    flux(3) = (qh(i,my+1,m) - qh(i,my,m))/dy
                    rhs(i,my,m) = rhs(i,my,m) - (flux(3)/dy)
                endif
            end do
        endif

    end do

end subroutine heat_fort_apply_bc


*dk inside_element
      subroutine inside_element(ielmtyp,
     &                          xicelm,yicelm,zicelm,
     &                          xtestpt,ytestpt,ztestpt,
     &                          iflag)
C
C
C#######################################################################
C
C      PURPOSE -
C
C         THIS ROUTINE FINDS WHETHER OR NOT THE TEST POINT (xtestpt,
C         ytestpt, ztestpt) IS WITHIN OR ON A FACE OF THE ELEMENT
C         DEFINED BY ielmtyp AND THE VERTICES xicelm(),yicelm(),zicelm()
C
C
C     ******************************************************************
C
C      INPUT ARGUMENTS -
C
C        ielmtyp                     - THE ELEMENT TYPE.
C        xicelm(),yicelm(),zicelm()  - THE COORDINATES OF THE ELEMENT.
C        xtestpt,ytestpt,ztestpt     - THE COORDINATES OF THE POINT
C                                      IN QUESTION.
C
C        iflag is used to pass in idebug values to inside_ routines
C        idebug is passed as 0 for values less than idebug_min
C        as these routines are called often and usually for every point
C
C     OUTPUT ARGUMENTS -
C
C        iflag  - RETURNS -1 IF THE TEST POINT IS OUTSIDE THE ELEMENT,
C                 0 IF IT IS INSIDE THE ELEMENT, OR A POSITIVE NUMBER
C                 CORRESPONDING TO THE FACE OF THE ELEMENT IT IS ON.
C
C
C     $Log: inside_element.f,v $
C     Revision 2.00  2007/11/05 19:45:58  spchu
C     Import to CVS
C
CPVCS
CPVCS       Rev 1.2   03 Jan 2007 10:59:38   tam
CPVCS    make implicit none, write value of iflag if debug
CPVCS    pass itmp instead of iflag to maintain iflag value
CPVCS
CPVCS       Rev 1.1   22 Mar 2000 08:40:06   dcg
CPVCS     use local_epsilon in place of epsilon
CPVCS
CPVCS       Rev 1.0   Tue Aug 03 15:27:50 1999   bap
CPVCS    Initial revision.
C
C#######################################################################
C
C     Standard Declarations for this module.
C
C#######################################################################
C
C
C     implicit real*8 (a-h,o-z)
      implicit none
C
      character*132 logmess
C
      include "local_element.h"
C
      real*8 xicelm(1000000), yicelm(1000000), zicelm(1000000)
      real*8 local_epsilon
      real*8 dist_ab, dist_atestpt, dist_btestpt
      real*8 xtestpt, ytestpt, ztestpt
C
      integer ielmtyp
      integer iflag, itmp, ierror, idebug, idebug_min
C
C     ******************************************************************
C     Initialize Variables
C
      local_epsilon = 1.0e-10
C
C#######################################################################
C
C     Start finding out what is what
C
C#######################################################################
C
C
C     set the min value that will trigger iformation from routines
      idebug_min = 9
      idebug = iflag
      iflag = 0

      if(ielmtyp.eq.ifelmpnt) then
         if((abs(xicelm(1)-xtestpt).lt.local_epsilon).AND.
     &      (abs(yicelm(1)-ytestpt).lt.local_epsilon).AND.
     &      (abs(zicelm(1)-ztestpt).lt.local_epsilon)) then
            iflag=0
         else
            iflag=-1
         endif
      elseif(ielmtyp.eq.ifelmlin) then
         dist_ab = sqrt((xicelm(1)-xicelm(2))**2+
     &                  (yicelm(1)-yicelm(2))**2+
     &                  (zicelm(1)-zicelm(2))**2)
         dist_atestpt = sqrt((xicelm(1)-xtestpt)**2+
     &                       (yicelm(1)-ytestpt)**2+
     &                       (zicelm(1)-ztestpt)**2)
         dist_btestpt = sqrt((xicelm(2)-xtestpt)**2+
     &                       (yicelm(2)-ytestpt)**2+
     &                       (zicelm(2)-ztestpt)**2)
         if(abs(dist_ab-(dist_atestpt+dist_btestpt)).lt.
     &      (local_epsilon*dist_ab)) then
            iflag = 0
         else
            iflag = -1
         endif
C
C     Definition of inside a triangle or a quad exists such that
C     the point must be in the same plane as the triangle in question.
C     So, the first call ensures that the point is in the plane,
C
      elseif(ielmtyp.eq.ifelmtri) then
         itmp=idebug
         if (idebug.lt. idebug_min) itmp=0
         call inside_tri(xicelm(1),yicelm(1),zicelm(1),
     &                     xicelm(2),yicelm(2),zicelm(2),
     &                     xicelm(3),yicelm(3),zicelm(3),
     &                     xtestpt,ytestpt,ztestpt,itmp)
         if(itmp.le.0) then
            iflag = -1
            goto 9999
         endif
         itmp=idebug
         if (idebug.lt. idebug_min) itmp=0
         call inside_tri2d(xicelm(1),yicelm(1),zicelm(1),
     &                     xicelm(2),yicelm(2),zicelm(2),
     &                     xicelm(3),yicelm(3),zicelm(3),
     &                     xtestpt,ytestpt,ztestpt,itmp)
         iflag=itmp
      elseif(ielmtyp.eq.ifelmqud) then
         itmp=idebug
         if (idebug.lt. idebug_min) itmp=0
         call inside_quad(xicelm(1),yicelm(1),zicelm(1),
     &                      xicelm(2),yicelm(2),zicelm(2),
     &                      xicelm(3),yicelm(3),zicelm(3),
     &                      xicelm(4),yicelm(4),zicelm(4),
     &                      xtestpt,ytestpt,ztestpt,itmp)
         if(itmp.le.0) then
            iflag = -1
            goto 9999
         endif
         itmp=idebug
         if (idebug.lt. idebug_min) itmp=0
         call inside_quad2d(xicelm(1),yicelm(1),zicelm(1),
     &                      xicelm(2),yicelm(2),zicelm(2),
     &                      xicelm(3),yicelm(3),zicelm(3),
     &                      xicelm(4),yicelm(4),zicelm(4),
     &                      xtestpt,ytestpt,ztestpt,itmp)
         iflag=itmp
      elseif(ielmtyp.eq.ifelmtet) then
         itmp=idebug
         if (idebug.lt. idebug_min) itmp=0
         call inside_tet(xicelm(1),yicelm(1),zicelm(1),
     &                   xicelm(2),yicelm(2),zicelm(2),
     &                   xicelm(3),yicelm(3),zicelm(3),
     &                   xicelm(4),yicelm(4),zicelm(4),
     &                   xtestpt,ytestpt,ztestpt,itmp)
         iflag=itmp
      elseif(ielmtyp.eq.ifelmpyr) then
         itmp=idebug
         if (idebug.lt. idebug_min) itmp=0
         call inside_pyr(xicelm(1),yicelm(1),zicelm(1),
     &                   xicelm(2),yicelm(2),zicelm(2),
     &                   xicelm(3),yicelm(3),zicelm(3),
     &                   xicelm(4),yicelm(4),zicelm(4),
     &                   xicelm(5),yicelm(5),zicelm(5),
     &                   xtestpt,ytestpt,ztestpt,itmp)
         iflag=itmp
      elseif(ielmtyp.eq.ifelmpri) then
         itmp=idebug
         if (idebug.lt. idebug_min) itmp=0
         call inside_pri(xicelm(1),yicelm(1),zicelm(1),
     &                   xicelm(2),yicelm(2),zicelm(2),
     &                   xicelm(3),yicelm(3),zicelm(3),
     &                   xicelm(4),yicelm(4),zicelm(4),
     &                   xicelm(5),yicelm(5),zicelm(5),
     &                   xicelm(6),yicelm(6),zicelm(6),
     &                   xtestpt,ytestpt,ztestpt,itmp)
         iflag=itmp
      elseif(ielmtyp.eq.ifelmhex) then
         itmp=idebug
         if (idebug.lt. idebug_min) itmp=0
         call inside_hex(xicelm(1),yicelm(1),zicelm(1),
     &                   xicelm(2),yicelm(2),zicelm(2),
     &                   xicelm(3),yicelm(3),zicelm(3),
     &                   xicelm(4),yicelm(4),zicelm(4),
     &                   xicelm(5),yicelm(5),zicelm(5),
     &                   xicelm(6),yicelm(6),zicelm(6),
     &                   xicelm(7),yicelm(7),zicelm(7),
     &                   xicelm(8),yicelm(8),zicelm(8),
     &                   xtestpt,ytestpt,ztestpt,itmp)
         iflag=itmp
      else
         iflag=0
         write(logmess,9010) ielmtyp
 9010    format('Invalid element in inside_element, type: ',i10)
         call writloga('default',0,logmess,0,ierror)
      endif
C
 9999 continue
      return
      end


!##############################################################################
!# Tutorial 011a: Create a 2x2 block system, assemble a vector with block meth.
!##############################################################################

module tutorial011a

  ! Include basic Feat-2 modules
  use fsystem
  use storage
  use genoutput

  use triangulation
  use meshgeneration

  use derivatives
  use element
  use cubature
  use spatialdiscretisation
  use linearsystemscalar
  use linearsystemblock
  use bilinearformevaluation
  use stdoperators

  use blockmatassemblybase
  use blockmatassembly
  use blockmatassemblystdop
  use collection

  use vectorio

  implicit none
  private

  public :: start_tutorial011a

contains

  ! ***************************************************************************

  subroutine start_tutorial011a

    ! Declare some variables.
    type(t_triangulation) :: rtriangulation
    type(t_spatialDiscretisation) :: rspatialDiscr
    type(t_blockDiscretisation) :: rblockDiscr

    type(t_scalarCubatureInfo), target :: rcubatureInfo
    type(t_vectorBlock) :: rrhs
    type(t_collection) :: rcollection
    character(LEN=SYS_STRLEN) :: spostdir

    ! Print a message
    call output_lbrk()
    call output_separator (OU_SEP_STAR)
    call output_line ("This is FEAT-2. Tutorial 011a")
    call output_separator (OU_SEP_MINUS)

    ! =================================
    ! Create a brick mesh
    ! =================================

    ! The mesh must always be in "standard" format.
    ! First create a 5x5-mesh on [0,1]x[0,1], then convert to standard.
    call meshgen_rectangular2DQuadMesh (rtriangulation, 0.0_DP, 1.0_DP, 0.0_DP, 1.0_DP, 4, 4)
    call tria_initStandardMeshFromRaw (rtriangulation)

    ! =================================
    ! Create a block discretisation that encapsules
    ! two equations, both discretised with Q1.
    ! =================================

    ! Set up a Q1 discretisation
    call spdiscr_initDiscr_simple (rspatialDiscr,EL_Q1_2D,rtriangulation)

    ! Set up a block discretisation for two equations. Both equations are Q1.
    call spdiscr_initBlockDiscr (rblockDiscr,rtriangulation)
    call spdiscr_appendBlockComponent (rblockDiscr,rspatialDiscr)
    call spdiscr_appendBlockComponent (rblockDiscr,rspatialDiscr)
    call spdiscr_commitBlockDiscr (rblockDiscr)

    ! =================================
    ! Use a 3-point Gauss Formula for the assembly
    ! =================================

    call spdiscr_createDefCubStructure (rspatialDiscr,rcubatureInfo,CUB_GEN_AUTO_G3)

    ! =================================
    ! Create a RHS vector.
    ! =================================

    ! Use the block discretisation to create a vector.
    call lsysbl_createVector (rblockDiscr,rrhs)

    ! =================================
    ! Assemble rrhs=(f,g) with
    !   f=1,
    !   g=32*y*(1-y)+32*x*(1-x)
    ! =================================

    ! Clear the vector.
    call lsysbl_clearVector (rrhs)

    ! Calculate f=1 to the 1st component.
    rcollection%DquickAccess(1) = 1.0_DP  ! Multiplier
    rcollection%IquickAccess(1) = 1       ! Component
    call bma_buildVector (rrhs,BMA_CALC_STANDARD,bma_fcalc_rhsConst,rcollection,&
        rcubatureInfo=rcubatureInfo)

    ! Calculate g = 1 * 32*y*(1-y)+32*x*(1-x) to the 2nd component.
    rcollection%DquickAccess(1) = 1.0_DP  ! Multiplier
    rcollection%IquickAccess(1) = 2       ! Component
    call bma_buildVector (rrhs,BMA_CALC_STANDARD,bma_fcalc_rhsBubble,rcollection,&
        rcubatureInfo=rcubatureInfo)

    ! =================================
    ! Output of the vector
    ! =================================
    call output_line ("Writing vector to text files...")

    if (sys_getenv_string("POSTDIR",spostdir)) then
      ! Write the vector to a text file.
      call vecio_writeBlockVectorHR (rrhs, "vector", .true., 0, &
          trim(spostdir)//"/tutorial011a_vector.txt", "(E11.2)")

      ! Write the vector to a MATLAB file.
      call vecio_spyBlockVector(&
          trim(spostdir)//"/tutorial011a_vector","vector",rrhs,.true.)

      ! Write the vector to a MAPLE file
      call vecio_writeBlockVectorMaple (rrhs, "vector", .true., 0,&
          trim(spostdir)//"/tutorial011a_vector.maple", "(E11.2)")
    else
      ! Write the vector to a text file.
      call vecio_writeBlockVectorHR (rrhs, "vector", .true., 0, &
          "./post/tutorial011a_vector.txt", "(E11.2)")

      ! Write the vector to a MATLAB file.
      call vecio_spyBlockVector(&
          "./post/tutorial011a_vector","vector",rrhs,.true.)

      ! Write the vector to a MAPLE file
      call vecio_writeBlockVectorMaple (rrhs, "vector", .true., 0,&
          "./post/tutorial011a_vector.maple", "(E11.2)")
    end if

    ! =================================
    ! Cleanup
    ! =================================

    ! Release the cubature formula
    call spdiscr_releaseCubStructure (rcubatureInfo)

    ! Release the vector
    call lsysbl_releaseVector (rrhs)

    ! Release the block discretisation
    call spdiscr_releaseBlockDiscr (rblockDiscr)

    ! Release the Q1-discretisation
    call spdiscr_releaseDiscr (rspatialDiscr)

    ! Release the triangulation
    call tria_done (rtriangulation)

  end subroutine

end module


#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! d_symtrid_qr
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine computes the real Schur factorization of a real
! symmetric tridiagonal matrix T.
!
! This routine performs a Cayley transformation of the symmetric
! tridiagonal matrix to a unitary matrix (a descending and a
! ascending sequence of core transformations). The unitary matrix
! is transformed to upper Hessenberg form by core chasing and then
! passed to z_unifact_qr.
!
! The Cayley (Moebius) transform -(z-i)/(z+i) maps the real line to
! the unit circle, in particular the interval [-1,1] is mapped to
! [-pi/2, pi/2].
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  VEC             LOGICAL
!                    .TRUE.: compute schurvectors
!                    .FALSE.: no schurvectors
!
!  ID              LOGICAL
!                    .TRUE.: initialize to Z to identity
!                    .FALSE.: assume Z is already initialized
!
!  SCA             LOGICAL
!                    .TRUE.: scale and shift the matrix to
!                            have eigenvalues in [-1,1]
!                    .FALSE.: do not scale nor shift the matrix
!                  !! CAUTION: Not scaling and shifting the matrix can
!                              result in inaccurate eigenvalues !!
!
!  N               INTEGER
!                    dimension of matrix
!
!  D               REAL(8) array of dimension (N)
!                    diagonal entries of T
!                    on exit: D contains the eigenvalues of T
!
!  E               REAL(8) array of dimension (N)
!                    subdiagonal entries of T
!                    on exit: if SCA=.TRUE., E is scaled
!
!  WORK            REAL(8) array of dimension (5*N)
!                    work space for eigensolver
!
!  M               INTEGER
!                    leading dimension of Z
!
! OUTPUT VARIABLES:
!
!  Z               COMPLEX(8) array of dimension (M,N)
!                    components of schurvectors
!                    if VEC = .FALSE. unused
!                    if VEC = .TRUE. and ID = .TRUE. initializes Z to I
!                    if VEC = .TRUE. and ID = .FALSE. assumes Z initialized
!
!  ITS             INTEGER array of dimension (N-1)
!                    Contains the number of iterations per deflation
!
!  INFO            INTEGER
!                    INFO = 2 implies QR failed to converge
!                    INFO = 1 implies factorization failed
!                    INFO = 0 implies successful computation
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine d_symtrid_qr(VEC,ID,SCA,N,D,E,WORK,M,Z,ITS,INFO)

  implicit none

  ! input variables
  logical, intent(in) :: VEC, ID, SCA
  integer, intent(in) :: N, M
  real(8), intent(inout) :: WORK(5*N) ! WORK(1:3N-3) = Q ! WORK(3N+1:5N) = QD
  integer, intent(inout) :: ITS(N-1), INFO
  real(8), intent(inout) :: D(N), E(N-1)
  complex(8), intent(inout) :: Z(M,N)
  ! compute variables
  integer :: ii
  real(8) :: scale

  ! initialize INFO
  INFO = 0

  if (VEC.AND.ID) then
    Z = cmplx(0d0,0d0,kind=8)
    do ii=1,min(M,N)
      Z(ii,ii) = cmplx(1d0,0d0,kind=8)
   end do
  end if

  ! factorize \Phi(T) and reduction to unitary Hessenberg form
  call d_symtrid_factor(VEC,.FALSE.,SCA,N,D,E,WORK(1:(3*(N-3))),WORK((3*N+1):(5*N)),scale,M,Z,INFO)

  ! check info
  if (INFO.EQ.-56) then
     ! matrix is zero, set eigenvalues to zero
     D = 0d0
     INFO = 0
     return
  end if
  if (INFO.NE.0) then
     ! print error in debug mode
     if (DEBUG) then
        call u_infocode_check(__FILE__,__LINE__,"d_symtrid_factor failed",INFO,INFO)
     end if
     INFO = 1
     ! no eigenvalues found, no back transform necessary
     return
  end if

  ! compute eigenvalues
  call z_unifact_qr(VEC,.FALSE.,N,WORK(1:3*N-3),WORK((3*N+1):(5*N-1)),M,Z,ITS,INFO)

  ! check info
  if (INFO.NE.0) then
     ! print error in debug mode
     if (DEBUG) then
        call u_infocode_check(__FILE__,__LINE__,"z_unifact_qr failed",INFO,INFO)
     end if
     INFO = 2
     ! since some of the eigenvalues have been found, the back transform is performed for all
     ! return
  end if

  ! back transformation
  do ii=1,N
     D(ii) = WORK(3*N+2*ii)/(1d0+WORK(3*N+2*ii-1))
  end do

  ! reverse scaling
  if (SCA) then
     do ii=1,N
        D(ii) = D(ii)*scale
     end do
  end if

end subroutine d_symtrid_qr


subroutine nsi_ManufacturedBoundaryConditions(a)
   use typre
   use Mod_NavierStokes
   implicit none
   class(NavierStokesProblem) :: a

   integer(ip) :: npoin,ipoin,ibopo,ndime
   real(rp), pointer :: exnor(:,:)
   real(rp), pointer :: coord(:)
   ! work variables
   real(rp)    :: x,y,z,pi,r,teta,rad,h,sigma,v0,vx,vy,vz

   if (a%ManufacturedBoundaryCondition == 1) then
      a%kfl_fixbo = -1
      a%kfl_fixno = -1
      a%bvess = 0

      call a%Mesh%GetNpoin(npoin)
      call a%Mesh%GetNdime(ndime)

      if(ndime==2)then
         call runend('nsi_ManufacturedBoundaryConditions: exact solution not ready for 2d case')
      end if

      pi= 4.0_rp*atan(1.0_rp)
      rad  = 1.0_rp
      h  = 1.0_rp
      v0 = 1.0_rp
      sigma = 0.2_rp

      do ipoin = 1,npoin
         call a%Mesh%GetBoundaryPoint(ipoin,ibopo,exnor)
         if (ibopo /= 0) then
            a%kfl_fixno(ndime,ipoin) = 1_ip
            call a%Mesh%GetPointCoord(ipoin,coord)
            x = coord(1)
            y = coord(2)
            z = coord(3)
            r = sqrt(x*x+y*y)
            if (h-abs(z) <= 1.0D-6) then
                vz = v0 * (rad*rad/(2*pi*sigma*sigma))*exp(-(r*r/(2*sigma*sigma)))
            elseif (abs(z) <= 1.0D-6) then
                vz = v0 * (rad*rad/(2*pi*sigma*sigma))*exp(-(r*r/(2*sigma*sigma)))
            else
                vx = 0.0_rp
                vy = 0.0_rp
                vz = 0.0_rp
                a%kfl_fixno(1,ipoin) = 1_ip
                a%kfl_fixno(2,ipoin) = 1_ip
                a%bvess(1,ipoin,1) = vx
                a%bvess(2,ipoin,1) = vy
            endif
            a%bvess(ndime,ipoin,1) = vz
         endif
      enddo

   endif

end subroutine


      subroutine cfje(conc,fjec,jcsort,narn1,narn2,nstmax,zchcu6)
c
c     This subroutine calculates the ionic asymmetry (the 3-rd order
c     electrostatic moment function J). This is defined as:
c
c       J = 1/6 SUM(i) m(i)z(i)**3
c
c     This is a higher order analogue of the ionic strength, I, which
c     is the 2nd-order electrostatic moment function. For comparison,
c     the ionic strength is defined as:
c
c       I = 1/2 SUM(i) m(i)z(i)**2
c
c     This J is not to be confused with the functions J0(x), J1(x), and
c     J2(x), which are also involved in higher-order electrostatic
c     contributions to activity coefficients (see EQLIBG/ghj0.f).
c     Note that a sorted summation is used.
c
c     This subroutine is called by:
c
c       EQLIB/ngcadv.f
c       EQ3NR/arrset.f
c       EQ3NR/scripx.f
c       EQ6/scripz.f
c
c-----------------------------------------------------------------------
c
c     Principal input:
c
c       conc   = array of species concentrations
c       jcsort = array of species indices, in order of increasing
c                  concentration, but with sorting restricted to within
c                  phase ranges
c       narn1  = start of the range of aqueous species
c       narn2  = end of the range of aqueous species
c       zchcu6 = array of one-sixth the electrical charge cubed
c
c     Principal output:
c
c       fjec   = the ionic asymmetry (the 3rd-order electrostatic
c                  moment function J)
c
c-----------------------------------------------------------------------
c
      implicit none
c
c-----------------------------------------------------------------------
c
c     Calling sequence variable declarations.
c
      integer nstmax
c
      integer jcsort(nstmax)
      integer narn1,narn2
c
      real*8 conc(nstmax),zchcu6(nstmax)
      real*8 fjec
c
c-----------------------------------------------------------------------
c
c     Local variable declarations.
c
      integer ileft,ns,nss,ns0,ns1,ns2,ns3,ns4,ns5,ns6,ns7,nval
c
      real*8 xx
c
c-----------------------------------------------------------------------
c
c     Logically, this could be represented by:
c
c       fjec = 0.
c       do ns = narn1 + 1,narn2
c         fjec = fjec + conc(ns)*zchcu6(ns)
c       enddo
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     In doing a sorted summation, a complication arises in that
c     water (ns = narn1) must be included in the range of the
c     loop, because the jcsort array is organized to contain the
c     species indices sorted according to increasing concentration
c     within phase ranges. There is no available sorting among
c     aqueous solute species only. Because the electrical charge
c     of water is zero, the calculation can be made looping from
c     narn1 to narn2. It is not necessary to temporarily set the
c     concentration of water (conc(narn1)) to zero. Note the use
c     of a local variable (xx) within the loop. Note also that the
c     loop is unrolled.
c
      xx = 0.
      nval = narn2 - narn1 + 1
      ileft = (nval/8)*8 + narn1 - 1
c
      do nss = narn1,ileft,8
        ns0 = jcsort(nss)
        ns1 = jcsort(nss + 1)
        ns2 = jcsort(nss + 2)
        ns3 = jcsort(nss + 3)
        ns4 = jcsort(nss + 4)
        ns5 = jcsort(nss + 5)
        ns6 = jcsort(nss + 6)
        ns7 = jcsort(nss + 7)
        xx = xx + conc(ns0)*zchcu6(ns0) + conc(ns1)*zchcu6(ns1)
     $          + conc(ns2)*zchcu6(ns2) + conc(ns3)*zchcu6(ns3)
     $          + conc(ns4)*zchcu6(ns4) + conc(ns5)*zchcu6(ns5)
     $          + conc(ns6)*zchcu6(ns6) + conc(ns7)*zchcu6(ns7)
      enddo
c
      do nss = ileft + 1,narn2
        ns = jcsort(nss)
        xx = xx + conc(ns)*zchcu6(ns)
      enddo
c
      fjec = xx
c
      end


module finite_elements
  use nrtype
contains

  subroutine fepdelin(u,ncyc)
    implicit none
    real(dp), intent(inout) :: u(:,:) ! Function u.
    integer, intent(in)     :: ncyc   ! Number of cycles.
    integer                 :: i, n, ng, cn, cng ! Position, grid dimension.
    type a2d
      real(dp), allocatable :: a(:,:)
    end type a2d
    type(a2d), allocatable  :: rho(:)
    real(dp), dimension(:,:), allocatable :: cu, cu_1 ! cu = Coarse solution for u.

    ! Exit if both dimensions aren't equal. We need a square matrix.
    dimu: if(size(u,1) /= size(u,2)) then
      write(*,*) ' Error: subr:: fepdelin:: dimu. U must be an N x N matrix.'
      return
    end if dimu

    ! Number of multigrids.
    ng = nint(log(n-1.)/log(2.))

    ! Exit if n-1 isn't a power of two.
    dimn: if (n /= 2**ng + 1) then
      write(*,*) ' Error: subr:: fepdelin:: dimn. N-1 must be a power of 2.'
    end if dimn

    ! Allocate the rho array.
    allocate( rho(ng) )
    allocate( rho(ng) % a(n,n) )

    ! Assign the array the values of the initial u at the finest grid.
    rho(ng) % a = u

    ! Assigning coarser n and coarser ng.
    cn  = n
    cng = ng
    grid: do
      if (cn <= 3) exit grid
      cn  = cn/2 + 1
      cng = cng - 1
      allocate( rho(cng) % a(cn,cn) )
      rho(cng) % a = hwrsct( rho(cng+1) % p )
    end do grid

    ! Assign the coarsest grid.
    cn = 3
    allocate(cu(cn,cn))
    call srhselpde(rho(1) % a, cu)

    ! Go through progressively finer grids.
    fg: do j = 2, ng
      call movealloc(cu, cu_1)
      cn = 2*cn - 1
      allocate(cu(cn,cn))
      ! interpolate from a coarse grid to a finer grid.
      cu = gridint(cu_1,cn)
      deallocate(cu_1)
      ! Iterate to solve the equation.

    end do fg

  end subroutine fepdelin

  function gridint(u,n)
    implicit none
    real(dp), intent(in) :: u(:,:)
    real(dp)             :: gridint(n,n)
    integer              :: cn ! Coarse n.

    cn = size(u,1)
    dimu: if (size(u,1) /= size(u,2)) then
      write(*,*) ' Error: subr:: gridint:: dimu. U must be a square matrix.'
      return
    end if dimu

    gridint(1:n:2,1:n:2)   = u(1:cn,1:cn)
    gridint(2:n-1:2,1:n:2) = 0.5_dp*(gridint(3:n:2,1:n:2) + gridint(1:n-2:2,1:n:2))
    gridint(1:n:2,2:n-1:2) = 0.5_dp*(gridint(1:n:2,3:n:2) + gridint(1:n:2,1:n-2:2))
  end function gridint

  function hwrsct(u)
    ! Function for restricting u to a coarser grid.
    implicit none
    real(dp), intent(in) :: u(:,:)
    real(dp)             :: hwrsct((size(u,1)+1)/2, (size(u,2)+1)/2) ! Restricted u
    integer              :: n, cn ! n and coarser n

    ! Current grid dimension.
    n = size(u,1)
    ! Coarser grid dimension.
    cn = (n+1)/2

    ! Boundary conditions.
    hwrsct(1:cn,1)  = u(1:n:2,1)
    hwrsct(1:cn,cn) = u(1:n:2,n)
    hwrsct(1,1:cn)  = u(1,1:n:2)
    hwrsct(cn,1:cn) = u(n,1:n:2)

    ! Internal elements.
    hwrsct(2:cn-1,2:cn-1) = 0.5_dp * u(3:n-2:2, 3:n-2:2) + 0.125_dp * &
                            (&
                            u(4:n-1:2,3:n-2:2) + u(2:n-3:2,3:n-2:2) + &
                            u(3:n-2:2,4:n-1:2) + u(3:n-2:2,2:n-3:2)   &
                            )
  end function hwrsct

  subroutine srhselpde(rhs, u, h)
    implicit none
    real(dp), intent(in)  :: rhs(:,:), h
    real(dp), intent(out) :: u(:,:)
    u = 0.0
    u(2,2) = -h*h*rhs(2,2)/4._dp
  end subroutine srhselpde

end module finite_elements


module integral

  complex*16, allocatable, save, public   :: Cpath(:)

  public :: define_path

  contains

  subroutine define_path()

    use param,              only : efermi, npath, npoles, fdtemp
    use constants,          only : twopi, cmplx_i, kboltz
    use fractions,          only : polres

    implicit none

    integer    :: ipath
    real*8     :: rad, theeta, dang

    rad = polres(1,2*npoles)*kboltz*fdtemp + 1d+8

    theeta = twopi/2.0

    allocate(Cpath(0:npath))

    Cpath(0) = efermi + rad
    do ipath = 1, npath
       dang = ipath*theeta/npath
       Cpath(ipath) = efermi + rad*exp(cmplx_i*dang)
    end do

  end subroutine define_path

end module integral


!
! FT verification routine.
!
      subroutine verify(n1,n2,n3,nt,cksum,verified)
        implicit none
        include 'npbparams.h'
       logical verified
!
! Arguments.
!
         integer, intent(in) :: n1, n2, n3, nt
         double complex, dimension(niter_default), intent(in) :: cksum
!
! Local variables.
!
         logical success
         logical temp(niter_default)
         integer kt,i
         double complex cexpd(20)
         real*8 epsilon
!
! Initialize tolerance level and success flag.
!
         epsilon = 1.0e-12
         success = .true.
!
         if ((n1 .eq. 64) .and. (n2 .eq. 64) .and.
     &            (n3 .eq. 64) .and. (nt .eq. 6)) then
!
! Class S reference values.
!
            cexpd(1) = dcmplx(554.6087004964D0, 484.5363331978D0)
            cexpd(2) = dcmplx(554.6385409189D0, 486.5304269511D0)
            cexpd(3) = dcmplx(554.6148406171D0, 488.3910722336D0)
            cexpd(4) = dcmplx(554.5423607415D0, 490.1273169046D0)
            cexpd(5) = dcmplx(554.4255039624D0, 491.7475857993D0)
            cexpd(6) = dcmplx(554.2683411902D0, 493.2597244941D0)

         else if ((n1 .eq. 128) .and. (n2 .eq. 128) .and.
     &            (n3 .eq. 32) .and. (nt .eq. 6)) then
!
! Class W reference values.
!
            cexpd(1) = dcmplx(567.3612178944D0, 529.3246849175D0)
            cexpd(2) = dcmplx(563.1436885271D0, 528.2149986629D0)
            cexpd(3) = dcmplx(559.4024089970D0, 527.0996558037D0)
            cexpd(4) = dcmplx(556.0698047020D0, 526.0027904925D0)
            cexpd(5) = dcmplx(553.0898991250D0, 524.9400845633D0)
            cexpd(6) = dcmplx(550.4159734538D0, 523.9212247086D0)
!
         else if ((n1 .eq. 256) .and. (n2 .eq. 256) .and.
     &            (n3 .eq. 128) .and. (nt .eq. 6)) then
!
! Class A reference values.
!
            cexpd(1) = dcmplx(504.6735008193D0, 511.4047905510D0)
            cexpd(2) = dcmplx(505.9412319734D0, 509.8809666433D0)
            cexpd(3) = dcmplx(506.9376896287D0, 509.8144042213D0)
            cexpd(4) = dcmplx(507.7892868474D0, 510.1336130759D0)
            cexpd(5) = dcmplx(508.5233095391D0, 510.4914655194D0)
            cexpd(6) = dcmplx(509.1487099959D0, 510.7917842803D0)
!
         else if ((n1 .eq. 512) .and. (n2 .eq. 256) .and.
     &            (n3 .eq. 256) .and. (nt .eq. 20)) then
!
! Class B reference values.
!
             cexpd(1) = dcmplx(5.177643571579D+02,5.077803458597D+02)
             cexpd(2) = dcmplx(5.154521291263D+02,5.088249431599D+02)
             cexpd(3) = dcmplx(5.146409228649D+02,5.096208912659D+02)
             cexpd(4) = dcmplx(5.142378756213D+02,5.101023387619D+02)
             cexpd(5) = dcmplx(5.139626667737D+02,5.103976610617D+02)
             cexpd(6) = dcmplx(5.137423460082D+02,5.105948019802D+02)
             cexpd(7) = dcmplx(5.135547056878D+02,5.107404165783D+02)
             cexpd(8) = dcmplx(5.133910925466D+02,5.108576573661D+02)
             cexpd(9) = dcmplx(5.132470705390D+02,5.109577278523D+02)
            cexpd(10) = dcmplx(5.131197729984D+02,5.110460304483D+02)
            cexpd(11) = dcmplx(5.130070319283D+02,5.111252433800D+02)
            cexpd(12) = dcmplx(5.129070537032D+02,5.111968077718D+02)
            cexpd(13) = dcmplx(5.128182883502D+02,5.112616233064D+02)
            cexpd(14) = dcmplx(5.127393733383D+02,5.113203605551D+02)
            cexpd(15) = dcmplx(5.126691062020D+02,5.113735928093D+02)
            cexpd(16) = dcmplx(5.126064276004D+02,5.114218460548D+02)
            cexpd(17) = dcmplx(5.125504076570D+02,5.114656139760D+02)
            cexpd(18) = dcmplx(5.125002331720D+02,5.115053595966D+02)
            cexpd(19) = dcmplx(5.124551951846D+02,5.115415130407D+02)
            cexpd(20) = dcmplx(5.124146770029D+02,5.115744692211D+02)
         else if ((n1 .eq. 512) .and. (n2 .eq. 512) .and.
     &            (n3 .eq. 512) .and. (nt .eq. 20)) then
!
! Class C reference values.
!
             cexpd(1) = dcmplx(5.195078707457D+02, 5.149019699238D+02)
             cexpd(2) = dcmplx(5.155422171134D+02, 5.127578201997D+02)
             cexpd(3) = dcmplx(5.144678022222D+02, 5.122251847514D+02)
             cexpd(4) = dcmplx(5.140150594328D+02, 5.121090289018D+02)
             cexpd(5) = dcmplx(5.137550426810D+02, 5.121143685824D+02)
             cexpd(6) = dcmplx(5.135811056728D+02, 5.121496764568D+02)
             cexpd(7) = dcmplx(5.134569343165D+02, 5.121870921893D+02)
             cexpd(8) = dcmplx(5.133651975661D+02, 5.122193250322D+02)
             cexpd(9) = dcmplx(5.132955192805D+02, 5.122454735794D+02)
            cexpd(10) = dcmplx(5.132410471738D+02, 5.122663649603D+02)
            cexpd(11) = dcmplx(5.131971141679D+02, 5.122830879827D+02)
            cexpd(12) = dcmplx(5.131605205716D+02, 5.122965869718D+02)
            cexpd(13) = dcmplx(5.131290734194D+02, 5.123075927445D+02)
            cexpd(14) = dcmplx(5.131012720314D+02, 5.123166486553D+02)
            cexpd(15) = dcmplx(5.130760908195D+02, 5.123241541685D+02)
            cexpd(16) = dcmplx(5.130528295923D+02, 5.123304037599D+02)
            cexpd(17) = dcmplx(5.130310107773D+02, 5.123356167976D+02)
            cexpd(18) = dcmplx(5.130103090133D+02, 5.123399592211D+02)
            cexpd(19) = dcmplx(5.129905029333D+02, 5.123435588985D+02)
            cexpd(20) = dcmplx(5.129714421109D+02, 5.123465164008D+02)
!
         else
!
            write (*,    120) 'NOT DONE'
            success = .false.
!
         end if
!
! Verification test for results.
!
	 verified=.false.
         if (success) then

            success = all (abs ((cksum(1:nt) - cexpd(1:nt)) /
     &                     cexpd(1:nt)) .le. epsilon)

            if (success) then
	       verified=.true.
               write (*,    120) 'PASSED'
            else
               write (*,    120) 'FAILED'
            end if

  120       format (' Verification test for FT ', a)
         end if
!
         return
      end


!-------------------------------------------------------
SUBROUTINE unmixImage(image, endMemberMatrix, numBands, numEndMembers, numRows, numCols, inNull, outNull, fractionsImage)
!-------------------------------------------------------
! Performs spectral unmixing of an image.
!
! For each pixel it finds the fractions that minimises
! || endMemberMatrix * fractions - pixelReflectance || ^ 2
!
! Uses the non-negative least squares (nnls) solver of Charles L. Lawson and
! Richard J. Hanson to do the optimization. See nnls.f90 for more details
! on the nnls algorithm.
!
! Tony Gill, January 2011.
!
! ARGUMENTS
! image (IN):              A 3D array containing the reflectance image (numBands, numRows, numCols).
! endMemberMatrix (IN):    A 2D array containing the reflectance of the endmembers (numBands, numEndmembers)
! numBands (IN):           The number of bands in the image.
! numEndMembers (IN):      The number of endmembers to be unmixed.
! numRows (IN):            The number of rows in the image.
! numCols (IN):            The number of columns in the image.
! inNull (IN):             The ignore value for the input image - if all values in the input pixel equal
!                          inNull then the pixel is not processed. The output fractions will be filled with outNull.
! outNull (IN):            The value to use to fill the output fractionsImage where the input pixel contains null data
!                          or the unmixing cannot be performed.
! fractionsImage (OUT):    A 3D array that on EXIT will contain an image.
!                          Each pixel in the image contains the endmember fractions plus
!                          an error term which is equal to the euclidean norm of the residual vector.
!                          The shape of the array is (numEndMembers+1,numRows,numCols).
!                          If nnls fails, the pixel will be filled with -10.0
!-------------------------------------------------------

   USE nonneg_leastsq
   IMPLICIT NONE

   ! Function arguments
   INTEGER, INTENT(IN)           :: numBands, numEndMembers, numRows, numCols
   DOUBLE PRECISION, INTENT(IN)  :: image(numBands,numRows,numCols), endMemberMatrix(numBands,numEndMembers)
   DOUBLE PRECISION, INTENT(IN)  :: inNull, outNull
   DOUBLE PRECISION, INTENT(OUT) :: fractionsImage(numEndMembers+1,numRows,numCols)

   ! Local variables
   INTEGER                       :: col, row, indx(numEndMembers), mode
   DOUBLE PRECISION              :: endMemberMatrixCopy(numBands,numEndMembers), pixelFractions(numEndMembers)
   DOUBLE PRECISION              :: pixelRefl(numBands), rnorm, w(numEndMembers)

   ! loop through the image.
   do col = 1, numCols
      do row = 1, numRows
        pixelRefl = image(:,row,col) ! pixel reflectance.

        if ( all(pixelRefl .EQ. inNull) ) then
           ! ignore the pixel - fill with out null.
           fractionsImage(:, row, col) = outNull
        else
           ! the pixel needs to be processed.
           endMemberMatrixCopy = endMemberMatrix ! nnls changes endMemberMatrix, so need to use a copy of it.
           CALL nnls(endMemberMatrixCopy, numBands, numEndMembers, pixelRefl, pixelFractions, rnorm, w, indx, mode)
           if (mode .GT. 1) then
              ! unmixing failed, fill the pixel.
              fractionsImage(:, row, col) = outNull
           else
              fractionsImage(:numEndMembers,row,col) = pixelFractions ! insert endmembers
              fractionsImage(numEndMembers+1, row, col) = rnorm ! insert rnorm value.
           endif
        endif
      end do
   end do
END SUBROUTINE unmixImage

!-------------------------------------------------------
SUBROUTINE unmixPixel(pixelRefl, endMemberMatrix, numBands, numEndMembers, inNull, outNull, pixelFractions)
!-------------------------------------------------------
! Performs spectral unmixing of a pixel.
!
! Finds the fractions that minimises
! || endMemberMatrix * fractions - pixelReflectance || ^ 2
!
! Uses the non-negative least squares (nnls) solver of Charles L. Lawson and
! Richard J. Hanson to do the optimization. See nnls.f90 for more details
! on the nnls algorithm.
!
! Tony Gill, January 2011.
!
! ARGUMENTS
! pixelRefl (IN):          A 1D array containing the reflectance (numBands).
! endMemberMatrix (IN):    A 2D array containing the reflectance of the endmembers (numBands, numEndmembers)
! numBands (IN):           The number of bands in the pixel.
! numEndMembers (IN):      The number of endmembers to be unmixed.
! inNull (IN):             The ignore value for the input image - if all values in the input pixel equal
!                          inNull then the pixel is not processed. The output fractions will be filled with outNull.
! outNull (IN):            The value to use to fill the output fractions array where the input pixel contains null data
!                          or the unmixing cannot be performed.
! pixelFractions (OUT):    A 1D array that on EXIT will contain the unmixed fractions.
!                          The array contains the endmember fractions plus
!                          an error term which is equal to the euclidean norm of the residual vector.
!                          The length of the array is (numEndMembers+1).
!-------------------------------------------------------

   USE nonneg_leastsq
   IMPLICIT NONE

   ! Function arguments
   INTEGER, INTENT(IN)           :: numBands, numEndMembers
   DOUBLE PRECISION, INTENT(IN)  :: pixelRefl(numBands), endMemberMatrix(numBands,numEndMembers)
   DOUBLE PRECISION, INTENT(IN)  :: inNull, outNull
   DOUBLE PRECISION, INTENT(OUT) :: pixelFractions(numEndMembers+1)

   ! Local variables
   INTEGER                       :: indx(numEndMembers), mode
   DOUBLE PRECISION              :: endMemberMatrixCopy(numBands,numEndMembers)
   DOUBLE PRECISION              :: pixelReflCopy(numBands), pixelFracs(numEndmembers), rnorm, w(numEndMembers)

   if ( all(pixelRefl .EQ. inNull) ) then
      ! ignore the pixel - fill with out null.
      pixelFractions(:) = outNull
   else
      ! the pixel needs to be processed.
      endMemberMatrixCopy = endMemberMatrix ! nnls changes endMemberMatrix, so need to use a copy of it.
      pixelReflCopy = pixelRefl
      CALL nnls(endMemberMatrixCopy, numBands, numEndMembers, pixelReflCopy, pixelFracs, rnorm, w, indx, mode)
      if (mode .GT. 1) then
         ! unmixing failed, fill the pixel.
         pixelFractions(:) = outNull
      else
         pixelFractions(:numEndMembers) = pixelFracs ! insert endmembers
         pixelFractions(numEndMembers+1) = rnorm ! insert rnorm value.
      endif
   endif
END SUBROUTINE unmixPixel


! This source file is part of the Limited-area GAME version (L-GAME), which is released under the MIT license.
! Github repository: https://github.com/OpenNWP/L-GAME

module vorticities

  ! This module contians the calculation of the vorticities.

  use definitions, only: t_state,t_diag,t_grid,wp
  use run_nml,     only: nlins,ncols,nlays,nlays_oro,re,toa,lcorio,llinear
  use averaging,   only: horizontal_covariant_x,horizontal_covariant_y

  implicit none

  private

  public :: calc_pot_vort

  contains

  subroutine rel_vort(state,diag,grid)

    ! This subroutine calculates the relative vorticity.

    type(t_state), intent(in)    :: state     ! state to work with
    type(t_diag),  intent(inout) :: diag      ! diagnostic quantities
    type(t_grid),  intent(in)    :: grid      ! model grid

    ! local variables
    integer                      :: ji,jk,jl          ! loop indices
    real(wp)                     :: l_rescale         ! length rescale factor in orography
    real(wp)                     :: delta_z           ! needed for handling terrain
    real(wp)                     :: vertical_gradient ! needed for handling terrain
    integer                      :: ind_shift         ! needed for handling terrain

    ! calculating the relative vorticity in x-direction
    !$OMP PARALLEL
    !$OMP DO PRIVATE(ji,jk,jl)
    do ji=1,nlins+1
      do jk=1,ncols
        do jl=2,nlays
          diag%z_eta_x(ji,jk,jl) = &
          + grid%dz(ji+1,jk+1,jl  )*state%wind_w(ji+1,jk+1,jl  )                                         &
          - grid%dy(ji  ,jk+1,jl-1)*horizontal_covariant_y(state%wind_v,state%wind_w,grid,ji,jk+1,jl-1)  &
          - grid%dz(ji  ,jk+1,jl  )*state%wind_w(ji  ,jk+1,jl  )                                         &
          + grid%dy(ji  ,jk+1,jl  )*horizontal_covariant_y(state%wind_v,state%wind_w,grid,ji,jk+1,jl  )
        enddo
        ! At the surface, w vanishes. Furthermore, the covariant velocity below the surface is also zero.
        diag%z_eta_x(ji,jk,nlays+1) = -grid%dy(ji,jk+1,nlays)*horizontal_covariant_y(state%wind_v,state%wind_w,grid,ji,jk+1,nlays)
      enddo
    enddo
    !$OMP END DO
    !$OMP END PARALLEL
    ! At the TOA, the horizontal vorticity is assumed to have no vertical shear.
    diag%z_eta_x(:,:,1) = diag%z_eta_x(:,:,2)
    ! dividing by the area
    diag%z_eta_x(:,:,:) = diag%z_eta_x(:,:,:)/grid%area_dual_x(:,:,:)

    ! calculating the relative vorticity in y-direction
    !$OMP PARALLEL
    !$OMP DO PRIVATE(ji,jk,jl)
    do ji=1,nlins
      do jk=1,ncols+1
        do jl=2,nlays
          diag%z_eta_y(ji,jk,jl) = &
          + grid%dz(ji+1,jk  ,jl  )*state%wind_w(ji+1,jk  ,jl  )                                         &
          + grid%dx(ji+1,jk  ,jl-1)*horizontal_covariant_x(state%wind_u,state%wind_w,grid,ji+1,jk,jl-1)  &
          - grid%dz(ji+1,jk+1,jl  )*state%wind_w(ji+1,jk+1,jl  )                                         &
          - grid%dx(ji+1,jk  ,jl  )*horizontal_covariant_x(state%wind_u,state%wind_w,grid,ji+1,jk,jl  )
        enddo
        ! At the surface, w vanishes. Furthermore, the covariant velocity below the surface is also zero.
        diag%z_eta_y(ji,jk,nlays+1) = grid%dx(ji+1,jk,nlays)*horizontal_covariant_x(state%wind_u,state%wind_w,grid,ji+1,jk,nlays)
      enddo
    enddo
    !$OMP END DO
    !$OMP END PARALLEL
    ! At the TOA, the horizontal vorticity is assumed to have no vertical shear.
    diag%z_eta_y(:,:,1) = diag%z_eta_y(:,:,2)
    ! dividing by the area
    diag%z_eta_y(:,:,:) = diag%z_eta_y(:,:,:)/grid%area_dual_y(:,:,:)

    ! calculating the relative vorticity in z-direction
    !$OMP PARALLEL
    !$OMP DO PRIVATE(ji,jk,jl,l_rescale,delta_z,ind_shift,vertical_gradient)
    do ji=1,nlins+1
      do jk=1,ncols+1
        ! layers which do not follow the orography
        do jl=1,nlays-nlays_oro
          diag%z_eta_z(ji,jk,jl) = &
          + grid%dy(ji,  jk+1,jl)*state%wind_v(ji,  jk+1,jl) &
          - grid%dx(ji+1,jk,  jl)*state%wind_u(ji+1,jk,  jl) &
          - grid%dy(ji,  jk,  jl)*state%wind_v(ji,  jk,  jl) &
          + grid%dx(ji,  jk,  jl)*state%wind_u(ji,  jk,  jl)
        enddo
        ! layers which follow the orography
        do jl=nlays-nlays_oro+1,nlays
          ! first
          l_rescale         = (re + grid%z_geo_area_dual_z(ji,jk,jl))/(re + grid%z_geo_v(ji,jk+1,jl))
          delta_z           = grid%z_geo_area_dual_z(ji,jk,jl) - grid%z_geo_v(ji,jk+1,jl)
          ind_shift = 1
          if (delta_z > 0 .or. jl == nlays) then
            ind_shift = -1
          endif
          vertical_gradient = (state%wind_v(ji,jk+1,jl) - state%wind_v(ji,jk+1,jl+ind_shift))/ &
          (grid%z_geo_v(ji,jk+1,jl) - grid%z_geo_v(ji,jk+1,jl+ind_shift))
          diag%z_eta_z(ji,jk,jl) = l_rescale*grid%dy(ji,jk+1,jl)* &
          (state%wind_v(ji,jk+1,jl) + delta_z*vertical_gradient)
          ! second
          l_rescale         = (re + grid%z_geo_area_dual_z(ji,jk,jl))/(re + grid%z_geo_u(ji+1,jk,jl))
          delta_z           = grid%z_geo_area_dual_z(ji,jk,jl) - grid%z_geo_u(ji+1,jk,jl)
          ind_shift = 1
          if (delta_z > 0 .or. jl == nlays) then
            ind_shift = -1
          endif
          vertical_gradient = (state%wind_u(ji+1,jk,jl) - state%wind_u(ji+1,jk,jl+ind_shift))/ &
          (grid%z_geo_u(ji+1,jk  ,jl) - grid%z_geo_u(ji+1,jk,jl+ind_shift))
          diag%z_eta_z(ji,jk,jl) = diag%z_eta_z(ji,jk,jl) - l_rescale*grid%dx(ji+1,jk,jl)* &
          (state%wind_u(ji+1,jk,jl) + delta_z*vertical_gradient)
          ! third
          l_rescale         = (re + grid%z_geo_area_dual_z(ji,jk,jl))/(re + grid%z_geo_v(ji,jk,jl))
          delta_z           = grid%z_geo_area_dual_z(ji,jk,jl) - grid%z_geo_v(ji,jk,jl)
          ind_shift = 1
          if (delta_z > 0 .or. jl == nlays) then
            ind_shift = -1
          endif
          vertical_gradient = (state%wind_v(ji,jk,jl) - state%wind_v(ji,jk,jl+ind_shift))/ &
          (grid%z_geo_v(ji,jk,jl) - grid%z_geo_v(ji,jk,jl+ind_shift))
          diag%z_eta_z(ji,jk,jl) = diag%z_eta_z(ji,jk,jl) - l_rescale*grid%dy(ji,jk,jl)* &
          (state%wind_v(ji,jk,jl) + delta_z*vertical_gradient)
          ! fourth
          l_rescale         = (re + grid%z_geo_area_dual_z(ji,jk,jl))/(re + grid%z_geo_u(ji,jk,jl))
          delta_z           = grid%z_geo_area_dual_z(ji,jk,jl) - grid%z_geo_u(ji,jk,jl)
          ind_shift = 1
          if (delta_z > 0 .or. jl == nlays) then
            ind_shift = -1
          endif
          vertical_gradient = (state%wind_u(ji,jk,jl) - state%wind_u(ji,jk,jl+ind_shift))/ &
          (grid%z_geo_u(ji,jk,jl) - grid%z_geo_u(ji,jk,jl+ind_shift))
          diag%z_eta_z(ji,jk,jl) = diag%z_eta_z(ji,jk,jl) + l_rescale*grid%dx(ji,jk,jl)* &
          (state%wind_u(ji,jk,jl) + delta_z*vertical_gradient)
        enddo
      enddo
    enddo
    !$OMP END DO
    !$OMP END PARALLEL
    ! dividing by the area
    diag%z_eta_z(:,:,:) = diag%z_eta_z(:,:,:)/grid%area_dual_z(:,:,:)

  end subroutine rel_vort

  subroutine calc_pot_vort(state,diag,grid)

    ! This subroutine calculates the potential vorticity.

    type(t_state), intent(in)    :: state    ! state to work with
    type(t_diag),  intent(inout) :: diag     ! diagnostic quantities
    type(t_grid),  intent(in)    :: grid     ! model grid

    ! local variables
    integer                      :: ji,jk,jl ! loop index

    ! calculating the relative vorticity
    if (.not. llinear) then
      call rel_vort(state,diag,grid)
    else
      diag%z_eta_x(:,:,:) = 0._wp
      diag%z_eta_y(:,:,:) = 0._wp
      diag%z_eta_z(:,:,:) = 0._wp
    endif

    ! adding the Coriolis vector to the relative vorticity to obtain the absolute vorticity
    if (lcorio) then
      !$OMP PARALLEL
      !$OMP DO PRIVATE(jl)
      do jl=1,nlays+1
        diag%z_eta_x(:,:,jl) = diag%z_eta_x(:,:,jl) + grid%fvec_x(:,:)
        diag%z_eta_y(:,:,jl) = diag%z_eta_y(:,:,jl) + grid%fvec_y(:,:)
      enddo
      !$OMP END DO
      !$OMP END PARALLEL
      !$OMP PARALLEL
      !$OMP DO PRIVATE(jl)
      do jl=1,nlays
        diag%z_eta_z(:,:,jl) = diag%z_eta_z(:,:,jl) + grid%fvec_z(:,:)
      enddo
      !$OMP END DO
      !$OMP END PARALLEL
    endif

    ! dividing by the averaged density to obtain the "potential vorticity"
    ! horizontal vorticity in x-direction
    !$OMP PARALLEL
    !$OMP DO PRIVATE(ji,jk,jl)
    do ji=1,nlins+1
      do jk=1,ncols
        do jl=1,nlays+1
          if (jl == 1) then
            diag%z_eta_x(ji,jk,jl) = diag%z_eta_x(ji,jk,jl)/(0.5_wp*(state%rho(ji,jk+1,jl) &
            ! linear extrapolation to the TOA
            +(toa-grid%z_geo_scal(ji,jk+1,jl))*(state%rho(ji,jk+1,jl)-state%rho(ji,jk+1,jl+1))/ &
            (grid%z_geo_scal(ji,jk+1,jl)-grid%z_geo_scal(ji,jk+1,jl+1)) &
            +state%rho(ji+1,jk+1,jl) &
            ! linear extrapolation to the TOA
            +(toa-grid%z_geo_scal(ji+1,jk+1,jl))*(state%rho(ji+1,jk+1,jl)-state%rho(ji+1,jk+1,jl+1))/ &
            (grid%z_geo_scal(ji+1,jk+1,jl)-grid%z_geo_scal(ji+1,jk+1,jl+1))))
          elseif (jl==nlays+1) then
            diag%z_eta_x(ji,jk,jl) = diag%z_eta_x(ji,jk,jl)/(0.5_wp*(state%rho(ji,jk+1,jl-1) &
            ! linear extrapolation to the surface
            +(grid%z_geo_w(ji,jk+1,jl)-grid%z_geo_scal(ji,jk+1,jl-1))*(state%rho(ji,jk+1,jl-2)-state%rho(ji,jk+1,jl-1))/ &
            (grid%z_geo_scal(ji,jk+1,jl-2)-grid%z_geo_scal(ji,jk+1,jl-1)) &
            +state%rho(ji+1,jk+1,jl-1) &
            ! linear extrapolation to the surface
            +(grid%z_geo_w(ji+1,jk+1,jl)-grid%z_geo_scal(ji+1,jk+1,jl-1))*(state%rho(ji+1,jk+1,jl-2)-state%rho(ji+1,jk+1,jl-1))/ &
            (grid%z_geo_scal(ji+1,jk+1,jl-2)-grid%z_geo_scal(ji+1,jk+1,jl-1))))
          else
            diag%z_eta_x(ji,jk,jl) = diag%z_eta_x(ji,jk,jl)/(0.25_wp*(state%rho(ji,jk+1,jl-1)+state%rho(ji+1,jk+1,jl-1)+ &
            state%rho(ji,jk+1,jl)+state%rho(ji+1,jk+1,jl)))
          endif
        enddo
      enddo
    enddo
    !$OMP END DO
    !$OMP END PARALLEL

    ! horizontal vorticity in y-direction
    !$OMP PARALLEL
    !$OMP DO PRIVATE(ji,jk,jl)
    do ji=1,nlins
      do jk=1,ncols+1
        do jl=1,nlays+1
          if (jl == 1) then
            diag%z_eta_y(ji,jk,jl) = diag%z_eta_y(ji,jk,jl)/(0.5_wp*(state%rho(ji+1,jk,jl) &
            ! linear extrapolation to the TOA
            +(toa-grid%z_geo_scal(ji+1,jk,jl))*(state%rho(ji+1,jk,jl)-state%rho(ji+1,jk,jl+1))/ &
            (grid%z_geo_scal(ji+1,jk,jl)-grid%z_geo_scal(ji+1,jk,jl+1)) &
            +state%rho(ji+1,jk+1,jl) &
            ! linear extrapolation to the TOA
            +(toa-grid%z_geo_scal(ji+1,jk+1,jl))*(state%rho(ji+1,jk+1,jl)-state%rho(ji+1,jk+1,jl+1))/ &
            (grid%z_geo_scal(ji+1,jk+1,jl)-grid%z_geo_scal(ji+1,jk+1,jl+1))))
          elseif (jl==nlays+1) then
            diag%z_eta_y(ji,jk,jl) = diag%z_eta_y(ji,jk,jl)/(0.5_wp*(state%rho(ji+1,jk,jl-1) &
            ! linear extrapolation to the surface
            +(grid%z_geo_w(ji+1,jk,jl)-grid%z_geo_scal(ji+1,jk,jl-1))*(state%rho(ji+1,jk,jl-2)-state%rho(ji+1,jk,jl-1))/ &
            (grid%z_geo_scal(ji+1,jk,jl-2)-grid%z_geo_scal(ji+1,jk,jl-1)) &
            +state%rho(ji+1,jk+1,jl-1) &
            ! linear extrapolation to the surface
            +(grid%z_geo_w(ji+1,jk+1,jl)-grid%z_geo_scal(ji+1,jk+1,jl-1))*(state%rho(ji+1,jk+1,jl-2)-state%rho(ji+1,jk+1,jl-1))/ &
            (grid%z_geo_scal(ji+1,jk+1,jl-2)-grid%z_geo_scal(ji+1,jk+1,jl-1))))
          else
            diag%z_eta_y(ji,jk,jl) = diag%z_eta_y(ji,jk,jl)/(0.25_wp*(state%rho(ji+1,jk,jl-1)+state%rho(ji+1,jk+1,jl-1)+ &
            state%rho(ji+1,jk,jl)+state%rho(ji+1,jk+1,jl)))
          endif
        enddo
      enddo
    enddo
    !$OMP END DO
    !$OMP END PARALLEL

    ! vertical vorticity
    !$OMP PARALLEL
    !$OMP DO PRIVATE(ji,jk)
    do ji=1,nlins+1
      do jk=1,ncols+1
        diag%z_eta_z(ji,jk,:) = diag%z_eta_z(ji,jk,:)/(0.25_wp*(state%rho(ji,jk,:)+state%rho(ji+1,jk,:) &
        +state%rho(ji+1,jk+1,:)+state%rho(ji,jk+1,:)))
      enddo
    enddo
    !$OMP END DO
    !$OMP END PARALLEL

  end subroutine calc_pot_vort

end module vorticities


      SUBROUTINE ZROT( N, CX, INCX, CY, INCY, C, S )
*
*  -- LAPACK auxiliary routine (version 3.2) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2006
*
*     .. Scalar Arguments ..
      INTEGER            INCX, INCY, N
      DOUBLE PRECISION   C
      COMPLEX*16         S
*     ..
*     .. Array Arguments ..
      COMPLEX*16         CX( * ), CY( * )
*     ..
*
*  Purpose
*  =======
*
*  ZROT   applies a plane rotation, where the cos (C) is real and the
*  sin (S) is complex, and the vectors CX and CY are complex.
*
*  Arguments
*  =========
*
*  N       (input) INTEGER
*          The number of elements in the vectors CX and CY.
*
*  CX      (input/output) COMPLEX*16 array, dimension (N)
*          On input, the vector X.
*          On output, CX is overwritten with C*X + S*Y.
*
*  INCX    (input) INTEGER
*          The increment between successive values of CY.  INCX <> 0.
*
*  CY      (input/output) COMPLEX*16 array, dimension (N)
*          On input, the vector Y.
*          On output, CY is overwritten with -CONJG(S)*X + C*Y.
*
*  INCY    (input) INTEGER
*          The increment between successive values of CY.  INCX <> 0.
*
*  C       (input) DOUBLE PRECISION
*  S       (input) COMPLEX*16
*          C and S define a rotation
*             [  C          S  ]
*             [ -conjg(S)   C  ]
*          where C*C + S*CONJG(S) = 1.0.
*
* =====================================================================
*
*     .. Local Scalars ..
      INTEGER            I, IX, IY
      COMPLEX*16         STEMP
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          DCONJG
*     ..
*     .. Executable Statements ..
*
      IF( N.LE.0 )
     $   RETURN
      IF( INCX.EQ.1 .AND. INCY.EQ.1 )
     $   GO TO 20
*
*     Code for unequal increments or equal increments not equal to 1
*
      IX = 1
      IY = 1
      IF( INCX.LT.0 )
     $   IX = ( -N+1 )*INCX + 1
      IF( INCY.LT.0 )
     $   IY = ( -N+1 )*INCY + 1
      DO 10 I = 1, N
         STEMP = C*CX( IX ) + S*CY( IY )
         CY( IY ) = C*CY( IY ) - DCONJG( S )*CX( IX )
         CX( IX ) = STEMP
         IX = IX + INCX
         IY = IY + INCY
   10 CONTINUE
      RETURN
*
*     Code for both increments equal to 1
*
   20 CONTINUE
      DO 30 I = 1, N
         STEMP = C*CX( I ) + S*CY( I )
         CY( I ) = C*CY( I ) - DCONJG( S )*CX( I )
         CX( I ) = STEMP
   30 CONTINUE
      RETURN
      END


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 1998 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                          Spherepack                           *
!     *                                                               *
!     *       A Package of Fortran Subroutines and Programs           *
!     *                                                               *
!     *              for Modeling Geophysical Processes               *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *                  John Adams and Paul Swarztrauber             *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
module icosahedral_geodesic_routines

    use spherepack_precision, only: &
        wp, & ! working precision
        ip, & ! integer precision
        PI

    ! Explicit typing only
    implicit none

    ! Everything is private unless stated otherwise
    private
    public :: ihgeod
    public :: sph2cart
    public :: cart2sph

    ! Parameters confined to the module
    real(wp), parameter :: ZERO = 0.0_wp
    real(wp), parameter :: ONE = 1.0_wp
    real(wp), parameter :: THREE = 3.0_wp

contains

    ! Purpose:
    !
    !     m         is the number of points on the edge of a
    !               single geodesic triangle
    !
    !     x, y, z     the coordinates of the geodesic points on
    !               the sphere are x(i, j, k), y(i, j, k), z(i, j, k)
    !               where i=1, ..., m+m-1; j=1, ..., m; and k=1, ..., 5.
    !               the indices are defined on the unfolded
    !               icosahedron as follows for the case m=3
    !
    !                north pole
    !
    !                 (5, 1)          0      l
    !        i     (4, 1) (5, 2)              a    (repeated for
    !           (3, 1) (4, 2) (5, 3)  theta1   t    k=2, 3, 4, 5 in
    !        (2, 1) (3, 2) (4, 3)              i        -->
    !     (1, 1) (2, 2) (3, 3)        theta2   t    the longitudinal
    !        (1, 2) (2, 3)                    u    direction)
    !           (1, 3)                pi     d
    !      j                                e
    !         south pole
    !
    !                total number of points is 10*(m-1)**2+2
    !                total number of triangles is 20*(m-1)**2
    !                total number of edges is 30*(m-1)**2
    !
    subroutine ihgeod(m, idp, jdp, x, y, z)

        ! Dummy arguments
        integer(ip), intent(in)     :: m
        integer(ip), intent(in)     :: idp
        integer(ip), intent(in)     :: jdp
        real(wp),    intent(inout)  :: x(idp, jdp, 5)
        real(wp),    intent(inout)  :: y(idp, jdp, 5)
        real(wp),    intent(inout)  :: z(idp, jdp, 5)

        ! Local variables
        real(wp)    :: dxi, dxj, dyi, dyj, dzi, dzj
        integer(ip) :: i, j, k
        real(wp)    :: phi, rad, theta
        real(wp)    :: x1, x2, x3, x4, x5, x6, xs
        real(wp)    :: y1, y2, y3, y4, y5, y6, ys
        real(wp)    :: z1, z2, z3, z4, z5, z6, zs

        block
            real(wp), parameter :: DELTA_PHI = 0.4_wp * PI
            real(wp), parameter :: BETA = cos(DELTA_PHI)
            real(wp), parameter :: THETA1 = acos(BETA/(ONE-BETA))
            real(wp), parameter :: THETA2 = PI - THETA1
            real(wp), parameter :: HALF_DELTA_PHI = DELTA_PHI/2
            real(wp), parameter :: TDPHI = THREE * HALF_DELTA_PHI

            do k=1, 5
                phi = real(k-1, kind=wp)* DELTA_PHI
                call sph2cart(ONE, THETA2, phi, x1, y1, z1)
                call sph2cart(ONE, pi, phi+HALF_DELTA_PHI, x2, y2, z2)
                call sph2cart(ONE, THETA2, phi+DELTA_PHI, x3, y3, z3)
                dxi = (x2-x1)/(m-1)
                dyi = (y2-y1)/(m-1)
                dzi = (z2-z1)/(m-1)
                dxj = (x3-x2)/(m-1)
                dyj = (y3-y2)/(m-1)
                dzj = (z3-z2)/(m-1)

                do i=1, m
                    xs = x1 + real(i - 1, kind=wp) * dxi
                    ys = y1 + real(i - 1, kind=wp) * dyi
                    zs = z1 + real(i - 1, kind=wp) * dzi
                    do j=1, i
                        x(j, i, k) = xs + real(j - 1, kind=wp) * dxj
                        y(j, i, k) = ys + real(j - 1, kind=wp) * dyj
                        z(j, i, k) = zs + real(j - 1, kind=wp) * dzj
                    end do
                end do

                call sph2cart(ONE, THETA1, phi+HALF_DELTA_PHI, x4, y4, z4)

                dxi = (x3-x4)/(m-1)
                dyi = (y3-y4)/(m-1)
                dzi = (z3-z4)/(m-1)
                dxj = (x4-x1)/(m-1)
                dyj = (y4-y1)/(m-1)
                dzj = (z4-z1)/(m-1)

                do j=1, m
                    xs = x1 + real(j - 1, kind=wp) * dxj
                    ys = y1 + real(j - 1, kind=wp) * dyj
                    zs = z1 + real(j - 1, kind=wp) * dzj
                    do i=1, j
                        x(j, i, k) = xs + real(i - 1, kind=wp) * dxi
                        y(j, i, k) = ys + real(i - 1, kind=wp) * dyi
                        z(j, i, k) = zs + real(i - 1, kind=wp) * dzi
                    end do
                end do

                call sph2cart(ONE, THETA1, phi+TDPHI, x5, y5, z5)

                dxj = (x5-x3)/(m-1)
                dyj = (y5-y3)/(m-1)
                dzj = (z5-z3)/(m-1)
                do i=1, m
                    xs = x4 + real(i - 1, kind=wp) * dxi
                    ys = y4 + real(i - 1, kind=wp) * dyi
                    zs = z4 + real(i - 1, kind=wp) * dzi
                    do j=1, i
                        x(j+m-1, i, k) = xs + real(j - 1, kind=wp) * dxj
                        y(j+m-1, i, k) = ys + real(j - 1, kind=wp) * dyj
                        z(j+m-1, i, k) = zs + real(j - 1, kind=wp) * dzj
                    end do
                end do

                call sph2cart(ONE, ZERO, phi+DELTA_PHI, x6, y6, z6)

                dxi = (x5-x6)/(m-1)
                dyi = (y5-y6)/(m-1)
                dzi = (z5-z6)/(m-1)
                dxj = (x6-x4)/(m-1)
                dyj = (y6-y4)/(m-1)
                dzj = (z6-z4)/(m-1)
                do j=1, m
                    xs = x4 + real(j - 1, kind=wp) * dxj
                    ys = y4 + real(j - 1, kind=wp) * dyj
                    zs = z4 + real(j - 1, kind=wp) * dzj
                    do i=1, j
                        x(j+m-1, i, k) = xs + real(i - 1, kind=wp) * dxi
                        y(j+m-1, i, k) = ys + real(i - 1, kind=wp) * dyi
                        z(j+m-1, i, k) = zs + real(i - 1, kind=wp) * dzi
                    end do
                end do
            end do

            do k=1, 5
                do j=1, 2*m - 1
                    do i=1, m
                        call cart2sph(x(j, i, k), y(j, i, k), z(j, i, k), rad, theta, phi)
                        call sph2cart(ONE, theta, phi, x(j, i, k), y(j, i, k), z(j, i, k))
                    end do
                end do
            end do
        end block

    end subroutine ihgeod

    pure subroutine cart2sph(x, y, z, r, theta, phi)

        ! Dummy arguments
        real(wp), intent(in)   :: x
        real(wp), intent(in)   :: y
        real(wp), intent(in)   :: z
        real(wp), intent(out)  :: r
        real(wp), intent(out)  :: theta
        real(wp), intent(out)  :: phi

        ! Local variables
        real(wp) :: radial

        radial = hypot(x, y)**2

        if (radial == ZERO) then
            phi = ZERO
            theta = ZERO

            if (z < ZERO) theta = PI

        else
            r = sqrt(radial+z**2)
            radial = sqrt(radial)
            phi = atan2(y, x)
            theta = atan2(radial, z)
        end if

    end subroutine cart2sph

    pure subroutine sph2cart(r, theta, phi, x, y, z)

        ! Dummy arguments
        real(wp), intent(in)  :: r
        real(wp), intent(in)  :: theta
        real(wp), intent(in)  :: phi
        real(wp), intent(out) :: x
        real(wp), intent(out) :: y
        real(wp), intent(out) :: z

        x = r*sin(theta)*cos(phi)
        y = r*sin(theta)*sin(phi)
        z = r*cos(theta)

    end subroutine sph2cart

end module icosahedral_geodesic_routines


C NCLFORTSTART
c c c trend being calculated in C wrapper.
c c c SUBROUTINE kenststncl(xdata,n,s,z,prob,trend)
      SUBROUTINE kenststncl(xdata,n,s,z,prob)
      IMPLICIT none
C                                     ! INPUT
      INTEGER n
      DOUBLE PRECISION    xdata(n)
      DOUBLE PRECISION    eps
C                                     ! OUTPUT
      INTEGER s
c c c DOUBLE PRECISION    z, prob, trend
      DOUBLE PRECISION    z, prob
C NCLEND
      INTEGER nslp                                ! LOCAL ==> INTERFACE
      DOUBLE PRECISION    slope(n*(n-1)/2)        ! MALLOC: Thiel-Sens
      LOGICAL             tieflg(n)               ! MALLOC

      eps    = 1.0d-5                             ! make optional
      nslp   = n*(n-1)/2

c c c      call kenstst(xdata,n,s,z,prob,trend
c c c     +            ,nslp,slope,tieflg,eps,nslp)

      call kenstst(xdata,n,s,z,prob,nslp
     +             ,slope,tieflg,eps,nslp)

      return
      end

c-----------
c c c "trend" was removed from this routine because it is
c c c  being calculated in the NCL C wrapper.
c c c
c c c      SUBROUTINE kenstst(xdata,n,s,z,prob,trend   ! standard
c c c     +                  ,nslp,slope,tieflg,eps,nc)! for NCL interface
c-----------
      SUBROUTINE kenstst(xdata,n,s,z,prob,nslp,slope,tieflg,eps,nc)
      IMPLICIT none
C                                     ! INPUT
      INTEGER n
      DOUBLE PRECISION    xdata(n)
C                                     ! OUTPUT
      INTEGER s, nc
cc    DOUBLE PRECISION    z, prob, trend
      DOUBLE PRECISION    z, prob

      INTEGER nslp                    ! FROM INTERFACE
      DOUBLE PRECISION    slope(nslp) ! MALLOC: Thiel-Sens
      DOUBLE PRECISION    eps
      LOGICAL tieflg(n)
C                                     ! LOCAL
      INTEGER j, k, nt, ntie, ncrit
      DOUBLE PRECISION  diff, dave, var, vartie, zero

      zero = 0.0d0
      ncrit  =  10    ! series must be at least this length

      if (n.lt.ncrit) then
          s    = 0
          z    = zero
          prob = zero
          return
      end if

      eps     = 1d-5  ! closer than this is a tie
      vartie  = zero
      nc      = 0     ! total number of comparisons used (# of non-ties)
      s       = 0     ! S statistic

      DO j=1,nslp
         slope(j) = zero
      END DO

      DO j=1,n
         tieflg(j) = .false.
      END DO

      DO j=1,n-1

         ntie = 1     ! a value is always tied with itself

        DO k=j+1,n
           diff = xdata(k)-xdata(j)

C                     ! close enough for a tie?
           dave = (xdata(j)+xdata(k))/2.0d0
           IF (diff.ne.0.0d0 .and. dave.ne.0.0d0) THEN
               if (abs(diff/dave) .lt. eps) diff = zero
           END IF

C                     ! counts
           nc = nc+1
           slope(nc) = diff/(k-j)

           IF (diff.gt.zero) THEN
               s = s+1
           ELSE IF (diff.lt.zero) THEN
               s = s-1
           ELSE
               ntie      = ntie + 1
               tieflg(k) = .true.
           END IF
        END DO

        IF (ntie.ne.1 .and. .not.tieflg(j)) then
            vartie = vartie + ntie*(ntie-1d0)*(2d0*ntie+5d0)/18d0
c c c       write(*,'("ntie=",i4,"  vartie=",f8.1)') ntie, vartie
        END IF
      END DO
                                                   ! adjustment
      nt    = INT((1d0 + sqrt( 1d0 + 8d0*nc ))/2d0)
      var   = nt* (nt-1d0)* (2d0*nt + 5d0)/18d0    ! simple variance no ties
      var   = var - vartie                         ! adjust for ties

      IF (s.gt.zero) then
          z = (s-1d0)/sqrt(var)
      ELSEIF (s.lt.zero) then
          z = (s+1d0)/sqrt(var)
      ELSE
          z = zero
      END IF

      prob = erf(abs(z)/sqrt(2d0))
c
c Theil-Sen Trend Estimate: sort and take median.
c This is commented out so we can use qsort in
c the C wrapper routine instead, for faster sorting.
c c c
c c c      call dsortu(slope,nc)
c c c      IF (mod(nc,2).eq.0) THEN
c c c          trend = 0.5d0*(slope(nc/2)+slope(nc/2+1))
c c c      ELSE
c c c          trend = slope(nc/2+1)
c c c      END IF

c c c      write(*,'(" n=",i3," s=",i5, " nc=",i6, "  nt=",i3
c c c     *         ," var=",f8.1," vartie=",f8.1," trend=",f10.5)')
c c c     *         n, s, nc, nt, var, vartie, trend

      RETURN
      END


! fortran_free_source
!
!  This module is part of PERFCODE, written by Bradley J. Eck.
!
!  Contents:
!       1. Generate_Grid  Computes the length, width, and area
!                          of each grid cell.
!       2. SET_ELEVATIONS  Gives an elevation to each grid cell center
!
MODULE GridGen
implicit none
contains
!============================================================================
!   \\\\\\\\\        B E G I N      S U B R O U T I N E       ///////////
!   /////////            G E N E R A T E  _ G R I D           \\\\\\\\\\\\
!============================================================================
subroutine Generate_Grid( prelim_dx, prelim_dy )
!   This subroutine takes the centerline geometry file that is generated
!   mannualy and creates a curvilinear grid.
!
!       INPUTS:  Preliminary grid spacing
!       OUTPUTS: Size of computational domain (imax & jmax )
!                Length, width and area of each grid cell ( module SHARED)
!                Coordinates of each CV center
!
USE shared,     ONLY: seg, area, lng, lng_south, lng_north, wid,   &
                      imax, jmax, vmax, CV_Info, astat, gridcell, model_mode
USE outputs,    ONLY: WRITE_MATRIX, WRITE_FLIPPED_MATRIX, WRITE_CV_INFO
USE geom_funcs, ONLY: F_L_xi, UNMAP_X, UNMAP_Y
USE pfc2Dfuns,  ONLY: F_LinearIndex
!------------------------------------------------------------------------------
implicit none
! VARIABLE DECLARATIONS
!   Agruments
real, intent(in) :: prelim_dx, prelim_dy
!   Internal Variables
INTEGER, parameter :: max_rec=144 ! maximum allowable number of rainfall records
integer :: N_seg
CHARACTER(len=20) infile    ! the file name to read parameters from
integer :: i, j, v     ! looping variables
character :: TRASH
real :: xi, eta, X, Y
real :: eta_s, eta_n
integer :: N_xi, N_eta, Seg_num
! for writing border info to file
integer :: factor = 5         ! how many times more border points than CVs?
integer :: ijf ! dummy variable for i or j times the factor
real, allocatable, dimension(:) :: NX, NY, SX, SY, EX, EY, WX, WY
! for writing grid to a file
integer :: res = 4
real, allocatable, dimension(:,:) :: X_gl_long, Y_gl_long, X_gl_tran, Y_gl_tran
!----------------------------------------------------------------------------------------------
! READ IN THE GEOMETRY DATA

! default value for input file
infile = 'CL_Segments.dat'

! Prompt the user for the input file
WRITE(*,*) 'GENERATE_GRID: Enter filename or press / for ', infile
READ(*,*) infile

OPEN( UNIT=8,   FILE = infile, ACTION = 'read', STATUS = 'old' )

! Number of segments
read( unit=8, fmt = * ) N_seg
read( unit=8, fmt = * ) trash

! allocate enough space to read in the CL segments
allocate( seg( N_seg ) )

do i = 1, N_seg
    READ( unit = 8 , fmt = * ) j, seg(j)%xcc1, seg(j)%ycc1, seg(j)%dx, &
                                  seg(j)%dy,   seg(j)%R1,   seg(j)%dR, &
                                  seg(j)%W,    seg(j)%theta1, seg(j)%dtheta
end do

close( 8 )

! estimate the length of each segment by evaluating the metric coefficients
do i = 1, N_seg
    seg(i)%arclen = F_L_xi( 0.5, 0.5, seg(i) ) * 1.0   ! L_xi * Delta_xi
end do

print *, 'Segment    ArcLength'
do i = 1, N_seg
    print *, i, seg(i)%arclen
end do

!total length
print *, '  Total Length: ', sum( seg(:)%arclen )

! average length
print *, 'Average Length: ', sum( seg(:)%arclen ) / real( N_seg )

! Number of elements per segment
!nint = nearest integer
N_xi = nint(  sum( seg(:)%arclen)  / real( N_seg ) / prelim_dx )
N_eta= nint(  sum( seg(:)%W     )  / real( N_seg ) / prelim_dy )
print *, 'N_xi = ', N_xi, '    N_eta = ', N_eta

! size of computational domain
imax = N_xi * N_seg
jmax = N_eta
vmax = imax * jmax

!NOTE: the rest of this subroutine only applies if
!      the model mode is 2D
if2d: if( model_mode .eq. '2D' ) then

  !--------------------------------------------------------
  ! ALLOCATE ARRAYS

  allocate(    lng( imax, jmax),  STAT = astat( 1) )
  allocate(    wid( imax, jmax),  STAT = astat( 2) )
  allocate(   area( imax, jmax),  STAT = astat( 3) )

  allocate(   lng_south( imax, jmax ),    STAT = astat( 6) )
  allocate(   lng_north( imax, jmax ),    STAT = astat( 7) )

  allocate ( CV_Info( vmax ), STAT = astat(17) )
  !---------------------------------------------------------------

  ! Now compute length, width, and area of each cell
  ! should confirm that all widths are the same

  do j = 1, jmax
  !    print *, 'j = ', j
  !    print *, 'i   Segment'
      do i = 1, imax
          ! Determine which segment we're in
          ! the intrinic function CEILING is like ROUNDUP in excel
          Seg_Num = ceiling( real(i) / real( imax ) * real( N_seg ) )
          ! Compute values of xi for the cell that we're in
          if ( i .LE. N_xi ) then
                  xi =   i * 1. / N_xi - 1. / N_xi / 2.
          else
                  xi = ( i - ( Seg_Num - 1 ) * N_xi ) * 1. / N_xi - 1. / N_xi / 2.
          end if
          ! value of eta
          eta = 1. / N_eta * j  -  1. / N_eta / 2.
          ! Physical Coordinates of CV
          X = unmap_x( xi = xi, eta = eta, seg = seg( Seg_Num ) )
          Y = unmap_y( xi = xi, eta = eta, seg = seg( Seg_Num ) )
          ! store the summary information for this cell
          v = F_LinearIndex( i, j, jmax )
          CV_Info(v) = gridcell( i, j, Seg_Num, xi, eta, X, Y )
          ! now compute the quantities of interest for each cell.
  !        print *, i, Seg_Num
          lng (i,j) = F_L_xi( xi, eta, seg( Seg_Num ) ) * 1. / N_xi
          wid (i,j) = seg( Seg_Num)%W / N_eta
          area(i,j) = lng(i,j) * wid(i,j)
          ! compute lengths for north and south faces of cell
          !   south
          eta_s = eta - 1./N_eta * 1./2.
          lng_south(i,j) = F_L_xi( xi, eta_s, seg( Seg_Num) ) * 1./N_xi
          !   north
          eta_n = eta + 1./N_eta * 1./2.
          lng_north(i,j) = F_L_xi( xi, eta_n, seg( Seg_Num) ) * 1./N_xi
      end do
  end do

  !----------------------------------------------------------------------------
  !   >>>>>>>>>>     W R I T E   B O U N D A R Y   C O O R D S    <<<<<<<<<<
  !----------------------------------------------------------------------------
  ! was going to make this a subroutine, but it seemed easier to add it here

  ! Allocate arrays
  ijf = imax * factor
  allocate( NX( ijf) )
  allocate( NY( ijf) )
  allocate( SX( ijf) )
  allocate( SY( ijf) )

  ijf = jmax * factor + 1
  allocate( EX( ijf ) )
  allocate( EY( ijf ) )
  allocate( WX( ijf ) )
  allocate( WY( ijf ) )

  ! NORTH and SOUTH borders
  !re-calc N_xi so as not to change the following formula
  N_xi = N_xi * factor
  do i = 1, imax * factor
      Seg_Num = ceiling( real(i) / real( imax * factor ) * real( N_seg ) )
      ! Compute values of xi
      if ( i .LE. N_xi ) then
              xi =   i * 1. / N_xi - 1. / N_xi / 2.
      else
              xi = ( i - ( Seg_Num - 1 ) * N_xi ) * 1. / N_xi - 1. / N_xi / 2.
      end if
      ! NORTH -- Physical Coordinates on border
      eta = 1.0
      NX(i) = unmap_x( xi = xi, eta = eta, seg = seg( Seg_Num ) )
      NY(i) = unmap_y( xi = xi, eta = eta, seg = seg( Seg_Num ) )
      ! SOUTH -- Physical Coordinates on border
      eta = 0.0
      SX(i) = unmap_x( xi = xi, eta = eta, seg = seg( Seg_Num ) )
      SY(i) = unmap_y( xi = xi, eta = eta, seg = seg( Seg_Num ) )
  end do

  ! EAST and WEST borders
  do j = 1, jmax * factor + 1
      eta = ( j - 1. ) / ( jmax * factor )
      ! WEST
      xi = 0.0
      WX(j) = unmap_x( xi = xi, eta = eta, seg = seg( 1 ) )
      WY(j) = unmap_y( xi = xi, eta = eta, seg = seg( 1 ) )
      ! EAST
      xi = 1.0
      EX(j) = unmap_x( xi = xi, eta = eta, seg = seg( N_seg ) )
      EY(j) = unmap_Y( xi = xi, eta = eta, seg = seg( N_seg ) )
  end do

  ! Write the borders to files
  open( unit = 40, file = 'NS_borders.csv', status = 'REPLACE')
  WRITE(40, *) 'NX, NY, SX, SY,'
  do i = 1, imax * factor
      write(40, 4) NX(i), NY(i), SX(i), SY(i)
  end do
  close(40)

  open( unit = 41, file = 'EW_borders.csv', status = 'REPLACE')
  write( 41, * ) 'EX, EY, WX, WY,'
  do j = 1, jmax * factor + 1
      write(41, 4) EX(j), EY(j), WX(j), WY(j)
  end do
  close(41)

  4 format( 4 (E12.7, ',') )

  !----------------------------------------------------------------------------
  !   >>>>>>>>>   WRITE GRID FOR PLOTTING                     <<<<<<<<<
  !----------------------------------------------------------------------------
  !
  ! envisioning the use of R's MATPLOT command, write a matrix of X coords
  ! and a matrix of Y coords
  ! we plot a bunch of points

  res = 4   !parameter to control the resolution of of the plotting
             ! this is analogous to the variable 'factor'  how many
             ! points do you want per CV?

  allocate( X_gl_long( imax * res, jmax + 1 ) )
  allocate( Y_gl_long( imax * res, jmax + 1 ) )

  ! redefine N_xi to reflect the amplified number of points for the grid
  N_xi = imax / N_seg * res

  ! LONGITUDINAL GRID LINES
  do j = 1, jmax + 1
      !value of eta is constant for each j
      eta = ( j - 1. ) / jmax
      do i = 1,  imax * res
          ! figure out which segment we're in
          Seg_Num = ceiling( real(i) / real( imax * res ) * real( N_seg ) )
          ! Compute values of xi
          if ( i .LE. N_xi ) then
              xi =  ( i - 1. ) / ( N_xi )
          else
              xi = ( i - ( ( Seg_Num - 1. ) * N_xi ) ) * 1. / N_xi
          end if
          X_gl_long(i, j)  = unmap_x( xi = xi, eta = eta, seg = seg( Seg_Num ) )
          Y_gl_long(i, j)  = unmap_y( xi = xi, eta = eta, seg = seg( Seg_Num ) )
      end do
  end do

  call WRITE_MATRIX( X_gl_long, imax * res  , jmax + 1, 'X_gl_long.csv' )
  call WRITE_MATRIX( Y_gl_long, imax * res  , jmax + 1, 'Y_gl_long.csv' )

  !TRANSVERSE GRID LINES (these are just straight and so only require two points)
  allocate( X_gl_tran( 2, imax + 1 ) )
  allocate( Y_gl_tran( 2, imax + 1 ) )

  ! put N_xi back to what its proper value
  N_xi = imax / N_seg

  do j = 1, 2
      eta = j - 1.
      do i = 1, imax + 1
          ! figure out which segment we're in
          Seg_Num = ceiling( real(i) / real( imax + 1 ) * real( N_seg ) )
          ! Compute values of xi
          if ( i .LE. N_xi ) then
              xi =  ( i - 1. ) / ( N_xi )
          else
              xi = ( i - 1.  - ( Seg_Num - 1. ) * N_xi ) / N_xi
          end if
          X_gl_tran(j, i)  = unmap_x( xi = xi, eta = eta, seg = seg( Seg_Num ) )
          Y_gl_tran(j, i)  = unmap_y( xi = xi, eta = eta, seg = seg( Seg_Num ) )
      end do
  end do

  call WRITE_MATRIX( X_gl_tran, 2, imax + 1 , 'X_gl_tran.csv' )
  call WRITE_MATRIX( Y_gl_tran, 2, imax + 1, 'Y_gl_tran.csv' )

!----------------------------------------------------------------------------
endif if2d
!---------------------------------------------------------------------------
end subroutine Generate_Grid
!============================================================================
!   \\\\\\\\\   E N D         S U B R O U T I N E   ///////////
!   /////////       G E N E R A T E _ G R I D       \\\\\\\\\\\\
!===========================================================================

!============================================================================
!   \\\\\\\\\   B E G I N     S U B R O U T I N E   ///////////
!   /////////       S E T _ E L E V A T I O N S     \\\\\\\\\\\\
!===========================================================================
subroutine Set_Elevations( )
!   Gives an elevation to each node of the grid
!
use SHARED, only: Z, imax, jmax, lng_south, CV_Info, seg,  &
                  nr_cs, slope_cs, wid_cs, eta_cs, Z_cs,   &
                  nr_lp, dist_lp, Z_lp, model_mode
use inputs, only: GET_LONG_PROFILE, GET_CROSS_SECTION
use utilities, only: F_Linterp
use outputs,   only: write_flipped_matrix
use pfc2dfuns,  only: F_LinearIndex
implicit none
INTEGER :: i, j, v      ! looping variables
real :: tot_wid  ! total width of the cross section
real :: CL_wid
! Generating elevations
real :: dist_along_lp, Z_eta_0, Z_add

!------------------------------------------------------------------------
! C R O S S   S E C T I O N
!------------------------------------------------------------------------

call GET_CROSS_SECTION( )

! Compute eta and elevation from widths and slopes
!    Given:  widths and slopes  slope_cs   wid_cs, nr_cs
!    Find : Z vs eta
tot_wid = sum( wid_cs(1:nr_cs) )

CL_wid = seg(1) % W

! Check tot_wid for consistency with the width given in CL segments
if(    abs(  tot_wid  -  CL_wid )   .GE. 1.e-3 ) then
    write( *,*) ' Cross Section Width =', tot_wid
    write( *,*) ' Centerline Width = ', CL_wid
    write(*,*) ' SET_ELEVATIONS: Total width specified in Cross Section file'
    write(*,*) '                 is inconsistent with the centerine geometry...Stopping Program'
    STOP

end if

eta_cs(1) = 0.
  z_cs(1) = 0.   !<---dummy value here, elevations are made relative to eta=0

! Compute etas and elevations
do i = 2, nr_cs + 1
    eta_cs(i) = eta_cs(i-1) +   wid_cs(i-1) / tot_wid
      Z_cs(i) =   z_cs(i-1) - slope_cs(i-1) * wid_cs(i-1)
end do

! print the results to confirm
print *, ' CROSS SECTION POINTS '
WRITE(*,*) ' Point        Eta       Elevation '
WRITE(*,*)  '=================================='
do i = 1, nr_cs + 1
    write(*,10) i, eta_cs(i), Z_cs(i)
end do

!------------------------------------------------------------------------
!     L O N G I T D I N A L   P R O F I L E
!------------------------------------------------------------------------
call GET_LONG_PROFILE

!--------------------------------------------------------------------------------
! I N T E R P O L A T E   E L E V A T I O N S
!--------------------------------------------------------------------------------

!NOTE: the rest of this subroutine only applies if
!      the model mode is 2D
if2d: if( model_mode .eq. '2D' ) then

    allocate(         Z( imax, jmax ) );           Z = 0.0  !,  STAT = astat( 4)

    do i = 1, imax
        ! Compute distance along longitudinal profile at eta = 0
        dist_along_lp = sum( lng_south(1:i,1 ) ) - lng_south(i,1)/2.
        ! Compute elevation at eta = 0 for this column of grid cells
        Z_eta_0 = F_Linterp(      x = dist_along_lp  ,   &
                            Known_X = dist_lp        ,   &
                            Known_Y =    Z_lp        ,   &
                                  n =   nr_lp               )
        do j = 1, jmax
            v = F_LinearIndex( i, j , jmax )
            Z_add  =        F_Linterp(       X = CV_Info(v)%eta , &
                                       known_X = eta_cs         , &
                                       known_Y = Z_cs           , &
                                             n = (nr_cs + 1)        )
            Z(i,j) = Z_eta_0  + Z_add
        end do
    end do

endif if2d

!--------------------------------------------------------------------------------
! F O R M A T   S T A T E M E N T S
!--------------------------------------------------------------------------------

10     FORMAT('   ', ( i3, '    '),  ( F10.3, '  ') , F10.6, i12   )

!---------------------------------------------------------------------------
end subroutine Set_Elevations
!============================================================================
!   \\\\\\\\\   E N D      S U B R O U T I N E       ///////////
!   /////////           S E T _ E L E V A T I O N S  \\\\\\\\\\\\
!===========================================================================

END MODULE GridGen


	parameter (g = 0.05)
	parameter (ityp = 5)
	parameter (m = 3)
	parameter (n = 4)
	parameter (n1 = 110)
	parameter (nn = 8)
	parameter (tol = 0.2)

	parameter (n2 = nn * n1)

	real dx (2, n2), dy (2, n2), dz (2, n2)
	integer nclust (n2)

	h1 = 3.5 / nn
	h2 = 4.5 / nn
	fi = h1
	psi = h2
	do 10 j = 1, n2
		fi = fi + h1 / n1
		psi = psi + h2 / n1
		th = 6.283 * (j-1) / (n1-1)
		x = sin (th)
		y = 1.2 * sin (m*th + fi)
		z = 1.5 * sin (n*th + psi)
		if (j .ne. 1) then
			dx (2, j-1) = x
			dy (2, j-1) = y
			dz (2, j-1) = z
		endif
		if (j .ne. n2) then
			dx (1, j) = x
			dy (1, j) = y
			dz (1, j) = z
		endif
  10    continue

	call setpen (4)
	call page (32., 22., 0, 0, 1)
	call region (6., 1., 20., 20., 0, 0, 0)
	call prjhl (1, 15., 8., 3.)
	call vplim (dx, dy, dz, n2, 1, n2, s)
	call setpen (6)
	call hallne (dx, dy, dz, n2, 1, n2, nclust, n2, g, tol, ityp)
	call endpg (' ')
	end