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

!     This file is part of the Code_Saturne Kernel, element of the
!     Code_Saturne CFD tool.

!     Copyright (C) 1998-2009 EDF S.A., France

!     contact: saturne-support@edf.fr

!     The Code_Saturne Kernel is free software; you can redistribute it
!     and/or modify it under the terms of the GNU General Public License
!     as published by the Free Software Foundation; either version 2 of
!     the License, or (at your option) any later version.

!     The Code_Saturne Kernel is distributed in the hope that it will be
!     useful, but WITHOUT ANY WARRANTY; without even the implied warranty
!     of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!     GNU General Public License for more details.

!     You should have received a copy of the GNU General Public License
!     along with the Code_Saturne Kernel; if not, write to the
!     Free Software Foundation, Inc.,
!     51 Franklin St, Fifth Floor,
!     Boston, MA  02110-1301  USA

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

subroutine cfqdmv &
!================

 ( idbia0 , idbra0 ,                                              &
   ndim   , ncelet , ncel   , nfac   , nfabor , nfml   , nprfml , &
   nnod   , lndfac , lndfbr , ncelbr ,                            &
   nvar   , nscal  , nphas  , ncepdp , ncesmp ,                   &
   nideve , nrdeve , nituse , nrtuse , iphas  ,                   &
   ifacel , ifabor , ifmfbr , ifmcel , iprfml ,                   &
   ipnfac , nodfac , ipnfbr , nodfbr ,                            &
   icepdc , icetsm , itypsm ,                                     &
   idevel , ituser , ia     ,                                     &
   xyzcen , surfac , surfbo , cdgfac , cdgfbo , xyznod , volume , &
   dt     , rtp    , rtpa   , propce , propfa , propfb ,          &
   flumas , flumab ,                                              &
   coefa  , coefb  , ckupdc , smacel , frcxt  , dfrcxt ,          &
   tpucou , trav   , viscf  , viscb  , viscfi , viscbi ,          &
   dam    , xam    ,                                              &
   drtp   , smbr   , rovsdt ,                                     &
   w1     , w2     , w3     , w4     , w5     , w6     ,          &
   w7     , w8     , w9     , coefu  ,                            &
   rdevel , rtuser , ra     )

!===============================================================================
! FONCTION :
! ----------

! RESOLUTION DES EQUATIONS N-S 1 PHASE INCOMPRESSIBLE OU RO VARIABLE
! SUR UN PAS DE TEMPS (CONVECTION/DIFFUSION - PRESSION /CONTINUITE)

! AU PREMIER APPEL,  ON EFFECTUE LA PREDICITION DES VITESSES
!               ET  ON CALCULE UN ESTIMATEUR SUR LA VITESSE PREDITE

! AU DEUXIEME APPEL, ON CALCULE UN ESTIMATEUR GLOBAL
!               POUR NAVIER-STOKES :
!   ON UTILISE TRAV, SMBR ET LES TABLEAUX DE TRAVAIL
!   ON APPELLE BILSC2 AU LIEU DE CODITS
!   ON REMPLIT LE PROPCE ESTIMATEUR IESTOT
!   CE DEUXIEME APPEL INTERVIENT DANS NAVSTO APRES RESOLP
!   LORS DE CE DEUXIEME APPEL
!     RTPA ET RTP SONT UN UNIQUE TABLEAU (= RTP)
!     LE FLUX DE MASSE EST LE FLUX DE MASSE DEDUIT DE LA VITESSE
!      AU CENTRE CONTENUE DANS RTP

