! Jack Yang, Rensselaer Polytechnic Institute
! June 2014
! this subroutine evaluates the special lumped mass matrix
! see Hughes, p445
subroutine lumpmassmatrix(xloc, dloc, doloc, p, hk, ien, f_fluids,ne_local,ien_local,node_local,nn_local, &
                         fden,fvis,I_fluid,rngface)
    use global_constants
    use run_variables
    use fluid_variables
    use solid_variables, only: nn_solid
    use r_common, only: density_solid, vis_solid
    use lumpedmass
    implicit none

    integer ien(nen,ne)
    real* 8 xloc(nsd,nn)                      ! geometry(nodes' locations)
    real* 8 dloc(ndf,nn),doloc(ndf,nn)        ! unknowns(current/previous)
    real* 8 p(ndf,nn),hk(ne)                  ! p: residual; hk: element characteristic length

    real* 8 x(nsd,nen)
    real* 8 d(ndf,nen),d_old(ndf,nen)

    real* 8 eft0,det,effd,effm,effc
    real* 8 sh(0:nsd,nen),ph(0:nsd,nen)
    real* 8 xr(nsd,nsd),cf(nsd,nsd),sx(nsd,nsd)

    real* 8 drt(ndf),drs(ndf),drtavg(ndf),drsavg(ndf)
    real* 8 dr(nsd,ndf),dravg(nsd,ndf)
    real* 8 u,v,w,pp,ug
    real* 8 tau(nsd,nsd)
    real* 8 hg,taum,tauc,vel,ree, taul
    real* 8 mu,nu,ro,g(nsd)
    real* 8 tempc(ndf),temp
    real* 8 dtinv,oma,ama
    integer inl, ie, isd, iq, node,jsd
    integer ieface,irng !,inface

    real* 8 f_fluids(nsd,nn)
    real* 8 fnode(nsd,nen),fq(nsd)
    integer nn_local
    integer node_local(nn_local)
    !-------------------------------------------
    real(8) fden(nn)
    real(8) local_den(nen)
    real(8) fvis(nn)
    real(8) local_vis(nen)
    !---------------------------------------------
    !real(8) TC,ZC,RC,P0,dens0
    real(8) I_fluid(nn)
    real(8) kappa
    integer rngface(neface,ne)
    !============================
    ! MPI varibalbes
    integer ne_local ! # of element on each processor
    integer ien_local(ne_local) ! subregion-->wholeregion element index
    integer ie_local ! loop parameter
    integer icount
    !-----------------------------------------
    !special lumped mass matrix variables
    real(8) alphalump
    real(8) vol, sumdiagcm, inddiagcm(nen)
    integer error_id1, error_id2, error_id3
    !===================================================

    if (allocated(mpqlumpmass)) then
        deallocate(mpqlumpmass)
    endif
    if (allocated(hattauij)) then
        deallocate(hattauij)
    endif
    if (allocated(flagdivision)) then
        deallocate(flagdivision)
    endif
    allocate(mpqlumpmass(nn)     ,stat=error_id1)
    allocate(hattauij(nsd,nsd,nn),stat=error_id2)
    allocate(flagdivision(nn)    ,stat=error_id3)

    mpqlumpmass(1:nn)=0.0

    do ie=1,ne     ! loop over elements
        do inl=1,nen
            node=ien(inl,ie)
            x(1:nsd,inl) = xloc(1:nsd,ien(inl,ie))
        enddo

        hg = hk(ie)
        vol=0.0
        sumdiagcm=0.0
        inddiagcm(1:nen)=0.0
        do iq=1,nquad  ! loop over the quadrature points in each element
            if (nsd==2) then
                if (nen.eq.3) then !calculate shape function at quad point
                    include "sh2d3n.h"
                elseif (nen.eq.4) then
                    include "sh2d4n.h"
                endif
            elseif (nsd==3) then
                if (nen.eq.4) then !calculate shape function at quad point
                    include "sh3d4n.h"
                elseif (nen.eq.8) then
                    include "sh3d8n.h"
                endif
            endif
            eft0 = abs(det) * wq(iq) ! calculate the weight at each quad pt
            vol=vol+eft0
            ph(0:nsd,1:nen) = sh(0:nsd,1:nen)*eft0
            do inl=1,nen
                inddiagcm(inl)=inddiagcm(inl)+eft0*sh(0,inl)**2.0
                sumdiagcm=sumdiagcm+eft0*sh(0,inl)**2.0
            enddo
        enddo ! end of qudrature pts loop

        alphalump=vol/sumdiagcm

        do inl=1,nen
            node=ien(inl,ie)
            mpqlumpmass(node)=mpqlumpmass(node)+alphalump*inddiagcm(inl)
        enddo
    enddo ! end of element loop

return
end subroutine lumpmassmatrix


   PROGRAM GALAHAD_GLTR_EXAMPLE  !  GALAHAD 2.2 - 27/05/2008 AT 14:30 GMT.
   USE GALAHAD_GLTR_DOUBLE                        ! double precision version
   IMPLICIT NONE
   INTEGER, PARAMETER :: working = KIND( 1.0D+0 ) ! set precision
   REAL ( KIND = working ), PARAMETER :: one = 1.0_working, two = 2.0_working
   INTEGER, PARAMETER :: n = 10000                ! problem dimension
   INTEGER :: i
   REAL ( KIND = working ) :: f, radius = 10.0_working  ! radius of ten
   REAL ( KIND = working ), DIMENSION( n ) :: X, R, VECTOR, H_vector
   TYPE ( GLTR_data_type ) :: data
   TYPE ( GLTR_control_type ) :: control
   TYPE ( GLTR_info_type ) :: inform
   CALL GLTR_initialize( data, control )  ! Initialize control parameters
   control%unitm = .FALSE.                ! M is not the identity matrix
   R = one                                ! The linear term is a vector of ones
   inform%status = 1
   DO                                     !  Iteration to find the minimizer
      CALL GLTR_solve( n, radius, f, X, R, VECTOR, data, control, inform )
      SELECT CASE( inform%status )  ! Branch as a result of inform%status
      CASE( 2, 6 )                  ! Form the preconditioned gradient
         VECTOR = VECTOR / two      ! Preconditioner is two times identity
      CASE ( 3, 7 )                 ! Form the matrix-vector product
         H_vector( 1 ) = - two * VECTOR( 1 ) + VECTOR( 2 )
         DO i = 2, n - 1
           H_vector( i ) = VECTOR( i - 1 ) - two * VECTOR( i ) + VECTOR( i + 1 )
         END DO
         H_vector( n ) = VECTOR( n - 1 ) - two * VECTOR( n )
         VECTOR = H_vector
      CASE ( 5 )        !  Restart
         R = one
      CASE ( - 30, 0 )  !  Successful return
         WRITE( 6, "( I6, ' iterations. Solution and Lagrange multiplier = ',  &
        &    2ES12.4 )" ) inform%iter + inform%iter_pass2, f, inform%multiplier
         CALL GLTR_terminate( data, control, inform ) ! delete internal workspace
         EXIT
      CASE DEFAULT      !  Error returns
         WRITE( 6, "( ' GLTR_solve exit status = ', I6 ) " ) inform%status
         CALL GLTR_terminate( data, control, inform ) ! delete internal workspace
         EXIT
      END SELECT
   END DO
   END PROGRAM GALAHAD_GLTR_EXAMPLE


	SUBROUTINE AF_HHFM  ( chhf, rhf, iret )
C************************************************************************
C* AF_HHFM								*
C*									*
C* This subroutine decodes a 3-digit string containing a height value	*
C* in units of hundreds-of-feet into a real height value in units of	*
C* feet.  On output, RHF = RMISSD if CHHF was not successfully	        *
C* decoded.								*
C*									*
C* AF_HHFM  ( CHHF, RHF, IRET )						*
C*									*
C* Input parameters:							*
C*	CHHF		CHAR*3		Encoded	height in ft*100	*
C*									*
C* Output parameters:							*
C*	RHF		REAL		Decoded height in feet    	*
C*	IRET		INTEGER		Return code 			*
C*					  0 = normal return 		*
C*									*
C**									*
C* Log:									*
C* J. Ator/NP12		09/96						*
C* J. Ator/NP12		08/97	New interface format, style changes	*
C* D. Kidwell/NCEP	 7/99	Changed output from meters to feet      *
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'afcmn.cmn'
C*
	CHARACTER*(*)	chhf
C-----------------------------------------------------------------------
C
C*	Initialize variables.
C
	iret = 0
	rhf = RMISSD
C
C*	Decode the string.
C
	lchhf = LEN ( chhf )
	IF  ( lchhf .eq. 3 )  THEN
	    CALL ST_INTG  ( chhf (1:3), ihhf, ier )
	    IF  ( ier .eq. 0 )  THEN
		rhf = FLOAT ( ihhf ) * 100.0
	    END IF
	END IF
C*
	RETURN
	END


*> \brief \b DSYTRF_AA
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DSYTRF_AA + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE DSYTRF_AA( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
*
*       .. Scalar Arguments ..
*       CHARACTER          UPLO
*       INTEGER            N, LDA, LWORK, INFO
*       ..
*       .. Array Arguments ..
*       INTEGER            IPIV( * )
*       DOUBLE PRECISION   A( LDA, * ), WORK( * )
*       ..
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> DSYTRF_AA computes the factorization of a real symmetric matrix A
*> using the Aasen's algorithm.  The form of the factorization is
*>
*>    A = U*T*U**T  or  A = L*T*L**T
*>
*> where U (or L) is a product of permutation and unit upper (lower)
*> triangular matrices, and T is a symmetric tridiagonal matrix.
*>
*> This is the blocked version of the algorithm, calling Level 3 BLAS.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] UPLO
*> \verbatim
*>          UPLO is CHARACTER*1
*>          = 'U':  Upper triangle of A is stored;
*>          = 'L':  Lower triangle of A is stored.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The order of the matrix A.  N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*>          A is DOUBLE PRECISION array, dimension (LDA,N)
*>          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
*>          N-by-N upper triangular part of A contains the upper
*>          triangular part of the matrix A, and the strictly lower
*>          triangular part of A is not referenced.  If UPLO = 'L', the
*>          leading N-by-N lower triangular part of A contains the lower
*>          triangular part of the matrix A, and the strictly upper
*>          triangular part of A is not referenced.
*>
*>          On exit, the tridiagonal matrix is stored in the diagonals
*>          and the subdiagonals of A just below (or above) the diagonals,
*>          and L is stored below (or above) the subdiaonals, when UPLO
*>          is 'L' (or 'U').
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A.  LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] IPIV
*> \verbatim
*>          IPIV is INTEGER array, dimension (N)
*>          On exit, it contains the details of the interchanges, i.e.,
*>          the row and column k of A were interchanged with the
*>          row and column IPIV(k).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK))
*>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*>          LWORK is INTEGER
*>          The length of WORK.  LWORK >= MAX(1,2*N). For optimum performance
*>          LWORK >= N*(1+NB), where NB is the optimal blocksize.
*>
*>          If LWORK = -1, then a workspace query is assumed; the routine
*>          only calculates the optimal size of the WORK array, returns
*>          this value as the first entry of the WORK array, and no error
*>          message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0:  successful exit
*>          < 0:  if INFO = -i, the i-th argument had an illegal value.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2017
*
*> \ingroup doubleSYcomputational
*
*  =====================================================================
      SUBROUTINE DSYTRF_AA( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO)
