Index: LMDZ4/trunk/libf/phylmd/albsno.F90
===================================================================
--- LMDZ4/trunk/libf/phylmd/albsno.F90	(revision 782)
+++ LMDZ4/trunk/libf/phylmd/albsno.F90	(revision 782)
@@ -0,0 +1,55 @@
+!
+! $Header$
+!
+SUBROUTINE albsno(klon, knon, dtime, agesno, alb_neig_grid, precip_snow)
+
+  IMPLICIT NONE
+
+! Input arguments
+!****************************************************************************************
+  INTEGER, INTENT(IN)                  :: klon, knon
+  REAL, INTENT(IN)                     :: dtime
+  REAL, DIMENSION(klon), INTENT(IN)    :: precip_snow
+
+! In/Output arguments
+!****************************************************************************************
+  REAL, DIMENSION(klon), INTENT(INOUT) :: agesno
+
+! Output arguments
+!****************************************************************************************
+  REAL, DIMENSION(klon), INTENT(OUT)   :: alb_neig_grid
+
+! Local variables
+!****************************************************************************************
+  INTEGER                              :: i, nv
+  INTEGER, PARAMETER                   :: nvm = 8 
+  REAL                                 :: as
+  REAL, DIMENSION(klon,nvm)            :: veget
+  REAL, DIMENSION(nvm),SAVE            :: init, decay
+  !$OMP THREADPRIVATE(init, decay)
+
+  DATA init /0.55, 0.14, 0.18, 0.29, 0.15, 0.15, 0.14, 0./
+  DATA decay/0.30, 0.67, 0.63, 0.45, 0.40, 0.14, 0.06, 1./
+!****************************************************************************************
+
+  veget = 0.
+  veget(:,1) = 1.     ! desert partout
+  DO i = 1, knon
+     alb_neig_grid(i) = 0.0
+  ENDDO
+  DO nv = 1, nvm
+     DO i = 1, knon
+        as = init(nv)+decay(nv)*EXP(-agesno(i)/5.)
+        alb_neig_grid(i) = alb_neig_grid(i) + veget(i,nv)*as
+     ENDDO
+  ENDDO
+  
+
+! modilation en fonction de l'age de la neige
+  DO i = 1, knon
+     agesno(i)  = (agesno(i) + (1.-agesno(i)/50.)*dtime/86400.)&
+          &             * EXP(-1.*MAX(0.0,precip_snow(i))*dtime/0.3)
+     agesno(i) =  MAX(agesno(i),0.0)
+  ENDDO
+  
+END SUBROUTINE albsno
Index: LMDZ4/trunk/libf/phylmd/calbeta.F90
===================================================================
--- LMDZ4/trunk/libf/phylmd/calbeta.F90	(revision 782)
+++ LMDZ4/trunk/libf/phylmd/calbeta.F90	(revision 782)
@@ -0,0 +1,103 @@
+!
+! $Header$
+!
+SUBROUTINE calbeta(dtime,indice,knon,snow,qsol, &
+     vbeta,vcal,vdif)
+
+  USE dimphy
+  IMPLICIT none
+!======================================================================
+! Auteur(s): Z.X. Li (LMD/CNRS) (adaptation du GCM au LMD)
+! date: 19940414
+!======================================================================
+!
+! Calculer quelques parametres pour appliquer la couche limite
+! ------------------------------------------------------------
+  INCLUDE "indicesol.inc"
+  
+! Variables d'entrees
+!****************************************************************************************
+  REAL, INTENT(IN)                   :: dtime
+  INTEGER, INTENT(IN)                :: indice
+  INTEGER, INTENT(IN)                :: knon
+  REAL, DIMENSION(klon), INTENT(IN)  :: snow
+  REAL, DIMENSION(klon), INTENT(IN)  :: qsol
+
+  
+! Variables de sorties
+!****************************************************************************************
+  REAL, DIMENSION(klon), INTENT(OUT) :: vbeta
+  REAL, DIMENSION(klon), INTENT(OUT) :: vcal
+  REAL, DIMENSION(klon), INTENT(OUT) :: vdif
+
+! Variables locales
+!****************************************************************************************
+  REAL, PARAMETER :: tau_gl=86400.0*5.0 ! temps de relaxation pour la glace de mer
+!cc      PARAMETER (tau_gl=86400.0*30.0)
+  REAL, PARAMETER :: mx_eau_sol=150.0
+  REAL, PARAMETER :: calsol=1.0/(2.5578E+06*0.15)
+  REAL, PARAMETER :: calsno=1.0/(2.3867E+06*0.15)
+  REAL, PARAMETER :: calice=1.0/(5.1444E+06*0.15)
+  
+  INTEGER         :: i
+
+!****************************************************************************************  
+   
+  vbeta(:) = 0.0
+  vcal(:) = 0.0
+  vdif(:) = 0.0
+  
+  IF (indice.EQ.is_oce) THEN
+     DO i = 1, knon
+        vcal(i)   = 0.0
+        vbeta(i)  = 1.0
+        vdif(i) = 0.0
+     ENDDO
+  ENDIF
+  
+  IF (indice.EQ.is_sic) THEN
+     DO i = 1, knon
+        vcal(i) = calice
+        IF (snow(i) .GT. 0.0) vcal(i) = calsno
+        vbeta(i)  = 1.0
+        vdif(i) = 1.0/tau_gl
+!          vdif(i) = calice/tau_gl ! c'etait une erreur
+     ENDDO
+  ENDIF
+  
+  IF (indice.EQ.is_ter) THEN
+     DO i = 1, knon
+        vcal(i) = calsol
+        IF (snow(i) .GT. 0.0) vcal(i) = calsno
+        vbeta(i)  = MIN(2.0*qsol(i)/mx_eau_sol, 1.0)
+        vdif(i) = 0.0
+     ENDDO
+  ENDIF
+  
+  IF (indice.EQ.is_lic) THEN
+     DO i = 1, knon
+        vcal(i) = calice
+        IF (snow(i) .GT. 0.0) vcal(i) = calsno
+        vbeta(i)  = 1.0
+        vdif(i) = 0.0
+     ENDDO
+  ENDIF
+  
+END SUBROUTINE calbeta
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
Index: LMDZ4/trunk/libf/phylmd/calcul_fluxs_mod.F90
===================================================================
--- LMDZ4/trunk/libf/phylmd/calcul_fluxs_mod.F90	(revision 782)
+++ LMDZ4/trunk/libf/phylmd/calcul_fluxs_mod.F90	(revision 782)
@@ -0,0 +1,246 @@
+!
+! $Header$
+!
+MODULE calcul_fluxs_mod
+
+
+CONTAINS
+  SUBROUTINE calcul_fluxs( knon, nisurf, dtime, &
+       tsurf, p1lay, cal, beta, coef1lay, ps, &
+       precip_rain, precip_snow, snow, qsurf, &
+       radsol, dif_grnd, t1lay, q1lay, u1lay, v1lay, &
+       petAcoef, peqAcoef, petBcoef, peqBcoef, &
+       tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
+    
+    USE dimphy, ONLY : klon
+
+! Cette routine calcule les fluxs en h et q a l'interface et eventuellement
+! une temperature de surface (au cas ou ok_veget = false)
+!
+! L. Fairhead 4/2000
+!
+! input:
+!   knon         nombre de points a traiter
+!   nisurf       surface a traiter
+!   tsurf        temperature de surface
+!   p1lay        pression 1er niveau (milieu de couche)
+!   cal          capacite calorifique du sol
+!   beta         evap reelle
+!   coef1lay     coefficient d'echange
+!   ps           pression au sol
+!   precip_rain  precipitations liquides
+!   precip_snow  precipitations solides
+!   snow         champs hauteur de neige
+!   runoff       runoff en cas de trop plein
+!   petAcoef     coeff. A de la resolution de la CL pour t
+!   peqAcoef     coeff. A de la resolution de la CL pour q
+!   petBcoef     coeff. B de la resolution de la CL pour t
+!   peqBcoef     coeff. B de la resolution de la CL pour q
+!   radsol       rayonnement net aus sol (LW + SW)
+!   dif_grnd     coeff. diffusion vers le sol profond
+!
+! output:
+!   tsurf_new    temperature au sol
+!   qsurf        humidite de l'air au dessus du sol
+!   fluxsens     flux de chaleur sensible
+!   fluxlat      flux de chaleur latente
+!   dflux_s      derivee du flux de chaleur sensible / Ts
+!   dflux_l      derivee du flux de chaleur latente  / Ts
+!
+
+    INCLUDE "YOETHF.inc"
+    INCLUDE "FCTTRE.inc"
+    INCLUDE "indicesol.inc"
+    INCLUDE "YOMCST.inc"
+
+! Parametres d'entree
+!****************************************************************************************
+    INTEGER, INTENT(IN)                  :: knon, nisurf
+    REAL   , INTENT(IN)                  :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)    :: petAcoef, peqAcoef
+    REAL, DIMENSION(klon), INTENT(IN)    :: petBcoef, peqBcoef
+    REAL, DIMENSION(klon), INTENT(IN)    :: ps, q1lay
+    REAL, DIMENSION(klon), INTENT(IN)    :: tsurf, p1lay, cal, beta, coef1lay
+    REAL, DIMENSION(klon), INTENT(IN)    :: precip_rain, precip_snow ! pas utiles
+    REAL, DIMENSION(klon), INTENT(IN)    :: radsol, dif_grnd
+    REAL, DIMENSION(klon), INTENT(IN)    :: t1lay, u1lay, v1lay
+
+! Parametres entree-sorties
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(INOUT) :: snow  ! snow pas utile
+
+! Parametres sorties
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)   :: qsurf
+    REAL, DIMENSION(klon), INTENT(OUT)   :: tsurf_new, evap, fluxsens, fluxlat
+    REAL, DIMENSION(klon), INTENT(OUT)   :: dflux_s, dflux_l
+
+! Variables locales
+!****************************************************************************************
+    INTEGER                              :: i
+    REAL, DIMENSION(klon)                :: zx_mh, zx_nh, zx_oh
+    REAL, DIMENSION(klon)                :: zx_mq, zx_nq, zx_oq
+    REAL, DIMENSION(klon)                :: zx_pkh, zx_dq_s_dt, zx_qsat, zx_coef
+    REAL, DIMENSION(klon)                :: zx_sl, zx_k1
+    REAL, DIMENSION(klon)                :: d_ts
+    REAL                                 :: zdelta, zcvm5, zx_qs, zcor, zx_dq_s_dh
+    REAL                                 :: qsat_new, q1_new
+    REAL, PARAMETER                      :: t_grnd = 271.35, t_coup = 273.15
+    REAL, PARAMETER                      :: max_eau_sol = 150.0
+    CHARACTER (len = 20)                 :: modname = 'calcul_fluxs'
+    LOGICAL                              :: fonte_neige
+    LOGICAL, SAVE                        :: check = .FALSE.
+    !$OMP THREADPRIVATE(check)
+
+! End definition
+!****************************************************************************************
+
+    IF (check) WRITE(*,*)'Entree ', modname,' surface = ',nisurf
+    
+    IF (check) THEN
+       WRITE(*,*)' radsol (min, max)', &
+            MINVAL(radsol(1:knon)), MAXVAL(radsol(1:knon))
+       CALL flush(6)
+    ENDIF
+  
+! Traitement neige et humidite du sol
+!****************************************************************************************
+!
+!!$  WRITE(*,*)'test calcul_flux, surface ', nisurf
+!!PB test
+!!$    if (nisurf == is_oce) then
+!!$      snow = 0.
+!!$      qsol = max_eau_sol
+!!$    else
+!!$      where (precip_snow > 0.) snow = snow + (precip_snow * dtime)
+!!$      where (snow > epsilon(snow)) snow = max(0.0, snow - (evap * dtime))
+!!$!      snow = max(0.0, snow + (precip_snow - evap) * dtime)
+!!$      where (precip_rain > 0.) qsol = qsol + (precip_rain - evap) * dtime
+!!$    endif 
+!!$    IF (nisurf /= is_ter) qsol = max_eau_sol
+
+
+! 
+! Initialisation
+!****************************************************************************************
+    evap = 0.
+    fluxsens=0.
+    fluxlat=0.
+    dflux_s = 0.
+    dflux_l = 0.	
+!
+! zx_qs = qsat en kg/kg
+!****************************************************************************************
+    DO i = 1, knon
+       zx_pkh(i) = (ps(i)/ps(i))**RKAPPA
+       IF (thermcep) THEN
+          zdelta=MAX(0.,SIGN(1.,rtt-tsurf(i)))
+          zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
+          zcvm5 = zcvm5 / RCPD / (1.0+RVTMP2*q1lay(i))
+          zx_qs= r2es * FOEEW(tsurf(i),zdelta)/ps(i)
+          zx_qs=MIN(0.5,zx_qs)
+          zcor=1./(1.-retv*zx_qs)
+          zx_qs=zx_qs*zcor
+          zx_dq_s_dh = FOEDE(tsurf(i),zdelta,zcvm5,zx_qs,zcor) &
+               /RLVTT / zx_pkh(i)
+       ELSE
+          IF (tsurf(i).LT.t_coup) THEN
+             zx_qs = qsats(tsurf(i)) / ps(i)
+             zx_dq_s_dh = dqsats(tsurf(i),zx_qs)/RLVTT &
+                  / zx_pkh(i)
+          ELSE
+             zx_qs = qsatl(tsurf(i)) / ps(i)
+             zx_dq_s_dh = dqsatl(tsurf(i),zx_qs)/RLVTT &
+                  / zx_pkh(i)
+          ENDIF
+       ENDIF
+       zx_dq_s_dt(i) = RCPD * zx_pkh(i) * zx_dq_s_dh
+       zx_qsat(i) = zx_qs
+       zx_coef(i) = coef1lay(i) * &
+            (1.0+SQRT(u1lay(i)**2+v1lay(i)**2)) * &
+            p1lay(i)/(RD*t1lay(i))
+       
+    ENDDO
+
+
+! === Calcul de la temperature de surface ===
+! zx_sl = chaleur latente d'evaporation ou de sublimation
+!****************************************************************************************
+
+    DO i = 1, knon
+       zx_sl(i) = RLVTT
+       IF (tsurf(i) .LT. RTT) zx_sl(i) = RLSTT
+       zx_k1(i) = zx_coef(i)
+    ENDDO
+    
+
+    DO i = 1, knon
+! Q
+       zx_oq(i) = 1. - (beta(i) * zx_k1(i) * peqBcoef(i) * dtime)
+       zx_mq(i) = beta(i) * zx_k1(i) * &
+            (peqAcoef(i) - zx_qsat(i) + &
+            zx_dq_s_dt(i) * tsurf(i)) &
+            / zx_oq(i)
+       zx_nq(i) = beta(i) * zx_k1(i) * (-1. * zx_dq_s_dt(i)) &
+            / zx_oq(i)
+       
+! H
+       zx_oh(i) = 1. - (zx_k1(i) * petBcoef(i) * dtime)
+       zx_mh(i) = zx_k1(i) * petAcoef(i) / zx_oh(i)
+       zx_nh(i) = - (zx_k1(i) * RCPD * zx_pkh(i))/ zx_oh(i)
+     
+! Tsurface
+       tsurf_new(i) = (tsurf(i) + cal(i)/(RCPD * zx_pkh(i)) * dtime * &
+            (radsol(i) + zx_mh(i) + zx_sl(i) * zx_mq(i)) & 
+            + dif_grnd(i) * t_grnd * dtime)/ &
+            ( 1. - dtime * cal(i)/(RCPD * zx_pkh(i)) * ( &
+            zx_nh(i) + zx_sl(i) * zx_nq(i)) &  
+            + dtime * dif_grnd(i))
+
+!
+! Y'a-t-il fonte de neige?
+!
+!    fonte_neige = (nisurf /= is_oce) .AND. &
+!     & (snow(i) > epsfra .OR. nisurf == is_sic .OR. nisurf == is_lic) &
+!     & .AND. (tsurf_new(i) >= RTT)
+!    if (fonte_neige) tsurf_new(i) = RTT  
+       d_ts(i) = tsurf_new(i) - tsurf(i)
+!    zx_h_ts(i) = tsurf_new(i) * RCPD * zx_pkh(i)
+!    zx_q_0(i) = zx_qsat(i) + zx_dq_s_dt(i) * d_ts(i)
+
+!== flux_q est le flux de vapeur d'eau: kg/(m**2 s)  positive vers bas
+!== flux_t est le flux de cpt (energie sensible): j/(m**2 s)
+       evap(i) = - zx_mq(i) - zx_nq(i) * tsurf_new(i) 
+       fluxlat(i) = - evap(i) * zx_sl(i)
+       fluxsens(i) = zx_mh(i) + zx_nh(i) * tsurf_new(i)
+       
+! Derives des flux dF/dTs (W m-2 K-1):
+       dflux_s(i) = zx_nh(i)
+       dflux_l(i) = (zx_sl(i) * zx_nq(i))
+
+! Nouvelle valeure de l'humidite au dessus du sol
+       qsat_new=zx_qsat(i) + zx_dq_s_dt(i) * d_ts(i)
+       q1_new = peqAcoef(i) - peqBcoef(i)*evap(i)*dtime
+       qsurf(i)=q1_new*(1.-beta(i)) + beta(i)*qsat_new
+!
+! en cas de fonte de neige
+!
+!    if (fonte_neige) then
+!      bilan_f = radsol(i) + fluxsens(i) - (zx_sl(i) * evap (i)) - &
+!     &          dif_grnd(i) * (tsurf_new(i) - t_grnd) - &
+!     &          RCPD * (zx_pkh(i))/cal(i)/dtime * (tsurf_new(i) - tsurf(i))
+!      bilan_f = max(0., bilan_f)
+!      fq_fonte = bilan_f / zx_sl(i)
+!      snow(i) = max(0., snow(i) - fq_fonte * dtime)
+!      qsol(i) = qsol(i) + (fq_fonte * dtime)
+!    endif
+!!$    if (nisurf == is_ter)  &
+!!$     &  run_off(i) = run_off(i) + max(qsol(i) - max_eau_sol, 0.0)
+!!$    qsol(i) = min(qsol(i), max_eau_sol) 
+    ENDDO
+!
+!****************************************************************************************
+!
+  END SUBROUTINE calcul_fluxs
+
+END MODULE calcul_fluxs_mod
Index: LMDZ4/trunk/libf/phylmd/clim.h
===================================================================
--- LMDZ4/trunk/libf/phylmd/clim.h	(revision 781)
+++ 	(revision )
@@ -1,112 +1,0 @@
-!
-! $Header$
-!
-C
-C     - - - - - - - - - - - - - - - - - - - - - - - - -
-C
-C*    =clim.h=  CLIM 1.1 include file 
-C	        Coupling Library for Interfacing Models
-C
-C     - - - - - - - - - - - - - - - - - - - - - - - - -
-C
-      INTEGER*4 CLIM_Void
-C
-      INTEGER*4	CLIM_MaxMod,
-     *          CLIM_MaxPort,   
-     *          CLIM_MaxSegments,
-     *          CLIM_MaxTag,
-     *          CLIM_MaxLink,
-     *          CLIM_ParSize,
-     *          CLIM_Clength
-C
-      INTEGER*4 CLIM_In,        CLIM_Out,       CLIM_InOut
-C
-      INTEGER*4 CLIM_Strategy,  CLIM_Serial,
-     *          CLIM_Apple,     CLIM_Orange,    CLIM_Box,
-     *          CLIM_Segments,  CLIM_Length,    CLIM_Offset,
-     *          CLIM_SizeX,     CLIM_SizeY,     CLIM_LdX
-C
-      INTEGER*4 CLIM_Integer,   CLIM_Real,      CLIM_Double
-C
-      INTEGER*4 CLIM_StopPvm,   CLIM_ContPvm
-C
-      INTEGER*4	CLIM_MaxCodes,  CLIM_Ok,
-     *          CLIM_FastExit,  CLIM_BadName,   CLIM_BadPort,
-     *          CLIM_BadType,   CLIM_DoubleDef, CLIM_NotStep,
-     *          CLIM_IncStep,   CLIM_IncSize,   CLIM_NotClim,
-     *          CLIM_TimeOut,
-     *          CLIM_Pvm,       CLIM_FirstCall, CLIM_PbRoute,
-     *          CLIM_Group,     CLIM_BadTaskId, CLIM_NoTask,
-     *          CLIM_InitBuff,  CLIM_Pack,      CLIM_Unpack,
-     *          CLIM_Down,      CLIM_PvmExit
-C
-C-----Parameter sizes
-C
-      PARAMETER ( CLIM_Void    = 0  )
-      PARAMETER ( CLIM_MaxMod  = 8 )
-      PARAMETER ( CLIM_MaxPort = 40 )
-      PARAMETER ( CLIM_MaxSegments = 160 )
-      PARAMETER ( CLIM_MaxLink = CLIM_MaxMod * CLIM_MaxPort )
-      PARAMETER ( CLIM_ParSize = 2 * CLIM_MaxSegments + 2 )
-      PARAMETER ( CLIM_MaxTag  = 16777215 )
-      PARAMETER ( CLIM_Clength = 32 )
-C
-C-----Ports status
-C
-      PARAMETER ( CLIM_In      = 1 )
-      PARAMETER ( CLIM_Out     = 0 )
-      PARAMETER ( CLIM_InOut   = 2 )
-C
-C-----Parallel distribution
-C
-      PARAMETER ( CLIM_Strategy = 1 )
-      PARAMETER ( CLIM_Segments = 2 )
-      PARAMETER ( CLIM_Serial   = 0 )
-      PARAMETER ( CLIM_Apple    = 1 )
-      PARAMETER ( CLIM_Box      = 2 )
-      PARAMETER ( CLIM_Orange   = 3 )
-      PARAMETER ( CLIM_Offset   = 2 )
-      PARAMETER ( CLIM_Length   = 3 )
-      PARAMETER ( CLIM_SizeX    = 3 )
-      PARAMETER ( CLIM_SizeY    = 4 )
-      PARAMETER ( CLIM_LdX      = 5 )
-C
-C-----Datatypes
-C
-      PARAMETER ( CLIM_Integer = 1 )
-      PARAMETER ( CLIM_Real    = 4 ) 
-      PARAMETER ( CLIM_Double  = 8 )
-C
-C-----Quit parameters
-C
-      PARAMETER ( CLIM_ContPvm = 0 )
-      PARAMETER ( CLIM_StopPvm = 1 )
-C
-C-----Error Codes
-C
-      PARAMETER ( CLIM_MaxCodes  = -21 )
-C
-      PARAMETER ( CLIM_Ok        = 0 )
-      PARAMETER ( CLIM_FastExit  = -1 )
-      PARAMETER ( CLIM_BadName   = -2 )
-      PARAMETER ( CLIM_BadPort   = -3 )
-      PARAMETER ( CLIM_BadType   = -4 )
-      PARAMETER ( CLIM_DoubleDef = -5 )
-      PARAMETER ( CLIM_NotStep   = -6 )
-      PARAMETER ( CLIM_IncStep   = -7 )
-      PARAMETER ( CLIM_IncSize   = -8 )
-      PARAMETER ( CLIM_NotClim   = -9 )
-      PARAMETER ( CLIM_TimeOut   = -10 )
-      PARAMETER ( CLIM_Pvm       = -11 )
-      PARAMETER ( CLIM_FirstCall = -12 )
-      PARAMETER ( CLIM_PbRoute   = -13 )
-      PARAMETER ( CLIM_Group     = -14 )
-      PARAMETER ( CLIM_BadTaskId = -15 )
-      PARAMETER ( CLIM_NoTask    = -16 )
-      PARAMETER ( CLIM_InitBuff  = -17 )
-      PARAMETER ( CLIM_Pack      = -18 )
-      PARAMETER ( CLIM_Unpack    = -19 )
-      PARAMETER ( CLIM_Down      = -20 )
-      PARAMETER ( CLIM_PvmExit   = -21 )
-C
-C-----End of clim.h
Index: LMDZ4/trunk/libf/phylmd/climb_hq_mod.F90
===================================================================
--- LMDZ4/trunk/libf/phylmd/climb_hq_mod.F90	(revision 782)
+++ LMDZ4/trunk/libf/phylmd/climb_hq_mod.F90	(revision 782)
@@ -0,0 +1,366 @@
+MODULE climb_hq_mod
+!
+! Module to solve the verctical diffusion of "q" and "H"; 
+! specific humidity and potential energi.
+!
+  USE dimphy
+
+  IMPLICIT NONE
+  SAVE 
+  PRIVATE
+  PUBLIC :: climb_hq_down, climb_hq_up
+
+  REAL, DIMENSION(:,:), ALLOCATABLE :: gamaq, gamah
+  !$OMP THREADPRIVATE(gamaq,gamah)
+  REAL, DIMENSION(:,:), ALLOCATABLE :: Ccoef_Q, Dcoef_Q
+  !$OMP THREADPRIVATE(Ccoef_Q, Dcoef_Q)
+  REAL, DIMENSION(:,:), ALLOCATABLE :: Ccoef_H, Dcoef_H
+  !$OMP THREADPRIVATE(Ccoef_H, Dcoef_H)
+  REAL, DIMENSION(:,:), ALLOCATABLE :: Kcoefhq
+  !$OMP THREADPRIVATE(Kcoefhq)
+
+CONTAINS
+!
+!****************************************************************************************
+!
+  SUBROUTINE climb_hq_down(knon, coefhq, paprs, pplay, &
+       delp, temp, q, dtime, &
+       petAcoef, peqAcoef, petBcoef, peqBcoef)
+
+    INCLUDE "YOMCST.inc"
+! This routine calculates recursivly the coefficients C and D
+! for the quantity X=[Q,H] in equation X(k) = C(k) + D(k)*X(k-1), where k is
+! the index of the vertical layer.
+!
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: knon
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: coefhq
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: pplay 
+    REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs 
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: temp, delp  ! temperature
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: q
+    REAL, INTENT(IN)                         :: dtime
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)       :: petAcoef
+    REAL, DIMENSION(klon), INTENT(OUT)       :: peqAcoef
+    REAL, DIMENSION(klon), INTENT(OUT)       :: petBcoef
+    REAL, DIMENSION(klon), INTENT(OUT)       :: peqBcoef
+
+! Local variables
+!****************************************************************************************
+    REAL, DIMENSION(klon,klev)               :: dels, local_H
+    REAL, DIMENSION(klon)                    :: psref, delz, pkh
+    INTEGER                                  :: k, i, ierr
+
+! Include
+!****************************************************************************************
+  INCLUDE "compbl.h"    
+
+
+!****************************************************************************************
+! 1)
+! Allocation
+!   
+!****************************************************************************************
+
+    ALLOCATE(Ccoef_Q(klon,klev), STAT=ierr)
+    IF ( ierr /= 0 )  PRINT*,' pb in allloc Ccoef_Q, ierr=', ierr
+    
+    ALLOCATE(Dcoef_Q(klon,klev), STAT=ierr)
+    IF ( ierr /= 0 )  PRINT*,' pb in allloc Dcoef_Q, ierr=', ierr
+    
+    ALLOCATE(Ccoef_H(klon,klev), STAT=ierr)
+    IF ( ierr /= 0 )  PRINT*,' pb in allloc Ccoef_H, ierr=', ierr
+    
+    ALLOCATE(Dcoef_H(klon,klev), STAT=ierr)
+    IF ( ierr /= 0 )  PRINT*,' pb in allloc Dcoef_H, ierr=', ierr
+    
+    ALLOCATE(Kcoefhq(klon,klev), STAT=ierr)
+    IF ( ierr /= 0 )  PRINT*,' pb in allloc Kcoefhq, ierr=', ierr
+    
+    ALLOCATE(gamaq(1:klon,2:klev), STAT=ierr)
+    IF ( ierr /= 0 ) PRINT*,' pb in allloc gamaq, ierr=', ierr
+    
+    ALLOCATE(gamah(1:klon,2:klev), STAT=ierr)
+    IF ( ierr /= 0 ) PRINT*,' pb in allloc gamah, ierr=', ierr
+       
+
+!****************************************************************************************
+! 2)
+! Definition of the coeficient K 
+!
+!****************************************************************************************
+    Kcoefhq(:,:) = 0.0
+    DO k = 2, klev
+       DO i = 1, knon
+          Kcoefhq(i,k) = &
+               coefhq(i,k)*RG /(pplay(i,k-1)-pplay(i,k)) &
+               *(paprs(i,k)*2/(temp(i,k)+temp(i,k-1))/RD)**2
+          Kcoefhq(i,k) = Kcoefhq(i,k) * dtime*RG
+       ENDDO
+    ENDDO
+
+!****************************************************************************************
+! 3)
+! Calculation of gama for "Q" and "H"
+!
+!****************************************************************************************
+!   surface pressure is used as reference
+    psref(:) = paprs(:,1) 
+
+!   definition of start value for gama
+    IF (iflag_pbl == 1) THEN
+       gamaq(:,:) = 0.0
+       gamah(:,:) = -1.0e-03
+       gamah(:,2) = -2.5e-03
+    ELSE
+       gamaq(:,:) = 0.0
+       gamah(:,:) = 0.0
+    ENDIF
+    
+!   calculation of gama
+    DO k = 2, klev
+       DO i = 1, knon
+          delz(i)  = RD * (temp(i,k-1)+temp(i,k)) / & 
+               2.0 / RG / paprs(i,k) * (pplay(i,k-1)-pplay(i,k))
+          pkh(i) = (psref(i)/paprs(i,k))**RKAPPA
+          
+          gamaq(i,k) = gamaq(i,k) * delz(i)    
+          gamah(i,k) = gamah(i,k) * delz(i) * RCPD * pkh(i)
+       ENDDO
+    ENDDO
+
+!****************************************************************************************    
+! 4)
+! Calculte the coefficients C and D for specific humidity, q
+!
+!****************************************************************************************
+    dels(:,:) = delp(:,:)
+    
+    CALL calc_coef(knon, Kcoefhq(:,:), gamaq(:,:), dels(:,:), q(:,:), &
+         Ccoef_Q(:,:), Dcoef_Q(:,:))
+
+!****************************************************************************************
+! 5)
+! Calculte the coefficients C and D for potentiel entalpie, H 
+!
+!****************************************************************************************
+    dels(:,:)    = 0.0
+    local_H(:,:) = 0.0
+
+    DO k=1,klev
+       DO i = 1, knon
+          dels(i,k) = (pplay(i,k)/psref(i))**RKAPPA * delp(i,k)               
+          local_H(i,k) = RCPD * temp(i,k) * &
+               (psref(i)/pplay(i,k))**RKAPPA
+       ENDDO
+    ENDDO
+
+
+    CALL calc_coef(knon, Kcoefhq(:,:), gamah(:,:), dels(:,:), local_H(:,:), &
+         Ccoef_H(:,:), Dcoef_H(:,:))
+ 
+!****************************************************************************************
+! 6)
+! Return the first layer in output variables
+!
+!****************************************************************************************
+    petAcoef(1:knon) = Ccoef_H(1:knon,1)
+    peqAcoef(1:knon) = Ccoef_Q(1:knon,1)
+    petBcoef(1:knon) = Dcoef_H(1:knon,1)
+    peqBcoef(1:knon) = Dcoef_Q(1:knon,1)
+
+  END SUBROUTINE climb_hq_down
+!
+!****************************************************************************************
+!
+  SUBROUTINE calc_coef(knon, Kcoef, gama, dels, X, Ccoef, Dcoef)
+!
+! Calculate the coefficients C and D in : X(k) = C(k) + D(k)*X(k-1)
+! where X is H or Q, and k the vertical level k=1,klev
+!
+    INCLUDE "YOMCST.inc"
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: knon
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: Kcoef, dels
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: X
+    REAL, DIMENSION(klon,2:klev), INTENT(IN) :: gama
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: Ccoef
+    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: Dcoef
+
+! Local variables
+!****************************************************************************************
+    INTEGER                                  :: k, i
+    REAL                                     :: buf
+
+!****************************************************************************************
+! Niveau au sommet, k=klev
+!
+!****************************************************************************************
+    Ccoef(:,:) = 0.0
+    Dcoef(:,:) = 0.0
+
+    DO i = 1, knon
+       buf = dels(i,klev) + Kcoef(i,klev)
+       
+       Ccoef(i,klev) = (X(i,klev)*dels(i,klev) - Kcoef(i,klev)*gama(i,klev))/buf
+       Dcoef(i,klev) = Kcoef(i,klev)/buf
+    END DO
+
+
+!****************************************************************************************
+! Niveau  (klev-1) <= k <= 2
+!
+!****************************************************************************************
+
+    DO k=(klev-1),2,-1
+       DO i = 1, knon
+          buf = dels(i,k) + Kcoef(i,k) + Kcoef(i,k+1)*(1.-Dcoef(i,k+1))
+          Ccoef(i,k) = (X(i,k)*dels(i,k) + Kcoef(i,k+1)*Ccoef(i,k+1) + &
+               Kcoef(i,k+1)*gama(i,k+1) - Kcoef(i,k)*gama(i,k))/buf
+          Dcoef(i,k) = Kcoef(i,k)/buf
+       END DO
+    END DO
+
+!****************************************************************************************
+! Niveau k=1
+!
+!****************************************************************************************
+
+    DO i = 1, knon
+       buf = dels(i,1) + Kcoef(i,2)*(1.-Dcoef(i,2))
+       Ccoef(i,1) = (X(i,1)*dels(i,1) + Kcoef(i,2)*(gama(i,2)+Ccoef(i,2)))/buf
+       Dcoef(i,1) = -1. * RG / buf
+    END DO
+
+  END SUBROUTINE calc_coef
+!
+!****************************************************************************************
+!
+  SUBROUTINE climb_hq_up(knon, dtime, t_old, q_old, &
+       flx_q1, flx_t1, paprs, pplay, &
+       flux_q, flux_h, d_q, d_t)
+! 
+! This routine calculates the flux and tendency of the specific humidity q and 
+! the potential engergi H. 
+! The quantities q and H are calculated according to 
+! X(k) = C(k) + D(k)*X(k-1) for X=[q,H], where the coefficients 
+! C and D are known from before and k is index of the vertical layer.
+!   
+    INCLUDE "YOMCST.inc"
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: knon
+    REAL, INTENT(IN)                         :: dtime
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: t_old, q_old
+    REAL, DIMENSION(klon), INTENT(IN)        :: flx_q1, flx_t1
+    REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: pplay
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: flux_q, flux_h, d_q, d_t
+
+! Local variables
+!****************************************************************************************
+    REAL, DIMENSION(klon,klev)               :: zx_pkh, zx_pkf
+    REAL, DIMENSION(klon,klev)               :: h_new, q_new
+    REAL, DIMENSION(klon)                    :: psref         
+    INTEGER                                  :: k, i
+
+!****************************************************************************************
+! 1) 
+! Definition of some variables
+!
+!****************************************************************************************
+    flux_q(:,:) = 0.0
+    flux_h(:,:) = 0.0
+    d_q(:,:)    = 0.0
+    d_t(:,:)    = 0.0
+
+    psref(1:knon) = paprs(1:knon,1)  
+
+    DO k = 1, klev
+       DO i = 1, knon
+          zx_pkh(i,k) = (psref(i)/paprs(i,k))**RKAPPA
+          zx_pkf(i,k) = (psref(i)/pplay(i,k))**RKAPPA
+       END DO
+    END DO
+!****************************************************************************************
+! 2)
+! Calculation of Q and H
+!
+!****************************************************************************************
+
+!- First layer
+    q_new(1:knon,1) = Ccoef_Q(1:knon,1) + Dcoef_Q(1:knon,1)*flx_q1(1:knon)*dtime
+    h_new(1:knon,1) = Ccoef_H(1:knon,1) + Dcoef_H(1:knon,1)*flx_t1(1:knon)*dtime
+    
+!- All the rest layers 
+    DO k = 2, klev
+       DO i = 1, knon
+          q_new(i,k) = Ccoef_Q(i,k) + Dcoef_Q(i,k)*q_new(i,k-1)
+          h_new(i,k) = Ccoef_H(i,k) + Dcoef_H(i,k)*h_new(i,k-1)
+       END DO
+    END DO
+!****************************************************************************************
+! 3)
+! Calculation of the flux for Q and H
+!
+!****************************************************************************************
+
+!- The flux at first layer, k=1
+    flux_q(1:knon,1)=flx_q1(1:knon)
+    flux_h(1:knon,1)=flx_t1(1:knon)
+
+!- The flux at all layers above surface
+    DO k = 2, klev
+       DO i = 1, knon
+          flux_q(i,k) = (Kcoefhq(i,k)/RG/dtime) * &
+               (q_new(i,k)-q_new(i,k-1)+gamaq(i,k))
+
+          flux_h(i,k) = (Kcoefhq(i,k)/RG/dtime) * &
+               (h_new(i,k)-h_new(i,k-1)+gamah(i,k)) / &
+               zx_pkh(i,k)
+       END DO
+    END DO
+
+!****************************************************************************************
+! 4)
+! Calculation of tendency for Q and H
+!
+!****************************************************************************************
+
+    DO k = 1, klev
+       DO i = 1, knon
+          d_t(i,k) = h_new(i,k)/zx_pkf(i,k)/RCPD - t_old(i,k)
+          d_q(i,k) = q_new(i,k) - q_old(i,k)
+       END DO
+    END DO
+
+!****************************************************************************************
+! Some deallocations
+!
+!****************************************************************************************
+    DEALLOCATE(Ccoef_Q, Dcoef_Q, Ccoef_H, Dcoef_H)    
+    DEALLOCATE(gamaq, gamah)
+    DEALLOCATE(Kcoefhq)
+
+    
+  END SUBROUTINE climb_hq_up
+!
+!****************************************************************************************
+!
+END MODULE climb_hq_mod
+
+
+
+
+
Index: LMDZ4/trunk/libf/phylmd/climb_wind_mod.F90
===================================================================
--- LMDZ4/trunk/libf/phylmd/climb_wind_mod.F90	(revision 782)
+++ LMDZ4/trunk/libf/phylmd/climb_wind_mod.F90	(revision 782)
@@ -0,0 +1,367 @@
+!
+! $Header$
+!
+MODULE climb_wind_mod
+!
+! Module to solve the verctical diffusion of the wind components "u" and "v".
+!
+  USE dimphy
+
+  IMPLICIT NONE
+
+  SAVE
+  PRIVATE
+  
+  REAL, DIMENSION(:),   ALLOCATABLE  :: alf1, alf2
+  !$OMP THREADPRIVATE(alf1,alf2)
+  REAL, DIMENSION(:,:), ALLOCATABLE  :: Kcoefm
+  !$OMP THREADPRIVATE(Kcoefm)
+  REAL, DIMENSION(:,:), ALLOCATABLE  :: Ccoef_U, Dcoef_U
+  !$OMP THREADPRIVATE(Ccoef_U, Dcoef_U)
+  REAL, DIMENSION(:,:), ALLOCATABLE  :: Ccoef_V, Dcoef_V
+  !$OMP THREADPRIVATE(Ccoef_V, Dcoef_V)
+  LOGICAL                            :: firstcall=.TRUE.
+  !$OMP THREADPRIVATE(firstcall)
+
+  
+  PUBLIC :: climb_wind_down, calcul_wind_flux, climb_wind_up
+
+CONTAINS
+!
+!****************************************************************************************
+!
+  SUBROUTINE climb_wind_init
+
+    INTEGER             :: ierr
+    CHARACTER(len = 20) :: modname = 'climb_wind_init'    
+
+!****************************************************************************************
+! Allocation of global module variables
+!
+!****************************************************************************************
+
+    ALLOCATE(alf1(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm(modname,'Pb in allocate alf2',1)
+
+    ALLOCATE(alf2(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm(modname,'Pb in allocate alf2',1)
+
+    ALLOCATE(Kcoefm(klon,klev), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm(modname,'Pb in allocate Kcoefm',1)
+
+    ALLOCATE(Ccoef_U(klon,klev), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm(modname,'Pb in allocate Ccoef_U',1)
+
+    ALLOCATE(Dcoef_U(klon,klev), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm(modname,'Pb in allocation Dcoef_U',1)
+
+    ALLOCATE(Ccoef_V(klon,klev), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm(modname,'Pb in allocation Ccoef_V',1)
+
+    ALLOCATE(Dcoef_V(klon,klev), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm(modname,'Pb in allocation Dcoef_V',1)
+
+    firstcall=.FALSE.
+
+  END SUBROUTINE climb_wind_init
+!
+!****************************************************************************************
+!
+  SUBROUTINE climb_wind_down(knon, dtime, coef_in, pplay, paprs, temp, delp, u_old, v_old)
+!
+! This routine calculates for the wind components u and v,
+! recursivly the coefficients C and D in equation 
+! X(k) = C(k) + D(k)*X(k-1), X=[u,v], k=[1,klev] is the vertical layer.
+!
+!
+    INCLUDE "YOMCST.inc"
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: knon
+    REAL, INTENT(IN)                         :: dtime
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: coef_in
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: pplay ! pres au milieu de couche (Pa)
+    REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs ! pression a inter-couche (Pa)
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: temp  ! temperature
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: delp
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: u_old
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: v_old
+
+! Local variables
+!****************************************************************************************
+    REAL, DIMENSION(klon)                    :: u1lay, v1lay
+    INTEGER                                  :: k, i
+
+
+!****************************************************************************************
+! Initialize module
+    IF (firstcall) CALL climb_wind_init
+
+!****************************************************************************************
+! Calculate the coefficients C and D in : u(k) = C(k) + D(k)*u(k-1)
+!
+!****************************************************************************************
+
+! - Define alpha (alf1 and alf2) 
+    alf1(:) = 1.0
+    alf2(:) = 1.0 - alf1(:)
+
+! - Calculte the wind components for the first layer
+    u1lay(1:knon) = u_old(1:knon,1)*alf1(1:knon) + u_old(1:knon,2)*alf2(1:knon)
+    v1lay(1:knon) = v_old(1:knon,1)*alf1(1:knon) + v_old(1:knon,2)*alf2(1:knon)    
+
+! - Calculate K
+    Kcoefm(:,:) = 0.0
+    DO i = 1, knon
+       Kcoefm(i,1) = coef_in(i,1) * (1.0+SQRT(u1lay(i)**2+v1lay(i)**2))* &
+            pplay(i,1)/(RD*temp(i,1)) 
+       Kcoefm(i,1) = Kcoefm(i,1) * dtime*RG
+    END DO
+
+    DO k = 2, klev
+       DO i=1,knon
+          Kcoefm(i,k) = coef_in(i,k)*RG/(pplay(i,k-1)-pplay(i,k)) &
+               *(paprs(i,k)*2/(temp(i,k)+temp(i,k-1))/RD)**2
+          Kcoefm(i,k) = Kcoefm(i,k) * dtime*RG
+       END DO
+    END DO
+
+! - Calculate the coefficients C and D, component "u"
+    CALL calc_coef(knon, Kcoefm(:,:), delp(:,:), &
+         u_old(:,:), alf1(:), alf2(:),  &
+         Ccoef_U(:,:), Dcoef_U(:,:))
+
+! - Calculate the coefficients C and D, component "v"
+    CALL calc_coef(knon, Kcoefm(:,:), delp(:,:), &
+         v_old(:,:), alf1(:), alf2(:),  &
+         Ccoef_V(:,:), Dcoef_V(:,:))
+
+  END SUBROUTINE climb_wind_down
+!
+!****************************************************************************************
+!
+  SUBROUTINE calc_coef(knon, Kcoef, dels, X, alfa1, alfa2, Ccoef, Dcoef)
+!
+! Find the coefficients C and D in fonction of alfa, K and dels
+!
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: knon
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: Kcoef, dels
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: X
+    REAL, DIMENSION(klon), INTENT(IN)        :: alfa1, alfa2
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: Ccoef, Dcoef
+  
+! local variables
+!****************************************************************************************
+    INTEGER                                  :: k, i
+    REAL                                     :: buf
+
+!****************************************************************************************
+! 
+! Niveau au sommet, k=klev
+!
+    Ccoef(:,:) = 0.0
+    Dcoef(:,:) = 0.0
+
+    DO i = 1, knon
+       buf = dels(i,klev) + Kcoef(i,klev)
+
+       Ccoef(i,klev) = X(i,klev)*dels(i,klev)/buf 
+       Dcoef(i,klev) = Kcoef(i,klev)/buf
+    END DO
+    
+! 
+! Niveau  (klev-1) <= k <= 2
+!
+    DO k=(klev-1),2,-1
+       DO i = 1, knon
+          buf = dels(i,k) + Kcoef(i,k) + &
+               Kcoef(i,k+1)*(1.-Dcoef(i,k+1))
+          
+          Ccoef(i,k) = X(i,k)*dels(i,k) + &
+               Kcoef(i,k+1)*Ccoef(i,k+1)
+          Ccoef(i,k) = Ccoef(i,k)/buf         
+          Dcoef(i,k) = Kcoef(i,k)/buf
+       END DO
+    END DO
+
+! 
+! Niveau k=1
+!
+    DO i = 1, knon
+       buf = dels(i,1) + &
+            (alfa1(i) + alfa2(i)*Dcoef(i,2)) * Kcoef(i,1) + &
+            (1.-Dcoef(i,2))*Kcoef(i,2)
+       
+       Ccoef(i,1) = X(i,1)*dels(i,1) + &
+            (Kcoef(i,2)-Kcoef(i,1)*alfa2(i)) * Ccoef(i,2)
+       Ccoef(i,1) = Ccoef(i,1)/buf
+       Dcoef(i,1) = Kcoef(i,1)/buf
+    END DO
+
+  END SUBROUTINE calc_coef
+!
+!****************************************************************************************
+!
+  SUBROUTINE calcul_wind_flux(knon, dtime, &
+       flux_u, flux_v)
+
+    INCLUDE "YOMCST.inc"
+
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                  :: knon
+    REAL, INTENT(IN)                     :: dtime
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)   :: flux_u
+    REAL, DIMENSION(klon), INTENT(OUT)   :: flux_v
+
+! Local variables
+!****************************************************************************************
+    INTEGER                              :: i
+    REAL, DIMENSION(klon)                :: u0, v0  ! u and v at niveau 0
+    REAL, DIMENSION(klon)                :: u1, v1  ! u and v at niveau 1
+    REAL, DIMENSION(klon)                :: u2, v2  ! u and v at niveau 2
+    
+
+!****************************************************************************************
+! Les vents de surface sont supposes nuls
+!
+!****************************************************************************************
+    u0(:) = 0.0
+    v0(:) = 0.0
+
+!****************************************************************************************
+! On calcule les vents du couhes 1 et 2 recurviement
+!
+!****************************************************************************************
+    DO i = 1, knon
+       u1(i) = Ccoef_U(i,1) + Dcoef_U(i,1)*u0(i)
+       v1(i) = Ccoef_V(i,1) + Dcoef_V(i,1)*v0(i)
+       u2(i) = Ccoef_U(i,2) + Dcoef_U(i,2)*u1(i)
+       v2(i) = Ccoef_V(i,2) + Dcoef_V(i,2)*v1(i)
+    END DO
+
+!****************************************************************************************
+! On calcule le flux
+!
+!****************************************************************************************
+    flux_u(:) = 0.0
+    flux_v(:) = 0.0
+
+    DO i=1,knon
+       flux_u(i) = Kcoefm(i,1)/RG/dtime * (u1(i)*alf1(i) + u2(i)*alf2(i) - u0(i)) 
+       flux_v(i) = Kcoefm(i,1)/RG/dtime * (v1(i)*alf1(i) + v2(i)*alf2(i) - v0(i)) 
+    END DO
+
+  END SUBROUTINE calcul_wind_flux
+!
+!****************************************************************************************
+!
+  SUBROUTINE climb_wind_up(knon, dtime, u_old, v_old, &
+       flx_u_new, flx_v_new, d_u_new, d_v_new)
+!
+! Diffuse the wind components from the surface and up to the top layer. Coefficents
+! C and D are known from before. The values for U and V at surface are supposed to be 
+! zero (this could be modified).
+!
+! u(k) = Cu(k) + Du(k)*u(k-1)
+! v(k) = Cv(k) + Dv(k)*v(k-1)
+! [1 <= k <= klev]
+!
+!****************************************************************************************
+    INCLUDE "YOMCST.inc"
+
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                     :: knon
+    REAL, INTENT(IN)                        :: dtime
+    REAL, DIMENSION(klon,klev), INTENT(IN)  :: u_old
+    REAL, DIMENSION(klon,klev), INTENT(IN)  :: v_old
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon,klev), INTENT(OUT) :: flx_u_new, flx_v_new
+    REAL, DIMENSION(klon,klev), INTENT(OUT) :: d_u_new, d_v_new
+
+! Local variables
+!****************************************************************************************
+    REAL, DIMENSION(klon,klev)              :: u_new, v_new
+    REAL, DIMENSION(klon)                   :: u0, v0
+    INTEGER                                 :: k, i
+    
+!
+!****************************************************************************************
+
+! Niveau 0
+    u0(1:knon) = 0.0
+    v0(1:knon) = 0.0
+
+! Niveau 1
+    DO i = 1, knon
+       u_new(i,1) = Ccoef_U(i,1) + Dcoef_U(i,1) * u0(i)
+       v_new(i,1) = Ccoef_V(i,1) + Dcoef_V(i,1) * v0(i)
+    END DO
+
+! Niveau 2 jusqu'au sommet klev
+    DO k = 2, klev
+       DO i=1, knon
+          u_new(i,k) = Ccoef_U(i,k) + Dcoef_U(i,k) * u_new(i,k-1)
+          v_new(i,k) = Ccoef_V(i,k) + Dcoef_V(i,k) * v_new(i,k-1)
+       END DO
+    END DO
+
+!****************************************************************************************
+! Calcul flux
+!
+!== flux_u/v est le flux de moment angulaire (positif vers bas)
+!== dont l'unite est: (kg m/s)/(m**2 s) 
+!
+!****************************************************************************************
+!
+    flx_u_new(:,:) = 0.0
+    flx_v_new(:,:) = 0.0
+
+! Niveau 1
+    DO i = 1, knon
+       flx_u_new(i,1) = Kcoefm(i,1)/RG/dtime * &
+            (u_new(i,1)*alf1(i)+u_new(i,2)*alf2(i) - u0(i)) 
+       flx_v_new(i,1) = Kcoefm(i,1)/RG/dtime * &
+            (v_new(i,1)*alf1(i)+v_new(i,2)*alf2(i) - v0(i)) 
+    END DO
+
+! Niveau 2->klev
+    DO k = 2, klev
+       DO i = 1, knon
+          flx_u_new(i,k) = Kcoefm(i,k)/RG/dtime * &
+               (u_new(i,k)-u_new(i,k-1))
+          
+          flx_v_new(i,k) = Kcoefm(i,k)/RG/dtime * &
+               (v_new(i,k)-v_new(i,k-1))
+       END DO
+    END DO
+
+!****************************************************************************************
+! Calcul tendances
+!
+!****************************************************************************************
+    d_u_new(:,:) = 0.0
+    d_v_new(:,:) = 0.0
+    DO k = 1, klev
+       DO i = 1, knon
+          d_u_new(i,k) = u_new(i,k) - u_old(i,k)
+          d_v_new(i,k) = v_new(i,k) - v_old(i,k)
+       END DO
+    END DO
+
+  END SUBROUTINE climb_wind_up
+!
+!****************************************************************************************
+!
+END MODULE climb_wind_mod
Index: LMDZ4/trunk/libf/phylmd/clmain.F
===================================================================
--- LMDZ4/trunk/libf/phylmd/clmain.F	(revision 781)
+++ 	(revision )
@@ -1,2449 +1,0 @@
-!
-! $Header$
-!
-c
-c
-#define IO_DISCONNECTED
-
-      SUBROUTINE clmain(dtime,itap,date0,pctsrf,pctsrf_new,
-     .                  t,q,u,v,
-     .                  jour, rmu0, co2_ppm,
-     .                  ok_veget, ocean, npas, nexca, ts,
-     .                  soil_model,cdmmax, cdhmax,
-     .                  ksta, ksta_ter, ok_kzmin, ftsoil,qsol,
-cIM BAD .                  paprs,pplay,radsol,snow,qsurf,evap,albe,alblw,
-     .                  paprs,pplay,snow,qsurf,evap,albe,alblw,
-     .                  fluxlat,
-     .                  rain_f, snow_f, solsw, sollw, sollwdown, fder,
-     .                  rlon, rlat, cufi, cvfi, rugos,
-     .                  debut, lafin, agesno,rugoro,
-     .                  d_t,d_q,d_u,d_v,d_ts,
-     .                  flux_t,flux_q,flux_u,flux_v,cdragh,cdragm,
-     .                  q2,
-     .                  dflux_t,dflux_q,
-     .                  zcoefh,zu1,zv1, t2m, q2m, u10m, v10m,
-cIM cf. AM : pbl
-     .                  pblh,capCL,oliqCL,cteiCL,pblT,
-     .                  therm,trmb1,trmb2,trmb3,plcl,
-     .                  fqcalving,fqfonte,ffonte, run_off_lic_0,
-cIM "slab" ocean
-     .                  flux_o, flux_g, tslab, seaice)
-cAA .                  itr, tr, flux_surf, d_tr)
-cAA REM:
-cAA-----
-cAA Tout ce qui a trait au traceurs est dans phytrac maintenant
-cAA pour l'instant le calcul de la couche limite pour les traceurs
-cAA se fait avec cltrac et ne tient pas compte de la differentiation
-cAA des sous-fraction de sol.
-cAA REM bis :
-cAA----------
-cAA Pour pouvoir extraire les coefficient d'echanges et le vent 
-cAA dans la premiere couche, 3 champs supplementaires ont ete crees
-cAA zcoefh,zu1 et zv1. Pour l'instant nous avons moyenne les valeurs
-cAA de ces trois champs sur les 4 subsurfaces du modele. Dans l'avenir 
-cAA si les informations des subsurfaces doivent etre prises en compte
-cAA il faudra sortir ces memes champs en leur ajoutant une dimension, 
-cAA c'est a dire nbsrf (nbre de subsurface).
-      USE ioipsl
-      USE interface_surf
-      USE dimphy
-      IMPLICIT none
-c======================================================================
-c Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818
-c Objet: interface de "couche limite" (diffusion verticale)
-c Arguments:
-c dtime----input-R- interval du temps (secondes)
-c itap-----input-I- numero du pas de temps
-c date0----input-R- jour initial
-c t--------input-R- temperature (K)
-c q--------input-R- vapeur d'eau (kg/kg)
-c u--------input-R- vitesse u
-c v--------input-R- vitesse v
-c ts-------input-R- temperature du sol (en Kelvin)
-c paprs----input-R- pression a intercouche (Pa)
-c pplay----input-R- pression au milieu de couche (Pa)
-c radsol---input-R- flux radiatif net (positif vers le sol) en W/m**2
-c rlat-----input-R- latitude en degree
-c rugos----input-R- longeur de rugosite (en m)
-c cufi-----input-R- resolution des mailles en x (m)
-c cvfi-----input-R- resolution des mailles en y (m)
-c
-c d_t------output-R- le changement pour "t"
-c d_q------output-R- le changement pour "q"
-c d_u------output-R- le changement pour "u"
-c d_v------output-R- le changement pour "v"
-c d_ts-----output-R- le changement pour "ts"
-c flux_t---output-R- flux de chaleur sensible (CpT) J/m**2/s (W/m**2)
-c                    (orientation positive vers le bas)
-c flux_q---output-R- flux de vapeur d'eau (kg/m**2/s)
-c flux_u---output-R- tension du vent X: (kg m/s)/(m**2 s) ou Pascal
-c flux_v---output-R- tension du vent Y: (kg m/s)/(m**2 s) ou Pascal
-c dflux_t derive du flux sensible
-c dflux_q derive du flux latent
-cIM "slab" ocean
-c flux_g---output-R-  flux glace (pour OCEAN='slab  ')
-c flux_o---output-R-  flux ocean (pour OCEAN='slab  ')
-c tslab-in/output-R temperature du slab ocean (en Kelvin) ! uniqmnt pour slab
-c seaice---output-R-  glace de mer (kg/m2) (pour OCEAN='slab  ')
-ccc
-c ffonte----Flux thermique utilise pour fondre la neige
-c fqfonte -- quantite d'eau due a la fonte de la calotte
-c fqcalving-Flux d'eau "perdue" par la surface et necessaire pour limiter la
-c           hauteur de neige, en kg/m2/s
-cAA on rajoute en output yu1 et yv1 qui sont les vents dans 
-cAA la premiere couche
-cAA ces 4 variables sont maintenant traites dans phytrac
-c itr--------input-I- nombre de traceurs
-c tr---------input-R- q. de traceurs
-c flux_surf--input-R- flux de traceurs a la surface
-c d_tr-------output-R tendance de traceurs
-cIM cf. AM : PBL
-c trmb1-------deep_cape
-c trmb2--------inhibition 
-c trmb3-------Point Omega
-c Cape(klon)-------Cape du thermique
-c EauLiq(klon)-------Eau liqu integr du thermique
-c ctei(klon)-------Critere d'instab d'entrainmt des nuages de CL
-c lcl------- Niveau de condensation
-c pblh------- HCL
-c pblT------- T au nveau HCL
-c======================================================================
-cym#include "dimensions.h"
-cym#include "dimphy.h"
-#include "indicesol.h"
-cxxx PB ajout pour soil
-#include "dimsoil.h"
-#include "iniprint.h"
-#include "compbl.h"
-c
-      REAL dtime
-      real date0
-      integer itap
-      REAL t(klon,klev), q(klon,klev)
-      REAL u(klon,klev), v(klon,klev)
-cIM 230604 BAD  REAL radsol(klon) ??? 
-      REAL paprs(klon,klev+1), pplay(klon,klev)
-      REAL rlon(klon), rlat(klon), cufi(klon), cvfi(klon)
-      REAL d_t(klon, klev), d_q(klon, klev)
-      REAL d_u(klon, klev), d_v(klon, klev)
-      REAL flux_t(klon,klev, nbsrf), flux_q(klon,klev, nbsrf)
-      REAL dflux_t(klon), dflux_q(klon)
-cIM "slab" ocean
-      REAL flux_o(klon), flux_g(klon)
-      REAL y_flux_o(klon), y_flux_g(klon)
-      REAL tslab(klon), ytslab(klon)
-      REAL seaice(klon), y_seaice(klon)
-c
-      REAL amn, amx
-cIM cf JLD
-      REAL y_fqcalving(klon), y_fqfonte(klon), y_ffonte(klon)
-      REAL fqcalving(klon,nbsrf), fqfonte(klon,nbsrf),ffonte(klon,nbsrf)
-      REAL run_off_lic_0(klon), y_run_off_lic_0(klon)
-
-      REAL flux_u(klon,klev, nbsrf), flux_v(klon,klev, nbsrf)
-      REAL rugmer(klon), agesno(klon,nbsrf),rugoro(klon)
-      REAL cdragh(klon), cdragm(klon)
-      integer jour            ! jour de l'annee en cours
-      real rmu0(klon)         ! cosinus de l'angle solaire zenithal
-      REAL co2_ppm            ! taux CO2 atmosphere
-      LOGICAL debut, lafin, ok_veget
-      character*6 ocean
-      integer npas, nexca
-cAA      INTEGER itr
-cAA      REAL tr(klon,klev,nbtr)
-cAA      REAL d_tr(klon,klev,nbtr)
-cAA      REAL flux_surf(klon,nbtr)
-c
-      REAL pctsrf(klon,nbsrf)
-      REAL ts(klon,nbsrf)
-      REAL d_ts(klon,nbsrf)
-      REAL snow(klon,nbsrf)
-      REAL qsurf(klon,nbsrf)
-      REAL evap(klon,nbsrf)
-      REAL albe(klon,nbsrf)
-      REAL alblw(klon,nbsrf)
-cxxx PB
-      REAL fluxlat(klon,nbsrf)
-C
-      real rain_f(klon), snow_f(klon)
-      REAL fder(klon)
-cIM cf. JLD   REAL sollw(klon), solsw(klon), sollwdown(klon)
-      REAL sollw(klon,nbsrf), solsw(klon,nbsrf), sollwdown(klon)
-      REAL rugos(klon,nbsrf)
-C la nouvelle repartition des surfaces sortie de l'interface
-      REAL pctsrf_new(klon,nbsrf)
-cAA
-      REAL zcoefh(klon,klev)
-      REAL zu1(klon)
-      REAL zv1(klon)
-cAA
-cxxx PB ajout pour soil
-      LOGICAL soil_model
-cIM ajout seuils cdrm, cdrh
-      REAL cdmmax, cdhmax
-cIM: 261103
-      REAL ksta, ksta_ter
-      LOGICAL ok_kzmin
-cIM: 261103
-      REAL ftsoil(klon,nsoilmx,nbsrf)
-      REAL ytsoil(klon,nsoilmx)
-      REAL qsol(klon)
-c======================================================================
-      EXTERNAL clqh, clvent, coefkz, calbeta, cltrac
-c======================================================================
-      REAL yts(klon), yrugos(klon), ypct(klon), yz0_new(klon)
-      REAL yalb(klon)
-      REAL yalblw(klon)
-      REAL yu1(klon), yv1(klon)
-      real ysnow(klon), yqsurf(klon), yagesno(klon), yqsol(klon)
-      real yrain_f(klon), ysnow_f(klon)
-      real ysollw(klon), ysolsw(klon), ysollwdown(klon)
-      real yfder(klon), ytaux(klon), ytauy(klon)
-      REAL yrugm(klon), yrads(klon),yrugoro(klon)
-cxxx PB
-      REAL yfluxlat(klon)
-C
-      REAL y_d_ts(klon)
-      REAL y_d_t(klon, klev), y_d_q(klon, klev)
-      REAL y_d_u(klon, klev), y_d_v(klon, klev)
-      REAL y_flux_t(klon,klev), y_flux_q(klon,klev)
-      REAL y_flux_u(klon,klev), y_flux_v(klon,klev)
-      REAL y_dflux_t(klon), y_dflux_q(klon)
-      REAL ycoefh(klon,klev), ycoefm(klon,klev)
-      REAL yu(klon,klev), yv(klon,klev)
-      REAL yt(klon,klev), yq(klon,klev)
-      REAL ypaprs(klon,klev+1), ypplay(klon,klev), ydelp(klon,klev)
-cAA      REAL ytr(klon,klev,nbtr)
-cAA      REAL y_d_tr(klon,klev,nbtr)
-cAA      REAL yflxsrf(klon,nbtr)
-c
-c
-      LOGICAL ok_nonloc
-      PARAMETER (ok_nonloc=.FALSE.)
-      REAL ycoefm0(klon,klev), ycoefh0(klon,klev)
-
-cIM 081204 hcl_Anne ? BEG
-      real yzlay(klon,klev),yzlev(klon,klev+1),yteta(klon,klev)
-      real ykmm(klon,klev+1),ykmn(klon,klev+1)
-      real ykmq(klon,klev+1)
-      real yq2(klon,klev+1),q2(klon,klev+1,nbsrf)
-      real q2diag(klon,klev+1)
-cIM 081204   real yustar(klon),y_cd_m(klon),y_cd_h(klon)
-cIM 081204 hcl_Anne ? END
-c
-#include "YOMCST.h"
-#include "YOETHF.h"
-#include "FCTTRE.h"
-      REAL u1lay(klon), v1lay(klon)
-      REAL delp(klon,klev)
-      INTEGER i, k, nsrf 
-cAA   INTEGER it
-      INTEGER ni(klon), knon, j
-c Introduction d'une variable "pourcentage potentiel" pour tenir compte
-c des eventuelles apparitions et/ou disparitions de la glace de mer
-      REAL pctsrf_pot(klon,nbsrf)
-      
-c======================================================================
-      REAL zx_alf1, zx_alf2 !valeur ambiante par extrapola.
-c======================================================================
-c
-c maf pour sorties IOISPL en cas de debugagage
-c
-      CHARACTER*80 cldebug
-      SAVE cldebug
-c$OMP THREADPRIVATE(cldebug)
-      CHARACTER*8 cl_surf(nbsrf)
-      SAVE cl_surf
-c$OMP THREADPRIVATE(cl_surf)
-      INTEGER nhoridbg, nidbg
-      SAVE nhoridbg, nidbg
-c$OMP THREADPRIVATE(nhoridbg, nidbg)
-#ifndef IO_DISCONNECTED
-      INTEGER ndexbg(iim*(jjm+1))
-      REAL zx_lon(iim,jjm+1), zx_lat(iim,jjm+1), zjulian
-      REAL tabindx(klon)
-      REAL debugtab(iim,jjm+1)
-#endif
-      LOGICAL first_appel
-      SAVE first_appel
-      DATA first_appel/.true./
-c$OMP THREADPRIVATE(first_appel)
-      LOGICAL debugindex
-      SAVE debugindex
-      DATA debugindex/.false./
-c$OMP THREADPRIVATE(debugindex)
-      integer idayref
-#include "temps.h"
-      REAL t2m(klon,nbsrf), q2m(klon,nbsrf)
-      REAL u10m(klon,nbsrf), v10m(klon,nbsrf)
-c
-      REAL yt2m(klon), yq2m(klon), yu10m(klon)
-      REAL yustar(klon)
-c -- LOOP
-       REAL yu10mx(klon)
-       REAL yu10my(klon)
-       REAL ywindsp(klon)
-c -- LOOP
-c
-      REAL yt10m(klon), yq10m(klon)
-cIM cf. AM : pbl, hbtm2 (Comme les autres diagnostics on cumule ds physic ce qui 
-c   permet de sortir les grdeurs par sous surface)
-      REAL pblh(klon,nbsrf)
-      REAL plcl(klon,nbsrf)
-      REAL capCL(klon,nbsrf)
-      REAL oliqCL(klon,nbsrf)
-      REAL cteiCL(klon,nbsrf)
-      REAL pblT(klon,nbsrf)
-      REAL therm(klon,nbsrf)
-      REAL trmb1(klon,nbsrf)
-      REAL trmb2(klon,nbsrf)
-      REAL trmb3(klon,nbsrf)
-      REAL ypblh(klon)
-      REAL ylcl(klon)
-      REAL ycapCL(klon)
-      REAL yoliqCL(klon)
-      REAL ycteiCL(klon)
-      REAL ypblT(klon)
-      REAL ytherm(klon)
-      REAL ytrmb1(klon)
-      REAL ytrmb2(klon)
-      REAL ytrmb3(klon)
-      REAL y_cd_h(klon), y_cd_m(klon)
-c     REAL ygamt(klon,2:klev) ! contre-gradient pour temperature
-c     REAL ygamq(klon,2:klev) ! contre-gradient pour humidite
-      REAL uzon(klon), vmer(klon)
-      REAL tair1(klon), qair1(klon), tairsol(klon)
-      REAL psfce(klon), patm(klon)
-c
-      REAL qairsol(klon), zgeo1(klon)
-      REAL rugo1(klon)
-c
-      LOGICAL zxli ! utiliser un jeu de fonctions simples
-      PARAMETER (zxli=.FALSE.)
-c
-      REAL zt, zqs, zdelta, zcor
-      REAL t_coup
-      PARAMETER(t_coup=273.15)
-C
-      character (len = 20) :: modname = 'clmain'
-      LOGICAL check
-      PARAMETER (check=.false.)
-
-
-c initialisation Anne
-      ytherm(:) = 0.
-C
-      if (check) THEN
-          write(*,*) modname,'  klon=',klon
-          call flush(6)
-      endif
-      IF (first_appel) THEN
-!          first_appel=.false.
-!
-! initialisation sorties netcdf
-!
-#ifndef IO_DISCONNECTED
-          idayref = day_ini
-          CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
-          CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlon,zx_lon)
-          DO i = 1, iim
-            zx_lon(i,1) = rlon(i+1)
-            zx_lon(i,jjm+1) = rlon(i+1)
-          ENDDO
-          CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlat,zx_lat)
-          cldebug='sous_index'
-          CALL histbeg(cldebug, iim,zx_lon(:,1),jjm+1,zx_lat(1,:),
-     $        1,iim,1,jjm
-     $        +1, itau_phy,zjulian,dtime,nhoridbg,nidbg) 
-! no vertical axis
-          cl_surf(1)='ter'
-          cl_surf(2)='lic'
-          cl_surf(3)='oce'
-          cl_surf(4)='sic'
-          DO nsrf=1,nbsrf
-            CALL histdef(nidbg, cl_surf(nsrf),cl_surf(nsrf), "-",iim,
-     $          jjm+1,nhoridbg, 1, 1, 1, -99, 32, "inst", dtime,dtime) 
-          END DO
-          CALL histend(nidbg)
-          CALL histsync(nidbg)
-#endif
-      ENDIF 
-          
-      DO k = 1, klev   ! epaisseur de couche
-      DO i = 1, klon
-         delp(i,k) = paprs(i,k)-paprs(i,k+1)
-      ENDDO
-      ENDDO
-      DO i = 1, klon  ! vent de la premiere couche
-ccc         zx_alf1 = (paprs(i,1)-pplay(i,2))/(pplay(i,1)-pplay(i,2))
-         zx_alf1 = 1.0
-         zx_alf2 = 1.0 - zx_alf1
-         u1lay(i) = u(i,1)*zx_alf1 + u(i,2)*zx_alf2
-         v1lay(i) = v(i,1)*zx_alf1 + v(i,2)*zx_alf2
-      ENDDO
-c
-c initialisation:
-c
-      DO i = 1, klon
-         rugmer(i) = 0.0
-         cdragh(i) = 0.0
-         cdragm(i) = 0.0
-         dflux_t(i) = 0.0
-         dflux_q(i) = 0.0
-         zu1(i) = 0.0
-         zv1(i) = 0.0
-      ENDDO
-      ypct = 0.0
-      yts = 0.0
-      ysnow = 0.0
-      yqsurf = 0.0
-      yalb = 0.0
-      yalblw = 0.0
-      yrain_f = 0.0
-      ysnow_f = 0.0
-      yfder = 0.0
-      ytaux = 0.0
-      ytauy = 0.0
-      ysolsw = 0.0
-      ysollw = 0.0
-      ysollwdown = 0.0
-      yrugos = 0.0
-      yu1 = 0.0
-      yv1 = 0.0
-      yrads = 0.0
-      ypaprs = 0.0
-      ypplay = 0.0
-      ydelp = 0.0
-      yu = 0.0
-      yv = 0.0
-      yt = 0.0
-      yq = 0.0
-      pctsrf_new = 0.0
-      y_flux_u = 0.0
-      y_flux_v = 0.0
-Cxx PB
-      y_dflux_t = 0.0
-      y_dflux_q = 0.0
-      ytsoil = 999999.
-      yrugoro = 0.
-c -- LOOP
-      yu10mx = 0.0
-      yu10my = 0.0
-      ywindsp = 0.0
-c -- LOOP
-      DO nsrf = 1, nbsrf
-      DO i = 1, klon
-         d_ts(i,nsrf) = 0.0
-      ENDDO
-      END DO
-C PB
-      yfluxlat=0.
-      flux_t = 0.
-      flux_q = 0.
-      flux_u = 0.
-      flux_v = 0.
-      DO k = 1, klev
-      DO i = 1, klon
-         d_t(i,k) = 0.0
-         d_q(i,k) = 0.0
-cxxx         flux_t(i,k) = 0.0
-cxxx         flux_q(i,k) = 0.0
-         d_u(i,k) = 0.0
-         d_v(i,k) = 0.0
-cxxx         flux_u(i,k) = 0.0
-cxxx         flux_v(i,k) = 0.0
-         zcoefh(i,k) = 0.0
-      ENDDO
-      ENDDO
-cAA      IF (itr.GE.1) THEN
-cAA      DO it = 1, itr
-cAA      DO k = 1, klev
-cAA      DO i = 1, klon
-cAA         d_tr(i,k,it) = 0.0
-cAA      ENDDO
-cAA      ENDDO
-cAA      ENDDO
-cAA      ENDIF
-
-c
-c Boucler sur toutes les sous-fractions du sol:
-c
-C Initialisation des "pourcentages potentiels". On considere ici qu'on 
-C peut avoir potentiellementdela glace sur tout le domaine oceanique 
-C (a affiner)
-
-      pctsrf_pot = pctsrf
-      pctsrf_pot(:,is_oce) = 1. - zmasq(:)
-      pctsrf_pot(:,is_sic) = 1. - zmasq(:)
-
-      DO 99999 nsrf = 1, nbsrf
-
-c chercher les indices:
-      DO j = 1, klon
-         ni(j) = 0
-      ENDDO
-      knon = 0
-      DO i = 1, klon
-
-C pour determiner le domaine a traiter on utilise les surfaces "potentielles"
-C  
-      IF (pctsrf_pot(i,nsrf).GT.epsfra) THEN
-         knon = knon + 1
-         ni(knon) = i
-      ENDIF
-      ENDDO
-c
-      if (check) THEN
-          write(*,*)'CLMAIN, nsrf, knon =',nsrf, knon
-          call flush(6)
-      endif
-c
-c variables pour avoir une sortie IOIPSL des INDEX
-c
-#ifndef IO_DISCONNECTED
-      IF (debugindex) THEN 
-          tabindx(:)=0.
-c          tabindx(1:knon)=(/FLOAT(i),i=1:knon/)
-          DO i=1,knon
-            tabindx(i)=FLOAT(i)
-          END DO 
-          debugtab(:,:)=0.
-          ndexbg(:)=0
-          CALL gath2cpl(tabindx,debugtab,klon,knon,iim,jjm,ni)
-          CALL histwrite(nidbg,cl_surf(nsrf),itap,debugtab,iim*(jjm+1)
-     $        ,ndexbg)
-      ENDIF 
-#endif
-
-      fluxlat(:,nsrf) = 0.
-      
-cym      IF (knon.EQ.0) GOTO 99999
-      DO j = 1, knon
-      i = ni(j)
-        ypct(j) = pctsrf(i,nsrf)
-        yts(j) = ts(i,nsrf)
-cIM "slab" ocean
-c        PRINT *, 'tslab = ', i, tslab(i)
-        ytslab(i) = tslab(i)
-        y_seaice(i) = seaice(i)
-c
-        ysnow(j) = snow(i,nsrf)
-        yqsurf(j) = qsurf(i,nsrf)
-        yalb(j) = albe(i,nsrf)
-        yalblw(j) = alblw(i,nsrf)
-        yrain_f(j) = rain_f(i)
-        ysnow_f(j) = snow_f(i)
-        yagesno(j) = agesno(i,nsrf)
-        yfder(j) = fder(i)
-        ytaux(j) = flux_u(i,1,nsrf)
-        ytauy(j) = flux_v(i,1,nsrf)
-        ysolsw(j) = solsw(i,nsrf)
-        ysollw(j) = sollw(i,nsrf)
-        ysollwdown(j) = sollwdown(i)
-        yrugos(j) = rugos(i,nsrf)
-        yrugoro(j) = rugoro(i)
-        yu1(j) = u1lay(i)
-        yv1(j) = v1lay(i)
-        yrads(j) =  ysolsw(j)+ ysollw(j)
-        ypaprs(j,klev+1) = paprs(i,klev+1)
-        y_run_off_lic_0(j) = run_off_lic_0(i)
-c -- LOOP
-       yu10mx(j) = u10m(i,nsrf)
-       yu10my(j) = v10m(i,nsrf)
-       ywindsp(j) = SQRT(yu10mx(j)*yu10mx(j) + yu10my(j)*yu10my(j) )
-c -- LOOP
-      END DO
-C
-C     IF bucket model for continent, copy soil water content
-      IF ( nsrf .eq. is_ter .and. .not. ok_veget ) THEN 
-          DO j = 1, knon
-            i = ni(j)
-            yqsol(j) = qsol(i)
-          END DO
-      ELSE 
-          yqsol(:)=0.
-      ENDIF 
-cxxx PB ajour pour soil
-      DO k = 1, nsoilmx
-        DO j = 1, knon
-          i = ni(j)
-          ytsoil(j,k) = ftsoil(i,k,nsrf)
-        END DO  
-      END DO 
-      DO k = 1, klev
-      DO j = 1, knon
-      i = ni(j)
-        ypaprs(j,k) = paprs(i,k)
-        ypplay(j,k) = pplay(i,k)
-        ydelp(j,k) = delp(i,k)
-        yu(j,k) = u(i,k)
-        yv(j,k) = v(i,k)
-        yt(j,k) = t(i,k)
-        yq(j,k) = q(i,k)
-      ENDDO
-      ENDDO
-c
-c
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-c calculer Cdrag et les coefficients d'echange
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-c  Calcul anciens du LMD. Effectues de toutes facons.
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-
-      CALL coefkz(nsrf, knon, ypaprs, ypplay,
-cIM 261103
-     .     ksta, ksta_ter,
-cIM 261103
-     .            yts, yrugos, yu, yv, yt, yq,
-     .            yqsurf, 
-     .            ycoefm, ycoefh)
-cIM 081204 BEG
-cCR test
-      if (iflag_pbl.eq.1) then
-cIM 081204 END
-        CALL coefkz2(nsrf, knon, ypaprs, ypplay,yt,
-     .                  ycoefm0, ycoefh0)
-        DO k = 1, klev
-        DO i = 1, knon
-           ycoefm(i,k) = MAX(ycoefm(i,k),ycoefm0(i,k))
-           ycoefh(i,k) = MAX(ycoefh(i,k),ycoefh0(i,k))
-        ENDDO
-        ENDDO
-      endif
-c
-cIM cf JLD : on seuille ycoefm et ycoefh
-      if (nsrf.eq.is_oce) then
-         do j=1,knon
-c           ycoefm(j,1)=min(ycoefm(j,1),1.1E-3)
-            ycoefm(j,1)=min(ycoefm(j,1),cdmmax)
-c           ycoefh(j,1)=min(ycoefh(j,1),1.1E-3)
-            ycoefh(j,1)=min(ycoefh(j,1),cdhmax)
-         enddo
-      endif
-
-c
-cIM: 261103
-      if (ok_kzmin) THEN
-cIM cf FH: 201103 BEG
-c   Calcul d'une diffusion minimale pour les conditions tres stables.
-      call coefkzmin(knon,ypaprs,ypplay,yu,yv,yt,yq,ycoefm
-     .   ,ycoefm0,ycoefh0)
-c      call dump2d(iim,jjm-1,ycoefm(2:klon-1,2), 'KZ         ')
-c      call dump2d(iim,jjm-1,ycoefm0(2:klon-1,2),'KZMIN      ')
- 
-       if ( 1.eq.1 ) then
-       DO k = 1, klev
-       DO i = 1, knon
-          ycoefm(i,k) = MAX(ycoefm(i,k),ycoefm0(i,k))
-          ycoefh(i,k) = MAX(ycoefh(i,k),ycoefh0(i,k))
-       ENDDO
-       ENDDO
-       endif
-cIM cf FH: 201103 END
-      endif !ok_kzmin
-cIM: 261103
-
-
-      IF (iflag_pbl.ge.3) then
-
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-c MELLOR ET YAMADA adapte a Mars Richard Fournier et Frederic Hourdin
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-
-         yzlay(1:knon,1)=
-     .   RD*yt(1:knon,1)/(0.5*(ypaprs(1:knon,1)+ypplay(1:knon,1)))
-     .   *(ypaprs(1:knon,1)-ypplay(1:knon,1))/RG
-         do k=2,klev
-            yzlay(1:knon,k)=
-     .      yzlay(1:knon,k-1)+RD*0.5*(yt(1:knon,k-1)+yt(1:knon,k))
-     .      /ypaprs(1:knon,k)*(ypplay(1:knon,k-1)-ypplay(1:knon,k))/RG
-         enddo
-         do k=1,klev
-            yteta(1:knon,k)=
-     .      yt(1:knon,k)*(ypaprs(1:knon,1)/ypplay(1:knon,k))**rkappa
-     .      *(1.+0.61*yq(1:knon,k))
-         enddo
-         yzlev(1:knon,1)=0.
-         yzlev(1:knon,klev+1)=2.*yzlay(1:knon,klev)-yzlay(1:knon,klev-1)
-         do k=2,klev
-            yzlev(1:knon,k)=0.5*(yzlay(1:knon,k)+yzlay(1:knon,k-1))
-         enddo
-         DO k = 1, klev+1
-            DO j = 1, knon
-               i = ni(j)
-               yq2(j,k)=q2(i,k,nsrf)
-            enddo
-         enddo
-
-
-c   Bug introduit volontairement pour converger avec les resultats
-c  du papier sur les thermiques.
-         if (1.eq.1) then
-         y_cd_m(1:knon) = ycoefm(1:knon,1)
-         y_cd_h(1:knon) = ycoefh(1:knon,1)
-         else
-         y_cd_h(1:knon) = ycoefm(1:knon,1)
-         y_cd_m(1:knon) = ycoefh(1:knon,1)
-         endif
-         call ustarhb(knon,yu,yv,y_cd_m, yustar)
-
-        if (prt_level > 9) THEN
-          WRITE(lunout,*)'USTAR = ',yustar
-        ENDIF
-
-c   iflag_pbl peut etre utilise comme longuer de melange
-
-         if (iflag_pbl.ge.11) then
-            call vdif_kcay(knon,dtime,rg,rd,ypaprs,yt
-     s      ,yzlev,yzlay,yu,yv,yteta
-     s      ,y_cd_m,yq2,q2diag,ykmm,ykmn,yustar,
-     s      iflag_pbl)
-         else
-            call yamada4(knon,dtime,rg,rd,ypaprs,yt
-     s      ,yzlev,yzlay,yu,yv,yteta
-     s      ,y_cd_m,yq2,ykmm,ykmn,ykmq,yustar,
-     s      iflag_pbl)
-         endif
-
-         ycoefm(1:knon,1)=y_cd_m(1:knon)
-         ycoefh(1:knon,1)=y_cd_h(1:knon)
-         ycoefm(1:knon,2:klev)=ykmm(1:knon,2:klev)
-         ycoefh(1:knon,2:klev)=ykmn(1:knon,2:klev)
-
-
-      ENDIF
-
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-c calculer la diffusion des vitesses "u" et "v"
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-
-      CALL clvent(knon,dtime,yu1,yv1,ycoefm,yt,yu,ypaprs,ypplay,ydelp,
-     s            y_d_u,y_flux_u)
-      CALL clvent(knon,dtime,yu1,yv1,ycoefm,yt,yv,ypaprs,ypplay,ydelp,
-     s            y_d_v,y_flux_v)
-
-c pour le couplage
-      ytaux = y_flux_u(:,1)
-      ytauy = y_flux_v(:,1)
-
-c FH modif sur le cdrag temperature
-cxxxPB : d�lace dans clcdrag
-cxxx      do i=1,knon
-cxxx         ycoefh(i,1)=ycoefm(i,1)*0.8
-cxxx      enddo
-
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-c calculer la diffusion de "q" et de "h"
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-      CALL clqh(dtime, itap, date0,jour, debut,lafin,
-     e          rlon, rlat, cufi, cvfi,
-     e          knon, nsrf, ni, pctsrf,
-     e          soil_model, ytsoil,yqsol,
-     e          ok_veget, ocean, npas, nexca,
-     e          rmu0, co2_ppm, yrugos, yrugoro,
-     e          yu1, yv1, ycoefh,
-     e          yt,yq,yts,ypaprs,ypplay,
-     e          ydelp,yrads,yalb, yalblw, ysnow, yqsurf, 
-     e          yrain_f, ysnow_f, yfder, ytaux, ytauy,
-c -- LOOP
-     e          ywindsp, 
-c -- LOOP
-cxxx     e          ysollw, ysolsw,
-     e          ysollw, ysollwdown, ysolsw,yfluxlat,
-     s          pctsrf_new, yagesno,
-     s          y_d_t, y_d_q, y_d_ts, yz0_new,
-     s          y_flux_t, y_flux_q, y_dflux_t, y_dflux_q,
-     s          y_fqcalving,y_fqfonte,y_ffonte,y_run_off_lic_0,
-cIM "slab" ocean
-     s          y_flux_o, y_flux_g, ytslab, y_seaice)
-c
-c calculer la longueur de rugosite sur ocean
-      yrugm=0.
-      IF (nsrf.EQ.is_oce) THEN
-      DO j = 1, knon
-         yrugm(j) = 0.018*ycoefm(j,1) * (yu1(j)**2+yv1(j)**2)/RG 
-     $      +  0.11*14e-6 / sqrt(ycoefm(j,1) * (yu1(j)**2+yv1(j)**2))
-         yrugm(j) = MAX(1.5e-05,yrugm(j))
-      ENDDO
-      ENDIF
-      DO j = 1, knon
-         y_dflux_t(j) = y_dflux_t(j) * ypct(j)
-         y_dflux_q(j) = y_dflux_q(j) * ypct(j)
-         yu1(j) = yu1(j) *  ypct(j)
-         yv1(j) = yv1(j) *  ypct(j)
-      ENDDO
-c
-      DO k = 1, klev
-        DO j = 1, knon
-          i = ni(j)
-          ycoefh(j,k) = ycoefh(j,k) * ypct(j)
-          ycoefm(j,k) = ycoefm(j,k) * ypct(j)
-          y_d_t(j,k) = y_d_t(j,k) * ypct(j)
-          y_d_q(j,k) = y_d_q(j,k) * ypct(j)
-C PB
-          flux_t(i,k,nsrf) = y_flux_t(j,k)
-          flux_q(i,k,nsrf) = y_flux_q(j,k)
-          flux_u(i,k,nsrf) = y_flux_u(j,k)
-          flux_v(i,k,nsrf) = y_flux_v(j,k)
-cxxx PB        y_flux_t(j,k) = y_flux_t(j,k) * ypct(j)
-cxxx PB        y_flux_q(j,k) = y_flux_q(j,k) * ypct(j)
-          y_d_u(j,k) = y_d_u(j,k) * ypct(j)
-          y_d_v(j,k) = y_d_v(j,k) * ypct(j)
-cxxx PB        y_flux_u(j,k) = y_flux_u(j,k) * ypct(j)
-cxxx PB        y_flux_v(j,k) = y_flux_v(j,k) * ypct(j)
-        ENDDO
-      ENDDO
-
-
-      evap(:,nsrf) = - flux_q(:,1,nsrf)
-c
-      albe(:, nsrf) = 0.
-      alblw(:, nsrf) = 0.
-      snow(:, nsrf) = 0.
-      qsurf(:, nsrf) = 0.
-      rugos(:, nsrf) = 0.
-      fluxlat(:,nsrf) = 0.
-      DO j = 1, knon
-         i = ni(j)
-         d_ts(i,nsrf) = y_d_ts(j)
-         albe(i,nsrf) = yalb(j)
-         alblw(i,nsrf) = yalblw(j)
-         snow(i,nsrf) = ysnow(j)
-         qsurf(i,nsrf) = yqsurf(j)
-         rugos(i,nsrf) = yz0_new(j)
-         fluxlat(i,nsrf) = yfluxlat(j)
-cxxx pb         rugmer(i) = yrugm(j)
-         IF (nsrf .EQ. is_oce) then 
-           rugmer(i) = yrugm(j)
-           rugos(i,nsrf) = yrugm(j)
-         endif	
-cIM cf JLD ??
-         agesno(i,nsrf) = yagesno(j)
-         fqcalving(i,nsrf) = y_fqcalving(j)        
-         fqfonte(i,nsrf) = y_fqfonte(j)        
-         ffonte(i,nsrf) = y_ffonte(j)        
-         cdragh(i) = cdragh(i) + ycoefh(j,1)
-         cdragm(i) = cdragm(i) + ycoefm(j,1)
-         dflux_t(i) = dflux_t(i) + y_dflux_t(j)
-         dflux_q(i) = dflux_q(i) + y_dflux_q(j)
-         zu1(i) = zu1(i) + yu1(j)
-         zv1(i) = zv1(i) + yv1(j)
-      END DO
-      IF ( nsrf .eq. is_ter ) THEN 
-      DO j = 1, knon
-         i = ni(j)
-         qsol(i) = yqsol(j)
-      END DO
-      END IF 
-      IF ( nsrf .eq. is_lic ) THEN 
-        DO j = 1, knon
-          i = ni(j)
-          run_off_lic_0(i) = y_run_off_lic_0(j)
-        END DO
-      END IF 
-c@$$ PB ajout pour soil
-      ftsoil(:,:,nsrf) = 0.
-      DO k = 1, nsoilmx
-        DO j = 1, knon
-          i = ni(j)
-          ftsoil(i, k, nsrf) = ytsoil(j,k)
-        END DO 
-      END DO 
-c
-#ifdef CRAY
-      DO k = 1, klev
-      DO j = 1, knon
-      i = ni(j)
-#else
-      DO j = 1, knon
-      i = ni(j)
-      DO k = 1, klev
-#endif
-         d_t(i,k) = d_t(i,k) + y_d_t(j,k)
-         d_q(i,k) = d_q(i,k) + y_d_q(j,k)
-c@$$ PB        flux_t(i,k) = flux_t(i,k) + y_flux_t(j,k)
-c@$$         flux_q(i,k) = flux_q(i,k) + y_flux_q(j,k)
-         d_u(i,k) = d_u(i,k) + y_d_u(j,k)
-         d_v(i,k) = d_v(i,k) + y_d_v(j,k)
-c@$$  PB       flux_u(i,k) = flux_u(i,k) + y_flux_u(j,k)
-c@$$         flux_v(i,k) = flux_v(i,k) + y_flux_v(j,k)
-         zcoefh(i,k) = zcoefh(i,k) + ycoefh(j,k)
-      ENDDO
-      ENDDO
-c
-c
-#undef T2m     
-#define T2m     
-#ifdef T2m
-ccc diagnostic t,q a 2m et u, v a 10m
-c
-      DO j=1, knon
-        i = ni(j)
-        uzon(j) = yu(j,1) + y_d_u(j,1)
-        vmer(j) = yv(j,1) + y_d_v(j,1)
-        tair1(j) = yt(j,1) + y_d_t(j,1)
-        qair1(j) = yq(j,1) + y_d_q(j,1)
-        zgeo1(j) = RD * tair1(j) / (0.5*(ypaprs(j,1)+ypplay(j,1)))
-     &                   * (ypaprs(j,1)-ypplay(j,1))
-        tairsol(j) = yts(j) + y_d_ts(j)
-        rugo1(j) = yrugos(j)
-        IF(nsrf.EQ.is_oce) THEN
-         rugo1(j) = rugos(i,nsrf)
-        ENDIF
-        psfce(j)=ypaprs(j,1)
-        patm(j)=ypplay(j,1)
-c
-        qairsol(j) = yqsurf(j)
-      ENDDO
-c
-      CALL stdlevvar(klon, knon, nsrf, zxli,
-     &               uzon, vmer, tair1, qair1, zgeo1,
-     &               tairsol, qairsol, rugo1, psfce, patm,
-cIM  &               yt2m, yq2m, yu10m)
-     &               yt2m, yq2m, yt10m, yq10m, yu10m, yustar)
-cIM 081204 END
-c
-c
-      DO j=1, knon
-       i = ni(j)
-       t2m(i,nsrf)=yt2m(j)
-
-c
-       q2m(i,nsrf)=yq2m(j)
-c
-c u10m, v10m : composantes du vent a 10m sans spirale de Ekman
-       u10m(i,nsrf)=(yu10m(j) * uzon(j))/sqrt(uzon(j)**2+vmer(j)**2)
-       v10m(i,nsrf)=(yu10m(j) * vmer(j))/sqrt(uzon(j)**2+vmer(j)**2)
-c
-      ENDDO
-c
-cIM cf AM : pbl, HBTM
-      DO i = 1, knon
-         y_cd_h(i) = ycoefh(i,1)
-         y_cd_m(i) = ycoefm(i,1)
-      ENDDO
-c     print*,'appel hbtm2'
-      CALL HBTM(knon, ypaprs, ypplay,
-     .          yt2m,yt10m,yq2m,yq10m,yustar,
-     .          y_flux_t,y_flux_q,yu,yv,yt,yq,
-     .          ypblh,ycapCL,yoliqCL,ycteiCL,ypblT,
-     .          ytherm,ytrmb1,ytrmb2,ytrmb3,ylcl)
-c     print*,'fin hbtm2'
-c
-      DO j=1, knon
-       i = ni(j)
-       pblh(i,nsrf)   = ypblh(j)
-       plcl(i,nsrf)   = ylcl(j)
-       capCL(i,nsrf)  = ycapCL(j)
-       oliqCL(i,nsrf) = yoliqCL(j)
-       cteiCL(i,nsrf) = ycteiCL(j)
-       pblT(i,nsrf)   = ypblT(j)
-       therm(i,nsrf)  = ytherm(j)
-       trmb1(i,nsrf)  = ytrmb1(j)
-       trmb2(i,nsrf)  = ytrmb2(j)
-       trmb3(i,nsrf)  = ytrmb3(j)
-      ENDDO
-c
-#else
-cIM cf AM : pbl, HBTM
-      DO j=1, knon
-       i = ni(j)
-       pblh(i,nsrf)   = 0.
-       plcl(i,nsrf)   = 0.
-       capCL(i,nsrf)  = 0.
-       oliqCL(i,nsrf) = 0.
-       cteiCL(i,nsrf) = 0.
-       pblT(i,nsrf)   = 0.
-       therm(i,nsrf)  = 0.
-       trmb1(i,nsrf)  = 0.
-       trmb2(i,nsrf)  = 0.
-       trmb3(i,nsrf)  = 0.
-      ENDDO 
-      DO j=1, knon
-       i = ni(j) 
-       t2m(i,nsrf)=0.
-       q2m(i,nsrf)=0.
-       u10m(i,nsrf)=0.
-       v10m(i,nsrf)=0.
-      ENDDO 
-#endif
-
-      do j=1,knon
-         do k=1,klev+1
-         i=ni(j)
-         q2(i,k,nsrf)=yq2(j,k)
-         enddo
-      enddo
-cIM "slab" ocean 
-      IF(OCEAN.EQ.'slab  '.OR.OCEAN.EQ.'force ') THEN
-       IF (nsrf.EQ.is_oce) THEN
-        DO j = 1, knon
-c on projette sur la grille globale
-         i = ni(j)
-         IF(pctsrf_new(i,is_oce).GT.epsfra) THEN
-          flux_o(i) = y_flux_o(j)
-         ELSE
-          flux_o(i) = 0.
-         ENDIF
-        ENDDO
-       ENDIF
-c
-       IF (nsrf.EQ.is_sic) THEN
-        DO j = 1, knon
-         i = ni(j)
-cIM 230604 on pondere lorsque l'on fait le bilan au sol :  flux_g(i) = y_flux_g(j)*ypct(j)
-         IF(pctsrf_new(i,is_sic).GT.epsfra) THEN
-          flux_g(i) = y_flux_g(j)
-         ELSE
-          flux_g(i) = 0.
-         ENDIF
-        ENDDO
-       ENDIF !nsrf.EQ.is_sic
-      ENDIF !OCEAN
-c
-      IF(OCEAN.EQ.'slab  ') THEN
-cIM appel interfoce_slab sur is_oce      IF(nsrf.EQ.is_oce) then 
-cIM appel interfoce_slab sur is_sic
-       IF(nsrf.EQ.is_sic) then  !appel sic
-        tslab(1:klon) = ytslab(1:klon)
-        seaice(1:klon) = y_seaice(1:klon)
-       ENDIF !nsrf
-      ENDIF !OCEAN
-99999 CONTINUE
-C
-C On utilise les nouvelles surfaces
-C A rajouter: conservation de l'albedo
-C
-      rugos(:,is_oce) = rugmer
-      pctsrf = pctsrf_new
-
-      RETURN
-      END
-      SUBROUTINE clqh(dtime,itime, date0,jour,debut,lafin,
-     e                rlon, rlat, cufi, cvfi, 
-     e                knon, nisurf, knindex, pctsrf,
-     $                soil_model,tsoil,qsol,
-     e                ok_veget, ocean, npas, nexca,
-     e                rmu0, co2_ppm, rugos, rugoro,
-     e                u1lay,v1lay,coef,
-     e                t,q,ts,paprs,pplay,
-     e                delp,radsol,albedo,alblw,snow,qsurf, 
-     e                precip_rain, precip_snow, fder, taux, tauy,
-c -- LOOP
-     e                ywindsp,
-c -- LOOP
-     $                sollw, sollwdown, swnet,fluxlat, 
-     s                pctsrf_new, agesno,
-     s                d_t, d_q, d_ts, z0_new, 
-     s                flux_t, flux_q,dflux_s,dflux_l,
-     s                fqcalving,fqfonte,ffonte,run_off_lic_0,
-cIM "slab" ocean
-     s                flux_o,flux_g,tslab,seaice)
-
-      USE interface_surf
-      USE dimphy
-      IMPLICIT none
-c======================================================================
-c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
-c Objet: diffusion verticale de "q" et de "h"
-c======================================================================
-#include "dimensions.h"
-cym#include "dimphy.h"
-#include "YOMCST.h"
-#include "YOETHF.h"
-#include "FCTTRE.h"
-#include "indicesol.h"
-#include "dimsoil.h"
-#include "iniprint.h"
-
-c Arguments:
-      INTEGER knon
-      REAL dtime              ! intervalle du temps (s)
-      real date0
-      REAL u1lay(klon)        ! vitesse u de la 1ere couche (m/s)
-      REAL v1lay(klon)        ! vitesse v de la 1ere couche (m/s)
-      REAL coef(klon,klev)    ! le coefficient d'echange (m**2/s)
-c                               multiplie par le cisaillement du 
-c                               vent (dV/dz); la premiere valeur
-c                               indique la valeur de Cdrag (sans unite)
-      REAL t(klon,klev)       ! temperature (K)
-      REAL q(klon,klev)       ! humidite specifique (kg/kg)
-      REAL ts(klon)           ! temperature du sol (K)
-      REAL evap(klon)         ! evaporation au sol
-      REAL paprs(klon,klev+1) ! pression a inter-couche (Pa)
-      REAL pplay(klon,klev)   ! pression au milieu de couche (Pa)
-      REAL delp(klon,klev)    ! epaisseur de couche en pression (Pa)
-      REAL radsol(klon)       ! ray. net au sol (Solaire+IR) W/m2
-      REAL albedo(klon)       ! albedo de la surface
-      REAL alblw(klon)
-      REAL snow(klon)         ! hauteur de neige
-      REAL qsurf(klon)         ! humidite de l'air au dessus de la surface
-      real precip_rain(klon), precip_snow(klon)
-      REAL agesno(klon)
-      REAL rugoro(klon)
-      REAL run_off_lic_0(klon)! runof glacier au pas de temps precedent
-      integer jour            ! jour de l'annee en cours
-      real rmu0(klon)         ! cosinus de l'angle solaire zenithal
-      real rugos(klon)        ! rugosite
-      integer knindex(klon)
-      real pctsrf(klon,nbsrf)
-      real rlon(klon), rlat(klon), cufi(klon), cvfi(klon)
-      logical ok_veget 
-      REAL co2_ppm            ! taux CO2 atmosphere
-      character*6 ocean
-      integer npas, nexca
-c -- LOOP
-       REAL yu10mx(klon)
-       REAL yu10my(klon)
-       REAL ywindsp(klon)
-c -- LOOP
-
-
-c
-      REAL d_t(klon,klev)     ! incrementation de "t"
-      REAL d_q(klon,klev)     ! incrementation de "q"
-      REAL d_ts(klon)         ! incrementation de "ts"
-      REAL flux_t(klon,klev)  ! (diagnostic) flux de la chaleur
-c                               sensible, flux de Cp*T, positif vers
-c                               le bas: j/(m**2 s) c.a.d.: W/m2
-      REAL flux_q(klon,klev)  ! flux de la vapeur d'eau:kg/(m**2 s)
-      REAL dflux_s(klon) ! derivee du flux sensible dF/dTs
-      REAL dflux_l(klon) ! derivee du flux latent dF/dTs
-cIM cf JLD
-c Flux thermique utiliser pour fondre la neige
-      REAL ffonte(klon)
-c Flux d'eau "perdu" par la surface et n�essaire pour que limiter la
-c hauteur de neige, en kg/m2/s
-      REAL fqcalving(klon)
-c Quantite d'eau de fonte de la calotte kg/m?s
-      REAL fqfonte(klon)
-cIM "slab" ocean
-      REAL tslab(klon)  !temperature du slab ocean (K) (OCEAN='slab  ')
-      REAL seaice(klon) ! glace de mer en kg/m2
-      REAL flux_o(klon) ! flux entre l'ocean et l'atmosphere W/m2
-      REAL flux_g(klon) ! flux entre l'ocean et la glace de mer W/m2
-c
-c======================================================================
-      REAL t_grnd  ! temperature de rappel pour glace de mer
-      PARAMETER (t_grnd=271.35)
-      REAL t_coup
-      PARAMETER(t_coup=273.15)
-c======================================================================
-      INTEGER i, k
-      REAL zx_cq(klon,klev)
-      REAL zx_dq(klon,klev)
-      REAL zx_ch(klon,klev)
-      REAL zx_dh(klon,klev)
-      REAL zx_buf1(klon)
-      REAL zx_buf2(klon)
-      REAL zx_coef(klon,klev)
-      REAL local_h(klon,klev) ! enthalpie potentielle
-      REAL local_q(klon,klev)
-      REAL local_ts(klon)
-      REAL psref(klon) ! pression de reference pour temperature potent.
-      REAL zx_pkh(klon,klev), zx_pkf(klon,klev)
-c======================================================================
-c contre-gradient pour la vapeur d'eau: (kg/kg)/metre
-      REAL gamq(klon,2:klev)
-c contre-gradient pour la chaleur sensible: Kelvin/metre
-      REAL gamt(klon,2:klev)
-      REAL z_gamaq(klon,2:klev), z_gamah(klon,2:klev)
-      REAL zdelz
-c======================================================================
-#include "compbl.h"
-c======================================================================
-c Rajout pour l'interface
-      integer itime
-      integer nisurf
-      logical debut, lafin
-      real zlev1(klon)
-      real fder(klon), taux(klon), tauy(klon)
-      real temp_air(klon), spechum(klon)
-      real epot_air(klon), ccanopy(klon)
-      real tq_cdrag(klon), petAcoef(klon), peqAcoef(klon)
-      real petBcoef(klon), peqBcoef(klon)
-      real sollw(klon), sollwdown(klon), swnet(klon), swdown(klon)
-      real p1lay(klon)
-c@$$C PB ajout pour soil
-      LOGICAL soil_model
-      REAL tsoil(klon, nsoilmx)
-      REAL qsol(klon)
-
-! Parametres de sortie
-      real fluxsens(klon), fluxlat(klon)
-      real tsol_rad(klon), tsurf_new(klon), alb_new(klon)
-      real emis_new(klon), z0_new(klon)
-      real pctsrf_new(klon,nbsrf)
-c JLD
-      real zzpk
-C
-      character (len = 20) :: modname = 'Debut clqh'
-      LOGICAL check
-      PARAMETER (check=.false.)
-C
-      if (check) THEN
-          write(*,*) modname,' nisurf=',nisurf
-          call flush(6)
-      endif
-c
-      if (check) THEN
-       WRITE(*,*)' qsurf (min, max)'
-     $     , minval(qsurf(1:knon)), maxval(qsurf(1:knon))
-       call flush(6)
-      ENDIF
-C
-C
-      if (iflag_pbl.eq.1) then
-        do k = 3, klev
-          do i = 1, knon
-            gamq(i,k)= 0.0
-            gamt(i,k)=  -1.0e-03
-          enddo
-        enddo
-        do i = 1, knon
-          gamq(i,2) = 0.0
-          gamt(i,2) = -2.5e-03
-        enddo
-      else
-        do k = 2, klev
-          do i = 1, knon
-            gamq(i,k) = 0.0
-            gamt(i,k) = 0.0
-          enddo
-        enddo
-      endif
-
-      DO i = 1, knon
-         psref(i) = paprs(i,1) !pression de reference est celle au sol
-         local_ts(i) = ts(i)
-      ENDDO
-      DO k = 1, klev
-      DO i = 1, knon
-         zx_pkh(i,k) = (psref(i)/paprs(i,k))**RKAPPA
-         zx_pkf(i,k) = (psref(i)/pplay(i,k))**RKAPPA
-         local_h(i,k) = RCPD * t(i,k) * zx_pkf(i,k)
-         local_q(i,k) = q(i,k)
-      ENDDO
-      ENDDO
-c
-c Convertir les coefficients en variables convenables au calcul:
-c
-c
-      DO k = 2, klev
-      DO i = 1, knon
-         zx_coef(i,k) = coef(i,k)*RG/(pplay(i,k-1)-pplay(i,k))
-     .                  *(paprs(i,k)*2/(t(i,k)+t(i,k-1))/RD)**2
-         zx_coef(i,k) = zx_coef(i,k) * dtime*RG
-      ENDDO
-      ENDDO
-c
-c Preparer les flux lies aux contre-gardients
-c
-      DO k = 2, klev
-      DO i = 1, knon
-         zdelz = RD * (t(i,k-1)+t(i,k))/2.0 / RG /paprs(i,k)
-     .              *(pplay(i,k-1)-pplay(i,k))
-         z_gamaq(i,k) = gamq(i,k) * zdelz
-         z_gamah(i,k) = gamt(i,k) * zdelz *RCPD * zx_pkh(i,k)
-      ENDDO
-      ENDDO
-      DO i = 1, knon
-         zx_buf1(i) = zx_coef(i,klev) + delp(i,klev)
-         zx_cq(i,klev) = (local_q(i,klev)*delp(i,klev)
-     .                   -zx_coef(i,klev)*z_gamaq(i,klev))/zx_buf1(i)
-         zx_dq(i,klev) = zx_coef(i,klev) / zx_buf1(i)
-c
-         zzpk=(pplay(i,klev)/psref(i))**RKAPPA
-         zx_buf2(i) = zzpk*delp(i,klev) + zx_coef(i,klev)
-         zx_ch(i,klev) = (local_h(i,klev)*zzpk*delp(i,klev)
-     .                   -zx_coef(i,klev)*z_gamah(i,klev))/zx_buf2(i)
-         zx_dh(i,klev) = zx_coef(i,klev) / zx_buf2(i)
-      ENDDO
-      DO k = klev-1, 2 , -1
-      DO i = 1, knon
-         zx_buf1(i) = delp(i,k)+zx_coef(i,k)
-     .               +zx_coef(i,k+1)*(1.-zx_dq(i,k+1))
-         zx_cq(i,k) = (local_q(i,k)*delp(i,k)
-     .                 +zx_coef(i,k+1)*zx_cq(i,k+1)
-     .                 +zx_coef(i,k+1)*z_gamaq(i,k+1)
-     .                 -zx_coef(i,k)*z_gamaq(i,k))/zx_buf1(i)
-         zx_dq(i,k) = zx_coef(i,k) / zx_buf1(i)
-c
-         zzpk=(pplay(i,k)/psref(i))**RKAPPA
-         zx_buf2(i) = zzpk*delp(i,k)+zx_coef(i,k)
-     .               +zx_coef(i,k+1)*(1.-zx_dh(i,k+1))
-         zx_ch(i,k) = (local_h(i,k)*zzpk*delp(i,k)
-     .                 +zx_coef(i,k+1)*zx_ch(i,k+1)
-     .                 +zx_coef(i,k+1)*z_gamah(i,k+1)
-     .                 -zx_coef(i,k)*z_gamah(i,k))/zx_buf2(i)
-         zx_dh(i,k) = zx_coef(i,k) / zx_buf2(i)
-      ENDDO
-      ENDDO
-C
-C nouvelle formulation JL Dufresne
-C
-C q1 = zx_cq(i,1) + zx_dq(i,1) * Flux_Q(i,1) * dt
-C h1 = zx_ch(i,1) + zx_dh(i,1) * Flux_H(i,1) * dt
-C
-      DO i = 1, knon
-         zx_buf1(i) = delp(i,1) + zx_coef(i,2)*(1.-zx_dq(i,2))
-         zx_cq(i,1) = (local_q(i,1)*delp(i,1)
-     .                 +zx_coef(i,2)*(z_gamaq(i,2)+zx_cq(i,2)))
-     .                /zx_buf1(i)
-         zx_dq(i,1) = -1. * RG / zx_buf1(i)
-c
-         zzpk=(pplay(i,1)/psref(i))**RKAPPA
-         zx_buf2(i) = zzpk*delp(i,1) + zx_coef(i,2)*(1.-zx_dh(i,2))
-         zx_ch(i,1) = (local_h(i,1)*zzpk*delp(i,1)
-     .                 +zx_coef(i,2)*(z_gamah(i,2)+zx_ch(i,2)))
-     .                /zx_buf2(i)
-         zx_dh(i,1) = -1. * RG / zx_buf2(i)
-      ENDDO
-
-C Appel a interfsurf (appel generique) routine d'interface avec la surface
-
-c initialisation
-       petAcoef =0. 
-	peqAcoef = 0.
-	petBcoef =0.
-	peqBcoef = 0.
-	p1lay =0.
-	
-c      do i = 1, knon
-        petAcoef(1:knon) = zx_ch(1:knon,1)
-        peqAcoef(1:knon) = zx_cq(1:knon,1)
-        petBcoef(1:knon) =  zx_dh(1:knon,1)
-        peqBcoef(1:knon) = zx_dq(1:knon,1)
-        tq_cdrag(1:knon) =coef(1:knon,1)
-        temp_air(1:knon) =t(1:knon,1)
-        epot_air(1:knon) =local_h(1:knon,1)
-        spechum(1:knon)=q(1:knon,1)
-        p1lay(1:knon) = pplay(1:knon,1)
-        zlev1(1:knon) = delp(1:knon,1)
-c        swnet = swdown * (1. - albedo)
-c
-cIM swdown=flux SW incident sur terres
-cIM swdown=flux SW net sur les autres surfaces 
-cIM     swdown(1:knon) = swnet(1:knon)
-        if(nisurf.eq.is_ter) THEN 
-         swdown(1:knon) = swnet(1:knon)/(1-albedo(1:knon)) 
-        else 
-         swdown(1:knon) = swnet(1:knon)
-        endif
-c      enddo
-      ccanopy = co2_ppm
-
-      CALL interfsurf(itime, dtime, date0, jour, rmu0,
-     e klon, iim, jjm, nisurf, knon, knindex, pctsrf, 
-     e rlon, rlat, cufi, cvfi, 
-     e debut, lafin, ok_veget, soil_model, nsoilmx,tsoil, qsol,
-     e zlev1,  u1lay, v1lay, temp_air, spechum, epot_air, ccanopy, 
-     e tq_cdrag, petAcoef, peqAcoef, petBcoef, peqBcoef,
-     e precip_rain, precip_snow, sollw, sollwdown, swnet, swdown,
-     e fder, taux, tauy, 
-c -- LOOP
-     e ywindsp,
-c -- LOOP
-     e rugos, rugoro,
-     e albedo, snow, qsurf,
-     e ts, p1lay, psref, radsol,
-     e ocean, npas, nexca, zmasq,
-     s evap, fluxsens, fluxlat, dflux_l, dflux_s,              
-     s tsol_rad, tsurf_new, alb_new, alblw, emis_new, z0_new, 
-     s pctsrf_new, agesno,fqcalving,fqfonte,ffonte, run_off_lic_0,
-cIM "slab" ocean 
-     s flux_o, flux_g, tslab, seaice)
-
-
-      do i = 1, knon
-        flux_t(i,1) = fluxsens(i)
-        flux_q(i,1) = - evap(i)
-        d_ts(i) = tsurf_new(i) - ts(i)
-        albedo(i) = alb_new(i)
-      enddo
-
-c==== une fois on a zx_h_ts, on peut faire l'iteration ========
-      DO i = 1, knon
-         local_h(i,1) = zx_ch(i,1) + zx_dh(i,1)*flux_t(i,1)*dtime
-         local_q(i,1) = zx_cq(i,1) + zx_dq(i,1)*flux_q(i,1)*dtime
-      ENDDO
-      DO k = 2, klev
-      DO i = 1, knon
-        local_q(i,k) = zx_cq(i,k) + zx_dq(i,k)*local_q(i,k-1)
-        local_h(i,k) = zx_ch(i,k) + zx_dh(i,k)*local_h(i,k-1)
-      ENDDO
-      ENDDO
-c======================================================================
-c== flux_q est le flux de vapeur d'eau: kg/(m**2 s)  positive vers bas
-c== flux_t est le flux de cpt (energie sensible): j/(m**2 s)
-      DO k = 2, klev
-      DO i = 1, knon
-        flux_q(i,k) = (zx_coef(i,k)/RG/dtime)
-     .                * (local_q(i,k)-local_q(i,k-1)+z_gamaq(i,k))
-        flux_t(i,k) = (zx_coef(i,k)/RG/dtime)
-     .                * (local_h(i,k)-local_h(i,k-1)+z_gamah(i,k))
-     .                / zx_pkh(i,k)
-      ENDDO
-      ENDDO
-c======================================================================
-C Calcul tendances
-      DO k = 1, klev
-      DO i = 1, knon
-         d_t(i,k) = local_h(i,k)/zx_pkf(i,k)/RCPD - t(i,k)
-         d_q(i,k) = local_q(i,k) - q(i,k)
-      ENDDO
-      ENDDO
-c
-
-      RETURN
-      END
-      SUBROUTINE clvent(knon,dtime, u1lay,v1lay,coef,t,ven,
-     e                  paprs,pplay,delp,
-     s                  d_ven,flux_v)
-      use dimphy
-      IMPLICIT none
-c======================================================================
-c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
-c Objet: diffusion vertical de la vitesse "ven"
-c======================================================================
-c Arguments:
-c dtime----input-R- intervalle du temps (en second)
-c u1lay----input-R- vent u de la premiere couche (m/s)
-c v1lay----input-R- vent v de la premiere couche (m/s)
-c coef-----input-R- le coefficient d'echange (m**2/s) multiplie par
-c                   le cisaillement du vent (dV/dz); la premiere
-c                   valeur indique la valeur de Cdrag (sans unite)
-c t--------input-R- temperature (K)
-c ven------input-R- vitesse horizontale (m/s)
-c paprs----input-R- pression a inter-couche (Pa)
-c pplay----input-R- pression au milieu de couche (Pa)
-c delp-----input-R- epaisseur de couche (Pa)
-c
-c
-c d_ven----output-R- le changement de "ven"
-c flux_v---output-R- (diagnostic) flux du vent: (kg m/s)/(m**2 s)
-c======================================================================
-cym#include "dimensions.h"
-cym#include "dimphy.h"
-#include "iniprint.h"
-      INTEGER knon
-      REAL dtime
-      REAL u1lay(klon), v1lay(klon)
-      REAL coef(klon,klev)
-      REAL t(klon,klev), ven(klon,klev)
-      REAL paprs(klon,klev+1), pplay(klon,klev), delp(klon,klev)
-      REAL d_ven(klon,klev)
-      REAL flux_v(klon,klev)
-c======================================================================
-#include "YOMCST.h"
-c======================================================================
-      INTEGER i, k
-      REAL zx_cv(klon,2:klev)
-      REAL zx_dv(klon,2:klev)
-      REAL zx_buf(klon)
-      REAL zx_coef(klon,klev)
-      REAL local_ven(klon,klev)
-      REAL zx_alf1(klon), zx_alf2(klon)
-c======================================================================
-      DO k = 1, klev
-      DO i = 1, knon
-         local_ven(i,k) = ven(i,k)
-      ENDDO
-      ENDDO
-c======================================================================
-      DO i = 1, knon
-ccc         zx_alf1(i) = (paprs(i,1)-pplay(i,2))/(pplay(i,1)-pplay(i,2))
-         zx_alf1(i) = 1.0
-         zx_alf2(i) = 1.0 - zx_alf1(i)
-         zx_coef(i,1) = coef(i,1)
-     .                 * (1.0+SQRT(u1lay(i)**2+v1lay(i)**2))
-     .                 * pplay(i,1)/(RD*t(i,1))
-         zx_coef(i,1) = zx_coef(i,1) * dtime*RG
-      ENDDO
-c======================================================================
-      DO k = 2, klev
-      DO i = 1, knon
-         zx_coef(i,k) = coef(i,k)*RG/(pplay(i,k-1)-pplay(i,k))
-     .                  *(paprs(i,k)*2/(t(i,k)+t(i,k-1))/RD)**2
-         zx_coef(i,k) = zx_coef(i,k) * dtime*RG
-      ENDDO
-      ENDDO
-c======================================================================
-      DO i = 1, knon
-         zx_buf(i) = delp(i,1) + zx_coef(i,1)*zx_alf1(i)+zx_coef(i,2)
-         zx_cv(i,2) = local_ven(i,1)*delp(i,1) / zx_buf(i)
-         zx_dv(i,2) = (zx_coef(i,2)-zx_alf2(i)*zx_coef(i,1))
-     .                /zx_buf(i)
-      ENDDO
-      DO k = 3, klev
-      DO i = 1, knon
-         zx_buf(i) = delp(i,k-1) + zx_coef(i,k)
-     .                         + zx_coef(i,k-1)*(1.-zx_dv(i,k-1))
-         zx_cv(i,k) = (local_ven(i,k-1)*delp(i,k-1)
-     .                  +zx_coef(i,k-1)*zx_cv(i,k-1) )/zx_buf(i)
-         zx_dv(i,k) = zx_coef(i,k)/zx_buf(i)
-      ENDDO
-      ENDDO
-      DO i = 1, knon
-         local_ven(i,klev) = ( local_ven(i,klev)*delp(i,klev)
-     .                        +zx_coef(i,klev)*zx_cv(i,klev) )
-     .                   / ( delp(i,klev) + zx_coef(i,klev)
-     .                       -zx_coef(i,klev)*zx_dv(i,klev) )
-      ENDDO
-      DO k = klev-1, 1, -1
-      DO i = 1, knon
-         local_ven(i,k) = zx_cv(i,k+1) + zx_dv(i,k+1)*local_ven(i,k+1)
-      ENDDO
-      ENDDO
-c======================================================================
-c== flux_v est le flux de moment angulaire (positif vers bas)
-c== dont l'unite est: (kg m/s)/(m**2 s)
-      DO i = 1, knon
-         flux_v(i,1) = zx_coef(i,1)/(RG*dtime)
-     .                 *(local_ven(i,1)*zx_alf1(i)
-     .                  +local_ven(i,2)*zx_alf2(i))
-      ENDDO
-      DO k = 2, klev
-      DO i = 1, knon
-         flux_v(i,k) = zx_coef(i,k)/(RG*dtime)
-     .               * (local_ven(i,k)-local_ven(i,k-1))
-      ENDDO
-      ENDDO
-c
-      DO k = 1, klev
-      DO i = 1, knon
-         d_ven(i,k) = local_ven(i,k) - ven(i,k)
-      ENDDO
-      ENDDO
-c
-      RETURN
-      END
-      SUBROUTINE coefkz(nsrf, knon, paprs, pplay,
-cIM 261103
-     .                  ksta, ksta_ter,
-cIM 261103
-     .                  ts, rugos,
-     .                  u,v,t,q,
-     .                  qsurf, 
-     .                  pcfm, pcfh)
-      USE dimphy
-      IMPLICIT none
-c======================================================================
-c Auteur(s) F. Hourdin, M. Forichon, Z.X. Li (LMD/CNRS) date: 19930922
-c           (une version strictement identique a l'ancien modele)
-c Objet: calculer le coefficient du frottement du sol (Cdrag) et les
-c        coefficients d'echange turbulent dans l'atmosphere.
-c Arguments:
-c nsrf-----input-I- indicateur de la nature du sol
-c knon-----input-I- nombre de points a traiter
-c paprs----input-R- pression a chaque intercouche (en Pa)
-c pplay----input-R- pression au milieu de chaque couche (en Pa)
-c ts-------input-R- temperature du sol (en Kelvin)
-c rugos----input-R- longeur de rugosite (en m)
-c u--------input-R- vitesse u
-c v--------input-R- vitesse v
-c t--------input-R- temperature (K)
-c q--------input-R- vapeur d'eau (kg/kg)
-c
-c itop-----output-I- numero de couche du sommet de la couche limite
-c pcfm-----output-R- coefficients a calculer (vitesse)
-c pcfh-----output-R- coefficients a calculer (chaleur et humidite)
-c======================================================================
-cym#include "dimensions.h"
-cym#include "dimphy.h"
-#include "YOMCST.h"
-#include "indicesol.h"
-#include "iniprint.h"
-c
-c Arguments:
-c
-      INTEGER knon, nsrf
-      REAL ts(klon)
-      REAL paprs(klon,klev+1), pplay(klon,klev)
-      REAL u(klon,klev), v(klon,klev), t(klon,klev), q(klon,klev)
-      REAL rugos(klon)
-c
-      REAL pcfm(klon,klev), pcfh(klon,klev)
-      INTEGER itop(klon)
-c
-c Quelques constantes et options:
-c
-      REAL cepdu2, ckap, cb, cc, cd, clam
-      PARAMETER (cepdu2 =(0.1)**2)
-      PARAMETER (CKAP=0.4)
-      PARAMETER (cb=5.0)
-      PARAMETER (cc=5.0)
-      PARAMETER (cd=5.0)
-      PARAMETER (clam=160.0)
-      REAL ratqs ! largeur de distribution de vapeur d'eau
-      PARAMETER (ratqs=0.05)
-      LOGICAL richum ! utilise le nombre de Richardson humide
-      PARAMETER (richum=.TRUE.)
-      REAL ric ! nombre de Richardson critique
-      PARAMETER(ric=0.4)
-      REAL prandtl
-      PARAMETER (prandtl=0.4)
-      REAL kstable ! diffusion minimale (situation stable)
-      ! GKtest
-      ! PARAMETER (kstable=1.0e-10)
-      REAL ksta, ksta_ter
-cIM: 261103     REAL kstable_ter, kstable_sinon
-cIM: 211003 cf GK   PARAMETER (kstable_ter = 1.0e-6)
-cIM: 261103     PARAMETER (kstable_ter = 1.0e-8)
-cIM: 261103   PARAMETER (kstable_ter = 1.0e-10)
-cIM: 261103   PARAMETER (kstable_sinon = 1.0e-10)
-      ! fin GKtest
-      REAL mixlen ! constante controlant longueur de melange
-      PARAMETER (mixlen=35.0)
-      INTEGER isommet ! le sommet de la couche limite
-cym      PARAMETER (isommet=klev)
-      LOGICAL tvirtu ! calculer Ri d'une maniere plus performante
-      PARAMETER (tvirtu=.TRUE.)
-      LOGICAL opt_ec ! formule du Centre Europeen dans l'atmosphere
-      PARAMETER (opt_ec=.FALSE.)
-
-#include "compbl.h"
-c
-c Variables locales:
-c
-      INTEGER i, k, kk !IM 120704
-      REAL zgeop(klon,klev)
-      REAL zmgeom(klon)
-      REAL zri(klon)
-      REAL zl2(klon)
-
-      REAL u1(klon), v1(klon), t1(klon), q1(klon), z1(klon)
-      REAL pcfm1(klon), pcfh1(klon)
-c
-      REAL zdphi, zdu2, ztvd, ztvu, zcdn
-      REAL zscf
-      REAL zt, zq, zdelta, zcvm5, zcor, zqs, zfr, zdqs
-      REAL z2geomf, zalh2, zalm2, zscfh, zscfm
-      REAL t_coup
-      PARAMETER (t_coup=273.15)
-cIM
-      LOGICAL check
-      PARAMETER (check=.false.)
-c
-c contre-gradient pour la chaleur sensible: Kelvin/metre
-      REAL gamt(2:klev)
-      real qsurf(klon) 
-c
-      LOGICAL appel1er
-      SAVE appel1er
-c$OMP THREADPRIVATE(appel1er)
-c
-c Fonctions thermodynamiques et fonctions d'instabilite
-      REAL fsta, fins, x
-      LOGICAL zxli ! utiliser un jeu de fonctions simples
-      PARAMETER (zxli=.FALSE.)
-c
-#include "YOETHF.h"
-#include "FCTTRE.h"
-      fsta(x) = 1.0 / (1.0+10.0*x*(1+8.0*x))
-      fins(x) = SQRT(1.0-18.0*x)
-c
-      DATA appel1er /.TRUE./
-c
-cym
-      isommet=klev
-      
-      IF (appel1er) THEN
-        if (prt_level > 9) THEN
-          WRITE(lunout,*)'coefkz, opt_ec:', opt_ec
-          WRITE(lunout,*)'coefkz, richum:', richum
-          IF (richum) WRITE(lunout,*)'coefkz, ratqs:', ratqs
-          WRITE(lunout,*)'coefkz, isommet:', isommet
-          WRITE(lunout,*)'coefkz, tvirtu:', tvirtu
-          appel1er = .FALSE.
-        endif
-      ENDIF
-c
-c Initialiser les sorties
-c
-      DO k = 1, klev
-      DO i = 1, knon
-         pcfm(i,k) = 0.0
-         pcfh(i,k) = 0.0
-      ENDDO
-      ENDDO
-      DO i = 1, knon
-         itop(i) = 0
-      ENDDO
-
-c
-c Prescrire la valeur de contre-gradient
-c
-      if (iflag_pbl.eq.1) then
-         DO k = 3, klev
-            gamt(k) = -1.0E-03
-         ENDDO
-         gamt(2) = -2.5E-03
-      else
-         DO k = 2, klev
-            gamt(k) = 0.0
-         ENDDO
-      ENDIF
-cIM cf JLD/ GKtest
-      IF ( nsrf .NE. is_oce ) THEN
-cIM 261103     kstable = kstable_ter
-        kstable = ksta_ter
-      ELSE
-cIM 261103     kstable = kstable_sinon
-        kstable = ksta
-      ENDIF
-cIM cf JLD/ GKtest fin
-c
-c Calculer les geopotentiels de chaque couche
-c
-      DO i = 1, knon
-         zgeop(i,1) = RD * t(i,1) / (0.5*(paprs(i,1)+pplay(i,1)))
-     .                   * (paprs(i,1)-pplay(i,1))
-      ENDDO
-      DO k = 2, klev
-      DO i = 1, knon
-         zgeop(i,k) = zgeop(i,k-1)
-     .              + RD * 0.5*(t(i,k-1)+t(i,k)) / paprs(i,k)
-     .                   * (pplay(i,k-1)-pplay(i,k))
-      ENDDO
-      ENDDO
-c
-c Calculer le frottement au sol (Cdrag)
-c
-      DO i = 1, knon
-       u1(i) = u(i,1)
-       v1(i) = v(i,1)
-       t1(i) = t(i,1)
-       q1(i) = q(i,1)
-       z1(i) = zgeop(i,1)
-      ENDDO
-c
-      CALL clcdrag(klon, knon, nsrf, zxli, 
-     $             u1, v1, t1, q1, z1,
-     $             ts, qsurf, rugos,
-     $             pcfm1, pcfh1) 
-cIM  $             ts, qsurf, rugos,
-C
-      DO i = 1, knon
-       pcfm(i,1)=pcfm1(i)
-       pcfh(i,1)=pcfh1(i)
-      ENDDO
-c
-c Calculer les coefficients turbulents dans l'atmosphere
-c
-      DO i = 1, knon
-         itop(i) = isommet
-      ENDDO
-
-
-      DO k = 2, isommet
-      DO i = 1, knon
-            zdu2=MAX(cepdu2,(u(i,k)-u(i,k-1))**2
-     .                     +(v(i,k)-v(i,k-1))**2)
-            zmgeom(i)=zgeop(i,k)-zgeop(i,k-1)
-            zdphi =zmgeom(i) / 2.0
-            zt = (t(i,k)+t(i,k-1)) * 0.5
-            zq = (q(i,k)+q(i,k-1)) * 0.5
-c
-c           calculer Qs et dQs/dT:
-c
-            IF (thermcep) THEN
-              zdelta = MAX(0.,SIGN(1.,RTT-zt))
-              zcvm5 = R5LES*RLVTT/RCPD/(1.0+RVTMP2*zq)*(1.-zdelta) 
-     .            + R5IES*RLSTT/RCPD/(1.0+RVTMP2*zq)*zdelta
-              zqs = R2ES * FOEEW(zt,zdelta) / pplay(i,k)
-              zqs = MIN(0.5,zqs)
-              zcor = 1./(1.-RETV*zqs)
-              zqs = zqs*zcor
-              zdqs = FOEDE(zt,zdelta,zcvm5,zqs,zcor)
-            ELSE
-              IF (zt .LT. t_coup) THEN
-                 zqs = qsats(zt) / pplay(i,k)
-                 zdqs = dqsats(zt,zqs)
-              ELSE
-                 zqs = qsatl(zt) / pplay(i,k)
-                 zdqs = dqsatl(zt,zqs)
-              ENDIF
-            ENDIF
-c
-c           calculer la fraction nuageuse (processus humide):
-c
-            zfr = (zq+ratqs*zq-zqs) / (2.0*ratqs*zq)
-            zfr = MAX(0.0,MIN(1.0,zfr))
-            IF (.NOT.richum) zfr = 0.0
-c
-c           calculer le nombre de Richardson:
-c
-            IF (tvirtu) THEN
-            ztvd =( t(i,k)
-     .             + zdphi/RCPD/(1.+RVTMP2*zq)
-     .              *( (1.-zfr) + zfr*(1.+RLVTT*zqs/RD/zt)/(1.+zdqs) )
-     .            )*(1.+RETV*q(i,k))
-            ztvu =( t(i,k-1)
-     .             - zdphi/RCPD/(1.+RVTMP2*zq)
-     .              *( (1.-zfr) + zfr*(1.+RLVTT*zqs/RD/zt)/(1.+zdqs) )
-     .            )*(1.+RETV*q(i,k-1))
-            zri(i) =zmgeom(i)*(ztvd-ztvu)/(zdu2*0.5*(ztvd+ztvu))
-            zri(i) = zri(i)
-     .             + zmgeom(i)*zmgeom(i)/RG*gamt(k)
-     .               *(paprs(i,k)/101325.0)**RKAPPA
-     .               /(zdu2*0.5*(ztvd+ztvu))
-c
-            ELSE ! calcul de Ridchardson compatible LMD5
-c
-            zri(i) =(RCPD*(t(i,k)-t(i,k-1))
-     .              -RD*0.5*(t(i,k)+t(i,k-1))/paprs(i,k)
-     .               *(pplay(i,k)-pplay(i,k-1))
-     .              )*zmgeom(i)/(zdu2*0.5*RCPD*(t(i,k-1)+t(i,k)))
-            zri(i) = zri(i) +
-     .             zmgeom(i)*zmgeom(i)*gamt(k)/RG
-cSB     .             /(paprs(i,k)/101325.0)**RKAPPA
-     .             *(paprs(i,k)/101325.0)**RKAPPA
-     .             /(zdu2*0.5*(t(i,k-1)+t(i,k)))
-            ENDIF
-c
-c           finalement, les coefficients d'echange sont obtenus:
-c
-            zcdn=SQRT(zdu2) / zmgeom(i) * RG
-c
-          IF (opt_ec) THEN
-            z2geomf=zgeop(i,k-1)+zgeop(i,k)
-            zalm2=(0.5*ckap/RG*z2geomf
-     .             /(1.+0.5*ckap/rg/clam*z2geomf))**2
-            zalh2=(0.5*ckap/rg*z2geomf
-     .             /(1.+0.5*ckap/RG/(clam*SQRT(1.5*cd))*z2geomf))**2
-            IF (zri(i).LT.0.0) THEN  ! situation instable
-               zscf = ((zgeop(i,k)/zgeop(i,k-1))**(1./3.)-1.)**3
-     .                / (zmgeom(i)/RG)**3 / (zgeop(i,k-1)/RG)
-               zscf = SQRT(-zri(i)*zscf)
-               zscfm = 1.0 / (1.0+3.0*cb*cc*zalm2*zscf)
-               zscfh = 1.0 / (1.0+3.0*cb*cc*zalh2*zscf)
-               pcfm(i,k)=zcdn*zalm2*(1.-2.0*cb*zri(i)*zscfm)
-               pcfh(i,k)=zcdn*zalh2*(1.-3.0*cb*zri(i)*zscfh)
-            ELSE ! situation stable
-               zscf=SQRT(1.+cd*zri(i))
-               pcfm(i,k)=zcdn*zalm2/(1.+2.0*cb*zri(i)/zscf)
-               pcfh(i,k)=zcdn*zalh2/(1.+3.0*cb*zri(i)*zscf)
-            ENDIF
-          ELSE
-            zl2(i)=(mixlen*MAX(0.0,(paprs(i,k)-paprs(i,itop(i)+1))
-     .                          /(paprs(i,2)-paprs(i,itop(i)+1)) ))**2
-            pcfm(i,k)=sqrt(max(zcdn*zcdn*(ric-zri(i))/ric, kstable))
-            pcfm(i,k)= zl2(i)* pcfm(i,k)
-            pcfh(i,k) = pcfm(i,k) /prandtl ! h et m different
-          ENDIF
-      ENDDO
-      ENDDO
-c
-c Au-dela du sommet, pas de diffusion turbulente:
-c
-      DO i = 1, knon
-         IF (itop(i)+1 .LE. klev) THEN
-            DO k = itop(i)+1, klev
-               pcfh(i,k) = 0.0
-               pcfm(i,k) = 0.0
-            ENDDO
-         ENDIF
-      ENDDO
-c
-      RETURN
-      END
-
-      SUBROUTINE coefkz2(nsrf, knon, paprs, pplay,t,
-     .                  pcfm, pcfh)
-      USE dimphy
-      IMPLICIT none
-c======================================================================
-c J'introduit un peu de diffusion sauf dans les endroits
-c ou une forte inversion est presente
-c On peut dire qu'il represente la convection peu profonde
-c
-c Arguments:
-c nsrf-----input-I- indicateur de la nature du sol
-c knon-----input-I- nombre de points a traiter
-c paprs----input-R- pression a chaque intercouche (en Pa)
-c pplay----input-R- pression au milieu de chaque couche (en Pa)
-c t--------input-R- temperature (K)
-c
-c pcfm-----output-R- coefficients a calculer (vitesse)
-c pcfh-----output-R- coefficients a calculer (chaleur et humidite)
-c======================================================================
-cym#include "dimensions.h"
-cym#include "dimphy.h"
-#include "YOMCST.h"
-#include "indicesol.h"
-#include "iniprint.h"
-c
-c Arguments:
-c
-      INTEGER knon, nsrf
-      REAL paprs(klon,klev+1), pplay(klon,klev)
-      REAL t(klon,klev)
-c
-      REAL pcfm(klon,klev), pcfh(klon,klev)
-c
-c Quelques constantes et options:
-c
-      REAL prandtl
-      PARAMETER (prandtl=0.4)
-      REAL kstable
-      PARAMETER (kstable=0.002)
-ccc      PARAMETER (kstable=0.001)
-      REAL mixlen ! constante controlant longueur de melange
-      PARAMETER (mixlen=35.0)
-      REAL seuil ! au-dela l'inversion est consideree trop faible
-      PARAMETER (seuil=-0.02)
-ccc      PARAMETER (seuil=-0.04)
-ccc      PARAMETER (seuil=-0.06)
-ccc      PARAMETER (seuil=-0.09)
-c
-c Variables locales:
-c
-      INTEGER i, k, invb(knon)
-      REAL zl2(knon)
-      REAL zdthmin(knon), zdthdp
-c
-c Initialiser les sorties
-c
-      DO k = 1, klev
-      DO i = 1, knon
-         pcfm(i,k) = 0.0
-         pcfh(i,k) = 0.0
-      ENDDO
-      ENDDO
-c
-c Chercher la zone d'inversion forte
-c
-      DO i = 1, knon
-         invb(i) = klev
-         zdthmin(i)=0.0
-      ENDDO
-      DO k = 2, klev/2-1
-      DO i = 1, knon
-         zdthdp = (t(i,k)-t(i,k+1))/(pplay(i,k)-pplay(i,k+1))
-     .          - RD * 0.5*(t(i,k)+t(i,k+1))/RCPD/paprs(i,k+1)
-         zdthdp = zdthdp * 100.0
-         IF (pplay(i,k).GT.0.8*paprs(i,1) .AND.
-     .       zdthdp.LT.zdthmin(i) ) THEN
-            zdthmin(i) = zdthdp
-            invb(i) = k
-         ENDIF
-      ENDDO
-      ENDDO
-c
-c Introduire une diffusion:
-c
-      DO k = 2, klev
-      DO i = 1, knon
-cIM cf FH/GK   IF ( (nsrf.NE.is_oce) .OR.  ! si ce n'est pas sur l'ocean
-cIM cf FH/GK  .     (invb(i).EQ.klev) .OR. ! s'il n'y a pas d'inversion
-      !IM cf JLD/ GKtest TERkz2
-      ! IF ( (nsrf.EQ.is_ter) .OR.  ! si on est sur la terre
-      ! fin GKtest
-      IF ( (nsrf.EQ.is_oce) .AND.  ! si on est sur ocean et si 
-     .     ( (invb(i).EQ.klev) .OR.      ! s'il n'y a pas d'inversion
-     .     (zdthmin(i).GT.seuil) ) )THEN ! si l'inversion est trop faible
-         zl2(i)=(mixlen*MAX(0.0,(paprs(i,k)-paprs(i,klev+1))
-     .                       /(paprs(i,2)-paprs(i,klev+1)) ))**2
-         pcfm(i,k)= zl2(i)* kstable
-         pcfh(i,k) = pcfm(i,k) /prandtl ! h et m different
-      ENDIF
-      ENDDO
-      ENDDO
-c
-      RETURN
-      END
-      SUBROUTINE calbeta(dtime,indice,knon,snow,qsol,
-     .                    vbeta,vcal,vdif)
-      USE dimphy
-      IMPLICIT none
-c======================================================================
-c Auteur(s): Z.X. Li (LMD/CNRS) (adaptation du GCM du LMD)
-c date: 19940414
-c======================================================================
-c
-c Calculer quelques parametres pour appliquer la couche limite
-c ------------------------------------------------------------
-cym#include "dimensions.h"
-cym#include "dimphy.h"
-#include "YOMCST.h"
-#include "indicesol.h"
-#include "iniprint.h"
-      REAL tau_gl ! temps de relaxation pour la glace de mer
-ccc      PARAMETER (tau_gl=86400.0*30.0)
-      PARAMETER (tau_gl=86400.0*5.0)
-      REAL mx_eau_sol
-      PARAMETER (mx_eau_sol=150.0)
-c
-      REAL calsol, calsno, calice ! epaisseur du sol: 0.15 m
-      PARAMETER (calsol=1.0/(2.5578E+06*0.15))
-      PARAMETER (calsno=1.0/(2.3867E+06*0.15))
-      PARAMETER (calice=1.0/(5.1444E+06*0.15))
-C
-      INTEGER i
-c
-      REAL dtime
-      REAL snow(klon), qsol(klon)
-      INTEGER indice, knon
-C
-      REAL vbeta(klon)
-      REAL vcal(klon)
-      REAL vdif(klon)
-C
-
-      IF (indice.EQ.is_oce) THEN
-      DO i = 1, knon
-          vcal(i)   = 0.0
-          vbeta(i)  = 1.0
-          vdif(i) = 0.0
-      ENDDO
-      ENDIF
-c
-      IF (indice.EQ.is_sic) THEN
-      DO i = 1, knon
-          vcal(i) = calice
-          IF (snow(i) .GT. 0.0) vcal(i) = calsno
-          vbeta(i)  = 1.0
-          vdif(i) = 1.0/tau_gl
-ccc          vdif(i) = calice/tau_gl ! c'etait une erreur
-      ENDDO
-      ENDIF
-c
-      IF (indice.EQ.is_ter) THEN
-      DO i = 1, knon
-          vcal(i) = calsol
-          IF (snow(i) .GT. 0.0) vcal(i) = calsno
-          vbeta(i)  = MIN(2.0*qsol(i)/mx_eau_sol, 1.0)
-          vdif(i) = 0.0
-      ENDDO
-      ENDIF
-c
-      IF (indice.EQ.is_lic) THEN
-      DO i = 1, knon
-          vcal(i) = calice
-          IF (snow(i) .GT. 0.0) vcal(i) = calsno
-          vbeta(i)  = 1.0
-          vdif(i) = 0.0
-      ENDDO
-      ENDIF
-c
-      RETURN
-      END
-C======================================================================
-      SUBROUTINE nonlocal(knon, paprs, pplay,
-     .                    tsol,beta,u,v,t,q,
-     .                    cd_h, cd_m, pcfh, pcfm, cgh, cgq)
-      USE dimphy
-      IMPLICIT none
-c======================================================================
-c Laurent Li (LMD/CNRS), le 30 septembre 1998
-c Couche limite non-locale. Adaptation du code du CCM3.
-c Code non teste, donc a ne pas utiliser.
-c======================================================================
-c Nonlocal scheme that determines eddy diffusivities based on a
-c diagnosed boundary layer height and a turbulent velocity scale.
-c Also countergradient effects for heat and moisture are included.
-c
-c For more information, see Holtslag, A.A.M., and B.A. Boville, 1993:
-c Local versus nonlocal boundary-layer diffusion in a global climate
-c model. J. of Climate, vol. 6, 1825-1842.
-c======================================================================
-cym#include "dimensions.h"
-cym#include "dimphy.h"
-#include "YOMCST.h"
-#include "iniprint.h"
-c
-c Arguments:
-c
-      INTEGER knon ! nombre de points a calculer
-      REAL tsol(klon) ! temperature du sol (K)
-      REAL beta(klon) ! efficacite d'evaporation (entre 0 et 1)
-      REAL paprs(klon,klev+1) ! pression a inter-couche (Pa)
-      REAL pplay(klon,klev)   ! pression au milieu de couche (Pa)
-      REAL u(klon,klev) ! vitesse U (m/s)
-      REAL v(klon,klev) ! vitesse V (m/s)
-      REAL t(klon,klev) ! temperature (K)
-      REAL q(klon,klev) ! vapeur d'eau (kg/kg)
-      REAL cd_h(klon) ! coefficient de friction au sol pour chaleur
-      REAL cd_m(klon) ! coefficient de friction au sol pour vitesse
-c
-      INTEGER isommet
-cym      PARAMETER (isommet=klev)
-      REAL vk
-      PARAMETER (vk=0.40)
-      REAL ricr
-      PARAMETER (ricr=0.4)
-      REAL fak
-      PARAMETER (fak=8.5)
-      REAL fakn
-      PARAMETER (fakn=7.2)
-      REAL onet
-      PARAMETER (onet=1.0/3.0)
-      REAL t_coup
-      PARAMETER(t_coup=273.15)
-      REAL zkmin
-      PARAMETER (zkmin=0.01)
-      REAL betam
-      PARAMETER (betam=15.0)
-      REAL betah
-      PARAMETER (betah=15.0)
-      REAL betas
-      PARAMETER (betas=5.0)
-      REAL sffrac
-      PARAMETER (sffrac=0.1)
-      REAL binm
-      PARAMETER (binm=betam*sffrac)
-      REAL binh
-      PARAMETER (binh=betah*sffrac)
-      REAL ccon
-      PARAMETER (ccon=fak*sffrac*vk)
-c
-      REAL z(klon,klev)
-      REAL pcfm(klon,klev), pcfh(klon,klev)
-c
-      INTEGER i, k
-      REAL zxt, zxq, zxu, zxv, zxmod, taux, tauy
-      REAL zx_alf1, zx_alf2 ! parametres pour extrapolation
-      REAL khfs(klon)       ! surface kinematic heat flux [mK/s]
-      REAL kqfs(klon)       ! sfc kinematic constituent flux [m/s]
-      REAL heatv(klon)      ! surface virtual heat flux
-      REAL ustar(klon)
-      REAL rino(klon,klev)  ! bulk Richardon no. from level to ref lev
-      LOGICAL unstbl(klon)  ! pts w/unstbl pbl (positive virtual ht flx)
-      LOGICAL stblev(klon)  ! stable pbl with levels within pbl
-      LOGICAL unslev(klon)  ! unstbl pbl with levels within pbl
-      LOGICAL unssrf(klon)  ! unstb pbl w/lvls within srf pbl lyr
-      LOGICAL unsout(klon)  ! unstb pbl w/lvls in outer pbl lyr
-      LOGICAL check(klon)   ! True=>chk if Richardson no.>critcal
-      REAL pblh(klon)
-      REAL cgh(klon,2:klev) ! counter-gradient term for heat [K/m]
-      REAL cgq(klon,2:klev) ! counter-gradient term for constituents
-      REAL cgs(klon,2:klev) ! counter-gradient star (cg/flux)
-      REAL obklen(klon)
-      REAL ztvd, ztvu, zdu2
-      REAL therm(klon)      ! thermal virtual temperature excess
-      REAL phiminv(klon)    ! inverse phi function for momentum
-      REAL phihinv(klon)    ! inverse phi function for heat
-      REAL wm(klon)         ! turbulent velocity scale for momentum
-      REAL fak1(klon)       ! k*ustar*pblh
-      REAL fak2(klon)       ! k*wm*pblh
-      REAL fak3(klon)       ! fakn*wstr/wm
-      REAL pblk(klon)       ! level eddy diffusivity for momentum
-      REAL pr(klon)         ! Prandtl number for eddy diffusivities
-      REAL zl(klon)         ! zmzp / Obukhov length
-      REAL zh(klon)         ! zmzp / pblh
-      REAL zzh(klon)        ! (1-(zmzp/pblh))**2
-      REAL wstr(klon)       ! w*, convective velocity scale
-      REAL zm(klon)         ! current level height
-      REAL zp(klon)         ! current level height + one level up
-      REAL zcor, zdelta, zcvm5, zxqs
-      REAL fac, pblmin, zmzp, term
-c
-#include "YOETHF.h"
-#include "FCTTRE.h"
-c
-c Initialisation
-c
-cym
-      isommet=klev
-
-      DO i = 1, klon
-         pcfh(i,1) = cd_h(i)
-         pcfm(i,1) = cd_m(i)
-      ENDDO
-      DO k = 2, klev
-      DO i = 1, klon
-         pcfh(i,k) = zkmin
-         pcfm(i,k) = zkmin
-         cgs(i,k) = 0.0
-         cgh(i,k) = 0.0
-         cgq(i,k) = 0.0
-      ENDDO
-      ENDDO
-c
-c Calculer les hauteurs de chaque couche
-c
-      DO i = 1, knon
-         z(i,1) = RD * t(i,1) / (0.5*(paprs(i,1)+pplay(i,1)))
-     .               * (paprs(i,1)-pplay(i,1)) / RG
-      ENDDO
-      DO k = 2, klev
-      DO i = 1, knon
-         z(i,k) = z(i,k-1)
-     .              + RD * 0.5*(t(i,k-1)+t(i,k)) / paprs(i,k)
-     .                   * (pplay(i,k-1)-pplay(i,k)) / RG
-      ENDDO
-      ENDDO
-c
-      DO i = 1, knon
-         IF (thermcep) THEN
-           zdelta=MAX(0.,SIGN(1.,RTT-tsol(i)))
-           zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
-           zcvm5 = zcvm5 / RCPD / (1.0+RVTMP2*q(i,1))
-           zxqs= r2es * FOEEW(tsol(i),zdelta)/paprs(i,1)
-           zxqs=MIN(0.5,zxqs)
-           zcor=1./(1.-retv*zxqs)
-           zxqs=zxqs*zcor
-         ELSE
-           IF (tsol(i).LT.t_coup) THEN
-              zxqs = qsats(tsol(i)) / paprs(i,1)
-           ELSE
-              zxqs = qsatl(tsol(i)) / paprs(i,1)
-           ENDIF
-         ENDIF
-        zx_alf1 = 1.0
-        zx_alf2 = 1.0 - zx_alf1
-        zxt = (t(i,1)+z(i,1)*RG/RCPD/(1.+RVTMP2*q(i,1)))
-     .        *(1.+RETV*q(i,1))*zx_alf1
-     .      + (t(i,2)+z(i,2)*RG/RCPD/(1.+RVTMP2*q(i,2)))
-     .        *(1.+RETV*q(i,2))*zx_alf2
-        zxu = u(i,1)*zx_alf1+u(i,2)*zx_alf2
-        zxv = v(i,1)*zx_alf1+v(i,2)*zx_alf2
-        zxq = q(i,1)*zx_alf1+q(i,2)*zx_alf2
-        zxmod = 1.0+SQRT(zxu**2+zxv**2)
-        khfs(i) = (tsol(i)*(1.+RETV*q(i,1))-zxt) *zxmod*cd_h(i)
-        kqfs(i) = (zxqs-zxq) *zxmod*cd_h(i) * beta(i)
-        heatv(i) = khfs(i) + 0.61*zxt*kqfs(i)
-        taux = zxu *zxmod*cd_m(i)
-        tauy = zxv *zxmod*cd_m(i)
-        ustar(i) = SQRT(taux**2+tauy**2)
-        ustar(i) = MAX(SQRT(ustar(i)),0.01)
-      ENDDO
-c
-      DO i = 1, knon
-         rino(i,1) = 0.0
-         check(i) = .TRUE.
-         pblh(i) = z(i,1)
-         obklen(i) = -t(i,1)*ustar(i)**3/(RG*vk*heatv(i))
-      ENDDO
-
-C
-C PBL height calculation:
-C Search for level of pbl. Scan upward until the Richardson number between
-C the first level and the current level exceeds the "critical" value.
-C
-      fac = 100.0
-      DO k = 1, isommet
-      DO i = 1, knon
-      IF (check(i)) THEN
-         zdu2 = (u(i,k)-u(i,1))**2+(v(i,k)-v(i,1))**2+fac*ustar(i)**2
-         zdu2 = max(zdu2,1.0e-20)
-         ztvd =(t(i,k)+z(i,k)*0.5*RG/RCPD/(1.+RVTMP2*q(i,k)))
-     .         *(1.+RETV*q(i,k))
-         ztvu =(t(i,1)-z(i,k)*0.5*RG/RCPD/(1.+RVTMP2*q(i,1)))
-     .         *(1.+RETV*q(i,1))
-         rino(i,k) = (z(i,k)-z(i,1))*RG*(ztvd-ztvu)
-     .               /(zdu2*0.5*(ztvd+ztvu))
-         IF (rino(i,k).GE.ricr) THEN
-           pblh(i) = z(i,k-1) + (z(i,k-1)-z(i,k)) *
-     .              (ricr-rino(i,k-1))/(rino(i,k-1)-rino(i,k))
-           check(i) = .FALSE.
-         ENDIF
-      ENDIF
-      ENDDO
-      ENDDO
-
-C
-C Set pbl height to maximum value where computation exceeds number of
-C layers allowed
-C
-      DO i = 1, knon
-        if (check(i)) pblh(i) = z(i,isommet)
-      ENDDO
-C
-C Improve estimate of pbl height for the unstable points.
-C Find unstable points (sensible heat flux is upward):
-C
-      DO i = 1, knon
-      IF (heatv(i) .GT. 0.) THEN
-        unstbl(i) = .TRUE.
-        check(i) = .TRUE.
-      ELSE
-        unstbl(i) = .FALSE.
-        check(i) = .FALSE.
-      ENDIF
-      ENDDO
-C
-C For the unstable case, compute velocity scale and the
-C convective temperature excess:
-C
-      DO i = 1, knon
-      IF (check(i)) THEN
-        phiminv(i) = (1.-binm*pblh(i)/obklen(i))**onet
-        wm(i)= ustar(i)*phiminv(i)
-        therm(i) = heatv(i)*fak/wm(i)
-        rino(i,1) = 0.0
-      ENDIF
-      ENDDO
-C
-C Improve pblh estimate for unstable conditions using the
-C convective temperature excess:
-C
-      DO k = 1, isommet
-      DO i = 1, knon
-      IF (check(i)) THEN
-         zdu2 = (u(i,k)-u(i,1))**2+(v(i,k)-v(i,1))**2+fac*ustar(i)**2
-         zdu2 = max(zdu2,1.0e-20)
-         ztvd =(t(i,k)+z(i,k)*0.5*RG/RCPD/(1.+RVTMP2*q(i,k)))
-     .         *(1.+RETV*q(i,k))
-         ztvu =(t(i,1)+therm(i)-z(i,k)*0.5*RG/RCPD/(1.+RVTMP2*q(i,1)))
-     .         *(1.+RETV*q(i,1))
-         rino(i,k) = (z(i,k)-z(i,1))*RG*(ztvd-ztvu)
-     .               /(zdu2*0.5*(ztvd+ztvu))
-         IF (rino(i,k).GE.ricr) THEN
-           pblh(i) = z(i,k-1) + (z(i,k-1)-z(i,k)) *
-     .              (ricr-rino(i,k-1))/(rino(i,k-1)-rino(i,k))
-           check(i) = .FALSE.
-         ENDIF
-      ENDIF
-      ENDDO
-      ENDDO
-C
-C Set pbl height to maximum value where computation exceeds number of
-C layers allowed
-C
-      DO i = 1, knon
-        if (check(i)) pblh(i) = z(i,isommet)
-      ENDDO
-C
-C Points for which pblh exceeds number of pbl layers allowed;
-C set to maximum
-C
-      DO i = 1, knon
-        IF (check(i)) pblh(i) = z(i,isommet)
-      ENDDO
-C
-C PBL height must be greater than some minimum mechanical mixing depth
-C Several investigators have proposed minimum mechanical mixing depth
-C relationships as a function of the local friction velocity, u*.  We
-C make use of a linear relationship of the form h = c u* where c=700.
-C The scaling arguments that give rise to this relationship most often
-C represent the coefficient c as some constant over the local coriolis
-C parameter.  Here we make use of the experimental results of Koracin
-C and Berkowicz (1988) [BLM, Vol 43] for wich they recommend 0.07/f
-C where f was evaluated at 39.5 N and 52 N.  Thus we use a typical mid
-C latitude value for f so that c = 0.07/f = 700.
-C
-      DO i = 1, knon
-        pblmin  = 700.0*ustar(i)
-        pblh(i) = MAX(pblh(i),pblmin)
-      ENDDO
-C
-C pblh is now available; do preparation for diffusivity calculation:
-C
-      DO i = 1, knon
-        pblk(i) = 0.0
-        fak1(i) = ustar(i)*pblh(i)*vk
-C
-C Do additional preparation for unstable cases only, set temperature
-C and moisture perturbations depending on stability.
-C
-        IF (unstbl(i)) THEN
-          zxt=(t(i,1)-z(i,1)*0.5*RG/RCPD/(1.+RVTMP2*q(i,1)))
-     .         *(1.+RETV*q(i,1))
-          phiminv(i) = (1. - binm*pblh(i)/obklen(i))**onet
-          phihinv(i) = sqrt(1. - binh*pblh(i)/obklen(i))
-          wm(i)      = ustar(i)*phiminv(i)
-          fak2(i)    = wm(i)*pblh(i)*vk
-          wstr(i)    = (heatv(i)*RG*pblh(i)/zxt)**onet
-          fak3(i)    = fakn*wstr(i)/wm(i)
-        ENDIF
-      ENDDO
-
-C Main level loop to compute the diffusivities and
-C counter-gradient terms:
-C
-      DO 1000 k = 2, isommet
-C
-C Find levels within boundary layer:
-C
-        DO i = 1, knon
-          unslev(i) = .FALSE.
-          stblev(i) = .FALSE.
-          zm(i) = z(i,k-1)
-          zp(i) = z(i,k)
-          IF (zkmin.EQ.0.0 .AND. zp(i).GT.pblh(i)) zp(i) = pblh(i)
-          IF (zm(i) .LT. pblh(i)) THEN
-            zmzp = 0.5*(zm(i) + zp(i))
-            zh(i) = zmzp/pblh(i)
-            zl(i) = zmzp/obklen(i)
-            zzh(i) = 0.
-            IF (zh(i).LE.1.0) zzh(i) = (1. - zh(i))**2
-C
-C stblev for points zm < plbh and stable and neutral
-C unslev for points zm < plbh and unstable
-C
-            IF (unstbl(i)) THEN
-              unslev(i) = .TRUE.
-            ELSE
-              stblev(i) = .TRUE.
-            ENDIF
-          ENDIF
-        ENDDO
-C
-C Stable and neutral points; set diffusivities; counter-gradient
-C terms zero for stable case:
-C
-        DO i = 1, knon
-          IF (stblev(i)) THEN
-            IF (zl(i).LE.1.) THEN
-              pblk(i) = fak1(i)*zh(i)*zzh(i)/(1. + betas*zl(i))
-            ELSE
-              pblk(i) = fak1(i)*zh(i)*zzh(i)/(betas + zl(i))
-            ENDIF
-            pcfm(i,k) = pblk(i)
-            pcfh(i,k) = pcfm(i,k)
-          ENDIF
-        ENDDO
-C
-C unssrf, unstable within surface layer of pbl
-C unsout, unstable within outer   layer of pbl
-C
-        DO i = 1, knon
-          unssrf(i) = .FALSE.
-          unsout(i) = .FALSE.
-          IF (unslev(i)) THEN
-            IF (zh(i).lt.sffrac) THEN
-              unssrf(i) = .TRUE.
-            ELSE
-              unsout(i) = .TRUE.
-            ENDIF
-          ENDIF
-        ENDDO
-C
-C Unstable for surface layer; counter-gradient terms zero
-C
-        DO i = 1, knon
-          IF (unssrf(i)) THEN
-            term = (1. - betam*zl(i))**onet
-            pblk(i) = fak1(i)*zh(i)*zzh(i)*term
-            pr(i) = term/sqrt(1. - betah*zl(i))
-          ENDIF
-        ENDDO
-C
-C Unstable for outer layer; counter-gradient terms non-zero:
-C
-        DO i = 1, knon
-          IF (unsout(i)) THEN
-            pblk(i) = fak2(i)*zh(i)*zzh(i)
-            cgs(i,k) = fak3(i)/(pblh(i)*wm(i))
-            cgh(i,k) = khfs(i)*cgs(i,k)
-            pr(i) = phiminv(i)/phihinv(i) + ccon*fak3(i)/fak
-            cgq(i,k) = kqfs(i)*cgs(i,k)
-          ENDIF
-        ENDDO
-C
-C For all unstable layers, set diffusivities
-C
-        DO i = 1, knon
-        IF (unslev(i)) THEN
-            pcfm(i,k) = pblk(i)
-            pcfh(i,k) = pblk(i)/pr(i)
-        ENDIF
-        ENDDO
- 1000 continue           ! end of level loop
-
-      RETURN
-      END
Index: LMDZ4/trunk/libf/phylmd/clvent.F90
===================================================================
--- LMDZ4/trunk/libf/phylmd/clvent.F90	(revision 782)
+++ LMDZ4/trunk/libf/phylmd/clvent.F90	(revision 782)
@@ -0,0 +1,168 @@
+!
+! $Header$
+!
+MODULE mod_clvent
+
+  REAL, DIMENSION(:), ALLOCATABLE, PRIVATE   :: flux_u1
+  REAL, DIMENSION(:), ALLOCATABLE, PRIVATE   :: flux_v1
+
+CONTAINS
+
+  SUBROUTINE clvent(knon,dtime, u1lay,v1lay,coef,t,ven, &
+       paprs,pplay,delp, &
+       d_ven,flux_v)
+  
+  use dimphy
+  IMPLICIT none
+!c======================================================================
+!c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+!c Objet: diffusion vertical de la vitesse "ven"
+!c======================================================================
+!c Arguments:
+!c dtime----input-R- intervalle du temps (en second)
+!c u1lay----input-R- vent u de la premiere couche (m/s)
+!c v1lay----input-R- vent v de la premiere couche (m/s)
+!c coef-----input-R- le coefficient d'echange (m**2/s) multiplie par
+!c                   le cisaillement du vent (dV/dz); la premiere
+!c                   valeur indique la valeur de Cdrag (sans unite)
+!c t--------input-R- temperature (K)
+!c ven------input-R- vitesse horizontale (m/s)
+!c paprs----input-R- pression a inter-couche (Pa)
+!c pplay----input-R- pression au milieu de couche (Pa)
+!c delp-----input-R- epaisseur de couche (Pa)
+!c
+!c
+!c d_ven----output-R- le changement de "ven"
+!c flux_v---output-R- (diagnostic) flux du vent: (kg m/s)/(m**2 s)
+!c======================================================================
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "iniprint.h"
+  INTEGER, INTENT(IN) :: knon
+  REAL, INTENT(IN) :: dtime
+  REAL, INTENT(IN) :: u1lay(klon), v1lay(klon)
+  REAL, INTENT(IN) :: coef(klon,klev)
+  REAL, INTENT(IN) :: t(klon,klev), ven(klon,klev)
+  REAL, INTENT(IN) :: paprs(klon,klev+1), pplay(klon,klev), delp(klon,klev)
+  REAL, INTENT(OUT) :: d_ven(klon,klev)
+  REAL, INTENT(OUT) :: flux_v(klon,klev)
+!c======================================================================
+#include "YOMCST.inc"
+!c======================================================================
+  INTEGER i, k
+  REAL zx_cv(klon,2:klev)
+  REAL zx_dv(klon,2:klev)
+  REAL zx_buf(klon)
+  REAL zx_coef(klon,klev)
+  REAL local_ven(klon,klev)
+  REAL zx_alf1(klon), zx_alf2(klon)
+
+
+  d_ven(:,:) = 0.0
+  flux_v(:,:) = 0.0
+!c======================================================================
+  DO k = 1, klev
+     DO i = 1, knon
+        local_ven(i,k) = ven(i,k)
+     ENDDO
+  ENDDO
+!c======================================================================
+  DO i = 1, knon
+!ccc         zx_alf1(i) = (paprs(i,1)-pplay(i,2))/(pplay(i,1)-pplay(i,2))
+     zx_alf1(i) = 1.0
+     zx_alf2(i) = 1.0 - zx_alf1(i)
+     zx_coef(i,1) = coef(i,1) &
+          * (1.0+SQRT(u1lay(i)**2+v1lay(i)**2)) &
+          * pplay(i,1)/(RD*t(i,1)) 
+     zx_coef(i,1) = zx_coef(i,1) * dtime*RG
+  ENDDO
+!c======================================================================
+  DO k = 2, klev
+     DO i = 1, knon
+        zx_coef(i,k) = coef(i,k)*RG/(pplay(i,k-1)-pplay(i,k)) &
+             *(paprs(i,k)*2/(t(i,k)+t(i,k-1))/RD)**2
+        zx_coef(i,k) = zx_coef(i,k) * dtime*RG
+     ENDDO
+  ENDDO
+!c======================================================================
+  DO i = 1, knon
+     zx_buf(i) = delp(i,1) + zx_coef(i,1)*zx_alf1(i)+zx_coef(i,2)
+     zx_cv(i,2) = local_ven(i,1)*delp(i,1) / zx_buf(i)
+     zx_dv(i,2) = (zx_coef(i,2)-zx_alf2(i)*zx_coef(i,1)) &
+          /zx_buf(i)
+  ENDDO
+  DO k = 3, klev
+     DO i = 1, knon
+        zx_buf(i) = delp(i,k-1) + zx_coef(i,k) &
+             + zx_coef(i,k-1)*(1.-zx_dv(i,k-1))
+        zx_cv(i,k) = (local_ven(i,k-1)*delp(i,k-1) &
+             +zx_coef(i,k-1)*zx_cv(i,k-1) )/zx_buf(i)
+        zx_dv(i,k) = zx_coef(i,k)/zx_buf(i)
+     ENDDO
+  ENDDO
+  DO i = 1, knon
+     local_ven(i,klev) = ( local_ven(i,klev)*delp(i,klev) &
+          +zx_coef(i,klev)*zx_cv(i,klev) ) &
+          / ( delp(i,klev) + zx_coef(i,klev) &
+          -zx_coef(i,klev)*zx_dv(i,klev) )
+  ENDDO
+  DO k = klev-1, 1, -1
+     DO i = 1, knon
+        local_ven(i,k) = zx_cv(i,k+1) + zx_dv(i,k+1)*local_ven(i,k+1)
+     ENDDO
+  ENDDO
+!c======================================================================
+!c== flux_v est le flux de moment angulaire (positif vers bas)
+!c== dont l'unite est: (kg m/s)/(m**2 s)
+  DO i = 1, knon
+     flux_v(i,1) = zx_coef(i,1)/(RG*dtime) &
+          *(local_ven(i,1)*zx_alf1(i) &
+          +local_ven(i,2)*zx_alf2(i))
+  ENDDO
+  DO k = 2, klev
+     DO i = 1, knon
+        flux_v(i,k) = zx_coef(i,k)/(RG*dtime) &
+             * (local_ven(i,k)-local_ven(i,k-1))
+     ENDDO
+  ENDDO
+!c
+  DO k = 1, klev
+     DO i = 1, knon
+        d_ven(i,k) = local_ven(i,k) - ven(i,k)
+     ENDDO
+  ENDDO
+!c
+!      RETURN
+
+
+
+END SUBROUTINE clvent
+
+
+SUBROUTINE save_flux(klon, flux_u_in, flux_v_in)
+
+  INTEGER, INTENT(IN)                 :: klon
+  REAL, DIMENSION(klon), INTENT(IN)   :: flux_u_in
+  REAL, DIMENSION(klon), INTENT(IN)   :: flux_v_in
+
+  if (.not. allocated(flux_u1)) ALLOCATE(flux_u1(klon), flux_v1(klon))
+  
+  flux_u1(:) = flux_u_in(:)
+  flux_v1(:) = flux_v_in(:)
+
+
+END SUBROUTINE save_flux
+
+SUBROUTINE calcul_flux_vent(klon, flux_u, flux_v)
+
+  INTEGER, INTENT(IN)                  :: klon
+  ! Output
+  REAL, DIMENSION(klon), INTENT(OUT)   :: flux_u
+  REAL, DIMENSION(klon), INTENT(OUT)   :: flux_v
+
+  flux_u = flux_u1
+  flux_v = flux_v1
+
+END SUBROUTINE calcul_flux_vent
+
+END MODULE mod_clvent
Index: LMDZ4/trunk/libf/phylmd/coef_diff_turb_mod.F90
===================================================================
--- LMDZ4/trunk/libf/phylmd/coef_diff_turb_mod.F90	(revision 782)
+++ LMDZ4/trunk/libf/phylmd/coef_diff_turb_mod.F90	(revision 782)
@@ -0,0 +1,675 @@
+!
+! $Header$
+!
+MODULE coef_diff_turb_mod
+!
+! This module contains some procedures for calculation of the coefficients of the
+! turbulent diffusion in the atmosphere and coefficients for turbulent diffusion 
+! at surface(cdrag)
+!
+  USE dimphy
+  
+  IMPLICIT NONE
+  
+CONTAINS
+!
+!****************************************************************************************
+!
+  SUBROUTINE coef_diff_turb(dtime, nsrf, knon, ni, &
+       ypaprs, ypplay, yu, yv, yq, yt, yts, yrugos, yqsurf, &
+       ycoefm, ycoefh)
+! 
+! Calculate coefficients(ycoefm, ycoefh) for turbulent diffusion in the 
+! atmosphere and coefficients for turbulent diffusion at surface - cdrag
+! (ycoefm(:,1), ycoefh(:,1)).
+!
+!
+! Input arguments
+!****************************************************************************************
+    REAL, INTENT(IN)                           :: dtime
+    INTEGER, INTENT(IN)                        :: nsrf, knon
+    INTEGER, DIMENSION(klon), INTENT(IN)       :: ni
+    REAL, DIMENSION(klon,klev+1), INTENT(IN)   :: ypaprs
+    REAL, DIMENSION(klon,klev), INTENT(IN)     :: ypplay
+    REAL, DIMENSION(klon,klev), INTENT(IN)     :: yu, yv
+    REAL, DIMENSION(klon,klev), INTENT(IN)     :: yq, yt
+    REAL, DIMENSION(klon), INTENT(IN)          :: yts, yrugos, yqsurf
+  
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon,klev), INTENT(OUT)    :: ycoefh
+    REAL, DIMENSION(klon,klev), INTENT(OUT)    :: ycoefm
+
+! Local variables with attribute SAVE
+!****************************************************************************************
+    REAL, DIMENSION(:,:,:), ALLOCATABLE, SAVE  :: q2save
+    !$OMP THREADPRIVATE(q2save)
+    LOGICAL, SAVE                              :: first_call=.TRUE.
+    !$OMP THREADPRIVATE(first_call)    
+
+! Other local variables
+!****************************************************************************************
+    INTEGER                                    :: k, i, j
+    REAL, DIMENSION(klon,klev)                 :: ycoefm0, ycoefh0, yzlay, yteta
+    REAL, DIMENSION(klon,klev+1)               :: yzlev, yq2, q2diag, ykmm, ykmn, ykmq
+    REAL, DIMENSION(klon)                      :: y_cd_h, y_cd_m
+    REAL, DIMENSION(klon)                      :: yustar
+
+! Include
+!****************************************************************************************
+    INCLUDE "clesphys.inc"
+    INCLUDE "indicesol.inc"
+    INCLUDE "iniprint.h"
+    INCLUDE "compbl.h"
+    INCLUDE "YOETHF.inc"
+    INCLUDE "YOMCST.inc"
+
+!****************************************************************************************
+! Start calculation
+! - Initilalize output variables 
+!****************************************************************************************
+
+    ycoefm(:,:) = 0.0
+    ycoefh(:,:) = 0.0
+
+
+!****************************************************************************************    
+! Methode 1 :
+!
+!****************************************************************************************    
+
+    CALL coefkz(nsrf, knon, ypaprs, ypplay, &
+         ksta, ksta_ter, &
+         yts, yrugos, yu, yv, yt, yq, &
+         yqsurf, &
+         ycoefm, ycoefh)
+  
+!****************************************************************************************
+! Methode 2 :
+!
+!****************************************************************************************
+
+    IF (iflag_pbl.EQ.1) THEN
+       CALL coefkz2(nsrf, knon, ypaprs, ypplay, yt, &
+            ycoefm0, ycoefh0)
+
+       DO k = 1, klev
+          DO i = 1, knon
+             ycoefm(i,k) = MAX(ycoefm(i,k),ycoefm0(i,k))
+             ycoefh(i,k) = MAX(ycoefh(i,k),ycoefh0(i,k))
+          ENDDO
+       ENDDO
+    ENDIF
+
+!****************************************************************************************
+! IM cf JLD : on seuille ycoefm et ycoefh
+!
+!****************************************************************************************
+    IF (nsrf.EQ.is_oce) THEN
+       DO j=1,knon
+          ycoefm(j,1)=MIN(ycoefm(j,1),cdmmax)
+          ycoefh(j,1)=MIN(ycoefh(j,1),cdhmax)
+       ENDDO
+    ENDIF
+  
+!****************************************************************************************  
+! Calcul d'une diffusion minimale pour les conditions tres stables
+!
+!****************************************************************************************
+    IF (ok_kzmin) THEN
+       CALL coefkzmin(knon,ypaprs,ypplay,yu,yv,yt,yq,ycoefm, &
+            ycoefm0,ycoefh0)
+       
+       DO k = 1, klev
+          DO i = 1, knon
+             ycoefm(i,k) = MAX(ycoefm(i,k),ycoefm0(i,k))
+             ycoefh(i,k) = MAX(ycoefh(i,k),ycoefh0(i,k))
+          ENDDO
+       ENDDO
+       
+    ENDIF
+
+  
+!****************************************************************************************
+! MELLOR ET YAMADA adapte a Mars Richard Fournier et Frederic Hourdin
+! Methode 3 :
+!****************************************************************************************
+
+    IF (iflag_pbl.GE.3) THEN
+
+       IF (first_call) THEN
+          PRINT*, "Using method MELLOR&YAMADA"
+          ! NB! q2save could/should be read and written from (re)startphy.nc
+          ALLOCATE(q2save(klon,klev+1,nbsrf))
+          q2save(:,:,:) = 1.e-8
+          first_call=.FALSE.
+       END IF
+
+       yzlay(1:knon,1)= &
+            RD*yt(1:knon,1)/(0.5*(ypaprs(1:knon,1)+ypplay(1:knon,1))) &
+            *(ypaprs(1:knon,1)-ypplay(1:knon,1))/RG
+       DO k=2,klev
+          DO i = 1, knon
+             yzlay(i,k)= &
+                  yzlay(i,k-1)+RD*0.5*(yt(i,k-1)+yt(i,k)) &
+                  /ypaprs(i,k)*(ypplay(i,k-1)-ypplay(i,k))/RG
+          END DO
+       END DO
+
+       DO k=1,klev
+          DO i = 1, knon
+             yteta(i,k)= &
+                  yt(i,k)*(ypaprs(i,1)/ypplay(i,k))**RKAPPA &
+                  *(1.+0.61*yq(i,k))
+          END DO
+       END DO
+
+       yzlev(1:knon,1)=0.
+       yzlev(1:knon,klev+1)=2.*yzlay(1:knon,klev)-yzlay(1:knon,klev-1)
+       DO k=2,klev
+          DO i = 1, knon
+             yzlev(i,k)=0.5*(yzlay(i,k)+yzlay(i,k-1))
+          END DO
+       END DO
+
+! Compresse q2save
+       DO k = 1, klev+1
+          DO j = 1, knon
+             i = ni(j)
+             yq2(j,k)=q2save(i,k,nsrf)
+          ENDDO
+       ENDDO
+         
+!   Bug introduit volontairement pour converger avec les resultats
+!   du papier sur les thermiques.
+       IF (1.EQ.1) THEN
+          y_cd_m(1:knon) = ycoefm(1:knon,1)
+          y_cd_h(1:knon) = ycoefh(1:knon,1)
+       ELSE
+          y_cd_h(1:knon) = ycoefm(1:knon,1)
+          y_cd_m(1:knon) = ycoefh(1:knon,1)
+       ENDIF
+       
+       CALL ustarhb(knon,yu,yv,y_cd_m, yustar)
+     
+       IF (prt_level > 9) THEN
+          WRITE(lunout,*) 'USTAR = ',yustar
+       ENDIF
+         
+!   iflag_pbl peut etre utilise comme longuer de melange
+       IF (iflag_pbl.GE.11) THEN
+          CALL vdif_kcay(knon,dtime,RG,RD,ypaprs,yt, &
+               yzlev,yzlay,yu,yv,yteta, &
+               y_cd_m,yq2,q2diag,ykmm,ykmn,yustar, &
+               iflag_pbl)
+       ELSE
+          CALL yamada4(knon,dtime,RG,RD,ypaprs,yt, &
+               yzlev,yzlay,yu,yv,yteta, &
+               y_cd_m,yq2,ykmm,ykmn,ykmq,yustar, &
+               iflag_pbl)
+       ENDIF
+       
+       ycoefm(1:knon,1)=y_cd_m(1:knon)
+       ycoefh(1:knon,1)=y_cd_h(1:knon)
+       ycoefm(1:knon,2:klev)=ykmm(1:knon,2:klev)
+       ycoefh(1:knon,2:klev)=ykmn(1:knon,2:klev)
+                
+! update q2save with yq2
+       DO j=1,knon
+          DO k=1,klev+1
+             i=ni(j)
+             q2save(i,k,nsrf) = yq2(j,k)
+          END DO
+       END DO
+       
+    ENDIF !(iflag_pbl.ge.3)
+
+  END SUBROUTINE coef_diff_turb
+!
+!****************************************************************************************
+!
+  SUBROUTINE coefkz(nsrf, knon, paprs, pplay, &
+       ksta, ksta_ter, &
+       ts, rugos, &
+       u,v,t,q, &
+       qsurf, &
+       pcfm, pcfh)
+    
+!======================================================================
+! Auteur(s) F. Hourdin, M. Forichon, Z.X. Li (LMD/CNRS) date: 19930922
+!           (une version strictement identique a l'ancien modele)
+! Objet: calculer le coefficient du frottement du sol (Cdrag) et les
+!        coefficients d'echange turbulent dans l'atmosphere.
+! Arguments:
+! nsrf-----input-I- indicateur de la nature du sol
+! knon-----input-I- nombre de points a traiter
+! paprs----input-R- pregssion a chaque intercouche (en Pa)
+! pplay----input-R- pression au milieu de chaque couche (en Pa)
+! ts-------input-R- temperature du sol (en Kelvin)
+! rugos----input-R- longeur de rugosite (en m)
+! u--------input-R- vitesse u
+! v--------input-R- vitesse v
+! t--------input-R- temperature (K)
+! q--------input-R- vapeur d'eau (kg/kg)
+!
+! pcfm-----output-R- coefficients a calculer (vitesse)
+! pcfh-----output-R- coefficients a calculer (chaleur et humidite)
+!======================================================================
+    INCLUDE "YOETHF.inc"
+    INCLUDE "FCTTRE.inc"
+    INCLUDE "iniprint.h"
+    INCLUDE "indicesol.inc"
+    INCLUDE "compbl.h"
+    INCLUDE "YOMCST.inc"
+!
+! Arguments:
+!
+    INTEGER, INTENT(IN)                      :: knon, nsrf
+    REAL, DIMENSION(klon), INTENT(IN)        :: ts
+    REAL, DIMENSION(klon,klev+1), INTENT(IN) ::  paprs
+    REAL, DIMENSION(klon,klev), INTENT(IN)   ::  pplay
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: u, v, t, q
+    REAL, DIMENSION(klon), INTENT(IN)        :: rugos
+
+    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: pcfm, pcfh
+
+
+! Local variables
+
+! numero de couche du sommet de la couche limite
+    INTEGER, DIMENSION(klon)    :: itop
+!
+! Quelques constantes et options:
+!
+    REAL cepdu2, ckap, cb, cc, cd, clam
+    PARAMETER (cepdu2 =(0.1)**2)
+    PARAMETER (CKAP=0.4)
+    PARAMETER (cb=5.0)
+    PARAMETER (cc=5.0)
+    PARAMETER (cd=5.0)
+    PARAMETER (clam=160.0)
+    REAL ratqs ! largeur de distribution de vapeur d'eau
+    PARAMETER (ratqs=0.05)
+    LOGICAL richum ! utilise le nombre de Richardson humide
+    PARAMETER (richum=.TRUE.)
+    REAL ric ! nombre de Richardson critique
+    PARAMETER(ric=0.4)
+    REAL prandtl
+    PARAMETER (prandtl=0.4)
+    REAL kstable ! diffusion minimale (situation stable)
+    ! GKtest
+    ! PARAMETER (kstable=1.0e-10)
+    REAL ksta, ksta_ter
+!IM: 261103     REAL kstable_ter, kstable_sinon
+!IM: 211003 cf GK   PARAMETER (kstable_ter = 1.0e-6)
+!IM: 261103     PARAMETER (kstable_ter = 1.0e-8)
+!IM: 261103   PARAMETER (kstable_ter = 1.0e-10)
+!IM: 261103   PARAMETER (kstable_sinon = 1.0e-10)
+    ! fin GKtest
+    REAL mixlen ! constante controlant longueur de melange
+    PARAMETER (mixlen=35.0)
+    INTEGER isommet ! le sommet de la couche limite
+    LOGICAL tvirtu ! calculer Ri d'une maniere plus performante
+    PARAMETER (tvirtu=.TRUE.)
+    LOGICAL opt_ec ! formule du Centre Europeen dans l'atmosphere
+    PARAMETER (opt_ec=.FALSE.)
+
+!
+! Variables locales:
+
+    INTEGER i, k !IM 120704
+    REAL zgeop(klon,klev)
+    REAL zmgeom(klon)
+    REAL zri(klon)
+    REAL zl2(klon)
+    
+    REAL u1(klon), v1(klon), t1(klon), q1(klon), z1(klon)
+    REAL pcfm1(klon), pcfh1(klon)
+
+    REAL zdphi, zdu2, ztvd, ztvu, zcdn
+    REAL zscf
+    REAL zt, zq, zdelta, zcvm5, zcor, zqs, zfr, zdqs
+    REAL z2geomf, zalh2, zalm2, zscfh, zscfm
+    REAL t_coup
+    PARAMETER (t_coup=273.15)
+!IM
+    LOGICAL check
+    PARAMETER (check=.FALSE.)
+!
+! contre-gradient pour la chaleur sensible: Kelvin/metre
+    REAL gamt(2:klev)
+    REAL qsurf(klon) 
+
+    LOGICAL, SAVE :: appel1er
+    !$OMP THREADPRIVATE(appel1er)
+!
+! Fonctions thermodynamiques et fonctions d'instabilite
+    REAL fsta, fins, x
+    LOGICAL zxli ! utiliser un jeu de fonctions simples
+    PARAMETER (zxli=.FALSE.)
+
+    fsta(x) = 1.0 / (1.0+10.0*x*(1+8.0*x))
+    fins(x) = SQRT(1.0-18.0*x)
+
+    DATA appel1er /.TRUE./
+
+
+    isommet=klev
+      
+    IF (appel1er) THEN
+       IF (prt_level > 9) THEN
+          WRITE(lunout,*)'coefkz, opt_ec:', opt_ec
+          WRITE(lunout,*)'coefkz, richum:', richum
+          IF (richum) WRITE(lunout,*)'coefkz, ratqs:', ratqs
+          WRITE(lunout,*)'coefkz, isommet:', isommet
+          WRITE(lunout,*)'coefkz, tvirtu:', tvirtu
+          appel1er = .FALSE.
+       ENDIF
+    ENDIF
+!
+! Initialiser les sorties
+!
+    DO k = 1, klev
+       DO i = 1, knon
+          pcfm(i,k) = 0.0
+          pcfh(i,k) = 0.0
+       ENDDO
+    ENDDO
+    DO i = 1, knon
+       itop(i) = 0
+    ENDDO
+    
+!
+! Prescrire la valeur de contre-gradient
+!
+    IF (iflag_pbl.EQ.1) THEN
+       DO k = 3, klev
+          gamt(k) = -1.0E-03
+       ENDDO
+       gamt(2) = -2.5E-03
+    ELSE
+       DO k = 2, klev
+          gamt(k) = 0.0
+       ENDDO
+    ENDIF
+!IM cf JLD/ GKtest
+    IF ( nsrf .NE. is_oce ) THEN
+!IM 261103     kstable = kstable_ter
+       kstable = ksta_ter
+    ELSE
+!IM 261103     kstable = kstable_sinon
+       kstable = ksta
+    ENDIF
+!IM cf JLD/ GKtest fin
+
+!
+! Calculer les geopotentiels de chaque couche
+!
+    DO i = 1, knon
+       zgeop(i,1) = RD * t(i,1) / (0.5*(paprs(i,1)+pplay(i,1))) &
+            * (paprs(i,1)-pplay(i,1))
+    ENDDO
+    DO k = 2, klev
+       DO i = 1, knon
+          zgeop(i,k) = zgeop(i,k-1) &
+               + RD * 0.5*(t(i,k-1)+t(i,k)) / paprs(i,k) &
+               * (pplay(i,k-1)-pplay(i,k))
+       ENDDO
+    ENDDO
+
+!
+! Calculer le frottement au sol (Cdrag)
+!
+    DO i = 1, knon
+       u1(i) = u(i,1)
+       v1(i) = v(i,1)
+       t1(i) = t(i,1)
+       q1(i) = q(i,1)
+       z1(i) = zgeop(i,1)
+    ENDDO
+
+    CALL clcdrag(klon, knon, nsrf, zxli, &
+         u1, v1, t1, q1, z1, &
+         ts, qsurf, rugos, &
+         pcfm1, pcfh1) 
+!IM               ts, qsurf, rugos,
+
+    DO i = 1, knon
+       pcfm(i,1)=pcfm1(i)
+       pcfh(i,1)=pcfh1(i)
+    ENDDO
+!
+! Calculer les coefficients turbulents dans l'atmosphere
+!
+    DO i = 1, knon
+       itop(i) = isommet
+    ENDDO
+
+
+    DO k = 2, isommet
+       DO i = 1, knon
+          zdu2=MAX(cepdu2,(u(i,k)-u(i,k-1))**2 &
+               +(v(i,k)-v(i,k-1))**2)
+          zmgeom(i)=zgeop(i,k)-zgeop(i,k-1)
+          zdphi =zmgeom(i) / 2.0
+          zt = (t(i,k)+t(i,k-1)) * 0.5
+          zq = (q(i,k)+q(i,k-1)) * 0.5
+
+!
+! Calculer Qs et dQs/dT:
+!
+          IF (thermcep) THEN
+             zdelta = MAX(0.,SIGN(1.,RTT-zt))
+             zcvm5 = R5LES*RLVTT/RCPD/(1.0+RVTMP2*zq)*(1.-zdelta) &
+                  + R5IES*RLSTT/RCPD/(1.0+RVTMP2*zq)*zdelta
+             zqs = R2ES * FOEEW(zt,zdelta) / pplay(i,k)
+             zqs = MIN(0.5,zqs)
+             zcor = 1./(1.-RETV*zqs)
+             zqs = zqs*zcor
+             zdqs = FOEDE(zt,zdelta,zcvm5,zqs,zcor)
+          ELSE
+             IF (zt .LT. t_coup) THEN
+                zqs = qsats(zt) / pplay(i,k)
+                zdqs = dqsats(zt,zqs)
+             ELSE
+                zqs = qsatl(zt) / pplay(i,k)
+                zdqs = dqsatl(zt,zqs)
+             ENDIF
+          ENDIF
+!
+!           calculer la fraction nuageuse (processus humide):
+!
+          zfr = (zq+ratqs*zq-zqs) / (2.0*ratqs*zq)
+          zfr = MAX(0.0,MIN(1.0,zfr))
+          IF (.NOT.richum) zfr = 0.0
+!
+!           calculer le nombre de Richardson:
+!
+          IF (tvirtu) THEN
+             ztvd =( t(i,k) &
+                  + zdphi/RCPD/(1.+RVTMP2*zq) &
+                  *( (1.-zfr) + zfr*(1.+RLVTT*zqs/RD/zt)/(1.+zdqs) ) &
+                  )*(1.+RETV*q(i,k))
+             ztvu =( t(i,k-1) &
+                  - zdphi/RCPD/(1.+RVTMP2*zq) &
+                  *( (1.-zfr) + zfr*(1.+RLVTT*zqs/RD/zt)/(1.+zdqs) ) &
+                  )*(1.+RETV*q(i,k-1))
+             zri(i) =zmgeom(i)*(ztvd-ztvu)/(zdu2*0.5*(ztvd+ztvu))
+             zri(i) = zri(i) &
+                  + zmgeom(i)*zmgeom(i)/RG*gamt(k) &
+                  *(paprs(i,k)/101325.0)**RKAPPA &
+                  /(zdu2*0.5*(ztvd+ztvu))
+
+          ELSE ! calcul de Ridchardson compatible LMD5
+
+             zri(i) =(RCPD*(t(i,k)-t(i,k-1)) &
+                  -RD*0.5*(t(i,k)+t(i,k-1))/paprs(i,k) &
+                  *(pplay(i,k)-pplay(i,k-1)) &
+                  )*zmgeom(i)/(zdu2*0.5*RCPD*(t(i,k-1)+t(i,k)))
+             zri(i) = zri(i) + &
+                  zmgeom(i)*zmgeom(i)*gamt(k)/RG &
+                  *(paprs(i,k)/101325.0)**RKAPPA &
+                  /(zdu2*0.5*(t(i,k-1)+t(i,k)))
+          ENDIF
+!
+!           finalement, les coefficients d'echange sont obtenus:
+!
+          zcdn=SQRT(zdu2) / zmgeom(i) * RG
+
+          IF (opt_ec) THEN
+             z2geomf=zgeop(i,k-1)+zgeop(i,k)
+             zalm2=(0.5*ckap/RG*z2geomf &
+                  /(1.+0.5*ckap/rg/clam*z2geomf))**2
+             zalh2=(0.5*ckap/rg*z2geomf &
+                  /(1.+0.5*ckap/RG/(clam*SQRT(1.5*cd))*z2geomf))**2
+             IF (zri(i).LT.0.0) THEN  ! situation instable
+                zscf = ((zgeop(i,k)/zgeop(i,k-1))**(1./3.)-1.)**3 &
+                     / (zmgeom(i)/RG)**3 / (zgeop(i,k-1)/RG)
+                zscf = SQRT(-zri(i)*zscf)
+                zscfm = 1.0 / (1.0+3.0*cb*cc*zalm2*zscf)
+                zscfh = 1.0 / (1.0+3.0*cb*cc*zalh2*zscf)
+                pcfm(i,k)=zcdn*zalm2*(1.-2.0*cb*zri(i)*zscfm)
+                pcfh(i,k)=zcdn*zalh2*(1.-3.0*cb*zri(i)*zscfh)
+             ELSE ! situation stable
+                zscf=SQRT(1.+cd*zri(i))
+                pcfm(i,k)=zcdn*zalm2/(1.+2.0*cb*zri(i)/zscf)
+                pcfh(i,k)=zcdn*zalh2/(1.+3.0*cb*zri(i)*zscf)
+             ENDIF
+          ELSE
+             zl2(i)=(mixlen*MAX(0.0,(paprs(i,k)-paprs(i,itop(i)+1)) &
+                  /(paprs(i,2)-paprs(i,itop(i)+1)) ))**2
+             pcfm(i,k)=SQRT(MAX(zcdn*zcdn*(ric-zri(i))/ric, kstable))
+             pcfm(i,k)= zl2(i)* pcfm(i,k)
+             pcfh(i,k) = pcfm(i,k) /prandtl ! h et m different
+          ENDIF
+       ENDDO
+    ENDDO
+
+!
+! Au-dela du sommet, pas de diffusion turbulente:
+!
+    DO i = 1, knon
+       IF (itop(i)+1 .LE. klev) THEN
+          DO k = itop(i)+1, klev
+             pcfh(i,k) = 0.0
+             pcfm(i,k) = 0.0
+          ENDDO
+       ENDIF
+    ENDDO
+      
+  END SUBROUTINE coefkz
+!
+!****************************************************************************************
+!
+  SUBROUTINE coefkz2(nsrf, knon, paprs, pplay,t, &
+       pcfm, pcfh)
+
+!======================================================================
+! J'introduit un peu de diffusion sauf dans les endroits
+! ou une forte inversion est presente
+! On peut dire qu'il represente la convection peu profonde
+!
+! Arguments:
+! nsrf-----input-I- indicateur de la nature du sol
+! knon-----input-I- nombre de points a traiter
+! paprs----input-R- pression a chaque intercouche (en Pa)
+! pplay----input-R- pression au milieu de chaque couche (en Pa)
+! t--------input-R- temperature (K)
+!
+! pcfm-----output-R- coefficients a calculer (vitesse)
+! pcfh-----output-R- coefficients a calculer (chaleur et humidite)
+!======================================================================
+!
+! Arguments:
+!
+    INTEGER, INTENT(IN)                       :: knon, nsrf
+    REAL, DIMENSION(klon, klev+1), INTENT(IN) ::  paprs
+    REAL, DIMENSION(klon, klev), INTENT(IN)   ::  pplay
+    REAL, DIMENSION(klon, klev), INTENT(IN)   :: t(klon,klev)
+    
+    REAL, DIMENSION(klon, klev), INTENT(OUT)  :: pcfm, pcfh
+!
+! Quelques constantes et options:
+!
+    REAL prandtl
+    PARAMETER (prandtl=0.4)
+    REAL kstable
+    PARAMETER (kstable=0.002)
+!    PARAMETER (kstable=0.001)
+    REAL mixlen ! constante controlant longueur de melange
+    PARAMETER (mixlen=35.0)
+    REAL seuil ! au-dela l'inversion est consideree trop faible
+    PARAMETER (seuil=-0.02)
+!    PARAMETER (seuil=-0.04)
+!    PARAMETER (seuil=-0.06)
+!    PARAMETER (seuil=-0.09)
+
+!
+! Variables locales:
+!
+    INTEGER i, k, invb(knon)
+    REAL zl2(knon)
+    REAL zdthmin(knon), zdthdp
+
+    INCLUDE "indicesol.inc"
+    INCLUDE "YOMCST.inc"
+!
+! Initialiser les sorties
+!
+    DO k = 1, klev
+       DO i = 1, knon
+          pcfm(i,k) = 0.0
+          pcfh(i,k) = 0.0
+       ENDDO
+    ENDDO
+
+!
+! Chercher la zone d'inversion forte
+!
+    DO i = 1, knon
+       invb(i) = klev
+       zdthmin(i)=0.0
+    ENDDO
+    DO k = 2, klev/2-1
+       DO i = 1, knon
+          zdthdp = (t(i,k)-t(i,k+1))/(pplay(i,k)-pplay(i,k+1)) &
+               - RD * 0.5*(t(i,k)+t(i,k+1))/RCPD/paprs(i,k+1)
+          zdthdp = zdthdp * 100.0
+          IF (pplay(i,k).GT.0.8*paprs(i,1) .AND. &
+               zdthdp.LT.zdthmin(i) ) THEN
+             zdthmin(i) = zdthdp
+             invb(i) = k
+          ENDIF
+       ENDDO
+    ENDDO
+
+!
+! Introduire une diffusion:
+!
+    IF ( nsrf.EQ.is_oce ) THEN
+       DO k = 2, klev
+          DO i = 1, knon
+!IM cf FH/GK   IF ( (nsrf.NE.is_oce) .OR.  ! si ce n'est pas sur l'ocean
+!IM cf FH/GK  .     (invb(i).EQ.klev) .OR. ! s'il n'y a pas d'inversion
+      !IM cf JLD/ GKtest TERkz2
+      ! IF ( (nsrf.EQ.is_ter) .OR.  ! si on est sur la terre
+      ! fin GKtest
+
+
+! s'il n'y a pas d'inversion ou si l'inversion est trop faible
+!          IF ( (nsrf.EQ.is_oce) .AND. &
+             IF ( (invb(i).EQ.klev) .OR. (zdthmin(i).GT.seuil) ) THEN 
+                zl2(i)=(mixlen*MAX(0.0,(paprs(i,k)-paprs(i,klev+1)) &
+                     /(paprs(i,2)-paprs(i,klev+1)) ))**2
+                pcfm(i,k)= zl2(i)* kstable
+                pcfh(i,k) = pcfm(i,k) /prandtl ! h et m different
+             ENDIF
+          ENDDO
+       ENDDO
+    ENDIF
+
+  END SUBROUTINE coefkz2
+!
+!****************************************************************************************
+!
+END MODULE coef_diff_turb_mod
Index: LMDZ4/trunk/libf/phylmd/coefkzmin.F
===================================================================
--- LMDZ4/trunk/libf/phylmd/coefkzmin.F	(revision 781)
+++ LMDZ4/trunk/libf/phylmd/coefkzmin.F	(revision 782)
@@ -8,7 +8,5 @@
       IMPLICIT NONE
 
-cym#include "dimensions.h"
-cym#include "dimphy.h"
-#include "YOMCST.h"
+      include "YOMCST.h"
 
 c.......................................................................
@@ -56,17 +54,11 @@
       REAL km(klon,klev+1)
       REAL kn(klon,klev+1)
-      integer l_mix,ngrid
+      integer ngrid
 
 
       integer nlay,nlev
-cym      PARAMETER (nlay=klev)
-cym      PARAMETER (nlev=klev+1)
-
       integer ig,k
 
       real,parameter :: kap=0.4
-
-      real frif,falpha,fsm
-      real fl,zzz,zl0,zq2,zn2
 
       nlay=klev
Index: LMDZ4/trunk/libf/phylmd/cpl_mod.F90
===================================================================
--- LMDZ4/trunk/libf/phylmd/cpl_mod.F90	(revision 782)
+++ LMDZ4/trunk/libf/phylmd/cpl_mod.F90	(revision 782)
@@ -0,0 +1,1235 @@
+!
+! $Header$
+!
+MODULE cpl_mod
+!
+! This module excahanges and transforms all fields that should be recieved or sent to 
+! coupler. The transformation of the fields are done from the grid 1D-array in phylmd 
+! to the regular 2D grid accepted by the coupler. Cumulation of the fields for each 
+! timestep is done in here. 
+!
+! Each type of surface that recevie fields from the coupler have a subroutine named 
+! cpl_receive_XXX_fields and each surface that have fields to be sent to the coupler 
+! have a subroutine named cpl_send_XXX_fields.
+!
+!*************************************************************************************
+
+! Use statements
+!*************************************************************************************
+  USE dimphy, ONLY : klon, zmasq
+  USE mod_phys_lmdz_para
+  USE ioipsl
+  USE iophy
+
+! The module oasis is always used. Without the cpp key CPP_COUPLE only the parameters 
+! in the module are compiled and not the subroutines.
+  USE oasis
+  USE write_field_phy
+  
+! Global attributes
+!*************************************************************************************
+  IMPLICIT NONE
+  PRIVATE
+
+  ! All subroutine are public except cpl_send_all and cpl_receive_all
+  PUBLIC :: cpl_init, cpl_receive_ocean_fields, cpl_receive_seaice_fields, &
+       cpl_send_ocean_fields, cpl_send_seaice_fields, cpl_send_land_fields, &
+       cpl_send_landice_fields, gath2cpl
+  
+
+! Declaration of module variables
+!*************************************************************************************
+! variable for coupling period
+  INTEGER, SAVE                             :: nexca
+  !$OMP THREADPRIVATE(nexca)
+
+! variables for cumulating fields during a coupling periode :
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: cpl_sols, cpl_nsol, cpl_rain
+  !$OMP THREADPRIVATE(cpl_sols,cpl_nsol,cpl_rain)
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: cpl_snow, cpl_evap, cpl_tsol
+  !$OMP THREADPRIVATE(cpl_snow,cpl_evap,cpl_tsol)
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: cpl_fder, cpl_albe, cpl_taux
+  !$OMP THREADPRIVATE(cpl_fder,cpl_albe,cpl_taux)
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: cpl_windsp
+  !$OMP THREADPRIVATE(cpl_windsp)
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: cpl_tauy
+  !$OMP THREADPRIVATE(cpl_tauy)
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: cpl_rriv2D, cpl_rcoa2D, cpl_rlic2D
+  !$OMP THREADPRIVATE(cpl_rriv2D,cpl_rcoa2D,cpl_rlic2D)
+
+! variables read from coupler :
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: read_sst     ! sea surface temperature
+  !$OMP THREADPRIVATE(read_sst)
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: read_sit     ! sea ice temperature
+  !$OMP THREADPRIVATE(read_sit)
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: read_sic     ! sea ice fraction
+  !$OMP THREADPRIVATE(read_sic)
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: read_alb_sic ! albedo at sea ice
+  !$OMP THREADPRIVATE(read_alb_sic)
+  
+! fraction for different surface, saved during whole coupling period
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: pctsrf_sav   
+  !$OMP THREADPRIVATE(pctsrf_sav)
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: zmasq2D
+  !$OMP THREADPRIVATE(zmasq2D)
+  INTEGER, ALLOCATABLE, DIMENSION(:), SAVE  :: unity
+  !$OMP THREADPRIVATE(unity)
+  INTEGER, SAVE                             :: nidct, nidcs
+  !$OMP THREADPRIVATE(nidct,nidcs)
+
+! variables to be sent to the coupler
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE :: cpl_sols2D, cpl_nsol2D, cpl_rain2D
+  !$OMP THREADPRIVATE(cpl_sols2D, cpl_nsol2D, cpl_rain2D)
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE :: cpl_snow2D, cpl_evap2D, cpl_tsol2D
+  !$OMP THREADPRIVATE(cpl_snow2D, cpl_evap2D, cpl_tsol2D)
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE :: cpl_fder2D, cpl_albe2D
+  !$OMP THREADPRIVATE(cpl_fder2D, cpl_albe2D)
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE :: cpl_taux2D, cpl_tauy2D
+  !$OMP THREADPRIVATE(cpl_taux2D, cpl_tauy2D)
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: cpl_windsp2D
+  !$OMP THREADPRIVATE(cpl_windsp2D)
+  
+
+CONTAINS
+!
+!************************************************************************************
+!
+  SUBROUTINE cpl_init(dtime, rlon, rlat)
+
+    INCLUDE "dimensions90.h"
+    INCLUDE "indicesol.inc"
+    INCLUDE "control.inc"
+    INCLUDE "temps.inc"
+    INCLUDE "iniprint.h"
+
+! Input arguments
+!*************************************************************************************
+    REAL, INTENT(IN)                  :: dtime
+    REAL, DIMENSION(klon), INTENT(IN) :: rlon, rlat
+
+! Local variables
+!*************************************************************************************
+    INTEGER                           :: error, sum_error, ig, i
+    INTEGER                           :: jf, nhoridct
+    INTEGER                           :: nhoridcs
+    INTEGER                           :: idtime
+    INTEGER                           :: idayref
+    INTEGER                           :: npas ! only for OASIS2
+    REAL                              :: zjulian
+    REAL, DIMENSION(iim,jjm+1)        :: zx_lon, zx_lat
+    CHARACTER(len = 20)               :: modname = 'cpl_init'
+    CHARACTER(len = 80)               :: abort_message
+    CHARACTER(len=80)                 :: clintocplnam, clfromcplnam
+
+!*************************************************************************************
+! Calculate coupling period
+!
+!*************************************************************************************
+     
+    npas = itaufin/ iphysiq
+    nexca = 86400 / dtime
+    WRITE(lunout,*)' ##### Ocean couple #####'
+    WRITE(lunout,*)' Valeurs des pas de temps'
+    WRITE(lunout,*)' npas = ', npas
+    WRITE(lunout,*)' nexca = ', nexca
+    
+!*************************************************************************************
+! Allocate variables
+!
+!*************************************************************************************
+    error = 0
+    sum_error = 0
+
+    ALLOCATE(unity(klon), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(pctsrf_sav(klon,nbsrf), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_sols(klon,2), stat = error) 
+    sum_error = sum_error + error
+    ALLOCATE(cpl_nsol(klon,2), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_rain(klon,2), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_snow(klon,2), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_evap(klon,2), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_tsol(klon,2), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_fder(klon,2), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_albe(klon,2), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_taux(klon,2), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_windsp(klon,2), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_tauy(klon,2), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_rriv2D(iim,jj_nb), stat=error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_rcoa2D(iim,jj_nb), stat=error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_rlic2D(iim,jj_nb), stat=error)
+    sum_error = sum_error + error
+    ALLOCATE(read_sst(iim, jj_nb), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(read_sic(iim, jj_nb), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(read_sit(iim, jj_nb), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(read_alb_sic(iim, jj_nb), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(zmasq2D(iim, jj_nb), stat = error)
+    sum_error = sum_error + error    
+   
+
+    IF (sum_error /= 0) THEN
+       abort_message='Pb allocation variables couplees'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+!*************************************************************************************
+! Initialize the allocated varaibles
+!
+!*************************************************************************************
+    DO ig = 1, klon
+       unity(ig) = ig
+    ENDDO
+    pctsrf_sav = 0.
+
+    cpl_sols = 0.   ; cpl_nsol = 0.  ; cpl_rain = 0.   ; cpl_snow = 0.
+    cpl_evap = 0.   ; cpl_tsol = 0.  ; cpl_fder = 0.   ; cpl_albe = 0.
+    cpl_taux = 0.   ; cpl_tauy = 0.  ; cpl_rriv2D = 0. ; cpl_rcoa2D = 0.
+    cpl_rlic2D = 0. ; cpl_windsp = 0.
+
+!*************************************************************************************
+! Transform the land-ocean mask into 2D grid. 
+! Colorize zmasq2D with 99 so that after gath2cpl points not valid can be recognized. 
+!
+!*************************************************************************************
+    zmasq2D(:,:) = 99.
+    CALL gath2cpl(zmasq, zmasq2D, klon, unity)
+
+!*************************************************************************************
+! Initialize coupling
+!
+!*************************************************************************************
+    idtime = INT(dtime)
+#ifdef CPP_COUPLE
+    CALL inicma
+#endif
+
+!*************************************************************************************
+! initialize NetCDF output
+!
+!*************************************************************************************
+    IF (is_sequential) THEN
+       idayref = day_ini
+       CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
+       CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlon,zx_lon)
+       DO i = 1, iim
+          zx_lon(i,1) = rlon(i+1)
+          zx_lon(i,jjm+1) = rlon(i+1)
+       ENDDO
+       CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlat,zx_lat)
+       clintocplnam="cpl_atm_tauflx"
+       CALL histbeg(clintocplnam, iim,zx_lon(:,1),jjm+1,zx_lat(1,:),&
+            1,iim,1,jjm+1, itau_phy,zjulian,dtime,nhoridct,nidct) 
+! no vertical axis
+       CALL histdef(nidct, 'tauxe','tauxe', &
+            "-",iim, jjm+1, nhoridct, 1, 1, 1, -99, 32, "inst", dtime,dtime)
+       CALL histdef(nidct, 'tauyn','tauyn', &
+            "-",iim, jjm+1, nhoridct, 1, 1, 1, -99, 32, "inst", dtime,dtime)
+       CALL histdef(nidct, 'tmp_lon','tmp_lon', &
+            "-",iim, jjm+1, nhoridct, 1, 1, 1, -99, 32, "inst", dtime,dtime)
+       CALL histdef(nidct, 'tmp_lat','tmp_lat', &
+            "-",iim, jjm+1, nhoridct, 1, 1, 1, -99, 32, "inst", dtime,dtime)
+       DO jf=1,jpflda2o1 + jpflda2o2
+          CALL histdef(nidct, cl_writ(jf),cl_writ(jf), &
+               "-",iim, jjm+1, nhoridct, 1, 1, 1, -99, 32, "inst", dtime,dtime)
+       END DO
+       CALL histend(nidct)
+       CALL histsync(nidct)
+       
+       clfromcplnam="cpl_atm_sst"
+       CALL histbeg(clfromcplnam, iim,zx_lon(:,1),jjm+1,zx_lat(1,:),1,iim,1,jjm+1, &
+            0,zjulian,dtime,nhoridcs,nidcs) 
+! no vertical axis
+       DO jf=1,jpfldo2a
+          CALL histdef(nidcs, cl_read(jf),cl_read(jf), &
+               "-",iim, jjm+1, nhoridcs, 1, 1, 1, -99, 32, "inst", dtime,dtime)
+       END DO
+       CALL histend(nidcs)
+       CALL histsync(nidcs)
+
+    ENDIF    ! is_sequential
+    
+  END SUBROUTINE cpl_init
+  
+!
+!*************************************************************************************
+!
+
+  SUBROUTINE cpl_receive_all(itime, dtime, pctsrf)
+! This subroutine reads from coupler for both ocean and seaice
+! 4 fields : read_sst, read_sic, read_sit and read_alb_sic. 
+
+    INCLUDE "indicesol.inc"
+    INCLUDE "temps.inc"
+    INCLUDE "iniprint.h"
+    INCLUDE "YOMCST.inc"
+    INCLUDE "dimensions90.h"
+
+! Input arguments
+!************************************************************************************
+    INTEGER, INTENT(IN)                     :: itime
+    REAL, INTENT(IN)                        :: dtime
+    REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf
+
+! Local variables
+!************************************************************************************
+    INTEGER                                 :: j, ig, il_time_secs
+    INTEGER                                 :: itau_w
+    INTEGER, DIMENSION(iim*(jjm+1))         :: ndexcs
+    CHARACTER(len = 20)                     :: modname = 'cpl_receive_all'
+    CHARACTER(len = 80)                     :: abort_message
+    REAL, DIMENSION(klon)                   :: read_sic1D
+    REAL, DIMENSION(iim,jj_nb,jpfldo2a)  :: tab_read_flds
+    REAL, DIMENSION(iim,jj_nb)           :: read_sic
+
+!*************************************************************************************
+! Start calculation
+! Get fields from coupler
+!
+!*************************************************************************************
+
+#ifdef CPP_COUPLE
+    il_time_secs=(itime-1)*dtime
+    CALL fromcpl(il_time_secs, tab_read_flds)
+#endif
+    
+! NetCDF output of received fields
+    IF (is_sequential) THEN
+       ndexcs(:) = 0
+       itau_w = itau_phy + itime
+       DO ig = 1, jpfldo2a
+          CALL histwrite(nidcs,cl_read(ig),itau_w,tab_read_flds(:,:,ig),iim*(jjm+1),ndexcs)
+       END DO
+    ENDIF
+
+! Save each field in a 2D array. 
+    read_sst(:,:)     = tab_read_flds(:,:,1)  ! Sea surface temperature
+    read_sic(:,:)     = tab_read_flds(:,:,2)  ! Sea ice concentration
+    read_alb_sic(:,:) = tab_read_flds(:,:,3)  ! Albedo at sea ice
+    read_sit(:,:)     = tab_read_flds(:,:,4)  ! Sea ice temperature
+
+!*************************************************************************************
+! Temperature and albedo are weighted with the fraction of sea-ice(read-sic)
+!
+!*************************************************************************************
+    DO j = 1, jj_nb
+       DO ig = 1, iim
+          IF (ABS(1. - read_sic(ig,j)) < 0.00001) THEN
+             read_sst(ig,j) = RTT - 1.8
+             read_sit(ig,j) = read_sit(ig,j) / read_sic(ig,j)
+             read_alb_sic(ig,j) = read_alb_sic(ig,j) / read_sic(ig,j)
+          ELSE IF (ABS(read_sic(ig,j)) < 0.00001) THEN
+             read_sst(ig,j) = read_sst(ig,j) / (1. - read_sic(ig,j))
+             read_sit(ig,j) = read_sst(ig,j)
+             read_alb_sic(ig,j) =  0.6
+          ELSE
+             read_sst(ig,j) = read_sst(ig,j) / (1. - read_sic(ig,j))
+             read_sit(ig,j) = read_sit(ig,j) / read_sic(ig,j)
+             read_alb_sic(ig,j) = read_alb_sic(ig,j) / read_sic(ig,j)
+          ENDIF
+       ENDDO
+    ENDDO
+    
+!*************************************************************************************
+!  Transform seaice fraction, read_sic into pctsrf_sav
+!
+!*************************************************************************************
+    CALL cpl2gath(read_sic, read_sic1D, klon, unity)
+
+    DO ig = 1, klon
+       ! treatment only of ocean and/or seaice points
+       IF (pctsrf(ig,is_oce) > epsfra .OR. &
+            pctsrf(ig,is_sic) > epsfra) THEN
+          pctsrf_sav(ig,is_sic) = (pctsrf(ig,is_oce) + pctsrf(ig,is_sic)) &
+               * read_sic1D(ig)
+          pctsrf_sav(ig,is_oce) = (pctsrf(ig,is_oce) + pctsrf(ig,is_sic)) &
+               - pctsrf_sav(ig,is_sic)
+       ENDIF
+    ENDDO
+
+!*************************************************************************************
+! To avoid round up problems
+!
+!*************************************************************************************
+    WHERE (ABS(pctsrf_sav(:,is_sic)) .LE. 2.*EPSILON(pctsrf_sav(1,is_sic)))
+       pctsrf_sav(:,is_sic) = 0.
+       pctsrf_sav(:,is_oce) = pctsrf(:,is_oce) + pctsrf(:,is_sic)
+    ENDWHERE
+    WHERE (ABS(pctsrf_sav(:,is_oce)) .LE. 2.*EPSILON(pctsrf_sav(1,is_oce)))
+       pctsrf_sav(:,is_sic) = pctsrf(:,is_oce) + pctsrf(:,is_sic)
+       pctsrf_sav(:,is_oce) = 0.
+    ENDWHERE
+    IF (MINVAL(pctsrf_sav(:,is_oce)) < 0.) THEN
+       WRITE(*,*)'Pb fraction ocean inferieure a 0'
+       WRITE(*,*)'au point ',MINLOC(pctsrf_sav(:,is_oce))
+       WRITE(*,*)'valeur = ',MINVAL(pctsrf_sav(:,is_oce)) 
+       abort_message = 'voir ci-dessus'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    IF (MINVAL(pctsrf_sav(:,is_sic)) < 0.) THEN
+       WRITE(*,*)'Pb fraction glace inferieure a 0'
+       WRITE(*,*)'au point ',MINLOC(pctsrf_sav(:,is_sic))
+       WRITE(*,*)'valeur = ',MINVAL(pctsrf_sav(:,is_sic)) 
+       abort_message = 'voir ci-dessus'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+        
+  END SUBROUTINE cpl_receive_all
+!
+!*************************************************************************************
+! 
+  SUBROUTINE cpl_receive_ocean_fields(itime, dtime, knon, knindex, pctsrf, &
+       tsurf_new, pctsrf_oce)
+!
+! This routine reads, if first time step in a coupling period, all fields reveived from
+! coupler for all types of surfaces. It returns the fields for the ocean surface which
+! are the sea surface temperature and the fraction of ocean. 
+! The fields are transformed into 1D arrays with valid points : 
+! tsurf_new(1:knon), pctsrf(1:klon).
+!
+    INCLUDE "indicesol.inc"
+
+! Input arguments
+!*************************************************************************************
+    INTEGER, INTENT(IN)                     :: itime
+    REAL, INTENT(IN)                        :: dtime
+    INTEGER, INTENT(IN)                     :: knon
+    INTEGER, DIMENSION(klon), INTENT(IN)    :: knindex
+    REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf
+
+! Output arguments
+!*************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)      :: tsurf_new
+    REAL, DIMENSION(klon), INTENT(OUT)      :: pctsrf_oce
+
+!*************************************************************************************
+! If first time step in a coupling period receive all fields for all types
+! of surfaces from coupler : read_sst, read_sit, read_alb_sic and pctsrf_sav. 
+! 
+!*************************************************************************************
+
+    IF (MOD(itime, nexca) == 1) CALL cpl_receive_all(itime, dtime, pctsrf)
+
+
+!*************************************************************************************
+! Transform read_sst into compressed 1D variable tsurf_new
+!
+!*************************************************************************************
+    CALL cpl2gath(read_sst, tsurf_new, knon, knindex)
+    pctsrf_oce(:) = pctsrf_sav(:,is_oce) 
+
+
+  END SUBROUTINE cpl_receive_ocean_fields
+!
+!*************************************************************************************
+!
+  SUBROUTINE cpl_receive_seaice_fields(knon, knindex, &
+       tsurf_new, alb_new, pctsrf_sic)
+!
+! This routine returns the fields for the seaice that have been read from the coupler
+! (done earlier with cpl_receive_ocean_fields). These fields are the temperature and 
+! albedo at sea ice surface and fraction of sea ice.
+! The fields are transformed into  1D arrays with valid points : 
+! tsurf_new(1:knon), alb_new(1:knon), pctsrf(1:klon).
+!
+    INCLUDE "indicesol.inc"
+
+! Input arguments
+!*************************************************************************************
+    INTEGER, INTENT(IN)                     :: knon
+    INTEGER, DIMENSION(klon), INTENT(IN)    :: knindex
+
+! Output arguments
+!*************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)      :: tsurf_new
+    REAL, DIMENSION(klon), INTENT(OUT)      :: alb_new
+    REAL, DIMENSION(klon), INTENT(OUT)      :: pctsrf_sic
+
+
+!*************************************************************************************
+! Transform fields read from coupler from 2D into compressed 1D variables
+!
+!*************************************************************************************
+    CALL cpl2gath(read_sit, tsurf_new, knon, knindex)
+    CALL cpl2gath(read_alb_sic, alb_new, knon, knindex)
+    pctsrf_sic(:) = pctsrf_sav(:,is_sic) 
+
+  END SUBROUTINE cpl_receive_seaice_fields
+
+!
+!*************************************************************************************
+!
+
+  SUBROUTINE cpl_send_ocean_fields(itime, knon, knindex, &
+       swdown, lwdown, fluxlat, fluxsens, &
+       precip_rain, precip_snow, evap, tsurf, fder, albsol, taux, tauy, windsp)
+!
+! This subroutine cumulates some fields for each time-step during a coupling 
+! period. At last time-step in a coupling period the fields are transformed to the 
+! grid accepted by the coupler. No sending to the coupler will be done from here 
+! (it is done in cpl_send_seaice_fields).
+!
+    INCLUDE "indicesol.inc"
+    INCLUDE "dimensions90.h"
+
+! Input arguments
+!*************************************************************************************
+    INTEGER, INTENT(IN)                     :: itime
+    INTEGER, INTENT(IN)                     :: knon
+    INTEGER, DIMENSION(klon), INTENT(IN)    :: knindex
+    REAL, DIMENSION(klon), INTENT(IN)       :: swdown, lwdown 
+    REAL, DIMENSION(klon), INTENT(IN)       :: fluxlat, fluxsens
+    REAL, DIMENSION(klon), INTENT(IN)       :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)       :: evap, tsurf, fder, albsol
+    REAL, DIMENSION(klon), INTENT(IN)       :: taux, tauy, windsp
+
+! Local variables
+!*************************************************************************************
+    INTEGER                                 :: cpl_index, ig 
+    INTEGER                                 :: error, sum_error
+    CHARACTER(len = 25)                     :: modname = 'cpl_send_ocean_fields'
+    CHARACTER(len = 80)                     :: abort_message
+
+!*************************************************************************************
+! Start calculation
+! The ocean points are saved with second array index=1
+!
+!*************************************************************************************
+    cpl_index = 1
+
+!*************************************************************************************
+! Reset fields to zero in the beginning of a new coupling period 
+!
+!*************************************************************************************
+    IF (MOD(itime, nexca) == 1) THEN
+       cpl_sols(:,cpl_index) = 0.0
+       cpl_nsol(:,cpl_index) = 0.0
+       cpl_rain(:,cpl_index) = 0.0
+       cpl_snow(:,cpl_index) = 0.0
+       cpl_evap(:,cpl_index) = 0.0
+       cpl_tsol(:,cpl_index) = 0.0
+       cpl_fder(:,cpl_index) = 0.0
+       cpl_albe(:,cpl_index) = 0.0
+       cpl_taux(:,cpl_index) = 0.0
+       cpl_tauy(:,cpl_index) = 0.0
+       cpl_windsp(:,cpl_index) = 0.0
+    ENDIF
+       
+!*************************************************************************************
+! Cumulate at each time-step
+!
+!*************************************************************************************    
+    DO ig = 1, knon
+       cpl_sols(ig,cpl_index) = cpl_sols(ig,cpl_index) + &
+            swdown(ig)      / FLOAT(nexca)
+       cpl_nsol(ig,cpl_index) = cpl_nsol(ig,cpl_index) + &
+            (lwdown(ig) + fluxlat(ig) +fluxsens(ig)) / FLOAT(nexca)
+       cpl_rain(ig,cpl_index) = cpl_rain(ig,cpl_index) + &
+            precip_rain(ig) / FLOAT(nexca)
+       cpl_snow(ig,cpl_index) = cpl_snow(ig,cpl_index) + &
+            precip_snow(ig) / FLOAT(nexca)
+       cpl_evap(ig,cpl_index) = cpl_evap(ig,cpl_index) + &
+            evap(ig)        / FLOAT(nexca)
+       cpl_tsol(ig,cpl_index) = cpl_tsol(ig,cpl_index) + &
+            tsurf(ig)       / FLOAT(nexca)
+       cpl_fder(ig,cpl_index) = cpl_fder(ig,cpl_index) + &
+            fder(ig)        / FLOAT(nexca)
+       cpl_albe(ig,cpl_index) = cpl_albe(ig,cpl_index) + &
+            albsol(ig)      / FLOAT(nexca)
+       cpl_taux(ig,cpl_index) = cpl_taux(ig,cpl_index) + &
+            taux(ig)        / FLOAT(nexca)
+       cpl_tauy(ig,cpl_index) = cpl_tauy(ig,cpl_index) + &
+            tauy(ig)        / FLOAT(nexca)      
+       cpl_windsp(ig,cpl_index) = cpl_windsp(ig,cpl_index) + &
+            windsp(ig)      / FLOAT(nexca) 
+    ENDDO
+
+!*************************************************************************************
+! If the time-step corresponds to the end of coupling period the 
+! fields are transformed to the 2D grid. 
+! No sending to the coupler (it is done from cpl_send_seaice_fields).
+!
+!*************************************************************************************
+    IF (MOD(itime, nexca) == 0) THEN
+
+       IF (.NOT. ALLOCATED(cpl_sols2D)) THEN
+          sum_error = 0
+          ALLOCATE(cpl_sols2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_nsol2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_rain2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_snow2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_evap2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_tsol2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_fder2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_albe2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_taux2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_tauy2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_windsp2D(iim,jj_nb), stat=error)
+          sum_error = sum_error + error
+          
+          IF (sum_error /= 0) THEN
+             abort_message='Pb allocation variables couplees pour l''ecriture'
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+       ENDIF
+       
+
+       CALL gath2cpl(cpl_sols(1,cpl_index), cpl_sols2D(1,1,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_nsol(1,cpl_index), cpl_nsol2D(1,1,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_rain(1,cpl_index), cpl_rain2D(1,1,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_snow(1,cpl_index), cpl_snow2D(1,1,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_evap(1,cpl_index), cpl_evap2D(1,1,cpl_index), &
+            knon, knindex)
+
+! cpl_tsol2D(:,:,:) not used!
+       CALL gath2cpl(cpl_tsol(1,cpl_index), cpl_tsol2D(1,1, cpl_index), &
+            knon, knindex)
+
+! cpl_fder2D(:,:,1) not used, only cpl_fder(:,:,2)!
+       CALL gath2cpl(cpl_fder(1,cpl_index), cpl_fder2D(1,1,cpl_index), &
+            knon, knindex)
+
+! cpl_albe2D(:,:,:) not used!
+       CALL gath2cpl(cpl_albe(1,cpl_index), cpl_albe2D(1,1,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_taux(1,cpl_index), cpl_taux2D(1,1,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_tauy(1,cpl_index), cpl_tauy2D(1,1,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_windsp(1,cpl_index), cpl_windsp2D(1,1), &
+            knon, knindex)
+
+    ENDIF
+
+  END SUBROUTINE cpl_send_ocean_fields
+
+!
+!*************************************************************************************
+!
+
+  SUBROUTINE cpl_send_seaice_fields(itime, dtime, knon, knindex, &
+       pctsrf, lafin, rlon, rlat, &
+       swdown, lwdown, fluxlat, fluxsens, &
+       precip_rain, precip_snow, evap, tsurf, fder, albsol, taux, tauy)
+!
+! This subroutine cumulates some fields for each time-step during a coupling 
+! period. At last time-step in a coupling period the fields are transformed to the 
+! grid accepted by the coupler. All fields for all types of surfaces are sent to
+! the coupler.
+!
+    INCLUDE "indicesol.inc"
+    INCLUDE "dimensions90.h"
+
+! Input arguments
+!*************************************************************************************
+    INTEGER, INTENT(IN)                     :: itime
+    INTEGER, INTENT(IN)                     :: knon
+    INTEGER, DIMENSION(klon), INTENT(IN)    :: knindex
+    REAL, INTENT(IN)                        :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)       :: rlon, rlat
+    REAL, DIMENSION(klon), INTENT(IN)       :: swdown, lwdown 
+    REAL, DIMENSION(klon), INTENT(IN)       :: fluxlat, fluxsens
+    REAL, DIMENSION(klon), INTENT(IN)       :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)       :: evap, tsurf, fder
+    REAL, DIMENSION(klon), INTENT(IN)       :: albsol, taux, tauy
+    REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf
+    LOGICAL, INTENT(IN)                     :: lafin
+
+! Local variables
+!*************************************************************************************
+    INTEGER                                 :: cpl_index, ig 
+    INTEGER                                 :: error, sum_error
+    CHARACTER(len = 25)                     :: modname = 'cpl_send_seaice_fields'
+    CHARACTER(len = 80)                     :: abort_message
+
+
+!*************************************************************************************
+! Start calulation
+! The sea-ice points are saved with second array index=2
+!
+!*************************************************************************************
+    cpl_index = 2
+
+!*************************************************************************************
+! Reset fields to zero in the beginning of a new coupling period 
+!
+!*************************************************************************************
+    IF (MOD(itime, nexca) == 1) THEN
+       cpl_sols(:,cpl_index) = 0.0
+       cpl_nsol(:,cpl_index) = 0.0
+       cpl_rain(:,cpl_index) = 0.0
+       cpl_snow(:,cpl_index) = 0.0
+       cpl_evap(:,cpl_index) = 0.0
+       cpl_tsol(:,cpl_index) = 0.0
+       cpl_fder(:,cpl_index) = 0.0
+       cpl_albe(:,cpl_index) = 0.0
+       cpl_taux(:,cpl_index) = 0.0
+       cpl_tauy(:,cpl_index) = 0.0
+    ENDIF
+       
+!*************************************************************************************
+! Cumulate at each time-step
+!
+!*************************************************************************************    
+    DO ig = 1, knon
+       cpl_sols(ig,cpl_index) = cpl_sols(ig,cpl_index) + &
+            swdown(ig)      / FLOAT(nexca)
+       cpl_nsol(ig,cpl_index) = cpl_nsol(ig,cpl_index) + &
+            (lwdown(ig) + fluxlat(ig) +fluxsens(ig)) / FLOAT(nexca)
+       cpl_rain(ig,cpl_index) = cpl_rain(ig,cpl_index) + &
+            precip_rain(ig) / FLOAT(nexca)
+       cpl_snow(ig,cpl_index) = cpl_snow(ig,cpl_index) + &
+            precip_snow(ig) / FLOAT(nexca)
+       cpl_evap(ig,cpl_index) = cpl_evap(ig,cpl_index) + &
+            evap(ig)        / FLOAT(nexca)
+       cpl_tsol(ig,cpl_index) = cpl_tsol(ig,cpl_index) + &
+            tsurf(ig)       / FLOAT(nexca)
+       cpl_fder(ig,cpl_index) = cpl_fder(ig,cpl_index) + &
+            fder(ig)        / FLOAT(nexca)
+       cpl_albe(ig,cpl_index) = cpl_albe(ig,cpl_index) + &
+            albsol(ig)      / FLOAT(nexca)
+       cpl_taux(ig,cpl_index) = cpl_taux(ig,cpl_index) + &
+            taux(ig)        / FLOAT(nexca)
+       cpl_tauy(ig,cpl_index) = cpl_tauy(ig,cpl_index) + &
+            tauy(ig)        / FLOAT(nexca)      
+    ENDDO
+
+!*************************************************************************************
+! If the time-step corresponds to the end of coupling period the 
+! fields are transformed to the 2D grid and all fields are sent to coupler.
+!
+!*************************************************************************************
+    IF (MOD(itime, nexca) == 0) THEN
+       IF (.NOT. ALLOCATED(cpl_sols2D)) THEN
+          sum_error = 0
+          ALLOCATE(cpl_sols2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_nsol2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_rain2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_snow2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_evap2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_tsol2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_fder2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_albe2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_taux2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_tauy2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_windsp2D(iim,jj_nb), stat=error)
+          sum_error = sum_error + error
+          
+          IF (sum_error /= 0) THEN
+             abort_message='Pb allocation variables couplees pour l''ecriture'
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+       ENDIF
+
+       CALL gath2cpl(cpl_sols(1,cpl_index), cpl_sols2D(1,1,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_nsol(1,cpl_index), cpl_nsol2D(1,1,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_rain(1,cpl_index), cpl_rain2D(1,1,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_snow(1,cpl_index), cpl_snow2D(1,1,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_evap(1,cpl_index), cpl_evap2D(1,1,cpl_index), &
+            knon, knindex)
+
+! cpl_tsol2D(:,:,:) not used!
+       CALL gath2cpl(cpl_tsol(1,cpl_index), cpl_tsol2D(1,1, cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_fder(1,cpl_index), cpl_fder2D(1,1,cpl_index), &
+            knon, knindex)
+
+! cpl_albe2D(:,:,:) not used!
+       CALL gath2cpl(cpl_albe(1,cpl_index), cpl_albe2D(1,1,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_taux(1,cpl_index), cpl_taux2D(1,1,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_tauy(1,cpl_index), cpl_tauy2D(1,1,cpl_index), &
+            knon, knindex)
+
+       ! Send all fields
+       CALL cpl_send_all(itime, dtime, pctsrf, lafin, rlon, rlat)
+    ENDIF
+
+  END SUBROUTINE cpl_send_seaice_fields
+
+!
+!*************************************************************************************
+!
+
+  SUBROUTINE cpl_send_land_fields(itime, knon, knindex, rriv_in, rcoa_in)
+!
+! This subroutine cumulates some fields for each time-step during a coupling 
+! period. At last time-step in a coupling period the fields are transformed to the 
+! grid accepted by the coupler. No sending to the coupler will be done from here 
+! (it is done in cpl_send_seaice_fields).
+!
+    INCLUDE "dimensions90.h"
+
+! Input arguments
+!*************************************************************************************
+    INTEGER, INTENT(IN)                       :: itime
+    INTEGER, INTENT(IN)                       :: knon
+    INTEGER, DIMENSION(klon), INTENT(IN)      :: knindex
+    REAL, DIMENSION(klon), INTENT(IN)         :: rriv_in
+    REAL, DIMENSION(klon), INTENT(IN)         :: rcoa_in
+
+! Local variables
+!*************************************************************************************
+    REAL, DIMENSION(iim,jj_nb)             :: rriv2D
+    REAL, DIMENSION(iim,jj_nb)             :: rcoa2D
+
+!*************************************************************************************
+! Rearrange fields in 2D variables 
+! First initialize to zero to avoid unvalid points causing problems
+!
+!*************************************************************************************
+    rriv2D(:,:) = 0.0
+    rcoa2D(:,:) = 0.0
+    CALL gath2cpl(rriv_in, rriv2D, knon, knindex)
+    CALL gath2cpl(rcoa_in, rcoa2D, knon, knindex)
+
+!*************************************************************************************
+! Reset cumulated fields to zero in the beginning of a new coupling period 
+!
+!*************************************************************************************
+    IF (MOD(itime, nexca) == 1) THEN
+       cpl_rriv2D(:,:) = 0.0
+       cpl_rcoa2D(:,:) = 0.0
+    ENDIF
+
+!*************************************************************************************
+! Cumulate : Following fields should be cumulated at each time-step
+!
+!*************************************************************************************    
+    cpl_rriv2D(:,:) = cpl_rriv2D(:,:) + rriv2D(:,:) / FLOAT(nexca)
+    cpl_rcoa2D(:,:) = cpl_rcoa2D(:,:) + rcoa2D(:,:) / FLOAT(nexca)
+
+  END SUBROUTINE cpl_send_land_fields
+
+!
+!*************************************************************************************
+!
+
+  SUBROUTINE cpl_send_landice_fields(itime, knon, knindex, rlic_in)
+! This subroutine cumulates the field for melting ice for each time-step 
+! during a coupling period. This routine will not send to coupler. Sending 
+! will be done in cpl_send_seaice_fields.
+!
+    INCLUDE "dimensions90.h"
+    
+! Input varibales
+!*************************************************************************************
+    INTEGER, INTENT(IN)                       :: itime
+    INTEGER, INTENT(IN)                       :: knon
+    INTEGER, DIMENSION(klon), INTENT(IN)      :: knindex
+    REAL, DIMENSION(klon), INTENT(IN)         :: rlic_in
+
+! Local varibales
+!*************************************************************************************
+    REAL, DIMENSION(iim,jj_nb)             :: rlic2D
+
+!*************************************************************************************
+! Rearrange field in a 2D variable 
+! First initialize to zero to avoid unvalid points causing problems
+!
+!*************************************************************************************
+    rlic2D(:,:) = 0.0
+    CALL gath2cpl(rlic_in, rlic2D, knon, knindex)
+
+!*************************************************************************************
+! Reset field to zero in the beginning of a new coupling period 
+!
+!*************************************************************************************
+    IF (MOD(itime, nexca) == 1) THEN
+       cpl_rlic2D(:,:) = 0.0
+    ENDIF
+
+!*************************************************************************************
+! Cumulate : Melting ice should be cumulated at each time-step
+!
+!*************************************************************************************    
+    cpl_rlic2D(:,:) = cpl_rlic2D(:,:) + rlic2D(:,:) / FLOAT(nexca)
+
+  END SUBROUTINE cpl_send_landice_fields
+
+!
+!*************************************************************************************
+!
+
+  SUBROUTINE cpl_send_all(itime, dtime, pctsrf, lafin, rlon, rlat)
+! This routine will send fields for all different surfaces to the coupler.
+! This subroutine should be executed after calculations by the last surface(sea-ice),
+! all calculations at the different surfaces have to be done before. 
+!    
+! Some includes
+!*************************************************************************************
+    INCLUDE "indicesol.inc"
+    INCLUDE "temps.inc"
+    INCLUDE "dimensions90.h"
+    
+! Input arguments
+!*************************************************************************************
+    INTEGER, INTENT(IN)                                  :: itime
+    REAL, INTENT(IN)                                     :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)                    :: rlon, rlat
+    REAL, DIMENSION(klon,nbsrf), INTENT(IN)              :: pctsrf
+    LOGICAL, INTENT(IN)                                  :: lafin
+    
+! Local variables
+!*************************************************************************************
+    INTEGER                                              :: error, sum_error, j
+    INTEGER                                              :: itau_w
+    INTEGER                                              :: il_time_secs
+    INTEGER, DIMENSION(iim*(jjm+1))                      :: ndexct
+    REAL                                                 :: Up, Down
+    REAL, DIMENSION(iim, jj_nb)                       :: tmp_lon, tmp_lat
+    REAL, DIMENSION(iim, jj_nb, 4)                    :: pctsrf2D
+    REAL, DIMENSION(iim, jj_nb)                       :: deno
+    CHARACTER(len = 20)                                  :: modname = 'cpl_send_all'
+    CHARACTER(len = 80)                                  :: abort_message
+   
+! Variables with fields to coupler
+    REAL, DIMENSION(iim, jj_nb)                       :: tmp_taux
+    REAL, DIMENSION(iim, jj_nb)                       :: tmp_tauy
+    REAL, DIMENSION(iim, jj_nb)                       :: tmp_calv
+! Table with all fields to send to coupler
+    REAL, DIMENSION(iim, jj_nb, jpflda2o1+jpflda2o2)  :: tab_flds
+#ifdef CPP_PARA
+    INCLUDE 'mpif.h'
+    INTEGER, DIMENSION(MPI_STATUS_SIZE)                  :: status
+#endif
+
+! End definitions
+!*************************************************************************************
+    
+
+
+!*************************************************************************************
+! All fields are stored in a table tab_flds(:,:,:)
+! First store the fields 7 to 18 which are already on the right format
+!
+!*************************************************************************************
+    tab_flds(:,:,7)  = cpl_windsp2D(:,:)
+    tab_flds(:,:,8)  = cpl_sols2D(:,:,2)
+    tab_flds(:,:,9)  = cpl_sols2D(:,:,1)
+    tab_flds(:,:,10) = cpl_nsol2D(:,:,2)
+    tab_flds(:,:,11) = cpl_nsol2D(:,:,1)
+    tab_flds(:,:,12) = cpl_fder2D(:,:,2)
+    tab_flds(:,:,13) = cpl_evap2D(:,:,2)
+    tab_flds(:,:,14) = cpl_evap2D(:,:,1)
+    tab_flds(:,:,17) = cpl_rcoa2D(:,:)
+    tab_flds(:,:,18) = cpl_rriv2D(:,:)
+    
+!*************************************************************************************
+! Transform the fraction of sub-surfaces from 1D to 2D array
+!
+!*************************************************************************************
+    pctsrf2D(:,:,:) = 0.
+    CALL gath2cpl(pctsrf(:,is_oce), pctsrf2D(:,:,is_oce), klon, unity)
+    CALL gath2cpl(pctsrf(:,is_sic), pctsrf2D(:,:,is_sic), klon, unity)
+    CALL gath2cpl(pctsrf(:,is_lic), pctsrf2D(:,:,is_lic), klon, unity)
+
+!*************************************************************************************
+! Calculate the average calving per latitude
+! Store calving in tab_flds(:,:,19)
+! 
+!*************************************************************************************      
+    DO j = 1, jj_nb
+       tmp_calv(:,j) = DOT_PRODUCT (cpl_rlic2D(1:iim,j), &
+            pctsrf2D(1:iim,j,is_lic)) / REAL(iim)
+    ENDDO
+    
+    
+    IF (is_parallel) THEN
+       IF (.NOT. is_north_pole) THEN
+#ifdef CPP_PARA
+          CALL MPI_RECV(Up,1,MPI_REAL_LMDZ,mpi_rank-1,1234,COMM_LMDZ_PHY,status,error)
+          CALL MPI_SEND(tmp_calv(1,1),1,MPI_REAL_LMDZ,mpi_rank-1,1234,COMM_LMDZ_PHY,error)
+#endif
+       ENDIF
+       
+       IF (.NOT. is_south_pole) THEN
+#ifdef CPP_PARA
+          CALL MPI_SEND(tmp_calv(1,jj_nb),1,MPI_REAL_LMDZ,mpi_rank+1,1234,COMM_LMDZ_PHY,error)
+          CALL MPI_RECV(down,1,MPI_REAL_LMDZ,mpi_rank+1,1234,COMM_LMDZ_PHY,status,error)
+#endif
+       ENDIF
+       
+       IF (.NOT. is_north_pole .AND. ii_begin /=1) THEN
+          Up=Up+tmp_calv(iim,1)
+          tmp_calv(:,1)=Up
+       ENDIF
+       
+       IF (.NOT. is_south_pole .AND. ii_end /= iim) THEN
+          Down=Down+tmp_calv(1,jj_nb)
+          tmp_calv(:,jj_nb)=Down	 
+       ENDIF
+    ENDIF
+      
+
+    tab_flds(:,:,19) = tmp_calv(:,:)
+
+!*************************************************************************************
+! Calculate total flux for snow, rain and wind with weighted addition using the 
+! fractions of ocean and seaice.
+!
+! Store the fields for rain and snow directly in tab_flds(:,:,15) and 
+! tab_flds(:,:,16) respectively.
+!
+!*************************************************************************************    
+    tab_flds(:,:,15) = 0.0
+    tab_flds(:,:,16) = 0.0
+    tmp_taux(:,:)    = 0.0
+    tmp_tauy(:,:)    = 0.0
+    
+    ! For all valid grid cells not entier land
+    WHERE (zmasq2D /= 1. .AND. zmasq2D /=99. )
+       deno =  pctsrf2D(:,:,is_oce) + pctsrf2D(:,:,is_sic) ! fraction oce+seaice
+       
+       tab_flds(:,:,15) = cpl_rain2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno +    &
+            cpl_rain2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno
+       tab_flds(:,:,16) = cpl_snow2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno +    &
+            cpl_snow2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno
+       
+       tmp_taux = cpl_taux2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno +    &
+            cpl_taux2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno
+       tmp_tauy = cpl_tauy2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno +    &
+            cpl_tauy2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno
+    ENDWHERE
+
+!*************************************************************************************
+! Transform the wind components from local atmospheric 2D coordinates to geocentric 
+! 3D coordinates. 
+! Store the resulting wind components in tab_flds(:,:,1:6)
+!*************************************************************************************
+
+! Transform the longitudes and latitudes on 2D arrays
+    CALL Grid1DTo2D_mpi(rlon,tmp_lon)
+    CALL Grid1DTo2D_mpi(rlat,tmp_lat)
+    
+    IF (is_sequential) THEN
+       IF (is_north_pole) tmp_lon(:,1)     = tmp_lon(:,2)
+       IF (is_south_pole) tmp_lon(:,jjm+1) = tmp_lon(:,jjm)
+    ENDIF
+      
+! NetCDF output of the wind before transformation of coordinate system
+    IF (is_sequential) THEN
+       ndexct(:) = 0
+       itau_w = itau_phy + itime
+       CALL histwrite(nidct,'tauxe',itau_w,tmp_taux,iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,'tauyn',itau_w,tmp_tauy,iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,'tmp_lon',itau_w,tmp_lon,iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,'tmp_lat',itau_w,tmp_lat,iim*(jjm+1),ndexct)
+    ENDIF
+
+! Transform the wind from local atmospheric 2D coordinates to geocentric 
+! 3D coordinates 
+    CALL atm2geo (iim, jj_nb, tmp_taux, tmp_tauy, tmp_lon, tmp_lat, &
+         tab_flds(:,:,1), tab_flds(:,:,2), tab_flds(:,:,3) )
+    
+    tab_flds(:,:,4)  = tab_flds(:,:,1)
+    tab_flds(:,:,5)  = tab_flds(:,:,2)
+    tab_flds(:,:,6)  = tab_flds(:,:,3)
+
+!*************************************************************************************
+! NetCDF output of all fields just before sending to coupler.
+!
+!*************************************************************************************
+    IF (is_sequential) THEN
+       CALL histwrite(nidct,cl_writ(8), itau_w,tab_flds(:,:,8), iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(9), itau_w,tab_flds(:,:,9), iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(10),itau_w,tab_flds(:,:,10),iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(11),itau_w,tab_flds(:,:,11),iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(12),itau_w,tab_flds(:,:,12),iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(13),itau_w,tab_flds(:,:,13),iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(14),itau_w,tab_flds(:,:,14),iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(15),itau_w,tab_flds(:,:,15),iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(16),itau_w,tab_flds(:,:,16),iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(17),itau_w,tab_flds(:,:,17),iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(18),itau_w,tab_flds(:,:,18),iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(19),itau_w,tab_flds(:,:,19),iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(1), itau_w,tab_flds(:,:,1), iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(2), itau_w,tab_flds(:,:,2), iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(3), itau_w,tab_flds(:,:,3), iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(4), itau_w,tab_flds(:,:,4), iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(5), itau_w,tab_flds(:,:,5), iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(6), itau_w,tab_flds(:,:,6), iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(7), itau_w,tab_flds(:,:,7), iim*(jjm+1),ndexct)
+       CALL histsync(nidct)
+    ENDIF
+
+
+!*************************************************************************************
+! Send the table of all fields
+!
+!*************************************************************************************
+#ifdef CPP_COUPLE
+    il_time_secs=(itime-1)*dtime
+    CALL intocpl(il_time_secs, lafin, tab_flds(:,:,:))
+#endif
+
+!*************************************************************************************
+! Finish with some dellocate
+!
+!*************************************************************************************  
+    sum_error=0
+    DEALLOCATE(cpl_sols2D, cpl_nsol2D, cpl_rain2D, cpl_snow2D, stat=error )
+    sum_error = sum_error + error
+    DEALLOCATE(cpl_evap2D, cpl_tsol2D, cpl_fder2D, cpl_albe2D, stat=error )
+    sum_error = sum_error + error
+    DEALLOCATE(cpl_taux2D, cpl_tauy2D, cpl_windsp2D, stat=error )
+    sum_error = sum_error + error
+    IF (sum_error /= 0) THEN
+       abort_message='Pb in deallocation of cpl_xxxx2D coupling variables'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    
+  END SUBROUTINE cpl_send_all
+!
+!*************************************************************************************
+!
+  SUBROUTINE cpl2gath(champ_in, champ_out, knon, knindex)
+! Cette routine ecrit un champ 'gathered' sur la grille 2D pour le passer
+! au coupleur.
+!
+! 
+! input:         
+!   champ_in     champ sur la grille gathere        
+!   knon         nombre de points dans le domaine a traiter
+!   knindex      index des points de la surface a traiter
+!
+! output:
+!   champ_out    champ sur la grille 2D
+!
+    INCLUDE "dimensions90.h"
+
+! Input
+    INTEGER, INTENT(IN)                       :: knon
+    REAL, DIMENSION(iim,jj_nb), INTENT(IN)    :: champ_in
+    INTEGER, DIMENSION(klon), INTENT(IN)      :: knindex
+
+! Output
+    REAL, DIMENSION(klon), INTENT(OUT)        :: champ_out
+
+! Local
+    INTEGER                                   :: i, ig
+    REAL, DIMENSION(klon)                     :: tamp
+
+!*************************************************************************************
+!
+! Transform from 2 dimensions (iim,jj_nb) to 1 dimension (klon)
+    CALL Grid2Dto1D_mpi(champ_in,tamp)
+
+! Compress from klon to knon
+    DO i = 1, knon
+       ig = knindex(i)
+       champ_out(i) = tamp(ig)
+    ENDDO
+
+  END SUBROUTINE cpl2gath
+!
+!*************************************************************************************
+!
+  SUBROUTINE gath2cpl(champ_in, champ_out, knon, knindex)
+! Cette routine ecrit un champ 'gathered' sur la grille 2D pour le passer
+! au coupleur.
+!
+! input:         
+!   champ_in     champ sur la grille gathere        
+!   knon         nombre de points dans le domaine a traiter
+!   knindex      index des points de la surface a traiter
+!
+! output:
+!   champ_out    champ sur la grille 2D
+!
+    INCLUDE "dimensions90.h"
+    
+! Input arguments
+!*************************************************************************************
+    INTEGER, INTENT(IN)                    :: knon
+    REAL, DIMENSION(klon), INTENT(IN)      :: champ_in
+    INTEGER, DIMENSION(klon), INTENT(IN)   :: knindex
+
+! Output arguments
+!*************************************************************************************
+    REAL, DIMENSION(iim,jj_nb), INTENT(OUT) :: champ_out
+
+! Local variables
+!*************************************************************************************
+    INTEGER                                :: i, ig
+    REAL, DIMENSION(klon)                  :: tamp
+
+!*************************************************************************************
+
+! Decompress from knon to klon
+    tamp = 0.
+    DO i = 1, knon
+       ig = knindex(i)
+       tamp(ig) = champ_in(i)
+    ENDDO
+
+! Transform from 1 dimension (klon) to 2 dimensions (iim,jj_nb)
+    CALL Grid1Dto2D_mpi(tamp,champ_out)
+    
+    IF (is_north_pole) champ_out(:,1)=tamp(1)
+    IF (is_south_pole) champ_out(:,jj_nb)=tamp(klon)
+    
+  END SUBROUTINE gath2cpl
+!
+!*************************************************************************************
+!
+END MODULE cpl_mod
+
Index: LMDZ4/trunk/libf/phylmd/fonte_neige_mod.F90
===================================================================
--- LMDZ4/trunk/libf/phylmd/fonte_neige_mod.F90	(revision 782)
+++ LMDZ4/trunk/libf/phylmd/fonte_neige_mod.F90	(revision 782)
@@ -0,0 +1,343 @@
+!
+! $Header$
+!
+MODULE fonte_neige_mod
+!
+! This module will treat the process of snow, melting, accumulating, calving, in 
+! case of simplified soil model.
+!
+!****************************************************************************************
+  USE dimphy, ONLY : klon
+
+  IMPLICIT NONE
+  SAVE
+
+! run_off_ter and run_off_lic are the runoff at the compressed grid knon for 
+! land and land-ice respectively
+! Note: run_off_lic is used in mod_landice and therfore not private
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE    :: run_off_ter
+  !$OMP THREADPRIVATE(run_off_ter)
+  REAL, ALLOCATABLE, DIMENSION(:)             :: run_off_lic
+  !$OMP THREADPRIVATE(run_off_lic)
+
+! run_off_lic_0 is the runoff at land-ice a time-step earlier, on the global 1D array grid
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE    :: run_off_lic_0
+  !$OMP THREADPRIVATE(run_off_lic_0)
+  
+  REAL, PRIVATE                               :: tau_calv  
+  !$OMP THREADPRIVATE(tau_calv)
+  REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE  :: ffonte_global
+  !$OMP THREADPRIVATE(ffonte_global)
+  REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE  :: fqfonte_global
+  !$OMP THREADPRIVATE(fqfonte_global)
+  REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE  :: fqcalving_global
+  !$OMP THREADPRIVATE(fqcalving_global)
+
+CONTAINS
+!
+!****************************************************************************************
+!
+  SUBROUTINE fonte_neige_init(restart_runoff)
+
+! This subroutine allocates and initialize variables in the module. 
+! The variable run_off_lic_0 is initialized to the field read from
+! restart file. The other variables are initialized to zero.
+!
+    INCLUDE "indicesol.inc"
+!****************************************************************************************
+! Input argument
+    REAL, DIMENSION(klon), INTENT(IN) :: restart_runoff 
+
+! Local variables
+    INTEGER                           :: error
+    CHARACTER (len = 80)              :: abort_message 
+    CHARACTER (len = 20)              :: modname = 'fonte_neige_init'
+
+
+!****************************************************************************************
+! Allocate run-off at landice and initilize with field read from restart
+!
+!****************************************************************************************
+
+    ALLOCATE(run_off_lic_0(klon), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation run_off_lic'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    run_off_lic_0(:) = restart_runoff(:) 
+
+!****************************************************************************************
+! Allocate other variables and initilize to zero
+!
+!****************************************************************************************
+    ALLOCATE(run_off_ter(klon), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation run_off_ter'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    run_off_ter(:) = 0.
+    
+    ALLOCATE(run_off_lic(klon), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation run_off_lic'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    run_off_lic(:) = 0.
+    
+    ALLOCATE(ffonte_global(klon,nbsrf))
+    IF (error /= 0) THEN
+       abort_message='Pb allocation ffonte_global'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    ffonte_global(:,:) = 0.0
+
+    ALLOCATE(fqfonte_global(klon,nbsrf))
+    IF (error /= 0) THEN
+       abort_message='Pb allocation fqfonte_global'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    fqfonte_global(:,:) = 0.0
+
+    ALLOCATE(fqcalving_global(klon,nbsrf))
+    IF (error /= 0) THEN
+       abort_message='Pb allocation fqcalving_global'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    fqcalving_global(:,:) = 0.0
+
+!****************************************************************************************
+! Read tau_calv
+!
+!****************************************************************************************
+    CALL conf_interface(tau_calv)
+
+
+  END SUBROUTINE fonte_neige_init
+!
+!****************************************************************************************
+!
+  SUBROUTINE fonte_neige( knon, nisurf, knindex, dtime, &
+       tsurf, precip_rain, precip_snow, &
+       snow, qsol, tsurf_new, evap)
+        
+! Routine de traitement de la fonte de la neige dans le cas du traitement
+! de sol simplifie!
+! LF 03/2001
+! input:
+!   knon         nombre de points a traiter
+!   nisurf       surface a traiter
+!   knindex      index des mailles valables pour surface a traiter
+!   dtime        
+!   tsurf        temperature de surface
+!   precip_rain  precipitations liquides
+!   precip_snow  precipitations solides
+!
+! input/output:
+!   snow         champs hauteur de neige
+!   qsol         hauteur d'eau contenu dans le sol
+!   tsurf_new    temperature au sol
+!   evap
+!
+  INCLUDE "indicesol.inc"
+  INCLUDE "dimensions90.h"
+  INCLUDE "YOETHF.inc"
+  INCLUDE "YOMCST.inc"
+  INCLUDE "FCTTRE.inc"
+  INCLUDE "clesphys.inc"
+
+! Input variables
+!****************************************************************************************
+    INTEGER, INTENT(IN)                  :: knon
+    INTEGER, INTENT(IN)                  :: nisurf
+    INTEGER, DIMENSION(klon), INTENT(IN) :: knindex
+    REAL   , INTENT(IN)                  :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)    :: tsurf
+    REAL, DIMENSION(klon), INTENT(IN)    :: precip_rain
+    REAL, DIMENSION(klon), INTENT(IN)    :: precip_snow
+    
+! Input/Output variables
+!****************************************************************************************
+
+    REAL, DIMENSION(klon), INTENT(INOUT) :: snow
+    REAL, DIMENSION(klon), INTENT(INOUT) :: qsol
+    REAL, DIMENSION(klon), INTENT(INOUT) :: tsurf_new
+    REAL, DIMENSION(klon), INTENT(INOUT) :: evap
+
+! Local variables
+!****************************************************************************************
+
+    INTEGER               :: i, j
+    REAL                  :: fq_fonte
+    REAL                  :: coeff_rel
+    REAL, PARAMETER       :: snow_max=3000.
+    REAL, PARAMETER       :: max_eau_sol = 150.0
+!! PB temporaire en attendant mieux pour le modele de neige
+! REAL, parameter :: chasno = RLMLT/(2.3867E+06*0.15)
+    REAL, PARAMETER       :: chasno = 3.334E+05/(2.3867E+06*0.15)
+!IM cf JLD/ GKtest
+    REAL, PARAMETER       :: chaice = 3.334E+05/(2.3867E+06*0.15)
+! fin GKtest
+    REAL, DIMENSION(klon) :: ffonte
+    REAL, DIMENSION(klon) :: fqcalving, fqfonte
+    REAL, DIMENSION(klon) :: d_ts
+    REAL, DIMENSION(klon) :: bil_eau_s, snow_evap
+
+    LOGICAL               :: neige_fond
+
+!****************************************************************************************
+! Start calculation
+! - Initialization
+!
+!****************************************************************************************
+    coeff_rel = dtime/(tau_calv * rday)
+    
+    bil_eau_s(:) = 0.
+
+!****************************************************************************************
+! - Increment snow due to precipitation and evaporation
+! - Calculate the water balance due to precipitation and evaporation (bil_eau_s)
+!
+!****************************************************************************************
+    WHERE (precip_snow > 0.) 
+       snow = snow + (precip_snow * dtime)
+    END WHERE
+
+    snow_evap = 0.
+    WHERE (evap > 0. ) 
+       snow_evap = MIN (snow / dtime, evap) 
+       snow = snow - snow_evap * dtime
+       snow = MAX(0.0, snow)
+    END WHERE
+    
+    bil_eau_s(:) = (precip_rain(:) * dtime) - (evap(:) - snow_evap(:)) * dtime
+
+
+!****************************************************************************************
+! - Calculate melting snow
+! - Calculate calving and decrement snow, if there are to much snow
+! - Update temperature at surface
+!
+!****************************************************************************************
+
+    ffonte(:) = 0.0
+    fqcalving(:) = 0.0
+    fqfonte(:) = 0.0
+    DO i = 1, knon
+       ! Y'a-t-il fonte de neige?
+       neige_fond = ((snow(i) > epsfra .OR. nisurf == is_sic .OR. nisurf == is_lic) &
+            .AND. tsurf_new(i) >= RTT)
+       IF (neige_fond) THEN
+          fq_fonte     = MIN( MAX((tsurf_new(i)-RTT )/chasno,0.0),snow(i))
+          ffonte(i)    = fq_fonte * RLMLT/dtime
+          fqfonte(i)   = fq_fonte/dtime
+          snow(i)      = MAX(0., snow(i) - fq_fonte)
+          bil_eau_s(i) = bil_eau_s(i) + fq_fonte 
+          tsurf_new(i) = tsurf_new(i) - fq_fonte * chasno  
+
+!IM cf JLD OK     
+!IM cf JLD/ GKtest fonte aussi pour la glace
+          IF (nisurf == is_sic .OR. nisurf == is_lic ) THEN
+             fq_fonte = MAX((tsurf_new(i)-RTT )/chaice,0.0)
+             ffonte(i) = ffonte(i) + fq_fonte * RLMLT/dtime
+             IF ( ok_lic_melt ) THEN
+                fqfonte(i) = fqfonte(i) + fq_fonte/dtime
+                bil_eau_s(i) = bil_eau_s(i) + fq_fonte
+             ENDIF
+             tsurf_new(i) = RTT
+          ENDIF
+          d_ts(i) = tsurf_new(i) - tsurf(i)
+       ENDIF
+
+       ! s'il y a une hauteur trop importante de neige, elle s'coule
+       fqcalving(i) = MAX(0., snow(i) - snow_max)/dtime
+       snow(i)=MIN(snow(i),snow_max)
+    END DO
+
+
+    IF (nisurf == is_ter) THEN
+       DO i = 1, knon
+          qsol(i) = qsol(i) + bil_eau_s(i)
+          run_off_ter(i) = run_off_ter(i) + MAX(qsol(i) - max_eau_sol, 0.0)
+          qsol(i) = MIN(qsol(i), max_eau_sol) 
+       END DO
+    ELSE IF (nisurf == is_lic) THEN
+       DO i = 1, knon
+          j = knindex(i)
+          run_off_lic(i)   = (coeff_rel *  fqcalving(i)) + &
+               (1. - coeff_rel) * run_off_lic_0(j)
+          run_off_lic_0(j) = run_off_lic(i)
+          run_off_lic(i)   = run_off_lic(i) + fqfonte(i)/dtime
+       END DO
+    ENDIF
+    
+!****************************************************************************************
+! Save ffonte, fqfonte and fqcalving in global arrays for each 
+! sub-surface separately
+!
+!****************************************************************************************
+    DO i = 1, knon
+       ffonte_global(knindex(i),nisurf)    = ffonte(i)
+       fqfonte_global(knindex(i),nisurf)   = fqfonte(i)
+       fqcalving_global(knindex(i),nisurf) = fqcalving(i)
+    ENDDO
+
+  END SUBROUTINE fonte_neige
+!
+!****************************************************************************************
+!
+  SUBROUTINE fonte_neige_final(restart_runoff)
+!
+! This subroutine returns run_off_lic_0 for later writing to restart file.
+!
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT) :: restart_runoff
+
+!****************************************************************************************
+! Set the output variables
+    restart_runoff(:) = run_off_lic_0(:)
+
+! Deallocation of all varaibles in the module
+    DEALLOCATE(run_off_lic_0, run_off_ter, run_off_lic, ffonte_global, &
+         fqfonte_global, fqcalving_global)
+
+  END SUBROUTINE fonte_neige_final
+!
+!****************************************************************************************
+!
+  SUBROUTINE fonte_neige_get_vars(pctsrf, fqcalving_out, &
+       fqfonte_out, ffonte_out)
+
+! Cumulate ffonte, fqfonte and fqcalving respectively for
+! all type of surfaces according to their fraction.
+!
+! This routine is called from physiq.F before histwrite.
+
+    INCLUDE "indicesol.inc"
+!****************************************************************************************
+    REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf
+
+    REAL, DIMENSION(klon), INTENT(OUT)      :: fqcalving_out
+    REAL, DIMENSION(klon), INTENT(OUT)      :: fqfonte_out
+    REAL, DIMENSION(klon), INTENT(OUT)      :: ffonte_out
+
+    INTEGER   :: nisurf
+!****************************************************************************************
+
+    ffonte_out(:)    = 0.0
+    fqfonte_out(:)   = 0.0
+    fqcalving_out(:) = 0.0
+
+    DO nisurf = 1, nbsrf
+       ffonte_out(:) = ffonte_out(:) + ffonte_global(:,nisurf)*pctsrf(:,nisurf)
+       fqfonte_out(:) = fqfonte_out(:) + fqfonte_global(:,nisurf)*pctsrf(:,nisurf)
+       fqcalving_out(:) = fqcalving_out(:) + fqcalving_global(:,nisurf)*pctsrf(:,nisurf)
+    ENDDO
+
+  END SUBROUTINE fonte_neige_get_vars
+!
+!****************************************************************************************
+!
+END MODULE fonte_neige_mod
+
+
+
Index: LMDZ4/trunk/libf/phylmd/inc_cpl.h
===================================================================
--- LMDZ4/trunk/libf/phylmd/inc_cpl.h	(revision 781)
+++ 	(revision )
@@ -1,26 +1,0 @@
-!
-! $Header$
-!
-!
-!
-! -- inc_cpl.h   1998-04
-!    **********
-!@
-!@  Contents : variables describing pipe and field names
-!@  --------
-!@
-!@ -- cl_write  : for fields to write
-!@
-!@ -- cl_read  : for fields to read
-!@
-!     -------------------------------------------------------------------
-!
-      INTEGER jpread, jpwrit
-      PARAMETER (jpread=0, jpwrit=1)
-#ifndef CPP_PSMILE
-      CHARACTER*8 cl_writ(jpmaxfld), cl_read(jpmaxfld)
-      CHARACTER*8 cl_f_writ(jpmaxfld), cl_f_read(jpmaxfld)
-      COMMON / comcpl / cl_writ, cl_read, cl_f_writ, cl_f_read
-!$OMP THREADPRIVATE(/comcpl/)
-#endif
-!     -------------------------------------------------------------------
Index: LMDZ4/trunk/libf/phylmd/inc_sipc.h
===================================================================
--- LMDZ4/trunk/libf/phylmd/inc_sipc.h	(revision 781)
+++ 	(revision )
@@ -1,27 +1,0 @@
-!
-! $Header$
-!
-C
-C -- inc_sipc.h   97-08-11   Version 2.0   Author: S&A
-C    **********
-C@
-C@  Contents : variables describing pools formed of shared memory segments 
-C@  --------
-C@
-C@ -- mpoolinit(r/w) : handles associated to model pools for passing initial info
-C@
-C@ -- mpoolwrit : handles associated to pools used to pass fields exchanged 
-C@               from model to coupler (see libsipc/SIPC_Write_Model.f)
-C@
-C@ -- mpoolread : handles associated to pools used to pass fields exchanged
-C@               from model to coupler (see libsipc/SIPC_Read_Model.f) 
-C@ 
-C     -------------------------------------------------------------------
-C
-      INTEGER  mpoolinitr
-      INTEGER  mpoolinitw
-      INTEGER  mpoolwrit(jpmaxfld)
-      INTEGER  mpoolread(jpmaxfld)
-      COMMON / compool / mpoolinitr, mpoolinitw, mpoolwrit, mpoolread
-c$OMP THREADPRIVATE(/compool/)
-C     -------------------------------------------------------------------
Index: LMDZ4/trunk/libf/phylmd/ini_histrac.h
===================================================================
--- LMDZ4/trunk/libf/phylmd/ini_histrac.h	(revision 781)
+++ LMDZ4/trunk/libf/phylmd/ini_histrac.h	(revision 782)
@@ -23,5 +23,5 @@
 
          zsto = pdtphys
-         zout = pdtphys * FLOAT(ecrit_tra)
+         zout = pdtphys * ecrit_tra
 c
          CALL histdef(nid_tra, "phis", "Surface geop. height", "-",
Index: LMDZ4/trunk/libf/phylmd/interface_surf.F90
===================================================================
--- LMDZ4/trunk/libf/phylmd/interface_surf.F90	(revision 781)
+++ 	(revision )
@@ -1,3729 +1,0 @@
-!
-! $Header$
-!
-
-  MODULE interface_surf
-
-! Ce module regroupe toutes les routines gerant l'interface entre le modele 
-! atmospherique et les modeles de surface (sols continentaux, oceans, glaces)
-! Les routines sont les suivantes:
-!
-!   interfsurf_*: routines d'aiguillage vers les interfaces avec les 
-!                 differents modeles de surface
-!   interfsol\
-!             > routines d'interface proprement dite
-!   interfoce/
-!
-!   interfstart: routine d'initialisation et de lecture de l'etat initial
-!                "interface"
-!   interffin  : routine d'ecriture de l'etat de redemmarage de l'interface
-!
-! 
-! L. Fairhead, LMD, 02/2000
-
-!ym  USE ioipsl
-
-  IMPLICIT none
-
-  PRIVATE
-  PUBLIC :: interfsurf,interfsurf_hq, gath2cpl 
-
-  INTERFACE interfsurf
-    module procedure interfsurf_hq, interfsurf_vent
-  END INTERFACE
-
-  INTERFACE interfoce
-    module procedure interfoce_cpl, interfoce_slab, interfoce_lim
-  END INTERFACE
-
-#include "YOMCST.inc"
-#include "indicesol.inc"
-!IM
-#include "clesphys.inc"
-
-! run_off      ruissellement total
-  REAL, ALLOCATABLE, DIMENSION(:),SAVE    :: run_off, run_off_lic
-!$OMP THREADPRIVATE(run_off, run_off_lic)
-  real, allocatable, dimension(:),save    :: coastalflow, riverflow
-!$OMP THREADPRIVATE(coastalflow, riverflow)
-!!$PB
-  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE :: tmp_rriv, tmp_rcoa,tmp_rlic
-!$OMP THREADPRIVATE(tmp_rriv, tmp_rcoa,tmp_rlic)
-!! pour simuler la fonte des glaciers antarctiques
-  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE :: coeff_iceberg
-!$OMP THREADPRIVATE(coeff_iceberg)
-  real, save                              :: surf_maille 
-!$OMP THREADPRIVATE(surf_maille)
-  real, save                              :: cte_flux_iceberg = 6.3e7
-!$OMP THREADPRIVATE(cte_flux_iceberg)  
-  integer, save                           :: num_antarctic = 1
-!$OMP THREADPRIVATE(num_antarctic)
-  REAL, save                              :: tau_calv
-!$OMP THREADPRIVATE(tau_calv)
-!!$
-  CONTAINS
-!
-!############################################################################
-!
-  SUBROUTINE interfsurf_hq(itime, dtime, date0, jour, rmu0, &
-      & klon, iim, jjm, nisurf, knon, knindex, pctsrf, &
-      & rlon, rlat, cufi, cvfi,&
-      & debut, lafin, ok_veget, soil_model, nsoilmx, tsoil, qsol,&
-      & zlev,  u1_lay, v1_lay, temp_air, spechum, epot_air, ccanopy, & 
-      & tq_cdrag, petAcoef, peqAcoef, petBcoef, peqBcoef, &
-      & precip_rain, precip_snow, sollw, sollwdown, swnet, swdown, &
-      & fder, taux, tauy, &
-! -- LOOP
-      & windsp, &
-! -- LOOP
-      & rugos, rugoro, &
-      & albedo, snow, qsurf, &
-      & tsurf, p1lay, ps, radsol, &
-      & ocean, npas, nexca, zmasq, &
-      & evap, fluxsens, fluxlat, dflux_l, dflux_s, &              
-      & tsol_rad, tsurf_new, alb_new, alblw, emis_new, &
-      & z0_new, pctsrf_new, agesno,fqcalving,fqfonte,ffonte, run_off_lic_0,&
-!IM "slab" ocean
-      & flux_o, flux_g, tslab, seaice)
-
-
-   USE mod_phys_lmdz_para
-! Cette routine sert d'aiguillage entre l'atmosphere et la surface en general 
-! (sols continentaux, oceans, glaces) pour les fluxs de chaleur et d'humidite.
-! En pratique l'interface se fait entre la couche limite du modele 
-! atmospherique (clmain.F) et les routines de surface (sechiba, oasis, ...)
-!
-! 
-! L.Fairhead 02/2000
-!
-! input:
-!   itime        numero du pas de temps
-!   klon         nombre total de points de grille
-!   iim, jjm     nbres de pts de grille
-!   dtime        pas de temps de la physique (en s)
-!   date0        jour initial 
-!   jour         jour dans l'annee en cours,
-!   rmu0         cosinus de l'angle solaire zenithal
-!   nexca        pas de temps couplage
-!   nisurf       index de la surface a traiter (1 = sol continental)
-!   knon         nombre de points de la surface a traiter
-!   knindex      index des points de la surface a traiter
-!   pctsrf       tableau des pourcentages de surface de chaque maille
-!   rlon         longitudes
-!   rlat         latitudes
-!   cufi,cvfi    resolution des mailles en x et y (m)
-!   debut        logical: 1er appel a la physique
-!   lafin        logical: dernier appel a la physique
-!   ok_veget     logical: appel ou non au schema de surface continental
-!                     (si false calcul simplifie des fluxs sur les continents)
-!   zlev         hauteur de la premiere couche
-!   u1_lay       vitesse u 1ere couche
-!   v1_lay       vitesse v 1ere couche
-!   temp_air     temperature de l'air 1ere couche
-!   spechum      humidite specifique 1ere couche
-!   epot_air     temp potentielle de l'air
-!   ccanopy      concentration CO2 canopee
-!   tq_cdrag     cdrag
-!   petAcoef     coeff. A de la resolution de la CL pour t
-!   peqAcoef     coeff. A de la resolution de la CL pour q
-!   petBcoef     coeff. B de la resolution de la CL pour t
-!   peqBcoef     coeff. B de la resolution de la CL pour q
-!   precip_rain  precipitation liquide
-!   precip_snow  precipitation solide
-!   sollw        flux IR net a la surface
-!   sollwdown    flux IR descendant a la surface
-!   swnet        flux solaire net
-!   swdown       flux solaire entrant a la surface
-!   albedo       albedo de la surface
-!   tsurf        temperature de surface
-!   tslab        temperature slab ocean
-!   pctsrf_slab  pourcentages (0-1) des sous-surfaces dans le slab
-!   tmp_pctsrf_slab = pctsrf_slab
-!   p1lay        pression 1er niveau (milieu de couche)
-!   ps           pression au sol
-!   radsol       rayonnement net aus sol (LW + SW)
-!   ocean        type d'ocean utilise (force, slab, couple)
-!   fder         derivee des flux (pour le couplage)
-!   taux, tauy   tension de vents
-! -- LOOP
-!   windsp       module du vent a 10m
-! -- LOOP
-!   rugos        rugosite
-!   zmasq        masque terre/ocean
-!   rugoro       rugosite orographique
-!   run_off_lic_0 runoff glacier du pas de temps precedent
-!
-! output:
-!   evap         evaporation totale
-!   fluxsens     flux de chaleur sensible
-!   fluxlat      flux de chaleur latente
-!   tsol_rad     
-!   tsurf_new    temperature au sol
-!   alb_new      albedo
-!   emis_new     emissivite
-!   z0_new       surface roughness
-!   pctsrf_new   nouvelle repartition des surfaces
-
-#include "iniprint.h"
-
-
-! Parametres d'entree
-  integer, intent(IN) :: itime
-  integer, intent(IN) :: iim, jjm
-  integer, intent(IN) :: klon
-  real, intent(IN) :: dtime
-  real, intent(IN) :: date0
-  integer, intent(IN) :: jour
-  real, intent(IN)    :: rmu0(klon)
-  integer, intent(IN) :: nisurf
-  integer, intent(IN) :: knon
-  integer, dimension(klon), intent(in) :: knindex
-  real, dimension(klon,nbsrf), intent(IN) :: pctsrf
-  logical, intent(IN) :: debut, lafin, ok_veget
-  real, dimension(klon), intent(IN) :: rlon, rlat
-  real, dimension(klon), intent(IN) :: cufi, cvfi
-  real, dimension(klon), intent(INOUT) :: tq_cdrag
-  real, dimension(klon), intent(IN) :: zlev
-  real, dimension(klon), intent(IN) :: u1_lay, v1_lay
-  real, dimension(klon), intent(IN) :: temp_air, spechum
-  real, dimension(klon), intent(IN) :: epot_air, ccanopy
-  real, dimension(klon), intent(IN) :: petAcoef, peqAcoef
-  real, dimension(klon), intent(IN) :: petBcoef, peqBcoef
-  real, dimension(klon), intent(IN) :: precip_rain, precip_snow
-  real, dimension(klon), intent(IN) :: sollw, sollwdown, swnet, swdown
-  real, dimension(klon), intent(IN) :: ps, albedo
-  real, dimension(klon), intent(IN) :: tsurf, p1lay
-!IM: "slab" ocean
-  real :: amn, amx 
-  real, dimension(klon), intent(INOUT) :: tslab
-  real, allocatable, dimension(:), save :: tmp_tslab
-!$OMP THREADPRIVATE(tmp_tslab)
-  real, dimension(klon), intent(OUT) :: flux_o, flux_g
-  real, dimension(klon), intent(INOUT)        :: seaice ! glace de mer (kg/m2)
-  real, dimension(klon)                       :: siceh  ! hauteur glace de mer (m)
-  REAL, DIMENSION(klon), INTENT(INOUT) :: radsol,fder
-  
-!  real, dimension(klon), intent(IN) :: zmasq
-  real, dimension(klon), intent(IN) :: zmasq
-  real, dimension(klon), intent(IN) :: taux, tauy, rugos, rugoro
-! -- LOOP
-  real, dimension(klon), intent(IN) :: windsp
-! -- LOOP
-  character (len = 6)  :: ocean
-  integer              :: npas, nexca ! nombre et pas de temps couplage
-  real, dimension(klon), intent(INOUT) :: evap, snow, qsurf
-!! PB ajout pour soil
-  logical          :: soil_model
-  integer          :: nsoilmx
-  REAL, DIMENSION(klon, nsoilmx) :: tsoil
-  REAL, dimension(klon), intent(INOUT) :: qsol
-  REAL, dimension(klon)          :: soilcap
-  REAL, dimension(klon)          :: soilflux
-! Parametres de sortie
-  real, dimension(klon), intent(OUT):: fluxsens, fluxlat
-  real, dimension(klon), intent(OUT):: tsol_rad, tsurf_new, alb_new
-  real, dimension(klon), intent(OUT):: alblw
-  real, dimension(klon), intent(OUT):: emis_new, z0_new
-  real, dimension(klon), intent(OUT):: dflux_l, dflux_s
-  real, dimension(klon,nbsrf), intent(OUT) :: pctsrf_new
-  real, dimension(klon), intent(INOUT):: agesno
-  real, dimension(klon), intent(INOUT):: run_off_lic_0
-
-! Flux thermique utiliser pour fondre la neige
-!jld a rajouter   real, dimension(klon), intent(INOUT):: ffonte
-  real, dimension(klon), intent(INOUT):: ffonte
-! Flux d'eau "perdue" par la surface et necessaire pour que limiter la
-! hauteur de neige, en kg/m2/s. Et quantite d'eau de fonte de la calotte.
-!jld a rajouter   real, dimension(klon), intent(INOUT):: fqcalving, fqfonte
-  REAL, DIMENSION(klon), INTENT(INOUT):: fqcalving, fqfonte
-!IM: "slab" ocean
-  real, dimension(klon) :: new_dif_grnd 
-!IM: "slab" ocean - Local
-  real, parameter :: t_grnd=271.35
-  real, dimension(klon) :: zx_sl
-  integer i
-  real, allocatable, dimension(:), save :: tmp_flux_o, tmp_flux_g
-!$OMP THREADPRIVATE(tmp_flux_o, tmp_flux_g)  
-  real, allocatable, dimension(:), save :: tmp_radsol
-!$OMP THREADPRIVATE(tmp_radsol)
-  real, allocatable, dimension(:,:), save :: tmp_pctsrf_slab
-!$OMP THREADPRIVATE(tmp_pctsrf_slab)
-  real, allocatable, dimension(:), save :: tmp_seaice
-!$OMP THREADPRIVATE(tmp_seaice)
-! Local
-  character (len = 20),save :: modname = 'interfsurf_hq'
-!$OMP THREADPRIVATE(modname)
-  character (len = 80) :: abort_message 
-  logical, save        :: first_call = .true.
-!$OMP THREADPRIVATE(first_call)  
-  integer, save        :: error
-!$OMP THREADPRIVATE(error)  
-  integer              :: ii, index
-  logical,save              :: check = .true.
-!$OMP THREADPRIVATE(check)  
-  real, dimension(klon):: cal, beta, dif_grnd, capsol
-!!$PB  real, parameter      :: calice=1.0/(5.1444e+06*0.15), tau_gl=86400.*5.
-  real, parameter      :: calice=1.0/(5.1444e+06*0.15), tau_gl=86400.*5.
-  real, parameter      :: calsno=1./(2.3867e+06*.15)
-  real, dimension(klon):: alb_ice
-  real, dimension(klon):: tsurf_temp
-  real, dimension(klon):: qsurf_new
-!!  real, allocatable, dimension(:), save :: alb_neig_grid
-  real, dimension(klon):: alb_neig, alb_eau
-  real, DIMENSION(klon):: zfra
-  logical              :: cumul = .false.
-  INTEGER,dimension(1) :: iloc
-  INTEGER                 :: isize
-  real, dimension(klon):: fder_prev
-  REAL, dimension(klon) :: bidule
-  real, dimension(klon) :: ps_tmp,p1lay_tmp
-  INTEGER :: j
-!
-!IM ?? quelques variables pour netcdf
-#include "netcdf.inc"
-
-  if (check) write(*,*) 'Entree ', modname
-!
-! On doit commencer par appeler les schemas de surfaces continentales
-! car l'ocean a besoin du ruissellement qui est y calcule
-!
-  if (first_call) then
-    call conf_interface(tau_calv)
-    if (nisurf /= is_ter .and. klon > 1) then 
-      write(*,*)' *** Warning ***'
-      write(*,*)' nisurf = ',nisurf,' /= is_ter = ',is_ter
-      write(*,*)'or on doit commencer par les surfaces continentales'
-      abort_message='voir ci-dessus'
-      call abort_gcm(modname,abort_message,1)
-    endif
-    if (ocean /= 'slab  ' .and. ocean /= 'force ' .and. ocean /= 'couple') then
-      write(*,*)' *** Warning ***'
-      write(*,*)'Option couplage pour l''ocean = ', ocean
-      abort_message='option pour l''ocean non valable'
-      call abort_gcm(modname,abort_message,1)
-    endif
-    if ( is_oce > is_sic ) then
-      write(*,*)' *** Warning ***'
-      write(*,*)' Pour des raisons de sequencement dans le code'
-      write(*,*)' l''ocean doit etre traite avant la banquise'
-      write(*,*)' or is_oce = ',is_oce, '> is_sic = ',is_sic
-      abort_message='voir ci-dessus'
-      call abort_gcm(modname,abort_message,1)
-    endif
-!    allocate(alb_neig_grid(klon), stat = error)
-!    if (error /= 0) then
-!      abort_message='Pb allocation alb_neig_grid'
-!      call abort_gcm(modname,abort_message,1)
-!    endif
-  endif
-  first_call = .false.
-  
-! Initialisations diverses
-!
-!!$  cal=0.; beta=1.; dif_grnd=0.; capsol=0.
-!!$  alb_new = 0.; z0_new = 0.; alb_neig = 0.0
-!!$! PB
-!!$  tsurf_new = 0.
-
-!IM cf JLD
-  ffonte(1:knon)=0.
-  fqcalving(1:knon)=0.
-  fqfonte  (1:knon)=0.
-
-
-  cal = 999999. ; beta = 999999. ; dif_grnd = 999999. ; capsol = 999999.
-  alb_new = 999999. ; z0_new = 999999. ; alb_neig = 999999.
-  tsurf_new = 999999.
-  alblw = 999999.
-
-!IM: "slab" ocean; initialisations
-  flux_o = 0.
-  flux_g = 0.
-!
-    if (.not. allocated(tmp_flux_o)) then
-      allocate(tmp_flux_o(klon), stat = error)
-      DO i=1, knon
-       tmp_flux_o(knindex(i))=flux_o(i)
-      ENDDO
-      if (error /= 0) then
-        abort_message='Pb allocation tmp_flux_o'
-        call abort_gcm(modname,abort_message,1)
-      endif
-    endif
-    if (.not. allocated(tmp_flux_g)) then  
-      allocate(tmp_flux_g(klon), stat = error)
-      DO i=1, knon
-       tmp_flux_g(knindex(i))=flux_g(i)
-      ENDDO
-      if (error /= 0) then
-        abort_message='Pb allocation tmp_flux_g'
-        call abort_gcm(modname,abort_message,1)
-      endif
-    endif
-    if (.not. allocated(tmp_radsol)) then  
-      allocate(tmp_radsol(klon), stat = error)
-      if (error /= 0) then
-        abort_message='Pb allocation tmp_radsol'
-        call abort_gcm(modname,abort_message,1)
-      endif
-    endif
-    if (.not. allocated(tmp_pctsrf_slab)) then
-      allocate(tmp_pctsrf_slab(klon,nbsrf), stat = error)
-      if (error /= 0) then
-        abort_message='Pb allocation tmp_pctsrf_slab'
-        call abort_gcm(modname,abort_message,1)
-      endif
-    DO i=1, klon
-     tmp_pctsrf_slab(i,1:nbsrf)=pctsrf(i,1:nbsrf)
-    ENDDO
-    endif
-!
-    if (.not. allocated(tmp_seaice)) then
-      allocate(tmp_seaice(klon), stat = error)
-      if (error /= 0) then
-        abort_message='Pb allocation tmp_seaice'
-        call abort_gcm(modname,abort_message,1)
-      endif
-    IF(check) THEN
-     PRINT*,'allocation tmp_seaice nisurf itime',nisurf, itime
-    ENDIF
-    endif
-!
-    if (.not. allocated(tmp_tslab)) then
-      allocate(tmp_tslab(klon), stat = error)
-      if (error /= 0) then
-        abort_message='Pb allocation tmp_tslab'
-        call abort_gcm(modname,abort_message,1)
-      endif
-    endif
-    DO i=1, klon
-     tmp_tslab(i)=tslab(i)
-    ENDDO
-!
-! Aiguillage vers les differents schemas de surface
-
-  if (nisurf == is_ter) then
-!
-! Surface "terre" appel a l'interface avec les sols continentaux
-!
-! allocation du run-off
-    if (.not. allocated(coastalflow)) then
-      allocate(coastalflow(knon), stat = error)
-      if (error /= 0) then
-        abort_message='Pb allocation coastalflow'
-        call abort_gcm(modname,abort_message,1)
-      endif
-      allocate(riverflow(knon), stat = error)
-      if (error /= 0) then
-        abort_message='Pb allocation riverflow'
-        call abort_gcm(modname,abort_message,1)
-      endif
-      allocate(run_off(knon), stat = error)
-      if (error /= 0) then
-        abort_message='Pb allocation run_off'
-        call abort_gcm(modname,abort_message,1)
-      endif
-!cym      
-      run_off=0.0
-!cym
-
-!!$PB
-      ALLOCATE (tmp_rriv(iim,jj_nb), stat=error)
-      if (error /= 0) then
-        abort_message='Pb allocation tmp_rriv'
-        call abort_gcm(modname,abort_message,1)
-      endif
-      tmp_rriv=0.
-      ALLOCATE (tmp_rcoa(iim,jj_nb), stat=error)
-      if (error /= 0) then
-        abort_message='Pb allocation tmp_rcoa'
-        call abort_gcm(modname,abort_message,1)
-      endif
-      tmp_rcoa=0.
-!ym      ALLOCATE (tmp_rlic(iim,jjm+1), stat=error)
-      ALLOCATE (tmp_rlic(iim,jj_nb), stat=error)
-      if (error /= 0) then
-        abort_message='Pb allocation tmp_rlic'
-        call abort_gcm(modname,abort_message,1)
-      endif
-      tmp_rlic=0.
-!!$
-    else if (size(coastalflow) /= knon) then
-      write(*,*)'Bizarre, le nombre de points continentaux'
-      write(*,*)'a change entre deux appels. J''arrete ...'
-      abort_message='voir ci-dessus'
-      call abort_gcm(modname,abort_message,1)
-    endif
-    coastalflow = 0.
-    riverflow = 0.
-!
-! Calcul age de la neige
-!
-!!$ PB ATTENTION changement ordre des appels
-!!$    CALL albsno(klon,agesno,alb_neig_grid)  
-
-    if (.not. ok_veget) then
-!
-! calcul albedo: lecture albedo fichier CL puis ajout albedo neige 
-! 
-       call interfsur_lim(itime, dtime, jour, &
-     & klon, nisurf, knon, knindex, debut,  &
-     & alb_new, z0_new)
-!  
-! calcul snow et qsurf, hydrol adapte !
-       CALL calbeta(dtime, nisurf, knon, snow, qsol, beta, capsol, dif_grnd)
-
-       IF (soil_model) THEN 
-           CALL soil(dtime, nisurf, knon,snow, tsurf, tsoil,soilcap, soilflux)
-           cal(1:knon) = RCPD / soilcap(1:knon)
-           radsol(1:knon) = radsol(1:knon)  + soilflux(1:knon)
-       ELSE 
-           cal = RCPD * capsol
-!!$      cal = capsol
-       ENDIF
-       CALL calcul_fluxs( klon, knon, nisurf, dtime, &
-     &   tsurf, p1lay, cal, beta, tq_cdrag, ps, &
-     &   precip_rain, precip_snow, snow, qsurf,  &
-     &   radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
-     &   petAcoef, peqAcoef, petBcoef, peqBcoef, &
-     &   tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
-
-       CALL fonte_neige( klon, knon, nisurf, dtime, &
-     &   tsurf, p1lay, cal, beta, tq_cdrag, ps, &
-     &   precip_rain, precip_snow, snow, qsol,  &
-     &   radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
-     &   petAcoef, peqAcoef, petBcoef, peqBcoef, &
-     &   tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l, &
-     &   fqcalving,fqfonte,ffonte, run_off_lic_0)
-
-
-     call albsno(klon,knon,dtime,agesno(:),alb_neig(:), precip_snow(:))  
-     where (snow(1 : knon) .LT. 0.0001) agesno(1 : knon) = 0.
-     zfra(1:knon) = max(0.0,min(1.0,snow(1:knon)/(snow(1:knon)+10.0)))
-     alb_new(1 : knon)  = alb_neig(1 : knon) *zfra(1:knon) + &
-    &                     alb_new(1 : knon)*(1.0-zfra(1:knon))
-     z0_new = sqrt(z0_new**2+rugoro**2)
-     alblw(1 : knon) = alb_new(1 : knon)
-
-    else
-!!      CALL albsno(klon,agesno,alb_neig_grid)  
-!
-!  appel a sechiba
-!
-#ifdef CPP_VEGET
-      p1lay_tmp(1:knon)=p1lay(1:knon)/100.
-      ps_tmp(1:knon)=ps(1:knon)/100.
- 
-       call interfsol(itime, klon, dtime, date0, nisurf, knon, &
-     &  knindex, rlon, rlat, cufi, cvfi, iim, jjm, pctsrf, &
-     &  debut, lafin, ok_veget, &
-     &  zlev,  u1_lay, v1_lay, temp_air, spechum, epot_air, ccanopy, & 
-     &  tq_cdrag, petAcoef, peqAcoef, petBcoef, peqBcoef, &
-     &  precip_rain, precip_snow, sollwdown, swnet, swdown, &
-     &  tsurf, p1lay_tmp, ps_tmp, radsol, &
-     &  evap, fluxsens, fluxlat, &              
-     &  tsol_rad, tsurf_new, alb_new, alblw, &
-     &  emis_new, z0_new, dflux_l, dflux_s, qsurf_new)
-
-!  
-! ajout de la contribution du relief
-!  
-      z0_new = SQRT(z0_new**2+rugoro**2)
-!
-! mise a jour de l'humidite saturante calculee par ORCHIDEE
-      qsurf(1:knon) = qsurf_new(1:knon)
-#else
-      abort_message='Pb de coherence: ok_veget = .t. mais CPP_VEGET = .f.'
-      call abort_gcm(modname,abort_message,1)
-#endif
-
-    endif    
-!
-! Remplissage des pourcentages de surface
-!
-    pctsrf_new(:,nisurf) = pctsrf(:,nisurf)
-
-  else if (nisurf == is_oce) then
-
-    if (check) write(*,*)'ocean, nisurf = ',nisurf,'knon=',knon 
-!
-! Surface "ocean" appel a l'interface avec l'ocean
-!
-    if (ocean == 'couple') then
-      if (nexca == 0) then
-        abort_message='nexca = 0 dans interfoce_cpl'
-        call abort_gcm(modname,abort_message,1)
-      endif
-
-      cumul = .false.
-
-      iloc = maxloc(fder(1:klon))
-      if (check) then
-        if (fder(iloc(1))> 0.) then
-          WRITE(*,*)'**** Debug fder ****'
-          WRITE(*,*)'max fder(',iloc(1),') = ',fder(iloc(1))
-        endif
-      endif
-!!$
-!!$      where(fder.gt.0.) 
-!!$        fder = 0.
-!!$      endwhere
-
-      call interfoce(itime, dtime, cumul, &
-      & klon, iim, jjm, nisurf, pctsrf, knon, knindex, rlon, rlat, &
-      & ocean, npas, nexca, debut, lafin, &
-      & swdown, sollw, precip_rain, precip_snow, evap, tsurf, &
-      & fluxlat, fluxsens, fder, albedo, taux, tauy, &
-! -- LOOP
-      & windsp, &
-! -- LOOP
-      & zmasq, &
-      & tsurf_new, alb_new, &
-      & pctsrf_new)
-
-!IM: "slab" ocean
-     else if (ocean == 'slab  ') then
-      DO i=1, knon
-       tsurf_new(i) = tmp_tslab(knindex(i))
-      ENDDO
-      pctsrf_new = tmp_pctsrf_slab
-!
-    else                              ! lecture conditions limites
-      call interfoce(itime, dtime, jour, & 
-     &  klon, nisurf, knon, knindex, &
-     &  debut, &
-     &  tsurf_new, pctsrf_new)
-
-    endif
-
-    tsurf_temp = tsurf_new
-    cal = 0.
-    beta = 1.
-    dif_grnd = 0.
-    alb_neig(:) = 0.
-    agesno(:) = 0.
-
-    call calcul_fluxs( klon, knon, nisurf, dtime, &
-     &   tsurf_temp, p1lay, cal, beta, tq_cdrag, ps, &
-     &   precip_rain, precip_snow, snow, qsurf,  &
-     &   radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
-     &   petAcoef, peqAcoef, petBcoef, peqBcoef, &
-     &   tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
-
-    fder_prev = fder    
-    fder = fder_prev + dflux_s + dflux_l
-
-      iloc = maxloc(fder(1:klon))
-        if (check.and.fder(iloc(1))> 0.) then
-          WRITE(*,*)'**** Debug fder****'
-          WRITE(*,*)'max fder(',iloc(1),') = ',fder(iloc(1))
-          WRITE(*,*)'fder_prev, dflux_s, dflux_l',fder_prev(iloc(1)), &
-     &                        dflux_s(iloc(1)), dflux_l(iloc(1))
-        endif
-!!$
-!!$      where(fder.gt.0.) 
-!!$        fder = 0.
-!!$      endwhere
-
-!IM: flux ocean-atmosphere utile pour le "slab" ocean
-    DO i=1, knon
-     zx_sl(i) = RLVTT
-     if (tsurf_new(i) .LT. RTT) zx_sl(i) = RLSTT
-!IM     flux_o(i) = fluxsens(i)-evap(i)*zx_sl(i)
-     flux_o(i) = fluxsens(i) + fluxlat(i)
-     tmp_flux_o(knindex(i)) = flux_o(i)
-     tmp_radsol(knindex(i))=radsol(i)
-    ENDDO
-!
-! 2eme appel a interfoce pour le cumul des champs (en particulier
-! fluxsens et fluxlat calcules dans calcul_fluxs)
-!
-    if (ocean == 'couple') then
-
-      cumul = .true.
-
-      call interfoce(itime, dtime, cumul, &
-      & klon, iim, jjm, nisurf, pctsrf, knon, knindex, rlon, rlat, &
-      & ocean, npas, nexca, debut, lafin, &
-      & swdown, sollw, precip_rain, precip_snow, evap, tsurf, &
-      & fluxlat, fluxsens, fder, albedo, taux, tauy, &
-! -- LOOP
-      & windsp, &
-! -- LOOP
-      & zmasq, &
-      & tsurf_new, alb_new, &
-      & pctsrf_new)
-
-    endif
-
-!
-! calcul albedo
-!
-
-    if ( minval(rmu0) == maxval(rmu0) .and. minval(rmu0) == -999.999 ) then
-      CALL alboc(FLOAT(jour),rlat,alb_eau)
-    else  ! cycle diurne
-      CALL alboc_cd(rmu0,alb_eau)
-    endif
-    DO ii =1, knon
-      alb_new(ii) = alb_eau(knindex(ii))
-    enddo
-
-    z0_new = sqrt(rugos**2 + rugoro**2)
-    alblw(1:knon) = alb_new(1:knon)
-
-!
-  else if (nisurf == is_sic) then
-
-    if (check) write(*,*)'sea ice, nisurf = ',nisurf,'knon=',knon 
-!
-! Surface "glace de mer" appel a l'interface avec l'ocean
-!
-!
-    if (ocean == 'couple') then
-
-      cumul =.false.
-
-      iloc = maxloc(fder(1:klon))
-      if (check.and.fder(iloc(1))> 0.) then
-        WRITE(*,*)'**** Debug fder ****'
-        WRITE(*,*)'max fder(',iloc(1),') = ',fder(iloc(1))
-      endif
-!!$
-!!$      where(fder.gt.0.) 
-!!$        fder = 0.
-!!$      endwhere
-
-      call interfoce(itime, dtime, cumul, &
-      & klon, iim, jjm, nisurf, pctsrf, knon, knindex, rlon, rlat, &
-      & ocean, npas, nexca, debut, lafin, &
-      & swdown, sollw, precip_rain, precip_snow, evap, tsurf, &
-      & fluxlat, fluxsens, fder, albedo, taux, tauy, &
-! -- LOOP
-      & windsp, &
-! -- LOOP
-      & zmasq, &
-      & tsurf_new, alb_new, &
-      & pctsrf_new)
-
-      tsurf_temp = tsurf_new
-      cal = 0.
-      dif_grnd = 0.
-      beta = 1.0
-
-!IM: "slab" ocean
-    else if (ocean == 'slab  ') then
-!IM ajout sicOBSERVE BEG
-   IF ( ok_slab_sicOBS) THEN 
-!                              ! lecture conditions limites
-      CALL interfoce(itime, dtime, jour, & 
-             &  klon, nisurf, knon, knindex, &
-             &  debut, &
-             &  tsurf_new, pctsrf_new)
-!
-    tmp_pctsrf_slab=pctsrf_new
-    print*,'jour lecture pctsrf_new sic =',jour
-!
-   ELSE !ok_slab_sicOBS 
-     pctsrf_new=tmp_pctsrf_slab
-   ENDIF
-!IM ajout sicOBSERVE END
-!
-     DO ii = 1, knon
-      tsurf_new(ii) = tsurf(ii)
-      IF (pctsrf_new(knindex(ii),nisurf) < EPSFRA) then
-       snow(ii) = 0.0
-       tsurf_new(ii) = RTT - 1.8
-       IF (soil_model) tsoil(ii,:) = RTT -1.8
-      ENDIF
-     ENDDO
-
-     CALL calbeta(dtime, nisurf, knon, snow, qsol, beta, capsol, dif_grnd)
-      
-     IF (soil_model) THEN 
-      CALL soil(dtime, nisurf, knon,snow, tsurf_new, tsoil,soilcap, soilflux)
-      cal(1:knon) = RCPD / soilcap(1:knon)
-      radsol(1:knon) = radsol(1:knon)  + soilflux(1:knon)
-     ELSE 
-      dif_grnd = 1.0 / tau_gl
-      cal = RCPD * calice
-      WHERE (snow > 0.0) cal = RCPD * calsno 
-     ENDIF
-     tsurf_temp = tsurf_new
-     beta = 1.0
-!
-    ELSE
-!                              ! lecture conditions limites
-      CALL interfoce(itime, dtime, jour, & 
-             &  klon, nisurf, knon, knindex, &
-             &  debut, &
-             &  tsurf_new, pctsrf_new)
-
-!IM cf LF
-      DO ii = 1, knon
-       tsurf_new(ii) = tsurf(ii)
-       IF (pctsrf_new(knindex(ii),nisurf) < EPSFRA) then
-          snow(ii) = 0.0
-!IM cf LF/JLD         tsurf(ii) = RTT - 1.8
-          tsurf_new(ii) = RTT - 1.8
-          IF (soil_model) tsoil(ii,:) = RTT -1.8
-        endif
-      enddo
-
-      CALL calbeta(dtime, nisurf, knon, snow, qsol, beta, capsol, dif_grnd)
-      
-      IF (soil_model) THEN 
-!IM cf LF/JLD        CALL soil(dtime, nisurf, knon,snow, tsurf, tsoil,soilcap, soilflux)
-         CALL soil(dtime, nisurf, knon,snow, tsurf_new, tsoil,soilcap, soilflux)
-         cal(1:knon) = RCPD / soilcap(1:knon)
-         radsol(1:knon) = radsol(1:knon)  + soilflux(1:knon)
-         dif_grnd = 1.0 / tau_gl
-      ELSE 
-         dif_grnd = 1.0 / tau_gl
-         cal = RCPD * calice
-         WHERE (snow > 0.0) cal = RCPD * calsno 
-      ENDIF
-!IMbadtsurf_temp = tsurf
-      tsurf_temp = tsurf_new
-      beta = 1.0
-    ENDIF !ocean ==
-
-    CALL calcul_fluxs( klon, knon, nisurf, dtime, &
-         &   tsurf_temp, p1lay, cal, beta, tq_cdrag, ps, &
-         &   precip_rain, precip_snow, snow, qsurf,  &
-         &   radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
-         &   petAcoef, peqAcoef, petBcoef, peqBcoef, &
-         &   tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
-!
-    IF (ocean /= 'couple') THEN
-      CALL fonte_neige( klon, knon, nisurf, dtime, &
-             &   tsurf_temp, p1lay, cal, beta, tq_cdrag, ps, &
-             &   precip_rain, precip_snow, snow, qsol,  &
-             &   radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
-             &   petAcoef, peqAcoef, petBcoef, peqBcoef, &
-             &   tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l, &
-             &   fqcalving,fqfonte,ffonte, run_off_lic_0)
-
-!     calcul albedo
-
-      CALL albsno(klon,knon,dtime,agesno(:),alb_neig(:), precip_snow(:))  
-      WHERE (snow(1 : knon) .LT. 0.0001) agesno(1 : knon) = 0.
-      zfra(1:knon) = MAX(0.0,MIN(1.0,snow(1:knon)/(snow(1:knon)+10.0)))
-      alb_new(1 : knon) = alb_neig(1 : knon) *zfra(1:knon) + & 
-     &                    0.6 * (1.0-zfra(1:knon))
-!!      alb_new(1 : knon) = 0.6
-    ENDIF
-!
-!IM: flux entre l'ocean et la glace de mer pour le "slab" ocean
-!
-    DO i = 1, knon
-!
-!IM: faire dependre le coefficient de conduction de la glace de mer
-!    de l'epaisseur de la glace de mer, dans l'hypothese ou le coeff.
-!    actuel correspond a 3m de glace de mer, cf. L.Li
-!
-       IF(1.EQ.0) THEN
-        IF(siceh(i).GT.0.) THEN
-         new_dif_grnd(i) = dif_grnd(i)*3./siceh(i)
-        ELSE
-         new_dif_grnd(i) = 0.
-        ENDIF
-       ENDIF !(1.EQ.0) THEN
-!
-     IF (cal(i).GT.1.0e-15) THEN
-       flux_g(i)=(tsurf_new(i)-t_grnd) &
-    &                          * dif_grnd(i) *RCPD/cal(i)
-!   &                          * new_dif_grnd(i) *RCPD/cal(i)
-     ENDIF
-     tmp_flux_g(knindex(i))=flux_g(i)
-!
-!IM: Attention: ne pas initialiser le tmp_radsol puisque c'est deja fait sur is_oce;
-!IM:            tmp_radsol doit etre le flux solaire qui arrive sur l'ocean 
-!IM:            et non pas celui qui arrive sur la glace de mer
-!
-    ENDDO
-
-    fder_prev = fder    
-    fder = fder_prev + dflux_s + dflux_l
-
-      iloc = maxloc(fder(1:klon))
-      if (check.and.fder(iloc(1))> 0.) then
-        WRITE(*,*)'**** Debug fder ****'
-        WRITE(*,*)'max fder(',iloc(1),') = ',fder(iloc(1))
-        WRITE(*,*)'fder_prev, dflux_s, dflux_l',fder_prev(iloc(1)), &
-     &                        dflux_s(iloc(1)), dflux_l(iloc(1))
-      endif
-!!$      where(fder.gt.0.) 
-!!$        fder = 0.
-!!$      endwhere
-
-!
-! 2eme appel a interfoce pour le cumul et le passage des flux a l'ocean
-!
-    if (ocean == 'couple') then
-
-      cumul =.true.
-
-      call interfoce(itime, dtime, cumul, &
-      & klon, iim, jjm, nisurf, pctsrf, knon, knindex, rlon, rlat, &
-      & ocean, npas, nexca, debut, lafin, &
-      & swdown, sollw, precip_rain, precip_snow, evap, tsurf, &
-      & fluxlat, fluxsens, fder, albedo, taux, tauy, &
-! -- LOOP
-      & windsp, &
-! -- LOOP
-      & zmasq, &
-      & tsurf_new, alb_new, &
-      & pctsrf_new)
-
-!IM: "slab" ocean 
-    else if (ocean == 'slab  ') then
-!
-   IF (check) THEN
-    amn=MIN(tmp_tslab(1),1000.)
-    amx=MAX(tmp_tslab(1),-1000.)
-    DO i=2, klon
-     amn=MIN(tmp_tslab(i),amn)
-     amx=MAX(tmp_tslab(i),amx)
-    ENDDO
-!
-    PRINT*,' debut avant interfoce_slab min max tmp_tslab',amn,amx
-   ENDIF !(check) THEN
-!
-       cumul = .true.
-       tslab = tmp_tslab   
-       call interfoce(klon, debut, itime, dtime, jour, &
-     & tmp_radsol, tmp_flux_o, tmp_flux_g, tmp_pctsrf_slab, &
-     & tslab, seaice, pctsrf_new)
-!
-       tmp_seaice=seaice
-       tmp_pctsrf_slab=pctsrf_new
-       DO i=1, knon
-         tmp_tslab(knindex(i))=tslab(knindex(i))
-       ENDDO !i
-!
-
-    endif
-
-     
-    z0_new = 0.002
-    z0_new = SQRT(z0_new**2+rugoro**2)
-    alblw(1:knon) = alb_new(1:knon)
-
-
-  else if (nisurf == is_lic) then
-
-    if (check) write(*,*)'glacier, nisurf = ',nisurf 
-
-    if (.not. allocated(run_off_lic)) then
-      allocate(run_off_lic(klon), stat = error)
-      if (error /= 0) then
-        abort_message='Pb allocation run_off_lic'
-        call abort_gcm(modname,abort_message,1)
-      endif
-      run_off_lic = 0.
-    endif
-!
-! Surface "glacier continentaux" appel a l'interface avec le sol
-!
-!    call interfsol(nisurf)
-    IF (soil_model) THEN 
-        CALL soil(dtime, nisurf, knon, snow, tsurf, tsoil,soilcap, soilflux)
-        cal(1:knon) = RCPD / soilcap(1:knon)
-        radsol(1:knon)  = radsol(1:knon) + soilflux(1:knon)
-    ELSE 
-        cal = RCPD * calice
-        WHERE (snow > 0.0) cal = RCPD * calsno
-    ENDIF 
-    beta = 1.0
-    dif_grnd = 0.0
-
-    call calcul_fluxs( klon, knon, nisurf, dtime, &
-     &   tsurf, p1lay, cal, beta, tq_cdrag, ps, &
-     &   precip_rain, precip_snow, snow, qsurf,  &
-     &   radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
-     &   petAcoef, peqAcoef, petBcoef, peqBcoef, &
-     &   tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
-
-    call fonte_neige( klon, knon, nisurf, dtime, &
-     &   tsurf, p1lay, cal, beta, tq_cdrag, ps, &
-     &   precip_rain, precip_snow, snow, qsol,  &
-     &   radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
-     &   petAcoef, peqAcoef, petBcoef, peqBcoef, &
-     &   tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l, &
-     &   fqcalving,fqfonte,ffonte, run_off_lic_0)
-
-! passage du run-off des glaciers calcule dans fonte_neige au coupleur
-    bidule=0.
-    bidule(1:knon)= run_off_lic(1:knon)    
-    call gath2cpl(bidule, tmp_rlic, klon, knon,iim,jjm,knindex)
-!
-! calcul albedo
-!
-     CALL albsno(klon,knon,dtime,agesno(:),alb_neig(:), precip_snow(:))  
-     WHERE (snow(1 : knon) .LT. 0.0001) agesno(1 : knon) = 0.
-     zfra(1:knon) = MAX(0.0,MIN(1.0,snow(1:knon)/(snow(1:knon)+10.0)))
-     alb_new(1 : knon)  = alb_neig(1 : knon)*zfra(1:knon) + &
-    &                     0.6 * (1.0-zfra(1:knon))
-!
-!IM: plusieurs choix/tests sur l'albedo des "glaciers continentaux"
-!       alb_new(1 : knon)  = 0.6 !IM cf FH/GK 
-!       alb_new(1 : knon)  = 0.82
-!       alb_new(1 : knon)  = 0.77 !211003 Ksta0.77
-!       alb_new(1 : knon)  = 0.8 !KstaTER0.8 & LMD_ARMIP5
-!IM: KstaTER0.77 & LMD_ARMIP6    
-        alb_new(1 : knon)  = 0.77
-
-!
-! Rugosite
-!
-    z0_new = rugoro
-!
-! Remplissage des pourcentages de surface
-!
-    pctsrf_new(:,nisurf) = pctsrf(:,nisurf)
-
-    alblw(1:knon) = alb_new(1:knon)
-  else
-    write(*,*)'Index surface = ',nisurf
-    abort_message = 'Index surface non valable'
-    call abort_gcm(modname,abort_message,1)
-  endif
-
-  END SUBROUTINE interfsurf_hq
-
-!
-!#########################################################################
-!
-  SUBROUTINE interfsurf_vent(nisurf, knon   &         
-  &                     )
-!
-! Cette routine sert d'aiguillage entre l'atmosphere et la surface en general 
-! (sols continentaux, oceans, glaces) pour les tensions de vents.
-! En pratique l'interface se fait entre la couche limite du modele 
-! atmospherique (clmain.F) et les routines de surface (sechiba, oasis, ...)
-!
-! 
-! L.Fairhead 02/2000
-!
-! input:
-!   nisurf       index de la surface a traiter (1 = sol continental)
-!   knon         nombre de points de la surface a traiter
-
-! Parametres d'entree
-  integer, intent(IN) :: nisurf
-  integer, intent(IN) :: knon
-
-
-  return
-  END SUBROUTINE interfsurf_vent
-!
-!#########################################################################
-!
-#ifdef CPP_VEGET
-  SUBROUTINE interfsol(itime, klon, dtime, date0, nisurf, knon, &
-     & knindex, rlon, rlat, cufi, cvfi, iim, jjm, pctsrf, &
-     & debut, lafin, ok_veget, &
-     & plev,  u1_lay, v1_lay, temp_air, spechum, epot_air, ccanopy, & 
-     & tq_cdrag, petAcoef, peqAcoef, petBcoef, peqBcoef, &
-     & precip_rain, precip_snow, lwdown, swnet, swdown, &
-     & tsurf, p1lay, ps, radsol, &
-     & evap, fluxsens, fluxlat, &              
-     & tsol_rad, tsurf_new, alb_new, alblw, &
-     & emis_new, z0_new, dflux_l, dflux_s, qsurf)
-
-  USE intersurf
-  USE mod_grid_phy_lmdz
-  USE mod_phys_lmdz_para
-  IMPLICIT NONE
-! Cette routine sert d'interface entre le modele atmospherique et le 
-! modele de sol continental. Appel a sechiba
-!
-! L. Fairhead 02/2000
-!
-! input:
-!   itime        numero du pas de temps
-!   klon         nombre total de points de grille
-!   dtime        pas de temps de la physique (en s)
-!   nisurf       index de la surface a traiter (1 = sol continental)
-!   knon         nombre de points de la surface a traiter
-!   knindex      index des points de la surface a traiter
-!   rlon         longitudes de la grille entiere
-!   rlat         latitudes de la grille entiere
-!   pctsrf       tableau des fractions de surface de chaque maille
-!   debut        logical: 1er appel a la physique (lire les restart)
-!   lafin        logical: dernier appel a la physique (ecrire les restart)
-!   ok_veget     logical: appel ou non au schema de surface continental
-!                     (si false calcul simplifie des fluxs sur les continents)
-!   plev         hauteur de la premiere couche (Pa)      
-!   u1_lay       vitesse u 1ere couche
-!   v1_lay       vitesse v 1ere couche
-!   temp_air     temperature de l'air 1ere couche
-!   spechum      humidite specifique 1ere couche
-!   epot_air     temp pot de l'air
-!   ccanopy      concentration CO2 canopee
-!   tq_cdrag     cdrag
-!   petAcoef     coeff. A de la resolution de la CL pour t
-!   peqAcoef     coeff. A de la resolution de la CL pour q
-!   petBcoef     coeff. B de la resolution de la CL pour t
-!   peqBcoef     coeff. B de la resolution de la CL pour q
-!   precip_rain  precipitation liquide
-!   precip_snow  precipitation solide
-!   lwdown       flux IR descendant a la surface
-!   swnet        flux solaire net
-!   swdown       flux solaire entrant a la surface
-!   tsurf        temperature de surface
-!   p1lay        pression 1er niveau (milieu de couche)
-!   ps           pression au sol
-!   radsol       rayonnement net aus sol (LW + SW)
-!   
-!
-! input/output
-!   run_off      ruissellement total
-!
-! output:
-!   evap         evaporation totale
-!   fluxsens     flux de chaleur sensible
-!   fluxlat      flux de chaleur latente
-!   tsol_rad     
-!   tsurf_new    temperature au sol
-!   alb_new      albedo
-!   emis_new     emissivite
-!   z0_new       surface roughness
-!   qsurf        air moisture at surface
-
-! Parametres d'entree
-  integer, intent(IN) :: itime
-  integer, intent(IN) :: klon
-  real, intent(IN)    :: dtime
-  real, intent(IN)    :: date0
-  integer, intent(IN) :: nisurf
-  integer, intent(IN) :: knon
-  integer, intent(IN) :: iim, jjm
-  integer, dimension(klon), intent(IN) :: knindex
-  logical, intent(IN) :: debut, lafin, ok_veget
-  real, dimension(klon,nbsrf), intent(IN) :: pctsrf
-  real, dimension(klon), intent(IN) :: rlon, rlat
-  real, dimension(klon), intent(IN) :: cufi, cvfi
-  real, dimension(klon), intent(IN) :: plev
-  real, dimension(klon), intent(IN) :: u1_lay, v1_lay
-  real, dimension(klon), intent(IN) :: temp_air, spechum
-  real, dimension(klon), intent(IN) :: epot_air, ccanopy
-  real, dimension(klon), intent(INOUT) :: tq_cdrag
-  real, dimension(klon), intent(IN) :: petAcoef, peqAcoef
-  real, dimension(klon), intent(IN) :: petBcoef, peqBcoef
-  real, dimension(klon), intent(IN) :: precip_rain, precip_snow
-  real, dimension(klon), intent(IN) :: lwdown, swnet, swdown, ps
-!IM cf. JP +++
-  real, dimension(klon) :: swdown_vrai
-!IM cf. JP ---
-  real, dimension(klon), intent(IN) :: tsurf, p1lay
-  real, dimension(klon), intent(IN) :: radsol
-! Parametres de sortie
-  real, dimension(klon), intent(OUT):: evap, fluxsens, fluxlat, qsurf
-  real, dimension(klon), intent(OUT):: tsol_rad, tsurf_new, alb_new, alblw
-  real, dimension(klon), intent(OUT):: emis_new, z0_new
-  real, dimension(klon), intent(OUT):: dflux_s, dflux_l
-
-! Local
-!
-  integer              :: ii, ij, jj, igrid, ireal, i, index, iglob
-  integer              :: error
-  character (len = 20) :: modname = 'interfsol'
-  character (len = 80) :: abort_message
-  logical,save              :: check = .FALSE.
-  real, dimension(klon) :: cal, beta, dif_grnd, capsol
-! type de couplage dans sechiba
-!  character (len=10)   :: coupling = 'implicit' 
-! drapeaux controlant les appels dans SECHIBA
-!  type(control_type), save   :: control_in
-! Preserved albedo
-!IM cf. JP +++
-  real, allocatable, dimension(:), save :: albedo_keep, zlev
-!IM cf. JP ---
-! coordonnees geographiques
-  real, allocatable, dimension(:,:), save :: lalo
-! pts voisins
-  integer,allocatable, dimension(:,:), save :: neighbours
-! fractions continents
-  real,allocatable, dimension(:), save :: contfrac
-! resolution de la grille
-  real, allocatable, dimension (:,:), save :: resolution
-! correspondance point n -> indices (i,j)
-  integer, allocatable, dimension(:,:), save :: correspond
-! offset pour calculer les point voisins
-  integer, dimension(8,3), save :: off_ini
- ! Identifieurs des fichiers restart et histoire
-  integer, save          :: rest_id, hist_id 
-  integer, save          :: rest_id_stom, hist_id_stom
-! 
-  real, allocatable, dimension (:,:), save :: lon_scat, lat_scat  
-
-  logical, save          :: lrestart_read = .true. , lrestart_write = .false.
-
-  real, dimension(klon):: snow
-  real, dimension(knon,2) :: albedo_out
-! Pb de nomenclature
-  real, dimension(klon) :: petA_orc, peqA_orc
-  real, dimension(klon) :: petB_orc, peqB_orc
-! Pb de correspondances de grilles
-  integer, dimension(:), save, allocatable :: ig, jg
-  integer :: indi, indj
-  integer, save, allocatable,dimension(:) :: ktindex
-  REAL, dimension(klon) :: bidule
-! Essai cdrag
-  real, dimension(klon) :: cdrag
-  integer :: jjb,jje,ijb,ije
-  INTEGER,SAVE :: offset
-  REAL, dimension(klon_glo) :: rlon_g,rlat_g
-  INTEGER, SAVE          :: orch_comm
-#include "temps.inc"
-#include "YOMCST.inc"
-#include "iniprint.h"
-
-  if (check) write(lunout,*)'Entree ', modname
-  if (check) write(lunout,*)'ok_veget = ',ok_veget
-
-
-  
-! initialisation
-  
-  if (debut) then
-    ALLOCATE(ktindex(klon))
-  IF ( .NOT. allocated(albedo_keep)) THEN
-     ALLOCATE(albedo_keep(klon))
-     ALLOCATE(zlev(klon))
-  ENDIF
-! Pb de correspondances de grilles
-   allocate(ig(klon))
-   allocate(jg(klon))
-   ig(1) = 1
-   jg(1) = 1
-   indi = 0
-   indj = 2
-   do igrid = 2, klon - 1
-     indi = indi + 1
-     if ( indi > iim) then
-       indi = 1
-       indj = indj + 1
-     endif
-     ig(igrid) = indi
-     jg(igrid) = indj
-   enddo
-   ig(klon) = 1
-   jg(klon) = jjm + 1
-
-    if ((.not. allocated(lalo))) then
-      allocate(lalo(knon,2), stat = error)
-      if (error /= 0) then
-        abort_message='Pb allocation lalo'
-        call abort_gcm(modname,abort_message,1)
-      endif      
-    endif
-    if ((.not. allocated(lon_scat))) then
-      allocate(lon_scat(iim,jjm+1), stat = error)
-      if (error /= 0) then
-        abort_message='Pb allocation lon_scat'
-        call abort_gcm(modname,abort_message,1)
-      endif      
-    endif
-    if ((.not. allocated(lat_scat))) then
-      allocate(lat_scat(iim,jjm+1), stat = error)
-      if (error /= 0) then
-        abort_message='Pb allocation lat_scat'
-        call abort_gcm(modname,abort_message,1)
-      endif      
-    endif
-    lon_scat = 0.
-    lat_scat = 0.
-    do igrid = 1, knon
-      index = knindex(igrid)
-      lalo(igrid,2) = rlon(index)
-      lalo(igrid,1) = rlat(index)
-
-    enddo
-   
-
-    
-    CALL Gather(rlon,rlon_g)
-    CALL Gather(rlat,rlat_g)
-
-    IF (is_mpi_root) THEN
-      index = 1
-      do jj = 2, jjm
-        do ij = 1, iim
-          index = index + 1
-          lon_scat(ij,jj) = rlon_g(index)
-          lat_scat(ij,jj) = rlat_g(index)
-        enddo
-      enddo
-     lon_scat(:,1) = lon_scat(:,2)
-     lat_scat(:,1) = rlat_g(1)
-     lon_scat(:,jjm+1) = lon_scat(:,2)
-     lat_scat(:,jjm+1) = rlat_g(klon_glo)
-   ENDIF
-   
-
-!
-! Allouer et initialiser le tableau des voisins et des fraction de continents
-!
-    if ( (.not.allocated(neighbours))) THEN
-      allocate(neighbours(knon,8), stat = error)
-      if (error /= 0) then
-        abort_message='Pb allocation neighbours'
-        call abort_gcm(modname,abort_message,1)
-      endif
-    endif
-    neighbours = -1.
-    if (( .not. allocated(contfrac))) then
-      allocate(contfrac(knon), stat = error)
-      if (error /= 0) then
-        abort_message='Pb allocation contfrac'
-        call abort_gcm(modname,abort_message,1)
-      endif      
-    endif
-
-    do igrid = 1, knon
-      ireal = knindex(igrid)
-      contfrac(igrid) = pctsrf(ireal,is_ter)
-    enddo
-
-
-   CALL Init_neighbours(iim,jjm,knon,neighbours,knindex,pctsrf(:,is_ter))
-
-!
-!  Allocation et calcul resolutions
-    IF ( (.NOT.ALLOCATED(resolution))) THEN
-      ALLOCATE(resolution(knon,2), stat = error)
-      if (error /= 0) then
-        abort_message='Pb allocation resolution'
-        call abort_gcm(modname,abort_message,1)
-      endif
-    ENDIF
-    do igrid = 1, knon
-      ij = knindex(igrid)
-      resolution(igrid,1) = cufi(ij)
-      resolution(igrid,2) = cvfi(ij)
-    enddo  
-
-  endif                          ! (fin debut) 
-
-! 
-! Appel a la routine sols continentaux
-!
-  if (lafin) lrestart_write = .true.
-  if (check) write(lunout,*)'lafin ',lafin,lrestart_write
-
-  petA_orc = petBcoef * dtime
-  petB_orc = petAcoef
-  peqA_orc = peqBcoef * dtime
-  peqB_orc = peqAcoef
-
-  cdrag = 0.
-  cdrag(1:knon) = tq_cdrag(1:knon)
-
-!IM cf. JP +++
-! zlev(1:knon) = (100.*plev(1:knon))/((ps(1:knon)/287.05*temp_air(1:knon))*9.80665)
-  zlev(1:knon) = (100.*plev(1:knon))/((ps(1:knon)/RD*temp_air(1:knon))*RG)
-!IM cf. JP ---
-
-
-! PF et PASB
-!   where(cdrag > 0.01) 
-!     cdrag = 0.01
-!   endwhere
-!  write(*,*)'Cdrag = ',minval(cdrag),maxval(cdrag)
-
-!
-! Init Orchidee
-!
-!  if (pole_nord) then 
-!    offset=0
-!    ktindex(:)=ktindex(:)+iim-1
-!  else
-!    offset = klon_begin-1+iim-1
-!    ktindex(:)=ktindex(:)+MOD(offset,iim)
-!    offset=offset-MOD(offset,iim)
-!  endif
-  
-   
-  if (debut) then
-    CALL Get_orchidee_communicator(knon,orch_comm)
-    IF (knon /=0) THEN
-      CALL Init_orchidee_index(iim,knon,orch_comm,knindex,offset,ktindex)
-    
-      call intersurf_main (itime+itau_phy-1, iim, jjm+1,offset, knon, ktindex, & 
-       & orch_comm,dtime, lrestart_read, lrestart_write, lalo, &
-       & contfrac, neighbours, resolution, date0, &
-       & zlev,  u1_lay, v1_lay, spechum, temp_air, epot_air, ccanopy, &
-       & cdrag, petA_orc, peqA_orc, petB_orc, peqB_orc, &
-       & precip_rain, precip_snow, lwdown, swnet, swdown, ps, &
-       & evap, fluxsens, fluxlat, coastalflow, riverflow, &
-       & tsol_rad, tsurf_new, qsurf, albedo_out, emis_new, z0_new, &
-       & lon_scat, lat_scat)
-
-     ENDIF
-!IM cf. JP +++
-    albedo_keep(1:knon) = (albedo_out(1:knon,1)+albedo_out(1:knon,2))/2.
-!IM cf. JP ---
-
-  endif
-
-!IM cf. JP +++
-!  swdown_vrai(1:knon) = swnet(1:knon)/(1. - albedo_keep(1:knon))
-  swdown_vrai(1:knon) = swdown(1:knon)
-
-!IM cf. JP ---
-    IF (knon /=0) THEN
-    
-      call intersurf_main (itime+itau_phy, iim, jjm+1,offset, knon, ktindex, & 
-       & orch_comm,dtime, lrestart_read, lrestart_write, lalo, &
-       & contfrac, neighbours, resolution, date0, &
-       & zlev,  u1_lay, v1_lay, spechum, temp_air, epot_air, ccanopy, &
-       & cdrag, petA_orc, peqA_orc, petB_orc, peqB_orc, &
-       & precip_rain, precip_snow, lwdown, swnet, swdown_vrai, ps, &
-       & evap, fluxsens, fluxlat, coastalflow, riverflow, &
-       & tsol_rad, tsurf_new, qsurf, albedo_out, emis_new, z0_new, &
-       & lon_scat, lat_scat)
-
-    ENDIF
-!IM cf. JP +++
-    albedo_keep(1:knon) = (albedo_out(1:knon,1)+albedo_out(1:knon,2))/2.
-!IM cf. JP ---
-
-    bidule=0.
-    bidule(1:knon)=riverflow(1:knon)
-    call gath2cpl(bidule, tmp_rriv, klon, knon,iim,jj_nb,knindex)
-    bidule=0.
-    bidule(1:knon)=coastalflow(1:knon)
-    call gath2cpl(bidule, tmp_rcoa, klon, knon,iim,jj_nb,knindex)
-    alb_new(1:knon) = albedo_out(1:knon,1) 
-    alblw(1:knon) = albedo_out(1:knon,2)
-
-
-! Convention orchidee: positif vers le haut
-  fluxsens(1:knon) = -1. * fluxsens(1:knon)
-  fluxlat(1:knon)  = -1. * fluxlat(1:knon)
-
-!  evap     = -1. * evap
-
-  if (debut) lrestart_read = .false.
-
-  END SUBROUTINE interfsol
-  
-  SUBROUTINE Init_orchidee_index(iim,knon,orch_comm,knindex,offset,ktindex)
-  USE mod_phys_lmdz_para, ONLY : is_parallel
-  
-  IMPLICIT NONE
-    INTEGER,INTENT(IN)  :: iim
-    INTEGER,INTENT(IN)  :: knon
-    INTEGER,INTENT(IN)  :: orch_comm
-    INTEGER,INTENT(IN)  :: knindex(knon)
-    INTEGER,INTENT(OUT) :: offset
-    INTEGER,INTENT(OUT) :: ktindex(knon)
-
-#ifdef CPP_PARA
-    INCLUDE 'mpif.h'
-    INTEGER :: status(MPI_STATUS_SIZE)
-#endif
-    INTEGER :: MyLastPoint
-    INTEGER :: LastPoint
-    INTEGER :: mpi_rank
-    INTEGER :: mpi_size
-    INTEGER :: ierr   
-    
-    MyLastPoint=klon_begin-1+knindex(knon)+iim-1
-
-    IF (is_parallel) THEN
-#ifdef CPP_PARA    
-      call MPI_COMM_SIZE(orch_comm,mpi_size,ierr)
-      call MPI_COMM_RANK(orch_comm,mpi_rank,ierr)
-#endif
-    ELSE
-      mpi_rank=0
-      mpi_size=1
-    ENDIF
-    
-    IF (is_parallel) THEN
-      IF (mpi_rank /= 0) then
-#ifdef CPP_PARA
-        CALL MPI_RECV(LastPoint,1,MPI_INTEGER,mpi_rank-1,1234,orch_comm,status,ierr)
-#endif
-      ENDIF
-        
-      IF (mpi_rank /= mpi_size-1) THEN
-#ifdef CPP_PARA
-        CALL MPI_SEND(MyLastPoint,1,MPI_INTEGER,mpi_rank+1,1234,orch_comm,ierr)  
-#endif
-      ENDIF
-    ENDIF
-    
-    IF (mpi_rank==0) THEN 
-      offset=0
-    ELSE
-     offset=LastPoint-MOD(LastPoint,iim)
-    ENDIF
-     
-    ktindex(:)=knindex(:)+(klon_begin+iim-1)-offset-1	
-    
-
-   END SUBROUTINE  Init_orchidee_index 
-
-  
-  SUBROUTINE Get_orchidee_communicator(knon,orch_comm)
-  USE mod_phys_lmdz_para, ONLY: mpi_rank, COMM_LMDZ_PHY
-
-  IMPLICIT NONE
-#ifdef CPP_PARA
-    include 'mpif.h'
-#endif    
-    INTEGER,INTENT(IN)  :: knon
-    INTEGER,INTENT(OUT) :: orch_comm
-    
-    INTEGER :: color
-    INTEGER :: ierr
-    
-    IF (knon==0) THEN 
-      color = 0
-    ELSE 
-      color = 1
-    ENDIF
-
-#ifdef CPP_PARA    
-    CALL MPI_COMM_SPLIT(COMM_LMDZ_PHY,color,mpi_rank,orch_comm,ierr)
-#endif
-    
-  END SUBROUTINE Get_orchidee_communicator 
-    
-    
-  SUBROUTINE Init_neighbours(iim,jjm,knon,neighbours,ktindex,pctsrf)
-  USE mod_phys_lmdz_para, not_use_mpi_root=>mpi_root
-  USE dimphy
-  IMPLICIT NONE
-
-#ifdef CPP_PARA
-  include 'mpif.h'
-#endif
-  INTEGER :: iim,jjm
-  INTEGER :: knon
-  INTEGER :: neighbours(knon,8)
-  INTEGER :: ktindex(knon)
-  REAL :: pctsrf(klon)
-  
-  INTEGER :: knon_nb(0:mpi_size-1)
-  INTEGER,DIMENSION(0:mpi_size-1) :: displs,sendcount
-  INTEGER,ALLOCATABLE :: ktindex_g(:)
-  REAL*8  :: pctsrf_g(klon2)
-  INTEGER,ALLOCATABLE ::neighbours_g(:,:)
-  INTEGER :: knon_g
-  REAL*8 :: correspond(iim,jjm+1)
-  INTEGER :: i,igrid,jj,ij,iglob,ierr,ireal,index
-  integer, dimension(8,3) :: off_ini
-  integer, dimension(8)   :: offset  
-  INTEGER :: ktindex_p(knon)
-
-  IF (is_sequential) THEN
-    knon_nb(:)=knon
-  ELSE  
-
-#ifdef CPP_PARA  
-    CALL MPI_GATHER(knon,1,MPI_INTEGER,knon_nb,1,MPI_INTEGER,0,COMM_LMDZ_PHY,ierr)
-#endif
-  
-  ENDIF
-    
-  IF (is_mpi_root) THEN
-    knon_g=sum(knon_nb(:))
-    ALLOCATE(ktindex_g(knon_g))
-    ALLOCATE(neighbours_g(knon_g,8))
-    neighbours_g(:,:)=-1
-    displs(0)=0
-    DO i=1,mpi_size-1
-      displs(i)=displs(i-1)+knon_nb(i-1)
-    ENDDO  
-  ENDIF
-  
-  ktindex_p(:)=ktindex(:)+klon_begin-1+iim-1
-
-  IF (is_sequential) THEN
-    ktindex_g(:)=ktindex_p(:)
-  ELSE
-
-#ifdef CPP_PARA  
-    CALL MPI_GATHERV(ktindex_p,knon,MPI_INTEGER,ktindex_g,knon_nb,displs,MPI_INTEGER,0,COMM_LMDZ_PHY,ierr)
-#endif
-
-  ENDIF
-     
-  CALL Gather(pctsrf,pctsrf_g)
-  
-  IF (is_mpi_root) THEN
-!  Initialisation des offset    
-!
-! offset bord ouest
-   off_ini(1,1) = - iim  ; off_ini(2,1) = - iim + 1; off_ini(3,1) = 1
-   off_ini(4,1) = iim + 1; off_ini(5,1) = iim      ; off_ini(6,1) = 2 * iim - 1
-   off_ini(7,1) = iim -1 ; off_ini(8,1) = - 1
-! offset point normal
-   off_ini(1,2) = - iim  ; off_ini(2,2) = - iim + 1; off_ini(3,2) = 1
-   off_ini(4,2) = iim + 1; off_ini(5,2) = iim      ; off_ini(6,2) = iim - 1
-   off_ini(7,2) = -1     ; off_ini(8,2) = - iim - 1
-! offset bord   est
-   off_ini(1,3) = - iim; off_ini(2,3) = - 2 * iim + 1; off_ini(3,3) = - iim + 1
-   off_ini(4,3) =  1   ; off_ini(5,3) = iim          ; off_ini(6,3) = iim - 1
-   off_ini(7,3) = -1   ; off_ini(8,3) = - iim - 1
-!
-!
-! Attention aux poles
-!
-    do igrid = 1, knon_g
-      index = ktindex_g(igrid)
-          jj = int((index - 1)/iim) + 1
-          ij = index - (jj - 1) * iim
-      correspond(ij,jj) = igrid
-    enddo
-
-    do igrid = 1, knon_g
-      iglob = ktindex_g(igrid)
-      if (mod(iglob, iim) == 1) then
-        offset = off_ini(:,1)
-      else if(mod(iglob, iim) == 0) then
-        offset = off_ini(:,3)
-      else
-        offset = off_ini(:,2)
-      endif 
-      do i = 1, 8
-        index = iglob + offset(i)
-        ireal = (min(max(1, index - iim + 1), klon2))
-        if (pctsrf_g(ireal) > EPSFRA) then
-          jj = int((index - 1)/iim) + 1
-          ij = index - (jj - 1) * iim
-            neighbours_g(igrid, i) = correspond(ij, jj)
-        endif
-      enddo
-    enddo
-
-!    DO i=0,phy_size-1
-!      displs(i)=displs(i)*8
-!      sendcount(i)=knon_nb(i)*8
-!    ENDDO
-  
-  ENDIF
-  
-  DO i=1,8
-    IF (is_sequential) THEN
-      neighbours(:,i)=neighbours_g(:,i)
-    ELSE
-#ifdef CPP_PARA
-    CALL MPI_SCATTERV(neighbours_g(:,i),knon_nb,displs,MPI_INTEGER,neighbours(:,i),knon,MPI_INTEGER,0,COMM_LMDZ_PHY,ierr) 
-#endif
-    ENDIF
-  ENDDO
-  
-  END SUBROUTINE Init_neighbours
-#endif
-!
-!#########################################################################
-!
-  SUBROUTINE interfoce_cpl(itime, dtime, cumul, &
-      & klon, iim, jjm, nisurf, pctsrf, knon, knindex, rlon, rlat, &
-      & ocean, npas, nexca, debut, lafin, &
-      & swdown, lwdown, precip_rain, precip_snow, evap, tsurf, &
-      & fluxlat, fluxsens, fder, albsol, taux, tauy, &
-! -- LOOP
-      & windsp, &
-! -- LOOP
-      & zmasq, &
-      & tsurf_new, alb_new, &
-      & pctsrf_new)
-
-   USE ioipsl
-   USE mod_phys_lmdz_para, not_use_mpi_root=>mpi_root
-   
-   USE iophy
-
-#ifdef CPP_PSMILE
-   USE oasis
-#endif
-   USE write_field_phy
-   implicit none
-#include "indicesol.inc"
-#include "YOMCST.inc"
-! Cette routine sert d'interface entre le modele atmospherique et un 
-! coupleur avec un modele d'ocean 'complet' derriere
-!
-! Le modele de glace qu'il est prevu d'utiliser etant couple directement a 
-! l'ocean presentement, on va passer deux fois dans cette routine par pas de 
-! temps physique, une fois avec les points oceans et l'autre avec les points
-! glace. A chaque pas de temps de couplage, la lecture des champs provenant
-! du coupleur se fera "dans" l'ocean et l'ecriture des champs a envoyer
-! au coupleur "dans" la glace. Il faut donc des tableaux de travail "tampons"
-! dimensionnes sur toute la grille qui remplissent les champs sur les
-! domaines ocean/glace quand il le faut. Il est aussi necessaire que l'index
-! ocean soit traiter avant l'index glace (sinon tout intervertir)
-!
-!
-! L. Fairhead 02/2000
-!
-! input:
-!   itime        numero du pas de temps
-!   iim, jjm     nbres de pts de grille
-!   dtime        pas de temps de la physique
-!   klon         nombre total de points de grille
-!   nisurf       index de la surface a traiter (1 = sol continental)
-!   pctsrf       tableau des fractions de surface de chaque maille
-!   knon         nombre de points de la surface a traiter
-!   knindex      index des points de la surface a traiter
-!   rlon         longitudes
-!   rlat         latitudes
-!   debut        logical: 1er appel a la physique
-!   lafin        logical: dernier appel a la physique
-!   ocean        type d'ocean
-!   nexca        frequence de couplage
-!   swdown       flux solaire entrant a la surface
-!   lwdown       flux IR net a la surface
-!   precip_rain  precipitation liquide
-!   precip_snow  precipitation solide
-!   evap         evaporation
-!   tsurf        temperature de surface
-!   fder         derivee dF/dT
-!   albsol       albedo du sol (coherent avec swdown)
-!   taux         tension de vent en x
-!   tauy         tension de vent en y
-! -- LOOP
-!    windsp       module du vent a 10m
-! -- LOOP
-!   nexca        frequence de couplage
-!   zmasq        masque terre/ocean
-!
-!
-! output:
-!   tsurf_new    temperature au sol
-!   alb_new      albedo
-!   pctsrf_new   nouvelle repartition des surfaces
-!   alb_ice      albedo de la glace
-!
-
-
-! Parametres d'entree
-  integer, intent(IN) :: itime
-  integer, intent(IN) :: iim, jjm
-  real, intent(IN) :: dtime
-  integer, intent(IN) :: klon
-  integer, intent(IN) :: nisurf
-  integer, intent(IN) :: knon
-  real, dimension(klon,nbsrf), intent(IN) :: pctsrf
-  integer, dimension(klon), intent(in) :: knindex
-  logical, intent(IN) :: debut, lafin
-  real, dimension(klon), intent(IN) :: rlon, rlat
-  character (len = 6)  :: ocean
-  real, dimension(klon), intent(IN) :: lwdown, swdown
-  real, dimension(klon), intent(IN) :: precip_rain, precip_snow
-  real, dimension(klon), intent(IN) :: tsurf, fder, albsol, taux, tauy
-! -- LOOP
-   real, dimension(klon), intent(IN) :: windsp
-! -- LOOP
-  INTEGER              :: nexca, npas, kstep
-  real, dimension(klon), intent(IN) :: zmasq
-  real, dimension(klon), intent(IN) :: fluxlat, fluxsens
-  logical, intent(IN)               :: cumul
-  real, dimension(klon), intent(INOUT) :: evap
-
-! Parametres de sortie
-  real, dimension(klon), intent(OUT):: tsurf_new, alb_new
-  real, dimension(klon,nbsrf), intent(OUT) :: pctsrf_new
-
-! Variables locales
-  integer                    :: j, error, sum_error, ig, cpl_index,i
-! -- LOOP
-  INTEGER :: nsrf
-! -- LOOP
-  character (len = 20) :: modname = 'interfoce_cpl'
-  character (len = 80) :: abort_message
-  logical,save              :: check = .FALSE.
-! variables pour moyenner les variables de couplage
-  real, allocatable, dimension(:,:),save :: cpl_sols, cpl_nsol, cpl_rain
-  real, allocatable, dimension(:,:),save :: cpl_snow, cpl_evap, cpl_tsol
-  real, allocatable, dimension(:,:),save :: cpl_fder, cpl_albe, cpl_taux
-! -- LOOP
-  real, allocatable, dimension(:,:),save :: cpl_windsp
-! -- LOOP
-  real, allocatable, dimension(:,:),save :: cpl_tauy
-  REAL, ALLOCATABLE, DIMENSION(:,:),SAVE :: cpl_rriv, cpl_rcoa, cpl_rlic
-!!$
-! variables tampons avant le passage au coupleur
-  real, allocatable, dimension(:,:,:),save :: tmp_sols, tmp_nsol, tmp_rain
-  real, allocatable, dimension(:,:,:),save :: tmp_snow, tmp_evap, tmp_tsol
-  real, allocatable, dimension(:,:,:),save :: tmp_fder, tmp_albe, tmp_taux
-! -- LOOP
-  real, allocatable, dimension(:,:,:),save :: tmp_windsp
-! -- LOOP
-!!$  real, allocatable, dimension(:,:,:),save :: tmp_tauy, tmp_rriv, tmp_rcoa
-  REAL, ALLOCATABLE, DIMENSION(:,:,:),SAVE :: tmp_tauy
-! variables a passer au coupleur
-!ym  real, dimension(iim, jjm+1) :: wri_sol_ice, wri_sol_sea, wri_nsol_ice 
-!ym  real, dimension(iim, jjm+1) :: wri_nsol_sea, wri_fder_ice, wri_evap_ice
-!ym  REAL, DIMENSION(iim, jjm+1) :: wri_evap_sea, wri_rcoa, wri_rriv
-!ym  REAL, DIMENSION(iim, jjm+1) :: wri_rain, wri_snow, wri_taux, wri_tauy
-!ym  REAL, DIMENSION(iim, jjm+1) :: wri_calv
-!ym  REAL, DIMENSION(iim, jjm+1) :: wri_tauxx, wri_tauyy, wri_tauzz
-!ym  REAL, DIMENSION(iim, jjm+1) :: tmp_lon, tmp_lat
-
-  real, dimension(iim, jj_nb) :: wri_sol_ice, wri_sol_sea, wri_nsol_ice 
-  real, dimension(iim, jj_nb) :: wri_nsol_sea, wri_fder_ice, wri_evap_ice
-  REAL, DIMENSION(iim, jj_nb) :: wri_evap_sea, wri_rcoa, wri_rriv
-  REAL, DIMENSION(iim, jj_nb) :: wri_rain, wri_snow, wri_taux, wri_tauy
-  REAL, DIMENSION(iim, jj_nb) :: wri_calv
-  REAL, DIMENSION(iim, jj_nb) :: wri_tauxx, wri_tauyy, wri_tauzz
-  REAL, DIMENSION(iim, jj_nb) :: tmp_lon, tmp_lat
-  REAL, DIMENSION(iim, jj_nb) :: wri_windsp
-
-! variables relues par le coupleur
-! read_sic = fraction de glace
-! read_sit = temperature de glace
-  real, allocatable, dimension(:,:),save :: read_sst, read_sic, read_sit
-  real, allocatable, dimension(:,:),save :: read_alb_sic
-! variable tampon
-  real, dimension(klon)       :: tamp_sic
-! sauvegarde des fractions de surface d'un pas de temps a l'autre apres 
-! l'avoir lu
-  real, allocatable,dimension(:,:),save :: pctsrf_sav
-  real, dimension(iim, jj_nb, 3) :: tamp_srf
-  integer, allocatable, dimension(:), save :: tamp_ind
-  real, allocatable, dimension(:,:),save :: tamp_zmasq
-  real, dimension(iim, jj_nb) :: deno
-  integer                     :: idtime
-  integer, allocatable,dimension(:),save :: unity
-! 
-  logical, save    :: first_appel = .true.
-  logical,save          :: print
-!maf
-! variables pour avoir une sortie IOIPSL des champs echanges
-  CHARACTER*80,SAVE :: clintocplnam, clfromcplnam
-  INTEGER, SAVE :: jf,nhoridct,nidct
-  INTEGER, SAVE :: nhoridcs,nidcs
-  INTEGER :: ndexct(iim*(jjm+1)),ndexcs(iim*(jjm+1))
-  REAL :: zx_lon(iim,jjm+1), zx_lat(iim,jjm+1), zjulian
-  INTEGER,save :: idayref
-!med  integer :: itau_w
-  integer,save :: itau_w
-! -- LOOP
-  integer :: nb_interf_cpl
-! -- LOOP
-
-  real :: Up,Down
-  integer :: ierr
-  integer :: il_time_secs
-  real :: tmp_field(klon)
-  
-#include "param_cou.h"
-#include "inc_cpl.h"
-#include "temps.inc"
-#include "iniprint.h"
-
-#ifdef CPP_PARA
-  include 'mpif.h'
-  integer :: status(MPI_STATUS_SIZE)
-#endif
-
-!
-! Initialisation
-!
-  if (check) write(*,*)'Entree ',modname,'nisurf = ',nisurf
- 
-  if (first_appel) then
-    error = 0
-    allocate(unity(klon), stat = error)
-    if ( error  /=0) then
-      abort_message='Pb allocation variable unity'
-      call abort_gcm(modname,abort_message,1)
-    endif
-    allocate(pctsrf_sav(klon,nbsrf), stat = error)
-    if ( error  /=0) then
-      abort_message='Pb allocation variable pctsrf_sav'
-      call abort_gcm(modname,abort_message,1)
-    endif
-    pctsrf_sav = 0.
-
-    do ig = 1, klon
-      unity(ig) = ig
-    enddo
-    sum_error = 0
-    allocate(cpl_sols(klon,2), stat = error); sum_error = sum_error + error
-    allocate(cpl_nsol(klon,2), stat = error); sum_error = sum_error + error
-    allocate(cpl_rain(klon,2), stat = error); sum_error = sum_error + error
-    allocate(cpl_snow(klon,2), stat = error); sum_error = sum_error + error
-    allocate(cpl_evap(klon,2), stat = error); sum_error = sum_error + error
-    allocate(cpl_tsol(klon,2), stat = error); sum_error = sum_error + error
-    allocate(cpl_fder(klon,2), stat = error); sum_error = sum_error + error
-    allocate(cpl_albe(klon,2), stat = error); sum_error = sum_error + error
-    allocate(cpl_taux(klon,2), stat = error); sum_error = sum_error + error
-! -- LOOP
-     allocate(cpl_windsp(klon,2), stat = error); sum_error = sum_error + error
-! -- LOOP
-    allocate(cpl_tauy(klon,2), stat = error); sum_error = sum_error + error
-!ym    ALLOCATE(cpl_rriv(iim,jjm+1), stat=error); sum_error = sum_error + error
-!ym    ALLOCATE(cpl_rcoa(iim,jjm+1), stat=error); sum_error = sum_error + error
-!ym    ALLOCATE(cpl_rlic(iim,jjm+1), stat=error); sum_error = sum_error + error
-    ALLOCATE(cpl_rriv(iim,jj_nb), stat=error); sum_error = sum_error + error
-    ALLOCATE(cpl_rcoa(iim,jj_nb), stat=error); sum_error = sum_error + error
-    ALLOCATE(cpl_rlic(iim,jj_nb), stat=error); sum_error = sum_error + error
-
-
-!!
-!ym    allocate(read_sst(iim, jjm+1), stat = error); sum_error = sum_error + error
-!ym    allocate(read_sic(iim, jjm+1), stat = error); sum_error = sum_error + error
-!ym    allocate(read_sit(iim, jjm+1), stat = error); sum_error = sum_error + error
-!ym    allocate(read_alb_sic(iim, jjm+1), stat = error); sum_error = sum_error + error
-    allocate(read_sst(iim, jj_nb), stat = error); sum_error = sum_error + error
-    allocate(read_sic(iim, jj_nb), stat = error); sum_error = sum_error + error
-    allocate(read_sit(iim, jj_nb), stat = error); sum_error = sum_error + error
-    allocate(read_alb_sic(iim, jj_nb), stat = error); sum_error = sum_error + error
-    read_sst=0.
-    read_sic=0.
-    read_sit=0.
-    read_alb_sic=0.
-    if (sum_error /= 0) then
-      abort_message='Pb allocation variables couplees'
-      call abort_gcm(modname,abort_message,1)
-    endif
-    cpl_sols = 0.; cpl_nsol = 0.; cpl_rain = 0.; cpl_snow = 0.
-    cpl_evap = 0.; cpl_tsol = 0.; cpl_fder = 0.; cpl_albe = 0.
-    cpl_taux = 0.; cpl_tauy = 0.; cpl_rriv = 0.; cpl_rcoa = 0.; cpl_rlic = 0.
-! -- LOOP
-     cpl_windsp = 0.
-! -- LOOP
-
-    sum_error = 0
-    allocate(tamp_ind(klon), stat = error); sum_error = sum_error + error
-!ym    allocate(tamp_zmasq(iim, jjm+1), stat = error); sum_error = sum_error + error    
-    allocate(tamp_zmasq(iim, jj_nb), stat = error); sum_error = sum_error + error    
-    tamp_zmasq=1.
-    
-    do ig = 1, klon
-      tamp_ind(ig) = ig
-    enddo
-    call gath2cpl(zmasq, tamp_zmasq, klon, klon, iim, jj_nb, tamp_ind)
-!
-! initialisation couplage
-!
-    idtime = int(dtime)
-#ifdef CPP_COUPLE
-#ifdef CPP_PSMILE
-   CALL inicma(iim, (jjm+1))
-#else
-   if (is_parallel) then
-      abort_message='coupleur parallele uniquement avec PSMILE'
-      call abort_gcm(modname,abort_message,1)
-   endif
-   call inicma(npas , nexca, idtime,(jjm+1)*iim)
-#endif
-#endif
-!
-! initialisation sorties netcdf
-!
- !ym  IO de check deconnecte pour le moment en //
-    IF (is_sequential) THEN
-    idayref = day_ini
-    CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
-    CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlon,zx_lon)
-    DO i = 1, iim
-      zx_lon(i,1) = rlon(i+1)
-      zx_lon(i,jjm+1) = rlon(i+1)
-    ENDDO
-    CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlat,zx_lat)
-    clintocplnam="cpl_atm_tauflx"
-    CALL histbeg(clintocplnam, iim,zx_lon(:,1),jjm+1,zx_lat(1,:),1,iim,1,jjm+1, &
-       & itau_phy,zjulian,dtime,nhoridct,nidct) 
-! no vertical axis
-    CALL histdef(nidct, 'tauxe','tauxe', &
-         & "-",iim, jjm+1, nhoridct, 1, 1, 1, -99, 32, "inst", dtime,dtime)
-    CALL histdef(nidct, 'tauyn','tauyn', &
-         & "-",iim, jjm+1, nhoridct, 1, 1, 1, -99, 32, "inst", dtime,dtime)
-    CALL histdef(nidct, 'tmp_lon','tmp_lon', &
-         & "-",iim, jjm+1, nhoridct, 1, 1, 1, -99, 32, "inst", dtime,dtime)
-    CALL histdef(nidct, 'tmp_lat','tmp_lat', &
-         & "-",iim, jjm+1, nhoridct, 1, 1, 1, -99, 32, "inst", dtime,dtime)
-    DO jf=1,jpflda2o1 + jpflda2o2
-      CALL histdef(nidct, cl_writ(jf),cl_writ(jf), &
-         & "-",iim, jjm+1, nhoridct, 1, 1, 1, -99, 32, "inst", dtime,dtime)
-    END DO
-    CALL histend(nidct)
-    CALL histsync(nidct)
-
-    clfromcplnam="cpl_atm_sst"
-    CALL histbeg(clfromcplnam, iim,zx_lon(:,1),jjm+1,zx_lat(1,:),1,iim,1,jjm+1, &
-       & 0,zjulian,dtime,nhoridcs,nidcs) 
-! no vertical axis
-    DO jf=1,jpfldo2a
-      CALL histdef(nidcs, cl_read(jf),cl_read(jf), &
-         & "-",iim, jjm+1, nhoridcs, 1, 1, 1, -99, 32, "inst", dtime,dtime)
-    END DO
-    CALL histend(nidcs)
-    CALL histsync(nidcs)
-
-    ENDIF    ! monocpu
-    
-! pour simuler la fonte des glaciers antarctiques
-! 
-!ym => pour le moment, c'est en commentaire, donc je squizze
-
-!ym    surf_maille = (4. * rpi * ra**2) / (iim * (jjm +1))
-!ym    ALLOCATE(coeff_iceberg(iim,jjm+1), stat=error)
-!ym    if (error /= 0) then
-!ym      abort_message='Pb allocation variable coeff_iceberg'
-!ym      call abort_gcm(modname,abort_message,1)
-!ym    endif
-!ym    open (12,file='flux_iceberg',form='formatted',status='old')
-!ym    read (12,*) coeff_iceberg
-!ym    close (12)
-!ym    num_antarctic = max(1, count(coeff_iceberg > 0))
-    
-    first_appel = .false.
-  endif ! fin if (first_appel)
-
-! Initialisations
-
-! calcul des fluxs a passer
-! -- LOOP
-  nb_interf_cpl = nb_interf_cpl + 1  
-  if (check) write(lunout,*)'passage dans interface_surf.F90 :  ',nb_interf_cpl 
-! -- LOOP
-  cpl_index = 1
-  if (nisurf == is_sic) cpl_index = 2
-  if (cumul) then
-! -- LOOP
-      if (check) write(lunout,*)'passage dans cumul '
-      if (check) write(lunout,*)'valeur de cpl_index ', cpl_index 
-! -- LOOP  
-    if (check) write(*,*) modname, 'cumul des champs'
-    do ig = 1, knon
-      cpl_sols(ig,cpl_index) = cpl_sols(ig,cpl_index) &
-       &                          + swdown(ig)      / FLOAT(nexca)
-      cpl_nsol(ig,cpl_index) = cpl_nsol(ig,cpl_index) &
-       &                          + (lwdown(ig) + fluxlat(ig) +fluxsens(ig))&
-       &                                / FLOAT(nexca)
-      cpl_rain(ig,cpl_index) = cpl_rain(ig,cpl_index) &
-       &                          + precip_rain(ig) / FLOAT(nexca)
-      cpl_snow(ig,cpl_index) = cpl_snow(ig,cpl_index) &
-       &                          + precip_snow(ig) / FLOAT(nexca)
-      cpl_evap(ig,cpl_index) = cpl_evap(ig,cpl_index) &
-       &                          + evap(ig)        / FLOAT(nexca)
-      cpl_tsol(ig,cpl_index) = cpl_tsol(ig,cpl_index) &
-       &                          + tsurf(ig)       / FLOAT(nexca)
-      cpl_fder(ig,cpl_index) = cpl_fder(ig,cpl_index) &
-       &                          + fder(ig)        / FLOAT(nexca)
-      cpl_albe(ig,cpl_index) = cpl_albe(ig,cpl_index) &
-       &                          + albsol(ig)      / FLOAT(nexca)
-      cpl_taux(ig,cpl_index) = cpl_taux(ig,cpl_index) &
-       &                          + taux(ig)        / FLOAT(nexca)
-      cpl_tauy(ig,cpl_index) = cpl_tauy(ig,cpl_index) &
-       &                          + tauy(ig)        / FLOAT(nexca)
-! -- LOOP
-      IF (cpl_index .EQ. 1) THEN
-      cpl_windsp(ig,cpl_index) = cpl_windsp(ig,cpl_index) &
-       &                          + windsp(ig)      / FLOAT(nexca) 
-      ENDIF
-! -- LOOP
-    enddo
-    IF (cpl_index .EQ. 1) THEN 
-        cpl_rriv(:,:) = cpl_rriv(:,:) + tmp_rriv(:,:) / FLOAT(nexca)
-        cpl_rcoa(:,:) = cpl_rcoa(:,:) + tmp_rcoa(:,:) / FLOAT(nexca)
-        cpl_rlic(:,:) = cpl_rlic(:,:) + tmp_rlic(:,:) / FLOAT(nexca)
-    ENDIF
-  endif
-
-  if (mod(itime, nexca) == 1) then
-!
-! Demande des champs au coupleur
-!
-! Si le domaine considere est l'ocean, on lit les champs venant du coupleur
-!
-    if (nisurf == is_oce .and. .not. cumul) then
-      if (check) write(*,*)'rentree fromcpl, itime-1 = ',itime-1
-#ifdef CPP_COUPLE
-#ifdef CPP_PSMILE
-      il_time_secs=(itime-1)*dtime
-      CALL fromcpl(il_time_secs, iim, jj_nb,                           &
-     &        read_sst, read_sic, read_sit, read_alb_sic)
-#else
-     if (is_parallel) then
-        abort_message='coupleur parallele uniquement avec PSMILE'
-        call abort_gcm(modname,abort_message,1)
-     endif
-
-      call fromcpl(itime-1,(jjm+1)*iim,                                  &
-     &        read_sst, read_sic, read_sit, read_alb_sic)
-#endif
-#endif
-!
-! sorties NETCDF des champs recus
-!
-     if (is_sequential) THEN
-       ndexcs(:)=0
-       itau_w = itau_phy + itime
-       CALL histwrite(nidcs,cl_read(1),itau_w,read_sst,iim*(jjm+1),ndexcs)
-       CALL histwrite(nidcs,cl_read(2),itau_w,read_sic,iim*(jjm+1),ndexcs)
-       CALL histwrite(nidcs,cl_read(3),itau_w,read_alb_sic,iim*(jjm+1),ndexcs)
-       CALL histwrite(nidcs,cl_read(4),itau_w,read_sit,iim*(jjm+1),ndexcs)
-       CALL histsync(nidcs)
-     endif
-! pas utile      IF (npas-itime.LT.nexca )CALL histclo(nidcs)
-
-!ym      do j = 1, jjm + 1
-       do j = 1, jj_nb
-         do ig = 1, iim
-          if (abs(1. - read_sic(ig,j)) < 0.00001) then
-            read_sst(ig,j) = RTT - 1.8
-            read_sit(ig,j) = read_sit(ig,j) / read_sic(ig,j)
-            read_alb_sic(ig,j) = read_alb_sic(ig,j) / read_sic(ig,j)
-          else if (abs(read_sic(ig,j)) < 0.00001) then
-            read_sst(ig,j) = read_sst(ig,j) / (1. - read_sic(ig,j))
-            read_sit(ig,j) = read_sst(ig,j)
-            read_alb_sic(ig,j) =  0.6
-          else
-            read_sst(ig,j) = read_sst(ig,j) / (1. - read_sic(ig,j))
-            read_sit(ig,j) = read_sit(ig,j) / read_sic(ig,j)
-            read_alb_sic(ig,j) = read_alb_sic(ig,j) / read_sic(ig,j)
-          endif
-        enddo
-      enddo
-!
-! transformer read_sic en pctsrf_sav
-!
-      call cpl2gath(read_sic, tamp_sic , klon, klon,iim,jj_nb, unity)
-      do ig = 1, klon
-        IF (pctsrf(ig,is_oce) > epsfra .OR.            &
-     &             pctsrf(ig,is_sic) > epsfra) THEN
-          pctsrf_sav(ig,is_sic) = (pctsrf(ig,is_oce) + pctsrf(ig,is_sic)) &
-     &                               * tamp_sic(ig)
-          pctsrf_sav(ig,is_oce) = (pctsrf(ig,is_oce) + pctsrf(ig,is_sic)) &
-     &                        - pctsrf_sav(ig,is_sic)
-        endif
-      enddo
-!
-! Pour rattraper des erreurs d'arrondis
-!
-      where (abs(pctsrf_sav(:,is_sic)) .le. 2.*epsilon(pctsrf_sav(1,is_sic)))
-        pctsrf_sav(:,is_sic) = 0.
-        pctsrf_sav(:,is_oce) = pctsrf(:,is_oce) + pctsrf(:,is_sic)
-      endwhere
-      where (abs(pctsrf_sav(:,is_oce)) .le. 2.*epsilon(pctsrf_sav(1,is_oce)))
-        pctsrf_sav(:,is_sic) = pctsrf(:,is_oce) + pctsrf(:,is_sic)
-        pctsrf_sav(:,is_oce) = 0.
-      endwhere
-      if (minval(pctsrf_sav(:,is_oce)) < 0.) then
-        write(*,*)'Pb fraction ocean inferieure a 0'
-        write(*,*)'au point ',minloc(pctsrf_sav(:,is_oce))
-        write(*,*)'valeur = ',minval(pctsrf_sav(:,is_oce)) 
-        abort_message = 'voir ci-dessus'
-        call abort_gcm(modname,abort_message,1)
-      endif
-      if (minval(pctsrf_sav(:,is_sic)) < 0.) then
-        write(*,*)'Pb fraction glace inferieure a 0'
-        write(*,*)'au point ',minloc(pctsrf_sav(:,is_sic))
-        write(*,*)'valeur = ',minval(pctsrf_sav(:,is_sic)) 
-        abort_message = 'voir ci-dessus'
-        call abort_gcm(modname,abort_message,1)
-      endif
-    endif 
-  endif                         ! fin mod(itime, nexca) == 1
-
-  if (mod(itime, nexca) == 0) then
-!
-! allocation memoire
-    if (nisurf == is_oce .and. (.not. cumul) ) then
-      sum_error = 0
-      allocate(tmp_sols(iim,jj_nb,2), stat=error); sum_error = sum_error + error
-      allocate(tmp_nsol(iim,jj_nb,2), stat=error); sum_error = sum_error + error
-      allocate(tmp_rain(iim,jj_nb,2), stat=error); sum_error = sum_error + error
-      allocate(tmp_snow(iim,jj_nb,2), stat=error); sum_error = sum_error + error
-      allocate(tmp_evap(iim,jj_nb,2), stat=error); sum_error = sum_error + error
-      allocate(tmp_tsol(iim,jj_nb,2), stat=error); sum_error = sum_error + error
-      allocate(tmp_fder(iim,jj_nb,2), stat=error); sum_error = sum_error + error
-      allocate(tmp_albe(iim,jj_nb,2), stat=error); sum_error = sum_error + error
-      allocate(tmp_taux(iim,jj_nb,2), stat=error); sum_error = sum_error + error
-      allocate(tmp_tauy(iim,jj_nb,2), stat=error); sum_error = sum_error + error
-! -- LOOP
-       allocate(tmp_windsp(iim,jj_nb,2), stat=error); sum_error = sum_error + error
-! -- LOOP
-!!$      allocate(tmp_rriv(iim,jjm+1,2), stat=error); sum_error = sum_error + error
-!!$      allocate(tmp_rcoa(iim,jjm+1,2), stat=error); sum_error = sum_error + error
-      if (sum_error /= 0) then
-        abort_message='Pb allocation variables couplees pour l''ecriture'
-        call abort_gcm(modname,abort_message,1)
-      endif
-    endif
-
-!
-! Mise sur la bonne grille des champs a passer au coupleur
-!
-    cpl_index = 1
-    if (nisurf == is_sic) cpl_index = 2
-    call gath2cpl(cpl_sols(1,cpl_index), tmp_sols(1,1,cpl_index), klon, knon,iim,jj_nb,                  knindex)
-    call gath2cpl(cpl_nsol(1,cpl_index), tmp_nsol(1,1,cpl_index), klon, knon,iim,jj_nb,                  knindex)
-    call gath2cpl(cpl_rain(1,cpl_index), tmp_rain(1,1,cpl_index), klon, knon,iim,jj_nb,                  knindex)
-    call gath2cpl(cpl_snow(1,cpl_index), tmp_snow(1,1,cpl_index), klon, knon,iim,jj_nb,                  knindex)
-    call gath2cpl(cpl_evap(1,cpl_index), tmp_evap(1,1,cpl_index), klon, knon,iim,jj_nb,                  knindex)
-    call gath2cpl(cpl_tsol(1,cpl_index), tmp_tsol(1,1,cpl_index), klon, knon,iim,jj_nb,                  knindex)
-    call gath2cpl(cpl_fder(1,cpl_index), tmp_fder(1,1,cpl_index), klon, knon,iim,jj_nb,                  knindex)
-    call gath2cpl(cpl_albe(1,cpl_index), tmp_albe(1,1,cpl_index), klon, knon,iim,jj_nb,                  knindex)
-    call gath2cpl(cpl_taux(1,cpl_index), tmp_taux(1,1,cpl_index), klon, knon,iim,jj_nb,                  knindex)
-    call gath2cpl(cpl_tauy(1,cpl_index), tmp_tauy(1,1,cpl_index), klon, knon,iim,jj_nb,                  knindex)
-! -- LOOP
-     call gath2cpl(cpl_windsp(1,cpl_index), tmp_windsp(1,1,cpl_index), klon, knon,iim,jj_nb,            knindex)
-! -- LOOP
-
-!
-! Si le domaine considere est la banquise, on envoie les champs au coupleur
-!
-    if (nisurf == is_sic .and. cumul) then
-      wri_rain = 0.; wri_snow = 0.; wri_rcoa = 0.; wri_rriv = 0. 
-      wri_taux = 0.; wri_tauy = 0.
-! -- LOOP
-       wri_windsp = 0.
-! -- LOOP      
-      call gath2cpl(pctsrf(1,is_oce), tamp_srf(1,1,1), klon, klon, iim, jj_nb, tamp_ind)
-      call gath2cpl(pctsrf(1,is_sic), tamp_srf(1,1,2), klon, klon, iim, jj_nb, tamp_ind)
-
-      wri_sol_ice = tmp_sols(:,:,2)
-      wri_sol_sea = tmp_sols(:,:,1)
-      wri_nsol_ice = tmp_nsol(:,:,2)
-      wri_nsol_sea = tmp_nsol(:,:,1)
-      wri_fder_ice = tmp_fder(:,:,2)
-      wri_evap_ice = tmp_evap(:,:,2)
-      wri_evap_sea = tmp_evap(:,:,1)
-! -- LOOP
-       wri_windsp = tmp_windsp(:,:,1)
-! -- LOOP
-
-!!$PB
-      wri_rriv = cpl_rriv(:,:)
-      wri_rcoa = cpl_rcoa(:,:)
-
-!ym  !! ATTENTION ICI
-      
-!ym      DO j = 1, jjm + 1
-!ym        wri_calv(:,j) = sum(cpl_rlic(:,j)) / iim
-!ym      enddo
-
-!Essai OM+JLD : ca marche !!!! (17 mars 2006)
-      tamp_srf(:,:,3)=0.
-      CALL gath2cpl( pctsrf(1,is_lic), tamp_srf(1,1,3), klon, klon, iim, jj_nb, tamp_ind)
-
-!YM pour retrouver resultat avant tamp_srf(:,3)=1.
-      
-      DO j = 1, jj_nb
-         wri_calv(:,j) = DOT_PRODUCT (cpl_rlic(1:iim,j), tamp_srf(1:iim,j,3)) / REAL(iim)
-      ENDDO
-
-!ym      wri_calv(:,:)=0.
-!ym      DO j = 1, jjphy_nb
-!ym        wri_calv(:,j) = sum(cpl_rlic(:,j))/iim
-!ym      enddo
-
-      IF (is_parallel) THEN
-        if (.NOT.is_north_pole) then
-#ifdef CPP_PARA
-          call MPI_RECV(Up,1,MPI_REAL_LMDZ,mpi_rank-1,1234,COMM_LMDZ_PHY,status,ierr)
-          call MPI_SEND(wri_calv(1,1),1,MPI_REAL_LMDZ,mpi_rank-1,1234,COMM_LMDZ_PHY,ierr)
-#endif
-        endif
-        
-        if (.NOT.is_south_pole) then
-#ifdef CPP_PARA
-          call MPI_SEND(wri_calv(1,jj_nb),1,MPI_REAL_LMDZ,mpi_rank+1,1234,COMM_LMDZ_PHY,ierr)  
-          call MPI_RECV(down,1,MPI_REAL_LMDZ,mpi_rank+1,1234,COMM_LMDZ_PHY,status,ierr)
-#endif
-        endif
-  	
-        if (mpi_rank /=0 .and. ii_begin /=1) then
-          Up=Up+wri_calv(iim,1)
-	  wri_calv(:,1)=Up
-        endif
-      
-        if (mpi_rank /=mpi_size-1 .and. ii_end /= iim) then
-          Down=Down+wri_calv(1,jj_nb)
-	  wri_calv(:,jj_nb)=Down	 
-        endif
-      ENDIF
-      
-      where (tamp_zmasq /= 1.)
-        deno =  tamp_srf(:,:,1) + tamp_srf(:,:,2)
-        wri_rain = tmp_rain(:,:,1) * tamp_srf(:,:,1) / deno +    &
-      &            tmp_rain(:,:,2) * tamp_srf(:,:,2) / deno
-        wri_snow = tmp_snow(:,:,1) * tamp_srf(:,:,1) / deno +    &
-      &            tmp_snow(:,:,2) * tamp_srf(:,:,2) / deno
-        wri_taux = tmp_taux(:,:,1) * tamp_srf(:,:,1) / deno +    &
-      &            tmp_taux(:,:,2) * tamp_srf(:,:,2) / deno
-        wri_tauy = tmp_tauy(:,:,1) * tamp_srf(:,:,1) / deno +    &
-      &            tmp_tauy(:,:,2) * tamp_srf(:,:,2) / deno
-      endwhere
-!
-! pour simuler la fonte des glaciers antarctiques
-!
-!$$$        wri_rain = wri_rain      &
-!$$$      &     + coeff_iceberg * cte_flux_iceberg / (num_antarctic * surf_maille)
-!      wri_calv = coeff_iceberg * cte_flux_iceberg / (num_antarctic * surf_maille)
-!
-! on passe les coordonnees de la grille
-!
-
-!ym      CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlon,tmp_lon)
-!ym      CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlat,tmp_lat)
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!! ATENTION A NE PAS OUBLIER
-!!! REMPLACER phy2dyn par grid1DTo2D_mpi
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-       CALL Grid1DTo2D_mpi(rlon,tmp_lon)
-       CALL Grid1DTo2D_mpi(rlat,tmp_lat)
-
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-     IF (is_sequential) THEN
-       IF (is_north_pole) tmp_lon(:,1) = tmp_lon(:,2)
-       IF (is_south_pole) tmp_lon(:,jjm + 1) = tmp_lon(:,jjm)
-     ENDIF
-!
-! sortie netcdf des champs pour le changement de repere
-!
-      IF (is_sequential) THEN
-        ndexct(:)=0
-        CALL histwrite(nidct,'tauxe',itau_w,wri_taux,iim*(jjm+1),ndexct)
-        CALL histwrite(nidct,'tauyn',itau_w,wri_tauy,iim*(jjm+1),ndexct)
-        CALL histwrite(nidct,'tmp_lon',itau_w,tmp_lon,iim*(jjm+1),ndexct)
-        CALL histwrite(nidct,'tmp_lat',itau_w,tmp_lat,iim*(jjm+1),ndexct)
-      ENDIF  
-!
-! calcul 3 coordonnees du vent
-!
-      CALL atm2geo (iim , jj_nb, wri_taux, wri_tauy, tmp_lon, tmp_lat, &
-         & wri_tauxx, wri_tauyy, wri_tauzz )
-!
-! sortie netcdf des champs apres changement de repere et juste avant
-! envoi au coupleur
-!
-    IF (is_sequential) THEN
-      CALL histwrite(nidct,cl_writ(8),itau_w,wri_sol_ice,iim*(jjm+1),ndexct)
-      CALL histwrite(nidct,cl_writ(9),itau_w,wri_sol_sea,iim*(jjm+1),ndexct)
-      CALL histwrite(nidct,cl_writ(10),itau_w,wri_nsol_ice,iim*(jjm+1),ndexct)
-      CALL histwrite(nidct,cl_writ(11),itau_w,wri_nsol_sea,iim*(jjm+1),ndexct)
-      CALL histwrite(nidct,cl_writ(12),itau_w,wri_fder_ice,iim*(jjm+1),ndexct)
-      CALL histwrite(nidct,cl_writ(13),itau_w,wri_evap_ice,iim*(jjm+1),ndexct)
-      CALL histwrite(nidct,cl_writ(14),itau_w,wri_evap_sea,iim*(jjm+1),ndexct)
-      CALL histwrite(nidct,cl_writ(15),itau_w,wri_rain,iim*(jjm+1),ndexct)
-      CALL histwrite(nidct,cl_writ(16),itau_w,wri_snow,iim*(jjm+1),ndexct)
-      CALL histwrite(nidct,cl_writ(17),itau_w,wri_rcoa,iim*(jjm+1),ndexct)
-      CALL histwrite(nidct,cl_writ(18),itau_w,wri_rriv,iim*(jjm+1),ndexct)
-      CALL histwrite(nidct,cl_writ(19),itau_w,wri_calv,iim*(jjm+1),ndexct)
-      CALL histwrite(nidct,cl_writ(1),itau_w,wri_tauxx,iim*(jjm+1),ndexct)
-      CALL histwrite(nidct,cl_writ(2),itau_w,wri_tauyy,iim*(jjm+1),ndexct)
-      CALL histwrite(nidct,cl_writ(3),itau_w,wri_tauzz,iim*(jjm+1),ndexct)
-      CALL histwrite(nidct,cl_writ(4),itau_w,wri_tauxx,iim*(jjm+1),ndexct)
-      CALL histwrite(nidct,cl_writ(5),itau_w,wri_tauyy,iim*(jjm+1),ndexct)
-      CALL histwrite(nidct,cl_writ(6),itau_w,wri_tauzz,iim*(jjm+1),ndexct)
-! -- LOOP
-      CALL histwrite(nidct,cl_writ(7),itau_w,wri_windsp,iim*(jjm+1),ndexct)
-! -- LOOP
-      CALL histsync(nidct)
-    ENDIF
-! pas utile      IF (lafin) CALL histclo(nidct)
-#ifdef CPP_COUPLE
-#ifdef CPP_PSMILE
-      il_time_secs=(itime-1)*dtime
-      
-      CALL intocpl(il_time_secs, iim, jjm+1, wri_sol_ice, wri_sol_sea, wri_nsol_ice,&
-      & wri_nsol_sea, wri_fder_ice, wri_evap_ice, wri_evap_sea, wri_rain, &
-      & wri_snow, wri_rcoa, wri_rriv, wri_calv, wri_tauxx, wri_tauyy,     &
-      & wri_tauzz, wri_tauxx, wri_tauyy, wri_tauzz,                       &
-! -- LOOP
-      & wri_windsp,lafin)
-! -- LOOP
-#else
-      call intocpl(itime, (jjm+1)*iim, wri_sol_ice, wri_sol_sea, wri_nsol_ice,&
-      & wri_nsol_sea, wri_fder_ice, wri_evap_ice, wri_evap_sea, wri_rain, &
-      & wri_snow, wri_rcoa, wri_rriv, wri_calv, wri_tauxx, wri_tauyy,     &
-      & wri_tauzz, wri_tauxx, wri_tauyy, wri_tauzz,                       &
-! -- LOOP
-      & wri_windsp,lafin)
-! -- LOOP
-#endif
-#endif
-! 
-      cpl_sols = 0.; cpl_nsol = 0.; cpl_rain = 0.; cpl_snow = 0.
-      cpl_evap = 0.; cpl_tsol = 0.; cpl_fder = 0.; cpl_albe = 0.
-      cpl_taux = 0.; cpl_tauy = 0.; cpl_rriv = 0.; cpl_rcoa = 0.; cpl_rlic = 0.
-! -- LOOP
-      cpl_windsp = 0.
-! -- LOOP
-!
-! deallocation memoire variables temporaires
-!
-      sum_error = 0
-      deallocate(tmp_sols, stat=error); sum_error = sum_error + error
-      deallocate(tmp_nsol, stat=error); sum_error = sum_error + error
-      deallocate(tmp_rain, stat=error); sum_error = sum_error + error
-      deallocate(tmp_snow, stat=error); sum_error = sum_error + error
-      deallocate(tmp_evap, stat=error); sum_error = sum_error + error
-      deallocate(tmp_fder, stat=error); sum_error = sum_error + error
-      deallocate(tmp_tsol, stat=error); sum_error = sum_error + error
-      deallocate(tmp_albe, stat=error); sum_error = sum_error + error
-      deallocate(tmp_taux, stat=error); sum_error = sum_error + error
-      deallocate(tmp_tauy, stat=error); sum_error = sum_error + error
-! -- LOOP
-      deallocate(tmp_windsp, stat=error); sum_error = sum_error + error
-! -- LOOP
-!!$PB
-!!$      deallocate(tmp_rriv, stat=error); sum_error = sum_error + error
-!!$      deallocate(tmp_rcoa, stat=error); sum_error = sum_error + error
-      if (sum_error /= 0) then
-        abort_message='Pb deallocation variables couplees'
-        call abort_gcm(modname,abort_message,1)
-      endif
-
-    endif
-
-  endif            ! fin (mod(itime, nexca) == 0)
-!
-! on range les variables lues/sauvegardees dans les bonnes variables de sortie
-!
-  if (nisurf == is_oce) then
-    call cpl2gath(read_sst, tsurf_new, klon, knon,iim,jj_nb, knindex)
-  else if (nisurf == is_sic) then
-    call cpl2gath(read_sit, tsurf_new, klon, knon,iim,jj_nb, knindex)
-    call cpl2gath(read_alb_sic, alb_new, klon, knon,iim,jj_nb, knindex)
-  endif
-  pctsrf_new(:,nisurf) = pctsrf_sav(:,nisurf)
-  
-  if (mod(itime, nexca) == -1) then
-    tmp_field=0.
-    do i = 1, knon
-      ig = knindex(i)
-      tmp_field(ig) = 1.
-    enddo    
-!ym    call WriteField_phy('knindex',tmp_field,1)
-    
-    tmp_field=0.
-    do i = 1, knon
-      ig = knindex(i)
-      tmp_field(ig) = tsurf_new(i)
-    enddo    
-!ym    call WriteField_phy('tsurf_new',tmp_field,1)
-    
-    tmp_field=0.
-    do i = 1, knon
-      ig = knindex(i)
-      tmp_field(ig) = alb_new(i)
-    enddo    
-!ym    call WriteField_phy('alb_new',tmp_field,1)
-    
-!    tmp_field=0.
-!   do i = 1, knon
-!      ig = knindex(i)
-!      tmp_field(ig) = pctsrf_new(i,nisurf)
- !   enddo    
-!ym    call WriteField_phy('pctsrf_new', pctsrf_new(:,nisurf),1)
-  endif
-!ym  do j=1,jjphy_nb
-!ym    do i=1,iim
-!ym      print *,phy_rank,'read_sst(',i,',',j,')=',read_sst(i,j)
-!ym    enddo
-!ym  enddo
-  
-!ym  do i=1,knon
-!ym    print *,phy_rank,'tsurf_new(',i,')=',tsurf_new(i)
-!ym  enddo
-!  if (lafin) call quitcpl
-
-  END SUBROUTINE interfoce_cpl
-!
-!#########################################################################
-!
-   SUBROUTINE interfoce_slab(klon, debut, itap, dtime, ijour, &
- & radsol, fluxo, fluxg, pctsrf, &
- & tslab, seaice, pctsrf_slab)
-!
-! Cette routine calcule la temperature d'un slab ocean, la glace de mer 
-! et les pourcentages de la maille couverte par l'ocean libre et/ou 
-! la glace de mer pour un "slab" ocean de 50m
-!
-! Conception: Laurent Li
-! Re-ecriture + adaptation LMDZ4: I. Musat
-!
-! input:
-!   klon         nombre total de points de grille
-!   debut        logical: 1er appel a la physique
-!   itap         numero du pas de temps
-!   dtime        pas de temps de la physique (en s)
-!   ijour        jour dans l'annee en cours
-!   radsol       rayonnement net au sol (LW + SW)
-!   fluxo        flux turbulent (sensible + latent) sur les mailles oceaniques 
-!   fluxg        flux de conduction entre la surface de la glace de mer et l'ocean
-!   pctsrf       tableau des pourcentages de surface de chaque maille
-! output: 
-!   tslab        temperature de l'ocean libre
-!   seaice       glace de mer (kg/m2)
-!   pctsrf_slab  "pourcentages" (valeurs entre 0. et 1.) surfaces issus du slab
-!
-#include "indicesol.inc"
-#include "clesphys.inc"
-! Parametres d'entree
-  integer, intent(IN) :: klon
-  logical, intent(IN) :: debut
-  INTEGER, intent(IN) :: itap
-  REAL, intent(IN) :: dtime
-  INTEGER, intent(IN) :: ijour
-  REAL, dimension(klon), intent(IN) :: radsol
-  REAL, dimension(klon), intent(IN) :: fluxo
-  REAL, dimension(klon), intent(IN) :: fluxg
-  real, dimension(klon, nbsrf), intent(IN) :: pctsrf
-! Parametres de sortie
-  real, dimension(klon), intent(INOUT) :: tslab
-  real, dimension(klon), intent(INOUT)        :: seaice ! glace de mer (kg/m2)
-  real, dimension(klon, nbsrf), intent(OUT) :: pctsrf_slab
-!
-! Variables locales :
-  REAL :: amn, amx
-  INTEGER, save :: lmt_pas, julien, idayvrai
-!$OMP THREADPRIVATE(lmt_pas, julien, idayvrai) 
-  REAL, parameter :: unjour=86400.
-  real, allocatable, dimension(:), save :: tmp_tslab, tmp_seaice
-  REAL, allocatable, dimension(:), save :: slab_bils
-  REAL, allocatable, dimension(:), save :: lmt_bils
-!$OMP THREADPRIVATE(tmp_tslab, tmp_seaice,slab_bils,lmt_bils)
-  logical,save              :: check = .false.
-!$OMP THREADPRIVATE(check) 
-
-!
-  REAL, parameter :: cyang=50.0 * 4.228e+06 ! capacite calorifique volumetrique de l'eau J/(m2 K)
-  REAL, parameter :: cbing=0.334e+05        ! J/kg
-  real, dimension(klon)                 :: siceh !hauteur de la glace de mer (m)
-  INTEGER :: i
-  integer :: sum_error, error
-  REAL :: zz, za, zb
-!
-  character (len = 80) :: abort_message
-  character (len = 20) :: modname = 'interfoce_slab'
-!
-  julien = MOD(ijour,360)
-  sum_error = 0
-  IF (debut) THEN
-   allocate(slab_bils(klon), stat = error); sum_error = sum_error + error
-   allocate(lmt_bils(klon), stat = error); sum_error = sum_error + error
-   allocate(tmp_tslab(klon), stat = error); sum_error = sum_error + error
-   allocate(tmp_seaice(klon), stat = error); sum_error = sum_error + error
-   if (sum_error /= 0) then
-    abort_message='Pb allocation var. slab_bils,lmt_bils,tmp_tslab,tmp_seaice'
-    call abort_gcm(modname,abort_message,1)
-   endif
-   tmp_tslab=tslab
-   tmp_seaice=seaice
-   lmt_pas = nint(86400./dtime * 1.0) ! pour une lecture une fois par jour
-!
-   IF (check) THEN
-    PRINT*,'interfoce_slab klon, debut, itap, dtime, ijour, &
- &          lmt_pas ', klon, debut, itap, dtime, ijour, &
- &          lmt_pas
-   ENDIF !check
-!
-   PRINT*, '************************'
-   PRINT*, 'SLAB OCEAN est actif, prenez precautions !'
-   PRINT*, '************************'
-!
-! a mettre un slab_bils aussi en force !!!
-!
-    DO i = 1, klon
-     slab_bils(i) = 0.0
-    ENDDO
-!
-   ENDIF !debut
-!
-   IF (check ) THEN
-    amn=MIN(tmp_tslab(1),1000.)
-    amx=MAX(tmp_tslab(1),-1000.)
-    DO i=2, klon
-     amn=MIN(tmp_tslab(i),amn)
-     amx=MAX(tmp_tslab(i),amx)
-    ENDDO
-!
-    PRINT*,' debut min max tslab',amn,amx 
-!
-!!
-    PRINT*,' itap,lmt_pas unjour',itap,lmt_pas,unjour
-   ENDIF 
-!!
-!
-   pctsrf_slab(1:klon,1:nbsrf) = pctsrf(1:klon,1:nbsrf)
-!
-! lecture du bilan au sol lmt_bils issu d'une simulation forcee en debut de journee
-! 
-   IF (MOD(itap,lmt_pas) .EQ. 1) THEN !1er pas de temps de la journee
-    idayvrai = ijour
-    CALL condsurf(julien,idayvrai, lmt_bils)
-   ENDIF !(MOD(itap-1,lmt_pas) .EQ. 0) THEN
-
-   DO i = 1, klon
-     IF((pctsrf_slab(i,is_oce).GT.epsfra).OR. &
-     &  (pctsrf_slab(i,is_sic).GT.epsfra)) THEN
-!
-! fabriquer de la glace si congelation atteinte:
-!
-      IF (tmp_tslab(i).LT.(RTT-1.8)) THEN
-       zz =  (RTT-1.8)-tmp_tslab(i)
-       tmp_seaice(i) = tmp_seaice(i) + cyang/cbing * zz
-       seaice(i) = tmp_seaice(i)
-       tmp_tslab(i) = RTT-1.8
-      ENDIF
-!
-! faire fondre de la glace si temperature est superieure a 0:
-!
-      IF ((tmp_tslab(i).GT.RTT) .AND. (tmp_seaice(i).GT.0.0)) THEN
-       zz = cyang/cbing * (tmp_tslab(i)-RTT)
-       zz = MIN(zz,tmp_seaice(i))
-       tmp_seaice(i) = tmp_seaice(i) - zz
-       seaice(i) = tmp_seaice(i)
-       tmp_tslab(i) = tmp_tslab(i) - zz*cbing/cyang
-      ENDIF
-!
-! limiter la glace de mer a 10 metres (10000 kg/m2)
-!
-      IF(tmp_seaice(i).GT.45.) THEN
-       tmp_seaice(i) = MIN(tmp_seaice(i),10000.0)
-      ELSE
-       tmp_seaice(i) = 0. 
-      ENDIF
-      seaice(i) = tmp_seaice(i)
-      siceh(i)=tmp_seaice(i)/1000. !en metres
-!
-! determiner la nature du sol (glace de mer ou ocean libre):
-!
-! on fait dependre la fraction de seaice "pctsrf(i,is_sic)" 
-! de l'epaisseur de seaice :
-! pctsrf(i,is_sic)=1. si l'epaisseur de la glace de mer est >= a 20cm
-! et pctsrf(i,is_sic) croit lineairement avec seaice de 0. a 20cm d'epaisseur
-!
-
-     IF(.NOT.ok_slab_sicOBS) then
-      pctsrf_slab(i,is_sic)=MIN(siceh(i)/0.20, &
-     &                      1.-(pctsrf_slab(i,is_ter)+pctsrf_slab(i,is_lic)))
-      pctsrf_slab(i,is_oce)=1.0 - &
-     &      (pctsrf_slab(i,is_ter)+pctsrf_slab(i,is_lic)+pctsrf_slab(i,is_sic))
-     ELSE
-      IF (i.EQ.1) print*,'cas ok_slab_sicOBS TRUE : passe sur la modif.'
-     ENDIF !(.NOT.ok_slab_sicOBS) then
-     ENDIF !pctsrf
-   ENDDO
-!
-! Calculer le bilan du flux de chaleur au sol :
-!
-   DO i = 1, klon
-    za = radsol(i) + fluxo(i)
-    zb = fluxg(i)
-    IF((pctsrf_slab(i,is_oce).GT.epsfra).OR. &
-   &   (pctsrf_slab(i,is_sic).GT.epsfra)) THEN
-     slab_bils(i)=slab_bils(i)+(za*pctsrf_slab(i,is_oce) &
-   &             +zb*pctsrf_slab(i,is_sic))/ FLOAT(lmt_pas)
-    ENDIF
-   ENDDO !klon
-!
-! calcul tslab 
-!
-   IF (MOD(itap,lmt_pas).EQ.0) THEN !fin de journee
-!
-! calcul tslab 
-    amn=MIN(tmp_tslab(1),1000.)
-    amx=MAX(tmp_tslab(1),-1000.)
-    DO i = 1, klon
-      IF ((pctsrf_slab(i,is_oce).GT.epsfra).OR. &
-     &    (pctsrf_slab(i,is_sic).GT.epsfra)) THEN
-       tmp_tslab(i) = tmp_tslab(i) + &
-     & (slab_bils(i)-lmt_bils(i)) &
-     &                         /cyang*unjour
-! on remet l'accumulation a 0
-       slab_bils(i) = 0.
-      ENDIF !pctsrf
-!
-      IF (check) THEN
-       IF(i.EQ.1) THEN  
-        PRINT*,'i tmp_tslab MOD(itap,lmt_pas).EQ.0 sicINTER',i,itap, &
-      & tmp_tslab(i), tmp_seaice(i)
-       ENDIF
-!
-       amn=MIN(tmp_tslab(i),amn)
-       amx=MAX(tmp_tslab(i),amx)
-      ENDIF
-    ENDDO !klon
-   ENDIF !(MOD(itap,lmt_pas).EQ.0) THEN
-!
-   IF ( check ) THEN
-    PRINT*,'fin min max tslab',amn,amx 
-   ENDIF 
-!
-   tslab = tmp_tslab
-   seaice = tmp_seaice
-  END SUBROUTINE interfoce_slab
-!
-!#########################################################################
-!
-  SUBROUTINE interfoce_lim(itime, dtime, jour, &
-     & klon, nisurf, knon, knindex, &
-     & debut,  &
-     & lmt_sst_p, pctsrf_new_p)
-     
-     USE mod_grid_phy_lmdz
-     USE mod_phys_lmdz_para
-#include "indicesol.inc"
-
-! Cette routine sert d'interface entre le modele atmospherique et un fichier
-! de conditions aux limites
-!
-! L. Fairhead 02/2000
-!
-! input:
-!   itime        numero du pas de temps courant
-!   dtime        pas de temps de la physique (en s)
-!   jour         jour a lire dans l'annee
-!   nisurf       index de la surface a traiter (1 = sol continental)
-!   knon         nombre de points dans le domaine a traiter
-!   knindex      index des points de la surface a traiter
-!   klon         taille de la grille
-!   debut        logical: 1er appel a la physique (initialisation)
-!
-! output:
-!   lmt_sst      SST lues dans le fichier de CL
-!   pctsrf_new   sous-maille fractionnelle
-!
-
-
-! Parametres d'entree
-  integer, intent(IN) :: itime
-  real   , intent(IN) :: dtime
-  integer, intent(IN) :: jour
-  integer, intent(in) :: klon
-  integer, intent(IN) :: nisurf
-  integer, intent(IN) :: knon
-  integer, dimension(klon_loc), intent(in) :: knindex
-  logical, intent(IN) :: debut
-
-! Parametres de sortie
-  real, intent(out), dimension(klon_loc) :: lmt_sst_p
-  real, intent(out), dimension(klon_loc,nbsrf) :: pctsrf_new_p
-
-!  real, dimension(klon) :: lmt_sst
-  real, dimension(klon_glo,nbsrf) :: pctsrf_new
-
-! Variables locales
-  integer     :: ii
-  INTEGER,save :: lmt_pas     ! frequence de lecture des conditions limites 
-                             ! (en pas de physique)
-!$OMP THREADPRIVATE(lmt_pas)
-  logical,save :: deja_lu    ! pour indiquer que le jour a lire a deja
-                             ! lu pour une surface precedente
-!$OMP THREADPRIVATE(deja_lu)
-  integer,save :: jour_lu 
-!$OMP THREADPRIVATE(jour_lu)
-  integer      :: ierr
-  character (len = 20) :: modname = 'interfoce_lim'
-  character (len = 80) :: abort_message
-  character (len = 20),save :: fich ='limit.nc'
-!$OMP THREADPRIVATE(fich)
-  logical, save     :: newlmt = .TRUE.
-!$OMP THREADPRIVATE(newlmt)
-  logical, save     :: check = .FALSE.
-!$OMP THREADPRIVATE(check)
-! Champs lus dans le fichier de CL
-  real, allocatable , save, dimension(:) :: sst_lu_p
-!$OMP THREADPRIVATE(sst_lu_p)
-
-  real, allocatable , save, dimension(:,:) :: pct_tmp_p
-!$OMP THREADPRIVATE(pct_tmp_p)
-  real, dimension(klon_glo,nbsrf) :: pct_tmp
-  real, dimension(klon_glo) :: sst_lu
-  real, dimension(klon_glo) :: nat_lu
-!
-! quelques variables pour netcdf
-!
-#include "netcdf.inc"
-  integer              :: nid, nvarid
-  integer, dimension(2) :: start, epais
-!
-! Fin declaration
-!
-  
-  if (debut .and. .not. allocated(sst_lu_p)) then
-    lmt_pas = nint(86400./dtime * 1.0) ! pour une lecture une fois par jour
-    jour_lu = jour - 1
-    allocate(sst_lu_p(klon_loc))
-    allocate(pct_tmp_p(klon_loc,nbsrf))
-  endif
-
-  if ((jour - jour_lu) /= 0) deja_lu = .false.
-  
-  if (check) write(*,*)modname,' :: jour, jour_lu, deja_lu', jour, jour_lu, deja_lu 
-  if (check) write(*,*)modname,' :: itime, lmt_pas ', itime, lmt_pas,dtime
-
-! Tester d'abord si c'est le moment de lire le fichier
-  if (mod(itime-1, lmt_pas) == 0 .and. .not. deja_lu) then
-!
-! Ouverture du fichier
-!
-!$OMP MASTER
-    if (is_mpi_root) then
-    
-    fich = trim(fich)
-    ierr = NF_OPEN (fich, NF_NOWRITE,nid)
-    if (ierr.NE.NF_NOERR) then
-      abort_message = 'Pb d''ouverture du fichier de conditions aux limites'
-      call abort_gcm(modname,abort_message,1)
-    endif
-! 
-! La tranche de donnees a lire:
-!
-    start(1) = 1
-    start(2) = jour
-    epais(1) = klon_glo
-    epais(2) = 1
-!
-    if (newlmt) then
-!
-! Fraction "ocean" 
-!
-      ierr = NF_INQ_VARID(nid, 'FOCE', nvarid)
-      if (ierr /= NF_NOERR) then
-        abort_message = 'Le champ <FOCE> est absent'
-        call abort_gcm(modname,abort_message,1)
-      endif
-#ifdef NC_DOUBLE
-      ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais,pct_tmp(1,is_oce))
-#else
-      ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais,pct_tmp(1,is_oce))
-#endif
-      if (ierr /= NF_NOERR) then
-        abort_message = 'Lecture echouee pour <FOCE>'
-        call abort_gcm(modname,abort_message,1)
-      endif
-!
-! Fraction "glace de mer" 
-!
-      ierr = NF_INQ_VARID(nid, 'FSIC', nvarid)
-      if (ierr /= NF_NOERR) then
-        abort_message = 'Le champ <FSIC> est absent'
-        call abort_gcm(modname,abort_message,1)
-      endif
-#ifdef NC_DOUBLE
-      ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais,pct_tmp(1,is_sic))
-#else
-      ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais,pct_tmp(1,is_sic))
-#endif
-      if (ierr /= NF_NOERR) then
-        abort_message = 'Lecture echouee pour <FSIC>'
-        call abort_gcm(modname,abort_message,1)
-      endif
-!
-! Fraction "terre" 
-!
-      ierr = NF_INQ_VARID(nid, 'FTER', nvarid)
-      if (ierr /= NF_NOERR) then
-        abort_message = 'Le champ <FTER> est absent'
-        call abort_gcm(modname,abort_message,1)
-      endif
-#ifdef NC_DOUBLE
-      ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais,pct_tmp(1,is_ter))
-#else
-      ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais,pct_tmp(1,is_ter))
-#endif
-      if (ierr /= NF_NOERR) then
-        abort_message = 'Lecture echouee pour <FTER>'
-        call abort_gcm(modname,abort_message,1)
-      endif
-!
-! Fraction "glacier terre" 
-!
-      ierr = NF_INQ_VARID(nid, 'FLIC', nvarid)
-      if (ierr /= NF_NOERR) then
-        abort_message = 'Le champ <FLIC> est absent'
-        call abort_gcm(modname,abort_message,1)
-      endif
-#ifdef NC_DOUBLE
-      ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais,pct_tmp(1,is_lic))
-#else
-      ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais,pct_tmp(1,is_lic))
-#endif
-      if (ierr /= NF_NOERR) then
-        abort_message = 'Lecture echouee pour <FLIC>'
-        call abort_gcm(modname,abort_message,1)
-      endif
-!
-    else  ! on en est toujours a rnatur
-! 
-      ierr = NF_INQ_VARID(nid, 'NAT', nvarid)
-      if (ierr /= NF_NOERR) then
-        abort_message = 'Le champ <NAT> est absent'
-        call abort_gcm(modname,abort_message,1)
-      endif
-#ifdef NC_DOUBLE
-      ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais, nat_lu)
-#else
-      ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais, nat_lu)
-#endif
-      if (ierr /= NF_NOERR) then
-        abort_message = 'Lecture echouee pour <NAT>'
-        call abort_gcm(modname,abort_message,1)
-      endif
-!
-! Remplissage des fractions de surface
-! nat = 0, 1, 2, 3 pour ocean, terre, glacier, seaice
-! 
-      pct_tmp = 0.0
-      do ii = 1, klon_glo
-        pct_tmp(ii,nint(nat_lu(ii)) + 1) = 1.
-      enddo
-
-!
-!  On se retrouve avec ocean en 1 et terre en 2 alors qu'on veut le contraire
-!
-      pctsrf_new = pct_tmp
-      pctsrf_new (:,2)= pct_tmp (:,1)
-      pctsrf_new (:,1)= pct_tmp (:,2)
-      pct_tmp = pctsrf_new 
-    endif ! fin test sur newlmt
-!
-! Lecture SST
-!
-    ierr = NF_INQ_VARID(nid, 'SST', nvarid)
-    if (ierr /= NF_NOERR) then
-      abort_message = 'Le champ <SST> est absent'
-      call abort_gcm(modname,abort_message,1)
-    endif
-#ifdef NC_DOUBLE
-    ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais, sst_lu)
-#else
-    ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais, sst_lu)
-#endif
-    if (ierr /= NF_NOERR) then
-      abort_message = 'Lecture echouee pour <SST>'
-      call abort_gcm(modname,abort_message,1)
-    endif    
-
-!
-! Fin de lecture
-!
-    ierr = NF_CLOSE(nid)
-   endif ! is_mpi_root
-
-!$OMP END MASTER
-!$OMP BARRIER
-  call Scatter(sst_lu,sst_lu_p)
-  call Scatter(pct_tmp(:,is_oce),pct_tmp_p(:,is_oce))
-  call Scatter(pct_tmp(:,is_sic),pct_tmp_p(:,is_sic))
-   deja_lu = .true.
-   jour_lu = jour
-  endif   
-
-!
-! Recopie des variables dans les champs de sortie
-!
-  
-  lmt_sst_p = 999999999.
-  
-  do ii = 1, knon
-    lmt_sst_p(ii) = sst_lu_p(knindex(ii))
-  enddo
-
-  do ii=1,klon_loc
-    pctsrf_new_p(ii,is_oce)=pct_tmp_p(ii,is_oce)
-    pctsrf_new_p(ii,is_sic)=pct_tmp_p(ii,is_sic)
-  enddo
-  
-
-  END SUBROUTINE interfoce_lim
-
-!
-!#########################################################################
-!
-  SUBROUTINE interfsur_lim(itime, dtime, jour, &
-     & klon, nisurf, knon, knindex, &
-     & debut,  &
-     & lmt_alb_p, lmt_rug_p)
-
-     USE mod_grid_phy_lmdz
-     USE mod_phys_lmdz_para
-     
-! Cette routine sert d'interface entre le modele atmospherique et un fichier
-! de conditions aux limites
-!
-! L. Fairhead 02/2000
-!
-! input:
-!   itime        numero du pas de temps courant
-!   dtime        pas de temps de la physique (en s)
-!   jour         jour a lire dans l'annee
-!   nisurf       index de la surface a traiter (1 = sol continental)
-!   knon         nombre de points dans le domaine a traiter
-!   knindex      index des points de la surface a traiter
-!   klon         taille de la grille
-!   debut        logical: 1er appel a la physique (initialisation)
-!
-! output:
-!   lmt_sst      SST lues dans le fichier de CL
-!   lmt_alb      Albedo lu 
-!   lmt_rug      longueur de rugosite lue
-!   pctsrf_new   sous-maille fractionnelle
-!
-
-
-! Parametres d'entree
-  integer, intent(IN) :: itime
-  real   , intent(IN) :: dtime
-  integer, intent(IN) :: jour
-  integer, intent(IN) :: nisurf
-  integer, intent(IN) :: knon
-  integer, intent(IN) :: klon
-  integer, dimension(klon_loc), intent(in) :: knindex
-  logical, intent(IN) :: debut
-
-! Parametres de sortie
-  real, intent(out), dimension(klon_loc) :: lmt_alb_p
-  real, intent(out), dimension(klon_loc) :: lmt_rug_p
-
-!  real,  dimension(klon) :: lmt_alb
-!  real,  dimension(klon) :: lmt_rug
-
-! Variables locales
-  integer     :: ii
-  integer,save :: lmt_pas     ! frequence de lecture des conditions limites 
-                             ! (en pas de physique)
-!$OMP THREADPRIVATE(lmt_pas) 
-  logical,save :: deja_lu_sur! pour indiquer que le jour a lire a deja
-                             ! lu pour une surface precedente
-!$OMP THREADPRIVATE(deja_lu_sur) 
-  integer,save :: jour_lu_sur 
-!$OMP THREADPRIVATE(jour_lu_sur) 
-  integer      :: ierr
-  character (len = 20) :: modname = 'interfsur_lim'
-  character (len = 80) :: abort_message
-  character (len = 20),save :: fich ='limit.nc'
-!$OMP THREADPRIVATE(fich) 
-  logical,save     :: newlmt = .false.
-!$OMP THREADPRIVATE(newlmt) 
-  logical,save     :: check = .false.
-!$OMP THREADPRIVATE(check) 
-! Champs lus dans le fichier de CL
-  real, allocatable , save, dimension(:) :: alb_lu_p, rug_lu_p
-!$OMP THREADPRIVATE(alb_lu_p, rug_lu_p) 
-  real, dimension(klon_glo) :: alb_lu, rug_lu
-!
-! quelques variables pour netcdf
-!
-#include "netcdf.inc"
-  integer ,save             :: nid, nvarid
-!$OMP THREADPRIVATE(nid, nvarid) 
-  integer, dimension(2),save :: start, epais
-!$OMP THREADPRIVATE(start, epais) 
-!
-! Fin declaration
-!
-  
-  if (debut) then
-    lmt_pas = nint(86400./dtime * 1.0) ! pour une lecture une fois par jour
-    jour_lu_sur = jour - 1
-    allocate(alb_lu_p(klon_loc))
-    allocate(rug_lu_p(klon_loc))
-  endif
-
-  if ((jour - jour_lu_sur) /= 0) deja_lu_sur = .false.
-  
-  if (check) write(*,*)modname,':: jour_lu_sur, deja_lu_sur', jour_lu_sur, deja_lu_sur 
-  if (check) write(*,*)modname,':: itime, lmt_pas', itime, lmt_pas
-  if (check) call flush(6)
-
-! Tester d'abord si c'est le moment de lire le fichier
-  if (mod(itime-1, lmt_pas) == 0 .and. .not. deja_lu_sur) then
-
-!$OMP MASTER
-   if (is_mpi_root) then
-!
-! Ouverture du fichier
-!
-    fich = trim(fich)
-    IF (check) WRITE(*,*)modname,' ouverture fichier ',fich
-    if (check) CALL flush(6)
-    ierr = NF_OPEN (fich, NF_NOWRITE,nid)
-    if (ierr.NE.NF_NOERR) then
-      abort_message = 'Pb d''ouverture du fichier de conditions aux limites'
-      call abort_gcm(modname,abort_message,1)
-    endif
-! 
-! La tranche de donnees a lire:
- 
-    start(1) = 1
-    start(2) = jour
-    epais(1) = klon_glo
-    epais(2) = 1
-!
-! Lecture Albedo
-!
-    ierr = NF_INQ_VARID(nid, 'ALB', nvarid)
-    if (ierr /= NF_NOERR) then
-      abort_message = 'Le champ <ALB> est absent'
-      call abort_gcm(modname,abort_message,1)
-    endif
-#ifdef NC_DOUBLE
-    ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais, alb_lu)
-#else
-    ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais, alb_lu)
-#endif
-    if (ierr /= NF_NOERR) then
-      abort_message = 'Lecture echouee pour <ALB>'
-      call abort_gcm(modname,abort_message,1)
-    endif
-!
-! Lecture rugosite !
-    ierr = NF_INQ_VARID(nid, 'RUG', nvarid)
-    if (ierr /= NF_NOERR) then
-      abort_message = 'Le champ <RUG> est absent'
-      call abort_gcm(modname,abort_message,1)
-    endif
-#ifdef NC_DOUBLE
-    ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais, rug_lu)
-#else
-    ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais, rug_lu)
-#endif
-    if (ierr /= NF_NOERR) then
-      abort_message = 'Lecture echouee pour <RUG>'
-      call abort_gcm(modname,abort_message,1)
-    endif
-
-!
-! Fin de lecture
-!
-    ierr = NF_CLOSE(nid)
-
-
-  endif  !! is_mpi_root
-!$OMP END MASTER
-
-    call Scatter(alb_lu,alb_lu_p)
-    call Scatter(rug_lu,rug_lu_p)
-    
-    deja_lu_sur = .true.
-    jour_lu_sur = jour
-
-
-  endif
-  
-!
-! Recopie des variables dans les champs de sortie
-!
-!!$  lmt_alb(:) = 0.0
-!!$  lmt_rug(:) = 0.0
- 
-  lmt_alb_p(:) = 999999.
-  lmt_rug_p(:) = 999999.
-  DO ii = 1, knon
-    lmt_alb_p(ii) = alb_lu_p(knindex(ii))
-    lmt_rug_p(ii) = rug_lu_p(knindex(ii))
-  enddo
-
-
-  END SUBROUTINE interfsur_lim
-
-!
-!#########################################################################
-!
-
-  SUBROUTINE calcul_fluxs( klon, knon, nisurf, dtime, &
-     & tsurf, p1lay, cal, beta, coef1lay, ps, &
-     & precip_rain, precip_snow, snow, qsurf, &
-     & radsol, dif_grnd, t1lay, q1lay, u1lay, v1lay, &
-     & petAcoef, peqAcoef, petBcoef, peqBcoef, &
-     & tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
-
-! Cette routine calcule les fluxs en h et q a l'interface et eventuellement
-! une temperature de surface (au cas ou ok_veget = false)
-!
-! L. Fairhead 4/2000
-!
-! input:
-!   knon         nombre de points a traiter
-!   nisurf       surface a traiter
-!   tsurf        temperature de surface
-!   p1lay        pression 1er niveau (milieu de couche)
-!   cal          capacite calorifique du sol
-!   beta         evap reelle
-!   coef1lay     coefficient d'echange
-!   ps           pression au sol
-!   precip_rain  precipitations liquides
-!   precip_snow  precipitations solides
-!   snow         champs hauteur de neige
-!   runoff       runoff en cas de trop plein
-!   petAcoef     coeff. A de la resolution de la CL pour t
-!   peqAcoef     coeff. A de la resolution de la CL pour q
-!   petBcoef     coeff. B de la resolution de la CL pour t
-!   peqBcoef     coeff. B de la resolution de la CL pour q
-!   radsol       rayonnement net aus sol (LW + SW)
-!   dif_grnd     coeff. diffusion vers le sol profond
-!
-! output:
-!   tsurf_new    temperature au sol
-!   qsurf        humidite de l'air au dessus du sol
-!   fluxsens     flux de chaleur sensible
-!   fluxlat      flux de chaleur latente
-!   dflux_s      derivee du flux de chaleur sensible / Ts
-!   dflux_l      derivee du flux de chaleur latente  / Ts
-!
-
-#include "YOETHF.inc"
-#include "FCTTRE.inc"
-#include "indicesol.inc"
-#include "YOMCST.inc"
-
-! Parametres d'entree
-  integer, intent(IN) :: knon, nisurf, klon
-  real   , intent(IN) :: dtime
-  real, dimension(klon), intent(IN) :: petAcoef, peqAcoef
-  real, dimension(klon), intent(IN) :: petBcoef, peqBcoef
-  real, dimension(klon), intent(IN) :: ps, q1lay
-  real, dimension(klon), intent(IN) :: tsurf, p1lay, cal, beta, coef1lay
-  real, dimension(klon), intent(IN) :: precip_rain, precip_snow
-  real, dimension(klon), intent(IN) :: radsol, dif_grnd
-  real, dimension(klon), intent(IN) :: t1lay, u1lay, v1lay
-  real, dimension(klon), intent(INOUT) :: snow, qsurf
-
-! Parametres sorties
-  real, dimension(klon), intent(OUT):: tsurf_new, evap, fluxsens, fluxlat
-  real, dimension(klon), intent(OUT):: dflux_s, dflux_l
-
-! Variables locales
-  integer :: i
-  real, dimension(klon) :: zx_mh, zx_nh, zx_oh
-  real, dimension(klon) :: zx_mq, zx_nq, zx_oq
-  real, dimension(klon) :: zx_pkh, zx_dq_s_dt, zx_qsat, zx_coef
-  real, dimension(klon) :: zx_sl, zx_k1
-  real, dimension(klon) :: zx_q_0 , d_ts
-  real                  :: zdelta, zcvm5, zx_qs, zcor, zx_dq_s_dh
-  real                  :: bilan_f, fq_fonte
-  REAL                  :: subli, fsno
-  REAL                  :: qsat_new, q1_new
-  real, parameter :: t_grnd = 271.35, t_coup = 273.15
-!! PB temporaire en attendant mieux pour le modele de neige
-  REAL, parameter :: chasno = 3.334E+05/(2.3867E+06*0.15)
-!
-  logical, save         :: check = .false.
-!$OMP THREADPRIVATE(check)
-  character (len = 20)  :: modname = 'calcul_fluxs'
-  logical, save         :: fonte_neige = .false.
-!$OMP THREADPRIVATE(fonte_neige)
-  real, save            :: max_eau_sol = 150.0
-!$OMP THREADPRIVATE(max_eau_sol)
-  character (len = 80) :: abort_message 
-  logical,save         :: first = .true.,second=.false.
-!$OMP THREADPRIVATE(first,second)
-
-  if (check) write(*,*)'Entree ', modname,' surface = ',nisurf
-
-  IF (check) THEN
-      WRITE(*,*)' radsol (min, max)' &
-         &     , MINVAL(radsol(1:knon)), MAXVAL(radsol(1:knon))
-      CALL flush(6)
-  ENDIF
-
-  if (size(coastalflow) /= knon .AND. nisurf == is_ter) then
-    write(*,*)'Bizarre, le nombre de points continentaux'
-    write(*,*)'a change entre deux appels. J''arrete ...'
-    abort_message='Pb run_off'
-    call abort_gcm(modname,abort_message,1)
-  endif
-!
-! Traitement neige et humidite du sol
-!
-!!$  WRITE(*,*)'test calcul_flux, surface ', nisurf
-!!PB test
-!!$    if (nisurf == is_oce) then
-!!$      snow = 0.
-!!$      qsol = max_eau_sol
-!!$    else
-!!$      where (precip_snow > 0.) snow = snow + (precip_snow * dtime)
-!!$      where (snow > epsilon(snow)) snow = max(0.0, snow - (evap * dtime))
-!!$!      snow = max(0.0, snow + (precip_snow - evap) * dtime)
-!!$      where (precip_rain > 0.) qsol = qsol + (precip_rain - evap) * dtime
-!!$    endif 
-!!$    IF (nisurf /= is_ter) qsol = max_eau_sol
-
-
-! 
-! Initialisation
-!
-  evap = 0.
-  fluxsens=0.
-  fluxlat=0.
-  dflux_s = 0.
-  dflux_l = 0.	
-!
-! zx_qs = qsat en kg/kg
-!
-  DO i = 1, knon
-    zx_pkh(i) = (ps(i)/ps(i))**RKAPPA
-  IF (thermcep) THEN
-      zdelta=MAX(0.,SIGN(1.,rtt-tsurf(i)))
-      zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
-      zcvm5 = zcvm5 / RCPD / (1.0+RVTMP2*q1lay(i))
-      zx_qs= r2es * FOEEW(tsurf(i),zdelta)/ps(i)
-      zx_qs=MIN(0.5,zx_qs)
-      zcor=1./(1.-retv*zx_qs)
-      zx_qs=zx_qs*zcor
-      zx_dq_s_dh = FOEDE(tsurf(i),zdelta,zcvm5,zx_qs,zcor) &
-     &                 /RLVTT / zx_pkh(i)
-    ELSE
-      IF (tsurf(i).LT.t_coup) THEN
-        zx_qs = qsats(tsurf(i)) / ps(i)
-        zx_dq_s_dh = dqsats(tsurf(i),zx_qs)/RLVTT &
-     &                    / zx_pkh(i)
-      ELSE
-        zx_qs = qsatl(tsurf(i)) / ps(i)
-        zx_dq_s_dh = dqsatl(tsurf(i),zx_qs)/RLVTT &
-     &               / zx_pkh(i)
-      ENDIF
-    ENDIF
-    zx_dq_s_dt(i) = RCPD * zx_pkh(i) * zx_dq_s_dh
-    zx_qsat(i) = zx_qs
-    zx_coef(i) = coef1lay(i) &
-     & * (1.0+SQRT(u1lay(i)**2+v1lay(i)**2)) &
-     & * p1lay(i)/(RD*t1lay(i))
-
-  ENDDO
-
-
-! === Calcul de la temperature de surface ===
-! 
-! zx_sl = chaleur latente d'evaporation ou de sublimation
-!
-  do i = 1, knon
-    zx_sl(i) = RLVTT
-    if (tsurf(i) .LT. RTT) zx_sl(i) = RLSTT
-    zx_k1(i) = zx_coef(i)
-  enddo
-
-
-  do i = 1, knon
-! Q
-    zx_oq(i) = 1. - (beta(i) * zx_k1(i) * peqBcoef(i) * dtime)
-    zx_mq(i) = beta(i) * zx_k1(i) * &
-     &             (peqAcoef(i) - zx_qsat(i) &
-     &                          + zx_dq_s_dt(i) * tsurf(i)) &
-     &             / zx_oq(i)
-    zx_nq(i) = beta(i) * zx_k1(i) * (-1. * zx_dq_s_dt(i)) &
-     &                              / zx_oq(i)
-
-! H
-    zx_oh(i) = 1. - (zx_k1(i) * petBcoef(i) * dtime)
-    zx_mh(i) = zx_k1(i) * petAcoef(i) / zx_oh(i)
-    zx_nh(i) = - (zx_k1(i) * RCPD * zx_pkh(i))/ zx_oh(i)
-
-! Tsurface
-    tsurf_new(i) = (tsurf(i) + cal(i)/(RCPD * zx_pkh(i)) * dtime * &
-     &             (radsol(i) + zx_mh(i) + zx_sl(i) * zx_mq(i)) & 
-     &                 + dif_grnd(i) * t_grnd * dtime)/ &
-     &          ( 1. - dtime * cal(i)/(RCPD * zx_pkh(i)) * ( &
-     &                       zx_nh(i) + zx_sl(i) * zx_nq(i)) &  
-     &                     + dtime * dif_grnd(i))
-
-!
-! Y'a-t-il fonte de neige?
-!
-!    fonte_neige = (nisurf /= is_oce) .AND. &
-!     & (snow(i) > epsfra .OR. nisurf == is_sic .OR. nisurf == is_lic) &
-!     & .AND. (tsurf_new(i) >= RTT)
-!    if (fonte_neige) tsurf_new(i) = RTT  
-    d_ts(i) = tsurf_new(i) - tsurf(i)
-!    zx_h_ts(i) = tsurf_new(i) * RCPD * zx_pkh(i)
-!    zx_q_0(i) = zx_qsat(i) + zx_dq_s_dt(i) * d_ts(i)
-!== flux_q est le flux de vapeur d'eau: kg/(m**2 s)  positive vers bas
-!== flux_t est le flux de cpt (energie sensible): j/(m**2 s)
-    evap(i) = - zx_mq(i) - zx_nq(i) * tsurf_new(i) 
-    fluxlat(i) = - evap(i) * zx_sl(i)
-    fluxsens(i) = zx_mh(i) + zx_nh(i) * tsurf_new(i)
-! Derives des flux dF/dTs (W m-2 K-1):
-    dflux_s(i) = zx_nh(i)
-    dflux_l(i) = (zx_sl(i) * zx_nq(i))
-! Nouvelle valeure de l'humidite au dessus du sol
-    qsat_new=zx_qsat(i) + zx_dq_s_dt(i) * d_ts(i)
-    q1_new = peqAcoef(i) - peqBcoef(i)*evap(i)*dtime
-    qsurf(i)=q1_new*(1.-beta(i)) + beta(i)*qsat_new
-!
-! en cas de fonte de neige
-!
-!    if (fonte_neige) then
-!      bilan_f = radsol(i) + fluxsens(i) - (zx_sl(i) * evap (i)) - &
-!     &          dif_grnd(i) * (tsurf_new(i) - t_grnd) - &
-!     &          RCPD * (zx_pkh(i))/cal(i)/dtime * (tsurf_new(i) - tsurf(i))
-!      bilan_f = max(0., bilan_f)
-!      fq_fonte = bilan_f / zx_sl(i)
-!      snow(i) = max(0., snow(i) - fq_fonte * dtime)
-!      qsol(i) = qsol(i) + (fq_fonte * dtime)
-!    endif
-!!$    if (nisurf == is_ter)  &
-!!$     &  run_off(i) = run_off(i) + max(qsol(i) - max_eau_sol, 0.0)
-!!$    qsol(i) = min(qsol(i), max_eau_sol) 
-  ENDDO
-
-  END SUBROUTINE calcul_fluxs
-!
-!#########################################################################
-!
-  SUBROUTINE gath2cpl(champ_in, champ_out, klon, knon, iim, jmp1, knindex)
-  USE mod_phys_lmdz_para
-  implicit none
-  
-! Cette routine ecrit un champ 'gathered' sur la grille 2D pour le passer
-! au coupleur.
-!
-! 
-! input:         
-!   champ_in     champ sur la grille gathere        
-!   knon         nombre de points dans le domaine a traiter
-!   knindex      index des points de la surface a traiter
-!   klon         taille de la grille
-!   iim,jjm      dimension de la grille 2D
-!
-! output:
-!   champ_out    champ sur la grille 2D
-!
-! input
-  integer                   :: klon, knon, iim, jmp1
-  real, dimension(klon_loc)     :: champ_in
-  integer, dimension(klon_loc)  :: knindex
-! output
-  real, dimension(iim,jmp1)  :: champ_out
-! local
-  integer                   :: i, ig, j
-  real, dimension(klon_loc)     :: tamp
-
-  tamp = 0.
-  do i = 1, knon
-    ig = knindex(i)
-    tamp(ig) = champ_in(i)
-  enddo    
-
-
-  CALL Grid1Dto2D_mpi(tamp,champ_out)
-
-  END SUBROUTINE gath2cpl
-!
-!#########################################################################
-!
-  SUBROUTINE cpl2gath(champ_in, champ_out, klon, knon, iim, jmp1, knindex)
-  USE mod_phys_lmdz_para
-  implicit none
-! Cette routine ecrit un champ 'gathered' sur la grille 2D pour le passer
-! au coupleur.
-!
-! 
-! input:         
-!   champ_in     champ sur la grille gathere        
-!   knon         nombre de points dans le domaine a traiter
-!   knindex      index des points de la surface a traiter
-!   klon         taille de la grille
-!   iim,jjm      dimension de la grille 2D
-!
-! output:
-!   champ_out    champ sur la grille 2D
-!
-! input
-  integer                   :: klon, knon, iim, jmp1
-  real, dimension(iim,jmp1)     :: champ_in
-  integer, dimension(klon_loc)  :: knindex
-! output
-  real, dimension(klon_loc)  :: champ_out
-! local
-  integer                   :: i, ig, j
-  real, dimension(klon_loc)     :: tamp
-  logical ,save                  :: check = .false.
-!$OMP THREADPRIVATE(check)
-
-  CALL Grid2Dto1D_mpi(champ_in,tamp)
-  
-  do i = 1, knon
-    ig = knindex(i)
-    champ_out(i) = tamp(ig)
-  enddo    
-
-  END SUBROUTINE cpl2gath
-!
-!#########################################################################
-!
-  SUBROUTINE albsno(klon, knon,dtime,agesno,alb_neig_grid, precip_snow)
-  IMPLICIT none
- 
-  INTEGER :: klon, knon
-  INTEGER, PARAMETER :: nvm = 8
-  REAL   :: dtime
-  REAL, dimension(klon,nvm) :: veget
-  REAL, DIMENSION(klon) :: alb_neig_grid, agesno, precip_snow
- 
-  INTEGER :: i, nv
- 
-  REAL, DIMENSION(nvm),SAVE :: init, decay
-!$OMP THREADPRIVATE(init, decay)
-  REAL :: as
-  DATA init /0.55, 0.14, 0.18, 0.29, 0.15, 0.15, 0.14, 0./
-  DATA decay/0.30, 0.67, 0.63, 0.45, 0.40, 0.14, 0.06, 1./
- 
-  veget = 0.
-  veget(:,1) = 1.     ! desert partout
-  DO i = 1, knon
-    alb_neig_grid(i) = 0.0
-  ENDDO
-  DO nv = 1, nvm
-    DO i = 1, knon
-      as = init(nv)+decay(nv)*EXP(-agesno(i)/5.)
-      alb_neig_grid(i) = alb_neig_grid(i) + veget(i,nv)*as
-    ENDDO
-  ENDDO
-!
-!! modilation en fonction de l'age de la neige
-!
-  DO i = 1, knon
-    agesno(i)  = (agesno(i) + (1.-agesno(i)/50.)*dtime/86400.)&
-            &             * EXP(-1.*MAX(0.0,precip_snow(i))*dtime/0.3)
-    agesno(i) =  MAX(agesno(i),0.0)
-  ENDDO
- 
-  END SUBROUTINE albsno
-!
-!#########################################################################
-!
-
-  SUBROUTINE fonte_neige( klon, knon, nisurf, dtime, &
-     & tsurf, p1lay, cal, beta, coef1lay, ps, &
-     & precip_rain, precip_snow, snow, qsol, &
-     & radsol, dif_grnd, t1lay, q1lay, u1lay, v1lay, &
-     & petAcoef, peqAcoef, petBcoef, peqBcoef, &
-     & tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l, &
-     & fqcalving,fqfonte,ffonte,run_off_lic_0)
-
-! Routine de traitement de la fonte de la neige dans le cas du traitement
-! de sol simplifie !
-! LF 03/2001
-! input:
-!   knon         nombre de points a traiter
-!   nisurf       surface a traiter
-!   tsurf        temperature de surface
-!   p1lay        pression 1er niveau (milieu de couche)
-!   cal          capacite calorifique du sol
-!   beta         evap reelle
-!   coef1lay     coefficient d'echange
-!   ps           pression au sol
-!   precip_rain  precipitations liquides
-!   precip_snow  precipitations solides
-!   snow         champs hauteur de neige
-!   qsol         hauteur d'eau contenu dans le sol
-!   runoff       runoff en cas de trop plein
-!   petAcoef     coeff. A de la resolution de la CL pour t
-!   peqAcoef     coeff. A de la resolution de la CL pour q
-!   petBcoef     coeff. B de la resolution de la CL pour t
-!   peqBcoef     coeff. B de la resolution de la CL pour q
-!   radsol       rayonnement net aus sol (LW + SW)
-!   dif_grnd     coeff. diffusion vers le sol profond
-!
-! output:
-!   tsurf_new    temperature au sol
-!   fluxsens     flux de chaleur sensible
-!   fluxlat      flux de chaleur latente
-!   dflux_s      derivee du flux de chaleur sensible / Ts
-!   dflux_l      derivee du flux de chaleur latente  / Ts
-! in/out:
-!   run_off_lic_0 run off glacier du pas de temps precedent
-!
-
-#include "YOETHF.inc"
-!rv#include "FCTTRE.inc"
-#include "indicesol.inc"
-!IM cf JLD
-#include "YOMCST.inc"
-
-! Parametres d'entree
-  integer, intent(IN) :: knon, nisurf, klon
-  real   , intent(IN) :: dtime
-  real, dimension(klon), intent(IN) :: petAcoef, peqAcoef
-  real, dimension(klon), intent(IN) :: petBcoef, peqBcoef
-  real, dimension(klon), intent(IN) :: ps, q1lay
-  real, dimension(klon), intent(IN) :: tsurf, p1lay, cal, beta, coef1lay
-  real, dimension(klon), intent(IN) :: precip_rain, precip_snow
-  real, dimension(klon), intent(IN) :: radsol, dif_grnd
-  real, dimension(klon), intent(IN) :: t1lay, u1lay, v1lay
-  real, dimension(klon), intent(INOUT) :: snow, qsol
-
-! Parametres sorties
-  real, dimension(klon), intent(INOUT):: tsurf_new, evap, fluxsens, fluxlat
-  real, dimension(klon), intent(INOUT):: dflux_s, dflux_l
-! Flux thermique utiliser pour fondre la neige
-  real, dimension(klon), intent(INOUT):: ffonte
-! Flux d'eau "perdu" par la surface et necessaire pour que limiter la
-! hauteur de neige, en kg/m2/s. Et flux d'eau de fonte de la calotte.
-  REAL, DIMENSION(klon), INTENT(INOUT):: fqcalving, fqfonte
-  real, dimension(klon), intent(INOUT):: run_off_lic_0
-! Variables locales
-! Masse maximum de neige (kg/m2). Au dessus de ce seuil, la neige
-! en exces "s'ecoule" (calving)
-!  real, parameter :: snow_max=1.
-!IM cf JLD/GK
-  real, parameter :: snow_max=3000.
-  integer :: i
-  real, dimension(klon) :: zx_mh, zx_nh, zx_oh
-  real, dimension(klon) :: zx_mq, zx_nq, zx_oq
-  real, dimension(klon) :: zx_pkh, zx_dq_s_dt, zx_qsat, zx_coef
-  real, dimension(klon) :: zx_sl, zx_k1
-  real, dimension(klon) :: zx_q_0 , d_ts
-  real                  :: zdelta, zcvm5, zx_qs, zcor, zx_dq_s_dh
-  real                  :: bilan_f, fq_fonte
-  REAL                  :: subli, fsno
-  REAL, DIMENSION(klon) :: bil_eau_s, snow_evap
-  real, parameter :: t_grnd = 271.35, t_coup = 273.15
-!! PB temporaire en attendant mieux pour le modele de neige
-! REAL, parameter :: chasno = RLMLT/(2.3867E+06*0.15)
-  REAL, parameter :: chasno = 3.334E+05/(2.3867E+06*0.15)
-!IM cf JLD/ GKtest
-  REAL, parameter :: chaice = 3.334E+05/(2.3867E+06*0.15)
-! fin GKtest
-!
-  logical, save         :: check = .FALSE.
-!$OMP THREADPRIVATE(check)
-  character (len = 20)  :: modname = 'fonte_neige'
-  logical, save         :: neige_fond = .false.
-!$OMP THREADPRIVATE(neige_fond)
-  real, save            :: max_eau_sol = 150.0
-!$OMP THREADPRIVATE(max_eau_sol)
-  character (len = 80) :: abort_message 
-  logical,save         :: first = .true.,second=.false.
-!$OMP THREADPRIVATE(first,second)
-  real                 :: coeff_rel
-#include "FCTTRE.inc"
-
-
-  if (check) write(*,*)'Entree ', modname,' surface = ',nisurf
-
-! Initialisations
-  coeff_rel = dtime/(tau_calv * rday)
-  bil_eau_s(:) = 0.
-  DO i = 1, knon
-    zx_pkh(i) = (ps(i)/ps(i))**RKAPPA
-  IF (thermcep) THEN
-      zdelta=MAX(0.,SIGN(1.,rtt-tsurf(i)))
-      zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
-      zcvm5 = zcvm5 / RCPD / (1.0+RVTMP2*q1lay(i))
-      zx_qs= r2es * FOEEW(tsurf(i),zdelta)/ps(i)
-      zx_qs=MIN(0.5,zx_qs)
-      zcor=1./(1.-retv*zx_qs)
-      zx_qs=zx_qs*zcor
-      zx_dq_s_dh = FOEDE(tsurf(i),zdelta,zcvm5,zx_qs,zcor) &
-     &                 /RLVTT / zx_pkh(i)
-    ELSE
-      IF (tsurf(i).LT.t_coup) THEN
-        zx_qs = qsats(tsurf(i)) / ps(i)
-        zx_dq_s_dh = dqsats(tsurf(i),zx_qs)/RLVTT &
-     &                    / zx_pkh(i)
-      ELSE
-        zx_qs = qsatl(tsurf(i)) / ps(i)
-        zx_dq_s_dh = dqsatl(tsurf(i),zx_qs)/RLVTT &
-     &               / zx_pkh(i)
-      ENDIF
-    ENDIF
-    zx_dq_s_dt(i) = RCPD * zx_pkh(i) * zx_dq_s_dh
-    zx_qsat(i) = zx_qs
-    zx_coef(i) = coef1lay(i) &
-     & * (1.0+SQRT(u1lay(i)**2+v1lay(i)**2)) &
-     & * p1lay(i)/(RD*t1lay(i))
-  ENDDO
-
-
-! === Calcul de la temperature de surface ===
-! 
-! zx_sl = chaleur latente d'evaporation ou de sublimation
-!
-  do i = 1, knon
-    zx_sl(i) = RLVTT
-    if (tsurf(i) .LT. RTT) zx_sl(i) = RLSTT
-    zx_k1(i) = zx_coef(i)
-  enddo
-
-
-  do i = 1, knon
-! Q
-    zx_oq(i) = 1. - (beta(i) * zx_k1(i) * peqBcoef(i) * dtime)
-    zx_mq(i) = beta(i) * zx_k1(i) * &
-     &             (peqAcoef(i) - zx_qsat(i) &
-     &                          + zx_dq_s_dt(i) * tsurf(i)) &
-     &             / zx_oq(i)
-    zx_nq(i) = beta(i) * zx_k1(i) * (-1. * zx_dq_s_dt(i)) &
-     &                              / zx_oq(i)
-
-! H
-    zx_oh(i) = 1. - (zx_k1(i) * petBcoef(i) * dtime)
-    zx_mh(i) = zx_k1(i) * petAcoef(i) / zx_oh(i)
-    zx_nh(i) = - (zx_k1(i) * RCPD * zx_pkh(i))/ zx_oh(i)
-  enddo
-
-
-  WHERE (precip_snow > 0.) snow = snow + (precip_snow * dtime)
-  snow_evap = 0.
-  WHERE (evap > 0. ) 
-    snow_evap = MIN (snow / dtime, evap) 
-    snow = snow - snow_evap * dtime
-    snow = MAX(0.0, snow)
-  end where
- 
-!  bil_eau_s = bil_eau_s + (precip_rain * dtime) - (evap - snow_evap) * dtime
-  bil_eau_s = (precip_rain * dtime) - (evap - snow_evap) * dtime
-
-!
-! Y'a-t-il fonte de neige?
-!
-  ffonte=0.
-  do i = 1, knon
-    neige_fond = ((snow(i) > epsfra .OR. nisurf == is_sic .OR. nisurf == is_lic) &
-     & .AND. tsurf_new(i) >= RTT)
-    if (neige_fond) then
-      fq_fonte = MIN( MAX((tsurf_new(i)-RTT )/chasno,0.0),snow(i))
-      ffonte(i) = fq_fonte * RLMLT/dtime
-      fqfonte(i) = fq_fonte/dtime
-      snow(i) = max(0., snow(i) - fq_fonte)
-      bil_eau_s(i) = bil_eau_s(i) + fq_fonte 
-      tsurf_new(i) = tsurf_new(i) - fq_fonte * chasno  
-!IM cf JLD OK     
-!IM cf JLD/ GKtest fonte aussi pour la glace
-      IF (nisurf == is_sic .OR. nisurf == is_lic ) THEN
-        fq_fonte = MAX((tsurf_new(i)-RTT )/chaice,0.0)
-        ffonte(i) = ffonte(i) + fq_fonte * RLMLT/dtime
-        IF ( ok_lic_melt ) THEN
-           fqfonte(i) = fqfonte(i) + fq_fonte/dtime
-           bil_eau_s(i) = bil_eau_s(i) + fq_fonte
-        ENDIF
-        tsurf_new(i) = RTT
-      ENDIF
-      d_ts(i) = tsurf_new(i) - tsurf(i)
-    endif
-!
-!   s'il y a une hauteur trop importante de neige, elle s'coule
-    fqcalving(i) = max(0., snow(i) - snow_max)/dtime
-    snow(i)=min(snow(i),snow_max)
-!
-    IF (nisurf == is_ter) then
-      qsol(i) = qsol(i) + bil_eau_s(i)
-      run_off(i) = run_off(i) + MAX(qsol(i) - max_eau_sol, 0.0)
-      qsol(i) = MIN(qsol(i), max_eau_sol) 
-    else if (nisurf == is_lic) then
-      run_off_lic(i) = (coeff_rel *  fqcalving(i)) + &
- &                        (1. - coeff_rel) * run_off_lic_0(i)
-      run_off_lic_0(i) = run_off_lic(i)
-      run_off_lic(i) = run_off_lic(i) + fqfonte(i)/dtime
-    endif
-  enddo
-
-  END SUBROUTINE fonte_neige
-!
-!#########################################################################
-!
-  END MODULE interface_surf
Index: LMDZ4/trunk/libf/phylmd/interfoce_lim.F90
===================================================================
--- LMDZ4/trunk/libf/phylmd/interfoce_lim.F90	(revision 782)
+++ LMDZ4/trunk/libf/phylmd/interfoce_lim.F90	(revision 782)
@@ -0,0 +1,289 @@
+!
+! $Header$
+!
+SUBROUTINE interfoce_lim(itime, dtime, jour, &
+     knon, knindex, &
+     debut,  &
+     lmt_sst_p, pctsrf_new_p)
+  
+  USE mod_grid_phy_lmdz
+  USE mod_phys_lmdz_para
+  
+  IMPLICIT NONE
+  
+  INCLUDE "indicesol.inc"
+  INCLUDE "netcdf.inc"
+
+! Cette routine sert d'interface entre le modele atmospherique et un fichier
+! de conditions aux limites
+!
+! L. Fairhead 02/2000
+!
+! input:
+!   itime        numero du pas de temps courant
+!   dtime        pas de temps de la physique (en s)
+!   jour         jour a lire dans l'annee
+!   nisurf       index de la surface a traiter (1 = sol continental)
+!   knon         nombre de points dans le domaine a traiter
+!   knindex      index des points de la surface a traiter
+!   klon         taille de la grille
+!   debut        logical: 1er appel a la physique (initialisation)
+!
+! output:
+!   lmt_sst_p      SST lues dans le fichier de CL
+!   pctsrf_new-p   sous-maille fractionnelle
+!
+
+
+! Parametres d'entree
+!****************************************************************************************
+  INTEGER, INTENT(IN)                       :: itime
+  INTEGER, INTENT(IN)                       :: jour
+  INTEGER, INTENT(IN)                       :: knon
+  INTEGER, DIMENSION(klon_loc), INTENT(IN)  :: knindex
+  REAL   , INTENT(IN)                       :: dtime
+  LOGICAL, INTENT(IN)                       :: debut
+  
+! Parametres de sortie
+!****************************************************************************************
+  REAL, INTENT(OUT), DIMENSION(klon_loc)       :: lmt_sst_p
+  REAL, INTENT(OUT), DIMENSION(klon_loc,nbsrf) :: pctsrf_new_p
+
+
+! Variables locales avec l'attribut SAVE
+!****************************************************************************************
+! frequence de lecture des conditions limites (en pas de physique) 
+  INTEGER,SAVE                              :: lmt_pas   
+  !$OMP THREADPRIVATE(lmt_pas)
+! pour indiquer que le jour a lire est deja lu pour une surface precedente
+  LOGICAL,SAVE                              :: deja_lu   
+  !$OMP THREADPRIVATE(deja_lu)
+  INTEGER,SAVE                              :: jour_lu 
+  !$OMP THREADPRIVATE(jour_lu)
+  CHARACTER (len = 20),SAVE                 :: fich ='limit.nc'
+  !$OMP THREADPRIVATE(fich)
+  LOGICAL, SAVE                             :: newlmt = .TRUE.
+  !$OMP THREADPRIVATE(newlmt)
+  LOGICAL, SAVE                             :: check = .FALSE.
+  !$OMP THREADPRIVATE(check)
+  REAL, ALLOCATABLE , SAVE, DIMENSION(:)    :: sst_lu_p
+  !$OMP THREADPRIVATE(sst_lu_p)
+  REAL, ALLOCATABLE , SAVE, DIMENSION(:,:)  :: pct_tmp_p
+  !$OMP THREADPRIVATE(pct_tmp_p)
+
+! Variables locales 
+!****************************************************************************************
+  INTEGER                                   :: nid, nvarid
+  INTEGER                                   :: ii
+  INTEGER                                   :: ierr
+  INTEGER, DIMENSION(2)                     :: start, epais
+  CHARACTER (len = 20)                      :: modname = 'interfoce_lim'
+  CHARACTER (len = 80)                      :: abort_message
+  REAL, DIMENSION(klon_glo,nbsrf)           :: pctsrf_new
+  REAL, DIMENSION(klon_glo,nbsrf)           :: pct_tmp
+  REAL, DIMENSION(klon_glo)                 :: sst_lu
+  REAL, DIMENSION(klon_glo)                 :: nat_lu
+!
+! Fin declaration
+!****************************************************************************************
+
+!****************************************************************************************
+! Start calculation
+!
+!****************************************************************************************
+  IF (debut .AND. .NOT. ALLOCATED(sst_lu_p)) THEN
+     lmt_pas = NINT(86400./dtime * 1.0) ! pour une lecture une fois par jour
+     jour_lu = jour - 1
+     ALLOCATE(sst_lu_p(klon_loc))
+     ALLOCATE(pct_tmp_p(klon_loc,nbsrf))
+  ENDIF
+  
+  IF ((jour - jour_lu) /= 0) deja_lu = .FALSE.
+  
+  IF (check) WRITE(*,*) modname, ' :: jour, jour_lu, deja_lu', jour, jour_lu, deja_lu 
+  IF (check) WRITE(*,*) modname, ' :: itime, lmt_pas ', itime, lmt_pas,dtime
+
+!****************************************************************************************
+! Ouverture et lecture du fichier pour le master process si c'est le bon moment
+!
+!****************************************************************************************
+! Tester d'abord si c'est le moment de lire le fichier
+  IF (MOD(itime-1, lmt_pas) == 0 .AND. .NOT. deja_lu) THEN
+
+!$OMP MASTER
+     IF (is_mpi_root) THEN
+
+        fich = TRIM(fich)
+        ierr = NF_OPEN (fich, NF_NOWRITE,nid)
+        IF (ierr.NE.NF_NOERR) THEN
+           abort_message = 'Pb d''ouverture du fichier de conditions aux limites'
+           CALL abort_gcm(modname,abort_message,1)
+        ENDIF
+
+        ! La tranche de donnees a lire:
+
+        start(1) = 1
+        start(2) = jour
+        epais(1) = klon_glo
+        epais(2) = 1
+
+        IF (newlmt) THEN
+           !
+           ! Fraction "ocean" 
+           !
+           ierr = NF_INQ_VARID(nid, 'FOCE', nvarid)
+           IF (ierr /= NF_NOERR) THEN
+              abort_message = 'Le champ <FOCE> est absent'
+              CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+#ifdef NC_DOUBLE
+           ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais,pct_tmp(1,is_oce))
+#else
+           ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais,pct_tmp(1,is_oce))
+#endif
+           IF (ierr /= NF_NOERR) THEN
+              abort_message = 'Lecture echouee pour <FOCE>'
+              CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+           !
+           ! Fraction "glace de mer" 
+           !
+           ierr = NF_INQ_VARID(nid, 'FSIC', nvarid)
+           IF (ierr /= NF_NOERR) THEN
+              abort_message = 'Le champ <FSIC> est absent'
+              CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+#ifdef NC_DOUBLE
+           ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais,pct_tmp(1,is_sic))
+#else
+           ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais,pct_tmp(1,is_sic))
+#endif
+           IF (ierr /= NF_NOERR) THEN
+              abort_message = 'Lecture echouee pour <FSIC>'
+              CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+           !
+           ! Fraction "terre" 
+           !
+           ierr = NF_INQ_VARID(nid, 'FTER', nvarid)
+           IF (ierr /= NF_NOERR) THEN
+              abort_message = 'Le champ <FTER> est absent'
+              CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+#ifdef NC_DOUBLE
+           ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais,pct_tmp(1,is_ter))
+#else
+           ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais,pct_tmp(1,is_ter))
+#endif
+           IF (ierr /= NF_NOERR) THEN
+              abort_message = 'Lecture echouee pour <FTER>'
+              CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+           !
+           ! Fraction "glacier terre" 
+           !
+           ierr = NF_INQ_VARID(nid, 'FLIC', nvarid)
+           IF (ierr /= NF_NOERR) THEN
+              abort_message = 'Le champ <FLIC> est absent'
+              CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+#ifdef NC_DOUBLE
+           ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais,pct_tmp(1,is_lic))
+#else
+           ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais,pct_tmp(1,is_lic))
+#endif
+           IF (ierr /= NF_NOERR) THEN
+              abort_message = 'Lecture echouee pour <FLIC>'
+              CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+           !
+        ELSE  ! on en est toujours a rnatur
+           ! 
+           ierr = NF_INQ_VARID(nid, 'NAT', nvarid)
+           IF (ierr /= NF_NOERR) THEN
+              abort_message = 'Le champ <NAT> est absent'
+              CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+#ifdef NC_DOUBLE
+           ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais, nat_lu)
+#else
+           ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais, nat_lu)
+#endif
+           IF (ierr /= NF_NOERR) THEN
+              abort_message = 'Lecture echouee pour <NAT>'
+              CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+!
+! Remplissage des fractions de surface
+! nat = 0, 1, 2, 3 pour ocean, terre, glacier, seaice
+! 
+           pct_tmp = 0.0
+           DO ii = 1, klon_glo
+              pct_tmp(ii,NINT(nat_lu(ii)) + 1) = 1.
+           ENDDO
+
+!
+!  On se retrouve avec ocean en 1 et terre en 2 alors qu'on veut le contraire
+!
+           pctsrf_new = pct_tmp
+           pctsrf_new (:,2)= pct_tmp (:,1)
+           pctsrf_new (:,1)= pct_tmp (:,2)
+           pct_tmp = pctsrf_new 
+        ENDIF ! fin test sur newlmt
+!
+! Lecture SST
+!
+        ierr = NF_INQ_VARID(nid, 'SST', nvarid)
+        IF (ierr /= NF_NOERR) THEN
+           abort_message = 'Le champ <SST> est absent'
+           CALL abort_gcm(modname,abort_message,1)
+        ENDIF
+#ifdef NC_DOUBLE
+        ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais, sst_lu)
+#else
+        ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais, sst_lu)
+#endif
+        IF (ierr /= NF_NOERR) THEN
+           abort_message = 'Lecture echouee pour <SST>'
+           CALL abort_gcm(modname,abort_message,1)
+        ENDIF
+          
+!****************************************************************************************
+! Fin de lecture, fermeture de fichier
+!
+!****************************************************************************************
+        ierr = NF_CLOSE(nid)
+     ENDIF ! is_mpi_root
+
+!$OMP END MASTER
+!$OMP BARRIER
+
+
+!****************************************************************************************
+! Distribue les variables sur tous les processus
+!
+!****************************************************************************************
+     CALL Scatter(sst_lu,sst_lu_p)
+     CALL Scatter(pct_tmp(:,is_oce),pct_tmp_p(:,is_oce))
+     CALL Scatter(pct_tmp(:,is_sic),pct_tmp_p(:,is_sic))
+     deja_lu = .TRUE.
+     jour_lu = jour
+  ENDIF
+
+!****************************************************************************************
+! Recopie des variables dans les champs de sortie
+!
+!****************************************************************************************
+  lmt_sst_p = 999999999.
+  
+  DO ii = 1, knon
+     lmt_sst_p(ii) = sst_lu_p(knindex(ii))
+  ENDDO
+  
+  DO ii=1,klon_loc
+     pctsrf_new_p(ii,is_oce)=pct_tmp_p(ii,is_oce)
+     pctsrf_new_p(ii,is_sic)=pct_tmp_p(ii,is_sic)
+  ENDDO
+  
+  
+END SUBROUTINE interfoce_lim
Index: LMDZ4/trunk/libf/phylmd/mpiclim.h
===================================================================
--- LMDZ4/trunk/libf/phylmd/mpiclim.h	(revision 781)
+++ 	(revision )
@@ -1,25 +1,0 @@
-!
-! $Header$
-!
-C
-C -- mpiclim.h  26-10-99   Version 2.4   Author: Jean Latour (F.S.E.)
-C    *********
-C@
-C@  Contents : variables related to MPI-2 message passing
-C@  --------
-C@
-C@ -- mpi_totproc: number of processors on which to launch each model
-C@
-C@ -- mpi_nproc: number of processors involved in the coupling for
-C@               each model
-C@ -- cmpi_modnam: models name
-C     -----------------------------------------------------------------
-C
-      INTEGER*4 mpi_totproc(1:CLIM_MaxMod-1),mpi_nproc(0:CLIM_MaxMod-1)
-C
-      CHARACTER*6 cmpi_modnam(1:CLIM_MaxMod-1)
-C
-      common/CLIM_mpiclim/mpi_totproc, mpi_nproc, cmpi_modnam 
-c$OMP THREADPRIVATE(/CLIM_mpiclim/)
-C
-C     -----------------------------------------------------------------
Index: LMDZ4/trunk/libf/phylmd/nonlocal.F
===================================================================
--- LMDZ4/trunk/libf/phylmd/nonlocal.F	(revision 782)
+++ LMDZ4/trunk/libf/phylmd/nonlocal.F	(revision 782)
@@ -0,0 +1,415 @@
+!
+! $Header$
+!
+C======================================================================
+      SUBROUTINE nonlocal(knon, paprs, pplay,
+     .                    tsol,beta,u,v,t,q,
+     .                    cd_h, cd_m, pcfh, pcfm, cgh, cgq)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Laurent Li (LMD/CNRS), le 30 septembre 1998
+c Couche limite non-locale. Adaptation du code du CCM3.
+c Code non teste, donc a ne pas utiliser.
+c======================================================================
+c Nonlocal scheme that determines eddy diffusivities based on a
+c diagnosed boundary layer height and a turbulent velocity scale.
+c Also countergradient effects for heat and moisture are included.
+c
+c For more information, see Holtslag, A.A.M., and B.A. Boville, 1993:
+c Local versus nonlocal boundary-layer diffusion in a global climate
+c model. J. of Climate, vol. 6, 1825-1842.
+c======================================================================
+#include "YOMCST.h"
+#include "iniprint.h"
+c
+c Arguments:
+c
+      INTEGER knon ! nombre de points a calculer
+      REAL tsol(klon) ! temperature du sol (K)
+      REAL beta(klon) ! efficacite d'evaporation (entre 0 et 1)
+      REAL paprs(klon,klev+1) ! pression a inter-couche (Pa)
+      REAL pplay(klon,klev)   ! pression au milieu de couche (Pa)
+      REAL u(klon,klev) ! vitesse U (m/s)
+      REAL v(klon,klev) ! vitesse V (m/s)
+      REAL t(klon,klev) ! temperature (K)
+      REAL q(klon,klev) ! vapeur d'eau (kg/kg)
+      REAL cd_h(klon) ! coefficient de friction au sol pour chaleur
+      REAL cd_m(klon) ! coefficient de friction au sol pour vitesse
+c
+      INTEGER isommet
+      REAL vk
+      PARAMETER (vk=0.40)
+      REAL ricr
+      PARAMETER (ricr=0.4)
+      REAL fak
+      PARAMETER (fak=8.5)
+      REAL fakn
+      PARAMETER (fakn=7.2)
+      REAL onet
+      PARAMETER (onet=1.0/3.0)
+      REAL t_coup
+      PARAMETER(t_coup=273.15)
+      REAL zkmin
+      PARAMETER (zkmin=0.01)
+      REAL betam
+      PARAMETER (betam=15.0)
+      REAL betah
+      PARAMETER (betah=15.0)
+      REAL betas
+      PARAMETER (betas=5.0)
+      REAL sffrac
+      PARAMETER (sffrac=0.1)
+      REAL binm
+      PARAMETER (binm=betam*sffrac)
+      REAL binh
+      PARAMETER (binh=betah*sffrac)
+      REAL ccon
+      PARAMETER (ccon=fak*sffrac*vk)
+c
+      REAL z(klon,klev)
+      REAL pcfm(klon,klev), pcfh(klon,klev)
+c
+      INTEGER i, k
+      REAL zxt, zxq, zxu, zxv, zxmod, taux, tauy
+      REAL zx_alf1, zx_alf2 ! parametres pour extrapolation
+      REAL khfs(klon)       ! surface kinematic heat flux [mK/s]
+      REAL kqfs(klon)       ! sfc kinematic constituent flux [m/s]
+      REAL heatv(klon)      ! surface virtual heat flux
+      REAL ustar(klon)
+      REAL rino(klon,klev)  ! bulk Richardon no. from level to ref lev
+      LOGICAL unstbl(klon)  ! pts w/unstbl pbl (positive virtual ht flx)
+      LOGICAL stblev(klon)  ! stable pbl with levels within pbl
+      LOGICAL unslev(klon)  ! unstbl pbl with levels within pbl
+      LOGICAL unssrf(klon)  ! unstb pbl w/lvls within srf pbl lyr
+      LOGICAL unsout(klon)  ! unstb pbl w/lvls in outer pbl lyr
+      LOGICAL check(klon)   ! True=>chk if Richardson no.>critcal
+      REAL pblh(klon)
+      REAL cgh(klon,2:klev) ! counter-gradient term for heat [K/m]
+      REAL cgq(klon,2:klev) ! counter-gradient term for constituents
+      REAL cgs(klon,2:klev) ! counter-gradient star (cg/flux)
+      REAL obklen(klon)
+      REAL ztvd, ztvu, zdu2
+      REAL therm(klon)      ! thermal virtual temperature excess
+      REAL phiminv(klon)    ! inverse phi function for momentum
+      REAL phihinv(klon)    ! inverse phi function for heat
+      REAL wm(klon)         ! turbulent velocity scale for momentum
+      REAL fak1(klon)       ! k*ustar*pblh
+      REAL fak2(klon)       ! k*wm*pblh
+      REAL fak3(klon)       ! fakn*wstr/wm
+      REAL pblk(klon)       ! level eddy diffusivity for momentum
+      REAL pr(klon)         ! Prandtl number for eddy diffusivities
+      REAL zl(klon)         ! zmzp / Obukhov length
+      REAL zh(klon)         ! zmzp / pblh
+      REAL zzh(klon)        ! (1-(zmzp/pblh))**2
+      REAL wstr(klon)       ! w*, convective velocity scale
+      REAL zm(klon)         ! current level height
+      REAL zp(klon)         ! current level height + one level up
+      REAL zcor, zdelta, zcvm5, zxqs
+      REAL fac, pblmin, zmzp, term
+c
+#include "YOETHF.h"
+#include "FCTTRE.h"
+c
+c Initialisation
+c
+      isommet=klev
+
+      DO i = 1, klon
+         pcfh(i,1) = cd_h(i)
+         pcfm(i,1) = cd_m(i)
+      ENDDO
+      DO k = 2, klev
+      DO i = 1, klon
+         pcfh(i,k) = zkmin
+         pcfm(i,k) = zkmin
+         cgs(i,k) = 0.0
+         cgh(i,k) = 0.0
+         cgq(i,k) = 0.0
+      ENDDO
+      ENDDO
+c
+c Calculer les hauteurs de chaque couche
+c
+      DO i = 1, knon
+         z(i,1) = RD * t(i,1) / (0.5*(paprs(i,1)+pplay(i,1)))
+     .               * (paprs(i,1)-pplay(i,1)) / RG
+      ENDDO
+      DO k = 2, klev
+      DO i = 1, knon
+         z(i,k) = z(i,k-1)
+     .              + RD * 0.5*(t(i,k-1)+t(i,k)) / paprs(i,k)
+     .                   * (pplay(i,k-1)-pplay(i,k)) / RG
+      ENDDO
+      ENDDO
+c
+      DO i = 1, knon
+         IF (thermcep) THEN
+           zdelta=MAX(0.,SIGN(1.,RTT-tsol(i)))
+           zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
+           zcvm5 = zcvm5 / RCPD / (1.0+RVTMP2*q(i,1))
+           zxqs= r2es * FOEEW(tsol(i),zdelta)/paprs(i,1)
+           zxqs=MIN(0.5,zxqs)
+           zcor=1./(1.-retv*zxqs)
+           zxqs=zxqs*zcor
+         ELSE
+           IF (tsol(i).LT.t_coup) THEN
+              zxqs = qsats(tsol(i)) / paprs(i,1)
+           ELSE
+              zxqs = qsatl(tsol(i)) / paprs(i,1)
+           ENDIF
+         ENDIF
+        zx_alf1 = 1.0
+        zx_alf2 = 1.0 - zx_alf1
+        zxt = (t(i,1)+z(i,1)*RG/RCPD/(1.+RVTMP2*q(i,1)))
+     .        *(1.+RETV*q(i,1))*zx_alf1
+     .      + (t(i,2)+z(i,2)*RG/RCPD/(1.+RVTMP2*q(i,2)))
+     .        *(1.+RETV*q(i,2))*zx_alf2
+        zxu = u(i,1)*zx_alf1+u(i,2)*zx_alf2
+        zxv = v(i,1)*zx_alf1+v(i,2)*zx_alf2
+        zxq = q(i,1)*zx_alf1+q(i,2)*zx_alf2
+        zxmod = 1.0+SQRT(zxu**2+zxv**2)
+        khfs(i) = (tsol(i)*(1.+RETV*q(i,1))-zxt) *zxmod*cd_h(i)
+        kqfs(i) = (zxqs-zxq) *zxmod*cd_h(i) * beta(i)
+        heatv(i) = khfs(i) + 0.61*zxt*kqfs(i)
+        taux = zxu *zxmod*cd_m(i)
+        tauy = zxv *zxmod*cd_m(i)
+        ustar(i) = SQRT(taux**2+tauy**2)
+        ustar(i) = MAX(SQRT(ustar(i)),0.01)
+      ENDDO
+c
+      DO i = 1, knon
+         rino(i,1) = 0.0
+         check(i) = .TRUE.
+         pblh(i) = z(i,1)
+         obklen(i) = -t(i,1)*ustar(i)**3/(RG*vk*heatv(i))
+      ENDDO
+
+C
+C PBL height calculation:
+C Search for level of pbl. Scan upward until the Richardson number between
+C the first level and the current level exceeds the "critical" value.
+C
+      fac = 100.0
+      DO k = 1, isommet
+      DO i = 1, knon
+      IF (check(i)) THEN
+         zdu2 = (u(i,k)-u(i,1))**2+(v(i,k)-v(i,1))**2+fac*ustar(i)**2
+         zdu2 = max(zdu2,1.0e-20)
+         ztvd =(t(i,k)+z(i,k)*0.5*RG/RCPD/(1.+RVTMP2*q(i,k)))
+     .         *(1.+RETV*q(i,k))
+         ztvu =(t(i,1)-z(i,k)*0.5*RG/RCPD/(1.+RVTMP2*q(i,1)))
+     .         *(1.+RETV*q(i,1))
+         rino(i,k) = (z(i,k)-z(i,1))*RG*(ztvd-ztvu)
+     .               /(zdu2*0.5*(ztvd+ztvu))
+         IF (rino(i,k).GE.ricr) THEN
+           pblh(i) = z(i,k-1) + (z(i,k-1)-z(i,k)) *
+     .              (ricr-rino(i,k-1))/(rino(i,k-1)-rino(i,k))
+           check(i) = .FALSE.
+         ENDIF
+      ENDIF
+      ENDDO
+      ENDDO
+
+C
+C Set pbl height to maximum value where computation exceeds number of
+C layers allowed
+C
+      DO i = 1, knon
+        if (check(i)) pblh(i) = z(i,isommet)
+      ENDDO
+C
+C Improve estimate of pbl height for the unstable points.
+C Find unstable points (sensible heat flux is upward):
+C
+      DO i = 1, knon
+      IF (heatv(i) .GT. 0.) THEN
+        unstbl(i) = .TRUE.
+        check(i) = .TRUE.
+      ELSE
+        unstbl(i) = .FALSE.
+        check(i) = .FALSE.
+      ENDIF
+      ENDDO
+C
+C For the unstable case, compute velocity scale and the
+C convective temperature excess:
+C
+      DO i = 1, knon
+      IF (check(i)) THEN
+        phiminv(i) = (1.-binm*pblh(i)/obklen(i))**onet
+        wm(i)= ustar(i)*phiminv(i)
+        therm(i) = heatv(i)*fak/wm(i)
+        rino(i,1) = 0.0
+      ENDIF
+      ENDDO
+C
+C Improve pblh estimate for unstable conditions using the
+C convective temperature excess:
+C
+      DO k = 1, isommet
+      DO i = 1, knon
+      IF (check(i)) THEN
+         zdu2 = (u(i,k)-u(i,1))**2+(v(i,k)-v(i,1))**2+fac*ustar(i)**2
+         zdu2 = max(zdu2,1.0e-20)
+         ztvd =(t(i,k)+z(i,k)*0.5*RG/RCPD/(1.+RVTMP2*q(i,k)))
+     .         *(1.+RETV*q(i,k))
+         ztvu =(t(i,1)+therm(i)-z(i,k)*0.5*RG/RCPD/(1.+RVTMP2*q(i,1)))
+     .         *(1.+RETV*q(i,1))
+         rino(i,k) = (z(i,k)-z(i,1))*RG*(ztvd-ztvu)
+     .               /(zdu2*0.5*(ztvd+ztvu))
+         IF (rino(i,k).GE.ricr) THEN
+           pblh(i) = z(i,k-1) + (z(i,k-1)-z(i,k)) *
+     .              (ricr-rino(i,k-1))/(rino(i,k-1)-rino(i,k))
+           check(i) = .FALSE.
+         ENDIF
+      ENDIF
+      ENDDO
+      ENDDO
+C
+C Set pbl height to maximum value where computation exceeds number of
+C layers allowed
+C
+      DO i = 1, knon
+        if (check(i)) pblh(i) = z(i,isommet)
+      ENDDO
+C
+C Points for which pblh exceeds number of pbl layers allowed;
+C set to maximum
+C
+      DO i = 1, knon
+        IF (check(i)) pblh(i) = z(i,isommet)
+      ENDDO
+C
+C PBL height must be greater than some minimum mechanical mixing depth
+C Several investigators have proposed minimum mechanical mixing depth
+C relationships as a function of the local friction velocity, u*.  We
+C make use of a linear relationship of the form h = c u* where c=700.
+C The scaling arguments that give rise to this relationship most often
+C represent the coefficient c as some constant over the local coriolis
+C parameter.  Here we make use of the experimental results of Koracin
+C and Berkowicz (1988) [BLM, Vol 43] for wich they recommend 0.07/f
+C where f was evaluated at 39.5 N and 52 N.  Thus we use a typical mid
+C latitude value for f so that c = 0.07/f = 700.
+C
+      DO i = 1, knon
+        pblmin  = 700.0*ustar(i)
+        pblh(i) = MAX(pblh(i),pblmin)
+      ENDDO
+C
+C pblh is now available; do preparation for diffusivity calculation:
+C
+      DO i = 1, knon
+        pblk(i) = 0.0
+        fak1(i) = ustar(i)*pblh(i)*vk
+C
+C Do additional preparation for unstable cases only, set temperature
+C and moisture perturbations depending on stability.
+C
+        IF (unstbl(i)) THEN
+          zxt=(t(i,1)-z(i,1)*0.5*RG/RCPD/(1.+RVTMP2*q(i,1)))
+     .         *(1.+RETV*q(i,1))
+          phiminv(i) = (1. - binm*pblh(i)/obklen(i))**onet
+          phihinv(i) = sqrt(1. - binh*pblh(i)/obklen(i))
+          wm(i)      = ustar(i)*phiminv(i)
+          fak2(i)    = wm(i)*pblh(i)*vk
+          wstr(i)    = (heatv(i)*RG*pblh(i)/zxt)**onet
+          fak3(i)    = fakn*wstr(i)/wm(i)
+        ENDIF
+      ENDDO
+
+C Main level loop to compute the diffusivities and
+C counter-gradient terms:
+C
+      DO 1000 k = 2, isommet
+C
+C Find levels within boundary layer:
+C
+        DO i = 1, knon
+          unslev(i) = .FALSE.
+          stblev(i) = .FALSE.
+          zm(i) = z(i,k-1)
+          zp(i) = z(i,k)
+          IF (zkmin.EQ.0.0 .AND. zp(i).GT.pblh(i)) zp(i) = pblh(i)
+          IF (zm(i) .LT. pblh(i)) THEN
+            zmzp = 0.5*(zm(i) + zp(i))
+            zh(i) = zmzp/pblh(i)
+            zl(i) = zmzp/obklen(i)
+            zzh(i) = 0.
+            IF (zh(i).LE.1.0) zzh(i) = (1. - zh(i))**2
+C
+C stblev for points zm < plbh and stable and neutral
+C unslev for points zm < plbh and unstable
+C
+            IF (unstbl(i)) THEN
+              unslev(i) = .TRUE.
+            ELSE
+              stblev(i) = .TRUE.
+            ENDIF
+          ENDIF
+        ENDDO
+C
+C Stable and neutral points; set diffusivities; counter-gradient
+C terms zero for stable case:
+C
+        DO i = 1, knon
+          IF (stblev(i)) THEN
+            IF (zl(i).LE.1.) THEN
+              pblk(i) = fak1(i)*zh(i)*zzh(i)/(1. + betas*zl(i))
+            ELSE
+              pblk(i) = fak1(i)*zh(i)*zzh(i)/(betas + zl(i))
+            ENDIF
+            pcfm(i,k) = pblk(i)
+            pcfh(i,k) = pcfm(i,k)
+          ENDIF
+        ENDDO
+C
+C unssrf, unstable within surface layer of pbl
+C unsout, unstable within outer   layer of pbl
+C
+        DO i = 1, knon
+          unssrf(i) = .FALSE.
+          unsout(i) = .FALSE.
+          IF (unslev(i)) THEN
+            IF (zh(i).lt.sffrac) THEN
+              unssrf(i) = .TRUE.
+            ELSE
+              unsout(i) = .TRUE.
+            ENDIF
+          ENDIF
+        ENDDO
+C
+C Unstable for surface layer; counter-gradient terms zero
+C
+        DO i = 1, knon
+          IF (unssrf(i)) THEN
+            term = (1. - betam*zl(i))**onet
+            pblk(i) = fak1(i)*zh(i)*zzh(i)*term
+            pr(i) = term/sqrt(1. - betah*zl(i))
+          ENDIF
+        ENDDO
+C
+C Unstable for outer layer; counter-gradient terms non-zero:
+C
+        DO i = 1, knon
+          IF (unsout(i)) THEN
+            pblk(i) = fak2(i)*zh(i)*zzh(i)
+            cgs(i,k) = fak3(i)/(pblh(i)*wm(i))
+            cgh(i,k) = khfs(i)*cgs(i,k)
+            pr(i) = phiminv(i)/phihinv(i) + ccon*fak3(i)/fak
+            cgq(i,k) = kqfs(i)*cgs(i,k)
+          ENDIF
+        ENDDO
+C
+C For all unstable layers, set diffusivities
+C
+        DO i = 1, knon
+        IF (unslev(i)) THEN
+            pcfm(i,k) = pblk(i)
+            pcfh(i,k) = pblk(i)/pr(i)
+        ENDIF
+        ENDDO
+ 1000 continue           ! end of level loop
+
+      RETURN
+      END
Index: LMDZ4/trunk/libf/phylmd/oasis.F90
===================================================================
--- LMDZ4/trunk/libf/phylmd/oasis.F90	(revision 782)
+++ LMDZ4/trunk/libf/phylmd/oasis.F90	(revision 782)
@@ -0,0 +1,396 @@
+!
+! $Header$
+!
+MODULE oasis
+!
+! This module contains subroutines for initialization, sending and receiving 
+! towards the coupler OASIS3. It also contains some parameters for the coupling.
+!
+! This module should always be compiled. With the coupler OASIS3 available the cpp key
+! CPP_COUPLE should be set and the entier of this file will then be compiled. 
+! In a forced mode CPP_COUPLE should not be defined and the compilation ends before 
+! the CONTAINS, without compiling the subroutines.
+!
+  USE dimphy 
+  USE mod_phys_lmdz_para
+  USE write_field_phy
+
+#ifdef CPP_COUPLE
+  USE mod_prism_proto
+  USE mod_prism_def_partition_proto
+  USE mod_prism_get_proto
+  USE mod_prism_put_proto
+#endif
+  
+  IMPLICIT NONE
+    
+! Maximum number of fields exchanged between ocean and atmosphere
+  INTEGER, PARAMETER  :: jpmaxfld=40
+! Number of fields exchanged from atmosphere to ocean via flx.F
+  INTEGER, PARAMETER  :: jpflda2o1=13
+! Number of fields exchanged from atmosphere to ocean via tau.F
+  INTEGER, PARAMETER  :: jpflda2o2=6
+! Number of fields exchanged from ocean to atmosphere
+  INTEGER, PARAMETER  :: jpfldo2a=4
+
+  CHARACTER (len=8), DIMENSION(jpmaxfld), PUBLIC, SAVE   :: cl_read
+  !$OMP THREADPRIVATE(cl_read)
+  CHARACTER (len=8), DIMENSION(jpmaxfld), PUBLIC, SAVE   :: cl_writ
+  !$OMP THREADPRIVATE(cl_writ)
+
+  INTEGER, DIMENSION(jpfldo2a), SAVE, PRIVATE            :: in_var_id
+  !$OMP THREADPRIVATE(in_var_id)
+  INTEGER, DIMENSION(jpflda2o1+jpflda2o2), SAVE, PRIVATE :: out_var_id
+  !$OMP THREADPRIVATE(out_var_id)
+
+
+#ifdef CPP_COUPLE
+
+CONTAINS
+
+  SUBROUTINE inicma
+!************************************************************************************
+!**** *INICMA*  - Initialize coupled mode communication for atmosphere
+!                 and exchange some initial information with Oasis
+!
+!     Rewrite to take the PRISM/psmile library into account
+!     LF 09/2003
+!
+    INCLUDE "dimensions90.h"
+
+! Local variables
+!************************************************************************************
+    INTEGER                            :: comp_id
+    INTEGER                            :: ierror, il_commlocal
+    INTEGER                            :: il_part_id
+    INTEGER, DIMENSION(3)              :: ig_paral
+    INTEGER, DIMENSION(2)              :: il_var_nodims
+    INTEGER, DIMENSION(4)              :: il_var_actual_shape
+    INTEGER                            :: il_var_type
+    INTEGER                            :: nuout = 6
+    INTEGER                            :: jf
+    CHARACTER (len = 6)                :: clmodnam
+    CHARACTER (len = 20)               :: modname = 'inicma'
+    CHARACTER (len = 80)               :: abort_message 
+
+!*    1. Initializations
+!        ---------------
+!************************************************************************************
+    WRITE(nuout,*) ' '
+    WRITE(nuout,*) ' '
+    WRITE(nuout,*) ' ROUTINE INICMA'
+    WRITE(nuout,*) ' **************'
+    WRITE(nuout,*) ' '
+    WRITE(nuout,*) ' '
+
+!
+! Define the model name
+!
+    clmodnam = 'lmdz.x'       ! as in $NBMODEL in Cpl/Nam/namcouple.tmp
+!
+!************************************************************************************
+! Here we go: psmile initialisation
+!************************************************************************************
+    IF (is_sequential) THEN
+       CALL prism_init_comp_proto (comp_id, clmodnam, ierror)
+       
+       IF (ierror .NE. PRISM_Ok) THEN
+          abort_message=' Probleme init dans prism_init_comp '
+          CALL abort_gcm(modname,abort_message,1)
+       ELSE
+          WRITE(nuout,*) 'inicma : init psmile ok '
+       ENDIF
+    ENDIF
+
+    CALL prism_get_localcomm_proto (il_commlocal, ierror)
+!************************************************************************************
+! Domain decomposition
+!************************************************************************************
+    ig_paral(1) = 1                            ! apple partition for //
+    ig_paral(2) = (jj_begin-1)*iim+ii_begin-1  ! offset
+    ig_paral(3) = (jj_end*iim+ii_end) - (jj_begin*iim+ii_begin) + 1
+
+    IF (mpi_rank==mpi_size-1) ig_paral(3)=ig_paral(3)+iim-1
+    WRITE(nuout,*) mpi_rank,'ig_paral--->',ig_paral(2),ig_paral(3)
+    
+    ierror=PRISM_Ok
+    CALL prism_def_partition_proto (il_part_id, ig_paral, ierror)
+
+    IF (ierror .NE. PRISM_Ok) THEN
+       abort_message=' Probleme dans prism_def_partition '
+       CALL abort_gcm(modname,abort_message,1)
+    ELSE
+       WRITE(nuout,*) 'inicma : decomposition domaine psmile ok '
+    ENDIF
+
+!************************************************************************************
+! Field Declarations
+!************************************************************************************
+!     Define symbolic name for fields exchanged from atmos to coupler,
+!         must be the same as (1) of the field  definition in namcouple:
+    cl_writ(1)='COTAUXXU'
+    cl_writ(2)='COTAUYYU'
+    cl_writ(3)='COTAUZZU'
+    cl_writ(4)='COTAUXXV'
+    cl_writ(5)='COTAUYYV'
+    cl_writ(6)='COTAUZZV'
+    cl_writ(7)='COWINDSP'
+    cl_writ(8)='COSHFICE'
+    cl_writ(9)='COSHFOCE'
+    cl_writ(10)='CONSFICE'
+    cl_writ(11)='CONSFOCE'
+    cl_writ(12)='CODFLXDT'
+    cl_writ(13)='COTFSICE'
+    cl_writ(14)='COTFSOCE'
+    cl_writ(15)='COTOLPSU'
+    cl_writ(16)='COTOSPSU'
+    cl_writ(17)='CORUNCOA'
+    cl_writ(18)='CORIVFLU'
+    cl_writ(19)='COCALVIN'
+!
+!     Define symbolic name for fields exchanged from coupler to atmosphere,
+!         must be the same as (2) of the field  definition in namcouple:
+!
+    cl_read(1)='SISUTESW'
+    cl_read(2)='SIICECOV'
+    cl_read(3)='SIICEALW'
+    cl_read(4)='SIICTEMW'
+    
+    il_var_nodims(1) = 2
+    il_var_nodims(2) = 1
+
+    il_var_actual_shape(1) = 1
+    il_var_actual_shape(2) = iim
+    il_var_actual_shape(3) = 1
+    il_var_actual_shape(4) = jjm+1
+   
+    il_var_type = PRISM_Real
+
+!************************************************************************************
+! Oceanic Fields
+!************************************************************************************
+    DO jf=1, jpfldo2a
+       CALL prism_def_var_proto(in_var_id(jf), cl_read(jf), il_part_id, &
+            il_var_nodims, PRISM_In, il_var_actual_shape, il_var_type, &
+            ierror)
+       IF (ierror .NE. PRISM_Ok) THEN
+          abort_message=' Probleme init dans prism_def_var_proto '
+          CALL abort_gcm(modname,abort_message,1)
+       ENDIF
+    END DO
+
+!************************************************************************************
+! Atmospheric Fields
+!************************************************************************************
+    DO jf=1, jpflda2o1+jpflda2o2
+       CALL prism_def_var_proto(out_var_id(jf), cl_writ(jf), il_part_id, &
+            il_var_nodims, PRISM_Out, il_var_actual_shape, il_var_type, &
+            ierror)
+       IF (ierror .NE. PRISM_Ok) THEN
+          abort_message=' Probleme init dans prism_def_var_proto '
+          CALL abort_gcm(modname,abort_message,1)
+       ENDIF
+    END DO
+
+!************************************************************************************
+! End definition
+!************************************************************************************
+    CALL prism_enddef_proto(ierror)
+    IF (ierror .NE. PRISM_Ok) THEN
+       abort_message=' Probleme init dans prism_ endef_proto'
+       CALL abort_gcm(modname,abort_message,1)
+    ELSE
+       WRITE(nuout,*) 'inicma : endef psmile ok '
+    ENDIF
+    
+  END SUBROUTINE inicma
+
+!
+!************************************************************************************
+!
+
+  SUBROUTINE fromcpl(ktime, tab_get)
+! ======================================================================
+! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine reads the SST 
+! and Sea-Ice provided by the coupler. Adaptation to psmile library
+!======================================================================
+!
+    INCLUDE "dimensions90.h"
+! Input arguments
+!************************************************************************************
+    INTEGER, INTENT(IN)                               ::  ktime
+
+! Output arguments
+!************************************************************************************
+    REAL, DIMENSION(iim, jj_nb,jpfldo2a), INTENT(OUT) :: tab_get
+
+! Local variables
+!************************************************************************************
+    INTEGER                       :: nuout  = 6             ! listing output unit
+    INTEGER                       :: ierror, i
+    INTEGER                       :: istart,iend
+    CHARACTER (len = 20)          :: modname = 'fromcpl'
+    CHARACTER (len = 80)          :: abort_message 
+    REAL, DIMENSION(iim*jj_nb)    :: field
+
+!************************************************************************************
+    WRITE (nuout,*) ' '
+    WRITE (nuout,*) 'Fromcpl: Reading fields from CPL, ktime=',ktime
+    WRITE (nuout,*) ' '
+    CALL flush (nuout)
+    
+    istart=ii_begin
+    IF (is_south_pole) THEN
+       iend=(jj_end-jj_begin)*iim+iim
+    ELSE
+       iend=(jj_end-jj_begin)*iim+ii_end
+    ENDIF
+    
+    DO i = 1, jpfldo2a
+       field(:) = -99999.
+       CALL prism_get_proto(in_var_id(i), ktime, field(istart:iend), ierror)
+       tab_get(:,:,i) = RESHAPE(field(:),(/iim,jj_nb/))
+       
+       IF (ierror .NE. PRISM_Ok .AND. ierror.NE.PRISM_Recvd .AND. &
+            ierror.NE.PRISM_FromRest &
+            .AND. ierror.NE.PRISM_Input .AND. ierror.NE.PRISM_RecvOut &
+            .AND. ierror.NE.PRISM_FromRestOut) THEN
+          WRITE (nuout,*)  cl_read(i), ktime   
+          abort_message=' Probleme dans prism_get_proto '
+          CALL abort_gcm(modname,abort_message,1)
+       ENDIF
+    END DO
+    
+    
+  END SUBROUTINE fromcpl
+
+!
+!************************************************************************************
+! 
+
+  SUBROUTINE intocpl(ktime, last, tab_put) 
+! ======================================================================
+! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine provides the 
+! atmospheric coupling fields to the coupler with the psmile library.
+! IF last time step, writes output fields to binary files.
+! ======================================================================
+!
+! 
+    INCLUDE "dimensions90.h"
+! Input arguments
+!************************************************************************************
+    INTEGER, INTENT(IN)                                          :: ktime
+    LOGICAL, INTENT(IN)                                          :: last
+    REAL, DIMENSION(iim, jj_nb, jpflda2o1+jpflda2o2), INTENT(IN) :: tab_put
+
+! Local variables
+!************************************************************************************
+    LOGICAL                     :: checkout=.FALSE.
+    INTEGER                     :: istart,iend
+    INTEGER                     :: wstart,wend
+    INTEGER, PARAMETER          :: nuout = 6 
+    INTEGER                     :: ierror, i
+    REAL, DIMENSION(iim*jj_nb)  :: field
+    CHARACTER (len = 20),SAVE   :: modname = 'intocpl'
+    CHARACTER (len = 80)        :: abort_message 
+
+!************************************************************************************
+
+    WRITE(nuout,*) ' '
+    WRITE(nuout,*) 'Intocpl: sending fields to CPL, ktime= ', ktime
+    WRITE(nuout,*) 'last  ', last
+    WRITE(nuout,*)
+
+
+    istart=ii_begin
+    IF (is_south_pole) THEN
+       iend=(jj_end-jj_begin)*iim+iim
+    ELSE
+       iend=(jj_end-jj_begin)*iim+ii_end
+    ENDIF
+    
+    IF (checkout) THEN   
+       wstart=istart
+       wend=iend
+       IF (is_north_pole) wstart=istart+iim-1
+       IF (is_south_pole) wend=iend-iim+1
+       
+       field = RESHAPE(tab_put(:,:,8),(/iim*jj_nb/))
+       CALL writeField_phy("fsolice",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,9),(/iim*jj_nb/))
+       CALL writeField_phy("fsolwat",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,10),(/iim*jj_nb/))
+       CALL writeField_phy("fnsolice",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,11),(/iim*jj_nb/))
+       CALL writeField_phy("fnsolwat",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,12),(/iim*jj_nb/))
+       CALL writeField_phy("fnsicedt",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,13),(/iim*jj_nb/))
+       CALL writeField_phy("evice",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,14),(/iim*jj_nb/))
+       CALL writeField_phy("evwat",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,15),(/iim*jj_nb/))
+       CALL writeField_phy("lpre",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,16),(/iim*jj_nb/))
+       CALL writeField_phy("spre",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,17),(/iim*jj_nb/))
+       CALL writeField_phy("dirunoff",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,18),(/iim*jj_nb/))
+       CALL writeField_phy("rivrunoff",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,19),(/iim*jj_nb/))
+       CALL writeField_phy("calving",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,1),(/iim*jj_nb/))
+       CALL writeField_phy("tauxx_u",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,2),(/iim*jj_nb/))
+       CALL writeField_phy("tauyy_u",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,3),(/iim*jj_nb/))
+       CALL writeField_phy("tauzz_u",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,4),(/iim*jj_nb/))
+       CALL writeField_phy("tauxx_v",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,5),(/iim*jj_nb/))
+       CALL writeField_phy("tauyy_v",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,6),(/iim*jj_nb/))
+       CALL writeField_phy("tauzz_v",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,7),(/iim*jj_nb/))
+       CALL writeField_phy("windsp",field(wstart:wend),1)
+    ENDIF
+   
+!************************************************************************************
+! PRISM_PUT
+!************************************************************************************
+
+    DO i = 1, jpflda2o1+jpflda2o2
+       field = RESHAPE(tab_put(:,:,i),(/iim*jj_nb/))
+       CALL prism_put_proto(out_var_id(i), ktime, field(istart:iend), ierror)
+       
+       IF (ierror .NE. PRISM_Ok .AND. ierror.NE.PRISM_Sent .AND. ierror.NE.PRISM_ToRest &
+            .AND. ierror.NE.PRISM_LocTrans .AND. ierror.NE.PRISM_Output .AND. &
+            ierror.NE.PRISM_SentOut .AND. ierror.NE.PRISM_ToRestOut) THEN
+          WRITE (nuout,*)  cl_writ(i), ktime   
+          abort_message=' Probleme dans prism_put_proto '
+          CALL abort_gcm(modname,abort_message,1)
+       ENDIF
+       
+    END DO
+   
+!************************************************************************************
+! Finalize PSMILE for the case is_sequential, if parallel finalization is done 
+! from Finalize_parallel in dyn3dpar/parallel.F90
+!************************************************************************************
+
+    IF (last) THEN
+       IF (is_sequential) THEN 
+          CALL prism_terminate_proto(ierror)
+          IF (ierror .NE. PRISM_Ok) THEN
+             abort_message=' Probleme dans prism_terminate_proto '
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+       ENDIF
+    ENDIF
+    
+    
+  END SUBROUTINE intocpl
+
+#endif
+  
+END MODULE oasis
Index: LMDZ4/trunk/libf/phylmd/oasis.dummy
===================================================================
--- LMDZ4/trunk/libf/phylmd/oasis.dummy	(revision 781)
+++ 	(revision )
@@ -1,709 +1,0 @@
-!
-! $Header$
-!
-C $Id$
-C****
-C
-C**** *INICMA*  - Initialize coupled mode communication for atmosphere
-C                 and exchange some initial information with Oasis
-C
-C     Input:
-C     -----
-C       KASTP  : total number of timesteps in atmospheric model
-C       KEXCH  : frequency of exchange (in time steps)
-C       KSTEP  : length of timestep (in seconds)
-C
-C     -----------------------------------------------------------
-C
-      SUBROUTINE inicma(kastp,kexch,kstep,imjm)
-c
-c     INCLUDE "param.h"
-c
-      INTEGER kastp, kexch, kstep,imjm
-      INTEGER iparal(3)
-      INTEGER ifcpl, idt, info, imxtag, istep, jf
-
-c -- LOOP
-c 
-#include "dimensions.h"
-      INTEGER jjmp1
-      PARAMETER (jjmp1=jjm+1-1/jjm)
-#include "dimphy.h"
-       REAL zwindsp(klon)
-c
-c -- LOOP
-c
-#include "param_cou.h"
-#include "inc_cpl.h"
-      CHARACTER*3 cljobnam      ! experiment name
-      CHARACTER*6 clmodnam      ! model name
-c     EM: not used by Oasis2.4
-CEM      CHARACTER*6 clbid(2)      ! for CLIM_Init call (not used)
-CEM                                ! must be dimensioned by the number of models
-CEM      INTEGER nbid(2)           ! for CLIM_Init call (not used)
-CEM                                ! must be dimensioned by the number of models
-      CHARACTER*5 cloasis       ! coupler name (Oasis)
-      INTEGER imess(4)
-      INTEGER getpid            ! system functions
-      INTEGER nuout
-CEM      LOGICAL llmodel
-      PARAMETER (nuout = 6)
-c
-#include "clim.h"
-#include "mpiclim.h"
-c
-#include "oasis.h"      
-                        ! contains the name of communication technique. Here
-                        ! cchan=CLIM only is possible.
-c			! ctype=MPI2
-c
-C     -----------------------------------------------------------
-C
-C*    1. Initializations
-C        ---------------
-C
-      WRITE(nuout,*) ' '
-      WRITE(nuout,*) ' '
-      WRITE(nuout,*) ' ROUTINE INICMA'
-      WRITE(nuout,*) ' **************'
-      WRITE(nuout,*) ' '
-      WRITE(nuout,*) ' '
-c
-c     Define the model name
-c
-      clmodnam = 'lmdz.x'       ! as in $NBMODEL in Cpl/Nam/namcouple.tmp
-c
-c     Define the coupler name
-c
-      cloasis = 'Oasis'        !  always 'Oasis' as in the coupler
-c
-c
-c     Define symbolic name for fields exchanged from atmos to coupler,
-c         must be the same as (1) of the field  definition in namcouple:
-c
-      cl_writ(8)='COSHFICE'
-      cl_writ(9)='COSHFOCE'
-      cl_writ(10)='CONSFICE'
-      cl_writ(11)='CONSFOCE'
-      cl_writ(12)='CODFLXDT'
-c      cl_writ(6)='COICTEMP'
-      cl_writ(13)='COTFSICE'
-      cl_writ(14)='COTFSOCE'
-      cl_writ(15)='COTOLPSU'
-      cl_writ(16)='COTOSPSU'
-      cl_writ(17)='CORUNCOA'
-      cl_writ(18)='CORIVFLU'
-      cl_writ(19)='COCALVIN'
-cxxx      cl_writ(13)='COZOTAUX'
-cxxx      cl_writ(14)='COZOTAUV'
-cxxx      cl_writ(15)='COMETAUY'
-cxxx      cl_writ(16)='COMETAUU'
-      cl_writ(1)='COTAUXXU'
-      cl_writ(2)='COTAUYYU'
-      cl_writ(3)='COTAUZZU'
-      cl_writ(4)='COTAUXXV'
-      cl_writ(5)='COTAUYYV'
-      cl_writ(6)='COTAUZZV'
-c -- LOOP
-      cl_writ(7)='COWINDSP'
-c -- LOOP
-c
-c     Define files name for fields exchanged from atmos to coupler,
-c         must be the same as (6) of the field  definition in namcouple:
-c
-      cl_f_writ(1)='flxatmos'
-      cl_f_writ(2)='flxatmos'
-      cl_f_writ(3)='flxatmos'
-      cl_f_writ(4)='flxatmos'
-      cl_f_writ(5)='flxatmos'
-      cl_f_writ(6)='flxatmos'
-      cl_f_writ(7)='flxatmos'
-      cl_f_writ(8)='flxatmos'
-      cl_f_writ(9)='flxatmos'
-      cl_f_writ(10)='flxatmos'
-      cl_f_writ(11)='flxatmos'
-      cl_f_writ(12)='flxatmos'
-      cl_f_writ(13)='flxatmos'
-      cl_f_writ(14)='flxatmos'
-      cl_f_writ(15)='flxatmos'
-      cl_f_writ(16)='flxatmos'
-      cl_f_writ(17)='flxatmos'
-      cl_f_writ(18)='flxatmos'
-c -- LOOP
-      cl_f_writ(19)='flxatmos'
-c -- LOOP
-
-c
-c
-c     Define symbolic name for fields exchanged from coupler to atmosphere,
-c         must be the same as (2) of the field  definition in namcouple:
-c
-      cl_read(1)='SISUTESW'
-      cl_read(2)='SIICECOV'
-      cl_read(3)='SIICEALW'
-      cl_read(4)='SIICTEMW'
-c
-c     Define files names for fields exchanged from coupler to atmosphere,
-c         must be the same as (7) of the field  definition in namcouple:
-c
-      cl_f_read(1)='sstatmos'
-      cl_f_read(2)='sstatmos'
-      cl_f_read(3)='sstatmos'
-      cl_f_read(4)='sstatmos'
-c
-c
-c     Define the number of processors involved in the coupling for
-c     Oasis (=1) and each model (as last two INTEGER on $CHATYPE line
-c     in the namcouple); they will be stored in a COMMON in mpiclim.h
-c     (used for CLIM/MPI2 only)
-      mpi_nproc(0)=1
-      mpi_nproc(1)=1
-      mpi_nproc(2)=1 
-c
-c     Define infos to be sent initially to oasis
-c
-      imess(1) = kastp      ! total number of timesteps in atmospheric model
-      imess(2) = kexch      ! period of exchange (in time steps)
-      imess(3) = kstep      ! length of atmospheric timestep (in seconds)
-      imess(4) = getpid()   ! PID of atmospheric model
-c
-c     Initialization and exchange of initial info in the CLIM technique
-c
-      IF (cchan.eq.'CLIM') THEN
-c
-c     Define the experiment name :
-c
-          cljobnam = 'CLI'      ! as $JOBNAM in namcouple
-c
-c         Start the coupling 
-c         (see lib/clim/src/CLIM_Init for the definition of input parameters)
-c
-cEM          clbid(1)='      '
-cEM          clbid(2)='      '
-cEM          nbid(1)=0
-cEM          nbid(2)=0
-CEM          llmodel=.true.
-c
-c         Define the number of processors used by each model as in
-c         $CHATYPE line of namcouple (used for CLIM/MPI2 only) 
-          mpi_totproc(1)=1
-          mpi_totproc(2)=1
-c
-c         Define names of each model as in $NBMODEL line of namcouple
-c         (used for CLIM/MPI2 only)        
-          cmpi_modnam(1)='lmdz.x'
-          cmpi_modnam(2)='opa.xx'
-c         Start the coupling 
-c
-          CALL CLIM_Init ( cljobnam, clmodnam, 3, 7,
-     *                 kastp, kexch, kstep,
-     *                 5, 3600, 3600, info )
-c
-          IF (info.ne.CLIM_Ok) THEN
-              WRITE ( nuout, *) ' inicma : pb init clim '
-              WRITE ( nuout, *) ' error code is = ', info
-              CALL halte('STOP in inicma')
-            ELSE
-              WRITE(nuout,*) 'inicma : init clim ok '
-          ENDIF
-c
-c         For each coupling field, association of a port to its symbolic name
-c
-c         -Define the parallel decomposition associated to the port of each
-c          field; here no decomposition for all ports.
-          iparal ( clim_strategy ) = clim_serial 
-          iparal ( clim_length   ) = imjm
-          iparal ( clim_offset   ) = 0
-c
-c         -Loop on total number of coupler-to-atmosphere fields
-c         (see lib/clim/src/CLIM_Define for the definition of input parameters)
-          DO jf=1, jpfldo2a
-            CALL CLIM_Define (cl_read(jf), clim_in , clim_double, iparal
-     $          , info )  
-            WRITE(nuout,*) 'inicma : clim define done for ',jf
-     $          ,cl_read(jf) 
-          END DO 
-c
-c         -Loop on total number of atmosphere-to-coupler fields 
-c         (see lib/clim/src/CLIM_Define for the definition of input parameters)
-          DO jf=1, jpflda2o1+jpflda2o2
-            CALL CLIM_Define (cl_writ(jf), clim_out , clim_double,
-     $          iparal, info )   
-            WRITE(nuout,*) 'inicma : clim define done for ',jf
-     $          ,cl_writ(jf) 
-          END DO 
-c
-          WRITE(nuout,*) 'inicma : clim_define ok '
-c
-c         -Join a pvm group, wait for other programs and broadcast usefull 
-c          informations to Oasis and to the ocean (see lib/clim/src/CLIM_Start)
-          CALL CLIM_Start ( imxtag, info )
-          IF (info.ne.clim_ok) THEN
-              WRITE ( nuout, *) 'inicma : pb start clim '
-              WRITE ( nuout, *) ' error code is = ', info
-              CALL halte('stop in inicma')
-            ELSE
-              WRITE ( nuout, *)  'inicma : start clim ok '
-          ENDIF
-c
-c         -Get initial information from Oasis
-c          (see lib/clim/src/CLIM_Stepi)
-          CALL CLIM_Stepi (cloasis, istep, ifcpl, idt, info)
-          IF (info .NE. clim_ok) THEN
-              WRITE ( UNIT = nuout, FMT = *)
-     $            ' warning : problem in getting step info ',
-     $            'from oasis '
-              WRITE (UNIT = nuout, FMT = *)
-     $            ' =======   error code number = ', info
-            ELSE
-              WRITE (UNIT = nuout, FMT = *)
-     $            ' got step information from oasis '
-          ENDIF
-          WRITE ( nuout, *) ' number of tstep in oasis ', istep
-          WRITE ( nuout, *) ' exchange frequency in oasis ', ifcpl
-          WRITE ( nuout, *) ' length of tstep in oasis ', idt
-      ENDIF 
-
-      RETURN
-      END
-
-c $Id$
-      SUBROUTINE fromcpl(kt, imjm, sst, gla, tice, albedo)
-c ======================================================================
-c S. Valcke (02/99) adapted From L.Z.X Li: this subroutine reads the SST 
-c and Sea-Ice provided by the coupler with the CLIM (PVM exchange messages)
-c technique. 
-c======================================================================
-      IMPLICIT none
-      INTEGER imjm, kt
-      REAL sst(imjm)          ! sea-surface-temperature
-      REAL gla(imjm)          ! sea-ice
-      REAL tice(imjm)          ! temp glace
-      REAL albedo(imjm)          ! albedo glace
-c
-      INTEGER nuout             ! listing output unit
-      PARAMETER (nuout=6)
-c
-      INTEGER nuread, ios, iflag, icpliter
-      INTEGER info, jf
-c
-#include "clim.h"
-c
-#include "oasis.h"
-#include "param_cou.h"
-c
-#include "inc_cpl.h"
-c
-c
-      WRITE (nuout,*) ' '
-      WRITE (nuout,*) 'Fromcpl: Reading fields from CPL, kt=',kt
-      WRITE (nuout,*) ' '
-      CALL flush (nuout)
-
-
-      IF (cchan.eq.'CLIM') THEN 
-
-c
-c     -Get interpolated oceanic fields from Oasis
-c
-          DO jf=1,jpfldo2a
-            IF (jf.eq.1) CALL CLIM_Import (cl_read(jf) , kt, sst, info)
-            IF (jf.eq.2) CALL CLIM_Import (cl_read(jf) , kt, gla, info)
-            IF (jf.eq.3) CALL CLIM_Import (cl_read(jf), kt,albedo, info)
-            IF (jf.eq.4) CALL CLIM_Import (cl_read(jf) , kt, tice, info)
-            IF ( info .NE. CLIM_Ok) THEN
-                WRITE(nuout,*)'Pb in reading ', cl_read(jf), jf
-                WRITE(nuout,*)'Couplage kt is = ',kt
-                WRITE(nuout,*)'CLIM error code is = ', info
-                CALL halte('STOP in fromcpl.F')
-            ENDIF
-          END DO 
-
-      ENDIF 
-c
-      RETURN
-      END
-
-c $Id$
-c -- LOOP
-      SUBROUTINE intocpl(kt, imjm, fsolice, fsolwat, fnsolice, fnsolwat,
-     $    fnsicedt, evice, evwat, lpre, spre, dirunoff, rivrunoff, 
-     $    calving, tauxx_u, tauyy_u, tauzz_u, tauxx_v, tauyy_v, tauzz_v,
-     $    windsp, last)
-c -- LOOP 
-c ======================================================================
-c S. Valcke (02/99) adapted From L.Z.X Li: this subroutine provides the 
-c atmospheric coupling fields to the coupler with the CLIM (PVM exchange 
-c messages) technique. 
-c IF last time step, writes output fields to binary files.
-c ======================================================================
-      IMPLICIT NONE
-c -- LOOP
-c 
-#include "dimensions.h"
-      INTEGER jjmp1
-      PARAMETER (jjmp1=jjm+1-1/jjm)
-#include "dimphy.h"
-c      REAL zu10m(klon), zv10m(klon)
-       REAL zwindsp(klon)
-c
-c -- LOOP
-c
-
-      INTEGER kt, imjm
-c
-      REAL fsolice(imjm)
-      REAL fsolwat(imjm)
-      REAL fnsolwat(imjm)
-      REAL fnsolice(imjm) 
-      REAL fnsicedt(imjm) 
-      REAL evice(imjm)
-      REAL evwat(imjm)
-      REAL lpre(imjm)
-      REAL spre(imjm)
-      REAL dirunoff(imjm)
-      REAL rivrunoff(imjm)
-      REAL calving(imjm)
-cxxx      REAL tauxu(imjm)
-cxxx      REAL tauxv(imjm)
-cxxx      REAL tauyu(imjm)
-cxxx      REAL tauyv(imjm)
-      REAL tauxx_u(imjm)
-      REAL tauxx_v(imjm)
-      REAL tauyy_u(imjm)
-      REAL tauyy_v(imjm)
-      REAL tauzz_u(imjm)
-      REAL tauzz_v(imjm)
-c -- LOOP
-       REAL windsp(imjm)
-c -- LOOP
-      LOGICAL last
-c
-      INTEGER nuout
-      PARAMETER (nuout = 6)
-c
-#include "clim.h"
-#include "param_cou.h"
-#include "inc_cpl.h"
-c
-      CHARACTER*8 file_name(jpmaxfld)
-      INTEGER max_file
-      INTEGER file_unit_max, file_unit(jpmaxfld),
-     $    file_unit_field(jpmaxfld) 
-
-      INTEGER icstep, info, jn, jf, ierror
-      LOGICAL trouve
-c
-#include "oasis.h"
-c
-      icstep=kt 
-c
-      WRITE(nuout,*) ' '
-      WRITE(nuout,*) 'Intocpl: sending fields to CPL, kt= ', kt
-      WRITE(nuout,*) 'last  ', last
-      WRITE(nuout,*)
-
-      IF (last) THEN 
-c
-c     -WRITE fields to binary files for coupler restart at last time step
-c
-c         -initialisation and files opening
-c
-          max_file=1
-          file_unit_max=99
-c         -keeps first file name
-          file_name(max_file)=cl_f_writ(max_file)
-c         -keeps first file unit
-          file_unit(max_file)=file_unit_max
-c         -decrements file unit maximum
-          file_unit_max=file_unit_max-1
-c         -keeps file unit for field
-          file_unit_field(1)=file_unit(max_file)
-c
-c         -different files names counter
-c
-          DO jf= 2, jpflda2o1 + jpflda2o2
-            trouve=.false.
-            DO jn= 1, max_file
-              IF (.not.trouve) THEN
-                  IF (cl_f_writ(jf).EQ.file_name(jn)) THEN
-c                 -keep file unit for field
-                      file_unit_field(jf)=file_unit(jn)
-                      trouve=.true.
-                  END IF 
-              END IF 
-            END DO 
-            IF (.not.trouve) then
-c           -increment the number of different files
-                max_file=max_file+1
-c           -keep file name
-                file_name(max_file)=cl_f_writ(jf)
-c           -keep file unit for file
-                file_unit(max_file)=file_unit_max
-c           -keep file unit for field
-                file_unit_field(jf)=file_unit(max_file)
-c           -decrement unit maximum number from 99 to 98, ...
-                file_unit_max=file_unit_max-1
-            END IF 
-          END DO 
-c          
-          DO jn=1, max_file 
-            OPEN (file_unit(jn), FILE=file_name(jn), FORM='UNFORMATTED')
-            WRITE(*,*) 'Opening FILE ', file_unit(jn), ' '
-     $          , file_name(jn) 
-            REWIND(file_unit(jn))
-          END DO
-c 
-c         WRITE fields to files          
-          DO jf=1, jpflda2o1 + jpflda2o2
-            IF (jf.eq.8)
-     $          CALL locwrite(cl_writ(jf),fsolice, imjm,
-     $          file_unit_field(jf), ierror) 
-            IF (jf.eq.9)
-     $          CALL locwrite(cl_writ(jf),fsolwat, imjm,
-     $          file_unit_field(jf), ierror) 
-            IF (jf.eq.10)
-     $          CALL locwrite(cl_writ(jf),fnsolice, imjm,
-     $          file_unit_field(jf), ierror) 
-            IF (jf.eq.11)
-     $          CALL locwrite(cl_writ(jf),fnsolwat, imjm,
-     $          file_unit_field(jf), ierror) 
-            IF (jf.eq.12)
-     $          CALL locwrite(cl_writ(jf),fnsicedt, imjm,
-     $          file_unit_field(jf), ierror) 
-c            IF (jf.eq.13)
-c     $          CALL locwrite(cl_writ(jf),ictemp, imjm,
-c     $          file_unit_field(jf), ierror) 
-            IF (jf.eq.13)
-     $          CALL locwrite(cl_writ(jf),evice, imjm,
-     $          file_unit_field(jf), ierror) 
-            IF (jf.eq.14)
-     $          CALL locwrite(cl_writ(jf),evwat, imjm,
-     $          file_unit_field(jf), ierror) 
-            IF (jf.eq.15)
-     $          CALL locwrite(cl_writ(jf),lpre, imjm,
-     $          file_unit_field(jf), ierror) 
-            IF (jf.eq.16)
-     $          CALL locwrite(cl_writ(jf),spre, imjm,
-     $          file_unit_field(jf), ierror) 
-            IF (jf.eq.17)
-     $          CALL locwrite(cl_writ(jf),dirunoff, imjm,
-     $          file_unit_field(jf), ierror) 
-            IF (jf.eq.18)
-     $          CALL locwrite(cl_writ(jf),rivrunoff, imjm,
-     $          file_unit_field(jf), ierror) 
-            IF (jf.eq.19)
-     $          CALL locwrite(cl_writ(jf),calving, imjm,
-     $          file_unit_field(jf), ierror) 
-cxxx            IF (jf.eq.13)
-cxxx     $          CALL locwrite(cl_writ(jf),tauxu, imjm,
-cxxx     $          file_unit_field(jf),ierror) 
-cxxx            IF (jf.eq.1')
-cxxx     $          CALL locwrite(cl_writ(jf),tauxv, imjm,
-cxxx     $          file_unit_field(jf),ierror) 
-cxxx            IF (jf.eq.15)
-cxxx     $          CALL locwrite(cl_writ(jf),tauyv, imjm,
-cxxx     $          file_unit_field(jf),ierror) 
-cxxx            IF (jf.eq.16)
-cxxx     $          CALL locwrite(cl_writ(jf),tauyu, imjm,
-cxxx     $          file_unit_field(jf), ierror) 
-            IF (jf.eq.1)
-     $          CALL locwrite(cl_writ(jf),tauxx_u, imjm,
-     $          file_unit_field(jf),ierror)
-            IF (jf.eq.2)
-     $          CALL locwrite(cl_writ(jf),tauyy_u, imjm,
-     $          file_unit_field(jf),ierror)
-            IF (jf.eq.3)
-     $          CALL locwrite(cl_writ(jf),tauzz_u, imjm,
-     $          file_unit_field(jf),ierror)
-            IF (jf.eq.4)
-     $          CALL locwrite(cl_writ(jf),tauxx_v, imjm,
-     $          file_unit_field(jf),ierror)
-            IF (jf.eq.5)
-     $          CALL locwrite(cl_writ(jf),tauyy_v, imjm,
-     $          file_unit_field(jf),ierror)
-            IF (jf.eq.6)
-     $          CALL locwrite(cl_writ(jf),tauzz_v, imjm,
-     $          file_unit_field(jf),ierror)
-c -- LOOP
-            IF (jf.eq.7)
-     $         CALL locwrite(cl_writ(jf),windsp, imjm,
-     $         file_unit_field(jf),ierror)
-c -- LOOP
-
-          END DO 
-C
-C         -simulate a FLUSH
-C
-          DO jn=1, max_file 
-            CLOSE (file_unit(jn))
-          END DO 
-C
-C
-          IF(cchan.eq.'CLIM') THEN 
-C
-C         -inform PVM daemon that message exchange is finished
-C
-              CALL CLIM_Quit (CLIM_ContPvm, info)
-              IF (info .NE. CLIM_Ok) THEN
-                  WRITE (6, *) 
-     $                'An error occured while leaving CLIM. Error = ',
-     $                info
-              ENDIF
-          END IF 
-          RETURN    
-      END IF 
-C
-      IF(cchan.eq.'CLIM') THEN 
-C
-C     -Give atmospheric fields to Oasis
-C 
-          DO jn=1, jpflda2o1 + jpflda2o2
-C            
-          IF (jn.eq.8) CALL CLIM_Export(cl_writ(jn), kt, fsolice, info)
-          IF (jn.eq.9) CALL CLIM_Export(cl_writ(jn), kt, fsolwat, info)
-         IF (jn.eq.10) CALL CLIM_Export(cl_writ(jn), kt, fnsolice, info)
-         IF (jn.eq.11) CALL CLIM_Export(cl_writ(jn), kt, fnsolwat, info)
-         IF (jn.eq.12) CALL CLIM_Export(cl_writ(jn), kt, fnsicedt, info)
-c          IF (jn.eq.6) CALL CLIM_Export(cl_writ(jn), kt, ictemp, info)
-          IF (jn.eq.13) CALL CLIM_Export(cl_writ(jn), kt, evice, info)
-          IF (jn.eq.14) CALL CLIM_Export(cl_writ(jn), kt, evwat, info)
-          IF (jn.eq.15) CALL CLIM_Export(cl_writ(jn), kt, lpre, info)
-          IF (jn.eq.16) CALL CLIM_Export(cl_writ(jn), kt, spre, info)
-          IF (jn.eq.17) CALL CLIM_Export(cl_writ(jn),kt,dirunoff, info)
-          IF (jn.eq.18) CALL CLIM_Export(cl_writ(jn),kt,rivrunoff,info)
-          IF (jn.eq.19) CALL CLIM_Export(cl_writ(jn),kt,calving,info)
-cxxx          IF (jn.eq.13) CALL CLIM_Export(cl_writ(jn), kt, tauxu, info)
-cxxx          IF (jn.eq.14) CALL CLIM_Export(cl_writ(jn), kt, tauxv, info)
-cxxx          IF (jn.eq.15) CALL CLIM_Export(cl_writ(jn), kt, tauyv, info)
-cxxx          IF (jn.eq.16) CALL CLIM_Export(cl_writ(jn), kt, tauyu, info)
-          IF (jn.eq.1) CALL CLIM_Export(cl_writ(jn), kt, tauxx_u, info)
-          IF (jn.eq.2) CALL CLIM_Export(cl_writ(jn), kt, tauyy_u, info)
-          IF (jn.eq.3) CALL CLIM_Export(cl_writ(jn), kt, tauzz_u, info)
-          IF (jn.eq.4) CALL CLIM_Export(cl_writ(jn), kt, tauxx_v, info)
-          IF (jn.eq.5) CALL CLIM_Export(cl_writ(jn), kt, tauyy_v, info)
-          IF (jn.eq.6) CALL CLIM_Export(cl_writ(jn), kt, tauzz_v, info)
-c -- LOOP
-          IF (jn.eq.7) CALL CLIM_Export(cl_writ(jn), kt, windsp, info)
-c -- LOOP          
-            IF (info .NE. CLIM_Ok) THEN
-                WRITE (nuout,*) 'STEP : Pb giving ',cl_writ(jn), ':',jn
-                WRITE (nuout,*) ' at timestep = ', icstep,'kt = ',kt
-                WRITE (nuout,*) 'Clim error code is = ',info
-                CALL halte('STOP in intocpl ')
-            ENDIF
-          END DO 
-      ENDIF 
-C
-      RETURN
-      END
-
-      SUBROUTINE halte
-      print *, 'Attention dans oasis.F, halte est non defini'
-      RETURN
-      END
-
-      SUBROUTINE locread
-      print *, 'Attention dans oasis.F, locread est non defini'
-      RETURN
-      END
-
-      SUBROUTINE locwrite
-      print *, 'Attention dans oasis.F, locwrite est non defini'
-      RETURN
-      END
-
-      SUBROUTINE pipe_model_define
-      print*,'Attention dans oasis.F, pipe_model_define est non defini'
-      RETURN
-      END
-
-      SUBROUTINE pipe_model_stepi
-      print*,'Attention dans oasis.F, pipe_model_stepi est non defini'
-      RETURN
-      END
-
-      SUBROUTINE pipe_model_recv
-      print *, 'Attention dans oasis.F, pipe_model_recv est non defini'
-      RETURN
-      END
-
-      SUBROUTINE pipe_model_send
-      print *, 'Attention dans oasis.F, pipe_model_send est non defini'
-      RETURN
-      END
-
-      SUBROUTINE clim_stepi
-      print *, 'Attention dans oasis.F, clim_stepi est non defini'
-      RETURN
-      END
-
-      SUBROUTINE clim_start
-      print *, 'Attention dans oasis.F, clim_start est non defini'
-      RETURN
-      END
-
-      SUBROUTINE clim_import
-      print *, 'Attention dans oasis.F, clim_import est non defini'
-      RETURN
-      END
-
-      SUBROUTINE clim_export
-      print *, 'Attention dans oasis.F, clim_export est non defini'
-      RETURN
-      END
-
-      SUBROUTINE clim_init
-      print *, 'Attention dans oasis.F, clim_init est non defini'
-      RETURN
-      END
-
-      SUBROUTINE clim_define
-      print *, 'Attention dans oasis.F, clim_define est non defini'
-      RETURN
-      END
-
-      SUBROUTINE clim_quit
-      print *, 'Attention dans oasis.F, clim_quit est non defini'
-      RETURN
-      END
-
-      SUBROUTINE svipc_write
-      print *, 'Attention dans oasis.F, svipc_write est non defini'
-      RETURN
-      END
-
-      SUBROUTINE svipc_close
-      print *, 'Attention dans oasis.F, svipc_close est non defini'
-      RETURN
-      END
-
-      SUBROUTINE svipc_read
-      print *, 'Attention dans oasis.F, svipc_read est non defini'
-      RETURN
-      END
-
-      SUBROUTINE quitcpl
-      print *, 'Attention dans oasis.F, quitcpl est non defini'
-      RETURN
-      END
-
-      SUBROUTINE sipc_write_model
-      print *, 'Attention dans oasis.F, sipc_write_model est non defini'
-      RETURN
-      END
-
-      SUBROUTINE sipc_attach
-      print *, 'Attention dans oasis.F, sipc_attach est non defini'
-      RETURN
-      END
-
-      SUBROUTINE sipc_init_model
-      print *, 'Attention dans oasis.F, sipc_init_model est non defini'
-      RETURN
-      END
-
-      SUBROUTINE sipc_read_model
-      print *, 'Attention dans oasis.F, sipc_read_model est non defini'
-      RETURN
-      END
Index: LMDZ4/trunk/libf/phylmd/oasis.h
===================================================================
--- LMDZ4/trunk/libf/phylmd/oasis.h	(revision 781)
+++ 	(revision )
@@ -1,17 +1,0 @@
-!
-! $Header$
-!
-C
-C -- oasis.h   
-C    ******
-C@
-C@  Contents : choice for the OASIS version: clim or pipe
-C@  --------
-
-      logical ok_oasis
-      parameter(ok_oasis = .false.)
-
-      CHARACTER*8 cchan
-      PARAMETER ( cchan='CLIM' )
-C
-C     --- end of oasis.h
Index: LMDZ4/trunk/libf/phylmd/oasis.psmile
===================================================================
--- LMDZ4/trunk/libf/phylmd/oasis.psmile	(revision 781)
+++ 	(revision )
@@ -1,550 +1,0 @@
-!
-! $Header$
-!
-
-  MODULE oasis
-
-! Module contenant les routines pour l'initialisation du couplage, la
-! lecture et l'ecriture des champs venant/transmis au coupleur
-!
-
-  IMPLICIT none
-
-  PRIVATE
-  PUBLIC :: inicma, fromcpl, intocpl
-
-  INTERFACE inicma
-    module procedure inicma
-  END INTERFACE  
-
-#include "param_cou.h"
-
-   integer, dimension(jpfldo2a), save              :: in_var_id
-   integer, dimension(jpflda2o1+jpflda2o2), save  :: il_out_var_id
-   CHARACTER (len=8), dimension(jpmaxfld), public, save   :: cl_writ, cl_read
-   CHARACTER (len=8), dimension(jpmaxfld), save   :: cl_f_writ, cl_f_read
-
-  CONTAINS
-
-!****
-!
-!**** *INICMA*  - Initialize coupled mode communication for atmosphere
-!                 and exchange some initial information with Oasis
-!
-!     Rewrite to take the PRISM/psmile library into account
-!     LF 09/2003
-!
-!     Input:
-!     -----
-!        im, jm: size of grid passed between gcm and coupler
-!
-!     -----------------------------------------------------------
-!
-   SUBROUTINE inicma(im, jm)
-
-   use mod_prism_proto
-   use mod_prism_def_partition_proto
-   use dimphy
-   implicit none
-
-#include "param_cou.h"
-
-!
-! parameters
-!
-   integer                  :: im, jm
-!
-! local variables
-!
-! integers
-!
-   integer                                  :: comp_id
-   integer                                  :: ierror, il_commlocal
-   integer                                  :: il_part_id
-   integer, dimension(:), allocatable       :: ig_paral
-   integer, dimension(2)                    :: il_var_nodims
-   integer, dimension(4)                    :: il_var_actual_shape
-   integer                                  :: il_var_type
-   integer                                  :: nuout = 6
-   integer                                  :: jf
-! characters
-!
-   character (len = 6)        :: clmodnam
-   character (len = 20),save  :: modname = 'inicma'
-   character (len = 80)       :: abort_message 
-   
-!
-!     -----------------------------------------------------------
-!
-!*    1. Initializations
-!        ---------------
-!
-   WRITE(nuout,*) ' '
-   WRITE(nuout,*) ' '
-   WRITE(nuout,*) ' ROUTINE INICMA'
-   WRITE(nuout,*) ' **************'
-   WRITE(nuout,*) ' '
-   WRITE(nuout,*) ' '
-!
-!     Define the model name
-!
-   clmodnam = 'lmdz.x'       ! as in $NBMODEL in Cpl/Nam/namcouple.tmp
-!
-!
-! Here we go: psmile initialisation
-!
-    IF (is_sequential) THEN
-      call prism_init_comp_proto (comp_id, clmodnam, ierror)
-
-      IF (ierror .ne. PRISM_Ok) THEN
-         abort_message=' Probleme init dans prism_init_comp '
-         call abort_gcm(modname,abort_message,1)
-      ELSE
-         WRITE(nuout,*) 'inicma : init psmile ok '
-      ENDIF
-    ENDIF
-
-      call prism_get_localcomm_proto (il_commlocal, ierror)
-!
-! and domain decomposition
-!
-! monoproc case
-!
-   allocate(ig_paral(3))
-!ym   ig_paral(1) = 0
-!ym   ig_paral(2) = 0
-!ym   ig_paral(3) = im * jm
-   ig_paral(1) = 1    ! apple partition for //
-   ig_paral(2) = (jj_begin-1)*im+ii_begin-1
-   ig_paral(3) = (jj_end*im+ii_end)-(jj_begin*im+ii_begin)+1
-   if (mpi_rank==mpi_size-1) ig_paral(3)=ig_paral(3)+im-1
-   print *,mpi_rank,'ig_paral--->',ig_paral(2),ig_paral(3)
-   
-   ierror=PRISM_Ok
-   call prism_def_partition_proto (il_part_id, ig_paral, ierror)
-   deallocate(ig_paral)
-!
-   IF (ierror .ne. PRISM_Ok) THEN
-     abort_message=' Probleme dans prism_def_partition '
-     call abort_gcm(modname,abort_message,1)
-   ELSE
-     WRITE(nuout,*) 'inicma : decomposition domaine psmile ok '
-   ENDIF
-
-!
-! Field Declarations
-!
-!     Define symbolic name for fields exchanged from atmos to coupler,
-!         must be the same as (1) of the field  definition in namcouple:
-!
-      cl_writ(1)='COTAUXXU'
-      cl_writ(2)='COTAUYYU'
-      cl_writ(3)='COTAUZZU'
-      cl_writ(4)='COTAUXXV'
-      cl_writ(5)='COTAUYYV'
-      cl_writ(6)='COTAUZZV'
-! -- LOOP
-      cl_writ(7)='COWINDSP'
-! -- LOOP
-      cl_writ(8)='COSHFICE'
-      cl_writ(9)='COSHFOCE'
-      cl_writ(10)='CONSFICE'
-      cl_writ(11)='CONSFOCE'
-      cl_writ(12)='CODFLXDT'
-      cl_writ(13)='COTFSICE'
-      cl_writ(14)='COTFSOCE'
-      cl_writ(15)='COTOLPSU'
-      cl_writ(16)='COTOSPSU'
-      cl_writ(17)='CORUNCOA'
-      cl_writ(18)='CORIVFLU'
-      cl_writ(19)='COCALVIN'
-!
-!     Define symbolic name for fields exchanged from coupler to atmosphere,
-!         must be the same as (2) of the field  definition in namcouple:
-!
-   cl_read(1)='SISUTESW'
-   cl_read(2)='SIICECOV'
-   cl_read(3)='SIICEALW'
-   cl_read(4)='SIICTEMW'
-
-   il_var_nodims(1) = 2
-   il_var_nodims(2) = 1
-
-   il_var_actual_shape(1) = 1
-   il_var_actual_shape(2) = im
-   il_var_actual_shape(3) = 1
-   il_var_actual_shape(4) = jm
-   
-   il_var_type = PRISM_Real
-!
-! Oceanic Fields
-!
-   DO jf=1, jpfldo2a
-     call prism_def_var_proto(in_var_id(jf), cl_read(jf), il_part_id, &
-&               il_var_nodims, PRISM_In, il_var_actual_shape, il_var_type, &
-&               ierror)
-     IF (ierror .ne. PRISM_Ok) THEN
-        abort_message=' Probleme init dans prism_def_var_proto '
-        call abort_gcm(modname,abort_message,1)
-     ENDIF
-   END DO 
-!
-! Atmospheric Fields
-!
-   DO jf=1, jpflda2o1+jpflda2o2
-     call prism_def_var_proto(il_out_var_id(jf), cl_writ(jf), il_part_id, &
-&               il_var_nodims, PRISM_Out, il_var_actual_shape, il_var_type, &
-&               ierror)
-     IF (ierror .ne. PRISM_Ok) THEN
-        abort_message=' Probleme init dans prism_def_var_proto '
-        call abort_gcm(modname,abort_message,1)
-     ENDIF
-   END DO 
-!
-! End
-!
-   call prism_enddef_proto(ierror)
-   IF (ierror .ne. PRISM_Ok) THEN
-      abort_message=' Probleme init dans prism_ endef_proto'
-      call abort_gcm(modname,abort_message,1)
-   ELSE
-      WRITE(nuout,*) 'inicma : endef psmile ok '
-   ENDIF
-
-   END SUBROUTINE inicma
-
-   SUBROUTINE fromcpl(kt, im, jm, sst, gla, tice, albedo)
-! ======================================================================
-! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine reads the SST 
-! and Sea-Ice provided by the coupler. Adaptation to psmile library
-!======================================================================
-
-   use mod_prism_proto
-   use mod_prism_get_proto
-   USE dimphy
-   USE mod_phys_lmdz_para
-   IMPLICIT none
-
-!
-! parametres
-!
-   integer                 :: im, jm, kt
-   real, dimension(im*jm)   :: sst            ! sea-surface-temperature
-   real, dimension(im*jm)   :: gla     ! sea-ice
-   real, dimension(im*jm)   :: tice    ! temp glace
-   real, dimension(im*jm)   :: albedo  ! albedo glace
-!
-! local variables
-!
-   integer                 :: nuout  = 6             ! listing output unit
-   integer                 :: ierror
-   character (len = 20),save  :: modname = 'fromcpl'
-   character (len = 80)       :: abort_message 
-   integer :: istart,iend
-!
-#include "param_cou.h"
-!
-!
-   WRITE (nuout,*) ' '
-   WRITE (nuout,*) 'Fromcpl: Reading fields from CPL, kt=',kt
-   WRITE (nuout,*) ' '
-   CALL flush (nuout)
-
-   istart=ii_begin
-   if (is_south_pole) then
-    iend=(jj_end-jj_begin)*im+im
-   else
-    iend=(jj_end-jj_begin)*im+ii_end
-   endif
-   
-   call prism_get_proto(in_var_id(1), kt, sst(istart:iend), ierror)
-   IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Recvd .and. &
- &     ierror.ne.PRISM_FromRest &
- &     .and. ierror.ne.PRISM_Input .and. ierror.ne.PRISM_RecvOut &
- &     .and. ierror.ne.PRISM_FromRestOut) THEN
-     WRITE (nuout,*)  cl_read(1), kt   
-     abort_message=' Probleme dans prism_get_proto '
-     call abort_gcm(modname,abort_message,1)
-   endif
-   call prism_get_proto(in_var_id(2), kt, gla(istart:iend), ierror)
-   IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Recvd .and. &
- &     ierror.ne.PRISM_FromRest &
- &     .and. ierror.ne.PRISM_Input .and. ierror.ne.PRISM_RecvOut &
- &     .and. ierror.ne.PRISM_FromRestOut) THEN
-     WRITE (nuout,*)  cl_read(2), kt   
-     abort_message=' Probleme dans prism_get_proto '
-     call abort_gcm(modname,abort_message,1)
-   endif
-   call prism_get_proto(in_var_id(3), kt, albedo(istart:iend), ierror)
-   IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Recvd .and. &
- &     ierror.ne.PRISM_FromRest &
- &     .and. ierror.ne.PRISM_Input .and. ierror.ne.PRISM_RecvOut &
- &     .and. ierror.ne.PRISM_FromRestOut) THEN
-     WRITE (nuout,*)  cl_read(3), kt   
-     abort_message=' Probleme dans prism_get_proto '
-     call abort_gcm(modname,abort_message,1)
-   endif
-   call prism_get_proto(in_var_id(4), kt, tice(istart:iend), ierror)
-   IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Recvd .and. &
- &     ierror.ne.PRISM_FromRest &
- &     .and. ierror.ne.PRISM_Input .and. ierror.ne.PRISM_RecvOut &
- &     .and. ierror.ne.PRISM_FromRestOut) THEN
-     WRITE (nuout,*)  cl_read(4), kt   
-     abort_message=' Probleme dans prism_get_proto '
-     call abort_gcm(modname,abort_message,1)
-   endif
-
-!
-   RETURN
-   END SUBROUTINE fromcpl
-
-   SUBROUTINE intocpl(kt, im, jm, fsolice, fsolwat, fnsolice, fnsolwat, &
- &    fnsicedt, evice, evwat, lpre, spre, dirunoff, rivrunoff, & 
- &    calving, tauxx_u, tauyy_u, tauzz_u, tauxx_v, tauyy_v, tauzz_v, &
-! -- LOOP
- &    windsp,                                                       &
-! -- LOOP
- &    last) 
-! ======================================================================
-! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine provides the 
-! atmospheric coupling fields to the coupler with the psmile library.
-! IF last time step, writes output fields to binary files.
-! ======================================================================
-
-   use mod_prism_proto
-   use mod_prism_put_proto
-   USE dimphy
-   USE mod_phys_lmdz_para
-   use write_field_phy
-   IMPLICIT NONE
-
-! 
-! parametres
-!
-   integer               :: kt, im, jm
-   real, dimension(im* jm) :: fsolice, fsolwat, fnsolwat, fnsolice
-   real, dimension(im* jm) :: fnsicedt, evice, evwat, lpre, spre
-   real, dimension(im* jm) :: dirunoff, rivrunoff, calving
-   real, dimension(im* jm) :: tauxx_u, tauxx_v, tauyy_u
-   real, dimension(im* jm) :: tauyy_v, tauzz_u, tauzz_v
-   real, dimension(im*jm) :: windsp
-   logical               :: last
-   logical :: checkout=.FALSE.
-   integer :: istart,iend
-   integer :: wstart,wend
-!
-! local
-!
-   integer, parameter    :: nuout = 6 
-   integer               :: ierror
-   character (len = 20),save  :: modname = 'intocpl'
-   character (len = 80)       :: abort_message 
-!
-!
-      WRITE(nuout,*) ' '
-      WRITE(nuout,*) 'Intocpl: sending fields to CPL, kt= ', kt
-      WRITE(nuout,*) 'last  ', last
-      WRITE(nuout,*)
-
-   istart=ii_begin
-   if (is_south_pole) then
-    iend=(jj_end-jj_begin)*im+im
-   else
-    iend=(jj_end-jj_begin)*im+ii_end
-   endif
-
-   IF (checkout) THEN   
-     wstart=istart
-     wend=iend
-     IF (is_north_pole) wstart=istart+im-1
-     IF (is_south_pole) wend=iend-im+1
-   
-     CALL writeField_phy("fsolice",fsolice(wstart:wend),1)
-     CALL writeField_phy("fsolwat",fsolwat(wstart:wend),1)
-     CALL writeField_phy("fnsolice",fnsolice(wstart:wend),1)
-     CALL writeField_phy("fnsolwat",fnsolwat(wstart:wend),1)
-     CALL writeField_phy("fnsicedt",fnsicedt(wstart:wend),1)
-     CALL writeField_phy("evice",evice(wstart:wend),1)
-     CALL writeField_phy("evwat",evwat(wstart:wend),1)
-     CALL writeField_phy("lpre",lpre(wstart:wend),1)
-     CALL writeField_phy("spre",spre(wstart:wend),1)
-     CALL writeField_phy("dirunoff",dirunoff(wstart:wend),1)
-     CALL writeField_phy("rivrunoff",rivrunoff(wstart:wend),1)
-     CALL writeField_phy("calving",calving(wstart:wend),1)
-     CALL writeField_phy("tauxx_u",tauxx_u(wstart:wend),1)
-     CALL writeField_phy("tauyy_u",tauyy_u(wstart:wend),1)
-     CALL writeField_phy("tauzz_u",tauzz_u(wstart:wend),1)
-     CALL writeField_phy("tauxx_v",tauxx_v(wstart:wend),1)
-     CALL writeField_phy("tauyy_v",tauyy_v(wstart:wend),1)
-     CALL writeField_phy("tauzz_v",tauzz_v(wstart:wend),1)
-     CALL writeField_phy("windsp",windsp(wstart:wend),1)
-   ENDIF
-   
-   call prism_put_proto(il_out_var_id(8), kt, fsolice(istart:iend), ierror)
-   IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
- &     .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
- &     ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN
-     WRITE (nuout,*)  cl_writ(8), kt   
-     abort_message=' Probleme dans prism_put_proto '
-     call abort_gcm(modname,abort_message,1)
-   endif
-   call prism_put_proto(il_out_var_id(9), kt, fsolwat(istart:iend), ierror)
-   IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
- &     .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
- &     ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN
-     WRITE (nuout,*)  cl_writ(9), kt   
-     abort_message=' Probleme dans prism_put_proto '
-     call abort_gcm(modname,abort_message,1)
-   endif
-   call prism_put_proto(il_out_var_id(10), kt, fnsolice(istart:iend), ierror)
-   IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
- &     .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
- &     ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN
-     WRITE (nuout,*)  cl_writ(10), kt   
-     abort_message=' Probleme dans prism_put_proto '
-     call abort_gcm(modname,abort_message,1)
-   endif
-   call prism_put_proto(il_out_var_id(11), kt, fnsolwat(istart:iend), ierror)
-   IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
- &     .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
- &     ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN
-     WRITE (nuout,*)  cl_writ(11), kt   
-     abort_message=' Probleme dans prism_put_proto '
-     call abort_gcm(modname,abort_message,1)
-   endif
-   call prism_put_proto(il_out_var_id(12), kt, fnsicedt(istart:iend), ierror)
-   IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
- &     .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
- &     ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN
-     WRITE (nuout,*)  cl_writ(12), kt   
-     abort_message=' Probleme dans prism_put_proto '
-     call abort_gcm(modname,abort_message,1)
-   endif
-   call prism_put_proto(il_out_var_id(13), kt, evice(istart:iend), ierror)
-   IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
- &     .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
- &     ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN
-     WRITE (nuout,*)  cl_writ(13), kt   
-     abort_message=' Probleme dans prism_put_proto '
-     call abort_gcm(modname,abort_message,1)
-   endif
-   call prism_put_proto(il_out_var_id(14), kt, evwat(istart:iend), ierror)
-   IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
- &     .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
- &     ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN
-     WRITE (nuout,*)  cl_writ(14), kt   
-     abort_message=' Probleme dans prism_put_proto '
-     call abort_gcm(modname,abort_message,1)
-   endif
-   call prism_put_proto(il_out_var_id(15), kt, lpre(istart:iend), ierror)
-   IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
- &     .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
- &     ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN
-     WRITE (nuout,*)  cl_writ(15), kt   
-     abort_message=' Probleme dans prism_put_proto '
-     call abort_gcm(modname,abort_message,1)
-   endif
-   call prism_put_proto(il_out_var_id(16), kt, spre(istart:iend), ierror)
-   IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
- &     .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
- &     ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN
-     WRITE (nuout,*)  cl_writ(16), kt   
-     abort_message=' Probleme dans prism_put_proto '
-     call abort_gcm(modname,abort_message,1)
-   endif
-   call prism_put_proto(il_out_var_id(17), kt, dirunoff(istart:iend), ierror)
-   IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
- &     .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
- &     ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN
-     WRITE (nuout,*)  cl_writ(17), kt   
-     abort_message=' Probleme dans prism_put_proto '
-     call abort_gcm(modname,abort_message,1)
-   endif
-   call prism_put_proto(il_out_var_id(18), kt, rivrunoff(istart:iend), ierror)
-   IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
- &     .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
- &     ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN
-     WRITE (nuout,*)  cl_writ(18), kt   
-     abort_message=' Probleme dans prism_put_proto '
-     call abort_gcm(modname,abort_message,1)
-   endif
-   call prism_put_proto(il_out_var_id(19), kt, calving(istart:iend), ierror)
-   IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
- &     .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
- &     ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN
-     WRITE (nuout,*)  cl_writ(19), kt   
-     abort_message=' Probleme dans prism_put_proto '
-     call abort_gcm(modname,abort_message,1)
-   endif
-   call prism_put_proto(il_out_var_id(1), kt, tauxx_u(istart:iend), ierror)
-   IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
- &     .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
- &     ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN
-     WRITE (nuout,*)  cl_writ(1), kt   
-     abort_message=' Probleme dans prism_put_proto '
-     call abort_gcm(modname,abort_message,1)
-   endif
-   call prism_put_proto(il_out_var_id(2), kt, tauyy_u(istart:iend), ierror)
-   IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
- &     .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
- &     ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN
-     WRITE (nuout,*)  cl_writ(2), kt   
-     abort_message=' Probleme dans prism_put_proto '
-     call abort_gcm(modname,abort_message,1)
-   endif
-   call prism_put_proto(il_out_var_id(3), kt, tauzz_u(istart:iend), ierror)
-   IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
- &     .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
- &     ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN
-     WRITE (nuout,*)  cl_writ(3), kt   
-     abort_message=' Probleme dans prism_put_proto '
-     call abort_gcm(modname,abort_message,1)
-   endif
-   call prism_put_proto(il_out_var_id(4), kt, tauxx_v(istart:iend), ierror)
-   IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
- &     .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
- &     ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN
-     WRITE (nuout,*)  cl_writ(4), kt   
-     abort_message=' Probleme dans prism_put_proto '
-     call abort_gcm(modname,abort_message,1)
-   endif
-   call prism_put_proto(il_out_var_id(5), kt, tauyy_v(istart:iend), ierror)
-   IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
- &     .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
- &     ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN
-     WRITE (nuout,*)  cl_writ(5), kt   
-     abort_message=' Probleme dans prism_put_proto '
-     call abort_gcm(modname,abort_message,1)
-   endif
-   call prism_put_proto(il_out_var_id(6), kt, tauzz_v(istart:iend), ierror)
-   IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
- &     .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
- &     ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN
-     WRITE (nuout,*)  cl_writ(6), kt   
-     abort_message=' Probleme dans prism_put_proto '
-     call abort_gcm(modname,abort_message,1)
-   endif
-   call prism_put_proto(il_out_var_id(7), kt, windsp(istart:iend), ierror)
-   IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
- &     .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
- &     ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN
-     WRITE (nuout,*)  cl_writ(7), kt   
-     abort_message=' Probleme dans prism_put_proto '
-     call abort_gcm(modname,abort_message,1)
-   endif
-
-   if (last) then
-     IF (is_sequential) THEN 
-       call prism_terminate_proto(ierror)
-         IF (ierror .ne. PRISM_Ok) THEN
-         abort_message=' Probleme dans prism_terminate_proto '
-         call abort_gcm(modname,abort_message,1)
-       endif
-     ENDIF
-   endif
-
-
-   RETURN
-   END SUBROUTINE intocpl
-
-   END MODULE oasis
Index: LMDZ4/trunk/libf/phylmd/oasis.true
===================================================================
--- LMDZ4/trunk/libf/phylmd/oasis.true	(revision 781)
+++ 	(revision )
@@ -1,644 +1,0 @@
-!
-! $Header$
-!
-C****
-C
-C**** *INICMA*  - Initialize coupled mode communication for atmosphere
-C                 and exchange some initial information with Oasis
-C
-C     Input:
-C     -----
-C       KASTP  : total number of timesteps in atmospheric model
-C       KEXCH  : frequency of exchange (in time steps)
-C       KSTEP  : length of timestep (in seconds)
-C
-C     -----------------------------------------------------------
-C
-      SUBROUTINE inicma(kastp,kexch,kstep,imjm)
-c
-c     INCLUDE "param.h"
-c
-      INTEGER kastp, kexch, kstep,imjm,klon
-      INTEGER iparal(3)
-      INTEGER ifcpl, idt, info, imxtag, istep, jf
-
-c -- LOOP
-c 
-#include "dimensions.h"
-      INTEGER jjmp1
-      PARAMETER (jjmp1=jjm+1-1/jjm)
-#include "dimphy.h"
-c      REAL zu10m(klon), zv10m(klon)
-       REAL zwindsp(klon)
-c
-c -- LOOP
-c
-#include "param_cou.h"
-#include "inc_cpl.h"
-      CHARACTER*3 cljobnam      ! experiment name
-      CHARACTER*6 clmodnam      ! model name
-c     EM: not used by Oasis2.4
-CEM      CHARACTER*6 clbid(2)      ! for CLIM_Init call (not used)
-CEM                                ! must be dimensioned by the number of models
-CEM      INTEGER nbid(2)           ! for CLIM_Init call (not used)
-CEM                                ! must be dimensioned by the number of models
-      CHARACTER*5 cloasis       ! coupler name (Oasis)
-      INTEGER imess(4)
-      INTEGER getpid            ! system functions
-      INTEGER nuout
-CEM      LOGICAL llmodel
-      PARAMETER (nuout = 6)
-c
-#include "clim.h"
-#include "mpiclim.h"
-c
-#include "oasis.h"      
-                        ! contains the name of communication technique. Here
-                        ! cchan=CLIM only is possible.
-c			! ctype=MPI2
-c
-C     -----------------------------------------------------------
-C
-C*    1. Initializations
-C        ---------------
-C
-      WRITE(nuout,*) ' '
-      WRITE(nuout,*) ' '
-      WRITE(nuout,*) ' ROUTINE INICMA'
-      WRITE(nuout,*) ' **************'
-      WRITE(nuout,*) ' '
-      WRITE(nuout,*) ' '
-c
-c     Define the model name
-c
-      clmodnam = 'lmdz.x'       ! as in $NBMODEL in Cpl/Nam/namcouple.tmp
-c
-c     Define the coupler name
-c
-      cloasis = 'Oasis'        !  always 'Oasis' as in the coupler
-c
-c
-c     Define symbolic name for fields exchanged from atmos to coupler,
-c         must be the same as (1) of the field  definition in namcouple:
-c
-      cl_writ(8)='COSHFICE'
-      cl_writ(9)='COSHFOCE'
-      cl_writ(10)='CONSFICE'
-      cl_writ(11)='CONSFOCE'
-      cl_writ(12)='CODFLXDT'
-c      cl_writ(6)='COICTEMP'
-      cl_writ(13)='COTFSICE'
-      cl_writ(14)='COTFSOCE'
-      cl_writ(15)='COTOLPSU'
-      cl_writ(16)='COTOSPSU'
-      cl_writ(17)='CORUNCOA'
-      cl_writ(18)='CORIVFLU'
-      cl_writ(19)='COCALVIN'
-c$$$      cl_writ(13)='COZOTAUX'
-c$$$      cl_writ(14)='COZOTAUV'
-c$$$      cl_writ(15)='COMETAUY'
-c$$$      cl_writ(16)='COMETAUU'
-      cl_writ(1)='COTAUXXU'
-      cl_writ(2)='COTAUYYU'
-      cl_writ(3)='COTAUZZU'
-      cl_writ(4)='COTAUXXV'
-      cl_writ(5)='COTAUYYV'
-      cl_writ(6)='COTAUZZV'
-c -- LOOP
-      cl_writ(7)='COWINDSP'
-c -- LOOP
-c
-c     Define files name for fields exchanged from atmos to coupler,
-c         must be the same as (6) of the field  definition in namcouple:
-c
-      cl_f_writ(1)='flxatmos'
-      cl_f_writ(2)='flxatmos'
-      cl_f_writ(3)='flxatmos'
-      cl_f_writ(4)='flxatmos'
-      cl_f_writ(5)='flxatmos'
-      cl_f_writ(6)='flxatmos'
-      cl_f_writ(7)='flxatmos'
-      cl_f_writ(8)='flxatmos'
-      cl_f_writ(9)='flxatmos'
-      cl_f_writ(10)='flxatmos'
-      cl_f_writ(11)='flxatmos'
-      cl_f_writ(12)='flxatmos'
-      cl_f_writ(13)='flxatmos'
-      cl_f_writ(14)='flxatmos'
-      cl_f_writ(15)='flxatmos'
-      cl_f_writ(16)='flxatmos'
-      cl_f_writ(17)='flxatmos'
-      cl_f_writ(18)='flxatmos'
-c -- LOOP
-      cl_f_writ(19)='flxatmos'
-c -- LOOP
-
-c
-c
-c     Define symbolic name for fields exchanged from coupler to atmosphere,
-c         must be the same as (2) of the field  definition in namcouple:
-c
-      cl_read(1)='SISUTESW'
-      cl_read(2)='SIICECOV'
-      cl_read(3)='SIICEALW'
-      cl_read(4)='SIICTEMW'
-c
-c     Define files names for fields exchanged from coupler to atmosphere,
-c         must be the same as (7) of the field  definition in namcouple:
-c
-      cl_f_read(1)='sstatmos'
-      cl_f_read(2)='sstatmos'
-      cl_f_read(3)='sstatmos'
-      cl_f_read(4)='sstatmos'
-c
-c
-c     Define the number of processors involved in the coupling for
-c     Oasis (=1) and each model (as last two INTEGER on $CHATYPE line
-c     in the namcouple); they will be stored in a COMMON in mpiclim.h
-c     (used for CLIM/MPI2 only)
-      mpi_nproc(0)=1
-      mpi_nproc(1)=1
-      mpi_nproc(2)=1 
-c
-c     Define infos to be sent initially to oasis
-c
-      imess(1) = kastp      ! total number of timesteps in atmospheric model
-      imess(2) = kexch      ! period of exchange (in time steps)
-      imess(3) = kstep      ! length of atmospheric timestep (in seconds)
-      imess(4) = getpid()   ! PID of atmospheric model
-c
-c     Initialization and exchange of initial info in the CLIM technique
-c
-      IF (cchan.eq.'CLIM') THEN
-c
-c     Define the experiment name :
-c
-          cljobnam = 'CLI'      ! as $JOBNAM in namcouple
-c
-c         Start the coupling 
-c         (see lib/clim/src/CLIM_Init for the definition of input parameters)
-c
-cEM          clbid(1)='      '
-cEM          clbid(2)='      '
-cEM          nbid(1)=0
-cEM          nbid(2)=0
-CEM          llmodel=.true.
-c
-c         Define the number of processors used by each model as in
-c         $CHATYPE line of namcouple (used for CLIM/MPI2 only) 
-          mpi_totproc(1)=1
-          mpi_totproc(2)=1
-c
-c         Define names of each model as in $NBMODEL line of namcouple
-c         (used for CLIM/MPI2 only)        
-          cmpi_modnam(1)='lmdz.x'
-          cmpi_modnam(2)='opa.xx'
-c         Start the coupling 
-c
-          CALL CLIM_Init ( cljobnam, clmodnam, 3, 7,
-     *                 kastp, kexch, kstep,
-     *                 5, 3600, 3600, info )
-c
-          IF (info.ne.CLIM_Ok) THEN
-              WRITE ( nuout, *) ' inicma : pb init clim '
-              WRITE ( nuout, *) ' error code is = ', info
-              CALL halte('STOP in inicma')
-            ELSE
-              WRITE(nuout,*) 'inicma : init clim ok '
-          ENDIF
-c
-c         For each coupling field, association of a port to its symbolic name
-c
-c         -Define the parallel decomposition associated to the port of each
-c          field; here no decomposition for all ports.
-          iparal ( clim_strategy ) = clim_serial 
-          iparal ( clim_length   ) = imjm
-          iparal ( clim_offset   ) = 0
-c
-c         -Loop on total number of coupler-to-atmosphere fields
-c         (see lib/clim/src/CLIM_Define for the definition of input parameters)
-          DO jf=1, jpfldo2a
-            CALL CLIM_Define (cl_read(jf), clim_in , clim_double, iparal
-     $          , info )  
-            WRITE(nuout,*) 'inicma : clim define done for ',jf
-     $          ,cl_read(jf) 
-          END DO 
-c
-c         -Loop on total number of atmosphere-to-coupler fields 
-c         (see lib/clim/src/CLIM_Define for the definition of input parameters)
-          DO jf=1, jpflda2o1+jpflda2o2
-            CALL CLIM_Define (cl_writ(jf), clim_out , clim_double,
-     $          iparal, info )   
-            WRITE(nuout,*) 'inicma : clim define done for ',jf
-     $          ,cl_writ(jf) 
-          END DO 
-c
-          WRITE(nuout,*) 'inicma : clim_define ok '
-c
-c         -Join a pvm group, wait for other programs and broadcast usefull 
-c          informations to Oasis and to the ocean (see lib/clim/src/CLIM_Start)
-          CALL CLIM_Start ( imxtag, info )
-          IF (info.ne.clim_ok) THEN
-              WRITE ( nuout, *) 'inicma : pb start clim '
-              WRITE ( nuout, *) ' error code is = ', info
-              CALL halte('stop in inicma')
-            ELSE
-              WRITE ( nuout, *)  'inicma : start clim ok '
-          ENDIF
-c
-c         -Get initial information from Oasis
-c          (see lib/clim/src/CLIM_Stepi)
-          CALL CLIM_Stepi (cloasis, istep, ifcpl, idt, info)
-          IF (info .NE. clim_ok) THEN
-              WRITE ( UNIT = nuout, FMT = *)
-     $            ' warning : problem in getting step info ',
-     $            'from oasis '
-              WRITE (UNIT = nuout, FMT = *)
-     $            ' =======   error code number = ', info
-            ELSE
-              WRITE (UNIT = nuout, FMT = *)
-     $            ' got step information from oasis '
-          ENDIF
-          WRITE ( nuout, *) ' number of tstep in oasis ', istep
-          WRITE ( nuout, *) ' exchange frequency in oasis ', ifcpl
-          WRITE ( nuout, *) ' length of tstep in oasis ', idt
-      ENDIF 
-
-      RETURN
-      END
-
-c $Id$
-      SUBROUTINE fromcpl(kt, imjm, sst, gla, tice, albedo)
-c ======================================================================
-c S. Valcke (02/99) adapted From L.Z.X Li: this subroutine reads the SST 
-c and Sea-Ice provided by the coupler with the CLIM (PVM exchange messages)
-c technique. 
-c======================================================================
-      IMPLICIT none
-      INTEGER imjm, kt
-      REAL sst(imjm)          ! sea-surface-temperature
-      REAL gla(imjm)          ! sea-ice
-      REAL tice(imjm)          ! temp glace
-      REAL albedo(imjm)          ! albedo glace
-c
-      INTEGER nuout             ! listing output unit
-      PARAMETER (nuout=6)
-c
-      INTEGER nuread, ios, iflag, icpliter
-      INTEGER info, jf
-c
-#include "clim.h"
-c
-#include "oasis.h"
-#include "param_cou.h"
-c
-#include "inc_cpl.h"
-c
-c
-      WRITE (nuout,*) ' '
-      WRITE (nuout,*) 'Fromcpl: Reading fields from CPL, kt=',kt
-      WRITE (nuout,*) ' '
-      CALL flush (nuout)
-
-
-      IF (cchan.eq.'CLIM') THEN 
-
-c
-c     -Get interpolated oceanic fields from Oasis
-c
-          DO jf=1,jpfldo2a
-            IF (jf.eq.1) CALL CLIM_Import (cl_read(jf) , kt, sst, info)
-            IF (jf.eq.2) CALL CLIM_Import (cl_read(jf) , kt, gla, info)
-            IF (jf.eq.3) CALL CLIM_Import (cl_read(jf), kt,albedo, info)
-            IF (jf.eq.4) CALL CLIM_Import (cl_read(jf) , kt, tice, info)
-            IF ( info .NE. CLIM_Ok) THEN
-                WRITE(nuout,*)'Pb in reading ', cl_read(jf), jf
-                WRITE(nuout,*)'Couplage kt is = ',kt
-                WRITE(nuout,*)'CLIM error code is = ', info
-                CALL halte('STOP in fromcpl.F')
-            ENDIF
-          END DO 
-
-      ENDIF 
-c
-      RETURN
-      END
-
-c $Id$
-      SUBROUTINE intocpl(kt, imjm, fsolice, fsolwat, fnsolice, fnsolwat,
-     $    fnsicedt, evice, evwat, lpre, spre, dirunoff, rivrunoff, 
-     $    calving, tauxx_u, tauyy_u, tauzz_u, tauxx_v, tauyy_v, tauzz_v,
-c -- LOOP
-     $    windsp, last)
-c -- LOOP 
-c ======================================================================
-c S. Valcke (02/99) adapted From L.Z.X Li: this subroutine provides the 
-c atmospheric coupling fields to the coupler with the CLIM (PVM exchange 
-c messages) technique. 
-c IF last time step, writes output fields to binary files.
-c ======================================================================
-      IMPLICIT NONE
-c -- LOOP
-c 
-#include "dimensions.h"
-      INTEGER jjmp1
-      PARAMETER (jjmp1=jjm+1-1/jjm)
-#include "dimphy.h"
-c      REAL zu10m(klon), zv10m(klon)
-       REAL zwindsp(klon)
-c
-c -- LOOP
-c
-
-      INTEGER kt, imjm
-c
-      REAL fsolice(imjm)
-      REAL fsolwat(imjm)
-      REAL fnsolwat(imjm)
-      REAL fnsolice(imjm) 
-      REAL fnsicedt(imjm) 
-      REAL evice(imjm)
-      REAL evwat(imjm)
-      REAL lpre(imjm)
-      REAL spre(imjm)
-      REAL dirunoff(imjm)
-      REAL rivrunoff(imjm)
-      REAL calving(imjm)
-c$$$      REAL tauxu(imjm)
-c$$$      REAL tauxv(imjm)
-c$$$      REAL tauyu(imjm)
-c$$$      REAL tauyv(imjm)
-      REAL tauxx_u(imjm)
-      REAL tauxx_v(imjm)
-      REAL tauyy_u(imjm)
-      REAL tauyy_v(imjm)
-      REAL tauzz_u(imjm)
-      REAL tauzz_v(imjm)
-c -- LOOP
-       REAL windsp(imjm)
-c -- LOOP
-      LOGICAL last
-c
-      INTEGER nuout
-      PARAMETER (nuout = 6)
-c
-#include "clim.h"
-#include "param_cou.h"
-#include "inc_cpl.h"
-c
-      CHARACTER*8 file_name(jpmaxfld)
-      INTEGER max_file
-      INTEGER file_unit_max, file_unit(jpmaxfld),
-     $    file_unit_field(jpmaxfld) 
-
-      INTEGER icstep, info, jn, jf, ierror
-      LOGICAL trouve
-c
-#include "oasis.h"
-c
-      icstep=kt 
-c
-      WRITE(nuout,*) ' '
-      WRITE(nuout,*) 'Intocpl: sending fields to CPL, kt= ', kt
-      WRITE(nuout,*) 'last  ', last
-      WRITE(nuout,*)
-
-      IF (last) THEN 
-c
-c     -WRITE fields to binary files for coupler restart at last time step
-c
-c         -initialisation and files opening
-c
-          max_file=1
-          file_unit_max=99
-c         -keeps first file name
-          file_name(max_file)=cl_f_writ(max_file)
-c         -keeps first file unit
-          file_unit(max_file)=file_unit_max
-c         -decrements file unit maximum
-          file_unit_max=file_unit_max-1
-c         -keeps file unit for field
-          file_unit_field(1)=file_unit(max_file)
-c
-c         -different files names counter
-c
-          DO jf= 2, jpflda2o1 + jpflda2o2
-            trouve=.false.
-            DO jn= 1, max_file
-              IF (.not.trouve) THEN
-                  IF (cl_f_writ(jf).EQ.file_name(jn)) THEN
-c                 -keep file unit for field
-                      file_unit_field(jf)=file_unit(jn)
-                      trouve=.true.
-                  END IF 
-              END IF 
-            END DO 
-            IF (.not.trouve) then
-c           -increment the number of different files
-                max_file=max_file+1
-c           -keep file name
-                file_name(max_file)=cl_f_writ(jf)
-c           -keep file unit for file
-                file_unit(max_file)=file_unit_max
-c           -keep file unit for field
-                file_unit_field(jf)=file_unit(max_file)
-c           -decrement unit maximum number from 99 to 98, ...
-                file_unit_max=file_unit_max-1
-            END IF 
-          END DO 
-c          
-          DO jn=1, max_file 
-            OPEN (file_unit(jn), FILE=file_name(jn), FORM='UNFORMATTED')
-            WRITE(*,*) 'Opening FILE ', file_unit(jn), ' '
-     $          , file_name(jn) 
-            REWIND(file_unit(jn))
-          END DO
-c 
-c         WRITE fields to files          
-          DO jf=1, jpflda2o1 + jpflda2o2
-            IF (jf.eq.8)
-     $          CALL locwrite(cl_writ(jf),fsolice, imjm,
-     $          file_unit_field(jf), ierror) 
-            IF (jf.eq.9)
-     $          CALL locwrite(cl_writ(jf),fsolwat, imjm,
-     $          file_unit_field(jf), ierror) 
-            IF (jf.eq.10)
-     $          CALL locwrite(cl_writ(jf),fnsolice, imjm,
-     $          file_unit_field(jf), ierror) 
-            IF (jf.eq.11)
-     $          CALL locwrite(cl_writ(jf),fnsolwat, imjm,
-     $          file_unit_field(jf), ierror) 
-            IF (jf.eq.12)
-     $          CALL locwrite(cl_writ(jf),fnsicedt, imjm,
-     $          file_unit_field(jf), ierror) 
-c            IF (jf.eq.13)
-c     $          CALL locwrite(cl_writ(jf),ictemp, imjm,
-c     $          file_unit_field(jf), ierror) 
-            IF (jf.eq.13)
-     $          CALL locwrite(cl_writ(jf),evice, imjm,
-     $          file_unit_field(jf), ierror) 
-            IF (jf.eq.14)
-     $          CALL locwrite(cl_writ(jf),evwat, imjm,
-     $          file_unit_field(jf), ierror) 
-            IF (jf.eq.15)
-     $          CALL locwrite(cl_writ(jf),lpre, imjm,
-     $          file_unit_field(jf), ierror) 
-            IF (jf.eq.16)
-     $          CALL locwrite(cl_writ(jf),spre, imjm,
-     $          file_unit_field(jf), ierror) 
-            IF (jf.eq.17)
-     $          CALL locwrite(cl_writ(jf),dirunoff, imjm,
-     $          file_unit_field(jf), ierror) 
-            IF (jf.eq.18)
-     $          CALL locwrite(cl_writ(jf),rivrunoff, imjm,
-     $          file_unit_field(jf), ierror) 
-            IF (jf.eq.19)
-     $          CALL locwrite(cl_writ(jf),calving, imjm,
-     $          file_unit_field(jf), ierror) 
-c$$$            IF (jf.eq.13)
-c$$$     $          CALL locwrite(cl_writ(jf),tauxu, imjm,
-c$$$     $          file_unit_field(jf),ierror) 
-c$$$            IF (jf.eq.1')
-c$$$     $          CALL locwrite(cl_writ(jf),tauxv, imjm,
-c$$$     $          file_unit_field(jf),ierror) 
-c$$$            IF (jf.eq.15)
-c$$$     $          CALL locwrite(cl_writ(jf),tauyv, imjm,
-c$$$     $          file_unit_field(jf),ierror) 
-c$$$            IF (jf.eq.16)
-c$$$     $          CALL locwrite(cl_writ(jf),tauyu, imjm,
-c$$$     $          file_unit_field(jf), ierror) 
-            IF (jf.eq.1)
-     $          CALL locwrite(cl_writ(jf),tauxx_u, imjm,
-     $          file_unit_field(jf),ierror)
-            IF (jf.eq.2)
-     $          CALL locwrite(cl_writ(jf),tauyy_u, imjm,
-     $          file_unit_field(jf),ierror)
-            IF (jf.eq.3)
-     $          CALL locwrite(cl_writ(jf),tauzz_u, imjm,
-     $          file_unit_field(jf),ierror)
-            IF (jf.eq.4)
-     $          CALL locwrite(cl_writ(jf),tauxx_v, imjm,
-     $          file_unit_field(jf),ierror)
-            IF (jf.eq.5)
-     $          CALL locwrite(cl_writ(jf),tauyy_v, imjm,
-     $          file_unit_field(jf),ierror)
-            IF (jf.eq.6)
-     $          CALL locwrite(cl_writ(jf),tauzz_v, imjm,
-     $          file_unit_field(jf),ierror)
-c -- LOOP
-            IF (jf.eq.7)
-     $          CALL locwrite(cl_writ(jf),windsp, imjm,
-     $         file_unit_field(jf),ierror)
-c -- LOOP
-
-          END DO 
-C
-C         -simulate a FLUSH
-C
-          DO jn=1, max_file 
-            CLOSE (file_unit(jn))
-          END DO 
-C
-C
-          IF(cchan.eq.'CLIM') THEN 
-C
-C         -inform PVM daemon that message exchange is finished
-C
-              CALL CLIM_Quit (CLIM_ContPvm, info)
-              IF (info .NE. CLIM_Ok) THEN
-                  WRITE (6, *) 
-     $                'An error occured while leaving CLIM. Error = ',
-     $                info
-              ENDIF
-          END IF 
-          RETURN    
-      END IF 
-C
-      IF(cchan.eq.'CLIM') THEN 
-C
-C     -Give atmospheric fields to Oasis
-C 
-          DO jn=1, jpflda2o1 + jpflda2o2
-C            
-          IF (jn.eq.8) CALL CLIM_Export(cl_writ(jn), kt, fsolice, info)
-          IF (jn.eq.9) CALL CLIM_Export(cl_writ(jn), kt, fsolwat, info)
-         IF (jn.eq.10) CALL CLIM_Export(cl_writ(jn), kt, fnsolice, info)
-         IF (jn.eq.11) CALL CLIM_Export(cl_writ(jn), kt, fnsolwat, info)
-         IF (jn.eq.12) CALL CLIM_Export(cl_writ(jn), kt, fnsicedt, info)
-c          IF (jn.eq.6) CALL CLIM_Export(cl_writ(jn), kt, ictemp, info)
-          IF (jn.eq.13) CALL CLIM_Export(cl_writ(jn), kt, evice, info)
-          IF (jn.eq.14) CALL CLIM_Export(cl_writ(jn), kt, evwat, info)
-          IF (jn.eq.15) CALL CLIM_Export(cl_writ(jn), kt, lpre, info)
-          IF (jn.eq.16) CALL CLIM_Export(cl_writ(jn), kt, spre, info)
-          IF (jn.eq.17) CALL CLIM_Export(cl_writ(jn),kt,dirunoff, info)
-          IF (jn.eq.18) CALL CLIM_Export(cl_writ(jn),kt,rivrunoff,info)
-          IF (jn.eq.19) CALL CLIM_Export(cl_writ(jn),kt,calving,info)
-c$$$          IF (jn.eq.13) CALL CLIM_Export(cl_writ(jn), kt, tauxu, info)
-c$$$          IF (jn.eq.14) CALL CLIM_Export(cl_writ(jn), kt, tauxv, info)
-c$$$          IF (jn.eq.15) CALL CLIM_Export(cl_writ(jn), kt, tauyv, info)
-c$$$          IF (jn.eq.16) CALL CLIM_Export(cl_writ(jn), kt, tauyu, info)
-          IF (jn.eq.1) CALL CLIM_Export(cl_writ(jn), kt, tauxx_u, info)
-          IF (jn.eq.2) CALL CLIM_Export(cl_writ(jn), kt, tauyy_u, info)
-          IF (jn.eq.3) CALL CLIM_Export(cl_writ(jn), kt, tauzz_u, info)
-          IF (jn.eq.4) CALL CLIM_Export(cl_writ(jn), kt, tauxx_v, info)
-          IF (jn.eq.5) CALL CLIM_Export(cl_writ(jn), kt, tauyy_v, info)
-          IF (jn.eq.6) CALL CLIM_Export(cl_writ(jn), kt, tauzz_v, info)
-c -- LOOP
-          IF (jn.eq.7) CALL CLIM_Export(cl_writ(jn), kt, windsp, info)
-c -- LOOP          
-            IF (info .NE. CLIM_Ok) THEN
-                WRITE (nuout,*) 'STEP : Pb giving ',cl_writ(jn), ':',jn
-                WRITE (nuout,*) ' at timestep = ', icstep,'kt = ',kt
-                WRITE (nuout,*) 'Clim error code is = ',info
-                CALL halte('STOP in intocpl ')
-            ENDIF
-          END DO 
-      ENDIF 
-C
-      RETURN
-      END
-
-      SUBROUTINE pipe_model_define
-      print*,'Attention dans oasis.F, pipe_model_define est non defini'
-      RETURN
-      END
-
-      SUBROUTINE pipe_model_stepi
-      print*,'Attention dans oasis.F, pipe_model_stepi est non defini'
-      RETURN
-      END
-
-      SUBROUTINE pipe_model_recv
-      print *, 'Attention dans oasis.F, pipe_model_recv est non defini'
-      RETURN
-      END
-
-      SUBROUTINE pipe_model_send
-      print *, 'Attention dans oasis.F, pipe_model_send est non defini'
-      RETURN
-      END
-
-      SUBROUTINE quitcpl
-      print *, 'Attention dans oasis.F, quitcpl est non defini'
-      RETURN
-      END
-
-      SUBROUTINE sipc_write_model
-      print *, 'Attention dans oasis.F, sipc_write_model est non defini'
-      RETURN
-      END
-
-      SUBROUTINE sipc_attach
-      print *, 'Attention dans oasis.F, sipc_attach est non defini'
-      RETURN
-      END
-
-      SUBROUTINE sipc_init_model
-      print *, 'Attention dans oasis.F, sipc_init_model est non defini'
-      RETURN
-      END
-
-      SUBROUTINE sipc_read_model
-      print *, 'Attention dans oasis.F, sipc_read_model est non defini'
-      RETURN
-      END
Index: LMDZ4/trunk/libf/phylmd/ocean_cpl_mod.F90
===================================================================
--- LMDZ4/trunk/libf/phylmd/ocean_cpl_mod.F90	(revision 782)
+++ LMDZ4/trunk/libf/phylmd/ocean_cpl_mod.F90	(revision 782)
@@ -0,0 +1,385 @@
+!
+! $Header$
+!
+MODULE ocean_cpl_mod
+!
+! This module is used both for the sub-surface ocean and sea-ice for the case of a 
+! coupled model configuration, ocean=couple. 
+!
+
+  USE dimphy,           ONLY : klon
+  USE cpl_mod
+  USE calcul_fluxs_mod, ONLY : calcul_fluxs
+  USE climb_wind_mod,   ONLY : calcul_wind_flux
+  USE mod_clvent,       ONLY : calcul_flux_vent
+  USE surface_data,     ONLY : newwind
+
+  IMPLICIT NONE
+  PRIVATE
+
+  PUBLIC :: ocean_cpl_init, ocean_cpl_get_vars, ocean_cpl_noice, ocean_cpl_ice
+
+  REAL, ALLOCATABLE, DIMENSION(:), SAVE       :: tmp_flux_o
+  !$OMP THREADPRIVATE(tmp_flux_o)
+  REAL, ALLOCATABLE, DIMENSION(:), SAVE       :: tmp_flux_g
+  !$OMP THREADPRIVATE(tmp_flux_g)
+
+!****************************************************************************************
+!
+CONTAINS
+!
+!****************************************************************************************
+!
+  SUBROUTINE ocean_cpl_init(dtime, rlon, rlat)
+!
+! Allocate fields for this module and initailize the module mod_cpl
+!
+! Input arguments
+!*************************************************************************************
+    REAL, INTENT(IN)                  :: dtime
+    REAL, DIMENSION(klon), INTENT(IN) :: rlon, rlat
+
+! Local variables
+!*************************************************************************************
+    INTEGER              :: error
+    CHARACTER (len = 80) :: abort_message
+    CHARACTER (len = 20) :: modname = 'ocean_cpl_init'
+
+
+    ALLOCATE(tmp_flux_o(klon), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation tmp_flux_o'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+
+    ALLOCATE(tmp_flux_g(klon), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation tmp_flux_g'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+
+! Initialize module cpl_init
+    CALL cpl_init(dtime, rlon, rlat)
+    
+  END SUBROUTINE ocean_cpl_init
+!
+!****************************************************************************************
+!
+  SUBROUTINE ocean_cpl_noice( &
+       sollw, albedo, &
+       windsp, &
+       fder_old, &
+       itime, dtime, knon, knindex, &
+       swdown, &
+       p1lay, tq_cdrag, precip_rain, precip_snow, temp_air, spechum, &
+       petAcoef, peqAcoef, petBcoef, peqBcoef, &
+       ps, u1_lay, v1_lay, pctsrf_in, &
+       radsol, snow, qsurf, agesno, &
+       evap, fluxsens, fluxlat, &
+       tsurf_new, dflux_s, dflux_l, pctsrf_oce)
+!
+! This subroutine treats the "open ocean", all grid points that are not entierly covered
+! by ice. The subroutine first receives fields from coupler, then some calculations at 
+! surface is done and finally it sends some fields to the coupler.
+!
+    INCLUDE "indicesol.inc"
+    INCLUDE "YOMCST.inc"
+!    
+! Input arguments  
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: itime, knon
+    INTEGER, DIMENSION(klon), INTENT(IN)     :: knindex
+    REAL, INTENT(IN)                         :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)        :: sollw
+    REAL, DIMENSION(klon), INTENT(IN)        :: albedo
+    REAL, DIMENSION(klon), INTENT(IN)        :: windsp
+    REAL, DIMENSION(klon), INTENT(IN)        :: fder_old
+    REAL, DIMENSION(klon), INTENT(IN)        :: swdown    
+    REAL, DIMENSION(klon), INTENT(IN)        :: p1lay
+    REAL, DIMENSION(klon), INTENT(IN)        :: tq_cdrag
+    REAL, DIMENSION(klon), INTENT(IN)        :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)        :: temp_air, spechum
+    REAL, DIMENSION(klon), INTENT(IN)        :: petAcoef, peqAcoef
+    REAL, DIMENSION(klon), INTENT(IN)        :: petBcoef, peqBcoef
+    REAL, DIMENSION(klon), INTENT(IN)        :: ps
+    REAL, DIMENSION(klon), INTENT(IN)        :: u1_lay, v1_lay
+    REAL, DIMENSION(klon,nbsrf), INTENT(IN)  :: pctsrf_in
+
+! In/Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(INOUT)     :: radsol
+    REAL, DIMENSION(klon), INTENT(INOUT)     :: snow
+    REAL, DIMENSION(klon), INTENT(INOUT)     :: agesno
+  
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)       :: qsurf
+    REAL, DIMENSION(klon), INTENT(OUT)       :: evap, fluxsens, fluxlat
+    REAL, DIMENSION(klon), INTENT(OUT)       :: tsurf_new
+    REAL, DIMENSION(klon), INTENT(OUT)       :: dflux_s, dflux_l      
+    REAL, DIMENSION(klon), INTENT(OUT)       :: pctsrf_oce
+
+! Local variables
+!****************************************************************************************
+    INTEGER               :: i
+    INTEGER, DIMENSION(1) :: iloc
+    REAL, DIMENSION(klon) :: cal, beta, dif_grnd
+    REAL, DIMENSION(klon) :: zx_sl
+    REAL, DIMENSION(klon) :: fder_new
+    REAL, DIMENSION(klon) :: tsurf_cpl
+    REAL, DIMENSION(klon) :: taux, tauy
+    LOGICAL               :: check=.FALSE.
+
+! End definitions
+!****************************************************************************************
+
+    IF (check) WRITE(*,*)' Entering ocean_cpl_noice'
+
+!****************************************************************************************
+! Receive sea-surface temperature(tsurf_cpl) and new fraction of ocean surface(pctsrf_oce) 
+! from coupler
+!
+!****************************************************************************************
+    CALL cpl_receive_ocean_fields(itime, dtime, knon, knindex, pctsrf_in, &
+         tsurf_cpl, pctsrf_oce)
+
+!****************************************************************************************
+! Calculate fluxes at surface
+!
+!****************************************************************************************
+    cal = 0.
+    beta = 1.
+    dif_grnd = 0.
+    agesno(:) = 0.
+    
+    CALL calcul_fluxs(knon, is_oce, dtime, &
+         tsurf_cpl, p1lay, cal, beta, tq_cdrag, ps, &
+         precip_rain, precip_snow, snow, qsurf,  &
+         radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
+         petAcoef, peqAcoef, petBcoef, peqBcoef, &
+         tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
+    
+!jg : temporary test, only calcul_flux_wind should be saved in the future
+    ! Calcultate the flux of u and v at surface
+    IF (newwind) THEN
+       ! calculate flux with new methode
+       CALL calcul_wind_flux(knon, dtime, taux, tauy)
+    ELSE 
+       ! use results from old clvent. jg: TO BE REMOVED
+       CALL calcul_flux_vent(klon, taux, tauy)
+    ENDIF
+
+
+!****************************************************************************************
+! Calculate fder : flux derivative (sensible and latente)
+!
+!****************************************************************************************
+    fder_new(:) = fder_old(:) + dflux_s(:) + dflux_l(:)
+    
+    iloc = MAXLOC(fder_new(1:klon))
+    IF (check .AND. fder_new(iloc(1))> 0.) THEN
+       WRITE(*,*)'**** Debug fder****'
+       WRITE(*,*)'max fder(',iloc(1),') = ',fder_new(iloc(1))
+       WRITE(*,*)'fder_old, dflux_s, dflux_l',fder_old(iloc(1)), &
+            dflux_s(iloc(1)), dflux_l(iloc(1))
+    ENDIF
+
+!****************************************************************************************
+! Flux ocean-atmosphere useful for "slab" ocean but here calculated only for printing
+! usage later in physiq  
+! 
+!****************************************************************************************
+    tmp_flux_o(:) = 0.0
+    DO i=1, knon
+       zx_sl(i) = RLVTT
+       IF (tsurf_new(i) .LT. RTT) zx_sl(i) = RLSTT
+       !IM     flux_o(i) = fluxsens(i)-evap(i)*zx_sl(i)
+       !       flux_o(i) = fluxsens(i) + fluxlat(i)
+       IF (pctsrf_oce(knindex(i)) .GT. epsfra) THEN
+          tmp_flux_o(knindex(i)) = fluxsens(i) + fluxlat(i)
+       ENDIF
+    ENDDO
+
+
+!****************************************************************************************
+! Send and cumulate fields to the coupler
+!
+!****************************************************************************************
+
+    CALL cpl_send_ocean_fields(itime, knon, knindex, &
+         swdown, sollw, fluxlat, fluxsens, &
+         precip_rain, precip_snow, evap, tsurf_new, fder_new, albedo, taux, tauy, windsp)
+    
+
+  END SUBROUTINE ocean_cpl_noice
+!
+!****************************************************************************************
+!
+  SUBROUTINE ocean_cpl_ice( &
+       rlon, rlat, sollw, albedo, &
+       fder_old, &
+       itime, dtime, knon, knindex, &
+       lafin, &
+       swdown, &
+       p1lay, tq_cdrag, precip_rain, precip_snow, temp_air, spechum, &
+       petAcoef, peqAcoef, petBcoef, peqBcoef, &
+       ps, u1_lay, v1_lay, pctsrf_in, &
+       radsol, snow, qsurf, &
+       alblw, evap, fluxsens, fluxlat, &
+       tsurf_new, alb_new, dflux_s, dflux_l, pctsrf_sic)
+!
+! This subroutine treats the ocean where there is ice. The subroutine first receives 
+! fields from coupler, then some calculations at surface is done and finally sends 
+! some fields to the coupler.
+!    
+    INCLUDE "indicesol.inc"
+    INCLUDE "YOMCST.inc"
+
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: itime, knon
+    INTEGER, DIMENSION(klon), INTENT(IN)     :: knindex
+    LOGICAL, INTENT(IN)                      :: lafin
+    REAL, INTENT(IN)                         :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)        :: rlon, rlat
+    REAL, DIMENSION(klon), INTENT(IN)        :: sollw
+    REAL, DIMENSION(klon), INTENT(IN)        :: albedo
+    REAL, DIMENSION(klon), INTENT(IN)        :: fder_old
+    REAL, DIMENSION(klon), INTENT(IN)        :: swdown
+    REAL, DIMENSION(klon), INTENT(IN)        :: p1lay
+    REAL, DIMENSION(klon), INTENT(IN)        :: tq_cdrag
+    REAL, DIMENSION(klon), INTENT(IN)        :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)        :: temp_air, spechum
+    REAL, DIMENSION(klon), INTENT(IN)        :: petAcoef, peqAcoef
+    REAL, DIMENSION(klon), INTENT(IN)        :: petBcoef, peqBcoef
+    REAL, DIMENSION(klon), INTENT(IN)        :: ps
+    REAL, DIMENSION(klon), INTENT(IN)        :: u1_lay, v1_lay
+    REAL, DIMENSION(klon,nbsrf), INTENT(IN)  :: pctsrf_in
+
+! In/output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(INOUT)     :: radsol
+    REAL, DIMENSION(klon), INTENT(INOUT)     :: snow
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)       :: qsurf
+    REAL, DIMENSION(klon), INTENT(OUT)       :: alblw
+    REAL, DIMENSION(klon), INTENT(OUT)       :: evap, fluxsens, fluxlat
+    REAL, DIMENSION(klon), INTENT(OUT)       :: tsurf_new, alb_new
+    REAL, DIMENSION(klon), INTENT(OUT)       :: dflux_s, dflux_l      
+    REAL, DIMENSION(klon), INTENT(OUT)       :: pctsrf_sic
+
+! Local variables
+!****************************************************************************************
+    INTEGER                 :: i
+    INTEGER, DIMENSION(1)   :: iloc
+    LOGICAL                 :: check=.FALSE.
+    REAL, PARAMETER         :: t_grnd=271.35
+    REAL, DIMENSION(klon)   :: cal, beta, dif_grnd
+    REAL, DIMENSION(klon)   :: tsurf_cpl, fder_new
+    REAL, DIMENSION(klon)   :: taux, tauy
+
+! End definitions
+!****************************************************************************************
+    
+    IF (check) WRITE(*,*)'Entering surface_seaice, knon=',knon 
+
+!****************************************************************************************
+! Receive ocean temperature(tsurf_cpl), albedo(alb_new) and new fraction of 
+! seaice(pctsrf_sic) from coupler
+!
+!****************************************************************************************
+
+    CALL cpl_receive_seaice_fields(knon, knindex, &
+         tsurf_cpl, alb_new, pctsrf_sic)
+    
+!****************************************************************************************
+! Calculate fluxes at surface
+!
+!****************************************************************************************
+    cal = 0.
+    dif_grnd = 0.
+    beta = 1.0
+    
+
+    CALL calcul_fluxs(knon, is_sic, dtime, &
+         tsurf_cpl, p1lay, cal, beta, tq_cdrag, ps, &
+         precip_rain, precip_snow, snow, qsurf,  &
+         radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
+         petAcoef, peqAcoef, petBcoef, peqBcoef, &
+         tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
+
+    ! Calcultate the flux of u and v at surface
+    IF (newwind) THEN
+       ! calculate flux with new methode
+       CALL calcul_wind_flux(knon, dtime, taux, tauy)
+    ELSE
+       ! use results from old clvent. jg: TO BE REMOVED
+       CALL calcul_flux_vent(klon, taux, tauy)
+    END IF
+
+!****************************************************************************************
+! Flux ocean-atmosphere useful for "slab" ocean but here calculated only for printing
+! usage later in physiq  
+! 
+!  IM: faire dependre le coefficient de conduction de la glace de mer
+!      de l'epaisseur de la glace de mer, dans l'hypothese ou le coeff.
+!      actuel correspond a 3m de glace de mer, cf. L.Li
+!
+!****************************************************************************************
+    tmp_flux_g(:) = 0.0
+    DO i = 1, knon
+       IF (cal(i) .GT. 1.0e-15 .AND. pctsrf_sic(knindex(i)) .GT. epsfra) &
+            tmp_flux_g(knindex(i)) = (tsurf_new(i)-t_grnd) * &
+            dif_grnd(i) * RCPD/cal(i) 
+    ENDDO
+    
+!****************************************************************************************
+! Calculate fder : flux derivative (sensible and latente)
+!
+!****************************************************************************************
+    fder_new(:) = fder_old(:) + dflux_s(:) + dflux_l(:)
+    
+    iloc = MAXLOC(fder_new(1:klon))
+    IF (check .AND. fder_new(iloc(1))> 0.) THEN
+       WRITE(*,*)'**** Debug fder ****'
+       WRITE(*,*)'max fder(',iloc(1),') = ',fder_new(iloc(1))
+       WRITE(*,*)'fder_old, dflux_s, dflux_l',fder_old(iloc(1)), &
+            dflux_s(iloc(1)), dflux_l(iloc(1))
+    ENDIF
+
+!****************************************************************************************
+! Send and cumulate fields to the coupler
+!
+!****************************************************************************************
+
+    CALL cpl_send_seaice_fields(itime, dtime, knon, knindex, &
+       pctsrf_in, lafin, rlon, rlat, &
+       swdown, sollw, fluxlat, fluxsens, &
+       precip_rain, precip_snow, evap, tsurf_new, fder_new, albedo, taux, tauy)
+ 
+
+    alblw(1:knon) = alb_new(1:knon)    
+
+  END SUBROUTINE ocean_cpl_ice
+!  
+!****************************************************************************************
+!
+  SUBROUTINE ocean_cpl_get_vars(flux_o, flux_g)
+
+! This subroutine returns variables private in this module to an external 
+! routine (physiq).
+
+    REAL, DIMENSION(klon), INTENT(OUT) :: flux_o
+    REAL, DIMENSION(klon), INTENT(OUT) :: flux_g
+
+! Set the output variables
+    flux_o(:) = tmp_flux_o(:)
+    flux_g(:) = tmp_flux_g(:)
+
+  END SUBROUTINE ocean_cpl_get_vars
+!
+!****************************************************************************************
+!
+END MODULE ocean_cpl_mod
Index: LMDZ4/trunk/libf/phylmd/phyetat0.F
===================================================================
--- LMDZ4/trunk/libf/phylmd/phyetat0.F	(revision 781)
+++ LMDZ4/trunk/libf/phylmd/phyetat0.F	(revision 782)
@@ -5,18 +5,25 @@
 c
       SUBROUTINE phyetat0 (fichnom,dtime,co2_ppm_etat0,solaire_etat0,
-     .            rlat_p,rlon_p, pctsrf_p, tsol_p,tsoil_p,
-cIM "slab" ocean
-     .           ocean, tslab_p,seaice_p,
-     .           qsurf_p,qsol_p,snow_p,albe_p, alblw_p, evap_p,
+     .           rlat_p, rlon_p, pctsrf_p, tsol_p,
+     .           ocean_in, ok_veget_in,
+     .           albe_p, alblw_p,
      .           rain_fall_p, snow_fall_p,solsw_p, sollw_p,
-     .           fder_p,radsol_p,frugs_p,agesno_p,clesphy0,
+     .           radsol_p,clesphy0,
      .           zmea_p,zstd_p,zsig_p,zgam_p,zthe_p,zpic_p,zval_p,
      .           rugsrel_p,tabcntr0,
      .           t_ancien_p,q_ancien_p,ancien_ok_p, rnebcon_p, ratqs_p,
-     .           clwcon_p,run_off_lic_0_p)
+     .           clwcon_p)
+
       USE dimphy
       USE mod_grid_phy_lmdz
       USE mod_phys_lmdz_para
       USE iophy
+      USE ocean_slab_mod,   ONLY : ocean_slab_init
+      USE ocean_cpl_mod,    ONLY : ocean_cpl_init
+      USE ocean_forced_mod, ONLY : ocean_forced_init
+      USE fonte_neige_mod,  ONLY : fonte_neige_init
+      USE pbl_surface_mod,  ONLY : pbl_surface_init
+      USE surface_data,     ONLY : ocean, ok_veget
+
       IMPLICIT none
 c======================================================================
@@ -25,5 +32,4 @@
 c======================================================================
 #include "dimensions.h"
-cym#include "dimphy.h"
 #include "netcdf.inc"
 #include "indicesol.h"
@@ -111,5 +117,6 @@
       real ratqs(klon_glo,klev)
 
-      CHARACTER*6 ocean
+      CHARACTER*6 ocean_in
+      LOGICAL ok_veget_in
 
       INTEGER        longcles
@@ -515,5 +522,5 @@
 c Lecture de tslab (pour slab ocean seulement):      
 c
-      IF (ocean .eq. 'slab  ') then
+      IF (ocean_in .eq. 'slab  ') then
         ierr = NF_INQ_VARID (nid, "TSLAB", nvarid)
         IF (ierr.NE.NF_NOERR) THEN
@@ -1543,4 +1550,32 @@
       call Scatter( zmasq_glo,zmasq)
 
+c
+c Initilalize variables in module surface_data
+c
+      ok_veget = ok_veget_in
+      ocean    = ocean_in
+c
+c Initialize module pbl_surface_mod 
+c
+      CALL pbl_surface_init(qsol_p, fder_p, snow_p, qsurf_p,
+     $     evap_p, frugs_p, agesno_p, tsoil_p)
+
+c Initialize ocean module according to ocean type
+      IF ( ocean == 'slab' ) THEN
+c        initilalize module ocean_slab_init
+         CALL ocean_slab_init(dtime, tslab_p, seaice_p, pctsrf_p)
+      ELSEIF ( ocean == 'couple' ) THEN
+c        initilalize module ocean_cpl_init
+         CALL ocean_cpl_init(dtime, rlon_p, rlat_p)
+      ELSE
+c        initilalize module ocean_forced_init
+         CALL ocean_forced_init
+      ENDIF
+c
+c Initilialize module fonte_neige_mod      
+c
+      CALL fonte_neige_init(run_off_lic_0_p)
+
+
       RETURN
       END
Index: LMDZ4/trunk/libf/phylmd/phyredem.F
===================================================================
--- LMDZ4/trunk/libf/phylmd/phyredem.F	(revision 781)
+++ LMDZ4/trunk/libf/phylmd/phyredem.F	(revision 782)
@@ -3,17 +3,19 @@
 !
 c
-      SUBROUTINE phyredem (fichnom,dtime,radpas,
-     .           rlat_p,rlon_p, pctsrf_p,tsol_p,tsoil_p,
-cIM "slab" ocean
-     .           tslab,seaice,
-     .           qsurf_p,qsol_p,snow_p,albedo_p, alblw_p, evap_p,
-     .           rain_fall_p, snow_fall_p,solsw_p, sollw_p,fder_p,
-     .           radsol_p,frugs_p,agesno_p,zmea_p,zstd_p,zsig_p,
+      SUBROUTINE phyredem (fichnom,dtime,radpas,ocean,
+     .           rlat_p,rlon_p, pctsrf_p,tsol_p,
+     .           albedo_p, alblw_p,
+     .           rain_fall_p, snow_fall_p,solsw_p, sollw_p,
+     .           radsol_p,zmea_p,zstd_p,zsig_p,
      .           zgam_p,zthe_p,zpic_p,zval_p,rugsrel_p,
-     .           t_ancien_p, q_ancien_p, rnebcon_p, ratqs_p, clwcon_p,
-     .           run_off_lic_0_p)
+     .           t_ancien_p, q_ancien_p, rnebcon_p, ratqs_p, clwcon_p)
+
       USE dimphy
       USE mod_grid_phy_lmdz
       USE mod_phys_lmdz_para
+      USE ocean_slab_mod,   ONLY : ocean_slab_final
+      USE fonte_neige_mod,  ONLY : fonte_neige_final
+      USE pbl_surface_mod,  ONLY : pbl_surface_final
+
       IMPLICIT none
 c======================================================================
@@ -21,6 +23,4 @@
 c Objet: Ecriture de l'etat de redemarrage pour la physique
 c======================================================================
-cym#include "dimensions.h"
-cym#include "dimphy.h"
 #include "netcdf.inc"
 #include "indicesol.h"
@@ -36,4 +36,5 @@
       REAL tsol_p(klon,nbsrf)
       REAL tsoil_p(klon,nsoilmx,nbsrf)
+      CHARACTER*6 ocean
 cIM "slab" ocean
       REAL tslab_p(klon), seaice_p(klon)
@@ -110,5 +111,25 @@
       CHARACTER*7 str7
       CHARACTER*2 str2
-c
+
+c======================================================================
+c 
+c Get variables which will be written to restart file from module 
+c pbl_surface_mod
+      CALL pbl_surface_final(qsol_p, fder_p, snow_p, qsurf_p, 
+     $     evap_p, frugs_p, agesno_p, tsoil_p)
+
+c Get a variable calculated in module fonte_neige_mod
+      CALL fonte_neige_final(run_off_lic_0_p)
+
+c If slab ocean then get 2 varaibles from module ocean_slab_mod
+      IF ( ocean == 'slab' ) THEN
+         CALL ocean_slab_final(tslab_p, seaice_p)
+      ELSE 
+         tslab_p(:)  = 0.0
+         seaice_p(:) = 0.0
+      ENDIF      
+
+c======================================================================
+
       call Gather( rlat_p,rlat)
       call Gather( rlon_p,rlon)
Index: LMDZ4/trunk/libf/phylmd/physiq.F
===================================================================
--- LMDZ4/trunk/libf/phylmd/physiq.F	(revision 781)
+++ LMDZ4/trunk/libf/phylmd/physiq.F	(revision 782)
@@ -26,4 +26,19 @@
       USE misc_mod, mydebug=>debug
       USE vampir
+      USE pbl_surface_mod, ONLY : pbl_surface
+
+#ifdef INCA
+cym      USE chemshut
+      USE species_names
+#ifdef INCA_CH4
+!      USE obs_pos
+#endif
+#endif
+
+      USE ocean_slab_mod, ONLY   : ocean_slab_get_vars
+      USE ocean_cpl_mod, ONLY    : ocean_cpl_get_vars
+      USE ocean_forced_mod, ONLY : ocean_forced_get_vars
+      USE fonte_neige_mod, ONLY  : fonte_neige_get_vars
+
       IMPLICIT none
 c======================================================================
@@ -70,8 +85,4 @@
 c d_q_dyn-input-R-tendance dynamique pour "q" (kg/kg/s)
 c omega---input-R-vitesse verticale en Pa/s
-cIM comgeomphy.h BEG
-c cuphy----input-R-resolution des mailles en x (m)
-c cvphy----input-R-resolution des mailles en y (m)
-cIM comgeomphy.h END
 c d_u-----output-R-tendance physique de "u" (m/s/s)
 c d_v-----output-R-tendance physique de "v" (m/s/s)
@@ -87,5 +98,5 @@
       integer iip1
       parameter (iip1=iim+1)
-cym#include "dimphy.h"
+
 #include "regdim.h"
 #include "indicesol.h"
@@ -110,8 +121,4 @@
       PARAMETER (ok_stratus=.FALSE.)
 c======================================================================
-c Parametres lies au coupleur OASIS:
-#include "oasis.h"
-      INTEGER,SAVE :: npas, nexca
-c$OMP THREADPRIVATE(npas, nexca)
       logical rnpb
 #ifdef INCA
@@ -124,10 +131,5 @@
       SAVE ocean
 c$OMP THREADPRIVATE(ocean)
-c      parameter (ocean = 'force ')
-c     parameter (ocean = 'couple')
-      logical ok_ocean
-      SAVE ok_ocean
-c$OMP THREADPRIVATE(ok_ocean)
-c
+
 cIM "slab" ocean
       REAL tslab(klon)    !Temperature du slab-ocean
@@ -167,15 +169,12 @@
       save ok_journe
 c$OMP THREADPRIVATE(ok_journe)
-c      PARAMETER (ok_journe=.true.)
 c
       LOGICAL ok_mensuel ! sortir le fichier mensuel
       save ok_mensuel
 c$OMP THREADPRIVATE(ok_mensuel)
-c      PARAMETER (ok_mensuel=.true.)
 c
       LOGICAL ok_instan ! sortir le fichier instantane
       save ok_instan
 c$OMP THREADPRIVATE(ok_instan)
-c      PARAMETER (ok_instan=.true.)
 c
       LOGICAL ok_region ! sortir le fichier regional
@@ -185,7 +184,4 @@
       REAL fm_therm(klon,klev+1)
       REAL entr_therm(klon,klev)
-      real,allocatable,save :: q2(:,:,:)
-c$OMP THREADPRIVATE(q2)
-cym      save q2
 c======================================================================
 c
@@ -212,6 +208,4 @@
       REAL presnivs(klev)
       REAL znivsig(klev)
-      REAL zsurf(nbsrf)
-      INTEGER kinv
       real pir
 
@@ -223,5 +217,4 @@
       REAL,allocatable,save :: t_ancien(:,:), q_ancien(:,:)
 c$OMP THREADPRIVATE(t_ancien, q_ancien)
-cym      SAVE t_ancien, q_ancien
       LOGICAL ancien_ok
       SAVE ancien_ok
@@ -268,24 +261,19 @@
       REAL,allocatable,save :: swup0(:,:), swup(:,:)
 c$OMP THREADPRIVATE(swdn0 , swdn, swup0, swup)
-cym      SAVE swdn0 , swdn, swup0, swup
 c
       REAL,allocatable,save :: SWdn200clr(:), SWdn200(:)
       REAL,allocatable,save :: SWup200clr(:), SWup200(:)
 c$OMP THREADPRIVATE(SWdn200clr, SWdn200, SWup200clr, SWup200)
-cym      SAVE SWdn200clr, SWdn200, SWup200clr, SWup200
 c
       REAL,allocatable,save :: lwdn0(:,:), lwdn(:,:)
       REAL,allocatable,save :: lwup0(:,:), lwup(:,:)
 c$OMP THREADPRIVATE(lwdn0 , lwdn, lwup0, lwup)
-cym      SAVE lwdn0 , lwdn, lwup0, lwup 
 c
       REAL,allocatable,save :: LWdn200clr(:), LWdn200(:)
       REAL,allocatable,save :: LWup200clr(:), LWup200(:)
 c$OMP THREADPRIVATE(LWdn200clr, LWdn200, LWup200clr, LWup200)
-cym      SAVE LWdn200clr, LWdn200, LWup200clr, LWup200
 c
       REAL,allocatable,save :: LWdnTOA(:), LWdnTOAclr(:)
 c$OMP THREADPRIVATE(LWdnTOA, LWdnTOAclr)
-cym      SAVE LWdnTOA, LWdnTOAclr
 c
 cIM Amip2
@@ -323,7 +311,4 @@
       REAL,SAVE,ALLOCATABLE :: wsumSTD(:,:,:), phisumSTD(:,:,:)
       REAL,SAVE,ALLOCATABLE :: qsumSTD(:,:,:), rhsumSTD(:,:,:)
-c
-cym      SAVE tsumSTD, usumSTD, vsumSTD, wsumSTD, phisumSTD, 
-cym     .     qsumSTD, rhsumSTD
 c$OMP THREADPRIVATE(tsumSTD, usumSTD, vsumSTD, wsumSTD, phisumSTD) 
 c$OMP THREADPRIVATE(qsumSTD, rhsumSTD)
@@ -332,5 +317,4 @@
       real,SAVE,ALLOCATABLE :: tnondef(:,:,:) 
 c$OMP THREADPRIVATE(tnondef)
-cym      save tnondef
 c
 c les produits uvSTD, vqSTD, .., T2STD sont calcules
@@ -360,6 +344,4 @@
       real,save,allocatable :: T2sumSTD(:,:,:)
 c
-cym      SAVE uvsumSTD, vqsumSTD, vTsumSTD, wqsumSTD
-cym      SAVE vphisumSTD, wTsumSTD, u2sumSTD, v2sumSTD, T2sumSTD
 c$OMP THREADPRIVATE(uvsumSTD, vqsumSTD, vTsumSTD, wqsumSTD)
 c$OMP THREADPRIVATE(vphisumSTD, wTsumSTD, u2sumSTD, v2sumSTD, T2sumSTD)
@@ -433,5 +415,4 @@
       REAL seed_re(klon,napisccp)
       INTEGER,ALLOCATABLE,SAVE :: seed_old(:,:)
-cym      SAVE seed_old
 c$OMP THREADPRIVATE(seed_old)
 cym !!!! A voir plus tard 
@@ -511,5 +492,4 @@
       PARAMETER(nbregdyn=5)
 
-      INTEGER linv
       INTEGER,ALLOCATABLE,SAVE :: pct_ocean(:,:)
 c$OMP THREADPRIVATE(pct_ocean)
@@ -683,6 +663,5 @@
 
       REAL,allocatable,save :: ftsol(:,:)
-c$OMP THREADPRIVATE(ftsol)
-cym      SAVE ftsol                  ! temperature du sol
+c$OMP THREADPRIVATE(ftsol)       ! temperature du sol
 
 cIM
@@ -691,14 +670,6 @@
 cym     SAVE newsst
 c
-      REAL,allocatable,save :: ftsoil(:,:,:)
-c$OMP THREADPRIVATE(ftsoil)
-cym      SAVE ftsoil                 ! temperature dans le sol
-c
-      REAL,allocatable,save :: fevap(:,:)
-c$OMP THREADPRIVATE(fevap)
-cym      SAVE fevap                 ! evaporation
-      REAL,allocatable,save :: fluxlat(:,:)
-c$OMP THREADPRIVATE(fluxlat)
-cym      SAVE fluxlat
+      REAL fevap(klon,nbsrf)
+      REAL fluxlat(klon,nbsrf)
 c
       REAL,allocatable,save :: deltat(:)
@@ -706,22 +677,11 @@
 cym      SAVE deltat                 ! ecart avec la SST de reference
 c
-      REAL,allocatable,save :: fqsurf(:,:)
-c$OMP THREADPRIVATE(fqsurf)
-cym      SAVE fqsurf                 ! humidite de l'air au contact de la surface
-c
-      REAL,allocatable,save :: qsol(:)
-c$OMP THREADPRIVATE(qsol)
-cym      SAVE qsol                  ! hauteur d'eau dans le sol
-c
-      REAL,allocatable,save :: fsnow(:,:)
-c$OMP THREADPRIVATE(fsnow)
-cym      SAVE fsnow                  ! epaisseur neigeuse
+      REAL qsol(klon)
 c
       REAL,allocatable,save :: falbe(:,:)
-c$OMP THREADPRIVATE(falbe)
-cym      SAVE falbe                  ! albedo par type de surface
+c$OMP THREADPRIVATE(falbe)       ! albedo par type de surface
+c
       REAL,allocatable,save :: falblw(:,:)
-c$OMP THREADPRIVATE(falblw)      
-cym      SAVE falblw                 ! albedo par type de surface
+c$OMP THREADPRIVATE(falblw)       ! albedo par type de surface
 
 c
@@ -770,7 +730,5 @@
       INTEGER igwd,idx(klon),itest(klon)
 c
-      REAL,allocatable,save :: agesno(:,:)
-c$OMP THREADPRIVATE(agesno)
-cym      SAVE agesno                 ! age de la neige
+      REAL agesno(klon,nbsrf)
 c
       REAL,allocatable,save :: alb_neig(:)
@@ -778,6 +736,6 @@
 cym      SAVE alb_neig               ! albedo de la neige
 c
-      REAL,allocatable,save :: run_off_lic_0(:)
-c$OMP THREADPRIVATE(run_off_lic_0)
+c      REAL,allocatable,save :: run_off_lic_0(:)
+cc$OMP THREADPRIVATE(run_off_lic_0)
 cym      SAVE run_off_lic_0
 cKE43
@@ -836,12 +794,5 @@
       REAL yu1(klon)            ! vents dans la premiere couche U
       REAL yv1(klon)            ! vents dans la premiere couche V
-      REAL,SAVE,ALLOCATABLE :: ffonte(:,:)    !Flux thermique utilise pour fondre la neige
-c$OMP THREADPRIVATE(ffonte)
-      REAL,SAVE,ALLOCATABLE :: fqcalving(:,:) !Flux d'eau "perdu" par la surface 
-c$OMP THREADPRIVATE(fqcalving)
-      REAL,SAVE,ALLOCATABLE :: fqfonte(:,:)  !Quantite d'eau de fonte des glaciers
-c$OMP THREADPRIVATE(fqfonte)
-c                               !et necessaire pour limiter la
-c                               !hauteur de neige, en kg/m2/s
+
       REAL zxffonte(klon), zxfqcalving(klon),zxfqfonte(klon)
 
@@ -882,9 +833,5 @@
       REAL evap(klon), devap(klon) ! evaporation et sa derivee
       REAL sens(klon), dsens(klon) ! chaleur sensible et sa derivee
-      REAL,allocatable,save :: dlw(:)    ! derivee infra rouge
-c$OMP THREADPRIVATE(dlw)
-cym
-cym      SAVE dlw
-cym
+
       REAL bils(klon) ! bilan de chaleur au sol
       REAL wfbilo(klon,nbsrf) ! bilan d'eau, pour chaque
@@ -892,7 +839,5 @@
       REAL wfbils(klon,nbsrf) ! bilan de chaleur au sol, pour chaque
 C                             ! type de sous-surface et pondere par la fraction
-      REAL,allocatable,save :: fder(:) ! Derive de flux (sensible et latente)
-c$OMP THREADPRIVATE(fder) 
-cym      save fder
+      REAL fder(klon)         
       REAL ve(klon) ! integr. verticale du transport meri. de l'energie
       REAL vq(klon) ! integr. verticale du transport meri. de l'eau
@@ -900,7 +845,5 @@
       REAL uq(klon) ! integr. verticale du transport zonal de l'eau
 c
-      REAL,allocatable,save :: frugs(:,:) ! longueur de rugosite
-c$OMP THREADPRIVATE(frugs) 
-cym      save frugs
+      REAL frugs(klon,nbsrf)
       REAL zxrugs(klon) ! longueur de rugosite
 c
@@ -944,5 +887,4 @@
       EXTERNAL alboc     ! calculer l'albedo sur ocean
       EXTERNAL ajsec     ! ajustement sec
-      EXTERNAL clmain    ! couche limite 
       EXTERNAL conlmd    ! convection (schema LMD)
 cKE43
@@ -1047,4 +989,5 @@
 c
       REAL zxtsol(klon), zxqsurf(klon), zxsnow(klon), zxfluxlat(klon)
+      REAL zxsnow_dummy(klon)
 c
       REAL dist, rmu0(klon), fract(klon)
@@ -1070,27 +1013,5 @@
 cym      REAL zx_aire(iim,jjmp1)
 c
-cIM cf. AM Variables locales pour la CLA (hbtm2)
-c
-      REAL,SAVE,ALLOCATABLE :: pblh(:, :)           ! Hauteur de couche limite
-c$OMP THREADPRIVATE(pblh)
-      REAL,SAVE,ALLOCATABLE :: plcl(:, :)           ! Niveau de condensation de la CLA
-c$OMP THREADPRIVATE(plcl)
-      REAL,SAVE,ALLOCATABLE :: capCL(:, :)          ! CAPE de couche limite
-c$OMP THREADPRIVATE(capCL)
-      REAL,SAVE,ALLOCATABLE :: oliqCL(:, :)          ! eau_liqu integree de couche limite
-c$OMP THREADPRIVATE(oliqCL)
-      REAL,SAVE,ALLOCATABLE :: cteiCL(:, :)          ! cloud top instab. crit. couche limite
-c$OMP THREADPRIVATE(cteiCL)
-      REAL,SAVE,ALLOCATABLE :: pblt(:, :)          ! T a la Hauteur de couche limite
-c$OMP THREADPRIVATE(pblt)
-      REAL,SAVE,ALLOCATABLE :: therm(:, :)
-c$OMP THREADPRIVATE(therm)
-      REAL,SAVE,ALLOCATABLE :: trmb1(:, :)          ! deep_cape
-c$OMP THREADPRIVATE(trmb1)
-      REAL,SAVE,ALLOCATABLE :: trmb2(:, :)          ! inhibition 
-c$OMP THREADPRIVATE(trmb2)
-      REAL,SAVE,ALLOCATABLE :: trmb3(:, :)          ! Point Omega
-c$OMP THREADPRIVATE(trmb3)
-c Grdeurs de sorties
+c Grandeurs de sorties
       REAL s_pblh(klon), s_lcl(klon), s_capCL(klon)
       REAL s_oliqCL(klon), s_cteiCL(klon), s_pblt(klon)
@@ -1246,7 +1167,4 @@
 cIM RH a 2m (la surface)
       REAL rh2m(klon), qsat2m(klon)
-      REAL zx_rh2m(klon,nbsrf), zx_qsat2m(klon,nbsrf)
-      REAL zx_qs1(klon,nbsrf), zx_t1(klon,nbsrf), zdelta1(klon,nbsrf)
-      REAL zcor1(klon,nbsrf)
       REAL tpot(klon), tpote(klon)
       REAL Lheat
@@ -1370,7 +1288,8 @@
       REAL ZRCPD
 c-jld ec_conser
+      REAL t2m(klon,nbsrf)  ! temperature a 2m
+      REAL q2m(klon,nbsrf)  ! humidite a 2m
+
 cIM: t2m, q2m, u10m, v10m et t2mincels, t2maxcels
-      REAL,SAVE,ALLOCATABLE :: t2m(:,:), q2m(:,:)   !temperature, humidite a 2m
-c$OMP THREADPRIVATE(t2m,q2m)
       REAL,SAVE,ALLOCATABLE :: u10m(:,:), v10m(:,:) !vents a 10m
 c$OMP THREADPRIVATE(u10m,v10m)
@@ -1420,5 +1339,4 @@
 c Declaration des constantes et des fonctions thermodynamiques
 c
-      REAL Field_tmp(klon_glo,klevp1)
       LOGICAL,SAVE :: first=.true.
 c$OMP THREADPRIVATE(first)
@@ -1443,12 +1361,8 @@
       aam=0.
       torsfc=0.
-cym => pour le couple ocean => revoir dans clmain/intersurf
-      fluxg(:)=0.
-      fluxo(:)=0.      
 
       if (first) then 
       
       allocate( t_ancien(klon,klev), q_ancien(klon,klev))
-      allocate( q2(klon,klev+1,nbsrf))
       allocate( swdn0(klon,klevp1), swdn(klon,klevp1))
       allocate( swup0(klon,klevp1), swup(klon,klevp1))
@@ -1464,11 +1378,5 @@
       allocate( rlon(klon))
       allocate( ftsol(klon,nbsrf))
-      allocate( ftsoil(klon,nsoilmx,nbsrf))
-      allocate( fevap(klon,nbsrf))
-      allocate( fluxlat(klon,nbsrf))
       allocate( deltat(klon))
-      allocate( fqsurf(klon,nbsrf))
-      allocate( qsol(klon))
-      allocate( fsnow(klon,nbsrf))
       allocate( falbe(klon,nbsrf))
       allocate( falblw(klon,nbsrf))
@@ -1482,7 +1390,5 @@
       allocate( rugoro(klon))
       allocate( zuthe(klon),zvthe(klon))
-      allocate( agesno(klon,nbsrf))
       allocate( alb_neig(klon))
-      allocate( run_off_lic_0(klon))
       allocate( ema_workcbmf(klon))   
       allocate( ema_cbmf(klon)) 
@@ -1499,7 +1405,4 @@
       allocate( snow_fall(klon) )
       allocate( total_rain(klon), nday_rain(klon))
-      allocate( dlw(klon)   )
-      allocate( fder(klon) )
-      allocate( frugs(klon,nbsrf) )
       allocate( pctsrf(klon,nbsrf))
       allocate( albsol(klon))
@@ -1546,22 +1449,8 @@
       allocate( newsst(klon))
       allocate( zqasc(klon,klev))
-      allocate( therm(klon, nbsrf))
       allocate( rain_con(klon))
-      allocate( pblt(klon, nbsrf))
-      allocate( t2m(klon,nbsrf), q2m(klon,nbsrf) )  
       allocate( u10m(klon,nbsrf), v10m(klon,nbsrf)) 
       allocate( topswad(klon), solswad(klon))
       allocate( topswai(klon), solswai(klon) )
-      allocate( ffonte(klon,nbsrf))
-      allocate( fqcalving(klon,nbsrf))
-      allocate( fqfonte(klon,nbsrf)) 
-      allocate( pblh(klon, nbsrf))
-      allocate( plcl(klon, nbsrf))  
-      allocate( capCL(klon, nbsrf))   
-      allocate( oliqCL(klon, nbsrf))       
-      allocate( cteiCL(klon, nbsrf))       
-      allocate( trmb1(klon, nbsrf))   
-      allocate( trmb2(klon, nbsrf))     
-      allocate( trmb3(klon, nbsrf)) 
       allocate( clwcon0(klon,klev),rnebcon0(klon,klev))
       allocate( tau_ae(klon,klev,2), piz_ae(klon,klev,2))
@@ -1576,5 +1465,4 @@
 	rnebcon(:,:)=0.
 	ratqs(:,:)=0.
-	run_off_lic_0(:)=0.
 	sollw(:)=0.
 	ema_work1(:,:)=0.
@@ -1615,9 +1503,4 @@
          u10m(:,:)=0.
          v10m(:,:)=0.
-         t2m(:,:)=0.
-         q2m(:,:)=0.
-         ffonte(:,:)=0.
-         fqcalving(:,:)=0.
-	 fqfonte(:,:)=0.
          piz_ae(:,:,:)=0.
          tau_ae(:,:,:)=0.
@@ -1643,21 +1526,5 @@
 c        histoW(:,:,:,:) = 0.0
 ! fin anne
-! Anne 12/09/2005
-
-         pblh(:,:)   =0.        ! Hauteur de couche limite
-         plcl(:,:)   =0.        ! Niveau de condensation de la CLA
-         capCL(:,:)  =0.        ! CAPE de couche limite
-         oliqCL(:,:) =0.        ! eau_liqu integree de couche limite
-         cteiCL(:,:) =0.        ! cloud top instab. crit. couche limite
-         pblt(:,:)   =0.        ! T a la Hauteur de couche limite
-         therm(:,:)  =0.
-         trmb1(:,:)  =0.        ! deep_cape
-         trmb2(:,:)  =0.        ! inhibition 
-         trmb3(:,:)  =0.        ! Point Omega
-! fin Anne
-
-cym
-         wfbils(:,:)=0
-cym      
+
 cIM      
          IF (ip_ebil_phy.ge.1) d_h_vcol_phy=0.
@@ -1677,19 +1544,15 @@
 c Initialiser les compteurs:
 c
-
-         frugs = 0.
          itap    = 0
          itaprad = 0
+
          CALL phyetat0 ("startphy.nc",dtime,co2_ppm_etat0,solaire_etat0,
-     .       rlat,rlon,pctsrf, ftsol,ftsoil,
-cIM "slab" ocean
-     .       ocean, tslab,seaice,
-     .       fqsurf,qsol,fsnow,
-cIM 220306  .       falbe, falblw, fevap, rain_fall,snow_fall,solsw, sollwdown,
-     .       falbe, falblw, fevap, rain_fall,snow_fall,solsw, sollw,
-     .       dlw,radsol,frugs,agesno,clesphy0,
+     .       rlat,rlon,pctsrf, ftsol,
+     .       ocean, ok_veget,
+     .       falbe, falblw, rain_fall,snow_fall,
+     .       solsw, sollw,
+     .       radsol,clesphy0,
      .       zmea,zstd,zsig,zgam,zthe,zpic,zval,rugoro,tabcntr0,
-     .       t_ancien, q_ancien, ancien_ok, rnebcon, ratqs,clwcon, 
-     .       run_off_lic_0)
+     .       t_ancien, q_ancien, ancien_ok, rnebcon, ratqs,clwcon)
 
        DO i=1,klon
@@ -1697,12 +1560,10 @@
      $       pctsrf(i, is_oce) + pctsrf(i, is_sic)  - 1.) .GT. EPSFRA) 
      $       THEN 
-             WRITE(*,*) 'physiq : pb sous surface au point ', i, 
-     $           pctsrf(i, 1 : nbsrf)
+            WRITE(*,*)
+     $   'physiq apres lecture de restart: pb sous surface au point ',
+     $   i, pctsrf(i, 1 : nbsrf)
          ENDIF 
       ENDDO
- 
-c   ATTENTION : il faudra a terme relire q2 dans l'etat initial
-         q2(:,:,:)=1.e-8
-c
+
          radpas = NINT( 86400./dtime/nbapp_rad)
 c
@@ -1717,9 +1578,5 @@
 cIM cf. AM 081204 END
 c
-         IF(ocean.NE.'force ') THEN
-          ok_ocean=.TRUE.
-         ENDIF
-c
-         CALL printflag( tabcntr0,radpas,ok_ocean,ok_oasis ,ok_journe,
+         CALL printflag( tabcntr0,radpas,ok_journe,
      ,                    ok_instan, ok_region )
 c
@@ -1780,16 +1637,16 @@
 c34EK
          IF (ok_orodr) THEN
-         DO i=1,klon
-         rugoro(i) = MAX(1.0e-05, zstd(i)*zsig(i)/2.0)
-         ENDDO
-         CALL SUGWD(klon,klev,paprs,pplay)
-         DO i=1,klon
-         zuthe(i)=0.
-         zvthe(i)=0.
-         if(zstd(i).gt.10.)then
-           zuthe(i)=(1.-zgam(i))*cos(zthe(i))
-           zvthe(i)=(1.-zgam(i))*sin(zthe(i))
-         endif
-         ENDDO
+           DO i=1,klon
+             rugoro(i) = MAX(1.0e-05, zstd(i)*zsig(i)/2.0)
+           ENDDO
+           CALL SUGWD(klon,klev,paprs,pplay)
+           DO i=1,klon
+             zuthe(i)=0.
+             zvthe(i)=0.
+             if(zstd(i).gt.10.)then
+               zuthe(i)=(1.-zgam(i))*cos(zthe(i))
+               zvthe(i)=(1.-zgam(i))*sin(zthe(i))
+             endif
+           ENDDO
          ENDIF
 c
@@ -1851,18 +1708,5 @@
          ecrit_tra = ecrit_tra * un_jour
 cIM 030306 END
-c
-c Initialiser le couplage si necessaire
-c
-      npas = 0
-      nexca = 0
-      if (ocean == 'couple') then
-        npas = itaufin/ iphysiq
-        nexca = 86400 / dtime
-        write(lunout,*)' ##### Ocean couple #####'
-        write(lunout,*)' Valeurs des pas de temps'
-        write(lunout,*)' npas = ', npas
-        write(lunout,*)' nexca = ', nexca
-      endif        
-c
+
       capemaxcels = 't_max(X)'
       t2mincels = 't_min(X)'
@@ -2142,28 +1986,5 @@
 C
       END IF 
-C
-c
-c Appeler la diffusion verticale (programme de couche limite)
-c
-      DO i = 1, klon
-c       if (.not. ok_veget) then
-c          frugs(i,is_ter) = SQRT(frugs(i,is_ter)**2+rugoro(i)**2)
-c       endif 
-c         frugs(i,is_lic) = rugoro(i)
-c         frugs(i,is_oce) = rugmer(i)
-c         frugs(i,is_sic) = 0.001
-         zxrugs(i) = 0.0
-      ENDDO
-      DO nsrf = 1, nbsrf
-      DO i = 1, klon
-c         frugs(i,nsrf) = MAX(frugs(i,nsrf),0.001)
-        frugs(i,nsrf) = MAX(frugs(i,nsrf),0.000015)
-      ENDDO
-      ENDDO
-      DO nsrf = 1, nbsrf
-      DO i = 1, klon
-            zxrugs(i) = zxrugs(i) + frugs(i,nsrf)*pctsrf(i,nsrf)
-      ENDDO
-      ENDDO
+
 c
 C calculs necessaires au calcul de l'albedo dans l'interface
@@ -2176,41 +1997,4 @@
         rmu0 = -999.999
       ENDIF
-c
-C     Calcul de l'abedo moyen par maille
-      albsol(:)=0.
-      albsollw(:)=0.
-      DO nsrf = 1, nbsrf
-      DO i = 1, klon
-         albsol(i) = albsol(i) + falbe(i,nsrf) * pctsrf(i,nsrf)
-         albsollw(i) = albsollw(i) + falblw(i,nsrf) * pctsrf(i,nsrf)
-      ENDDO
-      ENDDO
-C
-C     Repartition sous maille des flux LW et SW
-C Modif OM+PASB+JLD
-C Repartition du longwave par sous-surface linearisee
-Cn
-
-       DO nsrf = 1, nbsrf
-       DO i = 1, klon
-c@$$        fsollw(i,nsrf) = sollwdown(i) - RSIGMA*ftsol(i,nsrf)**4
-c@$$        fsollw(i,nsrf) = sollw(i)
-         fsollw(i,nsrf) = sollw(i)
-     $      + 4.0*RSIGMA*ztsol(i)**3 * (ztsol(i)-ftsol(i,nsrf))
-         fsolsw(i,nsrf) = solsw(i)*(1.-falbe(i,nsrf))/(1.-albsol(i))
-       ENDDO
-       ENDDO
-      
-cYM   !!!!!!!!!!!!!!!!!!!!!!!!!!!!
-cYM         Attention verrue
-cYM    ---> A supprimer plus tard       
-cYM         pour etre integre dans
-cYM         ORCHIDEE       
-      DO i = 1, klon
-        sollwdown(i)=sollw(i)+RSIGMA*ztsol(i)**4
-      ENDDO
-cYM  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!      
-      
-      fder = dlw
 
       if (mydebug) then
@@ -2220,70 +2004,53 @@
 	call writefield_phy('q_seri',q_seri,llm)
       endif
-  
-      IF (check) THEN
-       amn=MIN(tslab(1),1000.)
-       amx=MAX(tslab(1),-1000.)
-       DO i=2, klon
-        amn=MIN(tslab(i),amn)
-        amx=MAX(tslab(i),amx)
-       ENDDO
-c
-       PRINT*,' debut avant clqh min max tslab',amn,amx
-      ENDIF !(check) THEN
-c
-      CALL clmain(dtime,itap,date0,pctsrf,pctsrf_new,
-     e            t_seri,q_seri,u_seri,v_seri,
-     e            julien, rmu0, co2_ppm, 
-     e            ok_veget, ocean, npas, nexca, ftsol,
-     $            soil_model,cdmmax, cdhmax,
-     $            ksta, ksta_ter, ok_kzmin, ftsoil, qsol, 
-cIM BAD    $            paprs,pplay,radsol, fsnow,fqsurf,fevap,falbe,falblw,
-     $            paprs,pplay, fsnow,fqsurf,fevap,falbe,falblw,
-     $            fluxlat,
-     e            rain_fall, snow_fall,
-     e            fsolsw, fsollw, sollwdown, fder,
-     e            rlon, rlat, cuphy, cvphy, frugs,
-     e            debut, lafin, agesno,rugoro ,
-     s            d_t_vdf,d_q_vdf,d_u_vdf,d_v_vdf,d_ts,
-     s            fluxt,fluxq,fluxu,fluxv,cdragh,cdragm,
-     s            q2,
-     s            dsens, devap,
-     s            ycoefh,yu1,yv1, t2m, q2m, u10m, v10m,
-     s            pblh,capCL,oliqCL,cteiCL,pblT,
-     s            therm,trmb1,trmb2,trmb3,plcl,
-     s            fqcalving, fqfonte,ffonte, run_off_lic_0,
-cIM "slab" ocean
-     s            fluxo, fluxg, tslab, seaice) 
-c
-CXXX PB
-CXXX Incrementation des flux
-CXXX
-
-      zxfluxt=0.
-      zxfluxq=0.
-      zxfluxu=0.
-      zxfluxv=0.
-      DO nsrf = 1, nbsrf
-        DO k = 1, klev
-          DO i = 1, klon
-            zxfluxt(i,k) = zxfluxt(i,k) + 
-     $          fluxt(i,k,nsrf) * pctsrf( i, nsrf)
-            zxfluxq(i,k) = zxfluxq(i,k) + 
-     $          fluxq(i,k,nsrf) * pctsrf( i, nsrf)
-            zxfluxu(i,k) = zxfluxu(i,k) + 
-     $          fluxu(i,k,nsrf) * pctsrf( i, nsrf)
-            zxfluxv(i,k) = zxfluxv(i,k) + 
-     $          fluxv(i,k,nsrf) * pctsrf( i, nsrf)
-          END DO 
-        END DO 
-      END DO 
-      DO i = 1, klon
-         sens(i) = - zxfluxt(i,1) ! flux de chaleur sensible au sol
-c         evap(i) = - fluxq(i,1) ! flux d'evaporation au sol
-         evap(i) = - zxfluxq(i,1) ! flux d'evaporation au sol
-         fder(i) = dlw(i) + dsens(i) + devap(i)
-      ENDDO
-
-
+
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c Appel au pbl_surface : Planetary Boudary Layer et Surface
+c Cela implique tous les interactions des sous-surfaces et la partie diffusion 
+c turbulent du couche limit. 
+c 
+c Certains varibales de sorties de pbl_surface sont utiliser que pour 
+c ecriture des fihiers hist_XXXX.nc, ces sont :
+c   qsol,      zq2m,      s_pblh,  s_lcl,
+c   s_capCL,   s_oliqCL,  s_cteiCL,s_pblT,
+c   s_therm,   s_trmb1,   s_trmb2, s_trmb3,
+c   zxrugs,    zu10m,     zv10m,   fder,
+c   zxqsurf,   rh2m,      zxfluxu, zxfluxv,
+c   frugs,     agesno,    fsollw,  fsolsw,
+c   d_ts,      fevap,     fluxlat, t2m,
+c   wfbils,    wfbilo,    fluxt,   fluxu, fluxv,
+c
+c Certains ne sont pas utiliser du tout : 
+c   dsens, devap, zxsnow, zxfluxt, zxfluxq, q2m, fluxq
+c
+      CALL pbl_surface( 
+     e     dtime,     date0,     itap,    julien,
+     e     debut,     lafin,
+     e     rlon,      rlat,      rugoro,  rmu0,     
+     e     rain_fall, snow_fall, solsw,   sollw,    
+     e     t_seri,    q_seri,    u_seri,  v_seri,   
+     e     pplay,     paprs,     pctsrf,            
+     +     ftsol,     falbe,     falblw,  u10m,   v10m,
+     s     sollwdown, cdragh,    cdragm,  yu1,    yv1,
+     s     albsol,    albsollw,  sens,    evap,  
+     s     zxtsol,    zxfluxlat, zt2m,    qsat2m, 
+     s     d_t_vdf,   d_q_vdf,   d_u_vdf, d_v_vdf,
+     s     ycoefh,    pctsrf_new,                
+     d     qsol,      zq2m,      s_pblh,  s_lcl,
+     d     s_capCL,   s_oliqCL,  s_cteiCL,s_pblT,
+     d     s_therm,   s_trmb1,   s_trmb2, s_trmb3,
+     d     zxrugs,    zu10m,     zv10m,   fder,
+     d     zxqsurf,   rh2m,      zxfluxu, zxfluxv,
+     d     frugs,     agesno,    fsollw,  fsolsw,
+     d     d_ts,      fevap,     fluxlat, t2m,
+     d     wfbils,    wfbilo,    fluxt,   fluxu,  fluxv,
+     -     dsens,     devap,     zxsnow,
+     -     zxfluxt,   zxfluxq,   q2m,     fluxq )
+c
+c
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+      pctsrf(:,:) = pctsrf_new(:,:)
+      
       DO k = 1, klev
       DO i = 1, klon
@@ -2303,7 +2070,6 @@
 
 
-cIM
       IF (ip_ebil_phy.ge.2) THEN 
-        ztit='after clmain'
+        ztit='after surface_main'
         CALL diagetpq(airephy,ztit,ip_ebil_phy,2,2,dtime
      e      , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay
@@ -2315,127 +2081,5 @@
      s      , fs_bound, fq_bound )
       END IF 
-C
-c
-c Incrementer la temperature du sol
-c
-      DO i = 1, klon
-         zxtsol(i) = 0.0
-         zxfluxlat(i) = 0.0
-c
-         zt2m(i) = 0.0
-         zq2m(i) = 0.0
-         zu10m(i) = 0.0
-         zv10m(i) = 0.0
-cIM cf JLD ??
-         zxffonte(i) = 0.0
-         zxfqcalving(i) = 0.0
-	 zxfqfonte(i) = 0.0
-cIM cf. AM 081204 BEG
-c
-         s_pblh(i) = 0.0 
-         s_lcl(i) = 0.0 
-         s_capCL(i) = 0.0
-         s_oliqCL(i) = 0.0
-         s_cteiCL(i) = 0.0
-         s_pblT(i) = 0.0
-         s_therm(i) = 0.0
-         s_trmb1(i) = 0.0
-         s_trmb2(i) = 0.0
-         s_trmb3(i) = 0.0
-c
-         IF ( abs( pctsrf(i, is_ter) + pctsrf(i, is_lic) + 
-     $       pctsrf(i, is_oce) + pctsrf(i, is_sic)  - 1.) .GT. EPSFRA) 
-     $       THEN 
-             WRITE(*,*) 'physiq : pb sous surface au point ', i, 
-     $           pctsrf(i, 1 : nbsrf)
-         ENDIF 
-      ENDDO
-      DO nsrf = 1, nbsrf
-        DO i = 1, klon
-c        IF (pctsrf(i,nsrf) .GE. EPSFRA) THEN 
-            ftsol(i,nsrf) = ftsol(i,nsrf) + d_ts(i,nsrf)
-cIM cf. JLD
-            wfbils(i,nsrf) = ( fsolsw(i,nsrf) + fsollw(i,nsrf)
-     $         + fluxt(i,1,nsrf) + fluxlat(i,nsrf) ) * pctsrf(i,nsrf)
-cIM
-            wfbilo(i,nsrf) = ( fevap(i,nsrf) - 
-     $      (rain_fall(i) + snow_fall(i)) ) * pctsrf(i,nsrf)
-            zxtsol(i) = zxtsol(i) + ftsol(i,nsrf)*pctsrf(i,nsrf)
-            zxfluxlat(i) = zxfluxlat(i) + fluxlat(i,nsrf)*pctsrf(i,nsrf)
-cccIM
-            zt2m(i) = zt2m(i) + t2m(i,nsrf)*pctsrf(i,nsrf)
-            zq2m(i) = zq2m(i) + q2m(i,nsrf)*pctsrf(i,nsrf)
-            zu10m(i) = zu10m(i) + u10m(i,nsrf)*pctsrf(i,nsrf)
-            zv10m(i) = zv10m(i) + v10m(i,nsrf)*pctsrf(i,nsrf)
-cIM cf JLD ??
-            zxffonte(i) = zxffonte(i) + ffonte(i,nsrf)*pctsrf(i,nsrf)
-            zxfqcalving(i) = zxfqcalving(i) + 
-     .                      fqcalving(i,nsrf)*pctsrf(i,nsrf)
-            zxfqfonte(i) = zxfqfonte(i) + 
-     .                      fqfonte(i,nsrf)*pctsrf(i,nsrf)
-cIM cf. AM 081204 BEG
-            s_pblh(i) = s_pblh(i) + pblh(i,nsrf)*pctsrf(i,nsrf)
-            s_lcl(i) = s_lcl(i) + plcl(i,nsrf)*pctsrf(i,nsrf)
-            s_capCL(i) = s_capCL(i) + capCL(i,nsrf) *pctsrf(i,nsrf)
-            s_oliqCL(i) = s_oliqCL(i) + oliqCL(i,nsrf) *pctsrf(i,nsrf)
-            s_cteiCL(i) = s_cteiCL(i) + cteiCL(i,nsrf) *pctsrf(i,nsrf)
-            s_pblT(i) = s_pblT(i) + pblT(i,nsrf) *pctsrf(i,nsrf)
-            s_therm(i) = s_therm(i) + therm(i,nsrf) *pctsrf(i,nsrf)
-            s_trmb1(i) = s_trmb1(i) + trmb1(i,nsrf) *pctsrf(i,nsrf)
-            s_trmb2(i) = s_trmb2(i) + trmb2(i,nsrf) *pctsrf(i,nsrf)
-            s_trmb3(i) = s_trmb3(i) + trmb3(i,nsrf) *pctsrf(i,nsrf)
-c        ENDIF 
-        ENDDO
-      ENDDO
-
-      IF (check) THEN
-       amn=MIN(ftsol(1,is_ter),1000.)
-       amx=MAX(ftsol(1,is_ter),-1000.)
-       DO i=2, klon
-        amn=MIN(ftsol(i,is_ter),amn)
-        amx=MAX(ftsol(i,is_ter),amx)
-       ENDDO
-c
-       PRINT*,' debut apres d_ts min max ftsol',itap,amn,amx
-      ENDIF !(check) THEN
-c
-c Si une sous-fraction n'existe pas, elle prend la temp. moyenne
-c
-      DO nsrf = 1, nbsrf
-        DO i = 1, klon
-          IF (pctsrf(i,nsrf) .LT. epsfra.OR.t2m(i,nsrf).EQ.0.) THEN
-           ftsol(i,nsrf) = zxtsol(i)
-           t2m(i,nsrf) = zt2m(i)
-           q2m(i,nsrf) = zq2m(i)
-           u10m(i,nsrf) = zu10m(i)
-           v10m(i,nsrf) = zv10m(i)
-           ffonte(i,nsrf) = zxffonte(i)
-           fqcalving(i,nsrf) = zxfqcalving(i)
-           fqfonte(i,nsrf) = zxfqfonte(i)
-           pblh(i,nsrf)=s_pblh(i)
-           plcl(i,nsrf)=s_lcl(i)
-           capCL(i,nsrf)=s_capCL(i)
-           oliqCL(i,nsrf)=s_oliqCL(i) 
-           cteiCL(i,nsrf)=s_cteiCL(i)
-           pblT(i,nsrf)=s_pblT(i)
-           therm(i,nsrf)=s_therm(i)
-           trmb1(i,nsrf)=s_trmb1(i)
-           trmb2(i,nsrf)=s_trmb2(i)
-           trmb3(i,nsrf)=s_trmb3(i)
-          ENDIF
-        ENDDO
-      ENDDO
-c
-c Calculer la derive du flux infrarouge
-c
-cXXX      DO nsrf = 1, nbsrf
-      DO i = 1, klon
-cXXX        IF (pctsrf(i,nsrf) .GE. EPSFRA) THEN 
-            dlw(i) = - 4.0*RSIGMA*zxtsol(i)**3 
-cXXX     .          *(ftsol(i,nsrf)-zxtsol(i))
-cXXX     .          *pctsrf(i,nsrf)
-cXXX        ENDIF 
-cXXX      ENDDO
-      ENDDO
+
 c
 c Appeler la convection (au choix)
@@ -2473,5 +2117,5 @@
       ELSE IF (iflag_con.EQ.2) THEN
       CALL conflx(dtime, paprs, pplay, t_seri, q_seri,
-     e            conv_t, conv_q, zxfluxq(1,1), omega,
+     e            conv_t, conv_q, -evap, omega,
      s            d_t_con, d_q_con, rain_con, snow_con,
      s            pmfu, pmfd, pen_u, pde_u, pen_d, pde_d,
@@ -2956,34 +2600,5 @@
       ENDDO
       ENDDO
-c
-cIM Calculer l'humidite relative a 2m (rh2m) pour diagnostique
-cIM ajout dependance type surface
-      DO i = 1, klon
-       rh2m(i)=0.
-       qsat2m(i)=0.
-      DO nsrf=1, nbsrf
-         zx_t1(i,nsrf) = t2m(i,nsrf)
-         IF (thermcep) THEN
-            zdelta1(i,nsrf) = MAX(0.,SIGN(1.,rtt-zx_t1(i,nsrf)))
-            zx_qs1(i,nsrf)  = r2es * 
-     $      FOEEW(zx_t1(i,nsrf),zdelta1(i,nsrf))/paprs(i,1)
-            zx_qs1(i,nsrf)  = MIN(0.5,zx_qs1(i,nsrf))
-            zcor1(i,nsrf)   = 1./(1.-retv*zx_qs1(i,nsrf))
-            zx_qs1(i,nsrf)  = zx_qs1(i,nsrf)*zcor1(i,nsrf)
-         ELSE
-c
-           IF (zx_t.LT.RTT) THEN
-              zx_qs = qsats(zx_t)/paprs(i,1)
-           ELSE
-              zx_qs = qsatl(zx_t)/paprs(i,1)
-           ENDIF
-         ENDIF
-       zx_rh2m(i,nsrf) = q2m(i,nsrf)/zx_qs1(i,nsrf)
-       zx_qsat2m(i,nsrf)=zx_qs1(i,nsrf)
-       rh2m(i) = rh2m(i)+zx_rh2m(i,nsrf)*pctsrf(i,nsrf)
-       qsat2m(i)=qsat2m(i)+zx_qsat2m(i,nsrf)*pctsrf(i,nsrf)
-      ENDDO !nsrf
-      ENDDO
-c
+
 cIM Calcul temp.potentielle a 2m (tpot) et temp. potentielle 
 c   equivalente a 2m (tpote) pour diagnostique
@@ -3023,4 +2638,6 @@
 #endif
 
+           zxsnow_dummy(:) = 0.0
+
            CALL chemhook_begin (calday,
 #if defined(INCA) && !defined(INCA_CH4) && !defined(INCA_NMHC) && !defined(INCA_AER)
@@ -3042,5 +2659,5 @@
      $                          q_seri,
      $                          zxtsol,
-     $                          zxsnow,
+     $                          zxsnow_dummy,
      $                          solsw,
      $                          albsol,
@@ -3099,4 +2716,5 @@
 c
       IF (MOD(itaprad,radpas).EQ.0) THEN
+
       DO i = 1, klon
          albsol(i) = falbe(i,is_oce) * pctsrf(i,is_oce)
@@ -3172,25 +2790,5 @@
 c     .            agesno, ftsol,fqsurf,fsnow, ruis)
 c
-      DO i = 1, klon
-         zxqsurf(i) = 0.0
-         zxsnow(i) = 0.0
-      ENDDO
-      DO nsrf = 1, nbsrf
-      DO i = 1, klon
-         zxqsurf(i) = zxqsurf(i) + fqsurf(i,nsrf)*pctsrf(i,nsrf)
-         zxsnow(i) = zxsnow(i) + fsnow(i,nsrf)*pctsrf(i,nsrf)
-      ENDDO
-      ENDDO
-c
-c Si une sous-fraction n'existe pas, elle prend la valeur moyenne
-c
-cXXX      DO nsrf = 1, nbsrf
-cXXX      DO i = 1, klon
-cXXX         IF (pctsrf(i,nsrf).LT.epsfra) THEN
-cXXX            fqsurf(i,nsrf) = zxqsurf(i)
-cXXX            fsnow(i,nsrf) = zxsnow(i)
-cXXX         ENDIF
-cXXX      ENDDO
-cXXX      ENDDO
+
 c
 c Calculer le bilan du sol et la derive de temperature (couplage)
@@ -3493,5 +3091,4 @@
      $                        annee_ref,
      $                        day_ini,
-     $                        airephy,      
 #ifdef INCA_AER
      $                        xjour,
@@ -3558,4 +3155,22 @@
 c=============================================================
 #ifdef CPP_IOIPSL
+ 
+c Recupere des varibles calcule dans differents modules
+c pour ecriture dans histxxx.nc 
+
+      ! Get some variables from module mod_fonte_neige
+      CALL fonte_neige_get_vars(pctsrf, 
+     .     zxfqcalving, zxfqfonte, zxffonte)
+
+      IF (ocean == 'slab') THEN
+         ! Get some variables from module oceanslab
+         CALL ocean_slab_get_vars(tslab, seaice, fluxo, fluxg)
+      ELSEIF (ocean == 'couple') THEN
+         ! Get some variables from module oceancpl
+         CALL ocean_cpl_get_vars(fluxo, fluxg)
+      ELSE 
+         ! Get some variables from module oceanforced
+         CALL ocean_forced_get_vars(fluxo, fluxg)
+      ENDIF
 
 #ifdef histhf
@@ -3595,18 +3210,16 @@
 c====================================================================
 c
+      
+
       IF (lafin) THEN
          itau_phy = itau_phy + itap
-ccc         IF (ok_oasis) CALL quitcpl
-         CALL phyredem ("restartphy.nc",dtime,radpas,
-     .      rlat, rlon, pctsrf, ftsol, ftsoil,
-cIM "slab" ocean
-     .      tslab, seaice, 
-     .      fqsurf, qsol,
-     .      fsnow, falbe,falblw, fevap, rain_fall, snow_fall,
-cIM  .      solsw, sollwdown,dlw,
-     .      solsw, sollw,dlw,
-     .      radsol,frugs,agesno,
+         CALL phyredem ("restartphy.nc",dtime,radpas,ocean,
+     .      rlat, rlon, pctsrf, ftsol,
+     .      falbe,falblw, rain_fall, 
+     .      snow_fall,
+     .      solsw, sollw,
+     .      radsol,
      .      zmea,zstd,zsig,zgam,zthe,zpic,zval,rugoro,
-     .      t_ancien, q_ancien, rnebcon, ratqs, clwcon,run_off_lic_0)
+     .      t_ancien, q_ancien, rnebcon, ratqs, clwcon)
       ENDIF
       
Index: LMDZ4/trunk/libf/phylmd/phytrac.F
===================================================================
--- LMDZ4/trunk/libf/phylmd/phytrac.F	(revision 781)
+++ LMDZ4/trunk/libf/phylmd/phytrac.F	(revision 782)
@@ -415,5 +415,6 @@
 
 
-          ecrit_tra = NINT(86400./pdtphys *ecritphy) 
+c jg: c'est ca qu'on veut?????           
+          ecrit_tra = FLOAT(NINT(86400./pdtphys *ecritphy)) 
           print*,'dans phytrac ',pdtphys,ecritphy,ecrit_tra
 
Index: LMDZ4/trunk/libf/phylmd/printflag.F
===================================================================
--- LMDZ4/trunk/libf/phylmd/printflag.F	(revision 781)
+++ LMDZ4/trunk/libf/phylmd/printflag.F	(revision 782)
@@ -2,5 +2,5 @@
 ! $Header$
 !
-       SUBROUTINE  printflag( tabcntr0, radpas, ok_ocean,ok_oasis,
+       SUBROUTINE  printflag( tabcntr0, radpas, 
      ,                        ok_journe,ok_instan,ok_region        )
 c
@@ -14,5 +14,5 @@
        LOGICAL cycle_diurn0,soil_model0,new_oliq0,ok_orodr0
        LOGICAL ok_orolf0,ok_limitvr0
-       LOGICAL ok_ocean,ok_oasis,ok_journe,ok_instan,ok_region
+       LOGICAL ok_journe,ok_instan,ok_region
        INTEGER radpas , radpas0
 c
@@ -53,7 +53,4 @@
 
        PRINT 8, radpas
-       PRINT 100
-
-       PRINT 5,  ok_ocean,ok_oasis
        PRINT 100
 
@@ -138,8 +135,4 @@
      , l3,3x,',ok_region = ',l3,3x,5(1H*) )
 
- 5    FORMAT(2x,5(1H*),'      ok_ocean = ',l3,6x,' , ok_oasis = ',
-     , l3,14x,5(1H*) )
-
-
  7     FORMAT(2x,5(1H*),15x,'      ok_limitvrai   = ',l3,16x,5(1h*) )
 
Index: LMDZ4/trunk/libf/phylmd/readsulfate.F
===================================================================
--- LMDZ4/trunk/libf/phylmd/readsulfate.F	(revision 781)
+++ LMDZ4/trunk/libf/phylmd/readsulfate.F	(revision 782)
@@ -41,5 +41,5 @@
 c Input:
 c ------
-      REAL*8  r_day                   ! Day of integration
+      REAL  r_day                   ! Day of integration
       LOGICAL first                 ! First timestep 
                                     ! (and therefore initialization necessary)
@@ -47,8 +47,7 @@
 c Output:      
 c -------     
-      REAL*8  sulfate_p(klon_omp,klev)
-      REAL*8  sulfate (klon, klev)  ! Mass of sulfate (monthly mean data, 
+      REAL  sulfate_p(klon_omp,klev)
+      REAL  sulfate (klon, klev)  ! Mass of sulfate (monthly mean data, 
                                   !  from file) [ug SO4/m3]
-      REAL*8,SAVE,ALLOCATABLE :: sulfate_mpi(:,:) 
 c      
 c Local Variables:
@@ -58,19 +57,13 @@
       parameter (ny=jjm+1)
       
-      INTEGER ismaller
 CJLD      INTEGER idec1, idec2 ! The two decadal data read ini
       CHARACTER*4 cyear
       
       INTEGER im, day1, day2, im2
-      REAL*8 so4_1(iim, jjm+1, klev, 12)
-      REAL*8 so4_2(iim, jjm+1, klev, 12)   ! The sulfate distributions
-      
-cym      REAL*8 so4(klon, klev, 12)  ! SO4 in right dimension
-cym      SAVE so4
-cym      REAL*8 so4_out(klon, klev)
-cym      SAVE so4_out
-
-      REAL*8,allocatable,save :: so4(:, :, :)  ! SO4 in right dimension
-      REAL*8,allocatable,save :: so4_out(:, :)
+      REAL so4_1(iim, jjm+1, klev, 12)
+      REAL so4_2(iim, jjm+1, klev, 12)   ! The sulfate distributions
+      
+      REAL, allocatable,save :: so4(:, :, :)  ! SO4 in right dimension
+      REAL, allocatable,save :: so4_out(:, :)
 c$OMP THREADPRIVATE(so4,so4_out)
       
@@ -290,5 +283,5 @@
       
 c$OMP END MASTER
-      call Scatter(real(sulfate),real(sulfate_p))            
+      call Scatter(sulfate,sulfate_p)            
 
       RETURN
@@ -333,10 +326,9 @@
 #include "chem.h"      
 #include "dimensions.h"      
-cym#include "dimphy.h"      
 #include "temps.h"      
 c 
 c Input:
 c ------
-      REAL*8  r_day                   ! Day of integration
+      REAL  r_day                   ! Day of integration
       LOGICAL first                 ! First timestep 
                                     ! (and therefore initialization necessary)
@@ -344,7 +336,7 @@
 c Output:      
 c -------     
-      REAL*8  pi_sulfate_p (klon_omp, klev)  
+      REAL  pi_sulfate_p (klon_omp, klev)  
                                  
-      REAL*8  pi_sulfate (klon, klev)  ! Number conc. sulfate (monthly mean data, 
+      REAL  pi_sulfate (klon, klev)  ! Number conc. sulfate (monthly mean data, 
                                   !  from fil
 c      
@@ -355,14 +347,9 @@
       parameter (ny=jjm+1)
       
-      INTEGER im, day1, day2, im2, ismaller
-      REAL*8 pi_so4_1(iim, jjm+1, klev, 12)
-
-cym      REAL*8 pi_so4(klon, klev, 12)  ! SO4 in right dimension
-cym      SAVE pi_so4
-cym      REAL*8 pi_so4_out(klon, klev)
-cym      SAVE pi_so4_out
-
-      REAL*8,allocatable,save :: pi_so4(:, :, :)  ! SO4 in right dimension
-      REAL*8,allocatable,save :: pi_so4_out(:, :)
+      INTEGER im, day1, day2, im2
+      REAL pi_so4_1(iim, jjm+1, klev, 12)
+
+      REAL, allocatable,save :: pi_so4(:, :, :)  ! SO4 in right dimension
+      REAL, allocatable,save :: pi_so4_out(:, :)
 c$OMP THREADPRIVATE(pi_so4,pi_so4_out)            
       
@@ -530,5 +517,5 @@
       
 c$OMP END MASTER
-      call Scatter(real(pi_sulfate),real(pi_sulfate_p))            
+      call Scatter(pi_sulfate,pi_sulfate_p)            
 
       RETURN
@@ -563,7 +550,6 @@
       
             
-      REAL*8 so4mth(iim, ny, klev)
-c      REAL*8 so4mth(klev, ny, iim)
-      REAL*8 so4(iim, ny, klev, 12)
+      REAL so4mth(iim, ny, klev)
+      REAL so4(iim, ny, klev, 12)
 
  
@@ -609,8 +595,12 @@
          STATUS = NF_INQ_VARID (NCID, cvar, VARID)
          write (*,*) ncid,imth,cvar, varid
-c         STATUS = NF_INQ_VARID (NCID, VARMONTHS(i), VARID(i))
+
          IF (STATUS .NE. NF_NOERR) write (*,*) 'err in read ',status      
-         STATUS = NF_GET_VARA_DOUBLE
-     .    (NCID, VARID, START,COUNT, so4mth)
+
+#ifdef NC_DOUBLE
+         status = NF_GET_VAR_DOUBLE(NCID, VARID, START, COUNT, so4mth)
+#else
+         status = NF_GET_VAR_REAL(NCID, VARID, START, COUNT, so4mth)
+#endif
          IF (STATUS .NE. NF_NOERR) write (*,*) 'err in read data',status
          
@@ -623,5 +613,4 @@
                   endif
                   so4(i,j,k,imth)=so4mth(i,j,k)
-c                  so4(i,j,k,imth)=so4mth(k,j,i)
                ENDDO
             ENDDO
@@ -630,4 +619,7 @@
       
       STATUS = NF_CLOSE(NCID)
+      IF (STATUS .NE. NF_NOERR) write (*,*) 'err in closing file',status
+
+
       END ! subroutine getso4fromfile
       
Index: LMDZ4/trunk/libf/phylmd/write_histday.h
===================================================================
--- LMDZ4/trunk/libf/phylmd/write_histday.h	(revision 781)
+++ LMDZ4/trunk/libf/phylmd/write_histday.h	(revision 782)
@@ -548,9 +548,9 @@
 c
       DO i=1, klon
-       zx_tmp_2d(i)=MIN(100.,rh2m(i)*100.)
+       zx_tmp_fi2d(i)=MIN(100.,rh2m(i)*100.)
       ENDDO
 c
 cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1, zx_tmp_2d,zx_tmp_2d)
-      CALL histwrite_phy(nid_day,"rh2m",itau_w,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"rh2m",itau_w,zx_tmp_fi2d)
 c
 cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1, qsat2m,zx_tmp_2d)
Index: LMDZ4/trunk/libf/phylmd/write_histhf.h
===================================================================
--- LMDZ4/trunk/libf/phylmd/write_histhf.h	(revision 781)
+++ LMDZ4/trunk/libf/phylmd/write_histhf.h	(revision 782)
@@ -332,6 +332,7 @@
 cym      CALL gr_fi_ecrit(nbteta,klon,iim,jjmp1,PVteta,zx_tmp_3dte)
       DO k=1, nbteta
+       zx_tmp_fi2d(1:klon) = PVteta(1:klon,k)
        CALL histwrite_phy(nid_hf,"PV"//ctetaSTD(k),
-     .      itau_w,PVteta)
+     .      itau_w,zx_tmp_fi2d)
       ENDDO !k=1, nbteta
       ENDIF