!-------------------------------------------------------------------------------
!ARGU                             ARGUMENTS
!__________________.____._____.________________________________________________.
! name             !type!mode ! role                                           !
!__________________!____!_____!________________________________________________!
! idbia0           ! i  ! <-- ! number of first free position in ia            !
! idbra0           ! i  ! <-- ! number of first free position in ra            !
! ndim             ! i  ! <-- ! spatial dimension                              !
! ncelet           ! i  ! <-- ! number of extended (real + ghost) cells        !
! ncel             ! i  ! <-- ! number of cells                                !
! nfac             ! i  ! <-- ! number of interior faces                       !
! nfabor           ! i  ! <-- ! number of boundary faces                       !
! nfml             ! i  ! <-- ! number of families (group classes)             !
! nprfml           ! i  ! <-- ! number of properties per family (group class)  !
! nnod             ! i  ! <-- ! number of vertices                             !
! lndfac           ! i  ! <-- ! size of nodfac indexed array                   !
! lndfbr           ! i  ! <-- ! size of nodfbr indexed array                   !
! ncelbr           ! i  ! <-- ! number of cells with faces on boundary         !
! nvar             ! i  ! <-- ! total number of variables                      !
! nscal            ! i  ! <-- ! total number of scalars                        !
! nphas            ! i  ! <-- ! number of phases                               !
! ncepdp           ! i  ! <-- ! number of cells with head loss                 !
! ncesmp           ! i  ! <-- ! number of cells with mass source term          !
! nideve, nrdeve   ! i  ! <-- ! sizes of idevel and rdevel arrays              !
! nituse, nrtuse   ! i  ! <-- ! sizes of ituser and rtuser arrays              !
! iphas            ! i  ! <-- ! phase number                                   !
! ifacel(2, nfac)  ! ia ! <-- ! interior faces -> cells connectivity           !
! ifabor(nfabor)   ! ia ! <-- ! boundary faces -> cells connectivity           !
! ifmfbr(nfabor)   ! ia ! <-- ! boundary face family numbers                   !
! ifmcel(ncelet)   ! ia ! <-- ! cell family numbers                            !
! iprfml           ! ia ! <-- ! property numbers per family                    !
!  (nfml, nprfml)  !    !     !                                                !
! ipnfac(nfac+1)   ! ia ! <-- ! interior faces -> vertices index (optional)    !
! nodfac(lndfac)   ! ia ! <-- ! interior faces -> vertices list (optional)     !
! ipnfbr(nfabor+1) ! ia ! <-- ! boundary faces -> vertices index (optional)    !
! nodfbr(lndfbr)   ! ia ! <-- ! boundary faces -> vertices list (optional)     !
! icepdc(ncelet    ! te ! <-- ! numero des ncepdp cellules avec pdc            !
! icetsm(ncesmp    ! te ! <-- ! numero des cellules a source de masse          !
! itypsm           ! te ! <-- ! type de source de masse pour les               !
! (ncesmp,nvar)    !    !     !  variables (cf. ustsma)                        !
! idevel(nideve)   ! ia ! <-> ! integer work array for temporary development   !
! ituser(nituse)   ! ia ! <-> ! user-reserved integer work array               !
! ia(*)            ! ia ! --- ! main integer work array                        !
! xyzcen           ! ra ! <-- ! cell centers                                   !
!  (ndim, ncelet)  !    !     !                                                !
! surfac           ! ra ! <-- ! interior faces surface vectors                 !
!  (ndim, nfac)    !    !     !                                                !
! surfbo           ! ra ! <-- ! boundary faces surface vectors                 !
!  (ndim, nfabor)  !    !     !                                                !
! cdgfac           ! ra ! <-- ! interior faces centers of gravity              !
!  (ndim, nfac)    !    !     !                                                !
! cdgfbo           ! ra ! <-- ! boundary faces centers of gravity              !
!  (ndim, nfabor)  !    !     !                                                !
! xyznod           ! ra ! <-- ! vertex coordinates (optional)                  !
!  (ndim, nnod)    !    !     !                                                !
! volume(ncelet)   ! ra ! <-- ! cell volumes                                   !
! dt(ncelet)       ! ra ! <-- ! time step (per cell)                           !
! rtp, rtpa        ! ra ! <-- ! calculated variables at cell centers           !
!  (ncelet, *)     !    !     !  (at current and previous time steps)          !
! propce(ncelet, *)! ra ! <-- ! physical properties at cell centers            !
! propfa(nfac, *)  ! ra ! <-- ! physical properties at interior face centers   !
! propfb(nfabor, *)! ra ! <-- ! physical properties at boundary face centers   !
! flumas           ! tr ! <-- ! flux de masse aux faces internes               !
!  (nfac  )        !    !     !   (distinction iappel=1 ou 2)                  !
! flumab           ! tr ! <-- ! flux de masse aux faces de bord                !
!  (nfabor  )      !    !     !    (distinction iappel=1 ou 2)                 !
! coefa, coefb     ! ra ! <-- ! boundary conditions                            !
!  (nfabor, *)     !    !     !                                                !
! ckupdc           ! tr ! <-- ! tableau de travail pour pdc                    !
!  (ncepdp,6)      !    !     !                                                !
! smacel           ! tr ! <-- ! valeur des variables associee a la             !
! (ncesmp,*   )    !    !     !  source de masse                               !
!                  !    !     !  pour ivar=ipr, smacel=flux de masse           !
! frcxt(ncelet,    ! tr ! <-- ! force exterieure generant la pression          !
!   3,nphas)       !    !     !  hydrostatique                                 !
!dfrcxt(ncelet,    ! tr ! <-- ! variation de force exterieure                  !
!   3,nphas)       !    !     !  generant lapression hydrostatique             !
! tpucou           ! tr ! --> ! couplage vitesse pression                      !
! (ncelel,ndim)    !    !     !                                                !
! trav(ncelet,3    ! tr ! --> ! smb qui servira pour normalisation             !
!                  !    !     !  dans resolp                                   !
! viscf(nfac)      ! tr ! --- ! visc*surface/dist aux faces internes           !
! viscb(nfabor     ! tr ! --- ! visc*surface/dist aux faces de bord            !
! viscfi(nfac)     ! tr ! --- ! idem viscf pour increments                     !
! viscbi(nfabor    ! tr ! --- ! idem viscb pour increments                     !
! dam(ncelet       ! tr ! --- ! tableau de travail pour matrice                !
! xam(nfac,*)      ! tr ! --- ! tableau de travail pour matrice                !
! drtp(ncelet      ! tr ! --- ! tableau de travail pour increment              !
! smbr  (ncelet    ! tr ! --- ! tableau de travail pour sec mem                !
! rovsdt(ncelet    ! tr ! --- ! tableau de travail pour terme instat           !
! w1...9(ncelet    ! tr ! --- ! tableau de travail                             !
! coefu(nfab,3)    ! tr ! --- ! tableau de travail                             !
! rdevel(nrdeve)   ! ra ! <-> ! real work array for temporary development      !
! rtuser(nrtuse)   ! ra ! <-> ! user-reserved real work array                  !
! ra(*)            ! ra ! --- ! main real work array                           !
!__________________!____!_____!________________________________________________!

!     TYPE : E (ENTIER), R (REEL), A (ALPHANUMERIQUE), T (TABLEAU)
!            L (LOGIQUE)   .. ET TYPES COMPOSES (EX : TR TABLEAU REEL)
!     MODE : <-- donnee, --> resultat, <-> Donnee modifiee
!            --- tableau de travail

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

implicit none

!===============================================================================
! Common blocks
!===============================================================================

include "paramx.h"
include "pointe.h"
include "numvar.h"
include "entsor.h"
include "cstphy.h"
include "cstnum.h"
include "optcal.h"
include "period.h"
include "parall.h"
include "ppppar.h"
include "ppthch.h"
include "ppincl.h"
include "cfpoin.h"

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

! Arguments

integer          idbia0 , idbra0
integer          ndim   , ncelet , ncel   , nfac   , nfabor
integer          nfml   , nprfml
integer          nnod   , lndfac , lndfbr , ncelbr
integer          nvar   , nscal  , nphas
integer          ncepdp , ncesmp
integer          nideve , nrdeve , nituse , nrtuse , iphas

integer          ifacel(2,nfac) , ifabor(nfabor)
integer          ifmfbr(nfabor) , ifmcel(ncelet)
integer          iprfml(nfml,nprfml)
integer          ipnfac(nfac+1), nodfac(lndfac)
integer          ipnfbr(nfabor+1), nodfbr(lndfbr)
integer          icepdc(ncepdp)
integer          icetsm(ncesmp), itypsm(ncesmp,nvar)
integer          idevel(nideve), ituser(nituse)
integer          ia(*)

double precision xyzcen(ndim,ncelet)
double precision surfac(ndim,nfac), surfbo(ndim,nfabor)
double precision cdgfac(ndim,nfac), cdgfbo(ndim,nfabor)
double precision xyznod(ndim,nnod), volume(ncelet)
double precision dt(ncelet), rtp(ncelet,*), rtpa(ncelet,*)
double precision propce(ncelet,*)
double precision propfa(nfac,*), propfb(nfabor,*)
double precision flumas(nfac), flumab(nfabor)
double precision coefa(nfabor,*), coefb(nfabor,*)
double precision ckupdc(ncepdp,6), smacel(ncesmp,nvar)
double precision frcxt(ncelet,3,nphas), dfrcxt(ncelet,3,nphas)
double precision tpucou(ncelet,ndim), trav(ncelet,3)
double precision viscf(nfac), viscb(nfabor)
double precision viscfi(nfac), viscbi(nfabor)
double precision dam(ncelet), xam(nfac,2)
double precision drtp(ncelet)
double precision smbr(ncelet), rovsdt(ncelet)
double precision w1(ncelet), w2(ncelet), w3(ncelet)
double precision w4(ncelet), w5(ncelet), w6(ncelet)
double precision w7(ncelet), w8(ncelet), w9(ncelet)
double precision coefu(nfabor,3)
double precision rdevel(nrdeve), rtuser(nrtuse), ra(*)

! Local variables

integer          idebia, idebra, ifinia
integer          iel   , ielpdc, ifac  , ivar  , isou  , iii
integer          iccocg, inc   , init  , iphydp, ii
integer          ireslp, nswrgp, imligp, iwarnp, ipp
integer          ipriph, ikiph , iuiph , iviph , iwiph
integer          iclik , iclvar, iclvaf, iclipr
integer          ipcrom, ipcvis, ipcvst
integer          iconvp, idiffp, ndircp, nitmap, nswrsp
integer          ircflp, ischcp, isstpp, iescap
integer          imgrp , ncymxp, nitmfp
integer          idimte, itenso
integer          idiaex, iterns
integer          iifru
integer          maxelt, ils
double precision rnorm , vitnor
double precision romvom, rtprom
double precision epsrgp, climgp, extrap, blencp, epsilp
double precision epsrsp
double precision vit1  , vit2  , vit3  , thetap, pfac, pfac1
double precision cpdc11, cpdc22, cpdc33, cpdc12, cpdc13, cpdc23
double precision d2s3  , pbord , diipbx, diipby, diipbz, pip, xkb
!===============================================================================

!===============================================================================
! 1.  INITIALISATION
!===============================================================================

idebia = idbia0
idebra = idbra0

ipriph = ipr(iphas)
iuiph  = iu(iphas)
iviph  = iv(iphas)
iwiph  = iw(iphas)
if(itytur(iphas).eq.2 .or. iturb(iphas).eq.50                     &
     .or. iturb(iphas).eq.60) then
  ikiph  = ik(iphas)
endif

if(itytur(iphas).eq.2 .or. iturb(iphas).eq.50                     &
     .or. iturb(iphas).eq.60) then
  iclik  = iclrtp(ikiph ,icoef)
endif

ipcrom = ipproc(irom  (iphas))
ipcvis = ipproc(iviscl(iphas))
ipcvst = ipproc(ivisct(iphas))

!     Indicateur flux de bord Rusanov
if(iifbru.gt.0) then
  iifru = iifbru+(iphas-1)*nfabor
else
  iifru = 1
endif

!===============================================================================
! 2.  GRADIENT DE PRESSION ET GRAVITE
!===============================================================================

! ---> PRISE EN COMPTE DE LA PRESSION HYDROSTATIQUE :

if (iphydr.eq.1) then

!     on doit pouvoir adapter l'option iphydr au compressible,
!       mais noter plusieurs points
!       - on dispose de la masse volumique au pas de temps courant et au
!         pas de temps précédent (au pas de temps précédent dans propce
!         en particulier)
!       - la correction de pression est ici généree par la resolution de
!         l'energie (la pression change sans que rho ne change)
!       - si l'objectif se limite a adapter le calcul de grad p pour
!         qu'il compense le rho0 g, noter quand meme que l'on ne resout
!         pas en rho-rho0 et que P est tjrs cohérent avec rho (par la
!         thermo)

  do iel = 1, ncel

! variation de force (utilise dans resolp)

    if(igrdpp(iphas).gt.0) then
      rtprom = rtp(iel,isca(irho(iphas)))
    else
      rtprom = rtpa(iel,isca(irho(iphas)))
    endif

    dfrcxt(iel,1,iphas) = rtprom*gx - frcxt(iel,1,iphas)
    dfrcxt(iel,2,iphas) = rtprom*gy - frcxt(iel,2,iphas)
    dfrcxt(iel,3,iphas) = rtprom*gz - frcxt(iel,3,iphas)
  enddo
!     Ajout eventuel des pertes de charges
  if (ncepdp.gt.0) then
    do ielpdc = 1, ncepdp
      iel=icepdc(ielpdc)
      vit1   = rtp(iel,iuiph)
      vit2   = rtp(iel,iviph)
      vit3   = rtp(iel,iwiph)
      cpdc11 = ckupdc(ielpdc,1)
      cpdc22 = ckupdc(ielpdc,2)
      cpdc33 = ckupdc(ielpdc,3)
      cpdc12 = ckupdc(ielpdc,4)
      cpdc13 = ckupdc(ielpdc,5)
      cpdc23 = ckupdc(ielpdc,6)
      dfrcxt(iel,1,iphas) = dfrcxt(iel,1,iphas)                   &
 -rtp(iel,isca(irho(iphas)))*(cpdc11*vit1+cpdc12*vit2+cpdc13*vit3)
      dfrcxt(iel,2,iphas) = dfrcxt(iel,2,iphas)                   &
 -rtp(iel,isca(irho(iphas)))*(cpdc12*vit1+cpdc22*vit2+cpdc23*vit3)
      dfrcxt(iel,3,iphas) = dfrcxt(iel,3,iphas)                   &
 -rtp(iel,isca(irho(iphas)))*(cpdc13*vit1+cpdc23*vit2+cpdc33*vit3)
    enddo
  endif

  if(irangp.ge.0) then
    call parcom (dfrcxt(1,1,iphas))
    !==========
    call parcom (dfrcxt(1,2,iphas))
    !==========
    call parcom (dfrcxt(1,3,iphas))
    !==========
  endif
  if(iperio.eq.1) then
    idimte = 1
    itenso = 0
    call percom                                                   &
    !==========
  ( idimte , itenso ,                                             &
    dfrcxt(1,1,iphas),dfrcxt(1,1,iphas),dfrcxt(1,1,iphas),        &
    dfrcxt(1,2,iphas),dfrcxt(1,2,iphas),dfrcxt(1,2,iphas),        &
    dfrcxt(1,3,iphas),dfrcxt(1,3,iphas),dfrcxt(1,3,iphas))
  endif

endif

!       Fin du test sur IPHYDR


! ---> PRISE EN COMPTE DU GRADIENT DE PRESSION

iccocg = 1
inc    = 1
nswrgp = nswrgr(ipriph)
imligp = imligr(ipriph)
iwarnp = iwarni(ipriph)
epsrgp = epsrgr(ipriph)
climgp = climgr(ipriph)
extrap = extrag(ipriph)

call grdcel                                                       &
!==========
 ( idebia , idebra ,                                              &
   ndim   , ncelet , ncel   , nfac   , nfabor , nfml   , nprfml , &
   nnod   , lndfac , lndfbr , ncelbr , nphas  ,                   &
   nideve , nrdeve , nituse , nrtuse ,                            &
   ipriph , imrgra , inc    , iccocg , nswrgp , imligp , iphydr , &
   iwarnp , nfecra , epsrgp , climgp , extrap ,                   &
   ifacel , ifabor , ifmfbr , ifmcel , iprfml ,                   &
   ipnfac , nodfac , ipnfbr , nodfbr ,                            &
   idevel , ituser , ia     ,                                     &
   xyzcen , surfac , surfbo , cdgfac , cdgfbo , xyznod , volume , &
   frcxt(1,1,iphas), frcxt(1,2,iphas), frcxt(1,3,iphas),          &
   rtp(1,ipriph)   , coefa(1,iclrtp(ipriph,icoef))  ,             &
                     coefb(1,iclrtp(ipriph,icoef))  ,             &
   w1     , w2     , w3     ,                                     &
!        ------   ------   ------
   w4     , w5     , w6     ,                                     &
   rdevel , rtuser , ra     )


if (iphydr.eq.1) then
  do iel = 1, ncel
    trav(iel,1) = ( frcxt(iel,1,iphas) - w1(iel) )*volume(iel)
    trav(iel,2) = ( frcxt(iel,2,iphas) - w2(iel) )*volume(iel)
    trav(iel,3) = ( frcxt(iel,3,iphas) - w3(iel) )*volume(iel)
  enddo
else
  do iel = 1, ncel

    if(igrdpp(iphas).gt.0) then
      rtprom = rtp(iel,isca(irho(iphas)))
    else
      rtprom = rtpa(iel,isca(irho(iphas)))
    endif

    trav(iel,1) = ( rtprom*gx - w1(iel) )*volume(iel)
    trav(iel,2) = ( rtprom*gy - w2(iel) )*volume(iel)
    trav(iel,3) = ( rtprom*gz - w3(iel) )*volume(iel)
  enddo
endif

!    Calcul des efforts aux parois (partie 2/5), si demande
!    La pression a la face est calculee comme dans gradrc/gradmc
if (ineedf.eq.1) then
  iclipr = iclrtp(ipriph,icoef)
  do ifac = 1, nfabor
    iel = ifabor(ifac)
    ii = idiipb-1+3*(ifac-1)
    diipbx = ra(ii+1)
    diipby = ra(ii+2)
    diipbz = ra(ii+3)
    pip =  rtpa(iel,ipriph)                                       &
         +diipbx*w1(iel) +diipby*w2(iel)                          &
         +diipbz*w3(iel)
    pfac = coefa(ifac,iclipr) +coefb(ifac,iclipr)*pip
    pfac1= rtpa(iel,ipriph)                                       &
         +(cdgfbo(1,ifac)-xyzcen(1,iel))*w1(iel)                  &
         +(cdgfbo(2,ifac)-xyzcen(2,iel))*w2(iel)                  &
         +(cdgfbo(3,ifac)-xyzcen(3,iel))*w3(iel)
    pfac = coefb(ifac,iclipr)*(extrag(ipriph)*pfac1               &
         +(1.d0-extrag(ipriph))*pfac)                             &
         +(1.d0-coefb(ifac,iclipr))*pfac
    do isou = 1, 3
      ra(iforbr+(ifac-1)*ndim + isou-1) =                         &
           ra(iforbr+(ifac-1)*ndim + isou-1)                      &
           + pfac*surfbo(isou,ifac)
    enddo
  enddo
endif


!     Elimination du flux au bord associé au gradient de pression :
!       il est pris en compte par les conditions aux limites dans
!       le flux de Rusanov

if(iifbru.gt.0) then

  do ifac = 1, nfabor

    if(ia(iifru+ifac-1).eq.1) then

      iel = ifabor(ifac)

      iii = idiipb-1+3*(ifac-1)
      diipbx = ra(iii+1)
      diipby = ra(iii+2)
      diipbz = ra(iii+3)

      pip = rtp(iel,ipriph)                                       &
           +(w1(iel)*diipbx+w2(iel)*diipby+w3(iel)*diipbz)

      pbord = coefa(ifac,iclrtp(ipriph,icoef))                    &
           + coefb(ifac,iclrtp(ipriph,icoef))*pip

      trav(iel,1) = trav(iel,1) + pbord*surfbo(1,ifac)
      trav(iel,2) = trav(iel,2) + pbord*surfbo(2,ifac)
      trav(iel,3) = trav(iel,3) + pbord*surfbo(3,ifac)

    endif

  enddo

endif

!     Flux de C    .L. associé à Rusanov (PROPFB contient la contribution
!       de - div(rho u u) - grad P si on est passé dans cfrusb
!       ou 0 sinon).
!     Pour ne pas ajouter le flux div(rho u u) deux fois, on a remplace
!       codits et bilsc2 par cfcdts et cfbsc2 qui ne different des
!       precedents que par les indicateurs qui permettent de
!       ne pas prendre en compte le flux convectif aux faces de bord
!       pour lesquelles on est passe dans cfrusb

do ifac = 1, nfabor
  iel = ifabor(ifac)
  trav(iel,1) =  trav(iel,1) - propfb(ifac,ipprob(ifbrhu(iphas)))
  trav(iel,2) =  trav(iel,2) - propfb(ifac,ipprob(ifbrhv(iphas)))
  trav(iel,3) =  trav(iel,3) - propfb(ifac,ipprob(ifbrhw(iphas)))
enddo


! ---> 2/3 RHO * GRADIENT DE K SI k epsilon
!      NB : ON NE PREND PAS LE GRADIENT DE (RHO K), MAIS
!           CA COMPLIQUERAIT LA GESTION DES CL ...

if( (itytur(iphas).eq.2 .or. iturb(iphas).eq.50                   &
     .or. iturb(iphas).eq.60) .and.igrhok(iphas).eq.1) then
  iccocg = 1
  inc    = 1
  nswrgp = nswrgr(ikiph)
  imligp = imligr(ikiph)
  epsrgp = epsrgr(ikiph)
  climgp = climgr(ikiph)
  extrap = extrag(ikiph)

  iwarnp = iwarni(iuiph)
  iphydp = 0

  call grdcel                                                     &
  !==========
 ( idebia , idebra ,                                              &
   ndim   , ncelet , ncel   , nfac   , nfabor , nfml   , nprfml , &
   nnod   , lndfac , lndfbr , ncelbr , nphas  ,                   &
   nideve , nrdeve , nituse , nrtuse ,                            &
   ikiph  , imrgra , inc    , iccocg , nswrgp , imligp , iphydp , &
   iwarnp , nfecra , epsrgp , climgp , extrap ,                   &
   ifacel , ifabor , ifmfbr , ifmcel , iprfml ,                   &
   ipnfac , nodfac , ipnfbr , nodfbr ,                            &
   idevel , ituser , ia     ,                                     &
   xyzcen , surfac , surfbo , cdgfac , cdgfbo , xyznod , volume , &
   w6     , w6     , w6     ,                                     &
   rtp(1,ikiph)    , coefa(1,iclik)  , coefb(1,iclik)  ,          &
   w1     , w2     , w3     ,                                     &
!        ------   ------   ------
   w4     , w5     , w6     ,                                     &
   rdevel , rtuser , ra     )

  d2s3 = 2.d0/3.d0
  do iel = 1, ncel
    romvom = -rtp(iel,isca(irho(iphas)))*volume(iel)*d2s3
    trav(iel,1) = trav(iel,1) + w1(iel) * romvom
    trav(iel,2) = trav(iel,2) + w2(iel) * romvom
    trav(iel,3) = trav(iel,3) + w3(iel) * romvom
  enddo

!    Calcul des efforts aux parois (partie 3/5), si demande
  if (ineedf.eq.1) then
    do ifac = 1, nfabor
      iel = ifabor(ifac)
      ii = idiipb-1+3*(ifac-1)
      diipbx = ra(ii+1)
      diipby = ra(ii+2)
      diipbz = ra(ii+3)
      xkb = rtpa(iel,ikiph) + diipbx*w1(iel)                      &
           + diipby*w2(iel) + diipbz*w3(iel)
      xkb = coefa(ifac,iclik)+coefb(ifac,iclik)*xkb
      xkb = d2s3*propce(iel,ipcrom)*xkb
      do isou = 1, 3
        ra(iforbr+(ifac-1)*ndim + isou-1) =                       &
             ra(iforbr+(ifac-1)*ndim + isou-1)                    &
             + xkb*surfbo(isou,ifac)
      enddo
    enddo
  endif

endif



! ---> TERMES DE GRADIENT TRANSPOSE

if (ivisse(iphas).eq.1) then

  call vissec                                                     &
  !==========
 ( idebia , idebra ,                                              &
   ndim   , ncelet , ncel   , nfac   , nfabor , nfml   , nprfml , &
   nnod   , lndfac , lndfbr , ncelbr ,                            &
   nvar   , nscal  , nphas  , ncepdp , ncesmp ,                   &
   nideve , nrdeve , nituse , nrtuse , iphas  ,                   &
   ifacel , ifabor , ifmfbr , ifmcel , iprfml ,                   &
   ipnfac , nodfac , ipnfbr , nodfbr , icepdc , icetsm , itypsm , &
   idevel , ituser , ia     ,                                     &
   xyzcen , surfac , surfbo , cdgfac , cdgfbo , xyznod , volume , &
   rtpa   , propce , propfa , propfb ,                            &
   coefa  , coefb  , ckupdc , smacel ,                            &
   trav   ,                                                       &
!        ------
   viscf  , viscb  , rovsdt ,                                     &
   w1     , w2     , w3     , w4     , w5     , w6     ,          &
   rdevel , rtuser , ra     )

endif


! ---> TERMES DE PERTES DE CHARGE
!     SI IPHYDR=1 LE TERME A DEJA ETE PRIS EN COMPTE AVANT

if((ncepdp.gt.0).and.(iphydr.eq.0)) then

  idiaex = 1
  call tsepdc                                                     &
  !==========
 ( idebia , idebra ,                                              &
   ndim   , ncelet , ncel   , nfac   , nfabor , nfml   , nprfml , &
   nnod   , lndfac , lndfbr , ncelbr ,                            &
   nvar   , nscal  , nphas  ,                                     &
   ncepdp ,                                                       &
   nideve , nrdeve , nituse , nrtuse , iphas  , idiaex ,          &
   ifacel , ifabor , ifmfbr , ifmcel , iprfml ,                   &
   ipnfac , nodfac , ipnfbr , nodfbr ,                            &
   icepdc ,                                                       &
   idevel , ituser , ia     ,                                     &
   xyzcen , surfac , surfbo , cdgfac , cdgfbo , xyznod , volume , &
   rtp    , propce , propfa , propfb ,                            &
   coefa  , coefb  , ckupdc , trav   ,                            &
   w1     , w2     , w3     , w4     , w5     , w6     ,          &
   rdevel , rtuser , ra     )

endif


! ---> - DIVERGENCE DE RIJ

if(itytur(iphas).eq.3 ) then

  do isou = 1, 3

    if(isou.eq.1) ivar = iuiph
    if(isou.eq.2) ivar = iviph
    if(isou.eq.3) ivar = iwiph

    call divrij                                                   &
    !==========
 ( idebia , idebra ,                                              &
   ndim   , ncelet , ncel   , nfac   , nfabor , nfml   , nprfml , &
   nnod   , lndfac , lndfbr , ncelbr ,                            &
   nvar   , nscal  , nphas  ,                                     &
   nideve , nrdeve , nituse , nrtuse , isou   , ivar   , iphas  , &
   ifacel , ifabor , ifmfbr , ifmcel , iprfml ,                   &
   ipnfac , nodfac , ipnfbr , nodfbr ,                            &
   idevel , ituser , ia     ,                                     &
   xyzcen , surfac , surfbo , cdgfac , cdgfbo , xyznod , volume , &
   rtp    , propce , propfa , propfb ,                            &
   coefa  , coefb  ,                                              &
   viscf  , viscb  ,                                              &
   w1     , w2     , w3     , w4     , w5     , w6     ,          &
   w7     , w8     , w9     , coefu  ,                            &
   rdevel , rtuser , ra     )

    init = 1
    call divmas(ncelet,ncel,nfac,nfabor,init,nfecra,              &
                                   ifacel,ifabor,viscf,viscb,w1)

    do iel = 1, ncel
       trav(iel,isou) = trav(iel,isou) -  w1(iel)
    enddo

  enddo

endif



! ---> "VITESSE" DE DIFFUSION FACETTE
!      SI ON FAIT AUTRE CHOSE QUE DU K EPS, IL FAUDRA LA METTRE
!        DANS LA BOUCLE

if( idiff(iuiph).ge. 1 ) then

! --- Si la vitesse doit etre diffusee, on calcule la viscosite
!       pour le second membre (selon Rij ou non)

  if (itytur(iphas).eq.3) then
    do iel = 1, ncel
      w1(iel) = propce(iel,ipcvis)
    enddo
  else
    do iel = 1, ncel
      w1(iel) = propce(iel,ipcvis) + propce(iel,ipcvst)
    enddo
  endif

  call viscfa                                                     &
  !==========
 ( idebia , idebra ,                                              &
   ndim   , ncelet , ncel   , nfac   , nfabor , nfml   , nprfml , &
   nnod   , lndfac , lndfbr , ncelbr ,                            &
   nideve , nrdeve , nituse , nrtuse , imvisf ,                   &
   ifacel , ifabor , ifmfbr , ifmcel , iprfml ,                   &
   ipnfac , nodfac , ipnfbr , nodfbr ,                            &
   idevel , ituser , ia     ,                                     &
   xyzcen , surfac , surfbo , cdgfac , cdgfbo , xyznod , volume , &
   w1     ,                                                       &
   viscf  , viscb  ,                                              &
   rdevel , rtuser , ra     )

!     Quand on n'est pas en Rij ou que irijnu = 0, les tableaux
!       VISCFI, VISCBI se trouvent remplis par la meme occasion
!       (ils sont confondus avec VISCF, VISCB)
!     En Rij avec irijnu = 1, on calcule la viscosite increment
!       de la matrice dans VISCFI, VISCBI

  if(itytur(iphas).eq.3 .and. irijnu(iphas).eq.1) then
    do iel = 1, ncel
      w1(iel) = propce(iel,ipcvis) + propce(iel,ipcvst)
    enddo
    call viscfa                                                   &
    !==========
 ( idebia , idebra ,                                              &
   ndim   , ncelet , ncel   , nfac   , nfabor , nfml   , nprfml , &
   nnod   , lndfac , lndfbr , ncelbr ,                            &
   nideve , nrdeve , nituse , nrtuse , imvisf ,                   &
   ifacel , ifabor , ifmfbr , ifmcel , iprfml ,                   &
   ipnfac , nodfac , ipnfbr , nodfbr ,                            &
   idevel , ituser , ia     ,                                     &
   xyzcen , surfac , surfbo , cdgfac , cdgfbo , xyznod , volume , &
   w1     ,                                                       &
   viscfi , viscbi ,                                              &
   rdevel , rtuser , ra     )
  endif

else

! --- Si la vitesse n'a pas de diffusion, on annule la viscosite
!      (matrice et second membre sont dans le meme tableau,
!       sauf en Rij avec IRIJNU = 1)

  do ifac = 1, nfac
    viscf(ifac) = 0.d0
  enddo
  do ifac = 1, nfabor
    viscb(ifac) = 0.d0
  enddo

  if(itytur(iphas).eq.3.and.irijnu(iphas).eq.1) then
    do ifac = 1, nfac
      viscfi(ifac) = 0.d0
    enddo
    do ifac = 1, nfabor
      viscbi(ifac) = 0.d0
    enddo
  endif

endif


! 2.2  RESOLUTION IMPLICITE NON COUPLEE DES 3 COMPO. DE VITESSES
! ==============================================================

! ---> BOUCLE SUR LES DIRECTIONS DE L'ESPACE (U, V, W)


! Remarque : On suppose que le couplage vitesse pression
!  n'est valable que pour une seule phase.

do isou = 1, 3

  if(isou.eq.1) then
    ivar = iuiph
  endif
  if(isou.eq.2) then
    ivar = iviph
  endif
  if(isou.eq.3) then
    ivar = iwiph
  endif
  ipp  = ipprtp(ivar)

  iclvar = iclrtp(ivar,icoef)
  iclvaf = iclrtp(ivar,icoeff)


! ---> TERMES SOURCES UTILISATEURS

  do iel = 1, ncel
    smbr  (iel) = 0.d0
    drtp  (iel) = 0.d0
  enddo

  maxelt = max(ncelet, nfac, nfabor)
  ils    = idebia
  ifinia = ils + maxelt
  CALL IASIZE('CFQDMV',IFINIA)

  call ustsns                                                     &
  !==========
 ( ifinia , idebra ,                                              &
   ndim   , ncelet , ncel   , nfac   , nfabor , nfml   , nprfml , &
   nnod   , lndfac , lndfbr , ncelbr ,                            &
   nvar   , nscal  , nphas  , ncepdp , ncesmp ,                   &
   nideve , nrdeve , nituse , nrtuse ,                            &
   ivar   , iphas  ,                                              &
   ifacel , ifabor , ifmfbr , ifmcel , iprfml , maxelt , ia(ils), &
   ipnfac , nodfac , ipnfbr , nodfbr ,                            &
   icepdc , icetsm , itypsm ,                                     &
   idevel , ituser , ia     ,                                     &
   xyzcen , surfac , surfbo , cdgfac , cdgfbo , xyznod , volume , &
   dt     , rtp    , propce , propfa , propfb ,                   &
   coefa  , coefb  , ckupdc , smacel ,                            &
   smbr   , drtp   ,                                              &
!        ------   ------
   dam    , xam    ,                                              &
   w1     , w2     , w3     , w4     , w5     , w6     ,          &
   rdevel , rtuser , ra     )


  do iel = 1, ncel
    rovsdt(iel) = max(-drtp(iel),zero)
    smbr  (iel) = smbr(iel) + drtp(iel) * rtp(iel,ivar)
  enddo


! ---> TERME D'ACCUMULATION DE MASSE -(dRO/dt)*Volume

  init = 1
  call divmas(ncelet,ncel,nfac,nfabor,init,nfecra,                &
                           ifacel,ifabor,flumas,flumab,w1)



! ---> AJOUT DANS LE TERME SOURCE ET DANS LE TERME INSTATIONNAIRE

  do iel = 1, ncel
    smbr(iel) = smbr  (iel) +                                     &
         trav(iel,isou)+iconv(ivar)*w1(iel)*rtpa(iel,ivar)
  enddo

  do iel = 1, ncel
    rovsdt(iel) = rovsdt(iel) +                                   &
         istat(ivar)*(propce(iel,ipcrom)/dt(iel))*volume(iel)     &
         -iconv(ivar)*w1(iel)
  enddo


! ---> PERTES DE CHARGE

  if (ncepdp.gt.0) then
    do ielpdc = 1, ncepdp
      iel = icepdc(ielpdc)
      rovsdt(iel) = rovsdt(iel) +                                 &
           propce(iel,ipcrom)*volume(iel)*ckupdc(ielpdc,isou)
    enddo
  endif


! --->  TERMES DE SOURCE DE MASSE

  if (ncesmp.gt.0) then
    iterns = 1
    call catsma ( ncelet , ncel , ncesmp , iterns ,               &
                  isno2t(iphas), thetav(ivar),                    &
                  icetsm , itypsm(1,ivar)  ,                      &
                  volume , rtp(1,ivar) , smacel(1,ivar) ,         &
                  smacel(1,ipr(iphas)) , smbr , rovsdt , w1)
  endif



! ---> PARAMETRES POUR LA RESOLUTION DU SYSTEME

  iconvp = iconv (ivar)
  idiffp = idiff (ivar)
  ireslp = iresol(ivar)
  ndircp = ndircl(ivar)
  nitmap = nitmax(ivar)
!MO        IMRGRA
  nswrsp = nswrsm(ivar)
  nswrgp = nswrgr(ivar)
  imligp = imligr(ivar)
  ircflp = ircflu(ivar)
  ischcp = ischcv(ivar)
  isstpp = isstpc(ivar)
  imgrp  = imgr  (ivar)
  ncymxp = ncymax(ivar)
  nitmfp = nitmgf(ivar)
!MO        IPP
  iwarnp = iwarni(ivar)
  blencp = blencv(ivar)
  epsilp = epsilo(ivar)
  epsrsp = epsrsm(ivar)
  epsrgp = epsrgr(ivar)
  climgp = climgr(ivar)
  extrap = extrag(ivar)
  thetap = thetav(ivar)
  iescap = 0


! ---> FIN DE LA CONSTRUCTION ET DE LA RESOLUTION DU SYSTEME

  call cfcdts                                                     &
  !==========
 ( idebia , idebra ,                                              &
   ndim   , ncelet , ncel   , nfac   , nfabor , nfml   , nprfml , &
   nnod   , lndfac , lndfbr , ncelbr ,                            &
   nvar   , nscal  , nphas  ,                                     &
   nideve , nrdeve , nituse , nrtuse ,                            &
   ivar   , iconvp , idiffp , ireslp , ndircp ,  nitmap ,         &
   imrgra , nswrsp , nswrgp , imligp , ircflp ,                   &
   ischcp , isstpp , iescap , iifbru ,                            &
   imgrp  , ncymxp , nitmfp , ipp    , iwarnp ,                   &
   blencp , epsilp , epsrsp , epsrgp , climgp , extrap , thetap , &
   ifacel , ifabor , ifmfbr , ifmcel , iprfml , ia(iifru) ,       &
   ipnfac , nodfac , ipnfbr , nodfbr ,                            &
   idevel , ituser , ia     ,                                     &
   xyzcen , surfac , surfbo , cdgfac , cdgfbo , xyznod , volume , &
   rtpa(1,ivar)    , coefa(1,iclvar) , coefb(1,iclvar) ,          &
                     coefa(1,iclvaf) , coefb(1,iclvaf) ,          &
                     flumas , flumab ,                            &
   viscfi , viscbi , viscf  , viscb  ,                            &
   rovsdt , smbr   , rtp(1,ivar)     ,                            &
   dam    , xam    , drtp   ,                                     &
   w1     , w2     , w3     , w4     , w5     ,                   &
   w6     , w7     , w8     , w9     ,                            &
   rdevel , rtuser , ra     )


!     PAS DE COUPLAGE INSTATIONNAIRE EN COMPRESSIBLE

enddo

! --->  FIN DE LA BOUCLE SUR U, V, W,


! ---> IMPRESSION DE NORME

if (iwarni(iuiph).ge.2) then
  rnorm = -1.d0
  do iel = 1, ncel
    vitnor =                                                      &
     sqrt(rtp(iel,iuiph)**2+rtp(iel,iviph)**2+rtp(iel,iwiph)**2)
    rnorm = max(rnorm,vitnor)
  enddo
  if (irangp.ge.0) call parmax (rnorm)
                             !==========
  write(nfecra,1100) iphas, rnorm
endif


!--------
! FORMATS
!--------

 1100 format(/,                                                   &
 1X,'Phase ',I4,' : Vitesse maximale apres qdm ',E12.4)
!----
! FIN
!----

return
end subroutine