*
*  -- LAPACK computational routine (version 3.8.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2017
*
      IMPLICIT NONE
*
*     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            N, LDA, LWORK, INFO
*     ..
*     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   A( LDA, * ), WORK( * )
*     ..
*
*  =====================================================================
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
*
*     .. Local Scalars ..
      LOGICAL            LQUERY, UPPER
      INTEGER            J, LWKOPT
      INTEGER            NB, MJ, NJ, K1, K2, J1, J2, J3, JB
      DOUBLE PRECISION   ALPHA
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      EXTERNAL           LSAME, ILAENV
*     ..
*     .. External Subroutines ..
      EXTERNAL           DLASYF_AA, DGEMM, DGEMV, DSCAL, DCOPY, DSWAP,
     $                   XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
*     Determine the block size
*
      NB = ILAENV( 1, 'DSYTRF_AA', UPLO, N, -1, -1, -1 )
*
*     Test the input parameters.
*
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      LQUERY = ( LWORK.EQ.-1 )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -4
      ELSE IF( LWORK.LT.MAX( 1, 2*N ) .AND. .NOT.LQUERY ) THEN
         INFO = -7
      END IF
*
      IF( INFO.EQ.0 ) THEN
         LWKOPT = (NB+1)*N
         WORK( 1 ) = LWKOPT
      END IF
*
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSYTRF_AA', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
*
*     Quick return
*
      IF ( N.EQ.0 ) THEN
          RETURN
      ENDIF
      IPIV( 1 ) = 1
      IF ( N.EQ.1 ) THEN
         RETURN
      END IF
*
*     Adjust block size based on the workspace size
*
      IF( LWORK.LT.((1+NB)*N) ) THEN
         NB = ( LWORK-N ) / N
      END IF
*
      IF( UPPER ) THEN
*
*        .....................................................
*        Factorize A as L*D*L**T using the upper triangle of A
*        .....................................................
*
*        Copy first row A(1, 1:N) into H(1:n) (stored in WORK(1:N))
*
         CALL DCOPY( N, A( 1, 1 ), LDA, WORK( 1 ), 1 )
*
*        J is the main loop index, increasing from 1 to N in steps of
*        JB, where JB is the number of columns factorized by DLASYF;
*        JB is either NB, or N-J+1 for the last block
*
         J = 0
 10      CONTINUE
         IF( J.GE.N )
     $      GO TO 20
*
*        each step of the main loop
*         J is the last column of the previous panel
*         J1 is the first column of the current panel
*         K1 identifies if the previous column of the panel has been
*          explicitly stored, e.g., K1=1 for the first panel, and
*          K1=0 for the rest
*
         J1 = J + 1
         JB = MIN( N-J1+1, NB )
         K1 = MAX(1, J)-J
*
*        Panel factorization
*
         CALL DLASYF_AA( UPLO, 2-K1, N-J, JB,
     $                      A( MAX(1, J), J+1 ), LDA,
     $                      IPIV( J+1 ), WORK, N, WORK( N*NB+1 ) )
*
*        Adjust IPIV and apply it back (J-th step picks (J+1)-th pivot)
*
         DO J2 = J+2, MIN(N, J+JB+1)
            IPIV( J2 ) = IPIV( J2 ) + J
            IF( (J2.NE.IPIV(J2)) .AND. ((J1-K1).GT.2) ) THEN
               CALL DSWAP( J1-K1-2, A( 1, J2 ), 1,
     $                              A( 1, IPIV(J2) ), 1 )
            END IF
         END DO
         J = J + JB
*
*        Trailing submatrix update, where
*         the row A(J1-1, J2-1:N) stores U(J1, J2+1:N) and
*         WORK stores the current block of the auxiriarly matrix H
*
         IF( J.LT.N ) THEN
*
*           If first panel and JB=1 (NB=1), then nothing to do
*
            IF( J1.GT.1 .OR. JB.GT.1 ) THEN
*
*              Merge rank-1 update with BLAS-3 update
*
               ALPHA = A( J, J+1 )
               A( J, J+1 ) = ONE
               CALL DCOPY( N-J, A( J-1, J+1 ), LDA,
     $                          WORK( (J+1-J1+1)+JB*N ), 1 )
               CALL DSCAL( N-J, ALPHA, WORK( (J+1-J1+1)+JB*N ), 1 )
*
*              K1 identifies if the previous column of the panel has been
*               explicitly stored, e.g., K1=1 and K2= 0 for the first panel,
*               while K1=0 and K2=1 for the rest
*
               IF( J1.GT.1 ) THEN
*
*                 Not first panel
*
                  K2 = 1
               ELSE
*
*                 First panel
*
                  K2 = 0
*
*                 First update skips the first column
*
                  JB = JB - 1
               END IF
*
               DO J2 = J+1, N, NB
                  NJ = MIN( NB, N-J2+1 )
*
*                 Update (J2, J2) diagonal block with DGEMV
*
                  J3 = J2
                  DO MJ = NJ-1, 1, -1
                     CALL DGEMV( 'No transpose', MJ, JB+1,
     $                          -ONE, WORK( J3-J1+1+K1*N ), N,
     $                                A( J1-K2, J3 ), 1,
     $                           ONE, A( J3, J3 ), LDA )
                     J3 = J3 + 1
                  END DO
*
*                 Update off-diagonal block of J2-th block row with DGEMM
*
                  CALL DGEMM( 'Transpose', 'Transpose',
     $                        NJ, N-J3+1, JB+1,
     $                       -ONE, A( J1-K2, J2 ), LDA,
     $                             WORK( J3-J1+1+K1*N ), N,
     $                        ONE, A( J2, J3 ), LDA )
               END DO
*
*              Recover T( J, J+1 )
*
               A( J, J+1 ) = ALPHA
            END IF
*
*           WORK(J+1, 1) stores H(J+1, 1)
*
            CALL DCOPY( N-J, A( J+1, J+1 ), LDA, WORK( 1 ), 1 )
         END IF
         GO TO 10
      ELSE
*
*        .....................................................
*        Factorize A as L*D*L**T using the lower triangle of A
*        .....................................................
*
*        copy first column A(1:N, 1) into H(1:N, 1)
*         (stored in WORK(1:N))
*
         CALL DCOPY( N, A( 1, 1 ), 1, WORK( 1 ), 1 )
*
*        J is the main loop index, increasing from 1 to N in steps of
*        JB, where JB is the number of columns factorized by DLASYF;
*        JB is either NB, or N-J+1 for the last block
*
         J = 0
 11      CONTINUE
         IF( J.GE.N )
     $      GO TO 20
*
*        each step of the main loop
*         J is the last column of the previous panel
*         J1 is the first column of the current panel
*         K1 identifies if the previous column of the panel has been
*          explicitly stored, e.g., K1=1 for the first panel, and
*          K1=0 for the rest
*
         J1 = J+1
         JB = MIN( N-J1+1, NB )
         K1 = MAX(1, J)-J
*
*        Panel factorization
*
         CALL DLASYF_AA( UPLO, 2-K1, N-J, JB,
     $                      A( J+1, MAX(1, J) ), LDA,
     $                      IPIV( J+1 ), WORK, N, WORK( N*NB+1 ) )
*
*        Adjust IPIV and apply it back (J-th step picks (J+1)-th pivot)
*
         DO J2 = J+2, MIN(N, J+JB+1)
            IPIV( J2 ) = IPIV( J2 ) + J
            IF( (J2.NE.IPIV(J2)) .AND. ((J1-K1).GT.2) ) THEN
               CALL DSWAP( J1-K1-2, A( J2, 1 ), LDA,
     $                              A( IPIV(J2), 1 ), LDA )
            END IF
         END DO
         J = J + JB
*
*        Trailing submatrix update, where
*          A(J2+1, J1-1) stores L(J2+1, J1) and
*          WORK(J2+1, 1) stores H(J2+1, 1)
*
         IF( J.LT.N ) THEN
*
*           if first panel and JB=1 (NB=1), then nothing to do
*
            IF( J1.GT.1 .OR. JB.GT.1 ) THEN
*
*              Merge rank-1 update with BLAS-3 update
*
               ALPHA = A( J+1, J )
               A( J+1, J ) = ONE
               CALL DCOPY( N-J, A( J+1, J-1 ), 1,
     $                          WORK( (J+1-J1+1)+JB*N ), 1 )
               CALL DSCAL( N-J, ALPHA, WORK( (J+1-J1+1)+JB*N ), 1 )
*
*              K1 identifies if the previous column of the panel has been
*               explicitly stored, e.g., K1=1 and K2= 0 for the first panel,
*               while K1=0 and K2=1 for the rest
*
               IF( J1.GT.1 ) THEN
*
*                 Not first panel
*
                  K2 = 1
               ELSE
*
*                 First panel
*
                  K2 = 0
*
*                 First update skips the first column
*
                  JB = JB - 1
               END IF
*
               DO J2 = J+1, N, NB
                  NJ = MIN( NB, N-J2+1 )
*
*                 Update (J2, J2) diagonal block with DGEMV
*
                  J3 = J2
                  DO MJ = NJ-1, 1, -1
                     CALL DGEMV( 'No transpose', MJ, JB+1,
     $                          -ONE, WORK( J3-J1+1+K1*N ), N,
     $                                A( J3, J1-K2 ), LDA,
     $                           ONE, A( J3, J3 ), 1 )
                     J3 = J3 + 1
                  END DO
*
*                 Update off-diagonal block in J2-th block column with DGEMM
*
                  CALL DGEMM( 'No transpose', 'Transpose',
     $                        N-J3+1, NJ, JB+1,
     $                       -ONE, WORK( J3-J1+1+K1*N ), N,
     $                             A( J2, J1-K2 ), LDA,
     $                        ONE, A( J3, J2 ), LDA )
               END DO
*
*              Recover T( J+1, J )
*
               A( J+1, J ) = ALPHA
            END IF
*
*           WORK(J+1, 1) stores H(J+1, 1)
*
            CALL DCOPY( N-J, A( J+1, J+1 ), 1, WORK( 1 ), 1 )
         END IF
         GO TO 11
      END IF
*
   20 CONTINUE
      RETURN
*
*     End of DSYTRF_AA
*
      END


!Subrotina de verificação do código utilizando soluções manufaturadas

!!! Implementação 15/05/2017
! Leonardo Romero Monteiro

! obs.:1 ao utilizar esta subrotina, deve-se adiconar os termos fontes para as equações de NS e continuidade.

! obs.:2 os casos permanentes só são rodados uma vez, no final do código.

SUBROUTINE mms_i()

USE velpre
USE parametros
USE cond
use mms_m
use ls_param

IMPLICIT NONE
!==================================================================================================================
integer :: i, j, k
real(8) :: x,y,z,h,ha, hpi, dpi
real(8), dimension(nx,ny)     :: h_m
real(8), dimension(nx1,ny)    :: h_mx
real(8), dimension(nx,ny1)    :: h_my
real(8), dimension(nx1,ny,nz) :: lsx
real(8), dimension(nx,ny1,nz) :: lsy
real(8), dimension(nx,ny,nz1) :: lsz

hpi=0.5*pi
dpi=2.0*pi

erro_t = 0.

open (unit=2031989, action= 'write', file= 'dados//erros_mms.txt', status= 'unknown')

! cálculo das condições iniciais para verificar com as soluções manufaturadas
if (mms_t == 1) then ! Weng, 2009 - Caso permanente

	   do k = 1, nz
	   do j = 1, ny
	   do i = 1, nx
		x = (i-0.5)*dx
		y = (j-0.5)*dy
		z = (k-0.5)*dz

		ls(i,j,k) =  a*sin(x)*sin(y)+h0-z
	   enddo
	   enddo
	   enddo

	do j = 1, ny
	do i = 1, nx
	x = (i-0.5)*dx
	y = (j-0.5)*dy
	h_m(i,j) = a*sin(x)*sin(y) + h0
	enddo
	enddo

	do j = 1, ny
	do i = 1, nx1
	x = (i-1. )*dx
	y = (j-0.5)*dy
	h_mx(i,j) = a*sin(x)*sin(y) + h0
	enddo
	enddo

	do j = 1, ny1
	do i = 1, nx
	x = (i-0.5)*dx
	y = (j-1. )*dy
	h_my(i,j) = a*sin(x)*sin(y) + h0
	enddo
	enddo

	do k = 1, nz
	z = (k-0.5)*dz
	do j = 1, ny
	y = (j-0.5)*dy
	do i = 1, nx1
	x = (i-1.0)*dx

	u(i,j,k) =  sin(x)*cos(y)*sin(pi*0.5*z/h_mx(i,j)) - cos(x)*sin(y)*(cos(pi*2.*z/h_mx(i,j))-1.)
	enddo
	enddo
	enddo

	do k = 1, nz
	z = (k-0.5)*dz
	do j = 1, ny1
	y = (j-1.0)*dy
	do i = 1, nx
	x = (i-0.5)*dx

	v(i,j,k) = -cos(x)*sin(y)*sin(pi*0.5*z/h_my(i,j)) + sin(x)*cos(y)*(cos(pi*2.*z/h_my(i,j))-1.)
	enddo
	enddo
	enddo

	do k = 1, nz1
	z = (k-1.0)*dz
	do j = 1, ny
	y = (j-0.5)*dy
	do i = 1, nx
	x = (i-0.5)*dx

	w(i,j,k) = -a*(sin(x)**2.*cos(y)**2.-cos(x)**2.*sin(y)**2.)*(sin(2.*pi*z/h_m(i,j)) &
		     -2.*pi*z/h_m(i,j)*cos(2.*pi*z/h_m(i,j))+2.*pi)/(2.*pi)
	enddo
	enddo
	enddo

elseif (mms_t == 2) then ! Weng, 2009 - Caso não permanente

	   do k = 1, nz
	   do j = 1, ny
	   do i = 1, nx
		x = (i-0.5)*dx-pi
		y = (j-0.5)*dy-pi
		z = (k-0.5)*dz

		ls(i,j,k) =  a*cos(x*0.5)*cos(y*0.5)*cos(t) + h0-z
	   enddo
	   enddo
	   enddo

	do j = 1, ny
	y = (j-0.5)*dy-pi
	do i = 1, nx
	x = (i-0.5)*dx-pi

	 h_m(i,j) = a*cos(x*0.5)*cos(y*0.5)*cos(t) + h0
	enddo
	enddo

	do j = 1, ny
	y = (j-0.5)*dy-pi
	do i = 1, nx1
	x = (i-1. )*dx-pi

	 h_mx(i,j) = a*cos(x*0.5)*cos(y*0.5)*cos(t) + h0
	enddo
	enddo

	do j = 1, ny1
	y = (j-1. )*dy-pi
	do i = 1, nx
	x = (i-0.5)*dx-pi

	 h_my(i,j) = a*cos(x*0.5)*cos(y*0.5)*cos(t) + h0
	enddo
	enddo

	do k = 1, nz
	z = (k-0.5)*dz
	do j = 1, ny
	y = (j-0.5)*dy-pi
	do i = 1, nx1
	x = (i-1.0)*dx-pi

	 u(i,j,k) =  sin(y)*cos(x*0.5)*cos(x*0.5)*cos(hpi*(1.-z/h_mx(i,j)))*sin(t)
	enddo
	enddo
	enddo

	do k = 1, nz
	z = (k-0.5)*dz
	do j = 1, ny1
	y = (j-1.0)*dy-pi
	do i = 1, nx
	x = (i-0.5)*dx-pi

	 v(i,j,k) =  -sin(x)*cos(y*0.5)*cos(y*0.5)*cos(hpi*(1.-z/h_my(i,j)))*sin(t)
	enddo
	enddo
	enddo

	do k = 1, nz1
	z = (k-1.0)*dz
	do j = 1, ny
	y = (j-0.5)*dy-pi
	do i = 1, nx
	x = (i-0.5)*dx-pi

	 w(i,j,k) =  -a*cos(x*0.5)*cos(y*0.5)*cos(hpi*(1.-z/h_m(i,j)))*sin(t)
	enddo
	enddo
	enddo

	do k = 1, nz
	z = (k-0.5)*dz
	do j = 1, ny
	y = (j-0.5)*dy-pi
	do i = 1, nx
	x = (i-0.5)*dx-pi

	 prd1(i,j,k) = -coef*cos(x)*cos(y)*cos(hpi*z/h_m(i,j))
	enddo
	enddo
	enddo

endif

END SUBROUTINE mms_i

SUBROUTINE mms()

USE velpre
USE parametros
use mms_m
use ls_param

IMPLICIT NONE
!==================================================================================================================
integer :: i, j, k, nxc, nyc, nzc, npc

real(8), dimension(nx1,ny,nz) :: u_m
real(8), dimension(nx,ny1,nz) :: v_m
real(8), dimension(nx,ny,nz1) :: w_m
real(8), dimension(nx,ny,nz)  :: p_m
real(8), dimension(nx,ny)     :: h_m
real(8), dimension(nx1,ny)    :: h_mx
real(8), dimension(nx,ny1)    :: h_my
real(8), dimension(nx1,ny,nz) :: lsx
real(8), dimension(nx,ny1,nz) :: lsy
real(8), dimension(nx,ny,nz1) :: lsz

real(8) :: x,y,z,h, hpi

real(8) :: erro_u1, erro_v1, erro_w1, erro_p1

hpi = pi * 0.5

! cálculo das soluções manufaturadas
if (mms_t == 1) then ! Weng, 2009 - Caso permanente

	do j = 1, ny
	y = (j-0.5)*dy
	do i = 1, nx
	x = (i-0.5)*dx

	h_m(i,j) = a*sin(x)*sin(y) + h0
	enddo
	enddo

	do j = 1, ny
	y = (j-0.5)*dy
	do i = 1, nx1
	x = (i-1. )*dx

	h_mx(i,j) = a*sin(x)*sin(y) + h0
	enddo
	enddo

	do j = 1, ny1
	y = (j-1. )*dy
	do i = 1, nx
	x = (i-0.5)*dx

	h_my(i,j) = a*sin(x)*sin(y) + h0
	enddo
	enddo

	do k = 1, nz
	z = (k-0.5)*dz
	do j = 1, ny
	y = (j-0.5)*dy
	do i = 1, nx1
	x = (i-1.0)*dx

	u_m(i,j,k) =  sin(x)*cos(y)*sin(pi*0.5*z/h_mx(i,j)) - cos(x)*sin(y)*(cos(pi*2.*z/h_mx(i,j))-1.)
	enddo
	enddo
	enddo

	do k = 1, nz
	z = (k-0.5)*dz
	do j = 1, ny1
	y = (j-1.0)*dy
	do i = 1, nx
	x = (i-0.5)*dx

	v_m(i,j,k) = -cos(x)*sin(y)*sin(pi*0.5*z/h_my(i,j)) + sin(x)*cos(y)*(cos(pi*2.*z/h_my(i,j))-1.)
	enddo
	enddo
	enddo

	do k = 1, nz1
	z = (k-1.0)*dz
	do j = 1, ny
	y = (j-0.5)*dy
	do i = 1, nx
	x = (i-0.5)*dx

	w_m(i,j,k) = -a*(sin(x)**2.*cos(y)**2.-cos(x)**2.*sin(y)**2.)*(sin(2.*pi*z/h_m(i,j)) &
		     -2.*pi*z/h_m(i,j)*cos(2.*pi*z/h_m(i,j))+2.*pi)/(2.*pi)
	enddo
	enddo
	enddo

elseif (mms_t == 2) then ! Weng, 2009 - Caso não permanente

	do j = 1, ny
	y = (j-0.5)*dy-pi
	do i = 1, nx
	x = (i-0.5)*dx-pi

	 h_m(i,j) = a*cos(x*0.5)*cos(y*0.5)*cos(t) + h0
	enddo
	enddo

	do j = 1, ny
	y = (j-0.5)*dy-pi
	do i = 1, nx1
	x = (i-1. )*dx-pi

	 h_mx(i,j) = a*cos(x*0.5)*cos(y*0.5)*cos(t) + h0
	enddo
	enddo

	do j = 1, ny1
	y = (j-1. )*dy-pi
	do i = 1, nx
	x = (i-0.5)*dx-pi

	 h_my(i,j) = a*cos(x*0.5)*cos(y*0.5)*cos(t) + h0
	enddo
	enddo

	do k = 1, nz
	z = (k-0.5)*dz
	do j = 1, ny
	y = (j-0.5)*dy-pi
	do i = 1, nx1
	x = (i-1.0)*dx-pi

	 u_m(i,j,k) =  sin(y)*cos(x*0.5)*cos(x*0.5)*cos(hpi*(1.-z/h_mx(i,j)))*sin(t)
	enddo
	enddo
	enddo

	do k = 1, nz
	z = (k-0.5)*dz
	do j = 1, ny1
	y = (j-1.0)*dy-pi
	do i = 1, nx
	x = (i-0.5)*dx-pi

	 v_m(i,j,k) =  -sin(x)*cos(y*0.5)*cos(y*0.5)*cos(hpi*(1.-z/h_my(i,j)))*sin(t)
	enddo
	enddo
	enddo

	do k = 1, nz1
	z = (k-1.0)*dz
	do j = 1, ny
	y = (j-0.5)*dy-pi
	do i = 1, nx
	x = (i-0.5)*dx-pi

	 w_m(i,j,k) =  -a*cos(x*0.5)*cos(y*0.5)*cos(hpi*(1.-z/h_m(i,j)))*sin(t)
	enddo
	enddo
	enddo

	do k = 1, nz
	z = (k-0.5)*dz
	do j = 1, ny
	y = (j-0.5)*dy-pi
	do i = 1, nx
	x = (i-0.5)*dx-pi

	 p_m(i,j,k) =  -coef*cos(x)*cos(y)*cos(hpi*z/h_m(i,j))
	enddo
	enddo
	enddo

endif

	call interpx_cf(ls,nx,ny,nz,lsx) !(nx1,ny,nz)
	call interpy_cf(ls,nx,ny,nz,lsy) !(nx,ny1,nz)
	call interpz_cf(ls,nx,ny,nz,lsz) !(nx,ny,nz1)

! cálculo dos erros
erro_u = 0.
erro_v = 0.
erro_w = 0.
nxc = 0
nyc = 0
nzc = 0
npc = 0
	do k = 1, nz
	do j = 1, ny
	do i = 1, nx1
	if (lsx(i,j,k) > 0.) then
		erro_u(i,j,k) = (u_m(i,j,k)-u(i,j,k))**2.
		nxc = nxc + 1
	endif
	enddo
	enddo
	enddo

	do k = 1, nz
	do j = 1, ny1
	do i = 1, nx
	if (lsy(i,j,k) > 0.) then
		erro_v(i,j,k) = (v_m(i,j,k)-v(i,j,k))**2.
		nyc = nyc + 1
	endif
	enddo
	enddo
	enddo

	do k = 1, nz1
	do j = 1, ny
	do i = 1, nx
	if (lsz(i,j,k) > 0.) then
		erro_w(i,j,k) = (w_m(i,j,k)-w(i,j,k))**2.
		nzc = nzc + 1
	endif
	enddo
	enddo
	enddo

	do k = 1, nz
	do j = 1, ny
	do i = 1, nx
	if (ls(i,j,k) > 0.) then
		erro_p(i,j,k) = (p_m(i,j,k)-prd1(i,j,k))**2.
		npc = npc + 1
	endif
	enddo
	enddo
	enddo

	erro_u1 = sqrt(sum(erro_u)/nxc )
	erro_v1 = sqrt(sum(erro_v)/nyc )
	erro_w1 = sqrt(sum(erro_w)/nzc )
	erro_p1 = sqrt(sum(erro_p)/npc )

! plotagem dos erros
if(mod(it, ceiling(dt_frame/dt)).eq.0) then
write(2031989,*) t, dx, erro_u1, dy, erro_v1, dz, erro_w1, 'e_p=', erro_p1
endif

erro_t = (erro_u1 + erro_v1 + erro_w1)/3. + erro_t

!if (it == ts) write(2031989,*) "dt = ", dt, " ",  "erro total acumulado=", erro_t/ts
if (it == ts) write(*,*) "dt = ", dt, " ",  "erro total acumulado=", erro_t/ts

END SUBROUTINE mms

SUBROUTINE mms_bc()

USE velpre
USE parametros
USE cond
use mms_m
use ls_param

IMPLICIT NONE
!==================================================================================================================
integer :: i,j,k
real(8) :: x,y,z,ha,hpi,dpi

hpi=0.5*pi
dpi=2.0*pi

if ((mms_t == 1) .and. (t == 0.)) then ! Weng, 2009 - Caso permanente

	!! c.c. bx
	do k = 0, nz+1
	do j = 0, ny+1
	z = (k-0.5)*dz
	y = (j-0.5)*dy

	i = 0
	x = (i-1.0)*dx
	ha = a*sin(x)*sin(y) + h0
	bxx0(j,k)   = sin(x)*cos(y)*sin(pi*0.5*z/ha) - cos(x)*sin(y)*(cos(pi*2.*z/ha)-1.)

	i = 1
	x = (i-1.0)*dx
	ha = a*sin(x)*sin(y) + h0
	bxx1(j,k)   = sin(x)*cos(y)*sin(pi*0.5*z/ha) - cos(x)*sin(y)*(cos(pi*2.*z/ha)-1.)

	i = nx1
	x = (i-1.0)*dx
	ha = a*sin(x)*sin(y) + h0
	bxxf(j,k)   = sin(x)*cos(y)*sin(pi*0.5*z/ha) - cos(x)*sin(y)*(cos(pi*2.*z/ha)-1.)

	i = nx1+1
	x = (i-1.0)*dx
	ha = a*sin(x)*sin(y) + h0
	bxxf1(j,k)  = sin(x)*cos(y)*sin(pi*0.5*z/ha) - cos(x)*sin(y)*(cos(pi*2.*z/ha)-1.)

	i = 0
	x = (i-.5)*dx
	y = (j-1.)*dy
	z = (k-.5)*dz
	ha = a*sin(x)*sin(y) + h0
	bxy0(j,k)  = -cos(x)*sin(y)*sin(pi*0.5*z/ha) + sin(x)*cos(y)*(cos(pi*2.*z/ha)-1.)
	x = (i-.5)*dx
	y = (j-.5)*dy
	z = (k-1.)*dz
	ha = a*sin(x)*sin(y) + h0
	bxz0(j,k)  = -a*(sin(x)**2.*cos(y)**2.-cos(x)**2.*sin(y)**2.)*(sin(2.*pi*z/ha) &
		     -2.*pi*z/ha*cos(2.*pi*z/ha)+2.*pi)/(2.*pi)
	i = nx+1
	x = (i-.5)*dx
	y = (j-1.)*dy
	z = (k-.5)*dz
	ha = a*sin(x)*sin(y) + h0
	bxyf(j,k)  = -cos(x)*sin(y)*sin(pi*0.5*z/ha) + sin(x)*cos(y)*(cos(pi*2.*z/ha)-1.)
	x = (i-.5)*dx
	y = (j-.5)*dy
	z = (k-1.)*dz
	ha = a*sin(x)*sin(y) + h0
	bxzf(j,k)  = -a*(sin(x)**2.*cos(y)**2.-cos(x)**2.*sin(y)**2.)*(sin(2.*pi*z/ha) &
		     -2.*pi*z/ha*cos(2.*pi*z/ha)+2.*pi)/(2.*pi)

	enddo
	enddo

	!! c.c. by
	do k = 0, nz+1
	do i = 0, nx+1
	z = (k-0.5)*dz
	x = (i-0.5)*dx

	j = 0
	y = (j-1.0)*dy
	ha = a*sin(x)*sin(y) + h0
	byy0(i,k)  =  -cos(x)*sin(y)*sin(pi*0.5*z/ha) + sin(x)*cos(y)*(cos(pi*2.*z/ha)-1.)
	j = 1
	y = (j-1.0)*dy
	ha = a*sin(x)*sin(y) + h0
	byy1(i,k)  =  -cos(x)*sin(y)*sin(pi*0.5*z/ha) + sin(x)*cos(y)*(cos(pi*2.*z/ha)-1.)
	j = ny1
	y = (j-1.0)*dy
	ha = a*sin(x)*sin(y) + h0
	byyf(i,k)  =  -cos(x)*sin(y)*sin(pi*0.5*z/ha) + sin(x)*cos(y)*(cos(pi*2.*z/ha)-1.)
	j = ny1+1
	y = (j-1.0)*dy
	ha = a*sin(x)*sin(y) + h0
	byyf1(i,k) =  -cos(x)*sin(y)*sin(pi*0.5*z/ha) + sin(x)*cos(y)*(cos(pi*2.*z/ha)-1.)

	j = 0
	x = (i-1.)*dx
	y = (j-.5)*dy
	z = (k-.5)*dz
	ha = a*sin(x)*sin(y) + h0
	byx0(i,k)  = sin(x)*cos(y)*sin(pi*0.5*z/ha) - cos(x)*sin(y)*(cos(pi*2.*z/ha)-1.)
	x = (i-.5)*dx
	y = (j-.5)*dy
	z = (k-1.)*dz
	ha = a*sin(x)*sin(y) + h0
	byz0(i,k)  = -a*(sin(x)**2.*cos(y)**2.-cos(x)**2.*sin(y)**2.)*(sin(2.*pi*z/ha) &
		     -2.*pi*z/ha*cos(2.*pi*z/ha)+2.*pi)/(2.*pi)
	j = ny+1
	x = (i-1.)*dx
	y = (j-.5)*dy
	z = (k-.5)*dz
	ha = a*sin(x)*sin(y) + h0
	byxf(i,k)  =  sin(x)*cos(y)*sin(pi*0.5*z/ha) - cos(x)*sin(y)*(cos(pi*2.*z/ha)-1.)
	x = (i-.5)*dx
	y = (j-.5)*dy
	z = (k-1.)*dz
	ha = a*sin(x)*sin(y) + h0
	byzf(i,k)  = -a*(sin(x)**2.*cos(y)**2.-cos(x)**2.*sin(y)**2.)*(sin(2.*pi*z/ha) &
		     -2.*pi*z/ha*cos(2.*pi*z/ha)+2.*pi)/(2.*pi)
	enddo
	enddo

	!! c.c. bz
	do j = 0, ny+1
	do i = 0, nx+1
	y = (j-0.5)*dy
	x = (i-0.5)*dx
	ha = a*sin(x)*sin(y) + h0

	k = 0
	z = (k-1.)*dz
	bzz0(i,j)  = -a*(sin(x)**2.*cos(y)**2.-cos(x)**2.*sin(y)**2.)*(sin(2.*pi*z/ha) &
		     -2.*pi*z/ha*cos(2.*pi*z/ha)+2.*pi)/(2.*pi)
	k = 1
	z = (k-1.)*dz
	bzz1(i,j)  = -a*(sin(x)**2.*cos(y)**2.-cos(x)**2.*sin(y)**2.)*(sin(2.*pi*z/ha) &
		     -2.*pi*z/ha*cos(2.*pi*z/ha)+2.*pi)/(2.*pi)
	k = nz1
	z = (k-1.)*dz
	bzzf(i,j)  = -a*(sin(x)**2.*cos(y)**2.-cos(x)**2.*sin(y)**2.)*(sin(2.*pi*z/ha) &
		     -2.*pi*z/ha*cos(2.*pi*z/ha)+2.*pi)/(2.*pi)
	k = nz1+1
	z = (k-1.)*dz
	bzzf1(i,j)  = -a*(sin(x)**2.*cos(y)**2.-cos(x)**2.*sin(y)**2.)*(sin(2.*pi*z/ha) &
		      -2.*pi*z/ha*cos(2.*pi*z/ha)+2.*pi)/(2.*pi)

	k= 0
	x = (i-1.)*dx
	y = (j-.5)*dy
	z = (k-.5)*dz
	ha = a*sin(x)*sin(y) + h0
	bzx0(i,j)  =  sin(x)*cos(y)*sin(pi*0.5*z/ha) - cos(x)*sin(y)*(cos(pi*2.*z/ha)-1.)
	x = (i-.5)*dx
	y = (j-1.)*dy
	z = (k-.5)*dz
	ha = a*sin(x)*sin(y) + h0
	bzy0(i,j)  = -cos(x)*sin(y)*sin(pi*0.5*z/ha) + sin(x)*cos(y)*(cos(pi*2.*z/ha)-1.)

	k = nz+1
	x = (i-1.)*dx
	y = (j-.5)*dy
	z = (k-.5)*dz
	ha = a*sin(x)*sin(y) + h0
	bzxf(i,j)  =  sin(x)*cos(y)*sin(pi*0.5*z/ha) - cos(x)*sin(y)*(cos(pi*2.*z/ha)-1.)
	x = (i-.5)*dx
	y = (j-1.)*dy
	z = (k-.5)*dz
	ha = a*sin(x)*sin(y) + h0
	bzyf(i,j)  = -cos(x)*sin(y)*sin(pi*0.5*z/ha) + sin(x)*cos(y)*(cos(pi*2.*z/ha)-1.)

	enddo
	enddo

elseif (mms_t == 2) then ! Weng, 2009 - Caso não permanente

	!! c.c. bx
	do k = 0, nz+1
	do j = 0, ny+1
	z = (k-0.5)*dz
	y = (j-0.5)*dy-pi

	i = 0
	x = (i-1.0)*dx-pi

	ha = a*cos(x*0.5)*cos(y*0.5)*cos(t) + h0
	bxx0(j,k)   = sin(y)*cos(x*0.5)*cos(x*0.5)*cos(hpi*(1.-z/ha))*sin(t)

	i = 1
	x = (i-1.0)*dx-pi
	ha = a*cos(x*0.5)*cos(y*0.5)*cos(t) + h0
	bxx1(j,k)   = sin(y)*cos(x*0.5)*cos(x*0.5)*cos(hpi*(1.-z/ha))*sin(t)

	i = nx1
	x = (i-1.0)*dx-pi
	ha = a*cos(x*0.5)*cos(y*0.5)*cos(t) + h0
	bxxf(j,k)   = sin(y)*cos(x*0.5)*cos(x*0.5)*cos(hpi*(1.-z/ha))*sin(t)

	i = nx1+1
	x = (i-1.0)*dx-pi
	ha = a*cos(x*0.5)*cos(y*0.5)*cos(t) + h0
	bxxf1(j,k)  = sin(y)*cos(x*0.5)*cos(x*0.5)*cos(hpi*(1.-z/ha))*sin(t)

	i = 0
	x = (i-.5)*dx-pi
	y = (j-1.)*dy-pi
	z = (k-.5)*dz
	ha = a*cos(x*0.5)*cos(y*0.5)*cos(t) + h0
	bxy0(j,k)  = -sin(x)*cos(y*0.5)*cos(y*0.5)*cos(hpi*(1.-z/ha))*sin(t)
	x = (i-.5)*dx-pi
	y = (j-.5)*dy-pi
	z = (k-1.)*dz
	ha = a*cos(x*0.5)*cos(y*0.5)*cos(t) + h0
	bxz0(j,k)  = -a*cos(x*0.5)*cos(y*0.5)*cos(hpi*(1.-z/ha))*sin(t)

	i = nx+1
	x = (i-.5)*dx-pi
	y = (j-1.)*dy-pi
	z = (k-.5)*dz
	ha = a*cos(x*0.5)*cos(y*0.5)*cos(t) + h0
	bxyf(j,k)  = -sin(x)*cos(y*0.5)*cos(y*0.5)*cos(hpi*(1.-z/ha))*sin(t)
	x = (i-.5)*dx-pi
	y = (j-.5)*dy-pi
	z = (k-1.)*dz
	ha = a*cos(x*0.5)*cos(y*0.5)*cos(t) + h0
	bxzf(j,k)  = -a*cos(x*0.5)*cos(y*0.5)*cos(hpi*(1.-z/ha))*sin(t)

	enddo
	enddo

	!! c.c. by
	do k = 0, nz+1
	do i = 0, nx+1
	z = (k-.5)*dz
	x = (i-0.5)*dx-pi

	j = 0
	y = (j-1.0)*dy-pi
	ha = a*cos(x*0.5)*cos(y*0.5)*cos(t) + h0
	byy0(i,k)  =  -sin(x)*cos(y*0.5)*cos(y*0.5)*cos(hpi*(1.-z/ha))*sin(t)
	j = 1
	y = (j-1.0)*dy-pi
	ha = a*cos(x*0.5)*cos(y*0.5)*cos(t) + h0
	byy1(i,k)  =  -sin(x)*cos(y*0.5)*cos(y*0.5)*cos(hpi*(1.-z/ha))*sin(t)
	j = ny1
	y = (j-1.0)*dy-pi
	ha = a*cos(x*0.5)*cos(y*0.5)*cos(t) + h0
	byyf(i,k)  =  -sin(x)*cos(y*0.5)*cos(y*0.5)*cos(hpi*(1.-z/ha))*sin(t)
	j = ny1+1
	y = (j-1.0)*dy-pi
	ha = a*cos(x*0.5)*cos(y*0.5)*cos(t) + h0
	byyf1(i,k) =  -sin(x)*cos(y*0.5)*cos(y*0.5)*cos(hpi*(1.-z/ha))*sin(t)

	j = 0
	x = (i-1.)*dx-pi
	y = (j-.5)*dy-pi
	z = (k-.5)*dz
	ha = a*cos(x*0.5)*cos(y*0.5)*cos(t) + h0
	byx0(i,k)  = sin(y)*cos(x*0.5)*cos(x*0.5)*cos(hpi*(1.-z/ha))*sin(t)
	x = (i-.5)*dx-pi
	y = (j-.5)*dy-pi
	z = (k-1.)*dz
	ha = a*cos(x*0.5)*cos(y*0.5)*cos(t) + h0
	byz0(i,k)  = -a*cos(x*0.5)*cos(y*0.5)*cos(hpi*(1.-z/ha))*sin(t)

	j = ny+1
	x = (i-1.)*dx-pi
	y = (j-.5)*dy-pi
	z = (k-.5)*dz
	ha = a*cos(x*0.5)*cos(y*0.5)*cos(t) + h0
	byxf(i,k)  =  sin(y)*cos(x*0.5)*cos(x*0.5)*cos(hpi*(1.-z/ha))*sin(t)
	x = (i-.5)*dx-pi
	y = (j-.5)*dy-pi
	z = (k-1.)*dz
	ha = a*cos(x*0.5)*cos(y*0.5)*cos(t) + h0
	byzf(i,k)  = -a*cos(x*0.5)*cos(y*0.5)*cos(hpi*(1.-z/ha))*sin(t)

	enddo
	enddo

	!! c.c. bz
	do j = 0, ny+1
	do i = 0, nx+1
	y = (j-0.5)*dy-pi
	x = (i-0.5)*dx-pi
	ha = a*cos(x*0.5)*cos(y*0.5)*cos(t) + h0

	k = 0
	z = (k-1.)*dz
	bzz0(i,j)  = -a*cos(x*0.5)*cos(y*0.5)*cos(hpi*(1.-z/ha))*sin(t)

	k = 1
	z = (k-1.)*dz
	bzz1(i,j)  = -a*cos(x*0.5)*cos(y*0.5)*cos(hpi*(1.-z/ha))*sin(t)

	k = nz1
	z = (k-1.)*dz
	bzzf(i,j)  = -a*cos(x*0.5)*cos(y*0.5)*cos(hpi*(1.-z/ha))*sin(t)

	k = nz1+1
	z = (k-1.)*dz
	bzzf1(i,j)  = -a*cos(x*0.5)*cos(y*0.5)*cos(hpi*(1.-z/ha))*sin(t)

	k= 0
	x = (i-1.)*dx-pi
	y = (j-.5)*dy-pi
	z = (k-.5)*dz
	ha = a*cos(x*0.5)*cos(y*0.5)*cos(t) + h0
	bzx0(i,j)  =  sin(y)*cos(x*0.5)*cos(x*0.5)*cos(hpi*(1.-z/ha))*sin(t)
	x = (i-.5)*dx-pi
	y = (j-1.)*dy-pi
	z = (k-.5)*dz
	ha = a*cos(x*0.5)*cos(y*0.5)*cos(t) + h0
	bzy0(i,j)  = -a*cos(x*0.5)*cos(y*0.5)*cos(hpi*(1.-z/ha))*sin(t)

	k = nz+1
	x = (i-1.)*dx-pi
	y = (j-.5)*dy-pi
	z = (k-.5)*dz
	ha = a*cos(x*0.5)*cos(y*0.5)*cos(t) + h0
	bzxf(i,j)  =  sin(y)*cos(x*0.5)*cos(x*0.5)*cos(hpi*(1.-z/ha))*sin(t)
	x = (i-.5)*dx-pi
	y = (j-1.)*dy-pi
	z = (k-.5)*dz
	ha = a*cos(x*0.5)*cos(y*0.5)*cos(t) + h0
	bzyf(i,j)  = -a*cos(x*0.5)*cos(y*0.5)*cos(hpi*(1.-z/ha))*sin(t)

	enddo
	enddo
endif

END SUBROUTINE mms_bc

SUBROUTINE termo_fonte1()

! x, y and z are location of nodes in a 3D domain
! h0 is the reference surface height
! a  is the surface wave amplitude
! sn is the sign of h(x,y): sn=1.0 or -1.0
! L is the number of vertical mesh and LMAX is the maximum

use mms_m
IMPLICIT NONE

integer :: i,j,k

real(8) :: x,y,z,hpi,dpi,h1,h2,h3,zh1,h4,h5,dhdx,dhdy,d2hdx2,d2hdy2,d2hdxy, visc

real(8) :: ux, vx, wx
real(8) :: uy, vy, wy
real(8) :: uz, vz, wz

real(8) :: dudx,dudy,dudz,d2udx2,d2udy2,d2udz2,d2udxy,d2udxz,d2udyz
real(8) :: dvdx,dvdy,dvdz,d2vdx2,d2vdy2,d2vdz2,d2vdxy,d2vdxz,d2vdyz
real(8) :: dwdx,dwdy,dwdz,d2wdx2,d2wdy2,d2wdz2,d2wdxy,d2wdxz,d2wdyz

hpi=0.5*pi
dpi=2.0*pi

visc = 0.00100798/998.
!-------- derivadas para o termo fonte Fu
do k = 1, nz
do j = 1, ny
do i = 1, nx1
	x = (i-1.0)*dx
	y = (j-0.5)*dy
	z = (k-0.5)*dz

	dhdx=   a*cos(x)*sin(y)
	dhdy=   a*sin(x)*cos(y)
	d2hdx2=-a*sin(x)*sin(y)
	d2hdy2=-a*sin(x)*sin(y)
	d2hdxy= a*cos(x)*cos(y)

	h1 = a*sin(x)*sin(y) + h0
	h2 = h1*h1
	h3 = h2*h1
	h4 = h3*h1
	h5 = h4*h1

	zh1 = z/h1

	ux =  sin(x)*cos(y)*sin(hpi*zh1) - cos(x)*sin(y)*(cos(dpi*zh1)-1.)
	vx = -cos(x)*sin(y)*sin(hpi*zh1) + sin(x)*cos(y)*(cos(dpi*zh1)-1.)
	wx = -a*(sin(x)**2.*cos(y)**2.-cos(x)**2.*sin(y)**2.)*(sin(dpi*zh1) &
		     -dpi*zh1*cos(dpi*zh1)+dpi)/(dpi)

	dudx= cos(x)*cos(y)*sin(hpi*zh1)+sin(x)*sin(y)*(cos(dpi*zh1)-1.) &
	     -sin(x)*cos(y)*(hpi*z/h2)*cos(hpi*zh1)*dhdx &
	     -cos(x)*sin(y)*(dpi*z/h2)*sin(dpi*zh1)*dhdx

	dudy=-sin(x)*sin(y)*sin(hpi*zh1)-cos(x)*cos(y)*(cos(dpi*zh1)-1.) &
	     +sin(x)*cos(y)*(-hpi*z/h2)*cos(hpi*zh1)*dhdy &
	     +cos(x)*sin(y)*(-dpi*z/h2)*sin(dpi*zh1)*dhdy

	dudz=(hpi/h1)*sin(x)*cos(y)*cos(hpi*zh1)+(dpi/h1)*cos(x)*sin(y)*sin(dpi*zh1)

	d2udx2=-ux &
	       	+2.*cos(x)*cos(y)*(-hpi*z/h2)*cos(hpi*zh1)*dhdx &
		+2.*sin(x)*sin(y)*( dpi*z/h2)*sin(dpi*zh1)*dhdx &
		+sin(x)*cos(y)*(-(hpi*z/h2)**2*sin(hpi*zh1)+ (pi*z/h3)*cos(hpi*zh1))*dhdx**2 &
		+cos(x)*sin(y)*( (dpi*z/h2)**2*cos(dpi*zh1)+4.*pi*z/h3*sin(dpi*zh1))*dhdx**2 &
	       -(sin(x)*cos(y)*hpi*z/h2*cos(hpi*zh1)+cos(x)*sin(y)*(dpi*z/h2)*sin(dpi*zh1))*d2hdx2

	d2udy2=-ux &
		-2.*sin(x)*sin(y)*(-hpi*z/h2)*cos(hpi*zh1)*dhdy &
		-2.*cos(x)*cos(y)*( dpi*z/h2)*sin(dpi*zh1)*dhdy &
		+sin(x)*cos(y)*(-(hpi*z/h2)**2*sin(hpi*zh1)+ (pi*z/h3)*cos(hpi*zh1))*dhdy**2 &
		+cos(x)*sin(y)*( (dpi*z/h2)**2*cos(dpi*zh1)+4.*pi*z/h3*sin(dpi*zh1))*dhdy**2 &
		-(sin(x)*cos(y)*hpi*z/h2*cos(hpi*zh1)-cos(x)*sin(y)*(dpi*z/h2)*sin(dpi*zh1))*d2hdy2

	d2udz2=-(hpi/h1)**2.*sin(x)*cos(y)*sin(hpi*zh1) &
		+(dpi/h1)**2.*cos(x)*sin(y)*cos(dpi*zh1)

	d2vdxy=sin(x)*cos(y)*sin(hpi*zh1)-cos(x)*sin(y)*(cos(dpi*zh1)-1.0) &
		+sin(x)*sin(y)*(-hpi*z/h2)*cos(hpi*zh1)*dhdy &
		+cos(x)*cos(y)*( dpi*z/h2)*sin(dpi*zh1)*dhdy &
		+cos(x)*cos(y)*( hpi*z/h2)*cos(hpi*zh1)*dhdx &
		-sin(x)*sin(y)*( dpi*z/h2)*sin(dpi*zh1)*dhdx &
		+cos(x)*sin(y)*( (hpi*z/h2)**2*sin(hpi*zh1)- (pi*z/h3)*cos(hpi*zh1))*dhdx*dhdy &
		+sin(x)*cos(y)*(-(dpi*z/h2)**2*cos(dpi*zh1)-(4.*pi*z/h3)*sin(dpi*zh1))*dhdx*dhdy &
		+(cos(x)*sin(y)*(hpi*z/h2)*cos(hpi*zh1)+sin(x)*cos(y)*dpi*z/h2*sin(dpi*zh1))*d2hdxy

	d2wdxz=-a/dpi*sin(2.*x)*(dpi*dpi*z/h2)*sin(dpi*zh1) &
		+a/dpi*(sin(x)**2*cos(y)**2-cos(x)**2*sin(y)**2) &
		*((8.*pi*pi*z/h3)*sin(dpi*zh1)+(8.*pi*pi*pi*z*z/h4)*cos(dpi*zh1))*dhdx

	tf_u(i,j,k) = ux*dudx + vx*dudy + wx*dudz &
		     -visc*(d2udx2+d2udy2+d2udz2+d2udx2+d2vdxy+d2wdxz)

enddo
enddo
enddo

!-------- derivadas para o termo fonte Fv
do k = 1, nz
do j = 1, ny1
do i = 1, nx
	x = (i-0.5)*dx
	y = (j-1.0)*dy
	z = (k-0.5)*dz

	dhdx=   a*cos(x)*sin(y)
	dhdy=   a*sin(x)*cos(y)
	d2hdx2=-a*sin(x)*sin(y)
	d2hdy2=-a*sin(x)*sin(y)
	d2hdxy= a*cos(x)*cos(y)

	h1 = a*sin(x)*sin(y) + h0
	h2 = h1*h1
	h3 = h2*h1
	h4 = h3*h1
	h5 = h4*h1

	zh1 = z/h1

	uy =  sin(x)*cos(y)*sin(hpi*zh1) - cos(x)*sin(y)*(cos(dpi*zh1)-1.)
	vy = -cos(x)*sin(y)*sin(hpi*zh1) + sin(x)*cos(y)*(cos(dpi*zh1)-1.)
	wy = -a*(sin(x)**2.*cos(y)**2.-cos(x)**2.*sin(y)**2.)*(sin(dpi*zh1) &
		     -dpi*zh1*cos(dpi*zh1)+dpi)/(dpi)

	   dvdx= sin(x)*sin(y)*sin(hpi*zh1)+cos(x)*cos(y)*(cos(dpi*zh1)-1.0) &
		+cos(x)*sin(y)*(hpi*z/h2)*cos(hpi*zh1)*dhdx &
		+sin(x)*cos(y)*(dpi*z/h2)*sin(dpi*zh1)*dhdx

	   dvdy=-cos(x)*cos(y)*sin(hpi*zh1)-sin(x)*sin(y)*(cos(dpi*zh1)-1.0) &
		+cos(x)*sin(y)*(hpi*z/h2)*cos(hpi*zh1)*dhdy &
		+sin(x)*cos(y)*(dpi*z/h2)*sin(dpi*zh1)*dhdy

	   dvdz=-(hpi/h1)*cos(x)*sin(y)*cos(hpi*zh1)-sin(x)*cos(y)*(dpi/h1)*sin(dpi*zh1)

	   d2vdx2=-vy &
		+2.*sin(x)*sin(y)*(-hpi*z/h2)*cos(hpi*zh1)*dhdx &
		+2.*cos(x)*cos(y)*( dpi*z/h2)*sin(dpi*zh1)*dhdx &
		-cos(x)*sin(y)*(-(hpi*z/h2)**2*sin(hpi*zh1)+   pi*z/h3*cos(hpi*zh1))*dhdx**2 &
		-sin(x)*cos(y)*( (dpi*z/h2)**2*cos(dpi*zh1)+4.*pi*z/h3*sin(dpi*zh1))*dhdx**2 &
		+(cos(x)*sin(y)*hpi*z/h2*cos(hpi*zh1)+sin(x)*cos(y)*dpi*z/h2*sin(dpi*zh1))*d2hdx2

	   d2vdy2=-vy &
		-2.*cos(x)*cos(y)*(-hpi*z/h2)*cos(hpi*zh1)*dhdy &
		-2.*sin(x)*sin(y)*( dpi*z/h2)*sin(dpi*zh1)*dhdy &
		+(cos(x)*sin(y)*hpi*z/h2*cos(hpi*zh1)+sin(x)*cos(y)*(dpi*z/h2)*sin(dpi*zh1))*d2hdy2 &
		+ cos(x)*sin(y)*((hpi*z/h2)**2*sin(hpi*zh1)-   pi*z/h3*cos(hpi*zh1))*dhdy*dhdy &
		- sin(x)*cos(y)*((dpi*z/h2)**2*cos(dpi*zh1)+4.*pi*z/h3*sin(dpi*zh1))*dhdy*dhdy

	   d2vdz2=(hpi/h1)**2*cos(x)*sin(y)*sin(hpi*zh1)-sin(x)*cos(y)*(dpi/h1)**2*cos(dpi*zh1)

	   d2udxy=-cos(x)*sin(y)*sin(hpi*zh1)+sin(x)*cos(y)*(cos(dpi*zh1)-1.0) &
		+(sin(x)*sin(y)*dhdx-cos(x)*cos(y)*dhdy)*(hpi*z/h2)*cos(hpi*zh1) &
		+(sin(x)*sin(y)*dhdy-cos(x)*cos(y)*dhdx)*(dpi*z/h2)*sin(dpi*zh1) &
		-(sin(x)*cos(y)*(hpi*z/h2)*cos(hpi*zh1)+cos(x)*sin(y)*(dpi*z/h2)*sin(dpi*zh1))*d2hdxy &
		+ sin(x)*cos(y)*(-(hpi*z/h2)**2*sin(hpi*zh1)+   pi*z/h3*cos(hpi*zh1))*dhdx*dhdy &
		+ cos(x)*sin(y)*( (dpi*z/h2)**2*cos(dpi*zh1)+4.*pi*z/h3*sin(dpi*zh1))*dhdx*dhdy

	   d2wdyz= a/dpi*sin(2.*y)*(dpi*dpi*z/h2)*sin(dpi*zh1) &
		+a/dpi*(sin(x)**2*cos(y)**2-cos(x)**2*sin(y)**2) &
		*((8.*pi*pi*z/h3)*sin(dpi*zh1)+(8.*pi*pi*pi*z*z/h4)*cos(dpi*zh1))*dhdy

	tf_v(i,j,k) = uy*dvdx + vy*dvdy + wy*dvdz &
		     -visc*(d2vdx2+d2vdy2+d2vdz2+d2udxy+d2vdy2+d2wdyz)

enddo
enddo
enddo

!-------- derivatives of w
do k = 1, nz1
do j = 1, ny
do i = 1, nx
	x = (i-0.5)*dx
	y = (j-0.5)*dy
	z = (k-1.0)*dz

	dhdx=   a*cos(x)*sin(y)
	dhdy=   a*sin(x)*cos(y)
	d2hdx2=-a*sin(x)*sin(y)
	d2hdy2=-a*sin(x)*sin(y)
	d2hdxy= a*cos(x)*cos(y)

	h1 = a*sin(x)*sin(y) + h0
	h2 = h1*h1
	h3 = h2*h1
	h4 = h3*h1
	h5 = h4*h1

	zh1 = z/h1

	uz =  sin(x)*cos(y)*sin(pi*0.5*zh1) - cos(x)*sin(y)*(cos(pi*2.*zh1)-1.)
	vz = -cos(x)*sin(y)*sin(pi*0.5*zh1) + sin(x)*cos(y)*(cos(pi*2.*zh1)-1.)
	wz = -a*(sin(x)**2.*cos(y)**2.-cos(x)**2.*sin(y)**2.)*(sin(dpi*zh1) &
		     -dpi*zh1*cos(dpi*zh1)+dpi)/(dpi)

	   dwdx=-a/dpi*sin(2.*x)*(sin(dpi*zh1)-(dpi*zh1)*cos(dpi*zh1)+dpi) &
		+a/dpi*(sin(x)**2*cos(y)**2-cos(x)**2*sin(y)**2)*(dpi*dpi*z*z/h3)*sin(dpi*zh1)*dhdx

	   dwdy= a/dpi*sin(2.*y)*(sin(dpi*zh1)-(dpi*zh1)*cos(dpi*zh1)+dpi) &
		+a/dpi*(sin(x)**2*cos(y)**2-cos(x)**2*sin(y)**2)*(dpi*dpi*z*z/h3)*sin(dpi*zh1)*dhdy

	   dwdz=-a*dpi*z/h2*(sin(x)**2*cos(y)**2-cos(x)**2*sin(y)**2)*sin(dpi*zh1)

	   d2wdx2=-a/pi*cos(2.*x)*(sin(dpi*zh1)-(dpi*zh1)*cos(dpi*zh1)+dpi) &
		+a/pi*sin(2.*x)*(dpi*dpi*z*z/h3)*sin(dpi*zh1)*dhdx &
		+a/dpi*(sin(x)**2*cos(y)**2-cos(x)**2*sin(y)**2)*(-(dpi**3.*z**3./h5) &
		*cos(dpi*zh1)-(12.*pi*pi*z*z/h4)*sin(dpi*zh1))*dhdx*dhdx &
		+a/dpi*(sin(x)**2*cos(y)**2-cos(x)**2*sin(y)**2)*(4.*pi*pi*z*z/h3)*sin(dpi*zh1)*d2hdx2

	   d2wdy2= a/pi*cos(2.*y)*(sin(dpi*zh1)-(dpi*zh1)*cos(dpi*zh1)+dpi) &
		-a/pi*sin(2.*y)*(dpi*dpi*z*z/h3)*sin(dpi*zh1)*dhdy &
		+a/dpi*(sin(x)**2*cos(y)**2-cos(x)**2*sin(y)**2)*(-(dpi**3.*z**3./h5) &
		*cos(dpi*zh1)-(12.*pi*pi*z*z/h4)*sin(dpi*zh1))*dhdy*dhdy &
		+a/dpi*(sin(x)**2*cos(y)**2-cos(x)**2*sin(y)**2)*(dpi*dpi*z*z/h3)*sin(dpi*zh1)*d2hdy2

	   d2wdz2=-a*(sin(x)**2*cos(y)**2-cos(x)**2*sin(y)**2) &
		*(dpi*dpi*z/h3*cos(dpi*zh1)+(dpi/h2)*sin(dpi*zh1))

	   d2vdyz=-cos(x)*cos(y)*( hpi/h1)*cos(hpi*zh1)+sin(x)*sin(y)*(dpi/h1)*sin(dpi*zh1) &
		+cos(x)*sin(y)*(-pi*pi*z/4./h3*sin(hpi*zh1)+hpi/h2*cos(hpi*zh1))*dhdy &
		+sin(x)*cos(y)*( 4.*pi*pi*z/h3*cos(dpi*zh1)+dpi/h2*sin(dpi*zh1))*dhdy

	   d2udxz= cos(x)*cos(y)*(hpi/h1)*cos(hpi*zh1)-sin(x)*sin(y)*(dpi/h1)*sin(dpi*zh1) &
		+sin(x)*cos(y)*(pi*pi*z/4./h3*sin(hpi*zh1)-hpi/h2*cos(hpi*zh1))*dhdx &
		-cos(x)*sin(y)*(4.*pi*pi*z/h3*cos(dpi*zh1)+dpi/h2*sin(dpi*zh1))*dhdx

	tf_w(i,j,k) = uz*dwdx + vz*dwdy + wz*dwdz &
		     -visc*(d2wdx2+d2wdy2+d2wdz2+d2udxz+d2vdyz+d2wdz2)

enddo
enddo
enddo

END SUBROUTINE termo_fonte1

SUBROUTINE termo_fonte2()

! x, y and z are location of nodes in a 3D domain
! h0 is the reference surface height
! a  is the surface wave amplitude
! sn is the sign of h(x,y): sn=1.0 or -1.0
! L is the number of vertical mesh and LMAX is the maximum

use mms_m
IMPLICIT NONE

integer :: i,j,k

real(8) :: c,s,x,y,hpi,dpi,h1,h2,h3,zh1,h4,h5,dhdx,dhdy,d2hdx2,d2hdy2,d2hdxy,z,visc

real(8) :: dcdx,dcdy,dcdz,dsdx,dsdy,dsdz,d2cdx2,d2cdy2,d2cdz2,d2cdxy,d2cdxz,d2cdyz

real(8) :: dpdx,dpdy,dpdz

real(8) :: ux, vx, wx, dudt
real(8) :: uy, vy, wy, dvdt
real(8) :: uz, vz, wz, dwdt

real(8) :: dudx,dudy,dudz,d2udx2,d2udy2,d2udz2,d2udxy,d2udxz,d2udyz
real(8) :: dvdx,dvdy,dvdz,d2vdx2,d2vdy2,d2vdz2,d2vdxy,d2vdxz,d2vdyz
real(8) :: dwdx,dwdy,dwdz,d2wdx2,d2wdy2,d2wdz2,d2wdxy,d2wdxz,d2wdyz

hpi=0.5*pi
dpi=2.0*pi

visc = 0.00100798/998.

!-------- derivadas para o termo fonte Fu
do k = 1, nz
do j = 1, ny
do i = 1, nx1
	x = (i-1.0)*dx-pi
	y = (j-0.5)*dy-pi
	z = (k-0.5)*dz

	dhdx=   -a*0.5*sin(x*0.5)*cos(y*0.5)*cos(t)
	dhdy=   -a*0.5*cos(x*0.5)*sin(y*0.5)*cos(t)
	d2hdx2= -a*0.25*cos(x*0.5)*cos(y*0.5)*cos(t)
	d2hdy2= -a*0.25*cos(x*0.5)*cos(y*0.5)*cos(t)
	d2hdxy= -a*0.25*sin(x*0.5)*sin(y*0.5)*cos(t)

	h1 = a*cos(x*0.5)*cos(y*0.5)*cos(t) + h0
	h2 = h1*h1
	h3 = h2*h1

	zh1 = z/h1

	c = cos(hpi*(1.0-zh1))
	s = sin(hpi*(1.0-zh1))

	dcdx = -hpi*z/h2*s*dhdx
	dcdy = -hpi*z/h2*s*dhdy
	dcdz =  hpi/h1*s

	dsdx =  hpi*z/h2*c*dhdx
	dsdy =  hpi*z/h2*c*dhdy
	dsdz = -hpi/h1*c

	d2cdx2 = -hpi*z/h2*dsdx*dhdx +pi*z/h3*s*dhdx*dhdx -hpi*z/h2*s*d2hdx2
	d2cdy2 = -hpi*z/h2*dsdy*dhdy +pi*z/h3*s*dhdy*dhdy -hpi*z/h2*s*d2hdy2
	d2cdz2 = -(hpi/h1)**2.*c
	d2cdxy = -hpi*z/h2*dsdy*dhdx +pi*z/h3*s*dhdx*dhdy -hpi*z/h2*s*d2hdxy
	d2cdxz =  hpi*z/h2*hpi/h1*c*dhdx-hpi/h2*s*dhdx
	d2cdyz =  hpi*z/h2*hpi/h1*c*dhdy-hpi/h2*s*dhdy

	ux =  sin(y)*cos(x*0.5)*cos(x*0.5)*cos(hpi*(1.-zh1))*sin(t)
	vx = -sin(x)*cos(y*0.5)*cos(y*0.5)*cos(hpi*(1.-zh1))*sin(t)
	wx = -a*cos(x*0.5)*cos(y*0.5)*cos(hpi*(1.-zh1))*sin(t)

	dudt = sin(y)*cos(0.5*x)*cos(0.5*x)*c*cos(t)

	dudx= -0.5*sin(x)*sin(y)*c*sin(t)+sin(y)*cos(0.5*x)*cos(0.5*x)*dcdx*sin(t)

	dudy= cos(0.5*x)*cos(0.5*x)*cos(y)*c*sin(t)+sin(y)*cos(0.5*x)*cos(0.5*x)*dcdy*sin(t)

	dudz= cos(0.5*x)*cos(0.5*x)*sin(y)*dcdz*sin(t)

	d2udx2= -0.5*cos(x)*sin(y)*c*sin(t)-sin(x)*sin(y)*dcdx*sin(t)+sin(y)*cos(0.5*x)*cos(0.5*x)*d2cdx2*sin(t)

	d2udy2= -cos(0.5*x)*cos(0.5*x)*sin(y)*c*sin(t) +2.0*cos(y)*cos(0.5*x)*cos(0.5*x)*dcdy*sin(t) &
		+sin(y)*cos(0.5*x)*cos(0.5*x)*d2cdy2*sin(t)

       	d2udz2= cos(0.5*x)*cos(0.5*x)*sin(y)*d2cdz2*sin(t)

	d2vdxy= 0.5*sin(y)*cos(x)*c*sin(t)+0.5*sin(x)*sin(y)*dcdx*sin(t) &
	       -cos(0.5*y)*cos(0.5*y)*cos(x)*dcdy*sin(t)-sin(x)*cos(0.5*y)*cos(0.5*y)*d2cdxy*sin(t)

	d2wdxz= 0.5*a*sin(0.5*x)*cos(0.5*y)*dcdz*sin(t)-a*cos(0.5*x)*cos(0.5*y)*d2cdxz*sin(t)

	tf_u(i,j,k) = dudt + ux*dudx + vx*dudy + wx*dudz &
		     -visc*(d2udx2+d2udy2+d2udz2+d2udx2+d2vdxy+d2wdxz)

	dpdx=-sin(x)*cos(y)*cos(hpi*zh1)+cos(x)*cos(y)*sin(hpi*zh1)*hpi*zh1/h1*dhdx
	tf_px(i,j,k) =  dpdx * coef

enddo
enddo
enddo

!-------- derivadas para o termo fonte Fv
do k = 1, nz
do j = 1, ny1
do i = 1, nx
	x = (i-0.5)*dx-pi
	y = (j-1.0)*dy-pi
	z = (k-0.5)*dz

	dhdx=   -a*0.5*sin(x*0.5)*cos(y*0.5)*cos(t)
	dhdy=   -a*0.5*cos(x*0.5)*sin(y*0.5)*cos(t)
	d2hdx2= -a*0.25*cos(x*0.5)*cos(y*0.5)*cos(t)
	d2hdy2= -a*0.25*cos(x*0.5)*cos(y*0.5)*cos(t)
	d2hdxy= -a*0.25*sin(x*0.5)*sin(y*0.5)*cos(t)

	h1 = a*cos(x*0.5)*cos(y*0.5)*cos(t) + h0
	h2 = h1*h1
	h3 = h2*h1

	zh1 = z/h1

	c = cos(hpi*(1.0-zh1))
	s = sin(hpi*(1.0-zh1))

	dcdx = -hpi*z/h2*s*dhdx
	dcdy = -hpi*z/h2*s*dhdy
	dcdz =  hpi/h1*s

	dsdx =  hpi*z/h2*c*dhdx
	dsdy =  hpi*z/h2*c*dhdy
	dsdz = -hpi/h1*c

	d2cdx2 = -hpi*z/h2*dsdx*dhdx +pi*z/h3*s*dhdx*dhdx -hpi*z/h2*s*d2hdx2
	d2cdy2 = -hpi*z/h2*dsdy*dhdy +pi*z/h3*s*dhdy*dhdy -hpi*z/h2*s*d2hdy2
	d2cdz2 = -(hpi/h1)**2.*c
	d2cdxy = -hpi*z/h2*dsdy*dhdx +pi*z/h3*s*dhdx*dhdy -hpi*z/h2*s*d2hdxy
	d2cdxz =  hpi*z/h2*hpi/h1*c*dhdx-hpi/h2*s*dhdx
	d2cdyz =  hpi*z/h2*hpi/h1*c*dhdy-hpi/h2*s*dhdy

	uy =  sin(y)*cos(x*0.5)*cos(x*0.5)*cos(hpi*(1.-zh1))*sin(t)
	vy = -sin(x)*cos(y*0.5)*cos(y*0.5)*cos(hpi*(1.-zh1))*sin(t)
	wy = -a*cos(x*0.5)*cos(y*0.5)*cos(hpi*(1.-zh1))*sin(t)

          dvdt=-sin(x)*cos(0.5*y)*cos(0.5*y)*c*cos(t)

	   dvdx= -cos(x)*cos(0.5*y)*cos(0.5*y)*c*sin(t)-sin(x)*cos(0.5*y)*cos(0.5*y)*dcdx*sin(t)

	   dvdy= 0.5*sin(x)*sin(y)*c*sin(t)-sin(x)*cos(0.5*y)*cos(0.5*y)*dcdy*sin(t)

	   dvdz= -cos(0.5*y)*cos(0.5*y)*sin(x)*dcdz*sin(t)

	   d2vdx2= sin(x)*cos(0.5*y)*cos(0.5*y)*c*sin(t) -2.0*cos(x)*cos(0.5*y)*cos(0.5*y)*dcdx*sin(t) &
		  -sin(x)*cos(0.5*y)*cos(0.5*y)*d2cdx2*sin(t)

	   d2vdy2= 0.5*sin(x)*cos(y)*c*sin(t)+sin(x)*sin(y)*dcdy*sin(t)-sin(x)*cos(0.5*y)*cos(0.5*y)*d2cdy2*sin(t)

	   d2vdz2= -sin(x)*cos(0.5*y)*cos(0.5*y)*d2cdz2*sin(t)

	   d2udxy= -0.5*sin(x)*cos(y)*c*sin(t)-0.5*sin(x)*sin(y)*dcdy*sin(t) &
		   +cos(0.5*x)*cos(0.5*x)*cos(y)*dcdx*sin(t)+sin(y)*cos(0.5*x)*cos(0.5*x)*d2cdxy*sin(t)

	   d2wdyz= 0.5*a*cos(0.5*x)*sin(0.5*y)*dcdz*sin(t)-a*cos(0.5*x)*cos(0.5*y)*d2cdyz*sin(t)

	tf_v(i,j,k) = dvdt + uy*dvdx + vy*dvdy + wy*dvdz &
		     -visc*(d2vdx2+d2vdy2+d2vdz2+d2udxy+d2vdy2+d2wdyz)

	dpdy=-cos(x)*sin(y)*cos(hpi*zh1)+cos(x)*cos(y)*sin(hpi*zh1)*hpi*zh1/h1*dhdy
	tf_py(i,j,k) =  dpdy * coef
enddo
enddo
enddo

!-------- derivatives of w
do k = 1, nz1
do j = 1, ny
do i = 1, nx
	x = (i-0.5)*dx-pi
	y = (j-0.5)*dy-pi
	z = (k-1.0)*dz

	dhdx=   -a*0.5*sin(x*0.5)*cos(y*0.5)*cos(t)
	dhdy=   -a*0.5*cos(x*0.5)*sin(y*0.5)*cos(t)
	d2hdx2= -a*0.25*cos(x*0.5)*cos(y*0.5)*cos(t)
	d2hdy2= -a*0.25*cos(x*0.5)*cos(y*0.5)*cos(t)
	d2hdxy= -a*0.25*sin(x*0.5)*sin(y*0.5)*cos(t)

	h1 = a*cos(x*0.5)*cos(y*0.5)*cos(t) + h0
	h2 = h1*h1
	h3 = h2*h1

	zh1 = z/h1

	c = cos(hpi*(1.0-zh1))
	s = sin(hpi*(1.0-zh1))

	dcdx = -hpi*z/h2*s*dhdx
	dcdy = -hpi*z/h2*s*dhdy
	dcdz =  hpi/h1*s

	dsdx =  hpi*z/h2*c*dhdx
	dsdy =  hpi*z/h2*c*dhdy
	dsdz = -hpi/h1*c

	d2cdx2 = -hpi*z/h2*dsdx*dhdx +pi*z/h3*s*dhdx*dhdx -hpi*z/h2*s*d2hdx2
	d2cdy2 = -hpi*z/h2*dsdy*dhdy +pi*z/h3*s*dhdy*dhdy -hpi*z/h2*s*d2hdy2
	d2cdz2 = -(hpi/h1)**2.*c
	d2cdxy = -hpi*z/h2*dsdy*dhdx +pi*z/h3*s*dhdx*dhdy -hpi*z/h2*s*d2hdxy
	d2cdxz =  hpi*z/h2*hpi/h1*c*dhdx-hpi/h2*s*dhdx
	d2cdyz =  hpi*z/h2*hpi/h1*c*dhdy-hpi/h2*s*dhdy

	uz =  sin(y)*cos(x*0.5)*cos(x*0.5)*cos(hpi*(1.-zh1))*sin(t)
	vz = -sin(x)*cos(y*0.5)*cos(y*0.5)*cos(hpi*(1.-zh1))*sin(t)
	wz = -a*cos(x*0.5)*cos(y*0.5)*cos(hpi*(1.-zh1))*sin(t)

          dwdt=  -a*cos(0.5*x)*cos(0.5*y)*c*cos(t)

	   dwdx= 0.5*a*sin(0.5*x)*cos(0.5*y)*c*sin(t)-a*cos(0.5*x)*cos(0.5*y)*dcdx*sin(t)

	   dwdy= 0.5*a*cos(0.5*x)*sin(0.5*y)*c*sin(t)-a*cos(0.5*x)*cos(0.5*y)*dcdy*sin(t)

	   dwdz= -a*cos(0.5*x)*cos(0.5*y)*dcdz*sin(t)

	   d2wdx2= 0.25*a*cos(0.5*x)*cos(0.5*y)*c*sin(t)+a*sin(0.5*x)*cos(0.5*y)*dcdx*sin(t) &
		  -a*cos(0.5*x)*cos(0.5*y)*d2cdx2*sin(t)

	   d2wdy2= 0.25*a*cos(0.5*x)*cos(0.5*y)*c*sin(t)+a*cos(0.5*x)*sin(0.5*y)*dcdy*sin(t) &
		  -a*cos(0.5*x)*cos(0.5*y)*d2cdy2*sin(t)

	   d2wdz2= -a*cos(0.5*x)*cos(0.5*y)*d2cdz2*sin(t)

	   d2vdyz= 0.5*sin(x)*sin(y)*dcdz*sin(t)-sin(x)*cos(0.5*y)*cos(0.5*y)*d2cdyz*sin(t)

	   d2udxz=-0.5*sin(x)*sin(y)*dcdz*sin(t)+sin(y)*cos(0.5*x)*cos(0.5*x)*d2cdxz*sin(t)

	tf_w(i,j,k) = dwdt + uz*dwdx + vz*dwdy + wz*dwdz &
		     -visc*(d2wdx2+d2wdy2+d2wdz2+d2udxz+d2vdyz+d2wdz2)

	dpdz=-cos(x)*cos(y)*sin(hpi*zh1)*hpi/h1
	tf_pz(i,j,k) =  dpdz * coef

enddo
enddo
enddo

END SUBROUTINE termo_fonte2

SUBROUTINE termo_fontep2()

use mms_m
IMPLICIT NONE

integer :: i,j,k

real(8) :: x,y,hpi,dpi,h1,h2,h3,zh1,h4,h5,dhdx,dhdy,d2hdx2,d2hdy2,d2hdxy,z

real(8) :: d2pdx2,d2pdy2,d2pdz2

hpi=0.5*pi
dpi=2.0*pi

!-------- derivatives of pressure
do k = 1, nz
do j = 1, ny
do i = 1, nx
	x = (i-0.5)*dx-pi
	y = (j-0.5)*dy-pi
	z = (k-0.5)*dz

	dhdx=   -a*0.5*sin(x*0.5)*cos(y*0.5)*cos(t)
	dhdy=   -a*0.5*cos(x*0.5)*sin(y*0.5)*cos(t)
	d2hdx2= -a*0.25*cos(x*0.5)*cos(y*0.5)*cos(t)
	d2hdy2= -a*0.25*cos(x*0.5)*cos(y*0.5)*cos(t)
	d2hdxy= -a*0.25*sin(x*0.5)*sin(y*0.5)*cos(t)

	h1 = a*cos(x*0.5)*cos(y*0.5)*cos(t) + h0
	h2 = h1*h1

	zh1 = z/h1

	d2pdx2= -cos(x)*cos(y)*cos(hpi*zh1)-2.0*sin(x)*cos(y)*sin(hpi*zh1)*hpi*zh1/h1*dhdx &
		+cos(x)*cos(y)*(-cos(hpi*zh1)*(hpi*zh1/h1)**2*dhdx**2-sin(hpi*zh1)*pi*zh1/h2*dhdx**2+sin(hpi*zh1)*hpi*zh1/h1*d2hdx2)

	d2pdy2= -cos(x)*cos(y)*cos(hpi*zh1)-2.0*cos(x)*sin(y)*sin(hpi*zh1)*hpi*zh1/h1*dhdy &
		+cos(x)*cos(y)*(-cos(hpi*zh1)*(hpi*zh1/h1)**2*dhdy**2-sin(hpi*zh1)*pi*zh1/h2*dhdy**2+sin(hpi*zh1)*hpi*zh1/h1*d2hdy2)

	d2pdz2= -cos(x)*cos(y)*cos(hpi*zh1)*(hpi/h1)**2

	tf_p(i,j,k) = (d2pdx2 + d2pdy2 + d2pdz2) * coef

enddo
enddo
enddo

END SUBROUTINE termo_fontep2

	! zerando os termos no ar !
!	call interpx_cf(ls,nx,ny,nz,lsx) !(nx1,ny,nz)
!	call interpy_cf(ls,nx,ny,nz,lsy) !(nx,ny1,nz)
!	call interpz_cf(ls,nx,ny,nz,lsz) !(nx,ny,nz1)

!	   do k = 1, nz
!	   do j = 1, ny
!	   do i = 1, nx1
!		if ( lsx(i,j,k) < 0.) then
		! u(i,j,k) = 0.
!		endif
!	   enddo
!	   enddo
!	   enddo

!	   do k = 1, nz
!	   do j = 1, ny
!		if ( lsx(1,j,k) < 0.) then
!		 bxx0(j,k)  = 0.
!		 bxx1(j,k)  = 0.
!		 bxy0(j,k)  = 0.
!		 bxz0(j,k)  = 0.
!		endif

!		if ( lsx(nx1,j,k) < 0.) then
!		 bxxf(j,k)  = 0.
!		 bxxf1(j,k) = 0.
!		 bxyf(j,k)  = 0.
!		 bxzf(j,k)  = 0.
!		endif
!	   enddo
!	   enddo

!	   do k = 1, nz
!	   do j = 1, ny1
!	   do i = 1, nx
!		if ( lsy(i,j,k) < 0.) then
		! v(i,j,k) = 0.
!		endif
!	   enddo
!	   enddo
!	   enddo

!	   do k = 1, nz
!	   do i = 1, nx
!		if ( lsy(i,1,k) < 0.) then
!		 byy0(i,k)  = 0.
!		 byy1(i,k)  = 0.
!		 byx0(i,k)  = 0.
!		 byz0(i,k)  = 0.
!		endif

!		if ( lsy(i,ny1,k) < 0.) then
!		 byyf(i,k)  = 0.
!		 byyf1(i,k) = 0.
!		 byxf(i,k)  = 0.
!		 byzf(i,k)  = 0.
!		endif
!	   enddo
!	   enddo

!	   do k = 1, nz1
!	   do j = 1, ny
!	   do i = 1, nx
!		if ( lsz(i,j,k) < 0. ) then
		! w(i,j,k) = 0.
!		endif
!	   enddo
!	   enddo
!	   enddo

!	   do j = 1, ny
!	   do i = 1, nx
!		if ( lsz(i,j,1) < 0.) then
!		 bzz0(i,j)  = 0.
!		 bzz1(i,j)  = 0.
!		 bzx0(i,j)  = 0.
!		 bzy0(i,j)  = 0.
!		endif

!		if ( lsz(i,j,nz1) < 0.) then
!		 bzzf(i,j)  = 0.
!		 bzzf1(i,j) = 0.
!		 bzxf(i,j)  = 0.
!		 bzyf(i,j)  = 0.
!		endif
!	   enddo
!	   enddo


!==============================================================================!
  subroutine Vof_Max_Courant_Number(mult, dt, c_d, interf, courant_max)
!------------------------------------------------------------------------------!
!   Computes the Maximum Courant Number at cells. The argument interf helps    !
!   selecting if calculation will be performed close the interface, which      !
!   in turn will modify the time step if necessary and perform a simple        !
!   stepping approach. If interf = 0, then calculation is made everywhere      !
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Multiphase_Type), target :: mult
  real                          :: dt     ! time step
  real                          :: c_d(-mult % pnt_grid % n_bnd_cells:  &
                                        mult % pnt_grid % n_cells) ! Courant n.
  integer                       :: interf
  real                          :: courant_max
!--------------------------------[Locals]--------------------------------------!
  type(Field_Type),     pointer :: flow
  type(Grid_Type),      pointer :: grid
  type(Var_Type),       pointer :: vof
  type(Face_Type),      pointer :: m_flux
  integer                       :: c, c1, c2, s
  real                          :: vof_dist
!==============================================================================!

  ! Take aliases
  flow     => mult % pnt_flow
  m_flux   => flow % m_flux
  grid     => flow % pnt_grid
  vof      => mult % vof

  courant_max = 0.0

  ! Initialize
  c_d(-mult % pnt_grid % n_bnd_cells:mult % pnt_grid % n_cells) = 0.0

  if (interf == 1) then

    do s = 1, grid % n_faces
      c1 = grid % faces_c(1,s)
      c2 = grid % faces_c(2,s)

      if (c2 > 0) then

        vof_dist = min(max(vof % n(c1), 0.0),1.0)

        vof_dist = (1.0 - vof_dist) * (1.0 - vof_dist)            &
                                    * vof_dist * vof_dist * 16.0

        c_d(c1) = c_d(c1) + vof_dist * max(- m_flux % n(s)              &
                                           / flow % density_f(s)        &
                                           * dt / grid % vol(c1), 0.0)

        vof_dist = min(max(vof % n(c2), 0.0),1.0)

        vof_dist = (1.0 - vof_dist) * (1.0 - vof_dist)            &
                                    * vof_dist * vof_dist * 16.0

        c_d(c2) = c_d(c2) + vof_dist * max( m_flux % n(s)              &
                                          / flow % density_f(s)        &
                                          * dt / grid % vol(c2), 0.0)

      ! Side is on the boundary
      else ! (c2 < 0)
        vof_dist = min(max(vof % n(c1), 0.0),1.0)

        vof_dist = (1.0 - vof_dist) * (1.0 - vof_dist)            &
                                    * vof_dist * vof_dist * 16.0

        c_d(c1) = c_d(c1) + vof_dist * max(- m_flux % n(s)              &
                                           / flow % density_f(s)        &
                                           * dt / grid % vol(c1), 0.0)
      end if

    end do

    do c = 1, grid % n_cells
      courant_max = max(c_d(c), courant_max)
    end do

  else

    do s = 1, grid % n_faces
      c1 = grid % faces_c(1,s)
      c2 = grid % faces_c(2,s)

      if (c2 > 0) then

        c_d(c1) = c_d(c1) + max(- m_flux % n(s) / flow % density_f(s)  &
                                          * dt / grid % vol(c1), 0.0)

        c_d(c2) = c_d(c2) + max( m_flux % n(s) / flow % density_f(s)   &
                                          * dt / grid % vol(c2), 0.0)

      ! Side is on the boundary
      else ! (c2 < 0)

        c_d(c1) = c_d(c1) + max(- m_flux % n(s) / flow % density_f(s)  &
                                          * dt / grid % vol(c1), 0.0)

      end if

    end do

  end if

  call Comm_Mod_Global_Max_Real(courant_max)
  call Grid_Mod_Exchange_Real(grid, c_d)

  end subroutine


!        Generated by TAPENADE     (INRIA, Ecuador team)
!  Tapenade 3.12 (r6213) - 13 Oct 2016 10:54
!
!  Differentiation of porteagel_analyze in reverse (adjoint) mode:
!   gradient     of useful results: wtvelocity
!   with respect to varying inputs: i rotordiameter turbinez alpha
!                turbinexw wtvelocity ky kz wind_speed turbineyw
!                beta yawdeg ct
!   RW status of diff variables: i:out rotordiameter:out turbinez:out
!                alpha:out turbinexw:out wtvelocity:in-zero ky:out
!                kz:out wind_speed:out turbineyw:out beta:out yawdeg:out
!                ct:out
! implementation of the Bastankhah and Porte Agel (BPA) wake model for analysis
SUBROUTINE PORTEAGEL_ANALYZE_BV(nturbines, turbinexw, turbinexwb, &
& turbineyw, turbineywb, turbinez, turbinezb, rotordiameter, &
& rotordiameterb, ct, ctb, wind_speed, yawdeg, yawdegb, ky&
& , kz, alpha, beta, i, &
& wtvelocityb, nbdirs)
  !USE DIFFSIZES
!  Hint: nbdirs should be the maximum number of differentiation directions
  IMPLICIT NONE
!print *, "fortran"
! define precision to be the standard for a double precision ! on local system
  INTEGER, PARAMETER :: dp=KIND(0.d0)
! in
  INTEGER, INTENT(IN) :: nturbines
  REAL(dp), DIMENSION(nturbines), INTENT(IN) :: turbinexw, turbineyw, &
& turbinez
  REAL(dp), DIMENSION(nbdirs, nturbines), intent(out) :: turbinexwb, turbineywb, &
& turbinezb
  REAL(dp), DIMENSION(nturbines), INTENT(IN) :: rotordiameter, yawdeg
  REAL(dp), DIMENSION(nbdirs, nturbines), intent(out) :: rotordiameterb, yawdegb
  REAL(dp), DIMENSION(nturbines), INTENT(IN) :: ct
  REAL(dp), DIMENSION(nbdirs, nturbines), intent(out) :: ctb
  REAL(dp), INTENT(IN) :: ky, kz, alpha, beta, i, wind_speed
  REAL(dp), DIMENSION(nbdirs) :: kyb, kzb, alphab, betab, ib, &
& wind_speedb
! local (General)
  REAL(dp), DIMENSION(nturbines) :: yaw
  REAL(dp), DIMENSION(nbdirs, nturbines) :: yawb
  REAL(dp) :: x0, deltax0, deltay, theta_c_0, sigmay, sigmaz, &
& wake_offset
  REAL(dp), DIMENSION(nbdirs) :: x0b, deltax0b, deltayb, theta_c_0b, &
& sigmayb, sigmazb, wake_offsetb
  REAL(dp) :: x, deltav, deltav0m, deltaz, sigmay0, sigmaz0
  REAL(dp), DIMENSION(nbdirs) :: xb, deltavb, deltazb, sigmay0b, &
& sigmaz0b
  INTEGER :: turb, turbi
  REAL(dp), PARAMETER :: pi=3.141592653589793_dp
! model out
  REAL(dp), DIMENSION(nturbines) :: wtvelocity
  REAL(dp), DIMENSION(nbdirs, nturbines) :: wtvelocityb
  INTRINSIC COS, ATAN, MAX, SQRT, LOG
  INTRINSIC KIND
  INTEGER :: nd
  REAL(dp), DIMENSION(nbdirs) :: dummydiffb
  REAL(dp), DIMENSION(nbdirs) :: dummydiffb0
  INTEGER :: branch
  INTEGER :: nbdirs
! bastankhah and porte agel 2016 define yaw to be positive clockwise, this is reversed
  yaw = -(yawdeg*pi/180.0_dp)
! initialize wind turbine velocity array to the free-stream wind speed
  DO turb=1,nturbines
! determine the onset location of far wake
    CALL PUSHREAL4ARRAY(x0, dp/4)
    CALL X0_FUNC(rotordiameter(turb), yaw(turb), ct(turb), alpha, i, &
&          beta, x0)
! determine the initial wake angle at the onset of far wake
    CALL PUSHREAL4ARRAY(theta_c_0, dp/4)
    CALL THETA_C_0_FUNC(yaw(turb), ct(turb), theta_c_0)
! at turbineX-locations
    DO turbi=1,nturbines
! downstream distance between turbines
      x = turbinexw(turbi) - turbinexw(turb)
! downstream distance from far wake onset to downstream turbine
      CALL PUSHREAL4ARRAY(deltax0, dp/4)
      deltax0 = x - x0
! far wake region
      IF (deltax0 .GT. 0.0_dp) THEN
! horizontal spread
        CALL PUSHREAL4ARRAY(sigmay, dp/4)
        CALL SIGMAY_FUNC(ky, deltax0, rotordiameter(turb), yaw(turb), &
&                  sigmay)
! vertical spread
        CALL PUSHREAL4ARRAY(sigmaz, dp/4)
        CALL SIGMAZ_FUNC(kz, deltax0, rotordiameter(turb), sigmaz)
! horizontal cross-wind wake displacement from hub
        CALL WAKE_OFFSET_FUNC(rotordiameter(turb), theta_c_0, x0, yaw(&
&                       turb), ky, kz, ct(turb), sigmay, sigmaz, &
&                       wake_offset)
! cross wind distance from downstream hub location to wake center
        CALL PUSHREAL4ARRAY(deltay, dp/4)
        deltay = turbineyw(turbi) - (turbineyw(turb)+wake_offset)
! cross wind distance from hub height to height of point of interest
! velocity difference in the wake
! linear wake superposition (additive)
! near wake region (linearized)
        CALL PUSHCONTROL2B(2)
      ELSE IF (deltax0 .GT. -x0) THEN
! horizontal spread
        CALL PUSHREAL4ARRAY(sigmay, dp/4)
        CALL SIGMAY_FUNC(ky, deltax0, rotordiameter(turb), yaw(turb), &
&                  sigmay)
! vertical spread
        CALL PUSHREAL4ARRAY(sigmaz, dp/4)
        CALL SIGMAZ_FUNC(kz, deltax0, rotordiameter(turb), sigmaz)
! horizontal cross-wind wake displacement from hub
        CALL WAKE_OFFSET_FUNC(rotordiameter(turb), theta_c_0, x0, yaw(&
&                       turb), ky, kz, ct(turb), sigmay, sigmaz, &
&                       wake_offset)
! distance from downstream hub location to wake center
        CALL PUSHREAL4ARRAY(deltay, dp/4)
        deltay = turbineyw(turbi) - (turbineyw(turb)+wake_offset)
! vertical distance from downstream hub location to wake center
! horizontal spread at far wake onset
        CALL PUSHREAL4ARRAY(sigmay0, dp/4)
        CALL SIGMAY_FUNC(ky, 0.0_dp, rotordiameter(turb), yaw(turb), &
&                  sigmay0)
! vertical spread at far wake onset
        CALL PUSHREAL4ARRAY(sigmaz0, dp/4)
        CALL SIGMAZ_FUNC(kz, 0.0_dp, rotordiameter(turb), sigmaz0)
! linear wake superposition (additive)
        CALL PUSHCONTROL2B(1)
      ELSE
        CALL PUSHCONTROL2B(0)
      END IF
    END DO
  END DO
  DO nd=1,nbdirs
    ib(nd) = 0.0
    rotordiameterb(nd, :) = 0.0
    turbinezb(nd, :) = 0.0
    alphab(nd) = 0.0
    turbinexwb(nd, :) = 0.0
    kyb(nd) = 0.0
    kzb(nd) = 0.0
    wind_speedb(nd) = 0.0
    turbineywb(nd, :) = 0.0
    betab(nd) = 0.0
    ctb(nd, :) = 0.0
    yawb(nd, :) = 0.0
  END DO
  DO turb=nturbines,1,-1
    DO nd=1,nbdirs
      theta_c_0b(nd) = 0.0
      x0b(nd) = 0.0
    END DO
    DO turbi=nturbines,1,-1
      CALL POPCONTROL2B(branch)
      IF (branch .EQ. 0) THEN
        DO nd=1,nbdirs
          xb(nd) = 0.0
          deltax0b(nd) = 0.0
        END DO
      ELSE IF (branch .EQ. 1) THEN
        DO nd=1,nbdirs
          deltavb(nd) = -wtvelocityb(nd, turbi)
        END DO
        x = turbinexw(turbi) - turbinexw(turb)
        deltaz = turbinez(turbi) - turbinez(turb)
        CALL DELTAV_NEAR_WAKE_LIN_FUNC_BV(deltay, deltayb, deltaz, &
&                                   deltazb, wake_offset, wind_speed, &
&                                   wind_speedb, ct(turb), ctb(1, turb)&
&                                   , yaw(turb), yawb(1, turb), sigmay, &
&                                   sigmayb, sigmaz, sigmazb, &
&                                   rotordiameter(turb), rotordiameterb(&
&                                   1, turb), x, xb, x0, x0b, sigmay0, &
&                                   sigmay0b, sigmaz0, sigmaz0b, deltav&
&                                   , deltavb, nbdirs)
        CALL POPREAL4ARRAY(sigmaz0, dp/4)
        CALL SIGMAZ_FUNC_BV(kz, kzb, 0.0_dp, dummydiffb0, rotordiameter(&
&                     turb), rotordiameterb(1, turb), sigmaz0, sigmaz0b&
&                     , nbdirs)
        CALL POPREAL4ARRAY(sigmay0, dp/4)
        CALL SIGMAY_FUNC_BV(ky, kyb, 0.0_dp, dummydiffb, rotordiameter(&
&                     turb), rotordiameterb(1, turb), yaw(turb), yawb(1&
&                     , turb), sigmay0, sigmay0b, nbdirs)
        CALL POPREAL4ARRAY(deltay, dp/4)
        deltax0 = x - x0
        DO nd=1,nbdirs
          turbinezb(nd, turbi) = turbinezb(nd, turbi) + deltazb(nd)
          turbinezb(nd, turb) = turbinezb(nd, turb) - deltazb(nd)
          turbineywb(nd, turbi) = turbineywb(nd, turbi) + deltayb(nd)
          turbineywb(nd, turb) = turbineywb(nd, turb) - deltayb(nd)
          wake_offsetb(nd) = -deltayb(nd)
        END DO
        CALL WAKE_OFFSET_FUNC_BV(rotordiameter(turb), rotordiameterb(1, &
&                          turb), theta_c_0, theta_c_0b, x0, x0b, yaw(&
&                          turb), yawb(1, turb), ky, kyb, kz, kzb, ct(&
&                          turb), ctb(1, turb), sigmay, sigmayb, sigmaz&
&                          , sigmazb, wake_offset, wake_offsetb, nbdirs)
        CALL POPREAL4ARRAY(sigmaz, dp/4)
        CALL SIGMAZ_FUNC_BV(kz, kzb, deltax0, deltax0b, rotordiameter(&
&                     turb), rotordiameterb(1, turb), sigmaz, sigmazb, &
&                     nbdirs)
        CALL POPREAL4ARRAY(sigmay, dp/4)
        CALL SIGMAY_FUNC_BV(ky, kyb, deltax0, deltax0b, rotordiameter(&
&                     turb), rotordiameterb(1, turb), yaw(turb), yawb(1&
&                     , turb), sigmay, sigmayb, nbdirs)
      ELSE
        DO nd=1,nbdirs
          deltavb(nd) = -wtvelocityb(nd, turbi)
        END DO
        deltaz = turbinez(turbi) - turbinez(turb)
        CALL DELTAV_FUNC_BV(deltay, deltayb, deltaz, deltazb, &
&                     wake_offset, wind_speed, wind_speedb, ct(turb), &
&                     ctb(1, turb), yaw(turb), yawb(1, turb), sigmay, &
&                     sigmayb, sigmaz, sigmazb, rotordiameter(turb), &
&                     rotordiameterb(1, turb), deltav, deltavb, nbdirs)
        CALL POPREAL4ARRAY(deltay, dp/4)
        x = turbinexw(turbi) - turbinexw(turb)
        deltax0 = x - x0
        DO nd=1,nbdirs
          turbinezb(nd, turbi) = turbinezb(nd, turbi) + deltazb(nd)
          turbinezb(nd, turb) = turbinezb(nd, turb) - deltazb(nd)
          turbineywb(nd, turbi) = turbineywb(nd, turbi) + deltayb(nd)
          turbineywb(nd, turb) = turbineywb(nd, turb) - deltayb(nd)
          wake_offsetb(nd) = -deltayb(nd)
        END DO
        CALL WAKE_OFFSET_FUNC_BV(rotordiameter(turb), rotordiameterb(1, &
&                          turb), theta_c_0, theta_c_0b, x0, x0b, yaw(&
&                          turb), yawb(1, turb), ky, kyb, kz, kzb, ct(&
&                          turb), ctb(1, turb), sigmay, sigmayb, sigmaz&
&                          , sigmazb, wake_offset, wake_offsetb, nbdirs)
        CALL POPREAL4ARRAY(sigmaz, dp/4)
        CALL SIGMAZ_FUNC_BV(kz, kzb, deltax0, deltax0b, rotordiameter(&
&                     turb), rotordiameterb(1, turb), sigmaz, sigmazb, &
&                     nbdirs)
        CALL POPREAL4ARRAY(sigmay, dp/4)
        CALL SIGMAY_FUNC_BV(ky, kyb, deltax0, deltax0b, rotordiameter(&
&                     turb), rotordiameterb(1, turb), yaw(turb), yawb(1&
&                     , turb), sigmay, sigmayb, nbdirs)
        DO nd=1,nbdirs
          xb(nd) = 0.0
        END DO
      END IF
      CALL POPREAL4ARRAY(deltax0, dp/4)
      DO nd=1,nbdirs
        xb(nd) = xb(nd) + deltax0b(nd)
        x0b(nd) = x0b(nd) - deltax0b(nd)
        turbinexwb(nd, turbi) = turbinexwb(nd, turbi) + xb(nd)
        turbinexwb(nd, turb) = turbinexwb(nd, turb) - xb(nd)
      END DO
    END DO
    CALL POPREAL4ARRAY(theta_c_0, dp/4)
    CALL THETA_C_0_FUNC_BV(yaw(turb), yawb(1, turb), ct(turb), ctb(1, &
&                    turb), theta_c_0, theta_c_0b, nbdirs)
    CALL POPREAL4ARRAY(x0, dp/4)
    CALL X0_FUNC_BV(rotordiameter(turb), rotordiameterb(1, turb), yaw(&
&             turb), yawb(1, turb), ct(turb), ctb(1, turb), alpha, &
&             alphab, i, ib, beta, betab, x0, x0b, nbdirs)
  END DO
  DO nd=1,nbdirs
    wind_speedb(nd) = wind_speedb(nd) + SUM(wtvelocityb(nd, :))
    yawdegb(nd, :) = 0.0
    yawdegb(nd, :) = -(pi*yawb(nd, :)/180.0_dp)
  END DO
  DO nd=1,nbdirs
    wtvelocityb(nd, :) = 0.0
  END DO
END SUBROUTINE PORTEAGEL_ANALYZE_BV

!  Differentiation of x0_func in reverse (adjoint) mode:
!   gradient     of useful results: i yaw alpha rotor_diameter
!                x0 beta ct
!   with respect to varying inputs: i yaw alpha rotor_diameter
!                beta ct
! calculates the onset of far-wake conditions
SUBROUTINE X0_FUNC_BV(rotor_diameter, rotor_diameterb, yaw, yawb, ct, &
& ctb, alpha, alphab, i, ib, beta, betab, x0, x0b, nbdirs)
  !USE DIFFSIZES
!  Hint: nbdirs should be the maximum number of differentiation directions
  IMPLICIT NONE
! define precision to be the standard for a double precision ! on local system
  INTEGER, PARAMETER :: dp=KIND(0.d0)
! in
  REAL(dp), INTENT(IN) :: rotor_diameter, yaw, ct, alpha, i, beta
  REAL(dp), DIMENSION(nbdirs) :: rotor_diameterb, yawb, ctb, alphab, &
& ib, betab
! out
  REAL(dp) :: x0
  REAL(dp), DIMENSION(nbdirs) :: x0b
  INTRINSIC COS, SQRT, LOG
  INTRINSIC KIND
! determine the onset location of far wake
  REAL(dp) :: temp
  REAL(dp) :: temp0
  REAL(dp) :: temp1
  REAL(dp) :: temp2
  REAL(dp) :: temp3
  INTEGER :: nd
  REAL(dp), DIMENSION(nbdirs) :: tempb
  REAL(dp), DIMENSION(nbdirs) :: tempb0
  INTEGER :: nbdirs
  temp3 = SQRT(-ct + 1.0_dp)
  temp2 = SQRT(2.0_dp)
  temp1 = temp2*(alpha*i+beta*(-temp3+1.0_dp))
  temp0 = SQRT(-ct + 1.0_dp)
  temp = COS(yaw)
  DO nd=1,nbdirs
    tempb(nd) = x0b(nd)/temp1
    tempb0(nd) = -(rotor_diameter*temp*(temp0+1.0_dp)*temp2*tempb(nd)/&
&     temp1)
    rotor_diameterb(nd) = rotor_diameterb(nd) + (temp0+1.0_dp)*temp*&
&     tempb(nd)
    yawb(nd) = yawb(nd) - rotor_diameter*(temp0+1.0_dp)*SIN(yaw)*tempb(&
&     nd)
    IF (.NOT.1.0_dp - ct .EQ. 0.0) ctb(nd) = ctb(nd) + beta*tempb0(nd)/(&
&       2.0*temp3) - rotor_diameter*temp*tempb(nd)/(2.0*temp0)
    alphab(nd) = alphab(nd) + i*tempb0(nd)
    ib(nd) = ib(nd) + alpha*tempb0(nd)
    betab(nd) = betab(nd) + (1.0_dp-temp3)*tempb0(nd)
  END DO
END SUBROUTINE X0_FUNC_BV

!  Differentiation of theta_c_0_func in reverse (adjoint) mode:
!   gradient     of useful results: theta_c_0 yaw ct
!   with respect to varying inputs: yaw ct
! calculates the wake angle at the onset of far wake conditions
SUBROUTINE THETA_C_0_FUNC_BV(yaw, yawb, ct, ctb, theta_c_0, theta_c_0b, &
& nbdirs)
  !USE DIFFSIZES
!  Hint: nbdirs should be the maximum number of differentiation directions
  IMPLICIT NONE
! define precision to be the standard for a double precision ! on local system
  INTEGER, PARAMETER :: dp=KIND(0.d0)
! in
  REAL(dp), INTENT(IN) :: yaw, ct
  REAL(dp), DIMENSION(nbdirs) :: yawb, ctb
! out
  REAL(dp) :: theta_c_0
  REAL(dp), DIMENSION(nbdirs) :: theta_c_0b
  INTRINSIC COS, SQRT
  INTRINSIC KIND
! determine the initial wake angle at the onset of far wake
  REAL(dp) :: temp
  REAL(dp) :: temp0
  REAL(dp) :: temp1
  INTEGER :: nd
  REAL(dp), DIMENSION(nbdirs) :: tempb
  REAL(dp), DIMENSION(nbdirs) :: tempb0
  INTEGER :: nbdirs
  temp1 = COS(yaw)
  temp0 = COS(yaw)
  temp = SQRT(-(ct*temp0) + 1.0_dp)
  DO nd=1,nbdirs
    IF (1.0_dp - ct*temp0 .EQ. 0.0) THEN
      tempb(nd) = 0.0
    ELSE
      tempb(nd) = -(yaw*0.3_dp*theta_c_0b(nd)/(temp1*2.0*temp))
    END IF
    tempb0(nd) = (1.0_dp-temp)*0.3_dp*theta_c_0b(nd)/temp1
    ctb(nd) = ctb(nd) - temp0*tempb(nd)
    yawb(nd) = yawb(nd) + (yaw*SIN(yaw)/temp1+1.0)*tempb0(nd) + ct*SIN(&
&     yaw)*tempb(nd)
  END DO
END SUBROUTINE THETA_C_0_FUNC_BV

!  Differentiation of sigmay_func in reverse (adjoint) mode:
!   gradient     of useful results: yaw sigmay ky rotor_diameter
!                deltax0
!   with respect to varying inputs: yaw ky rotor_diameter deltax0
! calculates the horizontal spread of the wake at a given distance from the onset of far
! wake condition
SUBROUTINE SIGMAY_FUNC_BV(ky, kyb, deltax0, deltax0b, rotor_diameter, &
& rotor_diameterb, yaw, yawb, sigmay, sigmayb, nbdirs)
  !USE DIFFSIZES
!  Hint: nbdirs should be the maximum number of differentiation directions
  IMPLICIT NONE
! define precision to be the standard for a double precision on local system
  INTEGER, PARAMETER :: dp=KIND(0.d0)
! in
  REAL(dp), INTENT(IN) :: ky, deltax0, rotor_diameter, yaw
  REAL(dp), DIMENSION(nbdirs) :: kyb, deltax0b, rotor_diameterb, yawb
! out
  REAL(dp) :: sigmay
  REAL(dp), DIMENSION(nbdirs) :: sigmayb
  INTRINSIC COS, SQRT
  INTRINSIC KIND
! horizontal spread
  REAL(dp) :: temp
  REAL(dp) :: temp0
  INTEGER :: nd
  REAL(dp), DIMENSION(nbdirs) :: tempb
  INTEGER :: nbdirs
  temp0 = SQRT(8.0_dp)
  temp = ky*deltax0/rotor_diameter
  DO nd=1,nbdirs
    tempb(nd) = sigmayb(nd)
    rotor_diameterb(nd) = rotor_diameterb(nd) + (temp+COS(yaw)/temp0)*&
&     sigmayb(nd) - temp*tempb(nd)
    kyb(nd) = kyb(nd) + deltax0*tempb(nd)
    deltax0b(nd) = deltax0b(nd) + ky*tempb(nd)
    yawb(nd) = yawb(nd) - rotor_diameter*SIN(yaw)*sigmayb(nd)/temp0
  END DO
END SUBROUTINE SIGMAY_FUNC_BV

!  Differentiation of sigmaz_func in reverse (adjoint) mode:
!   gradient     of useful results: sigmaz kz rotor_diameter
!   with respect to varying inputs: kz rotor_diameter deltax0
! calculates the vertical spread of the wake at a given distance from the onset of far
! wake condition
SUBROUTINE SIGMAZ_FUNC_BV(kz, kzb, deltax0, deltax0b, rotor_diameter, &
& rotor_diameterb, sigmaz, sigmazb, nbdirs)
  !USE DIFFSIZES
!  Hint: nbdirs should be the maximum number of differentiation directions
  IMPLICIT NONE
! define precision to be the standard for a double precision ! on local system
  INTEGER, PARAMETER :: dp=KIND(0.d0)
! in
  REAL(dp), INTENT(IN) :: kz, deltax0, rotor_diameter
  REAL(dp), DIMENSION(nbdirs) :: kzb, deltax0b, rotor_diameterb
! out
  REAL(dp) :: sigmaz
  REAL(dp), DIMENSION(nbdirs) :: sigmazb
! load necessary intrinsic functions
  INTRINSIC COS, SQRT
  INTRINSIC KIND
! vertical spread
  REAL(dp) :: temp
  INTEGER :: nd
  REAL(dp), DIMENSION(nbdirs) :: tempb
  INTEGER :: nbdirs
  temp = kz*deltax0/rotor_diameter
  DO nd=1,nbdirs
    tempb(nd) = sigmazb(nd)
    rotor_diameterb(nd) = rotor_diameterb(nd) + (1.0/SQRT(8.0_dp)+temp)*&
&     sigmazb(nd) - temp*tempb(nd)
    kzb(nd) = kzb(nd) + deltax0*tempb(nd)
    deltax0b(nd) = kz*tempb(nd)
  END DO
END SUBROUTINE SIGMAZ_FUNC_BV

!  Differentiation of wake_offset_func in reverse (adjoint) mode:
!   gradient     of useful results: theta_c_0 yaw sigmay sigmaz
!                ky kz rotor_diameter x0 wake_offset ct
!   with respect to varying inputs: theta_c_0 yaw sigmay sigmaz
!                ky kz rotor_diameter x0 ct
! calculates the horizontal distance from the wake center to the hub of the turbine making
! the wake
SUBROUTINE WAKE_OFFSET_FUNC_BV(rotor_diameter, rotor_diameterb, &
& theta_c_0, theta_c_0b, x0, x0b, yaw, yawb, ky, kyb, kz, kzb, ct, ctb, &
& sigmay, sigmayb, sigmaz, sigmazb, wake_offset, wake_offsetb, nbdirs)
  !USE DIFFSIZES
!  Hint: nbdirs should be the maximum number of differentiation directions
  IMPLICIT NONE
! define precision to be the standard for a double precision ! on local system
  INTEGER, PARAMETER :: dp=KIND(0.d0)
! in
  REAL(dp), INTENT(IN) :: rotor_diameter, theta_c_0, x0, yaw, ky, kz, ct&
& , sigmay
  REAL(dp), DIMENSION(nbdirs) :: rotor_diameterb, theta_c_0b, x0b, &
& yawb, kyb, kzb, ctb, sigmayb
  REAL(dp), INTENT(IN) :: sigmaz
  REAL(dp), DIMENSION(nbdirs) :: sigmazb
! out
  REAL(dp) :: wake_offset
  REAL(dp), DIMENSION(nbdirs) :: wake_offsetb
  INTRINSIC COS, SQRT, LOG
  INTRINSIC KIND
! horizontal cross-wind wake displacement from hub
  REAL(dp) :: temp
  REAL(dp) :: temp0
  REAL(dp) :: temp1
  REAL(dp) :: temp2
  REAL(dp) :: temp3
  REAL(dp) :: temp4
  REAL(dp) :: temp5
  REAL(dp) :: temp6
  REAL(dp) :: temp7
  REAL(dp) :: temp8
  REAL(dp) :: temp9
  REAL(dp) :: temp10
  REAL(dp) :: temp11
  REAL(dp) :: temp12
  REAL(dp) :: temp13
  REAL(dp) :: temp14
  REAL(dp) :: temp15
  REAL(dp) :: temp16
  REAL(dp) :: temp17
  REAL(dp) :: temp18
  REAL(dp) :: temp19
  REAL(dp) :: temp20
  REAL(dp) :: temp21
  REAL(dp) :: temp22
  REAL(dp) :: temp23
  INTEGER :: nd
  REAL(dp), DIMENSION(nbdirs) :: tempb
  REAL(dp), DIMENSION(nbdirs) :: tempb0
  REAL(dp), DIMENSION(nbdirs) :: tempb1
  REAL(dp), DIMENSION(nbdirs) :: tempb2
  REAL(dp), DIMENSION(nbdirs) :: tempb3
  REAL(dp), DIMENSION(nbdirs) :: tempb4
  REAL(dp), DIMENSION(nbdirs) :: tempb5
  REAL(dp), DIMENSION(nbdirs) :: tempb6
  REAL(dp), DIMENSION(nbdirs) :: tempb7
  REAL(dp), DIMENSION(nbdirs) :: tempb8
  REAL(dp), DIMENSION(nbdirs) :: tempb9
  INTEGER :: nbdirs
  temp23 = SQRT(ct)
  temp22 = COS(yaw)
  temp7 = temp22*rotor_diameter**2
  temp6 = sigmay*sigmaz/temp7
  temp21 = SQRT(8.0_dp*temp6)
  temp20 = SQRT(ct)
  temp5 = (-temp20+1.6_dp)*(1.6_dp*temp21+temp23)
  temp19 = SQRT(ct)
  temp18 = COS(yaw)
  temp4 = temp18*rotor_diameter**2
  temp3 = sigmay*sigmaz/temp4
  temp17 = SQRT(8.0_dp*temp3)
  temp16 = 1.6_dp*temp17 - temp19
  temp15 = SQRT(ct)
  temp2 = (temp15+1.6_dp)*temp16/temp5
  temp14 = LOG(temp2)
  temp13 = SQRT(-ct + 1.0_dp)
  temp12 = 1.3_dp*temp13 - ct + 2.9_dp
  temp11 = theta_c_0/14.7_dp
  temp1 = ky*kz*ct
  temp10 = COS(yaw)
  temp0 = temp10/temp1
  temp9 = SQRT(temp0)
  temp8 = temp9*temp11*temp12
  temp = theta_c_0*x0/rotor_diameter
  DO nd=1,nbdirs
    tempb(nd) = rotor_diameter*wake_offsetb(nd)
    tempb0(nd) = tempb(nd)/rotor_diameter
    IF (temp0 .EQ. 0.0) THEN
      tempb1(nd) = 0.0
    ELSE
      tempb1(nd) = temp11*temp12*temp14*tempb(nd)/(2.0*temp9*temp1)
    END IF
    tempb2(nd) = -(temp0*tempb1(nd))
    tempb3(nd) = temp14*temp9*tempb(nd)
    tempb4(nd) = temp8*tempb(nd)/(temp2*temp5)
    IF (8.0_dp*temp3 .EQ. 0.0) THEN
      tempb5(nd) = 0.0
    ELSE
      tempb5(nd) = 8.0_dp*1.6_dp*(temp15+1.6_dp)*tempb4(nd)/(2.0*temp17*&
&       temp4)
    END IF
    tempb6(nd) = -(temp3*tempb5(nd))
    tempb7(nd) = -(temp2*tempb4(nd))
    IF (8.0_dp*temp6 .EQ. 0.0) THEN
      tempb8(nd) = 0.0
    ELSE
      tempb8(nd) = 8.0_dp*1.6_dp*(1.6_dp-temp20)*tempb7(nd)/(2.0*temp21*&
&       temp7)
    END IF
    tempb9(nd) = -(temp6*tempb8(nd))
    rotor_diameterb(nd) = rotor_diameterb(nd) + temp22*2*rotor_diameter*&
&     tempb9(nd) + temp18*2*rotor_diameter*tempb6(nd) - temp*tempb0(nd) &
&     + (temp+temp8*temp14)*wake_offsetb(nd)
    theta_c_0b(nd) = theta_c_0b(nd) + temp12*tempb3(nd)/14.7_dp + x0*&
&     tempb0(nd)
    x0b(nd) = x0b(nd) + theta_c_0*tempb0(nd)
    yawb(nd) = yawb(nd) - rotor_diameter**2*SIN(yaw)*tempb9(nd) - &
&     rotor_diameter**2*SIN(yaw)*tempb6(nd) - SIN(yaw)*tempb1(nd)
    kyb(nd) = kyb(nd) + ct*kz*tempb2(nd)
    kzb(nd) = kzb(nd) + ct*ky*tempb2(nd)
    IF (1.0_dp - ct .EQ. 0.0) THEN
      ctb(nd) = ctb(nd) + ky*kz*tempb2(nd) - temp11*tempb3(nd)
    ELSE
      ctb(nd) = ctb(nd) + ((1.6_dp-temp20)/(2.0*temp23)-(1.6_dp*temp21+&
&       temp23)/(2.0*temp20))*tempb7(nd) + (temp16/(2.0*temp15)-(temp15+&
&       1.6_dp)/(2.0*temp19))*tempb4(nd) + (-temp11-1.3_dp*temp11/(2.0*&
&       temp13))*tempb3(nd) + ky*kz*tempb2(nd)
    END IF
    sigmayb(nd) = sigmayb(nd) + sigmaz*tempb8(nd) + sigmaz*tempb5(nd)
    sigmazb(nd) = sigmazb(nd) + sigmay*tempb8(nd) + sigmay*tempb5(nd)
  END DO
END SUBROUTINE WAKE_OFFSET_FUNC_BV

!  Differentiation of deltav_func in reverse (adjoint) mode:
!   gradient     of useful results: yaw rotor_diameter wind_speed
!                deltav ct
!   with respect to varying inputs: yaw sigmay sigmaz rotor_diameter
!                wind_speed deltay deltaz ct
! calculates the velocity difference between hub velocity and free stream for a given wake
! for use in the far wake region
SUBROUTINE DELTAV_FUNC_BV(deltay, deltayb, deltaz, deltazb, wake_offset&
& , wind_speed, wind_speedb, ct, ctb, yaw, yawb, sigmay, sigmayb, sigmaz&
& , sigmazb, rotor_diameter, rotor_diameterb, deltav, deltavb, nbdirs)
  !USE DIFFSIZES
!  Hint: nbdirs should be the maximum number of differentiation directions
  IMPLICIT NONE
! define precision to be the standard for a double precision ! on local system
  INTEGER, PARAMETER :: dp=KIND(0.d0)
! in
  REAL(dp), INTENT(IN) :: deltay, deltaz, wake_offset, wind_speed, ct, &
& yaw, sigmay
  REAL(dp), DIMENSION(nbdirs) :: deltayb, deltazb, wind_speedb, ctb, &
& yawb, sigmayb
  REAL(dp), INTENT(IN) :: sigmaz, rotor_diameter
  REAL(dp), DIMENSION(nbdirs) :: sigmazb, rotor_diameterb
! out
  REAL(dp) :: deltav
  REAL(dp), DIMENSION(nbdirs) :: deltavb
  INTRINSIC COS, SQRT, EXP
  INTRINSIC KIND
! velocity difference in the wake
  REAL(dp) :: temp
  REAL(dp) :: temp0
  REAL(dp) :: temp1
  REAL(dp) :: temp2
  REAL(dp) :: temp3
  REAL(dp) :: temp4
  REAL(dp) :: temp5
  REAL(dp) :: temp6
  REAL(dp) :: temp7
  REAL(dp) :: temp8
  REAL(dp) :: temp9
  INTEGER :: nd
  REAL(dp), DIMENSION(nbdirs) :: tempb
  REAL(dp), DIMENSION(nbdirs) :: tempb0
  REAL(dp), DIMENSION(nbdirs) :: tempb1
  REAL(dp), DIMENSION(nbdirs) :: tempb2
  REAL(dp), DIMENSION(nbdirs) :: tempb3
  REAL(dp), DIMENSION(nbdirs) :: tempb4
  INTEGER :: nbdirs
  temp9 = sigmaz**2
  temp2 = deltaz**2/temp9
  temp8 = EXP(-(0.5_dp*temp2))
  temp7 = sigmay**2
  temp1 = deltay**2/temp7
  temp6 = EXP(-(0.5_dp*temp1))
  temp0 = 8.0_dp*sigmay*sigmaz
  temp5 = ct*rotor_diameter**2
  temp = temp5/temp0
  temp4 = COS(yaw)
  temp3 = SQRT(-(temp4*temp) + 1.0_dp)
  DO nd=1,nbdirs
    IF (1.0_dp - temp4*temp .EQ. 0.0) THEN
      tempb(nd) = 0.0
    ELSE
      tempb(nd) = -(wind_speed*temp6*temp8*deltavb(nd)/(2.0*temp3))
    END IF
    tempb0(nd) = -(temp4*tempb(nd)/temp0)
    tempb1(nd) = -(temp*tempb0(nd))
    tempb2(nd) = (1.0_dp-temp3)*deltavb(nd)
    tempb3(nd) = -(0.5_dp*EXP(-(0.5_dp*temp1))*wind_speed*temp8*tempb2(&
&     nd)/temp7)
    tempb4(nd) = -(0.5_dp*EXP(-(0.5_dp*temp2))*wind_speed*temp6*tempb2(&
&     nd)/temp9)
    yawb(nd) = yawb(nd) + temp*SIN(yaw)*tempb(nd)
    ctb(nd) = ctb(nd) + rotor_diameter**2*tempb0(nd)
    rotor_diameterb(nd) = rotor_diameterb(nd) + ct*2*rotor_diameter*&
&     tempb0(nd)
    sigmayb(nd) = sigmaz*8.0_dp*tempb1(nd) - temp1*2*sigmay*tempb3(nd)
    sigmazb(nd) = 8.0_dp*sigmay*tempb1(nd) - temp2*2*sigmaz*tempb4(nd)
    wind_speedb(nd) = wind_speedb(nd) + temp8*temp6*tempb2(nd)
    deltayb(nd) = 2*deltay*tempb3(nd)
    deltazb(nd) = 2*deltaz*tempb4(nd)
  END DO
END SUBROUTINE DELTAV_FUNC_BV

!  Differentiation of deltav_near_wake_lin_func in reverse (adjoint) mode:
!   gradient     of useful results: yaw rotor_diameter wind_speed
!                deltav x0 ct
!   with respect to varying inputs: yaw x sigmay sigmaz rotor_diameter
!                wind_speed deltay deltaz sigmay0 x0 ct sigmaz0
! calculates the velocity difference between hub velocity and free stream for a given wake
! for use in the near wake region only
SUBROUTINE DELTAV_NEAR_WAKE_LIN_FUNC_BV(deltay, deltayb, deltaz, deltazb&
& , wake_offset, wind_speed, wind_speedb, ct, ctb, yaw, yawb, sigmay, &
& sigmayb, sigmaz, sigmazb, rotor_diameter, rotor_diameterb, x, xb, x0, &
& x0b, sigmay0, sigmay0b, sigmaz0, sigmaz0b, deltav, deltavb, nbdirs)
  !USE DIFFSIZES
!  Hint: nbdirs should be the maximum number of differentiation directions
  IMPLICIT NONE
! define precision to be the standard for a double precision ! on local system
  INTEGER, PARAMETER :: dp=KIND(0.d0)
! in
  REAL(dp), INTENT(IN) :: deltay, deltaz, wake_offset, wind_speed, ct, &
& yaw, sigmay
  REAL(dp), DIMENSION(nbdirs) :: deltayb, deltazb, wind_speedb, ctb, &
& yawb, sigmayb
  REAL(dp), INTENT(IN) :: sigmaz, rotor_diameter, x, x0, sigmay0, &
& sigmaz0
  REAL(dp), DIMENSION(nbdirs) :: sigmazb, rotor_diameterb, xb, x0b, &
& sigmay0b, sigmaz0b
! local
  REAL(dp) :: deltav0m, deltavs
  REAL(dp), DIMENSION(nbdirs) :: deltav0mb, deltavsb
! out
  REAL(dp) :: deltav
  REAL(dp), DIMENSION(nbdirs) :: deltavb
  INTRINSIC COS, SQRT, EXP
  INTRINSIC KIND
  REAL(dp) :: temp
  REAL(dp) :: temp0
  REAL(dp) :: temp1
  REAL(dp) :: temp2
  REAL(dp) :: temp3
  REAL(dp) :: temp4
  REAL(dp) :: temp5
  REAL(dp) :: temp6
  REAL(dp) :: temp7
  REAL(dp) :: temp8
  REAL(dp) :: temp9
  REAL(dp) :: temp10
  INTEGER :: nd
  REAL(dp), DIMENSION(nbdirs) :: tempb
  REAL(dp), DIMENSION(nbdirs) :: tempb0
  REAL(dp), DIMENSION(nbdirs) :: tempb1
  REAL(dp), DIMENSION(nbdirs) :: tempb2
  REAL(dp), DIMENSION(nbdirs) :: tempb3
  REAL(dp), DIMENSION(nbdirs) :: tempb4
  REAL(dp), DIMENSION(nbdirs) :: tempb5
  REAL(dp), DIMENSION(nbdirs) :: tempb6
  INTEGER :: nbdirs
  deltavs = 0.9*wind_speed
! magnitude term of gaussian at x0
  deltav0m = wind_speed*(1.0_dp-SQRT(1.0_dp-ct*COS(yaw)/(8.0_dp*sigmay0*&
&   sigmaz0/rotor_diameter**2)))
! linearized gaussian magnitude term for near wake
  temp10 = sigmaz**2
  temp7 = deltaz**2/temp10
  temp9 = sigmay**2
  temp6 = deltay**2/temp9
  temp8 = EXP(-(0.5_dp*temp6))
  temp5 = x/x0
  temp4 = (deltav0m-deltavs)*temp5 + deltavs
  temp0 = 8.0_dp*sigmay0*sigmaz0
  temp3 = ct*rotor_diameter**2
  temp = temp3/temp0
  temp2 = COS(yaw)
  temp1 = SQRT(-(temp2*temp) + 1.0_dp)
  DO nd=1,nbdirs
    tempb(nd) = EXP(-(0.5_dp*temp7))*deltavb(nd)
    tempb0(nd) = temp8*tempb(nd)
    tempb1(nd) = (deltav0m-deltavs)*tempb0(nd)/x0
    tempb2(nd) = -(0.5_dp*EXP(-(0.5_dp*temp6))*temp4*tempb(nd)/temp9)
    tempb3(nd) = -(0.5_dp*EXP(-(0.5_dp*temp7))*temp4*temp8*deltavb(nd)/&
&     temp10)
    deltav0mb(nd) = temp5*tempb0(nd)
    deltavsb(nd) = (1.0-temp5)*tempb0(nd)
    xb(nd) = tempb1(nd)
    x0b(nd) = x0b(nd) - temp5*tempb1(nd)
    deltayb(nd) = 2*deltay*tempb2(nd)
    sigmayb(nd) = -(temp6*2*sigmay*tempb2(nd))
    deltazb(nd) = 2*deltaz*tempb3(nd)
    sigmazb(nd) = -(temp7*2*sigmaz*tempb3(nd))
    IF (1.0_dp - temp2*temp .EQ. 0.0) THEN
      tempb4(nd) = 0.0
    ELSE
      tempb4(nd) = -(wind_speed*deltav0mb(nd)/(2.0*temp1))
    END IF
    tempb5(nd) = -(temp2*tempb4(nd)/temp0)
    tempb6(nd) = -(temp*tempb5(nd))
    wind_speedb(nd) = wind_speedb(nd) + 0.9*deltavsb(nd) + (1.0_dp-temp1&
&     )*deltav0mb(nd)
    yawb(nd) = yawb(nd) + temp*SIN(yaw)*tempb4(nd)
    ctb(nd) = ctb(nd) + rotor_diameter**2*tempb5(nd)
    rotor_diameterb(nd) = rotor_diameterb(nd) + ct*2*rotor_diameter*&
&     tempb5(nd)
    sigmay0b(nd) = sigmaz0*8.0_dp*tempb6(nd)
    sigmaz0b(nd) = 8.0_dp*sigmay0*tempb6(nd)
  END DO
END SUBROUTINE DELTAV_NEAR_WAKE_LIN_FUNC_BV


C
C
       real*4 function ct_lin_grey( rgb, ci, cimin, cimax )
C      ----------------------------------------------------
C
C Function defining a standard linear grey-scale.
C
C    ct_lin_grey = (ci-cimin)/(cimax-cimin)
C
*-

       integer        rgb, ci, cimin, cimax
       ct_lin_grey  = (float(ci-cimin)/float(cimax-cimin))
       end