Index: /LMDZ4/trunk/libf/phylmd/buffer_mod.F90
===================================================================
--- /LMDZ4/trunk/libf/phylmd/buffer_mod.F90	(revision 1001)
+++ /LMDZ4/trunk/libf/phylmd/buffer_mod.F90	(revision 1001)
@@ -0,0 +1,86 @@
+MODULE buffer_mod
+
+PRIVATE
+  REAL,PARAMETER :: grow_factor=1.5
+
+  INTEGER, POINTER, SAVE :: buffer_i(:)
+  INTEGER,SAVE :: size_buffer_i = 0
+!$OMP THREADPRIVATE(buffer_i,size_buffer_i)
+
+  REAL,POINTER,SAVE      :: buffer_r(:)
+  INTEGER,SAVE :: size_buffer_r = 0 
+!$OMP THREADPRIVATE(buffer_r,size_buffer_r)
+  
+  LOGICAL,POINTER,SAVE   :: buffer_l(:)
+  INTEGER,SAVE :: size_buffer_l = 0
+!$OMP THREADPRIVATE(buffer_l,size_buffer_l)
+
+  CHARACTER,POINTER,SAVE :: buffer_c(:)
+  INTEGER,SAVE :: size_buffer_c = 0
+!$OMP THREADPRIVATE(buffer_c,size_buffer_c)
+
+INTERFACE get_buffer
+  MODULE PROCEDURE get_buffer_i, get_buffer_r, get_buffer_l, get_buffer_c
+END INTERFACE
+  
+PUBLIC :: get_buffer
+
+CONTAINS
+
+  SUBROUTINE get_buffer_i(buff,buff_size)
+  IMPLICIT NONE
+    INTEGER,POINTER    :: buff(:)
+    INTEGER,INTENT(IN) :: buff_size 
+
+    IF (buff_size>size_buffer_i) THEN
+      DEALLOCATE(buffer_i)
+      size_buffer_i=MAX(2,INT(size_buffer_i*grow_factor))
+      ALLOCATE(buffer_i(size_buffer_i))
+    ENDIF
+    
+    buff=>buffer_i
+  END SUBROUTINE get_buffer_i
+
+  SUBROUTINE get_buffer_r(buff,buff_size)
+  IMPLICIT NONE
+    REAL,POINTER       :: buff(:)
+    INTEGER,INTENT(IN) :: buff_size 
+
+    IF (buff_size>size_buffer_r) THEN
+      DEALLOCATE(buffer_r)
+      size_buffer_r=MAX(2,INT(size_buffer_r*grow_factor))
+      ALLOCATE(buffer_r(size_buffer_r))
+    ENDIF
+    
+    buff=>buffer_r
+  END SUBROUTINE get_buffer_r
+
+  SUBROUTINE get_buffer_l(buff,buff_size)
+  IMPLICIT NONE
+    LOGICAL,POINTER    :: buff(:)
+    INTEGER,INTENT(IN) :: buff_size 
+
+    IF (buff_size>size_buffer_l) THEN
+      DEALLOCATE(buffer_l)
+      size_buffer_l=MAX(2,INT(size_buffer_l*grow_factor))
+      ALLOCATE(buffer_l(size_buffer_l))
+    ENDIF
+    
+    buff=>buffer_l
+  END SUBROUTINE get_buffer_l
+  
+  SUBROUTINE get_buffer_c(buff,buff_size)
+  IMPLICIT NONE
+    CHARACTER,POINTER  :: buff(:)
+    INTEGER,INTENT(IN) :: buff_size 
+
+    IF (buff_size>size_buffer_c) THEN
+      DEALLOCATE(buffer_c)
+      size_buffer_c=MAX(2,INT(size_buffer_c*grow_factor))
+      ALLOCATE(buffer_c(size_buffer_c))
+    ENDIF
+    
+    buff=>buffer_c
+  END SUBROUTINE get_buffer_c
+  
+END MODULE buffer_mod
Index: /LMDZ4/trunk/libf/phylmd/clesphys.h
===================================================================
--- /LMDZ4/trunk/libf/phylmd/clesphys.h	(revision 1000)
+++ /LMDZ4/trunk/libf/phylmd/clesphys.h	(revision 1001)
@@ -48,4 +48,6 @@
        INTEGER :: ip_ebil_phy, iflag_rrtm
        LOGICAL ok_slab_sicOBS
+       LOGICAL :: ok_strato
+       LOGICAL :: ok_hines
 
        COMMON/clesphys/cycle_diurne, soil_model, new_oliq,              &
@@ -62,5 +64,5 @@
      &     , freq_ISCCP, ecrit_ISCCP, ip_ebil_phy                       &
      &     , ok_slab_sicOBS, ok_lic_melt, cvl_corr                      &
-     &     , qsol0, iflag_rrtm
+     &     , qsol0, iflag_rrtm, ok_strato,ok_hines
      
 !$OMP THREADPRIVATE(/clesphys/)
Index: /LMDZ4/trunk/libf/phylmd/conf_phys.F90
===================================================================
--- /LMDZ4/trunk/libf/phylmd/conf_phys.F90	(revision 1000)
+++ /LMDZ4/trunk/libf/phylmd/conf_phys.F90	(revision 1001)
@@ -1,2 +1,3 @@
+
 !
 ! $Header$
@@ -120,11 +121,12 @@
   LOGICAL,SAVE :: ok_lic_melt_omp
 !
-!
-    LOGICAL,SAVE :: cycle_diurne_omp,soil_model_omp,new_oliq_omp
-    LOGICAL,SAVE :: ok_orodr_omp, ok_orolf_omp, ok_limitvrai_omp
-    INTEGER, SAVE :: nbapp_rad_omp, iflag_con_omp
-!
-
-!$OMP MASTER
+  LOGICAL,SAVE :: cycle_diurne_omp,soil_model_omp,new_oliq_omp
+  LOGICAL,SAVE :: ok_orodr_omp, ok_orolf_omp, ok_limitvrai_omp
+  INTEGER, SAVE :: nbapp_rad_omp, iflag_con_omp
+  LOGICAL,SAVE :: ok_strato_omp
+  LOGICAL,SAVE :: ok_hines_omp
+!
+
+!$OMP MASTER 
 !Config Key  = OCEAN 
 !Config Desc = Type d'ocean
@@ -1094,4 +1096,20 @@
   call getin('alphas',alphas_omp)
 
+!Config key = ok_strato
+!Config  Desc = activation de la version strato
+!Config  Def  = .FALSE.
+!Config  Help = active la version stratosphérique de LMDZ de F. Lott
+
+  ok_strato_omp=.FALSE.
+  CALL getin('ok_strato',ok_strato_omp)
+      
+!Config  key = ok_hines
+!Config  Desc = activation de la parametrisation de hines
+!Config  Def  = .FALSE.
+!Config  Help = Clefs controlant la parametrization de Hines
+!               Et la sponge layer (Runs Stratospheriques)
+
+  ok_hines_omp=.FALSE.
+  CALL getin('ok_hines',ok_hines_omp)
 
 
@@ -1210,6 +1228,7 @@
     Fmax = Fmax_omp
     alphas = alphas_omp
-
-!$OMP MASTER
+    ok_strato = ok_strato_omp
+    ok_hines = ok_hines_omp
+    
 
 ! Attribution of new parmeters according to parameters in .def
@@ -1230,4 +1249,6 @@
        CALL abort_gcm('conf_phys','ocean not valid',1)
     END IF
+
+!$OMP MASTER
 
   write(numout,*)' ##############################################'
@@ -1327,4 +1348,7 @@
  & ecrit_hf, ecrit_day, ecrit_mth, ecrit_reg, ecrit_tra, ecrit_ISCCP
 
+  write(numout,*) 'ok_strato = ', ok_strato
+  write(numout,*) 'ok_hines = ',  ok_hines
+  
 !$OMP END MASTER
 
Index: /LMDZ4/trunk/libf/phylmd/cpl_mod.F90
===================================================================
--- /LMDZ4/trunk/libf/phylmd/cpl_mod.F90	(revision 1000)
+++ /LMDZ4/trunk/libf/phylmd/cpl_mod.F90	(revision 1001)
@@ -85,9 +85,9 @@
   !$OMP THREADPRIVATE(cpl_windsp2D)
   
-! variables for OPENMP parallelisation
+! variable for OPENMP parallelisation
+
   INTEGER,ALLOCATABLE,DIMENSION(:),SAVE :: knon_omp
   REAL,ALLOCATABLE,DIMENSION(:,:),SAVE ::  buffer_omp
   
-
 CONTAINS
 !
@@ -255,6 +255,6 @@
 
 !$OMP MASTER
-    ALLOCATE(knon_omp(0:omp_size-1)) 
-    ALLOCATE(buffer_omp(klon_mpi,0:omp_size-1))       
+  ALLOCATE(knon_omp(0:omp_size-1)) 
+  ALLOCATE(buffer_omp(klon_mpi,0:omp_size-1))       
 !$OMP END MASTER
 !$OMP BARRIER
@@ -311,6 +311,7 @@
        time_sec=(itime-1)*dtime
 #ifdef CPP_COUPLE
+    il_time_secs=(itime-1)*dtime
 !$OMP MASTER
-       CALL fromcpl(time_sec, tab_read_flds)
+    CALL fromcpl(il_time_secs, tab_read_flds)
 !$OMP END MASTER
 #endif
@@ -324,4 +325,5 @@
           END DO
        ENDIF
+
 
 ! Save each field in a 2D array. 
@@ -945,5 +947,5 @@
     REAL, DIMENSION(klon_mpi)                            :: rlon_mpi, rlat_mpi
 
-#ifdef CPP_PARA
+#ifdef CPP_MPI
     INCLUDE 'mpif.h'
     INTEGER, DIMENSION(MPI_STATUS_SIZE)                  :: status
@@ -1001,20 +1003,20 @@
     IF (is_omp_root) THEN
 
-       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
+      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
+#ifdef CPP_MPI
             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
+#ifdef CPP_MPI
             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)
@@ -1095,4 +1097,5 @@
 
 ! Transform the longitudes and latitudes on 2D arrays
+    
     CALL gather_omp(rlon,rlon_mpi)
     CALL gather_omp(rlat,rlat_mpi)
@@ -1162,6 +1165,7 @@
     time_sec=(itime-1)*dtime
 #ifdef CPP_COUPLE
+    il_time_secs=(itime-1)*dtime
 !$OMP MASTER
-    CALL intocpl(time_sec, lafin, tab_flds(:,:,:))
+    CALL intocpl(il_time_secs, lafin, tab_flds(:,:,:))
 !$OMP END MASTER
 #endif
@@ -1188,5 +1192,5 @@
 !
   SUBROUTINE cpl2gath(champ_in, champ_out, knon, knindex)
-    USE mod_phys_lmdz_para
+  USE mod_phys_lmdz_para
 ! Cette routine ecrit un champ 'gathered' sur la grille 2D pour le passer
 ! au coupleur.
@@ -1218,4 +1222,6 @@
 !*************************************************************************************
 !
+    
+
 ! Transform from 2 dimensions (iim,jj_nb) to 1 dimension (klon)
 !$OMP MASTER 
@@ -1230,5 +1236,5 @@
        champ_out(i) = temp_omp(ig)
     ENDDO
-   
+
   END SUBROUTINE cpl2gath
 !
Index: /LMDZ4/trunk/libf/phylmd/hines_gwd.F
===================================================================
--- /LMDZ4/trunk/libf/phylmd/hines_gwd.F	(revision 1001)
+++ /LMDZ4/trunk/libf/phylmd/hines_gwd.F	(revision 1001)
@@ -0,0 +1,2077 @@
+      SUBROUTINE HINES_GWD(NLON,NLEV,DTIME,paphm1x, papm1x,
+     I      rlat,tx,ux,vx,
+     O      zustrhi,zvstrhi,
+     O      d_t_hin, d_u_hin, d_v_hin)
+
+C ########################################################################
+C Parametrization of the momentum flux deposition due to a broad band 
+C spectrum of gravity waves, following Hines (1997a,b), as coded by 
+C McLANDRESS (1995). Modified by McFARLANE and MANZINI (1995-1997) 
+C                 MAECHAM model stand alone version
+C ########################################################################
+C 
+C
+         USE dimphy
+         implicit none
+
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOEGWD.h"
+#include "YOMCST.h"
+
+      INTEGER NAZMTH
+      PARAMETER(NAZMTH=8)
+
+C     INPUT ARGUMENTS.
+C     ----- ----------
+C
+C  - 2D
+C  PAPHM1   : HALF LEVEL PRESSURE (T-DT)
+C  PAPM1    : FULL LEVEL PRESSURE (T-DT)
+C  PTM1     : TEMPERATURE (T-DT)
+C  PUM1     : ZONAL WIND (T-DT)
+C  PVM1     : MERIDIONAL WIND (T-DT)
+C
+
+C     REFERENCE.
+C     ----------
+C         SEE MODEL DOCUMENTATION
+C
+C     AUTHOR.
+C     -------
+C
+C      N. MCFARLANE   DKRZ-HAMBURG   MAY 1995
+C      STAND ALONE E. MANZINI MPI-HAMBURG FEBRUARY 1997
+C
+C      BASED ON A COMBINATION OF THE OROGRAPHIC SCHEME BY N.MCFARLANE 1987
+C      AND THE HINES SCHEME AS CODED BY C. MCLANDRESS 1995.                       
+C
+C
+C
+cym      INTEGER KLEVM1
+C
+      REAL PAPHM1(klon,klev+1), PAPM1(klon,KLEV)  
+      REAL PTM1(klon,KLEV), PUM1(klon,KLEV), PVM1(klon,KLEV)
+      REAL PRFLUX(klon)
+C1
+C1
+C1
+      REAL RLAT(klon),COSLAT(KLON)
+C 
+      REAL TH(klon,KLEV),
+     2     UTENDGW(klon,KLEV), VTENDGW(klon,KLEV), 
+     3     PRESSG(klon),
+     4     UHS(klon,KLEV),     VHS(klon,KLEV), ZPR(klon)
+
+C     * VERTICAL POSITIONING ARRAYS.
+
+      REAL SGJ(klon,KLEV),     SHJ(klon,KLEV),    
+     1     SHXKJ(klon,KLEV),   DSGJ(klon,KLEV)
+
+C     * LOGICAL SWITCHES TO CONTROL ROOF DRAG, ENVELOP GW DRAG AND
+C     * HINES' DOPPLER SPREADING EXTROWAVE GW DRAG.
+C     * LOZPR IS TRUE FOR ZPR ENHANCEMENT
+
+
+C     * WORK ARRAYS.
+
+      REAL M_ALPHA(klon,KLEV,NAZMTH),     V_ALPHA(klon,KLEV,NAZMTH),
+     1     SIGMA_ALPHA(klon,KLEV,NAZMTH), 
+     1     SIGSQH_ALPHA(klon,KLEV,NAZMTH),
+     2     DRAG_U(klon,KLEV),   DRAG_V(klon,KLEV),  FLUX_U(klon,KLEV),
+     3     FLUX_V(klon,KLEV),   HEAT(klon,KLEV),    DIFFCO(klon,KLEV),
+     4     BVFREQ(klon,KLEV),   DENSITY(klon,KLEV), SIGMA_T(klon,KLEV),
+     5     VISC_MOL(klon,KLEV), ALT(klon,KLEV),      
+     6     SIGSQMCW(klon,KLEV,NAZMTH), 
+     6     SIGMATM(klon,KLEV), 
+     7     AK_ALPHA(klon,NAZMTH),       K_ALPHA(klon,NAZMTH),
+     8     MMIN_ALPHA(klon,NAZMTH),     I_ALPHA(klon,NAZMTH),
+     9     RMSWIND(klon), BVFBOT(klon), DENSBOT(klon)
+      REAL  SMOOTHR1(klon,KLEV), SMOOTHR2(klon,KLEV)
+      REAL  SIGALPMC(klon,KLEV,NAZMTH)      
+      REAL  F2MOD(klon,KLEV)
+      
+C     * THES ARE THE INPUT PARAMETERS FOR HINES ROUTINE AND
+C     * ARE SPECIFIED IN ROUTINE HINES_SETUP. SINCE THIS IS CALLED
+C     * ONLY AT FIRST CALL TO THIS ROUTINE THESE VARIABLES MUST BE SAVED
+C     * FOR USE AT SUBSEQUENT CALLS. THIS CAN BE AVOIDED BY CALLING
+C     * HINES_SETUP IN MAIN PROGRAM AND PASSING THE PARAMETERS AS
+C     * SUBROUTINE ARGUEMENTS.
+C
+
+      REAL    RMSCON
+      INTEGER NMESSG, IPRINT, ILRMS
+      INTEGER IFL
+C
+      INTEGER  NAZ,ICUTOFF,NSMAX,IHEATCAL
+      REAL  SLOPE,F1,F2,F3,F5,F6,KSTAR(KLON),ALT_CUTOFF,SMCO
+C
+C    PROVIDED AS INPUT
+C
+      integer nlon,nlev
+
+      real dtime
+      real paphm1x(nlon,nlev+1), papm1x(nlon,nlev)
+      real ux(nlon,nlev), vx(nlon,nlev), tx(nlon,nlev)
+c
+c     VARIABLES FOR OUTPUT
+c
+
+      real d_t_hin(nlon,nlev),d_u_hin(nlon,nlev),d_v_hin(nlon,nlev)
+      real zustrhi(nlon),zvstrhi(nlon) 
+
+C
+C     * LOGICAL SWITCHES TO CONTROL PRECIP ENHANCEMENT AND
+C     * HINES' DOPPLER SPREADING EXTROWAVE GW DRAG.
+C     * LOZPR IS TRUE FOR ZPR ENHANCEMENT
+C  
+      LOGICAL LOZPR, LORMS(klon)
+C
+C  LOCAL PARAMETERS TO MAKE THINGS WORK (TEMPORARY VARIABLE)
+
+      REAL RHOH2O,ZPCONS,RGOCP,ZLAT,DTTDSF,RATIO,HSCAL
+      INTEGER I,J,L,JL,JK,LE,LREF,LREFP,LEVBOT
+C
+C  DATA PARAMETERS NEEDED, EXPLAINED LATER
+
+      REAL V0,VMIN,DMPSCAL,TAUFAC,HMIN,APIBT,CPART,FCRIT
+      REAL PCRIT,PCONS
+      INTEGER IPLEV,IERROR
+   
+C
+C      
+C     PRINT *,' IT IS STARTED HINES GOING ON...'
+C
+C
+C
+C
+C*    COMPUTATIONAL CONSTANTS.
+C     ------------- ----------
+C
+C
+      d_t_hin(:,:)=0.
+      
+      RHOH2O=1000.    
+      ZPCONS = (1000.*86400.)/RHOH2O
+cym      KLEVM1=KLEV-1
+C
+
+        do jl=kidia,kfdia
+        PAPHM1(JL,1) = paphm1x(JL,klev+1)
+          do jk=1,klev      
+          le=klev+1-jk
+          PAPHM1(JL,JK+1) =  paphm1x(JL,le) 
+          PAPM1(JL,JK) = papm1x(JL,le)
+          PTM1(JL,JK) = tx(JL,le)
+          PUM1(JL,JK) = ux(JL,le)
+          PVM1(JL,JK) = vx(JL,le)
+          enddo
+        enddo
+C
+  100 CONTINUE
+C
+C    Define constants and arrays needed for the ccc/mam gwd scheme
+C    *Constants:
+
+      RGOCP=RD/RCPD
+      LREFP=KLEV-1
+      LREF=KLEV-2
+C1
+C1    *Arrays
+C1
+      DO 2101 JK=1,KLEV
+      DO 2102 JL=KIDIA,KFDIA
+      SHJ(JL,JK)=PAPM1(JL,JK)/PAPHM1(JL,klev+1)
+      SGJ(JL,JK)=PAPM1(JL,JK)/PAPHM1(JL,klev+1)
+      DSGJ(JL,JK)=(PAPHM1(JL,JK+1)-PAPHM1(JL,JK))/PAPHM1(JL,klev+1)
+      SHXKJ(JL,JK)=(PAPM1(JL,JK)/PAPHM1(JL,klev+1))**RGOCP 
+      TH(JL,JK)= PTM1(JL,JK)
+ 2102 CONTINUE
+ 2101 CONTINUE    
+      
+CC
+      DO 211 JL=KIDIA,KFDIA
+      PRESSG(JL)=PAPHM1(JL,klev+1)
+  211 CONTINUE
+C
+C
+      DO 301 JL=KIDIA,KFDIA
+      PRFLUX(JL) = 0.0
+      ZPR(JL)=ZPCONS*PRFLUX(JL)
+      ZLAT=(RLAT(JL)/180.)*RPI
+      COSLAT(Jl)=COS(ZLAT)    
+  301 CONTINUE
+C
+C
+  400 CONTINUE
+C  
+C
+C
+C
+*/#########################################################################
+*/
+*/
+C
+C     * AUG. 14/95 - C. MCLANDRESS.
+C     * SEP.    95   N. MCFARLANE.
+C
+C     * THIS ROUTINE CALCULATES THE HORIZONTAL WIND TENDENCIES
+C     * DUE TO MCFARLANE'S OROGRAPHIC GW DRAG SCHEME, HINES'
+C     * DOPPLER SPREAD SCHEME FOR "EXTROWAVES" AND ADDS ON
+C     * ROOF DRAG. IT IS BASED ON THE ROUTINE GWDFLX8.
+C
+C     * LREFP IS THE INDEX OF THE MODEL LEVEL BELOW THE REFERENCE LEVEL
+C     * I/O ARRAYS PASSED FROM MAIN.
+C     * (PRESSG = SURFACE PRESSURE)
+C
+C
+C
+C
+C     * CONSTANTS VALUES DEFINED IN DATA STATEMENT ARE :
+C     * VMIN     = MIMINUM WIND IN THE DIRECTION OF REFERENCE LEVEL
+C     *            WIND BEFORE WE CONSIDER BREAKING TO HAVE OCCURED.
+C     * DMPSCAL  = DAMPING TIME FOR GW DRAG IN SECONDS.
+C     * TAUFAC   = 1/(LENGTH SCALE).
+C     * HMIN     = MIMINUM ENVELOPE HEIGHT REQUIRED TO PRODUCE GW DRAG.
+C     * V0       = VALUE OF WIND THAT APPROXIMATES ZERO.
+
+
+      DATA    VMIN  /    5.0 /, V0       / 1.E-10 /,
+     1        TAUFAC/  5.E-6 /, HMIN     /   40000. /,
+     3        DMPSCAL  / 6.5E+6 /, APIBT / 1.5708 /,
+     4        CPART /    0.7 /, FCRIT    / 1. /
+
+C     * HINES EXTROWAVE GWD CONSTANTS DEFINED IN DATA STATEMENT ARE:
+C     * RMSCON = ROOT MEAN SQUARE GRAVITY WAVE WIND AT LOWEST LEVEL (M/S).
+C     * NMESSG  = UNIT NUMBER FOR PRINTED MESSAGES.
+C     * IPRINT  = 1 TO DO PRINT OUT SOME HINES ARRAYS.
+C     * IFL     = FIRST CALL FLAG TO HINES_SETUP ("SAVE" IT)
+C     * PCRIT = CRITICAL VALUE OF ZPR (MM/D)
+C     * IPLEV = LEVEL OF APPLICATION OF PRCIT
+C     * PCONS = FACTOR OF ZPR ENHANCEMENT
+C
+
+      DATA PCRIT / 5. /, PCONS / 4.75 /
+
+      IPLEV = LREFP-1
+C
+      DATA    RMSCON  / 1.00 /
+     1        IPRINT   /  2  /, NMESSG  /   6   /
+      DATA    IFL / 0 /
+C
+      LOZPR = .FALSE.
+C
+C-----------------------------------------------------------------------
+C
+C
+C
+C     * SET ERROR FLAG
+
+      IERROR = 0
+
+C     * SPECIFY VARIOUS PARAMETERS FOR HINES ROUTINE AT VERY FIRST CALL.
+C     * (NOTE THAT ARRAY K_ALPHA IS SPECIFIED SO MAKE SURE THAT
+C     * IT IS NOT OVERWRITTEN LATER ON).
+C
+        CALL HINES_SETUP (NAZ,SLOPE,F1,F2,F3,F5,F6,KSTAR,
+     1                    ICUTOFF,ALT_CUTOFF,SMCO,NSMAX,IHEATCAL,
+     2                   K_ALPHA,IERROR,NMESSG,klon,NAZMTH,COSLAT)
+        IF (IERROR.NE.0)  GO TO 999
+C
+C     * START GWD CALCULATIONS.
+
+      LREF  = LREFP-1
+
+C
+      DO 105 J=1,NAZMTH
+      DO 105 L=1,KLEV
+      DO 105 I=kidia,klon
+        SIGSQMCW(I,L,J) = 0.
+  105 CONTINUE
+c
+
+
+C     * INITIALIZE NECESSARY ARRAYS.
+C
+      DO 120 L=1,KLEV
+      DO 120 I=KIDIA,KFDIA
+        UTENDGW(I,L) = 0.
+        VTENDGW(I,L) = 0.
+
+        UHS(I,L) = 0.
+        VHS(I,L) = 0.
+
+ 120  CONTINUE
+C
+C     * IF USING HINES SCHEME THEN CALCULATE B V FREQUENCY AT ALL POINTS
+C     * AND SMOOTH BVFREQ.
+
+        DO 130 L=2,KLEV
+        DO 130 I=KIDIA,KFDIA
+          DTTDSF=(TH(I,L)/SHXKJ(I,L)-TH(I,L-1)/
+     1            SHXKJ(I,L-1))/(SHJ(I,L)-SHJ(I,L-1))
+          DTTDSF=MIN(DTTDSF, -5./SGJ(I,L))
+          BVFREQ(I,L)=SQRT(-DTTDSF*SGJ(I,L)*(SGJ(I,L)**RGOCP)/RD)
+     1                     *RG/PTM1(I,L)
+  130   CONTINUE
+        DO 135 L=1,KLEV
+        DO 135 I=KIDIA,KFDIA
+          IF(L.EQ.1)                        THEN
+            BVFREQ(I,L) = BVFREQ(I,L+1)
+          ENDIF
+          IF(L.GT.1)                        THEN
+            RATIO=5.*LOG(SGJ(I,L)/SGJ(I,L-1))
+            BVFREQ(I,L) = (BVFREQ(I,L-1) + RATIO*BVFREQ(I,L))
+     1                       /(1.+RATIO)
+          ENDIF
+  135   CONTINUE
+C
+C
+  300 CONTINUE
+
+C     * CALCULATE GW DRAG DUE TO HINES' EXTROWAVES
+C     * SET MOLECULAR VISCOSITY TO A VERY SMALL VALUE.
+C     * IF THE MODEL TOP IS GREATER THAN 100 KM THEN THE ACTUAL
+C     * VISCOSITY COEFFICIENT COULD BE SPECIFIED HERE.
+
+      DO 310 L=1,KLEV
+      DO 310 I=KIDIA,KFDIA
+         VISC_MOL(I,L) = 1.5E-5
+         DRAG_U(I,L) = 0.
+         DRAG_V(I,L) = 0.
+         FLUX_U(I,L) = 0.
+         FLUX_V(I,L) = 0.
+         HEAT(I,L)   = 0.
+         DIFFCO(I,L) = 0.
+ 310  CONTINUE
+
+C     * ALTITUDE AND DENSITY AT BOTTOM.
+
+      DO 330 I=KIDIA,KFDIA
+         HSCAL = RD * PTM1(I,KLEV) / RG
+         DENSITY(I,KLEV) = SGJ(I,KLEV) * PRESSG(I) / (RG*HSCAL)
+         ALT(I,KLEV) = 0.
+  330 CONTINUE
+
+C     * ALTITUDE AND DENSITY AT REMAINING LEVELS.
+
+      DO 340 L=KLEV-1,1,-1
+      DO 340 I=KIDIA,KFDIA
+         HSCAL = RD * PTM1(I,L) / RG
+         ALT(I,L) = ALT(I,L+1) + HSCAL * DSGJ(I,L) / SGJ(I,L)
+         DENSITY(I,L) = SGJ(I,L) * PRESSG(I) / (RG*HSCAL)
+  340 CONTINUE
+
+C
+C     * INITIALIZE SWITCHES FOR HINES GWD CALCULATION
+C
+      ILRMS = 0
+C
+      DO 345 I=KIDIA,KFDIA 
+      LORMS(I) = .FALSE.
+  345 CONTINUE 
+C
+C
+C     * DEFILE BOTTOM LAUNCH LEVEL
+C
+      LEVBOT = IPLEV
+C
+C     * BACKGROUND WIND MINUS VALUE AT BOTTOM LAUNCH LEVEL.
+C
+      DO 351 L=1,LEVBOT
+      DO 351 I=KIDIA,KFDIA 
+      UHS(I,L) = PUM1(I,L) - PUM1(I,LEVBOT)
+      VHS(I,L) = PVM1(I,L) - PVM1(I,LEVBOT)
+  351 CONTINUE
+C
+C     * SPECIFY ROOT MEAN SQUARE WIND AT BOTTOM LAUNCH LEVEL.
+C
+       DO 355 I=KIDIA,KFDIA 
+       RMSWIND(I) = RMSCON
+  355  CONTINUE
+
+      IF (LOZPR) THEN
+        DO 350 I=KIDIA,KFDIA 
+        IF (ZPR(I) .GT. PCRIT) THEN
+          RMSWIND(I) = RMSCON
+     >                +( (ZPR(I)-PCRIT)/ZPR(I) )*PCONS
+        ENDIF
+  350   CONTINUE
+      ENDIF
+C
+      DO 356 I=KIDIA,KFDIA 
+      IF (RMSWIND(I) .GT. 0.0) THEN
+      ILRMS = ILRMS+1
+      LORMS(I) = .TRUE.
+      ENDIF
+  356 CONTINUE
+C
+C     * CALCULATE GWD (NOTE THAT DIFFUSION COEFFICIENT AND
+C     * HEATING RATE ONLY CALCULATED IF IHEATCAL = 1).
+C
+      IF ( ILRMS.GT.0 )       THEN                    
+C
+      CALL HINES_EXTRO0 (DRAG_U,DRAG_V,HEAT,DIFFCO,FLUX_U,FLUX_V,
+     1                   UHS,VHS,BVFREQ,DENSITY,VISC_MOL,ALT,
+     2                   RMSWIND,K_ALPHA,M_ALPHA,V_ALPHA,
+     3                   SIGMA_ALPHA,SIGSQH_ALPHA,AK_ALPHA,
+     4                   MMIN_ALPHA,I_ALPHA,SIGMA_T,DENSBOT,BVFBOT,
+     5                   1,IHEATCAL,ICUTOFF,IPRINT,NSMAX,
+     6                   SMCO,ALT_CUTOFF,KSTAR,SLOPE,
+     7                   F1,F2,F3,F5,F6,NAZ,SIGSQMCW,SIGMATM,
+     8                   KIDIA,klon,1,LEVBOT,KLON,KLEV,NAZMTH,
+     9                   LORMS,SMOOTHR1,SMOOTHR2,
+     9                   SIGALPMC,F2MOD)
+
+C     * ADD ON HINES' GWD TENDENCIES TO OROGRAPHIC TENDENCIES AND
+C     * APPLY HINES' GW DRAG ON (UROW,VROW) WORK ARRAYS.
+
+      DO 360 L=1,KLEV
+      DO 360 I=KIDIA,KFDIA
+         UTENDGW(I,L) = UTENDGW(I,L) + DRAG_U(I,L)
+         VTENDGW(I,L) = VTENDGW(I,L) + DRAG_V(I,L)
+  360 CONTINUE
+C
+
+C     * END OF HINES CALCULATIONS.
+C
+      ENDIF
+C
+  500 CONTINUE
+
+
+C-----------------------------------------------------------------------
+C
+        do jl=kidia,kfdia
+          zustrhi(jl)=FLUX_U(jl,1)
+          zvstrhi(jl)=FLUX_v(jl,1)
+          do jk=1,klev
+          le=klev-jk+1
+          d_u_hin(jl,JK) =  UTENDGW(jl,le) * dtime
+          d_v_hin(jl,JK) =  VTENDGW(jl,le) * dtime
+          enddo
+        enddo
+
+c     PRINT *,'UTENDGW:',UTENDGW
+
+C     PRINT *,' HINES HAS BEEN COMPLETED (LONG ISNT IT...)'
+
+      RETURN
+ 999  CONTINUE
+
+C     * IF ERROR DETECTED THEN ABORT.
+
+      WRITE (NMESSG,6000)
+      WRITE (NMESSG,6010) IERROR
+ 6000 FORMAT (/' EXECUTION ABORTED IN GWDOREXV')
+ 6010 FORMAT ('     ERROR FLAG =',I4)
+
+C
+      RETURN
+      END
+*/
+*/
+
+
+      SUBROUTINE HINES_EXTRO0 (DRAG_U,DRAG_V,HEAT,DIFFCO,FLUX_U,FLUX_V,
+     1                         VEL_U,VEL_V,BVFREQ,DENSITY,VISC_MOL,ALT,
+     2                         RMSWIND,K_ALPHA,M_ALPHA,V_ALPHA,
+     3                         SIGMA_ALPHA,SIGSQH_ALPHA,AK_ALPHA,
+     4                         MMIN_ALPHA,I_ALPHA,SIGMA_T,DENSB,BVFB,
+     5                         IORDER,IHEATCAL,ICUTOFF,IPRINT,NSMAX,
+     6                         SMCO,ALT_CUTOFF,KSTAR,SLOPE,
+     7                         F1,F2,F3,F5,F6,NAZ,SIGSQMCW,SIGMATM,
+     8                         IL1,IL2,LEV1,LEV2,NLONS,NLEVS,NAZMTH,
+     9                         LORMS,SMOOTHR1,SMOOTHR2,
+     9                         SIGALPMC,F2MOD)
+
+       implicit none
+C
+C  Main routine for Hines' "extrowave" gravity wave parameterization based
+C  on Hines' Doppler spread theory. This routine calculates zonal
+C  and meridional components of gravity wave drag, heating rates
+C  and diffusion coefficient on a longitude by altitude grid.
+C  No "mythical" lower boundary region calculation is made so it
+C  is assumed that lowest level winds are weak (i.e, approximately zero).
+C
+C  Aug. 13/95 - C. McLandress
+C  SEPT. /95  - N.McFarlane
+C
+C  Modifications:
+C
+C  Output arguements:
+C
+C     * DRAG_U = zonal component of gravity wave drag (m/s^2).
+C     * DRAG_V = meridional component of gravity wave drag (m/s^2).
+C     * HEAT   = gravity wave heating (K/sec).
+C     * DIFFCO = diffusion coefficient (m^2/sec)
+C     * FLUX_U = zonal component of vertical momentum flux (Pascals)
+C     * FLUX_V = meridional component of vertical momentum flux (Pascals)
+C
+C  Input arguements:
+C
+C     * VEL_U      = background zonal wind component (m/s).
+C     * VEL_V      = background meridional wind component (m/s).
+C     * BVFREQ     = background Brunt Vassala frequency (radians/sec).
+C     * DENSITY    = background density (kg/m^3) 
+C     * VISC_MOL   = molecular viscosity (m^2/s)
+C     * ALT        = altitude of momentum, density, buoyancy levels (m)
+C     *              (NOTE: levels ordered so that ALT(I,1) > ALT(I,2), etc.)
+C     * RMSWIND   = root mean square gravity wave wind at lowest level (m/s).
+C     * K_ALPHA    = horizontal wavenumber of each azimuth (1/m).
+C     * IORDER	   = 1 means vertical levels are indexed from top down 
+C     *              (i.e., highest level indexed 1 and lowest level NLEVS);
+C     *           .NE. 1 highest level is index NLEVS.
+C     * IHEATCAL   = 1 to calculate heating rates and diffusion coefficient.
+C     * IPRINT     = 1 to print out various arrays.
+C     * ICUTOFF    = 1 to exponentially damp GWD, heating and diffusion 
+C     *              arrays above ALT_CUTOFF; otherwise arrays not modified.
+C     * ALT_CUTOFF = altitude in meters above which exponential decay applied.
+C     * SMCO       = smoothing factor used to smooth cutoff vertical 
+C     *              wavenumbers and total rms winds in vertical direction
+C     *              before calculating drag or heating
+C     *              (SMCO >= 1 ==> 1:SMCO:1 stencil used).
+C     * NSMAX      = number of times smoother applied ( >= 1),
+C     *            = 0 means no smoothing performed.
+C     * KSTAR      = typical gravity wave horizontal wavenumber (1/m).
+C     * SLOPE      = slope of incident vertical wavenumber spectrum
+C     *              (SLOPE must equal 1., 1.5 or 2.).
+C     * F1 to F6   = Hines's fudge factors (F4 not needed since used for
+C     *              vertical flux of vertical momentum).
+C     * NAZ        = actual number of horizontal azimuths used.
+C     * IL1        = first longitudinal index to use (IL1 >= 1).
+C     * IL2        = last longitudinal index to use (IL1 <= IL2 <= NLONS).
+C     * LEV1       = index of first level for drag calculation.
+C     * LEV2       = index of last level for drag calculation 
+C     *              (i.e., LEV1 < LEV2 <= NLEVS).
+C     * NLONS      = number of longitudes.
+C     * NLEVS      = number of vertical levels.
+C     * NAZMTH     = azimuthal array dimension (NAZMTH >= NAZ).
+C 
+C  Work arrays.
+C
+C     * M_ALPHA      = cutoff vertical wavenumber (1/m).
+C     * V_ALPHA      = wind component at each azimuth (m/s) and if IHEATCAL=1
+C     *                holds vertical derivative of cutoff wavenumber.
+C     * SIGMA_ALPHA  = total rms wind in each azimuth (m/s).
+C     * SIGSQH_ALPHA = portion of wind variance from waves having wave
+C     *                normals in the alpha azimuth (m/s).
+C     * SIGMA_T      = total rms horizontal wind (m/s).
+C     * AK_ALPHA     = spectral amplitude factor at each azimuth 
+C     *                (i.e.,{AjKj}) in m^4/s^2.
+C     * I_ALPHA      = Hines' integral.
+C     * MMIN_ALPHA   = minimum value of cutoff wavenumber.
+C     * DENSB        = background density at bottom level.
+C     * BVFB         = buoyancy frequency at bottom level and
+C     *                work array for ICUTOFF = 1.
+C
+C     * LORMS       = .TRUE. for drag computation 
+C
+      INTEGER  NAZ, NLONS, NLEVS, NAZMTH, IL1, IL2, LEV1, LEV2
+      INTEGER  ICUTOFF, NSMAX, IORDER, IHEATCAL, IPRINT
+      REAL  KSTAR(NLONS), F1, F2, F3, F5, F6, SLOPE
+      REAL  ALT_CUTOFF, SMCO
+      REAL  DRAG_U(NLONS,NLEVS),   DRAG_V(NLONS,NLEVS) 
+      REAL  HEAT(NLONS,NLEVS),     DIFFCO(NLONS,NLEVS)
+      REAL  FLUX_U(NLONS,NLEVS),   FLUX_V(NLONS,NLEVS)
+      REAL  VEL_U(NLONS,NLEVS),    VEL_V(NLONS,NLEVS)
+      REAL  BVFREQ(NLONS,NLEVS),   DENSITY(NLONS,NLEVS)
+      REAL  VISC_MOL(NLONS,NLEVS), ALT(NLONS,NLEVS)
+      REAL  RMSWIND(NLONS),       BVFB(NLONS),   DENSB(NLONS)
+      REAL  SIGMA_T(NLONS,NLEVS), SIGSQMCW(NLONS,NLEVS,NAZMTH)
+      REAL  SIGMA_ALPHA(NLONS,NLEVS,NAZMTH), SIGMATM(NLONS,NLEVS)
+      REAL  SIGSQH_ALPHA(NLONS,NLEVS,NAZMTH)
+      REAL  M_ALPHA(NLONS,NLEVS,NAZMTH), V_ALPHA(NLONS,NLEVS,NAZMTH)
+      REAL  AK_ALPHA(NLONS,NAZMTH),      K_ALPHA(NLONS,NAZMTH)
+      REAL  MMIN_ALPHA(NLONS,NAZMTH) ,   I_ALPHA(NLONS,NAZMTH)
+      REAL  SMOOTHR1(NLONS,NLEVS), SMOOTHR2(NLONS,NLEVS)
+      REAL  SIGALPMC(NLONS,NLEVS,NAZMTH)
+      REAL  F2MOD(NLONS,NLEVS)
+C
+      LOGICAL LORMS(NLONS)
+C
+C  Internal variables.
+C
+      INTEGER  LEVBOT, LEVTOP, I, N, L, LEV1P, LEV2M
+      INTEGER  ILPRT1, ILPRT2
+C----------------------------------------------------------------------- 
+C
+C     PRINT *,' IN HINES_EXTRO0'
+      LEV1P = LEV1 + 1
+      LEV2M = LEV2 - 1
+C
+C  Index of lowest altitude level (bottom of drag calculation).
+C
+      LEVBOT = LEV2
+      LEVTOP = LEV1
+      IF (IORDER.NE.1)  THEN
+      write(6,1)
+   1  format(2x,' error: IORDER NOT ONE! ')
+      END IF
+C
+C  Buoyancy and density at bottom level.
+C
+      DO 10 I = IL1,IL2
+        BVFB(I)  = BVFREQ(I,LEVBOT)
+        DENSB(I) = DENSITY(I,LEVBOT)
+ 10   CONTINUE
+C
+C  initialize some variables
+C
+      DO 20 N = 1,NAZ
+      DO 20 L=LEV1,LEV2
+      DO 20 I=IL1,IL2
+      M_ALPHA(I,L,N) = 0.0
+  20  CONTINUE
+      DO 21 L=LEV1,LEV2
+      DO 21 I=IL1,IL2
+      SIGMA_T(I,L) = 0.0
+  21  CONTINUE
+      DO 22 N = 1,NAZ
+      DO 22 I=IL1,IL2
+      I_ALPHA(I,N) = 0.0
+  22  CONTINUE 
+C
+C  Compute azimuthal wind components from zonal and meridional winds.
+C
+      CALL HINES_WIND ( V_ALPHA, 
+     ^                  VEL_U, VEL_V, NAZ,
+     ^                  IL1, IL2, LEV1, LEV2, NLONS, NLEVS, NAZMTH )
+C
+C  Calculate cutoff vertical wavenumber and velocity variances.
+C
+      CALL HINES_WAVNUM ( M_ALPHA, SIGMA_ALPHA, SIGSQH_ALPHA, SIGMA_T,
+     ^                    AK_ALPHA, V_ALPHA, VISC_MOL, DENSITY, DENSB,
+     ^                    BVFREQ, BVFB, RMSWIND, I_ALPHA, MMIN_ALPHA,
+     ^                    KSTAR, SLOPE, F1, F2, F3, NAZ, LEVBOT,
+     ^                    LEVTOP,IL1,IL2,NLONS,NLEVS,NAZMTH, SIGSQMCW,
+     ^                    SIGMATM,LORMS,SIGALPMC,F2MOD)
+C
+C  Smooth cutoff wavenumbers and total rms velocity in the vertical 
+C  direction NSMAX times, using FLUX_U as temporary work array.
+C   
+      IF (NSMAX.GT.0)  THEN
+        DO 80 N = 1,NAZ
+          DO 81 L=LEV1,LEV2
+          DO 81 I=IL1,IL2
+          SMOOTHR1(I,L) = M_ALPHA(I,L,N)
+ 81       CONTINUE 
+             CALL VERT_SMOOTH (SMOOTHR1, 
+     ^                       SMOOTHR2, SMCO, NSMAX,
+     ^                       IL1, IL2, LEV1, LEV2, NLONS, NLEVS )
+        DO 83 L=LEV1,LEV2
+        DO 83 I=IL1,IL2
+        M_ALPHA(I,L,N) = SMOOTHR1(I,L)
+ 83     CONTINUE
+ 80     CONTINUE
+        CALL VERT_SMOOTH ( SIGMA_T, 
+     ^                     SMOOTHR2, SMCO, NSMAX,
+     ^                     IL1, IL2, LEV1, LEV2, NLONS, NLEVS )
+      END IF
+C
+C  Calculate zonal and meridional components of the
+C  momentum flux and drag.
+C
+      CALL HINES_FLUX ( FLUX_U, FLUX_V, DRAG_U, DRAG_V, 
+     ^                  ALT, DENSITY, DENSB, M_ALPHA, 
+     ^                  AK_ALPHA, K_ALPHA, SLOPE, NAZ,
+     ^                  IL1, IL2, LEV1, LEV2, NLONS, NLEVS, NAZMTH,
+     ^                  LORMS)
+C
+C  Cutoff drag above ALT_CUTOFF, using BVFB as temporary work array.
+C
+      IF (ICUTOFF.EQ.1)  THEN		
+        CALL HINES_EXP ( DRAG_U, 
+     ^                   BVFB, ALT, ALT_CUTOFF, IORDER,
+     ^                   IL1, IL2, LEV1, LEV2, NLONS, NLEVS )
+        CALL HINES_EXP ( DRAG_V, 
+     ^                   BVFB, ALT, ALT_CUTOFF, IORDER,
+     ^                   IL1, IL2, LEV1, LEV2, NLONS, NLEVS )
+      END IF   
+C
+C  Print out various arrays for diagnostic purposes.
+C
+      IF (IPRINT.EQ.1)  THEN
+        ILPRT1 = 15
+        ILPRT2 = 16
+        CALL HINES_PRINT ( FLUX_U, FLUX_V, DRAG_U, DRAG_V, ALT,
+     ^                     SIGMA_T, SIGMA_ALPHA, V_ALPHA, M_ALPHA,
+     ^                     1, 1, 6, ILPRT1, ILPRT2, LEV1, LEV2,
+     ^                     NAZ, NLONS, NLEVS, NAZMTH)
+      END IF
+C
+C  If not calculating heating rate and diffusion coefficient then finished.
+C
+      IF (IHEATCAL.NE.1)  RETURN
+C
+C  Calculate vertical derivative of cutoff wavenumber (store
+C  in array V_ALPHA) using centered differences at interior gridpoints
+C  and one-sided differences at first and last levels.
+C 
+      DO 130 N = 1,NAZ
+        DO 100 L = LEV1P,LEV2M
+          DO 90 I = IL1,IL2
+            V_ALPHA(I,L,N) = ( M_ALPHA(I,L+1,N) - M_ALPHA(I,L-1,N) ) 
+     ^                       / ( ALT(I,L+1) - ALT(I,L-1) )
+  90      CONTINUE
+ 100    CONTINUE
+        DO 110 I = IL1,IL2
+          V_ALPHA(I,LEV1,N) = ( M_ALPHA(I,LEV1P,N) - M_ALPHA(I,LEV1,N) ) 
+     ^                       / ( ALT(I,LEV1P) - ALT(I,LEV1) )
+ 110    CONTINUE
+        DO 120 I = IL1,IL2
+          V_ALPHA(I,LEV2,N) = ( M_ALPHA(I,LEV2,N) - M_ALPHA(I,LEV2M,N) ) 
+     ^                       / ( ALT(I,LEV2) - ALT(I,LEV2M) )
+ 120    CONTINUE
+ 130  CONTINUE
+C
+C  Heating rate and diffusion coefficient.
+C
+      CALL HINES_HEAT ( HEAT, DIFFCO, 
+     ^                  M_ALPHA, V_ALPHA, AK_ALPHA, K_ALPHA, 
+     ^                  BVFREQ, DENSITY, DENSB, SIGMA_T, VISC_MOL, 
+     ^                  KSTAR, SLOPE, F2, F3, F5, F6, NAZ, 
+     ^                  IL1, IL2, LEV1, LEV2, NLONS, NLEVS, NAZMTH)
+C
+C  Finished.
+C
+      RETURN
+C-----------------------------------------------------------------------
+      END
+
+      SUBROUTINE HINES_WAVNUM (M_ALPHA,SIGMA_ALPHA,SIGSQH_ALPHA,SIGMA_T,
+     1                         AK_ALPHA,V_ALPHA,VISC_MOL,DENSITY,DENSB,
+     2                         BVFREQ,BVFB,RMS_WIND,I_ALPHA,MMIN_ALPHA,
+     3                         KSTAR,SLOPE,F1,F2,F3,NAZ,LEVBOT,LEVTOP,
+     4                         IL1,IL2,NLONS,NLEVS,NAZMTH,SIGSQMCW,
+     5                         SIGMATM,LORMS,SIGALPMC,F2MOD)
+C
+C  This routine calculates the cutoff vertical wavenumber and velocity
+C  variances on a longitude by altitude grid for the Hines' Doppler 
+C  spread gravity wave drag parameterization scheme.
+C  NOTE: (1) only values of four or eight can be used for # azimuths (NAZ).
+C        (2) only values of 1.0, 1.5 or 2.0 can be used for slope (SLOPE). 
+C
+C  Aug. 10/95 - C. McLandress
+C
+C  Output arguements:
+C
+C     * M_ALPHA      = cutoff wavenumber at each azimuth (1/m).
+C     * SIGMA_ALPHA  = total rms wind in each azimuth (m/s).
+C     * SIGSQH_ALPHA = portion of wind variance from waves having wave
+C     *                normals in the alpha azimuth (m/s).
+C     * SIGMA_T      = total rms horizontal wind (m/s).
+C     * AK_ALPHA     = spectral amplitude factor at each azimuth 
+C     *                (i.e.,{AjKj}) in m^4/s^2.
+C
+C  Input arguements:
+C
+C     * V_ALPHA  = wind component at each azimuth (m/s). 
+C     * VISC_MOL = molecular viscosity (m^2/s)
+C     * DENSITY  = background density (kg/m^3).
+C     * DENSB    = background density at model bottom (kg/m^3).
+C     * BVFREQ   = background Brunt Vassala frequency (radians/sec).
+C     * BVFB     = background Brunt Vassala frequency at model bottom.
+C     * RMS_WIND = root mean square gravity wave wind at lowest level (m/s).
+C     * KSTAR    = typical gravity wave horizontal wavenumber (1/m).
+C     * SLOPE    = slope of incident vertical wavenumber spectrum
+C     *            (SLOPE = 1., 1.5 or 2.).
+C     * F1,F2,F3 = Hines's fudge factors.
+C     * NAZ      = actual number of horizontal azimuths used (4 or 8).
+C     * LEVBOT   = index of lowest vertical level.
+C     * LEVTOP   = index of highest vertical level 
+C     *            (NOTE: if LEVTOP < LEVBOT then level index 
+C     *             increases from top down).
+C     * IL1      = first longitudinal index to use (IL1 >= 1).
+C     * IL2      = last longitudinal index to use (IL1 <= IL2 <= NLONS).
+C     * NLONS    = number of longitudes.
+C     * NLEVS    = number of vertical levels.
+C     * NAZMTH   = azimuthal array dimension (NAZMTH >= NAZ).
+C
+C     * LORMS       = .TRUE. for drag computation 
+C
+C  Input work arrays:
+C
+C     * I_ALPHA    = Hines' integral at a single level.
+C     * MMIN_ALPHA = minimum value of cutoff wavenumber.
+C
+      INTEGER  NAZ, LEVBOT, LEVTOP, IL1, IL2, NLONS, NLEVS, NAZMTH
+      REAL  SLOPE, KSTAR(NLONS), F1, F2, F3
+      REAL  M_ALPHA(NLONS,NLEVS,NAZMTH)
+      REAL  SIGMA_ALPHA(NLONS,NLEVS,NAZMTH)
+      REAL  SIGALPMC(NLONS,NLEVS,NAZMTH)
+      REAL  SIGSQH_ALPHA(NLONS,NLEVS,NAZMTH)
+      REAL  SIGSQMCW(NLONS,NLEVS,NAZMTH)
+      REAL  SIGMA_T(NLONS,NLEVS)
+      REAL  SIGMATM(NLONS,NLEVS)
+      REAL  AK_ALPHA(NLONS,NAZMTH)
+      REAL  V_ALPHA(NLONS,NLEVS,NAZMTH)
+      REAL  VISC_MOL(NLONS,NLEVS)
+      REAL  F2MOD(NLONS,NLEVS)
+      REAL  DENSITY(NLONS,NLEVS),  DENSB(NLONS)
+      REAL  BVFREQ(NLONS,NLEVS),   BVFB(NLONS),  RMS_WIND(NLONS)
+      REAL  I_ALPHA(NLONS,NAZMTH), MMIN_ALPHA(NLONS,NAZMTH)
+C
+      LOGICAL LORMS(NLONS)
+C
+C Internal variables.
+C
+      INTEGER  I, L, N, LSTART, LEND, LINCR, LBELOW
+      REAL  M_SUB_M_TURB, M_SUB_M_MOL, M_TRIAL
+      REAL  VISC, VISC_MIN, AZFAC, SP1
+
+cc      REAL  N_OVER_M(1000), SIGFAC(1000)
+
+      REAL  N_OVER_M(NLONS), SIGFAC(NLONS)
+      DATA  VISC_MIN / 1.E-10 / 
+C-----------------------------------------------------------------------     
+C
+
+C     PRINT *,'IN HINES_WAVNUM'
+      SP1 = SLOPE + 1.
+C
+C  Indices of levels to process.
+C
+      IF (LEVBOT.GT.LEVTOP)  THEN
+        LSTART = LEVBOT - 1     
+        LEND   = LEVTOP         
+        LINCR  = -1
+      ELSE
+      write(6,1)
+   1  format(2x,' error: IORDER NOT ONE! ')
+      END IF
+C
+C  Use horizontal isotropy to calculate azimuthal variances at bottom level.
+C
+      AZFAC = 1. / FLOAT(NAZ)
+      DO 20 N = 1,NAZ
+        DO 10 I = IL1,IL2
+          SIGSQH_ALPHA(I,LEVBOT,N) = AZFAC * RMS_WIND(I)**2
+ 10     CONTINUE
+ 20   CONTINUE
+C
+C  Velocity variances at bottom level.
+C
+      CALL HINES_SIGMA ( SIGMA_T, SIGMA_ALPHA, 
+     ^                   SIGSQH_ALPHA, NAZ, LEVBOT, 
+     ^                   IL1, IL2, NLONS, NLEVS, NAZMTH)
+c
+      CALL HINES_SIGMA ( SIGMATM, SIGALPMC, 
+     ^                   SIGSQMCW, NAZ, LEVBOT, 
+     ^                   IL1, IL2, NLONS, NLEVS, NAZMTH) 
+C
+C  Calculate cutoff wavenumber and spectral amplitude factor 
+C  at bottom level where it is assumed that background winds vanish
+C  and also initialize minimum value of cutoff wavnumber.
+C
+      DO 40 N = 1,NAZ
+        DO 30 I = IL1,IL2
+        IF (LORMS(I)) THEN
+          M_ALPHA(I,LEVBOT,N) =  BVFB(I) / 
+     ^                           ( F1 * SIGMA_ALPHA(I,LEVBOT,N) 
+     ^                           + F2 * SIGMA_T(I,LEVBOT) )
+          AK_ALPHA(I,N)   = SIGSQH_ALPHA(I,LEVBOT,N) 
+     ^                      / ( M_ALPHA(I,LEVBOT,N)**SP1 / SP1 )
+          MMIN_ALPHA(I,N) = M_ALPHA(I,LEVBOT,N)
+        ENDIF
+ 30     CONTINUE
+ 40   CONTINUE
+C
+C  Calculate quantities from the bottom upwards, 
+C  starting one level above bottom.
+C
+      DO 150 L = LSTART,LEND,LINCR
+C
+C  Level beneath present level.
+C
+        LBELOW = L - LINCR 
+C
+C  Calculate N/m_M where m_M is maximum permissible value of the vertical
+C  wavenumber (i.e., m > m_M are obliterated) and N is buoyancy frequency.
+C  m_M is taken as the smaller of the instability-induced 
+C  wavenumber (M_SUB_M_TURB) and that imposed by molecular viscosity
+C  (M_SUB_M_MOL). Since variance at this level is not yet known
+C  use value at level below.
+C
+        DO 50 I = IL1,IL2
+        IF (LORMS(I)) THEN
+c
+        F2MFAC=SIGMATM(I,LBELOW)**2
+        F2MOD(I,LBELOW) =1.+ 2.*F2MFAC
+     ^                      / ( F2MFAC+SIGMA_T(I,LBELOW)**2 )
+c
+         VISC = AMAX1 ( VISC_MOL(I,L), VISC_MIN )
+         M_SUB_M_TURB = BVFREQ(I,L) 
+     ^                 / ( F2 *F2MOD(I,LBELOW)*SIGMA_T(I,LBELOW))
+         M_SUB_M_MOL = (BVFREQ(I,L)*KSTAR(I)/VISC)**0.33333333/F3
+          IF (M_SUB_M_TURB .LT. M_SUB_M_MOL)  THEN
+            N_OVER_M(I) = F2 *F2MOD(I,LBELOW)*SIGMA_T(I,LBELOW)
+          ELSE
+            N_OVER_M(I) = BVFREQ(I,L) / M_SUB_M_MOL 
+          END IF
+        ENDIF
+  50    CONTINUE
+C
+C  Calculate cutoff wavenumber at this level.
+C
+        DO 70 N = 1,NAZ
+          DO 60 I = IL1,IL2
+          IF (LORMS(I)) THEN
+C
+C  Calculate trial value (since variance at this level is not yet known
+C  use value at level below). If trial value is negative or if it exceeds 
+C  minimum value (not permitted) then set it to minimum value. 
+C                                                                      
+            M_TRIAL = BVFB(I) / ( F1 * ( SIGMA_ALPHA(I,LBELOW,N)+  
+     ^       SIGALPMC(I,LBELOW,N)) + N_OVER_M(I) + V_ALPHA(I,L,N) )
+            IF (M_TRIAL.LE.0. .OR. M_TRIAL.GT.MMIN_ALPHA(I,N))  THEN
+              M_TRIAL = MMIN_ALPHA(I,N)
+            END IF
+            M_ALPHA(I,L,N) = M_TRIAL
+C
+C  Reset minimum value of cutoff wavenumber if necessary.
+C
+            IF (M_ALPHA(I,L,N) .LT. MMIN_ALPHA(I,N))  THEN
+              MMIN_ALPHA(I,N) = M_ALPHA(I,L,N)
+            END IF
+C
+          ENDIF
+ 60       CONTINUE
+ 70     CONTINUE
+C
+C  Calculate the Hines integral at this level.
+C
+        CALL HINES_INTGRL ( I_ALPHA, 
+     ^                      V_ALPHA, M_ALPHA, BVFB, SLOPE, NAZ, 
+     ^                      L, IL1, IL2, NLONS, NLEVS, NAZMTH,
+     ^                      LORMS )
+
+C
+C  Calculate the velocity variances at this level.
+C
+        DO 80 I = IL1,IL2
+          SIGFAC(I) = DENSB(I) / DENSITY(I,L) 
+     ^                * BVFREQ(I,L) / BVFB(I) 
+ 80     CONTINUE
+        DO 100 N = 1,NAZ
+          DO 90 I = IL1,IL2
+            SIGSQH_ALPHA(I,L,N) = SIGFAC(I) * AK_ALPHA(I,N) 
+     ^                            * I_ALPHA(I,N)
+  90      CONTINUE
+ 100    CONTINUE
+        CALL HINES_SIGMA ( SIGMA_T, SIGMA_ALPHA, 
+     ^                     SIGSQH_ALPHA, NAZ, L, 
+     ^                     IL1, IL2, NLONS, NLEVS, NAZMTH )
+c
+        CALL HINES_SIGMA ( SIGMATM, SIGALPMC, 
+     ^                     SIGSQMCW, NAZ, L, 
+     ^                     IL1, IL2, NLONS, NLEVS, NAZMTH )
+C
+C  End of level loop.
+C
+ 150  CONTINUE
+C
+      RETURN
+C-----------------------------------------------------------------------
+      END
+
+      SUBROUTINE HINES_WIND (V_ALPHA,VEL_U,VEL_V,
+     1                       NAZ,IL1,IL2,LEV1,LEV2,NLONS,NLEVS,NAZMTH)
+C
+C  This routine calculates the azimuthal horizontal background wind components 
+C  on a longitude by altitude grid for the case of 4 or 8 azimuths for
+C  the Hines' Doppler spread GWD parameterization scheme.
+C
+C  Aug. 7/95 - C. McLandress
+C
+C  Output arguement:
+C
+C     * V_ALPHA   = background wind component at each azimuth (m/s). 
+C     *             (note: first azimuth is in eastward direction
+C     *              and rotate in counterclockwise direction.)
+C
+C  Input arguements:
+C
+C     * VEL_U     = background zonal wind component (m/s).
+C     * VEL_V     = background meridional wind component (m/s).
+C     * NAZ       = actual number of horizontal azimuths used (must be 4 or 8).
+C     * IL1       = first longitudinal index to use (IL1 >= 1).
+C     * IL2       = last longitudinal index to use (IL1 <= IL2 <= NLONS).
+C     * LEV1      = first altitude level to use (LEV1 >=1). 
+C     * LEV2      = last altitude level to use (LEV1 < LEV2 <= NLEVS).
+C     * NLONS     = number of longitudes.
+C     * NLEVS     = number of vertical levels.
+C     * NAZMTH    = azimuthal array dimension (NAZMTH >= NAZ).
+C
+C  Constants in DATA statements.
+C
+C     * COS45 = cosine of 45 degrees. 		
+C     * UMIN  = minimum allowable value for zonal or meridional 
+C     *         wind component (m/s).
+C
+C  Subroutine arguements.
+C
+      INTEGER  NAZ, IL1, IL2, LEV1, LEV2
+      INTEGER  NLONS, NLEVS, NAZMTH
+      REAL  V_ALPHA(NLONS,NLEVS,NAZMTH)
+      REAL  VEL_U(NLONS,NLEVS), VEL_V(NLONS,NLEVS)
+C
+C  Internal variables.
+C
+      INTEGER  I, L
+      REAL U, V, COS45, UMIN
+C
+      DATA  COS45 / 0.7071068 /
+      DATA  UMIN / 0.001 /
+C-----------------------------------------------------------------------     
+C
+C  Case with 4 azimuths.
+C
+
+C      PRINT *,'IN HINES_WIND'
+      IF (NAZ.EQ.4)  THEN
+        DO 20 L = LEV1,LEV2
+          DO 10 I = IL1,IL2
+            U = VEL_U(I,L)
+            V = VEL_V(I,L)
+            IF (ABS(U) .LT. UMIN)  U = UMIN 
+            IF (ABS(V) .LT. UMIN)  V = UMIN 
+            V_ALPHA(I,L,1) = U 
+            V_ALPHA(I,L,2) = V
+            V_ALPHA(I,L,3) = - U
+            V_ALPHA(I,L,4) = - V
+ 10       CONTINUE
+ 20     CONTINUE
+      END IF
+C
+C  Case with 8 azimuths.
+C
+      IF (NAZ.EQ.8)  THEN
+        DO 40 L = LEV1,LEV2
+          DO 30 I = IL1,IL2
+            U = VEL_U(I,L)
+            V = VEL_V(I,L)
+            IF (ABS(U) .LT. UMIN)  U = UMIN  
+            IF (ABS(V) .LT. UMIN)  V = UMIN  
+            V_ALPHA(I,L,1) = U 
+            V_ALPHA(I,L,2) = COS45 * ( V + U )
+            V_ALPHA(I,L,3) = V
+            V_ALPHA(I,L,4) = COS45 * ( V - U )
+            V_ALPHA(I,L,5) = - U
+            V_ALPHA(I,L,6) = - V_ALPHA(I,L,2)
+            V_ALPHA(I,L,7) = - V
+            V_ALPHA(I,L,8) = - V_ALPHA(I,L,4)
+ 30       CONTINUE
+ 40     CONTINUE
+      END IF
+C
+      RETURN
+C-----------------------------------------------------------------------
+      END
+
+      SUBROUTINE HINES_FLUX (FLUX_U,FLUX_V,DRAG_U,DRAG_V,ALT,DENSITY,
+     1                       DENSB,M_ALPHA,AK_ALPHA,K_ALPHA,SLOPE,
+     2                       NAZ,IL1,IL2,LEV1,LEV2,NLONS,NLEVS,NAZMTH,
+     3                       LORMS)
+C
+C  Calculate zonal and meridional components of the vertical flux 
+C  of horizontal momentum and corresponding wave drag (force per unit mass)
+C  on a longitude by altitude grid for the Hines' Doppler spread 
+C  GWD parameterization scheme.
+C  NOTE: only 4 or 8 azimuths can be used.
+C
+C  Aug. 6/95 - C. McLandress
+C
+C  Output arguements:
+C
+C     * FLUX_U = zonal component of vertical momentum flux (Pascals)
+C     * FLUX_V = meridional component of vertical momentum flux (Pascals)
+C     * DRAG_U = zonal component of drag (m/s^2).
+C     * DRAG_V = meridional component of drag (m/s^2).
+C
+C  Input arguements:
+C
+C     * ALT       = altitudes (m).
+C     * DENSITY   = background density (kg/m^3).
+C     * DENSB     = background density at bottom level (kg/m^3).
+C     * M_ALPHA   = cutoff vertical wavenumber (1/m).
+C     * AK_ALPHA  = spectral amplitude factor (i.e., {AjKj} in m^4/s^2).
+C     * K_ALPHA   = horizontal wavenumber (1/m).
+C     * SLOPE     = slope of incident vertical wavenumber spectrum.
+C     * NAZ       = actual number of horizontal azimuths used (must be 4 or 8).
+C     * IL1       = first longitudinal index to use (IL1 >= 1).
+C     * IL2       = last longitudinal index to use (IL1 <= IL2 <= NLONS).
+C     * LEV1      = first altitude level to use (LEV1 >=1). 
+C     * LEV2      = last altitude level to use (LEV1 < LEV2 <= NLEVS).
+C     * NLONS     = number of longitudes.
+C     * NLEVS     = number of vertical levels.
+C     * NAZMTH    = azimuthal array dimension (NAZMTH >= NAZ).
+C
+C     * LORMS       = .TRUE. for drag computation 
+C
+C  Constant in DATA statement.
+C
+C     * COS45 = cosine of 45 degrees. 		
+C
+C  Subroutine arguements.
+C
+      INTEGER  NAZ, IL1, IL2, LEV1, LEV2
+      INTEGER  NLONS, NLEVS, NAZMTH
+      REAL  SLOPE
+      REAL  FLUX_U(NLONS,NLEVS), FLUX_V(NLONS,NLEVS)
+      REAL  DRAG_U(NLONS,NLEVS), DRAG_V(NLONS,NLEVS)
+      REAL  ALT(NLONS,NLEVS),    DENSITY(NLONS,NLEVS), DENSB(NLONS)
+      REAL  M_ALPHA(NLONS,NLEVS,NAZMTH)
+      REAL  AK_ALPHA(NLONS,NAZMTH), K_ALPHA(NLONS,NAZMTH)
+C
+      LOGICAL LORMS(NLONS)
+C
+C  Internal variables.
+C
+      INTEGER  I, L, LEV1P, LEV2M
+      REAL  COS45, PROD2, PROD4, PROD6, PROD8, DENDZ, DENDZ2
+      DATA  COS45 / 0.7071068 /   
+C-----------------------------------------------------------------------
+C
+      LEV1P = LEV1 + 1
+      LEV2M = LEV2 - 1
+      LEV2P = LEV2 + 1
+C
+C  Sum over azimuths for case where SLOPE = 1.
+C
+      IF (SLOPE.EQ.1.)  THEN
+C
+C  Case with 4 azimuths.
+C
+        IF (NAZ.EQ.4)  THEN
+          DO 20 L = LEV1,LEV2
+            DO 10 I = IL1,IL2
+              FLUX_U(I,L) = AK_ALPHA(I,1)*K_ALPHA(I,1)*M_ALPHA(I,L,1)
+     ^                    - AK_ALPHA(I,3)*K_ALPHA(I,3)*M_ALPHA(I,L,3)
+              FLUX_V(I,L) = AK_ALPHA(I,2)*K_ALPHA(I,2)*M_ALPHA(I,L,2)
+     ^                    - AK_ALPHA(I,4)*K_ALPHA(I,4)*M_ALPHA(I,L,4)
+ 10         CONTINUE
+ 20       CONTINUE
+        END IF
+C
+C  Case with 8 azimuths.
+C
+        IF (NAZ.EQ.8)  THEN
+          DO 40 L = LEV1,LEV2
+            DO 30 I = IL1,IL2
+              PROD2 = AK_ALPHA(I,2)*K_ALPHA(I,2)*M_ALPHA(I,L,2)
+              PROD4 = AK_ALPHA(I,4)*K_ALPHA(I,4)*M_ALPHA(I,L,4)
+              PROD6 = AK_ALPHA(I,6)*K_ALPHA(I,6)*M_ALPHA(I,L,6)
+              PROD8 = AK_ALPHA(I,8)*K_ALPHA(I,8)*M_ALPHA(I,L,8)
+              FLUX_U(I,L) = 
+     ^                AK_ALPHA(I,1)*K_ALPHA(I,1)*M_ALPHA(I,L,1)
+     ^              - AK_ALPHA(I,5)*K_ALPHA(I,5)*M_ALPHA(I,L,5)
+     ^              + COS45 * ( PROD2 - PROD4 - PROD6 + PROD8 )
+              FLUX_V(I,L) = 
+     ^                AK_ALPHA(I,3)*K_ALPHA(I,3)*M_ALPHA(I,L,3)
+     ^              - AK_ALPHA(I,7)*K_ALPHA(I,7)*M_ALPHA(I,L,7)
+     ^              + COS45 * ( PROD2 + PROD4 - PROD6 - PROD8 )
+ 30         CONTINUE
+ 40       CONTINUE
+        END IF
+C
+      END IF
+C
+C  Sum over azimuths for case where SLOPE not equal to 1.
+C
+      IF (SLOPE.NE.1.)  THEN
+C
+C  Case with 4 azimuths.
+C
+        IF (NAZ.EQ.4)  THEN
+          DO 60 L = LEV1,LEV2
+            DO 50 I = IL1,IL2
+              FLUX_U(I,L) = 
+     ^               AK_ALPHA(I,1)*K_ALPHA(I,1)*M_ALPHA(I,L,1)**SLOPE
+     ^             - AK_ALPHA(I,3)*K_ALPHA(I,3)*M_ALPHA(I,L,3)**SLOPE
+              FLUX_V(I,L) = 
+     ^               AK_ALPHA(I,2)*K_ALPHA(I,2)*M_ALPHA(I,L,2)**SLOPE
+     ^             - AK_ALPHA(I,4)*K_ALPHA(I,4)*M_ALPHA(I,L,4)**SLOPE
+ 50         CONTINUE
+ 60       CONTINUE
+        END IF
+C
+C  Case with 8 azimuths.
+C
+        IF (NAZ.EQ.8)  THEN
+          DO 80 L = LEV1,LEV2
+            DO 70 I = IL1,IL2
+              PROD2 = AK_ALPHA(I,2)*K_ALPHA(I,2)*M_ALPHA(I,L,2)**SLOPE
+              PROD4 = AK_ALPHA(I,4)*K_ALPHA(I,4)*M_ALPHA(I,L,4)**SLOPE
+              PROD6 = AK_ALPHA(I,6)*K_ALPHA(I,6)*M_ALPHA(I,L,6)**SLOPE
+              PROD8 = AK_ALPHA(I,8)*K_ALPHA(I,8)*M_ALPHA(I,L,8)**SLOPE
+              FLUX_U(I,L) = 
+     ^                AK_ALPHA(I,1)*K_ALPHA(I,1)*M_ALPHA(I,L,1)**SLOPE
+     ^              - AK_ALPHA(I,5)*K_ALPHA(I,5)*M_ALPHA(I,L,5)**SLOPE
+     ^              + COS45 * ( PROD2 - PROD4 - PROD6 + PROD8 )
+              FLUX_V(I,L) = 
+     ^                AK_ALPHA(I,3)*K_ALPHA(I,3)*M_ALPHA(I,L,3)**SLOPE
+     ^              - AK_ALPHA(I,7)*K_ALPHA(I,7)*M_ALPHA(I,L,7)**SLOPE
+     ^              + COS45 * ( PROD2 + PROD4 - PROD6 - PROD8 )
+ 70         CONTINUE
+ 80       CONTINUE
+        END IF
+C
+      END IF
+C
+C  Calculate flux from sum.
+C
+      DO 100 L = LEV1,LEV2
+        DO 90 I = IL1,IL2
+          FLUX_U(I,L) = FLUX_U(I,L) * DENSB(I) / SLOPE
+          FLUX_V(I,L) = FLUX_V(I,L) * DENSB(I) / SLOPE
+  90    CONTINUE
+ 100  CONTINUE
+C
+C  Calculate drag at intermediate levels using centered differences 
+C      
+      DO 120 L = LEV1P,LEV2M
+        DO 110 I = IL1,IL2
+        IF (LORMS(I)) THEN
+ccc       DENDZ2 = DENSITY(I,L) * ( ALT(I,L+1) - ALT(I,L-1) )
+          DENDZ2 = DENSITY(I,L) * ( ALT(I,L-1) - ALT(I,L) ) 
+ccc       DRAG_U(I,L) = - ( FLUX_U(I,L+1) - FLUX_U(I,L-1) ) / DENDZ2
+          DRAG_U(I,L) = - ( FLUX_U(I,L-1) - FLUX_U(I,L) ) / DENDZ2
+ccc       DRAG_V(I,L) = - ( FLUX_V(I,L+1) - FLUX_V(I,L-1) ) / DENDZ2
+          DRAG_V(I,L) = - ( FLUX_V(I,L-1) - FLUX_V(I,L) ) / DENDZ2
+          
+        ENDIF
+ 110    CONTINUE
+ 120  CONTINUE
+C
+C  Drag at first and last levels using one-side differences.
+C 
+      DO 130 I = IL1,IL2
+      IF (LORMS(I)) THEN
+        DENDZ = DENSITY(I,LEV1) * ( ALT(I,LEV1) - ALT(I,LEV1P) ) 
+        DRAG_U(I,LEV1) =  FLUX_U(I,LEV1)  / DENDZ
+        DRAG_V(I,LEV1) =  FLUX_V(I,LEV1)  / DENDZ
+      ENDIF
+ 130  CONTINUE
+      DO 140 I = IL1,IL2
+      IF (LORMS(I)) THEN
+        DENDZ = DENSITY(I,LEV2) * ( ALT(I,LEV2M) - ALT(I,LEV2) )
+        DRAG_U(I,LEV2) = - ( FLUX_U(I,LEV2M) - FLUX_U(I,LEV2) ) / DENDZ
+        DRAG_V(I,LEV2) = - ( FLUX_V(I,LEV2M) - FLUX_V(I,LEV2) ) / DENDZ
+      ENDIF
+ 140  CONTINUE
+      IF (NLEVS .GT. LEV2) THEN
+      DO 150 I = IL1,IL2
+      IF (LORMS(I)) THEN
+        DENDZ = DENSITY(I,LEV2P) * ( ALT(I,LEV2) - ALT(I,LEV2P) )
+        DRAG_U(I,LEV2P) = -  FLUX_U(I,LEV2)  / DENDZ
+        DRAG_V(I,LEV2P) = - FLUX_V(I,LEV2)  / DENDZ
+      ENDIF
+150   CONTINUE
+      ENDIF
+C
+      RETURN
+C-----------------------------------------------------------------------
+      END
+
+      SUBROUTINE HINES_HEAT (HEAT,DIFFCO,M_ALPHA,DMDZ_ALPHA,
+     1                       AK_ALPHA,K_ALPHA,BVFREQ,DENSITY,DENSB,
+     2                       SIGMA_T,VISC_MOL,KSTAR,SLOPE,F2,F3,F5,F6,
+     3                       NAZ,IL1,IL2,LEV1,LEV2,NLONS,NLEVS,NAZMTH)
+C
+C  This routine calculates the gravity wave induced heating and 
+C  diffusion coefficient on a longitude by altitude grid for  
+C  the Hines' Doppler spread gravity wave drag parameterization scheme.
+C
+C  Aug. 6/95 - C. McLandress
+C
+C  Output arguements:
+C
+C     * HEAT   = gravity wave heating (K/sec).
+C     * DIFFCO = diffusion coefficient (m^2/sec)
+C
+C  Input arguements:
+C
+C     * M_ALPHA     = cutoff vertical wavenumber (1/m).
+C     * DMDZ_ALPHA  = vertical derivative of cutoff wavenumber.
+C     * AK_ALPHA    = spectral amplitude factor of each azimuth 
+C                     (i.e., {AjKj} in m^4/s^2).
+C     * K_ALPHA     = horizontal wavenumber of each azimuth (1/m).
+C     * BVFREQ      = background Brunt Vassala frequency (rad/sec).
+C     * DENSITY     = background density (kg/m^3).
+C     * DENSB       = background density at bottom level (kg/m^3).
+C     * SIGMA_T     = total rms horizontal wind (m/s).
+C     * VISC_MOL    = molecular viscosity (m^2/s).
+C     * KSTAR       = typical gravity wave horizontal wavenumber (1/m).
+C     * SLOPE       = slope of incident vertical wavenumber spectrum.
+C     * F2,F3,F5,F6 = Hines's fudge factors.
+C     * NAZ         = actual number of horizontal azimuths used.
+C     * IL1         = first longitudinal index to use (IL1 >= 1).
+C     * IL2         = last longitudinal index to use (IL1 <= IL2 <= NLONS).
+C     * LEV1        = first altitude level to use (LEV1 >=1). 
+C     * LEV2        = last altitude level to use (LEV1 < LEV2 <= NLEVS).
+C     * NLONS       = number of longitudes.
+C     * NLEVS       = number of vertical levels.
+C     * NAZMTH      = azimuthal array dimension (NAZMTH >= NAZ).
+C
+      INTEGER  NAZ, IL1, IL2, LEV1, LEV2, NLONS, NLEVS, NAZMTH
+      REAL  KSTAR(NLONS), SLOPE, F2, F3, F5, F6
+      REAL  HEAT(NLONS,NLEVS), DIFFCO(NLONS,NLEVS)
+      REAL  M_ALPHA(NLONS,NLEVS,NAZMTH), DMDZ_ALPHA(NLONS,NLEVS,NAZMTH)
+      REAL  AK_ALPHA(NLONS,NAZMTH), K_ALPHA(NLONS,NAZMTH)
+      REAL  BVFREQ(NLONS,NLEVS), DENSITY(NLONS,NLEVS),  DENSB(NLONS) 
+      REAL  SIGMA_T(NLONS,NLEVS), VISC_MOL(NLONS,NLEVS)
+C
+C Internal variables.
+C
+      INTEGER  I, L, N
+      REAL  M_SUB_M_TURB, M_SUB_M_MOL, M_SUB_M, HEATNG
+      REAL  VISC, VISC_MIN, CPGAS, SM1
+C
+C specific heat at constant pressure
+C
+      DATA  CPGAS / 1004. / 
+C             
+C minimum permissible viscosity
+C
+      DATA  VISC_MIN / 1.E-10 /       
+C-----------------------------------------------------------------------     
+C
+C  Initialize heating array.
+C
+      DO 20 L = 1,NLEVS
+        DO 10 I = 1,NLONS
+          HEAT(I,L) = 0.
+  10    CONTINUE
+  20  CONTINUE
+C
+C  Perform sum over azimuths for case where SLOPE = 1.
+C
+      IF (SLOPE.EQ.1.)  THEN
+        DO 50 N = 1,NAZ
+          DO 40 L = LEV1,LEV2
+            DO 30 I = IL1,IL2
+              HEAT(I,L) = HEAT(I,L) + AK_ALPHA(I,N) * K_ALPHA(I,N) 
+     ^                    * DMDZ_ALPHA(I,L,N) 
+ 30         CONTINUE
+ 40       CONTINUE
+ 50     CONTINUE
+      END IF
+C
+C  Perform sum over azimuths for case where SLOPE not 1.
+C
+      IF (SLOPE.NE.1.)  THEN
+        SM1 = SLOPE - 1.
+        DO 80 N = 1,NAZ
+          DO 70 L = LEV1,LEV2
+            DO 60 I = IL1,IL2
+              HEAT(I,L) = HEAT(I,L) + AK_ALPHA(I,N) * K_ALPHA(I,N) 
+     ^                    * M_ALPHA(I,L,N)**SM1 * DMDZ_ALPHA(I,L,N) 
+ 60         CONTINUE
+ 70       CONTINUE
+ 80     CONTINUE
+      END IF
+C
+C  Heating and diffusion.
+C
+      DO 100 L = LEV1,LEV2
+        DO 90 I = IL1,IL2
+C
+C  Maximum permissible value of cutoff wavenumber is the smaller 
+C  of the instability-induced wavenumber (M_SUB_M_TURB) and 
+C  that imposed by molecular viscosity (M_SUB_M_MOL).
+C
+          VISC    = AMAX1 ( VISC_MOL(I,L), VISC_MIN )
+          M_SUB_M_TURB = BVFREQ(I,L) / ( F2 * SIGMA_T(I,L) )
+          M_SUB_M_MOL  = (BVFREQ(I,L)*KSTAR(I)/VISC)**0.33333333/F3
+          M_SUB_M      = AMIN1 ( M_SUB_M_TURB, M_SUB_M_MOL )
+C
+          HEATNG = - HEAT(I,L) * F5 * BVFREQ(I,L) / M_SUB_M 
+     ^               * DENSB(I) / DENSITY(I,L) 
+          DIFFCO(I,L) = F6 * HEATNG**0.33333333 / M_SUB_M**1.33333333
+          HEAT(I,L)   = HEATNG / CPGAS
+C
+ 90     CONTINUE
+ 100  CONTINUE
+C
+      RETURN
+C-----------------------------------------------------------------------
+      END
+
+      SUBROUTINE HINES_SIGMA (SIGMA_T,SIGMA_ALPHA,SIGSQH_ALPHA,
+     1                        NAZ,LEV,IL1,IL2,NLONS,NLEVS,NAZMTH)
+C
+C  This routine calculates the total rms and azimuthal rms horizontal 
+C  velocities at a given level on a longitude by altitude grid for 
+C  the Hines' Doppler spread GWD parameterization scheme.
+C  NOTE: only four or eight azimuths can be used.
+C
+C  Aug. 7/95 - C. McLandress
+C
+C  Output arguements:
+C
+C     * SIGMA_T      = total rms horizontal wind (m/s).
+C     * SIGMA_ALPHA  = total rms wind in each azimuth (m/s).
+C
+C  Input arguements:
+C
+C     * SIGSQH_ALPHA = portion of wind variance from waves having wave
+C     *                normals in the alpha azimuth (m/s).
+C     * NAZ       = actual number of horizontal azimuths used (must be 4 or 8).
+C     * LEV       = altitude level to process.
+C     * IL1       = first longitudinal index to use (IL1 >= 1).
+C     * IL2       = last longitudinal index to use (IL1 <= IL2 <= NLONS).
+C     * NLONS     = number of longitudes.
+C     * NLEVS     = number of vertical levels.
+C     * NAZMTH    = azimuthal array dimension (NAZMTH >= NAZ).
+C
+C  Subroutine arguements.
+C
+      INTEGER  LEV, NAZ, IL1, IL2
+      INTEGER  NLONS, NLEVS, NAZMTH
+      REAL  SIGMA_T(NLONS,NLEVS)
+      REAL  SIGMA_ALPHA(NLONS,NLEVS,NAZMTH)
+      REAL  SIGSQH_ALPHA(NLONS,NLEVS,NAZMTH)
+C
+C  Internal variables.
+C
+      INTEGER  I, N
+      REAL  SUM_EVEN, SUM_ODD 
+C-----------------------------------------------------------------------     
+C
+C  Calculate azimuthal rms velocity for the 4 azimuth case.
+C
+      IF (NAZ.EQ.4)  THEN
+        DO 10 I = IL1,IL2
+          SIGMA_ALPHA(I,LEV,1) = SQRT ( SIGSQH_ALPHA(I,LEV,1)
+     ^                                + SIGSQH_ALPHA(I,LEV,3) )
+          SIGMA_ALPHA(I,LEV,2) = SQRT ( SIGSQH_ALPHA(I,LEV,2)
+     ^                                + SIGSQH_ALPHA(I,LEV,4) )
+          SIGMA_ALPHA(I,LEV,3) = SIGMA_ALPHA(I,LEV,1)
+          SIGMA_ALPHA(I,LEV,4) = SIGMA_ALPHA(I,LEV,2)
+ 10     CONTINUE
+      END IF
+C
+C  Calculate azimuthal rms velocity for the 8 azimuth case.
+C
+      IF (NAZ.EQ.8)  THEN
+        DO 20 I = IL1,IL2
+          SUM_ODD  = ( SIGSQH_ALPHA(I,LEV,1) 
+     ^                 + SIGSQH_ALPHA(I,LEV,3) 
+     ^                 + SIGSQH_ALPHA(I,LEV,5) 
+     ^                 + SIGSQH_ALPHA(I,LEV,7) ) / 2.
+          SUM_EVEN = ( SIGSQH_ALPHA(I,LEV,2) 
+     ^                 + SIGSQH_ALPHA(I,LEV,4)
+     ^                 + SIGSQH_ALPHA(I,LEV,6) 
+     ^                 + SIGSQH_ALPHA(I,LEV,8) ) / 2.
+          SIGMA_ALPHA(I,LEV,1) = SQRT ( SIGSQH_ALPHA(I,LEV,1) 
+     ^                           + SIGSQH_ALPHA(I,LEV,5) + SUM_EVEN )
+          SIGMA_ALPHA(I,LEV,2) = SQRT ( SIGSQH_ALPHA(I,LEV,2) 
+     ^                           + SIGSQH_ALPHA(I,LEV,6) + SUM_ODD )
+          SIGMA_ALPHA(I,LEV,3) = SQRT ( SIGSQH_ALPHA(I,LEV,3) 
+     ^                           + SIGSQH_ALPHA(I,LEV,7) + SUM_EVEN )
+          SIGMA_ALPHA(I,LEV,4) = SQRT ( SIGSQH_ALPHA(I,LEV,4) 
+     ^                           + SIGSQH_ALPHA(I,LEV,8) + SUM_ODD )
+          SIGMA_ALPHA(I,LEV,5) = SIGMA_ALPHA(I,LEV,1)
+          SIGMA_ALPHA(I,LEV,6) = SIGMA_ALPHA(I,LEV,2)
+          SIGMA_ALPHA(I,LEV,7) = SIGMA_ALPHA(I,LEV,3)
+          SIGMA_ALPHA(I,LEV,8) = SIGMA_ALPHA(I,LEV,4)
+ 20     CONTINUE
+      END IF
+C
+C  Calculate total rms velocity.
+C
+      DO 50 I = IL1,IL2
+        SIGMA_T(I,LEV) = 0.
+ 50   CONTINUE
+      DO 70 N = 1,NAZ
+        DO 60 I = IL1,IL2
+          SIGMA_T(I,LEV) = SIGMA_T(I,LEV) + SIGSQH_ALPHA(I,LEV,N)
+ 60     CONTINUE
+ 70   CONTINUE
+      DO 80 I = IL1,IL2
+        SIGMA_T(I,LEV) = SQRT ( SIGMA_T(I,LEV) )
+ 80   CONTINUE
+C
+      RETURN
+C-----------------------------------------------------------------------     
+      END
+
+      SUBROUTINE HINES_INTGRL (I_ALPHA,V_ALPHA,M_ALPHA,BVFB,SLOPE,
+     1                         NAZ,LEV,IL1,IL2,NLONS,NLEVS,NAZMTH,
+     2                         LORMS)
+C
+C  This routine calculates the vertical wavenumber integral
+C  for a single vertical level at each azimuth on a longitude grid
+C  for the Hines' Doppler spread GWD parameterization scheme.
+C  NOTE: (1) only spectral slopes of 1, 1.5 or 2 are permitted.
+C        (2) the integral is written in terms of the product QM
+C            which by construction is always less than 1. Series
+C            solutions are used for small |QM| and analytical solutions
+C            for remaining values.
+C
+C  Aug. 8/95 - C. McLandress
+C
+C  Output arguement:
+C
+C     * I_ALPHA = Hines' integral.
+C
+C  Input arguements:
+C
+C     * V_ALPHA = azimuthal wind component (m/s). 
+C     * M_ALPHA = azimuthal cutoff vertical wavenumber (1/m).
+C     * BVFB    = background Brunt Vassala frequency at model bottom.
+C     * SLOPE   = slope of initial vertical wavenumber spectrum 
+C     *           (must use SLOPE = 1., 1.5 or 2.)
+C     * NAZ     = actual number of horizontal azimuths used.
+C     * LEV     = altitude level to process.
+C     * IL1     = first longitudinal index to use (IL1 >= 1).
+C     * IL2     = last longitudinal index to use (IL1 <= IL2 <= NLONS).
+C     * NLONS   = number of longitudes.
+C     * NLEVS   = number of vertical levels.
+C     * NAZMTH  = azimuthal array dimension (NAZMTH >= NAZ).
+C
+C     * LORMS       = .TRUE. for drag computation 
+C
+C  Constants in DATA statements:
+C
+C     * QMIN = minimum value of Q_ALPHA (avoids indeterminant form of integral)
+C     * QM_MIN = minimum value of Q_ALPHA * M_ALPHA (used to avoid numerical
+C     *          problems).
+C
+      INTEGER  LEV, NAZ, IL1, IL2, NLONS, NLEVS, NAZMTH
+      REAL  I_ALPHA(NLONS,NAZMTH)
+      REAL  V_ALPHA(NLONS,NLEVS,NAZMTH)
+      REAL  M_ALPHA(NLONS,NLEVS,NAZMTH)
+      REAL  BVFB(NLONS), SLOPE
+C
+      LOGICAL LORMS(NLONS)
+C
+C  Internal variables.
+C
+      INTEGER  I, N
+      REAL  Q_ALPHA, QM, SQRTQM, Q_MIN, QM_MIN
+C
+      DATA  Q_MIN / 1.0 /, QM_MIN / 0.01 /
+C-----------------------------------------------------------------------     
+C
+C  For integer value SLOPE = 1.
+C
+      IF (SLOPE .EQ. 1.)  THEN
+C
+        DO 20 N = 1,NAZ
+          DO 10 I = IL1,IL2
+          IF (LORMS(I)) THEN
+C
+            Q_ALPHA = V_ALPHA(I,LEV,N) / BVFB(I)
+            QM = Q_ALPHA * M_ALPHA(I,LEV,N)
+C
+C  If |QM| is small then use first 4 terms series of Taylor series
+C  expansion of integral in order to avoid indeterminate form of integral,
+C  otherwise use analytical form of integral.
+C
+            IF (ABS(Q_ALPHA).LT.Q_MIN .OR. ABS(QM).LT.QM_MIN)  THEN  
+              IF (Q_ALPHA .EQ. 0.)  THEN
+                I_ALPHA(I,N) = M_ALPHA(I,LEV,N)**2 / 2.
+              ELSE
+                I_ALPHA(I,N) = ( QM**2/2. + QM**3/3. + QM**4/4.
+     ^                           + QM**5/5. ) / Q_ALPHA**2
+              END IF
+            ELSE
+              I_ALPHA(I,N) = - ( ALOG(1.-QM) + QM ) / Q_ALPHA**2
+            END IF
+C
+          ENDIF
+ 10       CONTINUE
+ 20     CONTINUE
+C
+      END IF
+C
+C  For integer value SLOPE = 2.
+C
+      IF (SLOPE .EQ. 2.)  THEN
+C
+        DO 40 N = 1,NAZ
+          DO 30 I = IL1,IL2
+          IF (LORMS(I)) THEN
+C
+            Q_ALPHA = V_ALPHA(I,LEV,N) / BVFB(I)
+            QM = Q_ALPHA * M_ALPHA(I,LEV,N)
+C
+C  If |QM| is small then use first 4 terms series of Taylor series
+C  expansion of integral in order to avoid indeterminate form of integral,
+C  otherwise use analytical form of integral.
+C
+            IF (ABS(Q_ALPHA).LT.Q_MIN .OR. ABS(QM).LT.QM_MIN)  THEN  
+              IF (Q_ALPHA .EQ. 0.)  THEN
+                I_ALPHA(I,N) = M_ALPHA(I,LEV,N)**3 / 3.
+              ELSE
+                I_ALPHA(I,N) = ( QM**3/3. + QM**4/4. + QM**5/5. 
+     ^                           + QM**6/6. ) / Q_ALPHA**3
+              END IF
+            ELSE
+              I_ALPHA(I,N) = - ( ALOG(1.-QM) + QM + QM**2/2.) 
+     ^                         / Q_ALPHA**3
+            END IF
+C
+          ENDIF
+ 30       CONTINUE
+ 40     CONTINUE
+C
+      END IF
+C
+C  For real value SLOPE = 1.5
+C
+      IF (SLOPE .EQ. 1.5)  THEN
+C
+        DO 60 N = 1,NAZ
+          DO 50 I = IL1,IL2
+          IF (LORMS(I)) THEN
+C
+            Q_ALPHA = V_ALPHA(I,LEV,N) / BVFB(I)
+            QM = Q_ALPHA * M_ALPHA(I,LEV,N)       
+C
+C  If |QM| is small then use first 4 terms series of Taylor series
+C  expansion of integral in order to avoid indeterminate form of integral,
+C  otherwise use analytical form of integral.
+C
+            IF (ABS(Q_ALPHA).LT.Q_MIN .OR. ABS(QM).LT.QM_MIN)  THEN  
+              IF (Q_ALPHA .EQ. 0.)  THEN
+                I_ALPHA(I,N) = M_ALPHA(I,LEV,N)**2.5 / 2.5
+              ELSE
+                I_ALPHA(I,N) = ( QM/2.5 + QM**2/3.5 
+     ^                           + QM**3/4.5 + QM**4/5.5 ) 
+     ^                           * M_ALPHA(I,LEV,N)**1.5 / Q_ALPHA
+              END IF
+            ELSE
+              QM     = ABS(QM)
+              SQRTQM = SQRT(QM)
+              IF (Q_ALPHA .GE. 0.)  THEN
+                I_ALPHA(I,N) = ( ALOG( (1.+SQRTQM)/(1.-SQRTQM) )
+     ^                          -2.*SQRTQM*(1.+QM/3.) ) / Q_ALPHA**2.5
+              ELSE
+                I_ALPHA(I,N) = 2. * ( ATAN(SQRTQM) + SQRTQM*(QM/3.-1.) )
+     ^                          / ABS(Q_ALPHA)**2.5
+              END IF
+            END IF
+C
+          ENDIF
+ 50       CONTINUE
+ 60     CONTINUE
+C
+      END IF
+C
+C  If integral is negative (which in principal should not happen) then
+C  print a message and some info since execution will abort when calculating
+C  the variances.
+C
+      DO 80 N = 1,NAZ
+        DO 70 I = IL1,IL2
+          IF (I_ALPHA(I,N).LT.0.)  THEN
+            WRITE (6,*) 
+            WRITE (6,*) '******************************'
+            WRITE (6,*) 'Hines integral I_ALPHA < 0 '
+            WRITE (6,*) '  longitude I=',I
+            WRITE (6,*) '  azimuth   N=',N
+            WRITE (6,*) '  level   LEV=',LEV
+            WRITE (6,*) '  I_ALPHA =',I_ALPHA(I,N)
+            WRITE (6,*) '  V_ALPHA =',V_ALPHA(I,LEV,N)
+            WRITE (6,*) '  M_ALPHA =',M_ALPHA(I,LEV,N)
+            WRITE (6,*) '  Q_ALPHA =',V_ALPHA(I,LEV,N) / BVFB(I)
+            WRITE (6,*) '  QM      =',V_ALPHA(I,LEV,N) / BVFB(I) 
+     ^                                * M_ALPHA(I,LEV,N)
+            WRITE (6,*) '******************************'
+          END IF
+ 70     CONTINUE
+ 80   CONTINUE
+C
+      RETURN
+C-----------------------------------------------------------------------
+      END
+
+      SUBROUTINE HINES_SETUP (NAZ,SLOPE,F1,F2,F3,F5,F6,KSTAR,
+     1                        ICUTOFF,ALT_CUTOFF,SMCO,NSMAX,IHEATCAL,
+     2                       K_ALPHA,IERROR,NMESSG,NLONS,NAZMTH,COSLAT)
+C
+C  This routine specifies various parameters needed for the
+C  the Hines' Doppler spread gravity wave drag parameterization scheme.
+C
+C  Aug. 8/95 - C. McLandress
+C
+C  Output arguements:
+C
+C     * NAZ        = actual number of horizontal azimuths used
+C     *              (code set up presently for only NAZ = 4 or 8).
+C     * SLOPE      = slope of incident vertical wavenumber spectrum
+C     *              (code set up presently for SLOPE 1., 1.5 or 2.).
+C     * F1         = "fudge factor" used in calculation of trial value of
+C     *              azimuthal cutoff wavenumber M_ALPHA (1.2 <= F1 <= 1.9).
+C     * F2         = "fudge factor" used in calculation of maximum
+C     *              permissible instabiliy-induced cutoff wavenumber 
+C     *              M_SUB_M_TURB (0.1 <= F2 <= 1.4).
+C     * F3         = "fudge factor" used in calculation of maximum 
+C     *              permissible molecular viscosity-induced cutoff wavenumber 
+C     *              M_SUB_M_MOL (0.1 <= F2 <= 1.4).
+C     * F5         = "fudge factor" used in calculation of heating rate
+C     *              (1 <= F5 <= 3).
+C     * F6         = "fudge factor" used in calculation of turbulent 
+C     *              diffusivity coefficient.
+C     * KSTAR      = typical gravity wave horizontal wavenumber (1/m)
+C     *              used in calculation of M_SUB_M_TURB.
+C     * ICUTOFF    = 1 to exponentially damp off GWD, heating and diffusion 
+C     *              arrays above ALT_CUTOFF; otherwise arrays not modified.
+C     * ALT_CUTOFF = altitude in meters above which exponential decay applied.
+C     * SMCO       = smoother used to smooth cutoff vertical wavenumbers
+C     *              and total rms winds before calculating drag or heating.
+C     *              (==> a 1:SMCO:1 stencil used; SMCO >= 1.).
+C     * NSMAX      = number of times smoother applied ( >= 1),
+C     *            = 0 means no smoothing performed.
+C     * IHEATCAL   = 1 to calculate heating rates and diffusion coefficient.
+C     *            = 0 means only drag and flux calculated.
+C     * K_ALPHA    = horizontal wavenumber of each azimuth (1/m) which
+C     *              is set here to KSTAR.
+C     * IERROR     = error flag.
+C     *            = 0 no errors.
+C     *            = 10 ==> NAZ > NAZMTH
+C     *            = 20 ==> invalid number of azimuths (NAZ must be 4 or 8).
+C     *            = 30 ==> invalid slope (SLOPE must be 1., 1.5 or 2.).
+C     *            = 40 ==> invalid smoother (SMCO must be >= 1.)
+C
+C  Input arguements:
+C
+C     * NMESSG  = output unit number where messages to be printed.
+C     * NLONS   = number of longitudes.
+C     * NAZMTH  = azimuthal array dimension (NAZMTH >= NAZ).
+C
+      INTEGER  NAZ, NLONS, NAZMTH, IHEATCAL, ICUTOFF
+      INTEGER  NMESSG, NSMAX, IERROR
+      REAL  KSTAR(NLONS), SLOPE, F1, F2, F3, F5, F6, ALT_CUTOFF, SMCO
+      REAL  K_ALPHA(NLONS,NAZMTH),COSLAT(NLONS)
+      REAL  KSMIN, KSMAX
+C
+C Internal variables.
+C
+      INTEGER  I, N
+C-----------------------------------------------------------------------     
+C
+C  Specify constants.
+C
+      NAZ   = 8
+      SLOPE = 1.
+      F1    = 1.5 
+      F2    = 0.3 
+      F3    = 1.0 
+      F5    = 3.0 
+      F6    = 1.0       
+      KSMIN = 1.E-5       
+      KSMAX = 1.E-4       
+      DO I=1,NLONS
+         KSTAR(I) = KSMIN/( COSLAT(I)+(KSMIN/KSMAX) )      
+      ENDDO
+      ICUTOFF    = 1   
+      ALT_CUTOFF = 105.E3
+      SMCO       = 2.0 
+c      SMCO       = 1.0 
+      NSMAX      = 5
+c      NSMAX      = 2
+      IHEATCAL   = 0 
+C
+C  Print information to output file.
+C
+c      WRITE (NMESSG,6000)
+c 6000 FORMAT (/' Subroutine HINES_SETUP:')
+c      WRITE (NMESSG,*)  '  SLOPE = ', SLOPE
+c      WRITE (NMESSG,*)  '  NAZ = ', NAZ
+c      WRITE (NMESSG,*)  '  F1,F2,F3  = ', F1, F2, F3
+c      WRITE (NMESSG,*)  '  F5,F6     = ', F5, F6
+c      WRITE (NMESSG,*)  '  KSTAR     = ', KSTAR
+c     >           ,'  COSLAT     = ', COSLAT
+c      IF (ICUTOFF .EQ. 1)  THEN
+c        WRITE (NMESSG,*) '  Drag exponentially damped above ',
+c     &                       ALT_CUTOFF/1.E3
+c     END IF
+c      IF (NSMAX.LT.1 )  THEN
+c        WRITE (NMESSG,*) '  No smoothing of cutoff wavenumbers, etc'
+c      ELSE
+c        WRITE (NMESSG,*) '  Cutoff wavenumbers and sig_t smoothed:'
+c        WRITE (NMESSG,*) '    SMCO  =', SMCO
+c        WRITE (NMESSG,*) '    NSMAX =', NSMAX
+c     END IF
+C
+C  Check that things are setup correctly and log error if not
+C
+      IERROR = 0
+      IF (NAZ .GT. NAZMTH)                                  IERROR = 10
+      IF (NAZ.NE.4 .AND. NAZ.NE.8)                          IERROR = 20
+      IF (SLOPE.NE.1. .AND. SLOPE.NE.1.5 .AND. SLOPE.NE.2.) IERROR = 30
+      IF (SMCO .LT. 1.)                                     IERROR = 40
+C
+C  Use single value for azimuthal-dependent horizontal wavenumber.
+C
+      DO 20 N = 1,NAZ
+        DO 10 I = 1,NLONS
+          K_ALPHA(I,N) = KSTAR(I)
+ 10     CONTINUE
+ 20   CONTINUE
+C
+      RETURN
+C-----------------------------------------------------------------------
+      END
+
+      SUBROUTINE HINES_PRINT (FLUX_U,FLUX_V,DRAG_U,DRAG_V,ALT,SIGMA_T,
+     1                        SIGMA_ALPHA,V_ALPHA,M_ALPHA,
+     2                        IU_PRINT,IV_PRINT,NMESSG,
+     3                        ILPRT1,ILPRT2,LEVPRT1,LEVPRT2,
+     4                        NAZ,NLONS,NLEVS,NAZMTH)
+C
+C  Print out altitude profiles of various quantities from
+C  Hines' Doppler spread gravity wave drag parameterization scheme.
+C  (NOTE: only for NAZ = 4 or 8). 
+C
+C  Aug. 8/95 - C. McLandress
+C
+C  Input arguements:
+C
+C     * IU_PRINT = 1 to print out values in east-west direction.
+C     * IV_PRINT = 1 to print out values in north-south direction.
+C     * NMESSG   = unit number for printed output.
+C     * ILPRT1   = first longitudinal index to print.
+C     * ILPRT2   = last longitudinal index to print.
+C     * LEVPRT1  = first altitude level to print.
+C     * LEVPRT2  = last altitude level to print.
+C
+      INTEGER  NAZ, ILPRT1, ILPRT2, LEVPRT1, LEVPRT2
+      INTEGER  NLONS, NLEVS, NAZMTH
+      INTEGER  IU_PRINT, IV_PRINT, NMESSG
+      REAL  FLUX_U(NLONS,NLEVS), FLUX_V(NLONS,NLEVS)
+      REAL  DRAG_U(NLONS,NLEVS), DRAG_V(NLONS,NLEVS)
+      REAL  ALT(NLONS,NLEVS), SIGMA_T(NLONS,NLEVS)
+      REAL  SIGMA_ALPHA(NLONS,NLEVS,NAZMTH)
+      REAL  V_ALPHA(NLONS,NLEVS,NAZMTH), M_ALPHA(NLONS,NLEVS,NAZMTH)
+C
+C  Internal variables.
+C
+      INTEGER  N_EAST, N_WEST, N_NORTH, N_SOUTH
+      INTEGER  I, L
+C-----------------------------------------------------------------------
+C
+C  Azimuthal indices of cardinal directions.
+C
+      N_EAST = 1
+      IF (NAZ.EQ.4)  THEN
+        N_WEST  = 3       
+        N_NORTH = 2
+        N_SOUTH = 4       
+      ELSE IF (NAZ.EQ.8)  THEN
+        N_WEST  = 5       
+        N_NORTH = 3
+        N_SOUTH = 7       
+      END IF
+C
+C  Print out values for range of longitudes.
+C
+      DO 100 I = ILPRT1,ILPRT2
+C
+C  Print east-west wind, sigmas, cutoff wavenumbers, flux and drag.
+C
+        IF (IU_PRINT.EQ.1)  THEN
+          WRITE (NMESSG,*) 
+          WRITE (NMESSG,6001) I
+          WRITE (NMESSG,6005) 
+ 6001     FORMAT ( 'Hines GW (east-west) at longitude I =',I3)
+ 6005     FORMAT (15x,' U ',2x,'sig_E',2x,'sig_T',3x,'m_E',
+     &            4x,'m_W',4x,'fluxU',5x,'gwdU')
+          DO 10 L = LEVPRT1,LEVPRT2
+            WRITE (NMESSG,6701) ALT(I,L)/1.E3, V_ALPHA(I,L,N_EAST), 
+     &                          SIGMA_ALPHA(I,L,N_EAST), SIGMA_T(I,L),
+     &                          M_ALPHA(I,L,N_EAST)*1.E3, 
+     &                          M_ALPHA(I,L,N_WEST)*1.E3,
+     &                          FLUX_U(I,L)*1.E5, DRAG_U(I,L)*24.*3600.
+  10      CONTINUE
+ 6701     FORMAT (' z=',f7.2,1x,3f7.1,2f7.3,f9.4,f9.3)
+        END IF
+C
+C  Print north-south winds, sigmas, cutoff wavenumbers, flux and drag.
+C
+        IF (IV_PRINT.EQ.1)  THEN
+          WRITE(NMESSG,*) 
+          WRITE(NMESSG,6002) I
+ 6002     FORMAT ( 'Hines GW (north-south) at longitude I =',I3)
+          WRITE(NMESSG,6006) 
+ 6006     FORMAT (15x,' V ',2x,'sig_N',2x,'sig_T',3x,'m_N',
+     &            4x,'m_S',4x,'fluxV',5x,'gwdV')
+          DO 20 L = LEVPRT1,LEVPRT2
+            WRITE (NMESSG,6701) ALT(I,L)/1.E3, V_ALPHA(I,L,N_NORTH), 
+     &                          SIGMA_ALPHA(I,L,N_NORTH), SIGMA_T(I,L),
+     &                          M_ALPHA(I,L,N_NORTH)*1.E3, 
+     &                          M_ALPHA(I,L,N_SOUTH)*1.E3,
+     &                          FLUX_V(I,L)*1.E5, DRAG_V(I,L)*24.*3600.
+ 20       CONTINUE
+        END IF
+C
+ 100  CONTINUE
+C
+      RETURN
+C-----------------------------------------------------------------------
+      END
+
+      SUBROUTINE HINES_EXP (DATA,DATA_ZMAX,ALT,ALT_EXP,IORDER,
+     1                      IL1,IL2,LEV1,LEV2,NLONS,NLEVS)
+C
+C  This routine exponentially damps a longitude by altitude array 
+C  of data above a specified altitude.
+C
+C  Aug. 13/95 - C. McLandress
+C
+C  Output arguements:
+C
+C     * DATA = modified data array.
+C
+C  Input arguements:
+C
+C     * DATA    = original data array.
+C     * ALT     = altitudes.
+C     * ALT_EXP = altitude above which exponential decay applied.
+C     * IORDER	= 1 means vertical levels are indexed from top down 
+C     *           (i.e., highest level indexed 1 and lowest level NLEVS);
+C     *           .NE. 1 highest level is index NLEVS.
+C     * IL1     = first longitudinal index to use (IL1 >= 1).
+C     * IL2     = last longitudinal index to use (IL1 <= IL2 <= NLONS).
+C     * LEV1    = first altitude level to use (LEV1 >=1). 
+C     * LEV2    = last altitude level to use (LEV1 < LEV2 <= NLEVS).
+C     * NLONS   = number of longitudes.
+C     * NLEVS   = number of vertical
+C
+C  Input work arrays:
+C
+C     * DATA_ZMAX = data values just above altitude ALT_EXP.
+C
+      INTEGER  IORDER, IL1, IL2, LEV1, LEV2, NLONS, NLEVS
+      REAL  ALT_EXP
+      REAL  DATA(NLONS,NLEVS), DATA_ZMAX(NLONS), ALT(NLONS,NLEVS)
+C
+C Internal variables.
+C
+      INTEGER  LEVBOT, LEVTOP, LINCR, I, L
+      REAL  HSCALE
+      DATA  HSCALE / 5.E3 /
+C-----------------------------------------------------------------------     
+C
+C  Index of lowest altitude level (bottom of drag calculation).
+C
+      LEVBOT = LEV2
+      LEVTOP = LEV1
+      LINCR  = 1
+      IF (IORDER.NE.1)  THEN
+        LEVBOT = LEV1
+        LEVTOP = LEV2
+        LINCR  = -1
+      END IF
+C
+C  Data values at first level above ALT_EXP.
+C
+      DO 20 I = IL1,IL2
+        DO 10 L = LEVTOP,LEVBOT,LINCR
+          IF (ALT(I,L) .GE. ALT_EXP)  THEN
+            DATA_ZMAX(I) = DATA(I,L) 
+          END IF	   
+ 10     CONTINUE
+ 20   CONTINUE
+C
+C  Exponentially damp field above ALT_EXP to model top at L=1.
+C
+      DO 40 L = 1,LEV2 
+        DO 30 I = IL1,IL2
+          IF (ALT(I,L) .GE. ALT_EXP)  THEN
+            DATA(I,L) = DATA_ZMAX(I) * EXP( (ALT_EXP-ALT(I,L))/HSCALE )
+          END IF
+ 30     CONTINUE
+ 40   CONTINUE
+C
+      RETURN
+C-----------------------------------------------------------------------
+      END
+
+      SUBROUTINE VERT_SMOOTH (DATA,WORK,COEFF,NSMOOTH,
+     1                        IL1,IL2,LEV1,LEV2,NLONS,NLEVS)
+C
+C  Smooth a longitude by altitude array in the vertical over a
+C  specified number of levels using a three point smoother. 
+C
+C  NOTE: input array DATA is modified on output!
+C
+C  Aug. 3/95 - C. McLandress
+C
+C  Output arguement:
+C
+C     * DATA    = smoothed array (on output).
+C
+C  Input arguements:
+C
+C     * DATA    = unsmoothed array of data (on input).
+C     * WORK    = work array of same dimension as DATA.
+C     * COEFF   = smoothing coefficient for a 1:COEFF:1 stencil.
+C     *           (e.g., COEFF = 2 will result in a smoother which
+C     *           weights the level L gridpoint by two and the two 
+C     *           adjecent levels (L+1 and L-1) by one).
+C     * NSMOOTH = number of times to smooth in vertical.
+C     *           (e.g., NSMOOTH=1 means smoothed only once, 
+C     *           NSMOOTH=2 means smoothing repeated twice, etc.)
+C     * IL1     = first longitudinal index to use (IL1 >= 1).
+C     * IL2     = last longitudinal index to use (IL1 <= IL2 <= NLONS).
+C     * LEV1    = first altitude level to use (LEV1 >=1). 
+C     * LEV2    = last altitude level to use (LEV1 < LEV2 <= NLEVS).
+C     * NLONS   = number of longitudes.
+C     * NLEVS   = number of vertical levels.
+C
+C  Subroutine arguements.
+C
+      INTEGER  NSMOOTH, IL1, IL2, LEV1, LEV2, NLONS, NLEVS
+      REAL  COEFF
+      REAL  DATA(NLONS,NLEVS), WORK(NLONS,NLEVS)
+C
+C  Internal variables.
+C
+      INTEGER  I, L, NS, LEV1P, LEV2M
+      REAL  SUM_WTS
+C-----------------------------------------------------------------------     
+C
+C  Calculate sum of weights.
+C
+      SUM_WTS = COEFF + 2.
+C
+      LEV1P = LEV1 + 1
+      LEV2M = LEV2 - 1
+C
+C  Smooth NSMOOTH times
+C
+      DO 50 NS = 1,NSMOOTH
+C
+C  Copy data into work array.
+C
+        DO 20 L = LEV1,LEV2
+          DO 10 I = IL1,IL2
+            WORK(I,L) = DATA(I,L)
+ 10       CONTINUE
+ 20     CONTINUE
+C
+C  Smooth array WORK in vertical direction and put into DATA.
+C
+        DO 40 L = LEV1P,LEV2M
+          DO 30 I = IL1,IL2
+            DATA(I,L) = ( WORK(I,L+1) + COEFF*WORK(I,L) + WORK(I,L-1) ) 
+     &                    / SUM_WTS 
+ 30       CONTINUE
+ 40     CONTINUE
+C
+ 50   CONTINUE
+C
+      RETURN
+C-----------------------------------------------------------------------
+      END
+
+
+
+
+      
+      
Index: /LMDZ4/trunk/libf/phylmd/iophy.F90
===================================================================
--- /LMDZ4/trunk/libf/phylmd/iophy.F90	(revision 1000)
+++ /LMDZ4/trunk/libf/phylmd/iophy.F90	(revision 1001)
@@ -16,7 +16,75 @@
   INTERFACE histwrite_phy
     MODULE PROCEDURE histwrite2d_phy,histwrite3d_phy
-  END INTERFACE 
+  END INTERFACE
+
 
 contains
+
+  subroutine init_iophy_new(rlat,rlon)
+  USE dimphy
+  USE mod_phys_lmdz_para
+  USE mod_grid_phy_lmdz
+  USE ioipsl
+  implicit none
+  include 'dimensions.h'   
+    real,dimension(klon),intent(in) :: rlon
+    real,dimension(klon),intent(in) :: rlat
+
+    REAL,dimension(klon_glo)        :: rlat_glo
+    REAL,dimension(klon_glo)        :: rlon_glo
+    
+    INTEGER,DIMENSION(2) :: ddid
+    INTEGER,DIMENSION(2) :: dsg
+    INTEGER,DIMENSION(2) :: dsl
+    INTEGER,DIMENSION(2) :: dpf
+    INTEGER,DIMENSION(2) :: dpl
+    INTEGER,DIMENSION(2) :: dhs
+    INTEGER,DIMENSION(2) :: dhe 
+    INTEGER :: i    
+
+    CALL gather(rlat,rlat_glo)
+    CALL bcast(rlat_glo)
+    CALL gather(rlon,rlon_glo)
+    CALL bcast(rlon_glo)
+    
+!$OMP MASTER  
+    ALLOCATE(io_lat(jjm+1-1/iim))
+    io_lat(1)=rlat_glo(1)
+    io_lat(jjm+1-1/iim)=rlat_glo(klon_glo)
+    IF (iim > 1) then
+      DO i=2,jjm
+        io_lat(i)=rlat_glo(2+(i-2)*iim)
+      ENDDO
+    ENDIF
+
+    ALLOCATE(io_lon(iim))
+    io_lon(:)=rlon_glo(2-1/iim:iim+1-1/iim)
+
+
+    allocate(tmp_tab2d(iim,jj_nb))
+    allocate(tmp_tab3d(iim,jj_nb,klev))
+    allocate(ndex2d(iim*jj_nb))
+    allocate(ndex3d(iim*jj_nb*klev))
+    ndex2d(:)=0
+    ndex3d(:)=0
+    
+    ddid=(/ 1,2 /)
+    dsg=(/ iim, jjm+1-1/iim /)
+    dsl=(/ iim, jj_nb /)
+    dpf=(/ 1,jj_begin /)
+    dpl=(/ iim, jj_end /)
+    dhs=(/ ii_begin-1,0 /)
+    if (mpi_rank==mpi_size-1) then
+      dhe=(/0,0/)
+    else
+      dhe=(/ iim-ii_end,0 /)  
+    endif
+    
+    call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
+                      'APPLE',phys_domain_id)
+
+!$OMP END MASTER
+      
+  end subroutine init_iophy_new
 
   subroutine init_iophy(lat,lon)
@@ -139,50 +207,4 @@
   
   
-!  subroutine phy2dyn(field_phy,field_dyn,nlev)
-!  USE dimphy_old
-!  implicit none
-!  include 'dimensions.h'
-!  
-!    real,dimension(klon_mpi,nlev),intent(in) :: field_phy
-!    real,dimension(iim,jjphy_nb,nlev),intent(out) :: field_dyn
-!    integer,intent(in) :: nlev
-!    
-!    integer :: next
-!    integer :: j,l
-!    
-!      do l=1,nlev
-!        	
-!	if (jjphy_begin==jjphy_end) then
-!	  field_dyn(:,1,l)=0.
-!	  field_dyn(iiphy_begin:iiphy_end,1,l)=field_phy(1:klon_mpi,l)
-!	else
-!	
-!	 if (jjphy_begin==1) then
-!	    field_dyn(:,1,l)=field_phy(1,l)
-!	    next=2
-!	 else
-!	   field_dyn(:,1,l)=0.
-!	   next=iim-iiphy_begin+2
-!	   field_dyn(iiphy_begin:iim,1,l)=field_phy(1:next-1,l)   
-!	 endif
-!	
-!	  do j=2,jjphy_nb-1
-!	    field_dyn(:,j,l)=field_phy(next:next+iim-1,l)
-!	    next=next+iim
-!	  enddo
-!	  
-!	  if (jjphy_end==jjm+1-1/iim) then
-!             field_dyn(:,jjphy_nb,l)=field_phy(klon_mpi,l)
-!	  else
-!	   field_dyn(:,jjphy_nb,l)=0.
-!	   field_dyn(1:iiphy_end,jjphy_nb,l)=field_phy(next:next+iiphy_end-1,l)   
-!	  endif
-!	  
-!	endif
-!     
-!     enddo
-!	 
-!    end subroutine phy2dyn	    
-  
-	  
+
 end module iophy
Index: /LMDZ4/trunk/libf/phylmd/iostart.F90
===================================================================
--- /LMDZ4/trunk/libf/phylmd/iostart.F90	(revision 1001)
+++ /LMDZ4/trunk/libf/phylmd/iostart.F90	(revision 1001)
@@ -0,0 +1,491 @@
+MODULE iostart
+
+PRIVATE
+    INTEGER,SAVE :: nid_start 
+    INTEGER,SAVE :: nid_restart
+    
+    INTEGER,SAVE :: idim1,idim2,idim3
+    INTEGER,PARAMETER :: length=100
+    
+    INTERFACE get_field
+      MODULE PROCEDURE Get_field_r1,Get_field_r2,Get_field_r3
+    END INTERFACE get_field
+    
+    INTERFACE get_var
+      MODULE PROCEDURE get_var_r0,Get_var_r1,Get_var_r2,Get_var_r3
+    END INTERFACE get_var
+
+    INTERFACE put_field
+      MODULE PROCEDURE put_field_r1,put_field_r2,put_field_r3
+    END INTERFACE put_field
+
+    INTERFACE put_var
+      MODULE PROCEDURE put_var_r0,put_var_r1,put_var_r2,put_var_r3
+    END INTERFACE put_var
+
+    PUBLIC get_field,get_var,put_field,put_var
+    PUBLIC Open_startphy,close_startphy,open_restartphy,close_restartphy
+    
+CONTAINS
+
+  SUBROUTINE Open_startphy(filename)
+  USE netcdf
+  USE mod_phys_lmdz_para
+  IMPLICIT NONE
+    CHARACTER(LEN=*) :: filename
+    INTEGER          :: ierr
+
+    IF (is_mpi_root .AND. is_omp_root) THEN
+      ierr = NF90_OPEN (filename, NF90_NOWRITE,nid_start)
+      IF (ierr.NE.NF90_NOERR) THEN
+        write(6,*)' Pb d''ouverture du fichier '//filename
+        write(6,*)' ierr = ', ierr
+        CALL ABORT
+      ENDIF
+    ENDIF
+   
+  END SUBROUTINE Open_startphy
+
+  SUBROUTINE Close_startphy
+  USE netcdf
+  USE mod_phys_lmdz_para
+  IMPLICIT NONE
+    INTEGER          :: ierr
+
+    IF (is_mpi_root .AND. is_omp_root) THEN
+        ierr = NF90_CLOSE (nid_start)
+    ENDIF
+
+  END SUBROUTINE close_startphy
+
+
+  FUNCTION Inquire_Field(Field_name)
+  USE netcdf
+  USE mod_phys_lmdz_para
+  IMPLICIT NONE
+    CHARACTER(LEN=*) :: Field_name
+    LOGICAL :: inquire_field
+    INTEGER :: varid
+    INTEGER :: ierr
+    
+    IF (is_mpi_root .AND. is_omp_root) THEN
+      ierr=NF90_INQ_VARID(nid_start,Field_name,varid)
+      IF (ierr==NF90_NOERR) THEN
+        Inquire_field=.TRUE.
+      ELSE
+        Inquire_field=.FALSE.
+      ENDIF
+    ENDIF
+
+    CALL bcast(Inquire_field)
+
+  END FUNCTION Inquire_Field
+  
+ 
+  SUBROUTINE Get_Field_r1(field_name,field,found)
+  IMPLICIT NONE
+    CHARACTER(LEN=*),INTENT(IN)    :: Field_name
+    REAL,INTENT(INOUT)               :: Field(:)
+    LOGICAL,INTENT(OUT),OPTIONAL   :: found 
+
+    IF (PRESENT(found)) THEN
+      CALL Get_field_rgen(field_name,field,1,found)
+    ELSE
+      CALL Get_field_rgen(field_name,field,1)
+    ENDIF
+      
+  END SUBROUTINE Get_Field_r1
+  
+  SUBROUTINE Get_Field_r2(field_name,field,found)
+  IMPLICIT NONE
+    CHARACTER(LEN=*),INTENT(IN)    :: Field_name
+    REAL,INTENT(INOUT)               :: Field(:,:)
+    LOGICAL,INTENT(OUT),OPTIONAL   :: found 
+
+    IF (PRESENT(found)) THEN
+      CALL Get_field_rgen(field_name,field,size(field,2),found)
+    ELSE
+      CALL Get_field_rgen(field_name,field,size(field,2))
+    ENDIF
+
+      
+  END SUBROUTINE Get_Field_r2
+  
+  SUBROUTINE Get_Field_r3(field_name,field,found)
+  IMPLICIT NONE
+    CHARACTER(LEN=*),INTENT(IN)    :: Field_name
+    REAL,INTENT(INOUT)               :: Field(:,:,:)
+    LOGICAL,INTENT(OUT),OPTIONAL   :: found 
+
+    IF (PRESENT(found)) THEN
+      CALL Get_field_rgen(field_name,field,size(field,2)*size(field,3),found)
+    ELSE
+      CALL Get_field_rgen(field_name,field,size(field,2)*size(field,3))
+    ENDIF
+      
+  END SUBROUTINE Get_Field_r3
+  
+  SUBROUTINE Get_field_rgen(field_name,field,field_size,found)
+  USE netcdf
+  USE dimphy
+  USE mod_grid_phy_lmdz
+  USE mod_phys_lmdz_para
+  IMPLICIT NONE
+    CHARACTER(LEN=*) :: Field_name
+    INTEGER          :: field_size
+    REAL             :: field(klon,field_size)
+    LOGICAL,OPTIONAL :: found
+    
+    REAL    :: field_glo(klon_glo,field_size)
+    LOGICAL :: tmp_found
+    INTEGER :: varid
+    INTEGER :: ierr
+    
+    IF (is_mpi_root .AND. is_omp_root) THEN
+  
+      ierr=NF90_INQ_VARID(nid_start,Field_name,varid)
+      
+      IF (ierr==NF90_NOERR) THEN
+        CALL body(field_glo)
+        tmp_found=.TRUE.
+      ELSE
+        tmp_found=.FALSE.
+      ENDIF
+    
+    ENDIF
+    
+    CALL bcast(tmp_found)
+
+    IF (tmp_found) THEN
+      CALL scatter(field_glo,field)
+    ENDIF
+    
+    IF (PRESENT(found)) THEN
+      found=tmp_found
+    ELSE
+      IF (.NOT. tmp_found) THEN
+        PRINT*, 'phyetat0: Le champ <'//field_name//'> est absent'
+        CALL abort
+      ENDIF
+    ENDIF
+ 
+    
+    CONTAINS
+     
+     SUBROUTINE body(field_glo)
+       REAL :: field_glo(klon_glo*field_size)
+         ierr=NF90_GET_VAR(nid_start,varid,field_glo)
+         IF (ierr/=NF90_NOERR) THEN
+           PRINT*, 'phyetat0: Lecture echouee pour <'//field_name//'>'
+           CALL abort
+         ENDIF
+
+     END SUBROUTINE body
+
+  END SUBROUTINE Get_field_rgen
+  
+
+  SUBROUTINE get_var_r0(var_name,var,found)
+  IMPLICIT NONE  
+    CHARACTER(LEN=*),INTENT(IN)  :: var_name
+    REAL,INTENT(INOUT)             :: var
+    LOGICAL,OPTIONAL,INTENT(OUT) :: found
+
+    REAL                         :: varout(1)
+    
+    IF (PRESENT(found)) THEN
+      CALL Get_var_rgen(var_name,varout,size(varout),found)
+    ELSE
+      CALL Get_var_rgen(var_name,varout,size(varout))
+    ENDIF
+    var=varout(1)
+ 
+  END SUBROUTINE get_var_r0
+
+  SUBROUTINE get_var_r1(var_name,var,found)
+  IMPLICIT NONE  
+    CHARACTER(LEN=*),INTENT(IN)  :: var_name
+    REAL,INTENT(INOUT)             :: var(:)
+    LOGICAL,OPTIONAL,INTENT(OUT) :: found
+    
+    IF (PRESENT(found)) THEN
+      CALL Get_var_rgen(var_name,var,size(var),found)
+    ELSE
+      CALL Get_var_rgen(var_name,var,size(var))
+    ENDIF
+  
+  END SUBROUTINE get_var_r1
+
+  SUBROUTINE get_var_r2(var_name,var,found)
+  IMPLICIT NONE  
+    CHARACTER(LEN=*),INTENT(IN)  :: var_name
+    REAL,INTENT(OUT)             :: var(:,:)
+    LOGICAL,OPTIONAL,INTENT(OUT) :: found
+    
+    IF (PRESENT(found)) THEN
+      CALL Get_var_rgen(var_name,var,size(var),found)
+    ELSE
+      CALL Get_var_rgen(var_name,var,size(var))
+    ENDIF
+  
+  END SUBROUTINE get_var_r2
+
+  SUBROUTINE get_var_r3(var_name,var,found)
+  IMPLICIT NONE  
+    CHARACTER(LEN=*),INTENT(IN)  :: var_name
+    REAL,INTENT(INOUT)             :: var(:,:,:)
+    LOGICAL,OPTIONAL,INTENT(OUT) :: found
+    
+    IF (PRESENT(found)) THEN
+      CALL Get_var_rgen(var_name,var,size(var),found)
+    ELSE
+      CALL Get_var_rgen(var_name,var,size(var))
+    ENDIF
+  
+  END SUBROUTINE get_var_r3
+
+  SUBROUTINE Get_var_rgen(var_name,var,var_size,found)
+  USE netcdf
+  USE dimphy
+  USE mod_grid_phy_lmdz
+  USE mod_phys_lmdz_para
+  IMPLICIT NONE
+    CHARACTER(LEN=*) :: var_name
+    INTEGER          :: var_size
+    REAL             :: var(var_size)
+    LOGICAL,OPTIONAL :: found
+    
+    LOGICAL :: tmp_found
+    INTEGER :: varid
+    INTEGER :: ierr
+    
+    IF (is_mpi_root .AND. is_omp_root) THEN
+  
+      ierr=NF90_INQ_VARID(nid_start,var_name,varid)
+      
+      IF (ierr==NF90_NOERR) THEN
+        ierr=NF90_GET_VAR(nid_start,varid,var)
+        IF (ierr/=NF90_NOERR) THEN
+          PRINT*, 'phyetat0: Lecture echouee pour <'//var_name//'>'
+          CALL abort
+        ENDIF
+        tmp_found=.TRUE.
+      ELSE
+        tmp_found=.FALSE.
+      ENDIF
+    
+    ENDIF
+    
+    CALL bcast(tmp_found)
+
+    IF (tmp_found) THEN
+      CALL bcast(var)
+    ENDIF
+    
+    IF (PRESENT(found)) THEN
+      found=tmp_found
+    ELSE
+      IF (.NOT. tmp_found) THEN
+        PRINT*, 'phyetat0: La variable champ <'//var_name//'> est absente'
+        CALL abort
+      ENDIF
+    ENDIF
+
+  END SUBROUTINE Get_var_rgen
+
+
+  SUBROUTINE open_restartphy(filename)
+  USE netcdf
+  USE mod_phys_lmdz_para
+  USE mod_grid_phy_lmdz
+  USE dimphy
+  IMPLICIT NONE
+    CHARACTER(LEN=*),INTENT(IN) :: filename
+    INTEGER                     :: ierr
+    
+    IF (is_mpi_root .AND. is_omp_root) THEN
+      ierr = NF90_CREATE(filename, NF90_CLOBBER, nid_restart)
+      IF (ierr/=NF90_NOERR) THEN
+        write(6,*)' Pb d''ouverture du fichier '//filename
+        write(6,*)' ierr = ', ierr
+        CALL ABORT
+      ENDIF
+
+      ierr = NF90_PUT_ATT (nid_restart, NF90_GLOBAL, "title","Fichier redemmarage physique")
+
+      ierr = NF90_DEF_DIM (nid_restart, "index", length, idim1)
+      ierr = NF90_DEF_DIM (nid_restart, "points_physiques", klon_glo, idim2)
+      ierr = NF90_DEF_DIM (nid_restart, "horizon_vertical", klon_glo*klev, idim3)
+
+      ierr = NF90_ENDDEF(nid_restart)
+    ENDIF
+
+  END SUBROUTINE open_restartphy
+  
+  SUBROUTINE close_restartphy
+  USE netcdf
+  USE mod_phys_lmdz_para
+  IMPLICIT NONE
+    INTEGER          :: ierr
+
+    IF (is_mpi_root .AND. is_omp_root) THEN
+      ierr = NF90_CLOSE (nid_restart)
+    ENDIF
+ 
+  END SUBROUTINE close_restartphy
+
+  
+  SUBROUTINE put_field_r1(field_name,title,field)
+  IMPLICIT NONE
+  CHARACTER(LEN=*),INTENT(IN)    :: field_name
+  CHARACTER(LEN=*),INTENT(IN)    :: title
+  REAL,INTENT(IN)                :: field(:)
+  
+    CALL put_field_rgen(field_name,title,field,1)
+  
+  END SUBROUTINE put_field_r1
+
+  SUBROUTINE put_field_r2(field_name,title,field)
+  IMPLICIT NONE
+  CHARACTER(LEN=*),INTENT(IN)    :: field_name
+  CHARACTER(LEN=*),INTENT(IN)    :: title
+  REAL,INTENT(IN)                :: field(:,:)
+  
+    CALL put_field_rgen(field_name,title,field,size(field,2))
+  
+  END SUBROUTINE put_field_r2
+
+  SUBROUTINE put_field_r3(field_name,title,field)
+  IMPLICIT NONE
+  CHARACTER(LEN=*),INTENT(IN)    :: field_name
+  CHARACTER(LEN=*),INTENT(IN)    :: title
+  REAL,INTENT(IN)                :: field(:,:,:)
+  
+    CALL put_field_rgen(field_name,title,field,size(field,2)*size(field,3))
+  
+  END SUBROUTINE put_field_r3
+  
+  SUBROUTINE put_field_rgen(field_name,title,field,field_size)
+  USE netcdf
+  USE dimphy
+  USE mod_grid_phy_lmdz
+  USE mod_phys_lmdz_para
+  IMPLICIT NONE
+  CHARACTER(LEN=*),INTENT(IN)    :: field_name
+  CHARACTER(LEN=*),INTENT(IN)    :: title
+  INTEGER,INTENT(IN)             :: field_size
+  REAL,INTENT(IN)                :: field(klon,field_size)
+  
+  REAL                           :: field_glo(klon_glo,field_size)
+  INTEGER                        :: ierr
+  INTEGER                        :: nvarid
+  INTEGER                        :: idim
+   
+   
+    CALL gather(field,field_glo)
+    
+    IF (is_mpi_root .AND. is_omp_root) THEN
+      
+      IF (field_size==1) THEN
+        idim=idim2
+      ELSE IF (field_size==klev) THEN
+        idim=idim3
+      ELSE
+        PRINT *, "erreur phyredem : probleme de dimension"
+        CALL ABORT
+      ENDIF
+         
+      ierr = NF90_REDEF (nid_restart)
+#ifdef NC_DOUBLE
+      ierr = NF90_DEF_VAR (nid_restart, field_name, NF90_DOUBLE,(/ idim /),nvarid)
+#else
+      ierr = NF90_DEF_VAR (nid_restart, field_name, NF90_FLOAT,(/ idim /),nvarid)
+#endif
+      IF (LEN_TRIM(title) > 0) ierr = NF90_PUT_ATT (nid_restart,nvarid,"title", title)
+      ierr = NF90_ENDDEF(nid_restart)
+      ierr = NF90_PUT_VAR(nid_restart,nvarid,RESHAPE(field_glo,(/klon_glo*field_size/)))
+    ENDIF
+    
+   END SUBROUTINE put_field_rgen  
+  
+   SUBROUTINE put_var_r0(var_name,title,var)
+   IMPLICIT NONE
+     CHARACTER(LEN=*),INTENT(IN) :: var_name
+     CHARACTER(LEN=*),INTENT(IN) :: title
+     REAL,INTENT(IN)             :: var
+     REAL                        :: varin(1)
+     
+     varin(1)=var
+     
+     CALL put_var_rgen(var_name,title,varin,size(varin))
+
+  END SUBROUTINE put_var_r0
+
+
+   SUBROUTINE put_var_r1(var_name,title,var)
+   IMPLICIT NONE
+     CHARACTER(LEN=*),INTENT(IN) :: var_name
+     CHARACTER(LEN=*),INTENT(IN) :: title
+     REAL,INTENT(IN)             :: var(:)
+     
+     CALL put_var_rgen(var_name,title,var,size(var))
+
+  END SUBROUTINE put_var_r1
+ 
+  SUBROUTINE put_var_r2(var_name,title,var)
+   IMPLICIT NONE
+     CHARACTER(LEN=*),INTENT(IN) :: var_name
+     CHARACTER(LEN=*),INTENT(IN) :: title
+     REAL,INTENT(IN)             :: var(:,:)
+     
+     CALL put_var_rgen(var_name,title,var,size(var))
+
+  END SUBROUTINE put_var_r2     
+  
+  SUBROUTINE put_var_r3(var_name,title,var)
+   IMPLICIT NONE
+     CHARACTER(LEN=*),INTENT(IN) :: var_name
+     CHARACTER(LEN=*),INTENT(IN) :: title
+     REAL,INTENT(IN)             :: var(:,:,:)
+     
+     CALL put_var_rgen(var_name,title,var,size(var))
+
+  END SUBROUTINE put_var_r3
+
+  SUBROUTINE put_var_rgen(var_name,title,var,var_size)
+  USE netcdf
+  USE dimphy
+  USE mod_phys_lmdz_para
+  IMPLICIT NONE
+     CHARACTER(LEN=*),INTENT(IN) :: var_name
+     CHARACTER(LEN=*),INTENT(IN) :: title
+     INTEGER,INTENT(IN)          :: var_size
+     REAL,INTENT(IN)             :: var(var_size)
+     
+     INTEGER :: ierr
+     INTEGER :: nvarid
+         
+    IF (is_mpi_root .AND. is_omp_root) THEN
+    
+      IF (var_size/=length) THEN
+        PRINT *, "erreur phyredem : probleme de dimension"
+        CALL abort
+      ENDIF
+      
+      ierr = NF90_REDEF (nid_restart)
+
+#ifdef NC_DOUBLE
+      ierr = NF90_DEF_VAR (nid_restart, var_name, NF90_DOUBLE,(/ idim1 /),nvarid)
+#else
+      ierr = NF90_DEF_VAR (nid_restart, var_name, NF90_FLOAT,(/ idim1 /),nvarid)
+#endif
+      IF (LEN_TRIM(title)>0) ierr = NF90_PUT_ATT (nid_restart,nvarid,"title", title)
+      ierr = NF90_ENDDEF(nid_restart)
+     
+      ierr = NF90_PUT_VAR(nid_restart,nvarid,var)
+
+    ENDIF
+    
+  END SUBROUTINE put_var_rgen     
+    
+END MODULE iostart
Index: /LMDZ4/trunk/libf/phylmd/limit_read_mod.F90
===================================================================
--- /LMDZ4/trunk/libf/phylmd/limit_read_mod.F90	(revision 1000)
+++ /LMDZ4/trunk/libf/phylmd/limit_read_mod.F90	(revision 1001)
@@ -15,8 +15,13 @@
 
   REAL, ALLOCATABLE, DIMENSION(:,:), SAVE, PRIVATE :: pctsrf
+!$OMP THREADPRIVATE(pctsrf)
   REAL, ALLOCATABLE, DIMENSION(:),   SAVE, PRIVATE :: rugos
+!$OMP THREADPRIVATE(rugos)
   REAL, ALLOCATABLE, DIMENSION(:),   SAVE, PRIVATE :: albedo
+!$OMP THREADPRIVATE(albedo)  
   REAL, ALLOCATABLE, DIMENSION(:),   SAVE, PRIVATE :: sst
-  LOGICAL :: read_continents=.FALSE.
+!$OMP THREADPRIVATE(sst)  
+  LOGICAL,SAVE :: read_continents=.FALSE.
+!$OMP THREADPRIVATE(read_continents) 
 
 CONTAINS
@@ -157,7 +162,8 @@
 !****************************************************************************************
 ! frequence de lecture des conditions limites (en pas de physique) 
-    INTEGER,SAVE                              :: lmt_pas   
+    INTEGER,SAVE                              :: lmt_pas
+!$OMP THREADPRIVATE(lmt_pas) 
     LOGICAL, SAVE                             :: first_call=.TRUE.
-    
+!$OMP THREADPRIVATE(first_call)    
 ! Locals variables
 !****************************************************************************************
Index: /LMDZ4/trunk/libf/phylmd/limit_slab.F90
===================================================================
--- /LMDZ4/trunk/libf/phylmd/limit_slab.F90	(revision 1000)
+++ /LMDZ4/trunk/libf/phylmd/limit_slab.F90	(revision 1001)
@@ -25,4 +25,5 @@
 !****************************************************************************************
   REAL, DIMENSION(:), ALLOCATABLE, SAVE :: bils_save, foce_save
+!$OMP THREADPRIVATE(bils_save, foce_save)
 
 ! Locals variables
Index: /LMDZ4/trunk/libf/phylmd/mod_grid_phy_lmdz.F90
===================================================================
--- /LMDZ4/trunk/libf/phylmd/mod_grid_phy_lmdz.F90	(revision 1000)
+++ /LMDZ4/trunk/libf/phylmd/mod_grid_phy_lmdz.F90	(revision 1001)
@@ -3,8 +3,8 @@
 !
 MODULE mod_grid_phy_lmdz
-  INTEGER :: nbp_lon  ! == iim
-  INTEGER :: nbp_lat  ! == jjmp1
-  INTEGER :: nbp_lev  ! == llm
-  INTEGER :: klon_glo
+  INTEGER,SAVE :: nbp_lon  ! == iim
+  INTEGER,SAVE :: nbp_lat  ! == jjmp1
+  INTEGER,SAVE :: nbp_lev  ! == llm
+  INTEGER,SAVE :: klon_glo
 
   INTERFACE grid1dTo2d_glo
Index: /LMDZ4/trunk/libf/phylmd/mod_phys_lmdz_mpi_data.F90
===================================================================
--- /LMDZ4/trunk/libf/phylmd/mod_phys_lmdz_mpi_data.F90	(revision 1000)
+++ /LMDZ4/trunk/libf/phylmd/mod_phys_lmdz_mpi_data.F90	(revision 1001)
@@ -37,5 +37,5 @@
   INTEGER,SAVE :: mpi_root
   LOGICAL,SAVE :: is_mpi_root
-  LOGICAL,SAVE :: is_ok_mpi
+  LOGICAL,SAVE :: is_using_mpi
   
   
@@ -58,8 +58,8 @@
     INTEGER :: i
     
-#ifdef CPP_PARA
-    is_ok_mpi=.TRUE.
+#ifdef CPP_MPI
+    is_using_mpi=.TRUE.
 #else
-    is_ok_mpi=.FALSE.
+    is_using_mpi=.FALSE.
 #endif
     
@@ -72,6 +72,6 @@
     COMM_LMDZ_PHY=COMM_LMDZ
 
-    IF (is_ok_mpi) THEN    
-#ifdef CPP_PARA
+    IF (is_using_mpi) THEN    
+#ifdef CPP_MPI
       CALL MPI_COMM_SIZE(COMM_LMDZ_PHY,mpi_size,ierr)    
       CALL MPI_COMM_RANK(COMM_LMDZ_PHY,mpi_rank,ierr)
Index: /LMDZ4/trunk/libf/phylmd/mod_phys_lmdz_mpi_transfert.F90
===================================================================
--- /LMDZ4/trunk/libf/phylmd/mod_phys_lmdz_mpi_transfert.F90	(revision 1000)
+++ /LMDZ4/trunk/libf/phylmd/mod_phys_lmdz_mpi_transfert.F90	(revision 1001)
@@ -66,21 +66,21 @@
     CHARACTER(LEN=*),INTENT(INOUT) :: Var1
    
-#ifndef CPP_PARA
-    RETURN
-#endif
-
     CALL bcast_mpi_cgen(Var1,len(Var1))
+
   END SUBROUTINE bcast_mpi_c
 
 !! -- Les entiers -- !!
   
-  SUBROUTINE bcast_mpi_i(var1)
+  SUBROUTINE bcast_mpi_i(var)
+  USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root
   IMPLICIT NONE
-    INTEGER,INTENT(INOUT) :: Var1
-   
-#ifndef CPP_PARA
-    RETURN
-#endif
-    CALL bcast_mpi_igen(Var1,1)
+    INTEGER,INTENT(INOUT) :: Var
+    
+    INTEGER               :: var_tmp(1)
+    
+    IF (is_mpi_root) var_tmp(1)=var
+    CALL bcast_mpi_igen(Var_tmp,1)
+    var=var_tmp(1)
+    
   END SUBROUTINE bcast_mpi_i
 
@@ -88,9 +88,7 @@
   IMPLICIT NONE
     INTEGER,INTENT(INOUT) :: Var(:)
-   
-#ifndef CPP_PARA
-    RETURN
-#endif
+
     CALL bcast_mpi_igen(Var,size(Var))
+    
   END SUBROUTINE bcast_mpi_i1
 
@@ -99,8 +97,6 @@
     INTEGER,INTENT(INOUT) :: Var(:,:)
    
-#ifndef CPP_PARA
-    RETURN
-#endif
     CALL bcast_mpi_igen(Var,size(Var))
+  
   END SUBROUTINE bcast_mpi_i2
 
@@ -109,8 +105,6 @@
     INTEGER,INTENT(INOUT) :: Var(:,:,:)
    
-#ifndef CPP_PARA
-    RETURN
-#endif
     CALL bcast_mpi_igen(Var,size(Var))
+
   END SUBROUTINE bcast_mpi_i3
 
@@ -119,8 +113,6 @@
     INTEGER,INTENT(INOUT) :: Var(:,:,:,:)
    
-#ifndef CPP_PARA
-    RETURN
-#endif
     CALL bcast_mpi_igen(Var,size(Var))
+
   END SUBROUTINE bcast_mpi_i4
 
@@ -129,11 +121,13 @@
 
   SUBROUTINE bcast_mpi_r(var)
+  USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root
   IMPLICIT NONE
     REAL,INTENT(INOUT) :: Var
-   
-#ifndef CPP_PARA
-    RETURN
-#endif
-    CALL bcast_mpi_rgen(Var,1)
+    REAL               :: var_tmp(1)
+    
+    IF (is_mpi_root) var_tmp(1)=var
+    CALL bcast_mpi_rgen(Var_tmp,1)
+    var=var_tmp(1)   
+
   END SUBROUTINE bcast_mpi_r
 
@@ -142,8 +136,6 @@
     REAL,INTENT(INOUT) :: Var(:)
    
-#ifndef CPP_PARA
-    RETURN
-#endif
     CALL bcast_mpi_rgen(Var,size(Var))
+
   END SUBROUTINE bcast_mpi_r1
 
@@ -152,8 +144,6 @@
     REAL,INTENT(INOUT) :: Var(:,:)
    
-#ifndef CPP_PARA
-    RETURN
-#endif
     CALL bcast_mpi_rgen(Var,size(Var))
+
   END SUBROUTINE bcast_mpi_r2
 
@@ -162,8 +152,6 @@
     REAL,INTENT(INOUT) :: Var(:,:,:)
    
-#ifndef CPP_PARA
-    RETURN
-#endif
     CALL bcast_mpi_rgen(Var,size(Var))
+
   END SUBROUTINE bcast_mpi_r3
 
@@ -172,8 +160,6 @@
     REAL,INTENT(INOUT) :: Var(:,:,:,:)
    
-#ifndef CPP_PARA
-    RETURN
-#endif
     CALL bcast_mpi_rgen(Var,size(Var))
+
   END SUBROUTINE bcast_mpi_r4
   
@@ -181,11 +167,13 @@
 
   SUBROUTINE bcast_mpi_l(var)
+  USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root
   IMPLICIT NONE
     LOGICAL,INTENT(INOUT) :: Var
-   
-#ifndef CPP_PARA
-    RETURN
-#endif
-    CALL bcast_mpi_lgen(Var,1)
+    LOGICAL               :: var_tmp(1)
+    
+    IF (is_mpi_root) var_tmp(1)=var
+    CALL bcast_mpi_lgen(Var_tmp,1)
+    var=var_tmp(1)   
+
   END SUBROUTINE bcast_mpi_l
 
@@ -194,8 +182,6 @@
     LOGICAL,INTENT(INOUT) :: Var(:)
    
-#ifndef CPP_PARA
-    RETURN
-#endif
     CALL bcast_mpi_lgen(Var,size(Var))
+
   END SUBROUTINE bcast_mpi_l1
 
@@ -204,8 +190,6 @@
     LOGICAL,INTENT(INOUT) :: Var(:,:)
    
-#ifndef CPP_PARA
-    RETURN
-#endif
     CALL bcast_mpi_lgen(Var,size(Var))
+
   END SUBROUTINE bcast_mpi_l2
 
@@ -214,8 +198,6 @@
     LOGICAL,INTENT(INOUT) :: Var(:,:,:)
    
-#ifndef CPP_PARA
-    RETURN
-#endif
     CALL bcast_mpi_lgen(Var,size(Var))
+
   END SUBROUTINE bcast_mpi_l3
 
@@ -224,8 +206,6 @@
     LOGICAL,INTENT(INOUT) :: Var(:,:,:,:)
    
-#ifndef CPP_PARA
-    RETURN
-#endif
     CALL bcast_mpi_lgen(Var,size(Var))
+
   END SUBROUTINE bcast_mpi_l4
   
@@ -241,16 +221,5 @@
     INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
 
-    INTEGER :: dummy
-
-#ifndef CPP_PARA
-    VarOut(:)=VarIn(:)
-    RETURN
-#endif
-
-     IF (is_mpi_root) THEN
-      CALL scatter_mpi_igen(VarIn,Varout,1)
-     ELSE
-      CALL scatter_mpi_igen(dummy,Varout,1)
-    ENDIF
+    CALL scatter_mpi_igen(VarIn,Varout,1)
     
   END SUBROUTINE scatter_mpi_i
@@ -263,15 +232,5 @@
     INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
     
-    INTEGER :: dummy
-
-#ifndef CPP_PARA
-    VarOut(:,:)=VarIn(:,:)
-    RETURN
-#endif
-    IF (is_mpi_root) THEN
-      CALL scatter_mpi_igen(VarIn,Varout,Size(VarOut,2))
-    ELSE
-      CALL scatter_mpi_igen(dummy,Varout,Size(VarOut,2))
-    ENDIF
+    CALL scatter_mpi_igen(VarIn,Varout,Size(VarOut,2))
     
   END SUBROUTINE scatter_mpi_i1
@@ -284,15 +243,6 @@
     INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
     
-    INTEGER :: dummy
-    
-#ifndef CPP_PARA
-    VarOut(:,:,:)=VarIn(:,:,:)
-    RETURN
-#endif
-    IF (is_mpi_root) THEN
-      CALL scatter_mpi_igen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3))
-    ELSE
-      CALL scatter_mpi_igen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3))
-    ENDIF
+    CALL scatter_mpi_igen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3))
+
   END SUBROUTINE scatter_mpi_i2
 
@@ -304,15 +254,5 @@
     INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
     
-    INTEGER :: dummy
-    
-#ifndef CPP_PARA
-    VarOut(:,:,:,:)=VarIn(:,:,:,:)
-    RETURN
-#endif
-    IF (is_mpi_root) THEN
-      CALL scatter_mpi_igen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4))
-    ELSE
-      CALL scatter_mpi_igen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4))
-    ENDIF
+    CALL scatter_mpi_igen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4))
   
   END SUBROUTINE scatter_mpi_i3
@@ -326,15 +266,5 @@
     REAL,INTENT(OUT),DIMENSION(:) :: VarOut
     
-    REAL :: dummy
-    
-#ifndef CPP_PARA
-    VarOut(:)=VarIn(:)
-    RETURN
-#endif
-    IF (is_mpi_root) THEN
       CALL scatter_mpi_rgen(VarIn,Varout,1)
-    ELSE
-      CALL scatter_mpi_rgen(dummy,Varout,1)
-    ENDIF
   
   END SUBROUTINE scatter_mpi_r
@@ -347,15 +277,5 @@
     REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
     
-    REAL :: dummy
-    
-#ifndef CPP_PARA
-    VarOut(:,:)=VarIn(:,:)
-    RETURN
-#endif
-    IF (is_mpi_root) THEN
       CALL scatter_mpi_rgen(VarIn,Varout,Size(VarOut,2))
-    ELSE
-      CALL scatter_mpi_rgen(dummy,Varout,Size(VarOut,2))      
-    ENDIF
   
   END SUBROUTINE scatter_mpi_r1
@@ -368,15 +288,5 @@
     REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
     
-    REAL :: dummy
-    
-#ifndef CPP_PARA
-    VarOut(:,:,:)=VarIn(:,:,:)
-    RETURN
-#endif
-    IF (is_mpi_root) THEN
       CALL scatter_mpi_rgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3))
-    ELSE
-      CALL scatter_mpi_rgen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3))
-    ENDIF
   
   END SUBROUTINE scatter_mpi_r2
@@ -389,15 +299,5 @@
     REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
     
-    REAL :: dummy
-    
-#ifndef CPP_PARA
-    VarOut(:,:,:,:)=VarIn(:,:,:,:)
-    RETURN
-#endif
-    IF (is_mpi_root) THEN
       CALL scatter_mpi_rgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4))
-    ELSE
-      CALL scatter_mpi_rgen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4))
-    ENDIF
   
   END SUBROUTINE scatter_mpi_r3
@@ -411,15 +311,5 @@
     LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut
     
-    LOGICAL :: dummy
-    
-#ifndef CPP_PARA
-    VarOut(:)=VarIn(:)
-    RETURN
-#endif
-    IF (is_mpi_root) THEN
       CALL scatter_mpi_lgen(VarIn,Varout,1)
-    ELSE
-      CALL scatter_mpi_lgen(dummy,Varout,1)
-    ENDIF
     
   END SUBROUTINE scatter_mpi_l
@@ -432,15 +322,5 @@
     LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
     
-    LOGICAL :: dummy
-    
-#ifndef CPP_PARA
-    VarOut(:,:)=VarIn(:,:)
-    RETURN
-#endif
-    IF (is_mpi_root) THEN
       CALL scatter_mpi_lgen(VarIn,Varout,Size(VarOut,2))
-    ELSE
-      CALL scatter_mpi_lgen(dummy,Varout,Size(VarOut,2))      
-    ENDIF
   
   END SUBROUTINE scatter_mpi_l1
@@ -453,15 +333,5 @@
     LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
     
-    LOGICAL :: dummy
-    
-#ifndef CPP_PARA
-    VarOut(:,:,:)=VarIn(:,:,:)
-    RETURN
-#endif
-    IF (is_mpi_root) THEN
       CALL scatter_mpi_lgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3))
-    ELSE
-      CALL scatter_mpi_lgen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3))
-    ENDIF
   
   END SUBROUTINE scatter_mpi_l2
@@ -474,15 +344,5 @@
     LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
     
-    LOGICAL :: dummy
-    
-#ifndef CPP_PARA
-    VarOut(:,:,:,:)=VarIn(:,:,:,:)
-    RETURN
-#endif
-    IF (is_mpi_root) THEN
       CALL scatter_mpi_lgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4))
-    ELSE
-      CALL scatter_mpi_lgen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4))
-    ENDIF
   
   END SUBROUTINE scatter_mpi_l3  
@@ -501,21 +361,7 @@
     INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
     
-    INTEGER :: dummy
-
-#ifndef CPP_PARA
-    VarOut(:)=VarIn(:)
-    RETURN
-#endif
-
-    IF (is_mpi_root) THEN
       CALL gather_mpi_igen(VarIn,VarOut,1)
-    ELSE
-      CALL gather_mpi_igen(VarIn,dummy,1)
-    ENDIF
   
   END SUBROUTINE gather_mpi_i
-  
-  
-  
   
 
@@ -529,16 +375,5 @@
     INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
     
-    INTEGER :: dummy
-    
-#ifndef CPP_PARA
-    VarOut(:,:)=VarIn(:,:)
-    RETURN
-#endif
-
-    IF (is_mpi_root) THEN
       CALL gather_mpi_igen(VarIn,VarOut,Size(VarIn,2))
-    ELSE
-      CALL gather_mpi_igen(VarIn,dummy,Size(VarIn,2))
-    ENDIF
   
   END SUBROUTINE gather_mpi_i1
@@ -553,16 +388,5 @@
     INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
     
-    INTEGER :: dummy
-    
-#ifndef CPP_PARA
-    VarOut(:,:,:)=VarIn(:,:,:)
-    RETURN
-#endif
-
-    IF (is_mpi_root) THEN
       CALL gather_mpi_igen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3))
-    ELSE
-      CALL gather_mpi_igen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3))
-    ENDIF
   
   END SUBROUTINE gather_mpi_i2
@@ -577,16 +401,5 @@
     INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
     
-    INTEGER :: dummy
-    
-#ifndef CPP_PARA
-    VarOut(:,:,:,:)=VarIn(:,:,:,:)
-    RETURN
-#endif
-
-    IF (is_mpi_root) THEN
       CALL gather_mpi_igen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4))
-    ELSE
-      CALL gather_mpi_igen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4))
-    ENDIF
   
   END SUBROUTINE gather_mpi_i3
@@ -601,16 +414,5 @@
     REAL,INTENT(OUT),DIMENSION(:) :: VarOut
     
-    REAL :: dummy
-    
-#ifndef CPP_PARA
-    VarOut(:)=VarIn(:)
-    RETURN
-#endif
-
-    IF (is_mpi_root) THEN
       CALL gather_mpi_rgen(VarIn,VarOut,1)
-    ELSE
-      CALL gather_mpi_rgen(VarIn,dummy,1)
-    ENDIF
   
   END SUBROUTINE gather_mpi_r
@@ -625,16 +427,5 @@
     REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
     
-    REAL :: dummy
-    
-#ifndef CPP_PARA
-    VarOut(:,:)=VarIn(:,:)
-    RETURN
-#endif
-
-    IF (is_mpi_root) THEN
       CALL gather_mpi_rgen(VarIn,VarOut,Size(VarIn,2))
-    ELSE
-      CALL gather_mpi_rgen(VarIn,dummy,Size(VarIn,2))
-    ENDIF
   
   END SUBROUTINE gather_mpi_r1
@@ -649,16 +440,5 @@
     REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
     
-    REAL :: dummy
-    
-#ifndef CPP_PARA
-    VarOut(:,:,:)=VarIn(:,:,:)
-    RETURN
-#endif
-
-    IF (is_mpi_root) THEN
       CALL gather_mpi_rgen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3))
-    ELSE
-      CALL gather_mpi_rgen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3))      
-    ENDIF
   
   END SUBROUTINE gather_mpi_r2
@@ -673,16 +453,5 @@
     REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
     
-    REAL :: dummy
-    
-#ifndef CPP_PARA
-    VarOut(:,:,:,:)=VarIn(:,:,:,:)
-    RETURN
-#endif
-
-    IF (is_mpi_root) THEN
       CALL gather_mpi_rgen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4))
-    ELSE
-      CALL gather_mpi_rgen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4))
-    ENDIF
   
   END SUBROUTINE gather_mpi_r3
@@ -697,16 +466,5 @@
     LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut
     
-    LOGICAL :: dummy
-    
-#ifndef CPP_PARA
-    VarOut(:)=VarIn(:)
-    RETURN
-#endif
-
-    IF (is_mpi_root) THEN
       CALL gather_mpi_lgen(VarIn,VarOut,1)
-    ELSE
-      CALL gather_mpi_lgen(VarIn,dummy,1)      
-    ENDIF
   
   END SUBROUTINE gather_mpi_l
@@ -721,16 +479,5 @@
     LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
     
-    LOGICAL :: dummy
-    
-#ifndef CPP_PARA
-    VarOut(:,:)=VarIn(:,:)
-    RETURN
-#endif
-
-    IF (is_mpi_root) THEN
       CALL gather_mpi_lgen(VarIn,VarOut,Size(VarIn,2))
-    ELSE
-      CALL gather_mpi_lgen(VarIn,dummy,Size(VarIn,2))
-    ENDIF
   
   END SUBROUTINE gather_mpi_l1
@@ -745,16 +492,5 @@
     LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
     
-    LOGICAL :: dummy
-    
-#ifndef CPP_PARA
-    VarOut(:,:,:)=VarIn(:,:,:)
-    RETURN
-#endif
-
-    IF (is_mpi_root) THEN
       CALL gather_mpi_lgen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3))
-    ELSE
-      CALL gather_mpi_lgen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3))
-    ENDIF
   
   END SUBROUTINE gather_mpi_l2
@@ -769,16 +505,5 @@
     LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
     
-    LOGICAL :: dummy
-    
-#ifndef CPP_PARA
-    VarOut(:,:,:,:)=VarIn(:,:,:,:)
-    RETURN
-#endif
-
-    IF (is_mpi_root) THEN
-      CALL gather_mpi_lgen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4))
-    ELSE
-      CALL gather_mpi_lgen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4))      
-    ENDIF
+    CALL gather_mpi_lgen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4))
   
   END SUBROUTINE gather_mpi_l3
@@ -808,18 +533,8 @@
     INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
     INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
-    
-    CALL body(VarIn,VarOut,size(VarOut,2))
-  
-    CONTAINS 
-      SUBROUTINE body(VarIn,VarOut,s1)
-        INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
-        INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
-        INTEGER,INTENT(IN) :: s1
-	
-	INTEGER,DIMENSION(klon_glo,s1) :: Var_tmp
-        
-        CALL grid2dTo1d_glo(VarIn,Var_tmp)
-        CALL scatter_mpi(Var_tmp,VarOut)
-      END SUBROUTINE body
+    INTEGER,DIMENSION(klon_glo,size(VarOut,2)) :: Var_tmp
+
+    CALL grid2dTo1d_glo(VarIn,Var_tmp)
+    CALL scatter_mpi(Var_tmp,VarOut)
 
   END SUBROUTINE scatter2D_mpi_i1
@@ -831,18 +546,9 @@
     INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
     INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
-    
-    CALL body(VarIn,VarOut,size(VarOut,2),size(VarOut,3))
-  
-    CONTAINS 
-      SUBROUTINE body(VarIn,VarOut,s1,s2)
-        INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
-        INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
-        INTEGER,INTENT(IN) :: s1,s2
-	
-        INTEGER,DIMENSION(klon_glo,s1,s2) :: Var_tmp
-        
-        CALL grid2dTo1d_glo(VarIn,Var_tmp)
-        CALL scatter_mpi(Var_tmp,VarOut)
-      END SUBROUTINE body
+
+    INTEGER,DIMENSION(klon_glo,size(VarOut,2),size(VarOut,3)) :: Var_tmp
+
+    CALL grid2dTo1d_glo(VarIn,Var_tmp)
+    CALL scatter_mpi(Var_tmp,VarOut)
 
   END SUBROUTINE scatter2D_mpi_i2
@@ -854,20 +560,9 @@
     INTEGER,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
     INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
-    
-    CALL body(VarIn,VarOut,size(VarOut,2),size(VarOut,3),size(VarOut,4))
-  
-    CONTAINS 
-      SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
-        INTEGER,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
-        INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
-        INTEGER,INTENT(IN) :: s1,s2,s3
-	
-        INTEGER,DIMENSION(klon_glo,s1,s2,s3) :: Var_tmp
-        
-        CALL grid2dTo1d_glo(VarIn,Var_tmp)
-        CALL scatter_mpi(Var_tmp,VarOut)
-      END SUBROUTINE body
-  
- 
+    INTEGER,DIMENSION(klon_glo,size(VarOut,2),size(VarOut,3),size(VarOut,4)) :: Var_tmp
+
+    CALL grid2dTo1d_glo(VarIn,Var_tmp)
+    CALL scatter_mpi(Var_tmp,VarOut)
+    
   END SUBROUTINE scatter2D_mpi_i3
 
@@ -894,18 +589,9 @@
     REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
     REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
-
-    CALL body(VarIn,VarOut,size(VarOut,2))
-  
-    CONTAINS 
-      SUBROUTINE body(VarIn,VarOut,s1)
-        REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
-        REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
-        INTEGER,INTENT(IN) :: s1
-	
-        REAL,DIMENSION(klon_glo,s1) :: Var_tmp
-        
-        CALL grid2dTo1d_glo(VarIn,Var_tmp)
-        CALL scatter_mpi(Var_tmp,VarOut)
-      END SUBROUTINE body
+    
+    REAL,DIMENSION(klon_glo,size(VarOut,2)) :: Var_tmp
+    
+    CALL grid2dTo1d_glo(VarIn,Var_tmp)
+    CALL scatter_mpi(Var_tmp,VarOut)
 
   END SUBROUTINE scatter2D_mpi_r1
@@ -918,18 +604,9 @@
     REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
     REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
-    
-    CALL body(VarIn,VarOut,size(VarOut,2),size(VarOut,3))
-  
-    CONTAINS 
-      SUBROUTINE body(VarIn,VarOut,s1,s2)
-        REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
-        REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
-        INTEGER,INTENT(IN) :: s1,s2
-	
-        REAL,DIMENSION(klon_glo,s1,s2) :: Var_tmp
-        
-        CALL grid2dTo1d_glo(VarIn,Var_tmp)
-        CALL scatter_mpi(Var_tmp,VarOut)
-      END SUBROUTINE body
+
+    REAL,DIMENSION(klon_glo,size(VarOut,2),size(VarOut,3)) :: Var_tmp
+    
+    CALL grid2dTo1d_glo(VarIn,Var_tmp)
+    CALL scatter_mpi(Var_tmp,VarOut)
 
   END SUBROUTINE scatter2D_mpi_r2
@@ -942,17 +619,8 @@
     REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
     
-    CALL body(VarIn,VarOut,size(VarOut,2),size(VarOut,3),size(VarOut,4))
-  
-    CONTAINS 
-      SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
-        REAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
-        REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
-        INTEGER,INTENT(IN) :: s1,s2,s3
-	
-        REAL,DIMENSION(klon_glo,s1,s2,s3) :: Var_tmp
-        
-        CALL grid2dTo1d_glo(VarIn,Var_tmp)
-        CALL scatter_mpi(Var_tmp,VarOut)
-      END SUBROUTINE body
+    REAL,DIMENSION(klon_glo,size(VarOut,2),size(VarOut,3),size(VarOut,4)) :: Var_tmp
+
+    CALL grid2dTo1d_glo(VarIn,Var_tmp)
+    CALL scatter_mpi(Var_tmp,VarOut)
  
   END SUBROUTINE scatter2D_mpi_r3
@@ -981,17 +649,8 @@
     LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
     
-    CALL body(VarIn,VarOut,size(VarOut,2))
-  
-    CONTAINS 
-      SUBROUTINE body(VarIn,VarOut,s1)
-        LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
-        LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
-        INTEGER,INTENT(IN) :: s1
-	
-        LOGICAL,DIMENSION(klon_glo,s1) :: Var_tmp
-        
-        CALL grid2dTo1d_glo(VarIn,Var_tmp)
-        CALL scatter_mpi(Var_tmp,VarOut)
-      END SUBROUTINE body
+    LOGICAL,DIMENSION(klon_glo,size(VarOut,2)) :: Var_tmp
+
+    CALL grid2dTo1d_glo(VarIn,Var_tmp)
+    CALL scatter_mpi(Var_tmp,VarOut)
   
   END SUBROUTINE scatter2D_mpi_l1
@@ -1005,17 +664,8 @@
     LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
     
-    CALL body(VarIn,VarOut,size(VarOut,2),size(VarOut,3))
-  
-    CONTAINS 
-      SUBROUTINE body(VarIn,VarOut,s1,s2)
-        LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
-        LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
-        INTEGER,INTENT(IN) :: s1,s2
-	
-        LOGICAL,DIMENSION(klon_glo,s1,s2) :: Var_tmp
-        
-        CALL grid2dTo1d_glo(VarIn,Var_tmp)
-        CALL scatter_mpi(Var_tmp,VarOut)
-      END SUBROUTINE body
+    LOGICAL, DIMENSION(klon_glo,size(VarOut,2),size(VarOut,3)) :: Var_tmp
+  
+    CALL grid2dTo1d_glo(VarIn,Var_tmp)
+    CALL scatter_mpi(Var_tmp,VarOut)
 
   END SUBROUTINE scatter2D_mpi_l2
@@ -1028,17 +678,8 @@
     LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
     
-    CALL body(VarIn,VarOut,size(VarOut,2),size(VarOut,3),size(VarOut,4))
-  
-    CONTAINS 
-      SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
-        LOGICAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
-        LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
-        INTEGER,INTENT(IN) :: s1,s2,s3
-	
-        LOGICAL,DIMENSION(klon_glo,s1,s2,s3) :: Var_tmp
-        
-        CALL grid2dTo1d_glo(VarIn,Var_tmp)
-        CALL scatter_mpi(Var_tmp,VarOut)
-      END SUBROUTINE body
+    LOGICAL,DIMENSION(klon_glo,size(VarOut,2),size(VarOut,3),size(VarOut,4)) :: Var_tmp
+
+    CALL grid2dTo1d_glo(VarIn,Var_tmp)
+    CALL scatter_mpi(Var_tmp,VarOut)
  
   END SUBROUTINE scatter2D_mpi_l3
@@ -1069,18 +710,9 @@
     INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
     INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
-    
-    CALL body(VarIn,VarOut,size(VarOut,3))
-  
-    CONTAINS 
-      SUBROUTINE body(VarIn,VarOut,s1)
-        INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
-        INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
-        INTEGER,INTENT(IN) :: s1
-	
-        INTEGER,DIMENSION(klon_glo,s1) :: Var_tmp
-        
-        CALL gather_mpi(VarIn,Var_tmp)
-        CALL grid1dTo2d_glo(Var_tmp,VarOut)
-      END SUBROUTINE body
+
+    INTEGER,DIMENSION(klon_glo,size(VarOut,3)) :: Var_tmp
+
+    CALL gather_mpi(VarIn,Var_tmp)
+    CALL grid1dTo2d_glo(Var_tmp,VarOut)
 
   END SUBROUTINE gather2D_mpi_i1
@@ -1092,18 +724,9 @@
     INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
     INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
-    
-    CALL body(VarIn,VarOut,size(VarOut,3),SIZE(VarOut,4))
-  
-    CONTAINS 
-      SUBROUTINE body(VarIn,VarOut,s1,s2)
-        INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
-        INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
-        INTEGER,INTENT(IN) :: s1,s2
-	
-        INTEGER,DIMENSION(klon_glo,s1,s2) :: Var_tmp
-        
-        CALL gather_mpi(VarIn,Var_tmp)
-        CALL grid1dTo2d_glo(Var_tmp,VarOut)
-      END SUBROUTINE body
+
+    INTEGER,DIMENSION(klon_glo,size(VarOut,3),SIZE(VarOut,4)) :: Var_tmp
+    
+    CALL gather_mpi(VarIn,Var_tmp)
+    CALL grid1dTo2d_glo(Var_tmp,VarOut)
 
   END SUBROUTINE gather2D_mpi_i2
@@ -1115,18 +738,9 @@
     INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
     INTEGER,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
-    
-    CALL body(VarIn,VarOut,size(VarOut,3),SIZE(VarOut,4),SIZE(VarOut,5))
-  
-    CONTAINS 
-      SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
-        INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
-        INTEGER,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
-        INTEGER,INTENT(IN) :: s1,s2,s3
-	
-        INTEGER,DIMENSION(klon_glo,s1,s2,s3) :: Var_tmp
-        
-        CALL gather_mpi(VarIn,Var_tmp)
-        CALL grid1dTo2d_glo(Var_tmp,VarOut)
-      END SUBROUTINE body
+ 
+    INTEGER,DIMENSION(klon_glo,size(VarOut,3),SIZE(VarOut,4),SIZE(VarOut,5)) :: Var_tmp
+    
+    CALL gather_mpi(VarIn,Var_tmp)
+    CALL grid1dTo2d_glo(Var_tmp,VarOut)
 
   END SUBROUTINE gather2D_mpi_i3
@@ -1155,17 +769,8 @@
     REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
     
-    CALL body(VarIn,VarOut,size(VarOut,3))
-  
-    CONTAINS 
-      SUBROUTINE body(VarIn,VarOut,s1)
-        REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
-        REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
-        INTEGER,INTENT(IN) :: s1
-	
-        REAL,DIMENSION(klon_glo,s1) :: Var_tmp
-        
-        CALL gather_mpi(VarIn,Var_tmp)
-        CALL grid1dTo2d_glo(Var_tmp,VarOut)
-      END SUBROUTINE body
+    REAL,DIMENSION(klon_glo,size(VarOut,3)) :: Var_tmp
+
+    CALL gather_mpi(VarIn,Var_tmp)
+    CALL grid1dTo2d_glo(Var_tmp,VarOut)
 
   END SUBROUTINE gather2D_mpi_r1
@@ -1178,17 +783,8 @@
     REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
     
-    CALL body(VarIn,VarOut,size(VarOut,3),SIZE(VarOut,4))
-  
-    CONTAINS 
-      SUBROUTINE body(VarIn,VarOut,s1,s2)
-        REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
-        REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
-        INTEGER,INTENT(IN) :: s1,s2
-	
-        REAL,DIMENSION(klon_glo,s1,s2) :: Var_tmp
-        
-        CALL gather_mpi(VarIn,Var_tmp)
-        CALL grid1dTo2d_glo(Var_tmp,VarOut)
-      END SUBROUTINE body
+    REAL,DIMENSION(klon_glo,size(VarOut,3),SIZE(VarOut,4)) :: Var_tmp
+
+    CALL gather_mpi(VarIn,Var_tmp)
+    CALL grid1dTo2d_glo(Var_tmp,VarOut)
 
   END SUBROUTINE gather2D_mpi_r2
@@ -1201,17 +797,8 @@
     REAL,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
     
-    CALL body(VarIn,VarOut,size(VarOut,3),SIZE(VarOut,4),SIZE(VarOut,5))
-  
-    CONTAINS 
-      SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
-        REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
-        REAL,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
-        INTEGER,INTENT(IN) :: s1,s2,s3
-	
-        REAL,DIMENSION(klon_glo,s1,s2,s3) :: Var_tmp
-        
-        CALL gather_mpi(VarIn,Var_tmp)
-        CALL grid1dTo2d_glo(Var_tmp,VarOut)
-      END SUBROUTINE body
+    REAL,DIMENSION(klon_glo,size(VarOut,3),SIZE(VarOut,4),SIZE(VarOut,5)) :: Var_tmp
+    
+    CALL gather_mpi(VarIn,Var_tmp)
+    CALL grid1dTo2d_glo(Var_tmp,VarOut)
 
   END SUBROUTINE gather2D_mpi_r3
@@ -1240,17 +827,8 @@
     LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
     
-    CALL body(VarIn,VarOut,size(VarOut,3))
-  
-    CONTAINS 
-      SUBROUTINE body(VarIn,VarOut,s1)
-        LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
-        LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
-        INTEGER,INTENT(IN) :: s1
-	
-        LOGICAL,DIMENSION(klon_glo,s1) :: Var_tmp
-        
-        CALL gather_mpi(VarIn,Var_tmp)
-        CALL grid1dTo2d_glo(Var_tmp,VarOut)
-      END SUBROUTINE body
+    LOGICAL,DIMENSION(klon_glo,size(VarOut,3)) :: Var_tmp
+
+    CALL gather_mpi(VarIn,Var_tmp)
+    CALL grid1dTo2d_glo(Var_tmp,VarOut)
 
   END SUBROUTINE gather2D_mpi_l1
@@ -1263,17 +841,8 @@
     LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
     
-    CALL body(VarIn,VarOut,size(VarOut,3),SIZE(VarOut,4))
-  
-    CONTAINS 
-      SUBROUTINE body(VarIn,VarOut,s1,s2)
-        LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
-        LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
-        INTEGER,INTENT(IN) :: s1,s2
-	
-        LOGICAL,DIMENSION(klon_glo,s1,s2) :: Var_tmp
-        
-        CALL gather_mpi(VarIn,Var_tmp)
-        CALL grid1dTo2d_glo(Var_tmp,VarOut)
-      END SUBROUTINE body
+    LOGICAL,DIMENSION(klon_glo,size(VarOut,3),SIZE(VarOut,4)) :: Var_tmp
+
+    CALL gather_mpi(VarIn,Var_tmp)
+    CALL grid1dTo2d_glo(Var_tmp,VarOut)
 
   END SUBROUTINE gather2D_mpi_l2
@@ -1286,17 +855,8 @@
     LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
     
-    CALL body(VarIn,VarOut,size(VarOut,3),SIZE(VarOut,4),SIZE(VarOut,5))
-  
-    CONTAINS 
-      SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
-        LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
-        LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
-        INTEGER,INTENT(IN) :: s1,s2,s3
-	
-        LOGICAL,DIMENSION(klon_glo,s1,s2,s3) :: Var_tmp
-        
-        CALL gather_mpi(VarIn,Var_tmp)
-        CALL grid1dTo2d_glo(Var_tmp,VarOut)
-      END SUBROUTINE body
+    LOGICAL,DIMENSION(klon_glo,size(VarOut,3),SIZE(VarOut,4),SIZE(VarOut,5)) :: Var_tmp
+    
+    CALL gather_mpi(VarIn,Var_tmp)
+    CALL grid1dTo2d_glo(Var_tmp,VarOut)
 
   END SUBROUTINE gather2D_mpi_l3
@@ -1313,18 +873,11 @@
     INTEGER,INTENT(IN)  :: VarIn
     INTEGER,INTENT(OUT) :: VarOut
-    
-    INTEGER :: dummy
-    
-#ifndef CPP_PARA
-    VarOut=VarIn
-    RETURN
-#endif
-
-    IF (is_mpi_root) THEN
-      CALL reduce_sum_mpi_igen(VarIn,Varout,1)
-    ELSE
-      CALL reduce_sum_mpi_igen(VarIn,dummy,1)
-    ENDIF
-  
+    INTEGER             :: VarIn_tmp(1)
+    INTEGER             :: VarOut_tmp(1)
+    
+    VarIn_tmp(1)=VarIn    
+    CALL reduce_sum_mpi_igen(VarIn_tmp,Varout_tmp,1)
+    VarOut=VarOut_tmp(1)
+    
   END SUBROUTINE reduce_sum_mpi_i
 
@@ -1336,16 +889,5 @@
     INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
     
-    INTEGER :: dummy
-    
-#ifndef CPP_PARA
-    VarOut(:)=VarIn(:)
-    RETURN
-#endif
-
-    IF (is_mpi_root) THEN
-      CALL reduce_sum_mpi_igen(VarIn,Varout,SIZE(VarIn))
-    ELSE
-      CALL reduce_sum_mpi_igen(VarIn,dummy,SIZE(VarIn))      
-    ENDIF
+    CALL reduce_sum_mpi_igen(VarIn,Varout,SIZE(VarIn))
   
   END SUBROUTINE reduce_sum_mpi_i1
@@ -1358,16 +900,5 @@
     INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
     
-    INTEGER :: dummy
-    
-#ifndef CPP_PARA
-    VarOut(:,:)=VarIn(:,:)
-    RETURN
-#endif
-
-    IF (is_mpi_root) THEN
-      CALL reduce_sum_mpi_igen(VarIn,Varout,SIZE(VarIn))
-    ELSE
-      CALL reduce_sum_mpi_igen(VarIn,dummy,SIZE(VarIn))      
-    ENDIF
+    CALL reduce_sum_mpi_igen(VarIn,Varout,SIZE(VarIn))
   
   END SUBROUTINE reduce_sum_mpi_i2
@@ -1380,16 +911,5 @@
     INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
     
-    INTEGER :: dummy
-    
-#ifndef CPP_PARA
-    VarOut(:,:,:)=VarIn(:,:,:)
-    RETURN
-#endif
-
-    IF (is_mpi_root) THEN
-      CALL reduce_sum_mpi_igen(VarIn,Varout,SIZE(VarIn))
-    ELSE
-      CALL reduce_sum_mpi_igen(VarIn,dummy,SIZE(VarIn))      
-    ENDIF
+    CALL reduce_sum_mpi_igen(VarIn,Varout,SIZE(VarIn))
   
   END SUBROUTINE reduce_sum_mpi_i3
@@ -1402,16 +922,5 @@
     INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
     
-    INTEGER :: dummy
-    
-#ifndef CPP_PARA
-    VarOut(:,:,:,:)=VarIn(:,:,:,:)
-    RETURN
-#endif
-
-    IF (is_mpi_root) THEN
-      CALL reduce_sum_mpi_igen(VarIn,Varout,SIZE(VarIn))
-    ELSE
-      CALL reduce_sum_mpi_igen(VarIn,dummy,SIZE(VarIn))      
-    ENDIF
+    CALL reduce_sum_mpi_igen(VarIn,Varout,SIZE(VarIn))
   
   END SUBROUTINE reduce_sum_mpi_i4                  
@@ -1424,17 +933,10 @@
     REAL,INTENT(IN)  :: VarIn
     REAL,INTENT(OUT) :: VarOut
-    
-    REAL :: dummy
-    
-#ifndef CPP_PARA
-    VarOut=VarIn
-    RETURN
-#endif
-
-    IF (is_mpi_root) THEN
-      CALL reduce_sum_mpi_rgen(VarIn,Varout,1)
-    ELSE
-      CALL reduce_sum_mpi_rgen(VarIn,dummy,1)
-    ENDIF
+    REAL             :: VarIn_tmp(1)
+    REAL             :: VarOut_tmp(1)
+    
+    VarIn_tmp(1)=VarIn    
+    CALL reduce_sum_mpi_rgen(VarIn_tmp,Varout_tmp,1)
+    VarOut=VarOut_tmp(1)
   
   END SUBROUTINE reduce_sum_mpi_r
@@ -1447,17 +949,6 @@
     REAL,INTENT(OUT),DIMENSION(:) :: VarOut
     
-    REAL :: dummy
-    
-#ifndef CPP_PARA
-    VarOut(:)=VarIn(:)
-    RETURN
-#endif
-
-    IF (is_mpi_root) THEN
-      CALL reduce_sum_mpi_rgen(VarIn,Varout,SIZE(VarIn))
-    ELSE
-      CALL reduce_sum_mpi_rgen(VarIn,dummy,SIZE(VarIn))      
-    ENDIF
-  
+    CALL reduce_sum_mpi_rgen(VarIn,Varout,SIZE(VarIn))
+     
   END SUBROUTINE reduce_sum_mpi_r1
 
@@ -1469,16 +960,5 @@
     REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
     
-    REAL :: dummy
-    
-#ifndef CPP_PARA
-    VarOut(:,:)=VarIn(:,:)
-    RETURN
-#endif
-
-    IF (is_mpi_root) THEN
-      CALL reduce_sum_mpi_rgen(VarIn,Varout,SIZE(VarIn))
-    ELSE
-      CALL reduce_sum_mpi_rgen(VarIn,dummy,SIZE(VarIn))      
-    ENDIF
+    CALL reduce_sum_mpi_rgen(VarIn,Varout,SIZE(VarIn))
   
   END SUBROUTINE reduce_sum_mpi_r2
@@ -1491,16 +971,5 @@
     REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
     
-    REAL :: dummy
-    
-#ifndef CPP_PARA
-    VarOut(:,:,:)=VarIn(:,:,:)
-    RETURN
-#endif
-
-    IF (is_mpi_root) THEN
-      CALL reduce_sum_mpi_rgen(VarIn,Varout,SIZE(VarIn))
-    ELSE
-      CALL reduce_sum_mpi_rgen(VarIn,dummy,SIZE(VarIn))      
-    ENDIF
+    CALL reduce_sum_mpi_rgen(VarIn,Varout,SIZE(VarIn))
   
   END SUBROUTINE reduce_sum_mpi_r3
@@ -1513,16 +982,5 @@
     REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
     
-    REAL :: dummy
-    
-#ifndef CPP_PARA
-    VarOut(:,:,:,:)=VarIn(:,:,:,:)
-    RETURN
-#endif
-
-    IF (is_mpi_root) THEN
-      CALL reduce_sum_mpi_rgen(VarIn,Varout,SIZE(VarIn))
-    ELSE
-      CALL reduce_sum_mpi_rgen(VarIn,dummy,SIZE(VarIn))      
-    ENDIF
+    CALL reduce_sum_mpi_rgen(VarIn,Varout,SIZE(VarIn))
   
   END SUBROUTINE reduce_sum_mpi_r4 
@@ -1769,7 +1227,6 @@
   END SUBROUTINE grid2dTo1d_mpi_l3
 
-
-                            
-END MODULE mod_phys_lmdz_mpi_transfert
+               
+
 
 
@@ -1785,12 +1242,12 @@
     INTEGER,INTENT(IN) :: nb
     
-#ifdef CPP_PARA
+#ifdef CPP_MPI
     INCLUDE 'mpif.h'
 #endif
     INTEGER :: ierr
 
-    IF (.not.is_ok_mpi) RETURN
-    
-#ifdef CPP_PARA
+    IF (.not.is_using_mpi) RETURN
+    
+#ifdef CPP_MPI
     CALL MPI_BCAST(Var,nb,MPI_CHARACTER,mpi_root_x,COMM_LMDZ_PHY,ierr)
 #endif
@@ -1807,12 +1264,12 @@
     INTEGER,INTENT(IN) :: nb
     
-#ifdef CPP_PARA
+#ifdef CPP_MPI
     INCLUDE 'mpif.h'
 #endif
     INTEGER :: ierr
 
-    IF (.not.is_ok_mpi) RETURN
-
-#ifdef CPP_PARA
+    IF (.not.is_using_mpi) RETURN
+
+#ifdef CPP_MPI
     CALL MPI_BCAST(Var,nb,MPI_INTEGER,mpi_root_x,COMM_LMDZ_PHY,ierr)
 #endif
@@ -1830,12 +1287,12 @@
     INTEGER,INTENT(IN) :: nb
     
-#ifdef CPP_PARA
+#ifdef CPP_MPI
     INCLUDE 'mpif.h'
 #endif
     INTEGER :: ierr
 
-    IF (.not.is_ok_mpi) RETURN
-
-#ifdef CPP_PARA
+    IF (.not.is_using_mpi) RETURN
+
+#ifdef CPP_MPI
     CALL MPI_BCAST(Var,nb,MPI_REAL_LMDZ,mpi_root_x,COMM_LMDZ_PHY,ierr)
 #endif
@@ -1853,12 +1310,12 @@
     INTEGER,INTENT(IN) :: nb
     
-#ifdef CPP_PARA
+#ifdef CPP_MPI
     INCLUDE 'mpif.h'
 #endif
     INTEGER :: ierr
 
-    IF (.not.is_ok_mpi) RETURN
-
-#ifdef CPP_PARA
+    IF (.not.is_using_mpi) RETURN
+
+#ifdef CPP_MPI
     CALL MPI_BCAST(Var,nb,MPI_LOGICAL,mpi_root_x,COMM_LMDZ_PHY,ierr)
 #endif
@@ -1877,5 +1334,5 @@
     INTEGER,INTENT(OUT),DIMENSION(klon_mpi,dimsize) :: VarOut
   
-#ifdef CPP_PARA
+#ifdef CPP_MPI
     INCLUDE 'mpif.h'
 #endif
@@ -1887,5 +1344,5 @@
 
 
-    IF (.not.is_ok_mpi) THEN
+    IF (.not.is_using_mpi) THEN
       VarOut(:,:)=VarIn(:,:)
       RETURN
@@ -1906,5 +1363,5 @@
     ENDIF
       
-#ifdef CPP_PARA 
+#ifdef CPP_MPI 
     CALL MPI_SCATTERV(VarTmp,counts,displs,MPI_INTEGER,VarOut,klon_mpi*dimsize,   &
                       MPI_INTEGER,mpi_root_x, COMM_LMDZ_PHY,ierr)
@@ -1922,5 +1379,5 @@
     REAL,INTENT(OUT),DIMENSION(klon_mpi,dimsize) :: VarOut
   
-#ifdef CPP_PARA
+#ifdef CPP_MPI
     INCLUDE 'mpif.h'
 #endif
@@ -1932,5 +1389,5 @@
     INTEGER :: ierr
 
-    IF (.not.is_ok_mpi) THEN
+    IF (.not.is_using_mpi) THEN
       VarOut(:,:)=VarIn(:,:)
       RETURN
@@ -1950,5 +1407,5 @@
     ENDIF
       
-#ifdef CPP_PARA 
+#ifdef CPP_MPI 
     CALL MPI_SCATTERV(VarTmp,counts,displs,MPI_REAL_LMDZ,VarOut,klon_mpi*dimsize,   &
                       MPI_REAL_LMDZ,mpi_root_x, COMM_LMDZ_PHY,ierr)
@@ -1968,5 +1425,5 @@
     LOGICAL,INTENT(OUT),DIMENSION(klon_mpi,dimsize) :: VarOut
   
-#ifdef CPP_PARA
+#ifdef CPP_MPI
     INCLUDE 'mpif.h'
 #endif
@@ -1978,5 +1435,5 @@
     INTEGER :: ierr
 
-    IF (.not.is_ok_mpi) THEN
+    IF (.not.is_using_mpi) THEN
       VarOut(:,:)=VarIn(:,:)
       RETURN
@@ -1996,5 +1453,5 @@
     ENDIF
       
-#ifdef CPP_PARA
+#ifdef CPP_MPI
     CALL MPI_SCATTERV(VarTmp,counts,displs,MPI_LOGICAL,VarOut,klon_mpi*dimsize,   &
                       MPI_LOGICAL,mpi_root_x, COMM_LMDZ_PHY,ierr)
@@ -2011,5 +1468,5 @@
     IMPLICIT NONE
   
-#ifdef CPP_PARA
+#ifdef CPP_MPI
     INCLUDE 'mpif.h'
 #endif
@@ -2025,5 +1482,5 @@
     INTEGER :: ierr
 
-    IF (.not.is_ok_mpi) THEN
+    IF (.not.is_using_mpi) THEN
       VarOut(:,:)=VarIn(:,:)
       RETURN
@@ -2041,5 +1498,5 @@
     ENDIF
     
-#ifdef CPP_PARA
+#ifdef CPP_MPI
     CALL MPI_GATHERV(VarIn,klon_mpi*dimsize,MPI_INTEGER,VarTmp,counts,displs,   &
                      MPI_INTEGER,mpi_root_x, COMM_LMDZ_PHY,ierr)
@@ -2065,5 +1522,5 @@
     IMPLICIT NONE
   
-#ifdef CPP_PARA
+#ifdef CPP_MPI
     INCLUDE 'mpif.h'
 #endif
@@ -2089,10 +1546,10 @@
     ENDIF
     
-    IF (.not.is_ok_mpi) THEN
+    IF (.not.is_using_mpi) THEN
       VarOut(:,:)=VarIn(:,:)
       RETURN
     ENDIF
 
-#ifdef CPP_PARA
+#ifdef CPP_MPI
     CALL MPI_GATHERV(VarIn,klon_mpi*dimsize,MPI_REAL_LMDZ,VarTmp,counts,displs,   &
                       MPI_REAL_LMDZ,mpi_root_x, COMM_LMDZ_PHY,ierr)
@@ -2121,5 +1578,5 @@
     LOGICAL,INTENT(OUT),DIMENSION(klon_glo,dimsize) :: VarOut
   
-#ifdef CPP_PARA
+#ifdef CPP_MPI
     INCLUDE 'mpif.h'
 #endif
@@ -2131,5 +1588,5 @@
     INTEGER :: ierr
     
-    IF (.not.is_ok_mpi) THEN
+    IF (.not.is_using_mpi) THEN
       VarOut(:,:)=VarIn(:,:)
       RETURN
@@ -2147,5 +1604,5 @@
     
 
-#ifdef CPP_PARA
+#ifdef CPP_MPI
     CALL MPI_GATHERV(VarIn,klon_mpi*dimsize,MPI_LOGICAL,VarTmp,counts,displs,   &
                       MPI_LOGICAL,mpi_root_x, COMM_LMDZ_PHY,ierr)
@@ -2172,5 +1629,5 @@
     IMPLICIT NONE
     
-#ifdef CPP_PARA
+#ifdef CPP_MPI
     INCLUDE 'mpif.h'
 #endif
@@ -2181,5 +1638,5 @@
     INTEGER :: ierr
    
-    IF (.not.is_ok_mpi) THEN
+    IF (.not.is_using_mpi) THEN
       VarOut(:)=VarIn(:)
       RETURN
@@ -2187,5 +1644,5 @@
 
 
-#ifdef CPP_PARA
+#ifdef CPP_MPI
     CALL MPI_REDUCE(VarIn,VarOut,nb,MPI_INTEGER,MPI_SUM,mpi_root_x,COMM_LMDZ_PHY,ierr)
 #endif
@@ -2199,5 +1656,5 @@
     IMPLICIT NONE
 
-#ifdef CPP_PARA
+#ifdef CPP_MPI
     INCLUDE 'mpif.h'
 #endif
@@ -2208,10 +1665,10 @@
     INTEGER :: ierr
  
-    IF (.not.is_ok_mpi) THEN
+    IF (.not.is_using_mpi) THEN
       VarOut(:)=VarIn(:)
       RETURN
     ENDIF
    
-#ifdef CPP_PARA
+#ifdef CPP_MPI
     CALL MPI_REDUCE(VarIn,VarOut,nb,MPI_REAL_LMDZ,MPI_SUM,mpi_root_x,COMM_LMDZ_PHY,ierr)
 #endif
@@ -2443,2 +1900,3 @@
   END SUBROUTINE grid2dTo1d_mpi_lgen   
 
+END MODULE mod_phys_lmdz_mpi_transfert
Index: /LMDZ4/trunk/libf/phylmd/mod_phys_lmdz_omp_data.F90
===================================================================
--- /LMDZ4/trunk/libf/phylmd/mod_phys_lmdz_omp_data.F90	(revision 1000)
+++ /LMDZ4/trunk/libf/phylmd/mod_phys_lmdz_omp_data.F90	(revision 1001)
@@ -7,5 +7,5 @@
   INTEGER,SAVE :: omp_rank
   LOGICAL,SAVE :: is_omp_root
-  LOGICAL,SAVE :: is_ok_omp
+  LOGICAL,SAVE :: is_using_omp
   
   INTEGER,SAVE,DIMENSION(:),ALLOCATABLE :: klon_omp_para_nb
@@ -27,5 +27,5 @@
     INTEGER :: i
 
-#ifdef _OPENMP    
+#ifdef CPP_OMP    
     INTEGER :: OMP_GET_NUM_THREADS
     EXTERNAL OMP_GET_NUM_THREADS
@@ -34,12 +34,12 @@
 #endif  
 
-#ifdef _OPENMP
+#ifdef CPP_OMP
 !$OMP MASTER
-        is_ok_omp=.TRUE.
+        is_using_omp=.TRUE.
         omp_size=OMP_GET_NUM_THREADS()
 !$OMP END MASTER
         omp_rank=OMP_GET_THREAD_NUM()    
 #else    
-    is_ok_omp=.FALSE.
+    is_using_omp=.FALSE.
     omp_size=1
     omp_rank=0
Index: /LMDZ4/trunk/libf/phylmd/mod_phys_lmdz_omp_transfert.F90
===================================================================
--- /LMDZ4/trunk/libf/phylmd/mod_phys_lmdz_omp_transfert.F90	(revision 1000)
+++ /LMDZ4/trunk/libf/phylmd/mod_phys_lmdz_omp_transfert.F90	(revision 1001)
@@ -4,6 +4,20 @@
 MODULE mod_phys_lmdz_omp_transfert
 
-  INTEGER,PARAMETER :: omp_buffer_size = 1024*1024*16
-  INTEGER,SAVE,DIMENSION(omp_buffer_size) :: omp_buffer
+  PRIVATE
+  
+  INTEGER,PARAMETER :: grow_factor=1.5
+  INTEGER,PARAMETER :: size_min=1024
+  
+  CHARACTER(LEN=size_min),SAVE            :: buffer_c
+  INTEGER,SAVE                            :: size_c
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:)   :: buffer_i
+  INTEGER,SAVE                            :: size_i
+  REAL,SAVE,ALLOCATABLE,DIMENSION(:)      :: buffer_r
+  INTEGER,SAVE                            :: size_r
+  LOGICAL,SAVE,ALLOCATABLE,DIMENSION(:)   :: buffer_l
+  INTEGER,SAVE                            :: size_l
+
+
+  
   
   INTERFACE bcast_omp
@@ -33,6 +47,57 @@
   END INTERFACE 
 
+
+  PUBLIC bcast_omp,scatter_omp,gather_omp,reduce_sum_omp
+
 CONTAINS
 
+  SUBROUTINE check_buffer_i(buff_size)
+  IMPLICIT NONE
+  INTEGER :: buff_size
+
+    IF (buff_size>size_i) THEN
+!$OMP BARRIER
+!$OMP MASTER
+      IF (ALLOCATED(buffer_i)) DEALLOCATE(buffer_i)
+      size_i=MAX(size_min,INT(grow_factor*buff_size))
+      ALLOCATE(buffer_i(size_i))
+!$OMP END MASTER
+!$OMP BARRIER
+    ENDIF
+  
+  END SUBROUTINE check_buffer_i
+  
+  SUBROUTINE check_buffer_r(buff_size)
+  IMPLICIT NONE
+  INTEGER :: buff_size
+
+    IF (buff_size>size_r) THEN
+!$OMP BARRIER
+!$OMP MASTER
+      IF (ALLOCATED(buffer_r)) DEALLOCATE(buffer_r)
+      size_r=MAX(size_min,INT(grow_factor*buff_size))
+      ALLOCATE(buffer_r(size_r))
+!$OMP END MASTER
+!$OMP BARRIER
+    ENDIF
+  
+  END SUBROUTINE check_buffer_r
+  
+  SUBROUTINE check_buffer_l(buff_size)
+  IMPLICIT NONE
+  INTEGER :: buff_size
+
+    IF (buff_size>size_l) THEN
+!$OMP BARRIER
+!$OMP MASTER
+      IF (ALLOCATED(buffer_l)) DEALLOCATE(buffer_l)
+      size_l=MAX(size_min,INT(grow_factor*buff_size))
+      ALLOCATE(buffer_l(size_l))
+!$OMP END MASTER
+!$OMP BARRIER
+    ENDIF
+  
+  END SUBROUTINE check_buffer_l
+    
 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 !! Definition des Broadcast --> 4D   !!
@@ -44,6 +109,6 @@
   IMPLICIT NONE
     CHARACTER(LEN=*),INTENT(INOUT) :: Var
-
-    CALL bcast_omp_cgen(Var,len(Var),omp_buffer)
+    
+    CALL bcast_omp_cgen(Var,len(Var),buffer_c)
     
   END SUBROUTINE bcast_omp_c
@@ -54,6 +119,10 @@
   IMPLICIT NONE
     INTEGER,INTENT(INOUT) :: Var
-
-    CALL bcast_omp_igen(Var,1,omp_buffer)
+    INTEGER :: Var_tmp(1)
+    
+    Var_tmp(1)=Var
+    CALL check_buffer_i(1)
+    CALL bcast_omp_igen(Var_tmp,1,buffer_i)
+    Var=Var_tmp(1)
 
   END SUBROUTINE bcast_omp_i
@@ -64,5 +133,6 @@
     INTEGER,INTENT(INOUT) :: Var(:)
    
-    CALL bcast_omp_igen(Var,size(Var),omp_buffer)
+    CALL check_buffer_i(size(Var))
+    CALL bcast_omp_igen(Var,size(Var),buffer_i)
 
   END SUBROUTINE bcast_omp_i1
@@ -73,5 +143,6 @@
     INTEGER,INTENT(INOUT) :: Var(:,:)
    
-    CALL bcast_omp_igen(Var,size(Var),omp_buffer)
+    CALL check_buffer_i(size(Var))
+    CALL bcast_omp_igen(Var,size(Var),buffer_i)
 
   END SUBROUTINE bcast_omp_i2
@@ -82,5 +153,6 @@
     INTEGER,INTENT(INOUT) :: Var(:,:,:)
 
-    CALL bcast_omp_igen(Var,size(Var),omp_buffer)
+    CALL check_buffer_i(size(Var))
+    CALL bcast_omp_igen(Var,size(Var),buffer_i)
 
   END SUBROUTINE bcast_omp_i3
@@ -91,5 +163,6 @@
     INTEGER,INTENT(INOUT) :: Var(:,:,:,:)
    
-    CALL bcast_omp_igen(Var,size(Var),omp_buffer)
+    CALL check_buffer_i(size(Var))
+    CALL bcast_omp_igen(Var,size(Var),buffer_i)
 
   END SUBROUTINE bcast_omp_i4
@@ -101,6 +174,10 @@
   IMPLICIT NONE
     REAL,INTENT(INOUT) :: Var
-
-    CALL bcast_omp_rgen(Var,1,omp_buffer)
+    REAL :: Var_tmp(1)
+    
+    Var_tmp(1)=Var
+    CALL check_buffer_r(1)
+    CALL bcast_omp_rgen(Var_tmp,1,buffer_r)
+    Var=Var_tmp(1)
 
   END SUBROUTINE bcast_omp_r
@@ -111,5 +188,6 @@
     REAL,INTENT(INOUT) :: Var(:)
    
-    CALL bcast_omp_rgen(Var,size(Var),omp_buffer)
+    CALL check_buffer_r(size(Var))
+    CALL bcast_omp_rgen(Var,size(Var),buffer_r)
 
   END SUBROUTINE bcast_omp_r1
@@ -120,5 +198,6 @@
     REAL,INTENT(INOUT) :: Var(:,:)
    
-    CALL bcast_omp_rgen(Var,size(Var),omp_buffer)
+    CALL check_buffer_r(size(Var))
+    CALL bcast_omp_rgen(Var,size(Var),buffer_r)
 
   END SUBROUTINE bcast_omp_r2
@@ -129,5 +208,6 @@
     REAL,INTENT(INOUT) :: Var(:,:,:)
 
-    CALL bcast_omp_igen(Var,size(Var),omp_buffer)
+    CALL check_buffer_r(size(Var))
+    CALL bcast_omp_rgen(Var,size(Var),buffer_r)
 
   END SUBROUTINE bcast_omp_r3
@@ -138,5 +218,6 @@
     REAL,INTENT(INOUT) :: Var(:,:,:,:)
    
-    CALL bcast_omp_rgen(Var,size(Var),omp_buffer)
+    CALL check_buffer_r(size(Var))
+    CALL bcast_omp_rgen(Var,size(Var),buffer_r)
 
   END SUBROUTINE bcast_omp_r4
@@ -148,6 +229,10 @@
   IMPLICIT NONE
     LOGICAL,INTENT(INOUT) :: Var
-
-    CALL bcast_omp_lgen(Var,1,omp_buffer)
+    LOGICAL :: Var_tmp(1)
+    
+    Var_tmp(1)=Var
+    CALL check_buffer_l(1)
+    CALL bcast_omp_lgen(Var_tmp,1,buffer_l)
+    Var=Var_tmp(1)
 
   END SUBROUTINE bcast_omp_l
@@ -158,5 +243,6 @@
     LOGICAL,INTENT(INOUT) :: Var(:)
    
-    CALL bcast_omp_lgen(Var,size(Var),omp_buffer)
+    CALL check_buffer_l(size(Var))
+    CALL bcast_omp_lgen(Var,size(Var),buffer_l)
 
   END SUBROUTINE bcast_omp_l1
@@ -167,5 +253,6 @@
     LOGICAL,INTENT(INOUT) :: Var(:,:)
    
-    CALL bcast_omp_lgen(Var,size(Var),omp_buffer)
+    CALL check_buffer_l(size(Var))
+    CALL bcast_omp_lgen(Var,size(Var),buffer_l)
 
   END SUBROUTINE bcast_omp_l2
@@ -176,5 +263,6 @@
     LOGICAL,INTENT(INOUT) :: Var(:,:,:)
 
-    CALL bcast_omp_lgen(Var,size(Var),omp_buffer)
+    CALL check_buffer_l(size(Var))
+    CALL bcast_omp_lgen(Var,size(Var),buffer_l)
 
   END SUBROUTINE bcast_omp_l3
@@ -185,5 +273,6 @@
     LOGICAL,INTENT(INOUT) :: Var(:,:,:,:)
    
-    CALL bcast_omp_lgen(Var,size(Var),omp_buffer)
+    CALL check_buffer_l(size(Var))
+    CALL bcast_omp_lgen(Var,size(Var),buffer_l)
 
   END SUBROUTINE bcast_omp_l4
@@ -196,5 +285,4 @@
 
   SUBROUTINE scatter_omp_i(VarIn, VarOut)
-    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
     IMPLICIT NONE
   
@@ -202,12 +290,6 @@
     INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
 
-    INTEGER :: dummy
-
-
-     IF (is_omp_root) THEN
-      CALL scatter_omp_igen(VarIn,Varout,1,omp_buffer)
-     ELSE
-      CALL scatter_omp_igen(dummy,Varout,1,omp_buffer)
-    ENDIF
+    CALL Check_buffer_i(size(VarIn))   
+    CALL scatter_omp_igen(VarIn,Varout,1,buffer_i)
     
   END SUBROUTINE scatter_omp_i
@@ -215,17 +297,11 @@
 
   SUBROUTINE scatter_omp_i1(VarIn, VarOut)
-    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
     IMPLICIT NONE
   
     INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
     INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
-    
-    INTEGER :: dummy
-
-    IF (is_omp_root) THEN
-      CALL scatter_omp_igen(VarIn,Varout,Size(VarOut,2),omp_buffer)
-    ELSE
-      CALL scatter_omp_igen(dummy,Varout,Size(VarOut,2),omp_buffer)
-    ENDIF
+
+    CALL Check_buffer_i(size(VarIn))   
+    CALL scatter_omp_igen(VarIn,Varout,Size(VarOut,2),buffer_i)
     
   END SUBROUTINE scatter_omp_i1
@@ -233,5 +309,4 @@
   
   SUBROUTINE scatter_omp_i2(VarIn, VarOut)
-    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
     IMPLICIT NONE
   
@@ -239,11 +314,6 @@
     INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
     
-    INTEGER :: dummy
-    
-    IF (is_omp_root) THEN
-      CALL scatter_omp_igen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3),omp_buffer)
-    ELSE
-      CALL scatter_omp_igen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3),omp_buffer)
-    ENDIF
+    CALL Check_buffer_i(size(VarIn))   
+    CALL scatter_omp_igen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3),buffer_i)
 
   END SUBROUTINE scatter_omp_i2
@@ -251,5 +321,4 @@
 
   SUBROUTINE scatter_omp_i3(VarIn, VarOut)
-    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
     IMPLICIT NONE
   
@@ -257,11 +326,6 @@
     INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
     
-    INTEGER :: dummy
-    
-    IF (is_omp_root) THEN
-      CALL scatter_omp_igen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4),omp_buffer)
-    ELSE
-      CALL scatter_omp_igen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4),omp_buffer)
-    ENDIF
+    CALL Check_buffer_i(size(VarIn))   
+    CALL scatter_omp_igen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4),buffer_i)
   
   END SUBROUTINE scatter_omp_i3
@@ -271,5 +335,4 @@
 
   SUBROUTINE scatter_omp_r(VarIn, VarOut)
-    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
     IMPLICIT NONE
   
@@ -277,12 +340,6 @@
     REAL,INTENT(OUT),DIMENSION(:) :: VarOut
 
-    REAL :: dummy
-
-
-     IF (is_omp_root) THEN
-      CALL scatter_omp_rgen(VarIn,Varout,1,omp_buffer)
-     ELSE
-      CALL scatter_omp_rgen(dummy,Varout,1,omp_buffer)
-    ENDIF
+    CALL Check_buffer_r(size(VarIn))   
+    CALL scatter_omp_rgen(VarIn,Varout,1,buffer_r)
     
   END SUBROUTINE scatter_omp_r
@@ -290,5 +347,4 @@
 
   SUBROUTINE scatter_omp_r1(VarIn, VarOut)
-    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
     IMPLICIT NONE
   
@@ -296,17 +352,11 @@
     REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
     
-    REAL :: dummy
-
-    IF (is_omp_root) THEN
-      CALL scatter_omp_rgen(VarIn,Varout,Size(VarOut,2),omp_buffer)
-    ELSE
-      CALL scatter_omp_rgen(dummy,Varout,Size(VarOut,2),omp_buffer)
-    ENDIF
-    
+    CALL Check_buffer_r(size(VarIn))   
+    CALL scatter_omp_rgen(VarIn,Varout,Size(VarOut,2),buffer_r)
+        
   END SUBROUTINE scatter_omp_r1
   
   
   SUBROUTINE scatter_omp_r2(VarIn, VarOut)
-    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
     IMPLICIT NONE
   
@@ -314,11 +364,6 @@
     REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
     
-    REAL :: dummy
-    
-    IF (is_omp_root) THEN
-      CALL scatter_omp_rgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3),omp_buffer)
-    ELSE
-      CALL scatter_omp_rgen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3),omp_buffer)
-    ENDIF
+    CALL Check_buffer_r(size(VarIn))   
+    CALL scatter_omp_rgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3),buffer_r)
 
   END SUBROUTINE scatter_omp_r2
@@ -326,5 +371,4 @@
 
   SUBROUTINE scatter_omp_r3(VarIn, VarOut)
-    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
     IMPLICIT NONE
   
@@ -332,11 +376,6 @@
     REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
     
-    REAL :: dummy
-    
-    IF (is_omp_root) THEN
-      CALL scatter_omp_rgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4),omp_buffer)
-    ELSE
-      CALL scatter_omp_rgen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4),omp_buffer)
-    ENDIF
+    CALL Check_buffer_r(size(VarIn))   
+    CALL scatter_omp_rgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4),buffer_r)
   
   END SUBROUTINE scatter_omp_r3
@@ -345,5 +384,4 @@
 
   SUBROUTINE scatter_omp_l(VarIn, VarOut)
-    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
     IMPLICIT NONE
   
@@ -351,12 +389,6 @@
     LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut
 
-    LOGICAL :: dummy
-
-
-     IF (is_omp_root) THEN
-      CALL scatter_omp_lgen(VarIn,Varout,1,omp_buffer)
-     ELSE
-      CALL scatter_omp_lgen(dummy,Varout,1,omp_buffer)
-    ENDIF
+    CALL Check_buffer_l(size(VarIn))   
+    CALL scatter_omp_lgen(VarIn,Varout,1,buffer_l)
     
   END SUBROUTINE scatter_omp_l
@@ -364,5 +396,4 @@
 
   SUBROUTINE scatter_omp_l1(VarIn, VarOut)
-    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
     IMPLICIT NONE
   
@@ -370,11 +401,6 @@
     LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
     
-    LOGICAL :: dummy
-
-    IF (is_omp_root) THEN
-      CALL scatter_omp_lgen(VarIn,Varout,Size(VarOut,2),omp_buffer)
-    ELSE
-      CALL scatter_omp_lgen(dummy,Varout,Size(VarOut,2),omp_buffer)
-    ENDIF
+    CALL Check_buffer_l(size(VarIn))   
+    CALL scatter_omp_lgen(VarIn,Varout,Size(VarOut,2),buffer_l)
     
   END SUBROUTINE scatter_omp_l1
@@ -382,5 +408,4 @@
   
   SUBROUTINE scatter_omp_l2(VarIn, VarOut)
-    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
     IMPLICIT NONE
   
@@ -388,11 +413,6 @@
     LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
     
-    LOGICAL :: dummy
-    
-    IF (is_omp_root) THEN
-      CALL scatter_omp_lgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3),omp_buffer)
-    ELSE
-      CALL scatter_omp_lgen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3),omp_buffer)
-    ENDIF
+    CALL Check_buffer_l(size(VarIn))   
+    CALL scatter_omp_lgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3),buffer_l)
 
   END SUBROUTINE scatter_omp_l2
@@ -400,5 +420,4 @@
 
   SUBROUTINE scatter_omp_l3(VarIn, VarOut)
-    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
     IMPLICIT NONE
   
@@ -406,11 +425,6 @@
     LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
     
-    LOGICAL :: dummy
-    
-    IF (is_omp_root) THEN
-      CALL scatter_omp_lgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4),omp_buffer)
-    ELSE
-      CALL scatter_omp_lgen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4),omp_buffer)
-    ENDIF
+    CALL Check_buffer_l(size(VarIn))   
+    CALL scatter_omp_lgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4),buffer_l)
   
   END SUBROUTINE scatter_omp_l3  
@@ -418,5 +432,4 @@
 
   SUBROUTINE gather_omp_i(VarIn, VarOut)
-    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
     IMPLICIT NONE
   
@@ -424,12 +437,6 @@
     INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
 
-    INTEGER :: dummy
-
-
-     IF (is_omp_root) THEN
-      CALL gather_omp_igen(VarIn,Varout,1,omp_buffer)
-     ELSE
-      CALL gather_omp_igen(dummy,Varout,1,omp_buffer)
-    ENDIF
+    CALL Check_buffer_i(size(VarOut))   
+    CALL gather_omp_igen(VarIn,Varout,1,buffer_i)
     
   END SUBROUTINE gather_omp_i
@@ -437,5 +444,4 @@
 
   SUBROUTINE gather_omp_i1(VarIn, VarOut)
-    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
     IMPLICIT NONE
   
@@ -443,11 +449,6 @@
     INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
     
-    INTEGER :: dummy
-
-    IF (is_omp_root) THEN
-      CALL gather_omp_igen(VarIn,Varout,Size(VarIn,2),omp_buffer)
-    ELSE
-      CALL gather_omp_igen(VarIn,dummy,Size(VarIn,2),omp_buffer)
-    ENDIF
+    CALL Check_buffer_i(size(VarOut))   
+    CALL gather_omp_igen(VarIn,Varout,Size(VarIn,2),buffer_i)
     
   END SUBROUTINE gather_omp_i1
@@ -455,5 +456,4 @@
 
   SUBROUTINE gather_omp_i2(VarIn, VarOut)
-    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
     IMPLICIT NONE
   
@@ -461,17 +461,11 @@
     INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
     
-    INTEGER :: dummy
-
-    IF (is_omp_root) THEN
-      CALL gather_omp_igen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3),omp_buffer)
-    ELSE
-      CALL gather_omp_igen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3),omp_buffer)
-    ENDIF
-    
+    CALL Check_buffer_i(size(VarOut))   
+    CALL gather_omp_igen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3),buffer_i)
+          
   END SUBROUTINE gather_omp_i2
   
 
   SUBROUTINE gather_omp_i3(VarIn, VarOut)
-    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
     IMPLICIT NONE
   
@@ -479,11 +473,6 @@
     INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
     
-    INTEGER :: dummy
-
-    IF (is_omp_root) THEN
-      CALL gather_omp_igen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4),omp_buffer)
-    ELSE
-      CALL gather_omp_igen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4),omp_buffer)
-    ENDIF
+    CALL Check_buffer_i(size(VarOut))   
+    CALL gather_omp_igen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4),buffer_i)
     
   END SUBROUTINE gather_omp_i3
@@ -492,5 +481,4 @@
 
   SUBROUTINE gather_omp_r(VarIn, VarOut)
-    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
     IMPLICIT NONE
   
@@ -498,12 +486,6 @@
     REAL,INTENT(OUT),DIMENSION(:) :: VarOut
 
-    REAL :: dummy
-
-
-     IF (is_omp_root) THEN
-      CALL gather_omp_rgen(VarIn,Varout,1,omp_buffer)
-     ELSE
-      CALL gather_omp_rgen(VarIn,dummy,1,omp_buffer)
-    ENDIF
+    CALL Check_buffer_r(size(VarOut))   
+    CALL gather_omp_rgen(VarIn,Varout,1,buffer_r)
     
   END SUBROUTINE gather_omp_r
@@ -511,23 +493,16 @@
 
   SUBROUTINE gather_omp_r1(VarIn, VarOut)
-    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
     IMPLICIT NONE
   
     REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
     REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
-    
-    REAL :: dummy
-
-    IF (is_omp_root) THEN
-      CALL gather_omp_rgen(VarIn,Varout,Size(VarIn,2),omp_buffer)
-    ELSE
-      CALL gather_omp_rgen(VarIn,dummy,Size(VarIn,2),omp_buffer)
-    ENDIF
-    
+
+    CALL Check_buffer_r(size(VarOut))   
+    CALL gather_omp_rgen(VarIn,Varout,Size(VarIn,2),buffer_r)
+        
   END SUBROUTINE gather_omp_r1
 
 
   SUBROUTINE gather_omp_r2(VarIn, VarOut)
-    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
     IMPLICIT NONE
   
@@ -535,11 +510,6 @@
     REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
     
-    REAL :: dummy
-
-    IF (is_omp_root) THEN
-      CALL gather_omp_rgen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3),omp_buffer)
-    ELSE
-      CALL gather_omp_rgen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3),omp_buffer)
-    ENDIF
+    CALL Check_buffer_r(size(VarOut))   
+    CALL gather_omp_rgen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3),buffer_r)
     
   END SUBROUTINE gather_omp_r2
@@ -547,5 +517,4 @@
 
   SUBROUTINE gather_omp_r3(VarIn, VarOut)
-    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
     IMPLICIT NONE
   
@@ -553,11 +522,5 @@
     REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
     
-    REAL :: dummy
-
-    IF (is_omp_root) THEN
-      CALL gather_omp_rgen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4),omp_buffer)
-    ELSE
-      CALL gather_omp_rgen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4),omp_buffer)
-    ENDIF
+    CALL gather_omp_rgen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4),buffer_r)
     
   END SUBROUTINE gather_omp_r3
@@ -565,5 +528,4 @@
 
   SUBROUTINE gather_omp_l(VarIn, VarOut)
-    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
     IMPLICIT NONE
   
@@ -571,12 +533,6 @@
     LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut
 
-    LOGICAL :: dummy
-
-
-     IF (is_omp_root) THEN
-      CALL gather_omp_lgen(VarIn,Varout,1,omp_buffer)
-     ELSE
-      CALL gather_omp_lgen(VarIn,dummy,1,omp_buffer)
-    ENDIF
+    CALL Check_buffer_l(size(VarOut))   
+    CALL gather_omp_lgen(VarIn,Varout,1,buffer_l)
     
   END SUBROUTINE gather_omp_l
@@ -584,5 +540,4 @@
 
   SUBROUTINE gather_omp_l1(VarIn, VarOut)
-    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
     IMPLICIT NONE
   
@@ -590,11 +545,6 @@
     LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
     
-    LOGICAL :: dummy
-
-    IF (is_omp_root) THEN
-      CALL gather_omp_lgen(VarIn,Varout,Size(VarIn,2),omp_buffer)
-    ELSE
-      CALL gather_omp_lgen(VarIn,dummy,Size(VarIn,2),omp_buffer)
-    ENDIF
+    CALL Check_buffer_l(size(VarOut))   
+    CALL gather_omp_lgen(VarIn,Varout,Size(VarIn,2),buffer_l)
     
   END SUBROUTINE gather_omp_l1
@@ -602,5 +552,4 @@
 
   SUBROUTINE gather_omp_l2(VarIn, VarOut)
-    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
     IMPLICIT NONE
   
@@ -608,11 +557,6 @@
     LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
     
-    LOGICAL :: dummy
-
-    IF (is_omp_root) THEN
-      CALL gather_omp_lgen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3),omp_buffer)
-    ELSE
-      CALL gather_omp_lgen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3),omp_buffer)
-    ENDIF
+    CALL Check_buffer_l(size(VarOut))   
+    CALL gather_omp_lgen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3),buffer_l)
     
   END SUBROUTINE gather_omp_l2
@@ -620,5 +564,4 @@
 
   SUBROUTINE gather_omp_l3(VarIn, VarOut)
-    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
     IMPLICIT NONE
   
@@ -626,11 +569,6 @@
     LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
     
-    LOGICAL :: dummy
-
-    IF (is_omp_root) THEN
-      CALL gather_omp_lgen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4),omp_buffer)
-    ELSE
-      CALL gather_omp_lgen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4),omp_buffer)
-    ENDIF
+    CALL Check_buffer_l(size(VarOut))   
+    CALL gather_omp_lgen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4),buffer_l)
     
   END SUBROUTINE gather_omp_l3
@@ -644,7 +582,12 @@
     INTEGER,INTENT(IN)  :: VarIn
     INTEGER,INTENT(OUT) :: VarOut
-    
-    CALL reduce_sum_omp_igen(VarIn,Varout,1,omp_buffer)
-  
+    INTEGER             :: VarIn_tmp(1)
+    INTEGER             :: VarOut_tmp(1)
+    
+    VarIn_tmp(1)=VarIn
+    CALL Check_buffer_i(1)   
+    CALL reduce_sum_omp_igen(VarIn_tmp,Varout_tmp,1,buffer_i)
+    VarOut=VarOut_tmp(1)
+    
   END SUBROUTINE reduce_sum_omp_i
 
@@ -655,5 +598,6 @@
     INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
     
-    CALL reduce_sum_omp_igen(VarIn,Varout,Size(VarIn),omp_buffer)
+    CALL Check_buffer_i(size(VarIn))   
+    CALL reduce_sum_omp_igen(VarIn,Varout,Size(VarIn),buffer_i)
    
   END SUBROUTINE reduce_sum_omp_i1
@@ -665,6 +609,7 @@
     INTEGER,INTENT(IN),DIMENSION(:,:)  :: VarIn
     INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
-    
-    CALL reduce_sum_omp_igen(VarIn,Varout,Size(VarIn),omp_buffer)
+
+    CALL Check_buffer_i(size(VarIn))   
+    CALL reduce_sum_omp_igen(VarIn,Varout,Size(VarIn),buffer_i)
   
   END SUBROUTINE reduce_sum_omp_i2
@@ -677,5 +622,6 @@
     INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
     
-    CALL reduce_sum_omp_igen(VarIn,Varout,Size(VarIn),omp_buffer)
+    CALL Check_buffer_i(size(VarIn))   
+    CALL reduce_sum_omp_igen(VarIn,Varout,Size(VarIn),buffer_i)
   
   END SUBROUTINE reduce_sum_omp_i3
@@ -688,5 +634,6 @@
     INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
   
-    CALL reduce_sum_omp_igen(VarIn,Varout,Size(VarIn),omp_buffer)
+    CALL Check_buffer_i(size(VarIn))   
+    CALL reduce_sum_omp_igen(VarIn,Varout,Size(VarIn),buffer_i)
   
   END SUBROUTINE reduce_sum_omp_i4
@@ -698,6 +645,11 @@
     REAL,INTENT(IN)  :: VarIn
     REAL,INTENT(OUT) :: VarOut
-    
-    CALL reduce_sum_omp_rgen(VarIn,Varout,1,omp_buffer)
+    REAL             :: VarIn_tmp(1)
+    REAL             :: VarOut_tmp(1)
+    
+    VarIn_tmp(1)=VarIn
+    CALL Check_buffer_r(1)   
+    CALL reduce_sum_omp_rgen(VarIn_tmp,Varout_tmp,1,buffer_r)
+    VarOut=VarOut_tmp(1)
   
   END SUBROUTINE reduce_sum_omp_r
@@ -709,5 +661,6 @@
     REAL,INTENT(OUT),DIMENSION(:) :: VarOut
     
-    CALL reduce_sum_omp_rgen(VarIn,Varout,Size(VarIn),omp_buffer)
+    CALL Check_buffer_r(size(VarIn))   
+    CALL reduce_sum_omp_rgen(VarIn,Varout,Size(VarIn),buffer_r)
    
   END SUBROUTINE reduce_sum_omp_r1
@@ -720,5 +673,6 @@
     REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
     
-    CALL reduce_sum_omp_rgen(VarIn,Varout,Size(VarIn),omp_buffer)
+    CALL Check_buffer_r(size(VarIn))   
+    CALL reduce_sum_omp_rgen(VarIn,Varout,Size(VarIn),buffer_r)
   
   END SUBROUTINE reduce_sum_omp_r2
@@ -731,5 +685,6 @@
     REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
     
-    CALL reduce_sum_omp_rgen(VarIn,Varout,Size(VarIn),omp_buffer)
+    CALL Check_buffer_r(size(VarIn))   
+    CALL reduce_sum_omp_rgen(VarIn,Varout,Size(VarIn),buffer_r)
   
   END SUBROUTINE reduce_sum_omp_r3
@@ -742,364 +697,360 @@
     REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
   
-    CALL reduce_sum_omp_rgen(VarIn,Varout,Size(VarIn),omp_buffer)
+    CALL Check_buffer_r(size(VarIn))   
+    CALL reduce_sum_omp_rgen(VarIn,Varout,Size(VarIn),buffer_r)
   
   END SUBROUTINE reduce_sum_omp_r4
 
-
-
-END MODULE mod_phys_lmdz_omp_transfert
-
-
-
-
-
-SUBROUTINE bcast_omp_cgen(Var,Nb,Buff)
-  IMPLICIT NONE
-    
-  CHARACTER(LEN=*),INTENT(INOUT) :: Var
-  CHARACTER(LEN=*),INTENT(INOUT) :: Buff
-  INTEGER,INTENT(IN) :: Nb
-    
-  INTEGER :: i
-  
-!$OMP MASTER
-    Buff=Var
-!$OMP END MASTER
-!$OMP BARRIER
-
-  DO i=1,Nb
-    Var=Buff
-  ENDDO
-!$OMP BARRIER      
-  
-END SUBROUTINE bcast_omp_cgen
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!    LES ROUTINES GENERIQUES    !
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  SUBROUTINE bcast_omp_cgen(Var,Nb,Buff)
+  IMPLICIT NONE
+    
+    CHARACTER(LEN=*),INTENT(INOUT) :: Var
+    CHARACTER(LEN=*),INTENT(INOUT) :: Buff
+    INTEGER,INTENT(IN) :: Nb
+    
+    INTEGER :: i
+  
+  !$OMP MASTER
+      Buff=Var
+  !$OMP END MASTER
+  !$OMP BARRIER
+
+    DO i=1,Nb
+      Var=Buff
+    ENDDO
+  !$OMP BARRIER      
+  
+  END SUBROUTINE bcast_omp_cgen
 
 
       
-SUBROUTINE bcast_omp_igen(Var,Nb,Buff)
-  IMPLICIT NONE
-    
-  INTEGER,DIMENSION(Nb),INTENT(INOUT) :: Var
-  INTEGER,DIMENSION(Nb),INTENT(INOUT) :: Buff
-  INTEGER,INTENT(IN) :: Nb
-
-  INTEGER :: i
-    
-!$OMP MASTER
-  DO i=1,Nb
-    Buff(i)=Var(i)
-  ENDDO
-!$OMP END MASTER
-!$OMP BARRIER
-
-  DO i=1,Nb
-    Var(i)=Buff(i)
-  ENDDO
-!$OMP BARRIER        
-
-END SUBROUTINE bcast_omp_igen
-
-
-SUBROUTINE bcast_omp_rgen(Var,Nb,Buff)
-  IMPLICIT NONE
-    
-  REAL,DIMENSION(Nb),INTENT(INOUT) :: Var
-  REAL,DIMENSION(Nb),INTENT(INOUT) :: Buff
-  INTEGER,INTENT(IN) :: Nb
-
-  INTEGER :: i
-    
-!$OMP MASTER
-  DO i=1,Nb
-    Buff(i)=Var(i)
-  ENDDO
-!$OMP END MASTER
-!$OMP BARRIER
-
-  DO i=1,Nb
-    Var(i)=Buff(i)
-  ENDDO
-!$OMP BARRIER        
-
-END SUBROUTINE bcast_omp_rgen
-
-SUBROUTINE bcast_omp_lgen(Var,Nb,Buff)
-  IMPLICIT NONE
-    
-  LOGICAL,DIMENSION(Nb),INTENT(INOUT) :: Var
-  LOGICAL,DIMENSION(Nb),INTENT(INOUT) :: Buff
-  INTEGER,INTENT(IN) :: Nb
-
-  INTEGER :: i
-    
-!$OMP MASTER
-  DO i=1,Nb
-    Buff(i)=Var(i)
-  ENDDO
-!$OMP END MASTER
-!$OMP BARRIER
-
-  DO i=1,Nb
-    Var(i)=Buff(i)
-  ENDDO
-!$OMP BARRIER        
-
-END SUBROUTINE bcast_omp_lgen
-
-
-
-
-
-SUBROUTINE scatter_omp_igen(VarIn,VarOut,dimsize,Buff)
+  SUBROUTINE bcast_omp_igen(Var,Nb,Buff)
+  IMPLICIT NONE
+    
+    INTEGER,DIMENSION(Nb),INTENT(INOUT) :: Var
+    INTEGER,DIMENSION(Nb),INTENT(INOUT) :: Buff
+    INTEGER,INTENT(IN) :: Nb
+
+    INTEGER :: i
+    
+  !$OMP MASTER
+    DO i=1,Nb
+      Buff(i)=Var(i)
+    ENDDO
+  !$OMP END MASTER
+  !$OMP BARRIER
+
+    DO i=1,Nb
+      Var(i)=Buff(i)
+    ENDDO
+  !$OMP BARRIER        
+
+  END SUBROUTINE bcast_omp_igen
+
+
+  SUBROUTINE bcast_omp_rgen(Var,Nb,Buff)
+  IMPLICIT NONE
+    
+    REAL,DIMENSION(Nb),INTENT(INOUT) :: Var
+    REAL,DIMENSION(Nb),INTENT(INOUT) :: Buff
+    INTEGER,INTENT(IN) :: Nb
+
+    INTEGER :: i
+    
+  !$OMP MASTER
+    DO i=1,Nb
+      Buff(i)=Var(i)
+    ENDDO
+  !$OMP END MASTER
+  !$OMP BARRIER
+
+    DO i=1,Nb
+      Var(i)=Buff(i)
+    ENDDO
+  !$OMP BARRIER        
+
+  END SUBROUTINE bcast_omp_rgen
+
+  SUBROUTINE bcast_omp_lgen(Var,Nb,Buff)
+  IMPLICIT NONE
+    
+    LOGICAL,DIMENSION(Nb),INTENT(INOUT) :: Var
+    LOGICAL,DIMENSION(Nb),INTENT(INOUT) :: Buff
+    INTEGER,INTENT(IN) :: Nb
+  
+    INTEGER :: i
+    
+  !$OMP MASTER
+    DO i=1,Nb
+      Buff(i)=Var(i)
+    ENDDO
+  !$OMP END MASTER
+  !$OMP BARRIER
+
+    DO i=1,Nb
+      Var(i)=Buff(i)
+    ENDDO
+  !$OMP BARRIER        
+
+  END SUBROUTINE bcast_omp_lgen
+
+
+  SUBROUTINE scatter_omp_igen(VarIn,VarOut,dimsize,Buff)
+    USE mod_phys_lmdz_omp_data
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi 
+    IMPLICIT NONE
+
+    INTEGER,INTENT(IN) :: dimsize
+    INTEGER,INTENT(IN),DIMENSION(klon_mpi,dimsize) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(klon_omp,dimsize) :: VarOut
+    INTEGER,INTENT(INOUT),DIMENSION(klon_mpi,dimsize) :: Buff
+
+    INTEGER :: i,ij
+    
+  !$OMP MASTER
+    DO i=1,dimsize
+      DO ij=1,klon_mpi
+        Buff(ij,i)=VarIn(ij,i)
+      ENDDO
+    ENDDO  
+  !$OMP END MASTER
+  !$OMP BARRIER
+ 
+    DO i=1,dimsize
+      DO ij=1,klon_omp
+        VarOut(ij,i)=Buff(klon_omp_begin-1+ij,i)
+      ENDDO
+    ENDDO
+  !$OMP BARRIER  
+ 
+  END SUBROUTINE scatter_omp_igen
+
+
+  SUBROUTINE scatter_omp_rgen(VarIn,VarOut,dimsize,Buff)
   USE mod_phys_lmdz_omp_data
   USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi 
   IMPLICIT NONE
 
-  INTEGER,INTENT(IN) :: dimsize
-  INTEGER,INTENT(IN),DIMENSION(klon_mpi,dimsize) :: VarIn
-  INTEGER,INTENT(OUT),DIMENSION(klon_omp,dimsize) :: VarOut
-  INTEGER,INTENT(INOUT),DIMENSION(klon_mpi,dimsize) :: Buff
-
-  INTEGER :: i,ij
-    
-!$OMP MASTER
-  DO i=1,dimsize
-    DO ij=1,klon_mpi
-      Buff(ij,i)=VarIn(ij,i)
-    ENDDO
-  ENDDO  
-!$OMP END MASTER
-!$OMP BARRIER
-
-  DO i=1,dimsize
-    DO ij=1,klon_omp
-      VarOut(ij,i)=Buff(klon_omp_begin-1+ij,i)
-    ENDDO
-  ENDDO
-!$OMP BARRIER  
-
-END SUBROUTINE scatter_omp_igen
-
-
-SUBROUTINE scatter_omp_rgen(VarIn,VarOut,dimsize,Buff)
+    INTEGER,INTENT(IN) :: dimsize
+    REAL,INTENT(IN),DIMENSION(klon_mpi,dimsize) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(klon_omp,dimsize) :: VarOut
+    REAL,INTENT(INOUT),DIMENSION(klon_mpi,dimsize) :: Buff
+
+    INTEGER :: i,ij
+    
+  !$OMP MASTER
+    DO i=1,dimsize
+      DO ij=1,klon_mpi
+        Buff(ij,i)=VarIn(ij,i)
+      ENDDO
+    ENDDO  
+  !$OMP END MASTER
+  !$OMP BARRIER
+
+    DO i=1,dimsize
+      DO ij=1,klon_omp
+        VarOut(ij,i)=Buff(klon_omp_begin-1+ij,i)
+      ENDDO
+    ENDDO
+  !$OMP BARRIER  
+
+  END SUBROUTINE scatter_omp_rgen
+
+
+  SUBROUTINE scatter_omp_lgen(VarIn,VarOut,dimsize,Buff)
   USE mod_phys_lmdz_omp_data
   USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi 
   IMPLICIT NONE
 
-  INTEGER,INTENT(IN) :: dimsize
-  REAL,INTENT(IN),DIMENSION(klon_mpi,dimsize) :: VarIn
-  REAL,INTENT(OUT),DIMENSION(klon_omp,dimsize) :: VarOut
-  REAL,INTENT(INOUT),DIMENSION(klon_mpi,dimsize) :: Buff
-
-  INTEGER :: i,ij
-    
-!$OMP MASTER
-  DO i=1,dimsize
-    DO ij=1,klon_mpi
-      Buff(ij,i)=VarIn(ij,i)
-    ENDDO
-  ENDDO  
-!$OMP END MASTER
-!$OMP BARRIER
-
-  DO i=1,dimsize
-    DO ij=1,klon_omp
-      VarOut(ij,i)=Buff(klon_omp_begin-1+ij,i)
-    ENDDO
-  ENDDO
-!$OMP BARRIER  
-
-END SUBROUTINE scatter_omp_rgen
-
-
-SUBROUTINE scatter_omp_lgen(VarIn,VarOut,dimsize,Buff)
+    INTEGER,INTENT(IN) :: dimsize
+    LOGICAL,INTENT(IN),DIMENSION(klon_mpi,dimsize) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(klon_omp,dimsize) :: VarOut
+    LOGICAL,INTENT(INOUT),DIMENSION(klon_mpi,dimsize) :: Buff
+
+    INTEGER :: i,ij
+    
+ !$OMP MASTER 
+    DO i=1,dimsize
+      DO ij=1,klon_mpi
+        Buff(ij,i)=VarIn(ij,i)
+      ENDDO
+    ENDDO  
+  !$OMP END MASTER
+  !$OMP BARRIER
+
+    DO i=1,dimsize
+      DO ij=1,klon_omp
+        VarOut(ij,i)=Buff(klon_omp_begin-1+ij,i)
+      ENDDO
+    ENDDO
+  !$OMP BARRIER  
+
+  END SUBROUTINE scatter_omp_lgen
+
+
+
+
+
+  SUBROUTINE gather_omp_igen(VarIn,VarOut,dimsize,Buff)
   USE mod_phys_lmdz_omp_data
   USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi 
   IMPLICIT NONE
 
-  INTEGER,INTENT(IN) :: dimsize
-  LOGICAL,INTENT(IN),DIMENSION(klon_mpi,dimsize) :: VarIn
-  LOGICAL,INTENT(OUT),DIMENSION(klon_omp,dimsize) :: VarOut
-  LOGICAL,INTENT(INOUT),DIMENSION(klon_mpi,dimsize) :: Buff
-
-  INTEGER :: i,ij
-    
-!$OMP MASTER
-  DO i=1,dimsize
-    DO ij=1,klon_mpi
-      Buff(ij,i)=VarIn(ij,i)
-    ENDDO
-  ENDDO  
-!$OMP END MASTER
-!$OMP BARRIER
-
-  DO i=1,dimsize
-    DO ij=1,klon_omp
-      VarOut(ij,i)=Buff(klon_omp_begin-1+ij,i)
-    ENDDO
-  ENDDO
-!$OMP BARRIER  
-
-END SUBROUTINE scatter_omp_lgen
-
-
-
-
-
-SUBROUTINE gather_omp_igen(VarIn,VarOut,dimsize,Buff)
+    INTEGER,INTENT(IN) :: dimsize
+    INTEGER,INTENT(IN),DIMENSION(klon_omp,dimsize) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(klon_mpi,dimsize) :: VarOut
+    INTEGER,INTENT(INOUT),DIMENSION(klon_mpi,dimsize) :: Buff
+
+    INTEGER :: i,ij
+    
+    DO i=1,dimsize
+      DO ij=1,klon_omp
+        Buff(klon_omp_begin-1+ij,i)=VarIn(ij,i)
+      ENDDO
+    ENDDO
+  !$OMP BARRIER  
+  
+  
+  !$OMP MASTER
+    DO i=1,dimsize
+      DO ij=1,klon_mpi
+        VarOut(ij,i)=Buff(ij,i)
+      ENDDO
+    ENDDO  
+  !$OMP END MASTER
+  !$OMP BARRIER
+
+  END SUBROUTINE gather_omp_igen
+
+
+  SUBROUTINE gather_omp_rgen(VarIn,VarOut,dimsize,Buff)
   USE mod_phys_lmdz_omp_data
   USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi 
   IMPLICIT NONE
 
-  INTEGER,INTENT(IN) :: dimsize
-  INTEGER,INTENT(IN),DIMENSION(klon_omp,dimsize) :: VarIn
-  INTEGER,INTENT(OUT),DIMENSION(klon_mpi,dimsize) :: VarOut
-  INTEGER,INTENT(INOUT),DIMENSION(klon_mpi,dimsize) :: Buff
-
-  INTEGER :: i,ij
-    
-  DO i=1,dimsize
-    DO ij=1,klon_omp
-      Buff(klon_omp_begin-1+ij,i)=VarIn(ij,i)
-    ENDDO
-  ENDDO
-!$OMP BARRIER  
-
-
-!$OMP MASTER
-  DO i=1,dimsize
-    DO ij=1,klon_mpi
-      VarOut(ij,i)=Buff(ij,i)
-    ENDDO
-  ENDDO  
-!$OMP END MASTER
-!$OMP BARRIER
-
-END SUBROUTINE gather_omp_igen
-
-
-SUBROUTINE gather_omp_rgen(VarIn,VarOut,dimsize,Buff)
+    INTEGER,INTENT(IN) :: dimsize
+    REAL,INTENT(IN),DIMENSION(klon_omp,dimsize) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(klon_mpi,dimsize) :: VarOut
+    REAL,INTENT(INOUT),DIMENSION(klon_mpi,dimsize) :: Buff
+
+    INTEGER :: i,ij
+    
+    DO i=1,dimsize
+      DO ij=1,klon_omp
+        Buff(klon_omp_begin-1+ij,i)=VarIn(ij,i)
+      ENDDO
+    ENDDO
+  !$OMP BARRIER  
+
+
+  !$OMP MASTER
+    DO i=1,dimsize
+      DO ij=1,klon_mpi
+        VarOut(ij,i)=Buff(ij,i)
+      ENDDO
+    ENDDO  
+  !$OMP END MASTER
+  !$OMP BARRIER
+
+  END SUBROUTINE gather_omp_rgen
+
+
+  SUBROUTINE gather_omp_lgen(VarIn,VarOut,dimsize,Buff)
   USE mod_phys_lmdz_omp_data
   USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi 
   IMPLICIT NONE
 
-  INTEGER,INTENT(IN) :: dimsize
-  REAL,INTENT(IN),DIMENSION(klon_omp,dimsize) :: VarIn
-  REAL,INTENT(OUT),DIMENSION(klon_mpi,dimsize) :: VarOut
-  REAL,INTENT(INOUT),DIMENSION(klon_mpi,dimsize) :: Buff
-
-  INTEGER :: i,ij
-    
-  DO i=1,dimsize
-    DO ij=1,klon_omp
-      Buff(klon_omp_begin-1+ij,i)=VarIn(ij,i)
-    ENDDO
-  ENDDO
-!$OMP BARRIER  
-
-
-!$OMP MASTER
-  DO i=1,dimsize
-    DO ij=1,klon_mpi
-      VarOut(ij,i)=Buff(ij,i)
-    ENDDO
-  ENDDO  
-!$OMP END MASTER
-!$OMP BARRIER
-
-END SUBROUTINE gather_omp_rgen
-
-
-SUBROUTINE gather_omp_lgen(VarIn,VarOut,dimsize,Buff)
-  USE mod_phys_lmdz_omp_data
-  USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi 
-  IMPLICIT NONE
-
-  INTEGER,INTENT(IN) :: dimsize
-  LOGICAL,INTENT(IN),DIMENSION(klon_omp,dimsize) :: VarIn
-  LOGICAL,INTENT(OUT),DIMENSION(klon_mpi,dimsize) :: VarOut
-  LOGICAL,INTENT(INOUT),DIMENSION(klon_mpi,dimsize) :: Buff
-
-  INTEGER :: i,ij
-    
-  DO i=1,dimsize
-    DO ij=1,klon_omp
-      Buff(klon_omp_begin-1+ij,i)=VarIn(ij,i)
-    ENDDO
-  ENDDO
-!$OMP BARRIER  
-
-
-!$OMP MASTER
-  DO i=1,dimsize
-    DO ij=1,klon_mpi
-      VarOut(ij,i)=Buff(ij,i)
-    ENDDO
-  ENDDO  
-!$OMP END MASTER
-!$OMP BARRIER
-
-END SUBROUTINE gather_omp_lgen
-
-
-SUBROUTINE reduce_sum_omp_igen(VarIn,VarOut,dimsize,Buff)
-  IMPLICIT NONE
-
-  INTEGER,INTENT(IN) :: dimsize
-  INTEGER,INTENT(IN),DIMENSION(dimsize) :: VarIn
-  INTEGER,INTENT(OUT),DIMENSION(dimsize) :: VarOut
-  INTEGER,INTENT(INOUT),DIMENSION(dimsize) :: Buff
-
-  INTEGER :: i
-
-!$OMP MASTER
-  Buff(:)=0
-!$OMP END MASTER
-!$OMP BARRIER
-
-!$OMP CRITICAL     
-  DO i=1,dimsize
-    Buff(i)=Buff(i)+VarIn(i)
-  ENDDO
-!$OMP END CRITICAL
-!$OMP BARRIER  
-
-!$OMP MASTER
-  DO i=1,dimsize
-    VarOut(i)=Buff(i)
-  ENDDO
-!$OMP END MASTER
-!$OMP BARRIER
-
-END SUBROUTINE reduce_sum_omp_igen
-
-SUBROUTINE reduce_sum_omp_rgen(VarIn,VarOut,dimsize,Buff)
-  IMPLICIT NONE
-
-  INTEGER,INTENT(IN) :: dimsize
-  REAL,INTENT(IN),DIMENSION(dimsize) :: VarIn
-  REAL,INTENT(OUT),DIMENSION(dimsize) :: VarOut
-  REAL,INTENT(INOUT),DIMENSION(dimsize) :: Buff
-
-  INTEGER :: i
-
-!$OMP MASTER
-  Buff(:)=0
-!$OMP END MASTER
-!$OMP BARRIER
-
-!$OMP CRITICAL     
-  DO i=1,dimsize
-    Buff(i)=Buff(i)+VarIn(i)
-  ENDDO
-!$OMP END CRITICAL
-!$OMP BARRIER  
-
-!$OMP MASTER
-  DO i=1,dimsize
-    VarOut(i)=Buff(i)
-  ENDDO
-!$OMP END MASTER
-!$OMP BARRIER
-
-END SUBROUTINE reduce_sum_omp_rgen
+    INTEGER,INTENT(IN) :: dimsize
+    LOGICAL,INTENT(IN),DIMENSION(klon_omp,dimsize) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(klon_mpi,dimsize) :: VarOut
+    LOGICAL,INTENT(INOUT),DIMENSION(klon_mpi,dimsize) :: Buff
+
+    INTEGER :: i,ij
+    
+    DO i=1,dimsize
+      DO ij=1,klon_omp
+        Buff(klon_omp_begin-1+ij,i)=VarIn(ij,i)
+      ENDDO
+    ENDDO
+  !$OMP BARRIER  
+
+
+  !$OMP MASTER
+    DO i=1,dimsize
+      DO ij=1,klon_mpi
+        VarOut(ij,i)=Buff(ij,i)
+      ENDDO
+    ENDDO  
+  !$OMP END MASTER
+  !$OMP BARRIER
+
+  END SUBROUTINE gather_omp_lgen
+
+
+  SUBROUTINE reduce_sum_omp_igen(VarIn,VarOut,dimsize,Buff)
+  IMPLICIT NONE
+
+    INTEGER,INTENT(IN) :: dimsize
+    INTEGER,INTENT(IN),DIMENSION(dimsize) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(dimsize) :: VarOut
+    INTEGER,INTENT(INOUT),DIMENSION(dimsize) :: Buff
+
+    INTEGER :: i
+
+  !$OMP MASTER
+    Buff(:)=0
+  !$OMP END MASTER
+  !$OMP BARRIER
+  
+  !$OMP CRITICAL     
+    DO i=1,dimsize
+      Buff(i)=Buff(i)+VarIn(i)
+    ENDDO
+  !$OMP END CRITICAL
+  !$OMP BARRIER  
+  
+  !$OMP MASTER
+    DO i=1,dimsize
+      VarOut(i)=Buff(i)
+    ENDDO
+  !$OMP END MASTER
+  !$OMP BARRIER
+  
+  END SUBROUTINE reduce_sum_omp_igen
+
+  SUBROUTINE reduce_sum_omp_rgen(VarIn,VarOut,dimsize,Buff)
+  IMPLICIT NONE
+
+    INTEGER,INTENT(IN) :: dimsize
+    REAL,INTENT(IN),DIMENSION(dimsize) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(dimsize) :: VarOut
+    REAL,INTENT(INOUT),DIMENSION(dimsize) :: Buff
+
+    INTEGER :: i
+
+  !$OMP MASTER
+    Buff(:)=0
+  !$OMP END MASTER
+  !$OMP BARRIER
+  
+  !$OMP CRITICAL     
+    DO i=1,dimsize
+      Buff(i)=Buff(i)+VarIn(i)
+    ENDDO
+  !$OMP END CRITICAL
+  !$OMP BARRIER  
+  
+  !$OMP MASTER
+    DO i=1,dimsize
+      VarOut(i)=Buff(i)
+    ENDDO
+  !$OMP END MASTER
+  !$OMP BARRIER
+  
+  END SUBROUTINE reduce_sum_omp_rgen
+
+END MODULE mod_phys_lmdz_omp_transfert
Index: /LMDZ4/trunk/libf/phylmd/mod_phys_lmdz_para.F90
===================================================================
--- /LMDZ4/trunk/libf/phylmd/mod_phys_lmdz_para.F90	(revision 1000)
+++ /LMDZ4/trunk/libf/phylmd/mod_phys_lmdz_para.F90	(revision 1001)
@@ -28,5 +28,5 @@
     CALL Test_transfert
 !$OMP END PARALLEL    
-     IF (is_ok_mpi .OR. is_ok_omp) THEN
+     IF (is_using_mpi .OR. is_using_omp) THEN
        is_sequential=.FALSE.
        is_parallel=.TRUE.
Index: /LMDZ4/trunk/libf/phylmd/oasis.F90
===================================================================
--- /LMDZ4/trunk/libf/phylmd/oasis.F90	(revision 1000)
+++ /LMDZ4/trunk/libf/phylmd/oasis.F90	(revision 1001)
@@ -44,4 +44,5 @@
   !$OMP THREADPRIVATE(out_var_id)
 
+  CHARACTER(LEN=*),PARAMETER :: OPA_version='OPA9'
 
 #ifdef CPP_COUPLE
Index: /LMDZ4/trunk/libf/phylmd/orografi_strato.F
===================================================================
--- /LMDZ4/trunk/libf/phylmd/orografi_strato.F	(revision 1001)
+++ /LMDZ4/trunk/libf/phylmd/orografi_strato.F	(revision 1001)
@@ -0,0 +1,2052 @@
+      SUBROUTINE drag_noro_strato (nlon,nlev,dtime,paprs,pplay,
+     e                   pmea,pstd, psig, pgam, pthe,ppic,pval,
+     e                   kgwd,kdx,ktest,
+     e                   t, u, v,
+     s                   pulow, pvlow, pustr, pvstr,
+     s                   d_t, d_u, d_v)
+c
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): F.Lott (LMD/CNRS) date: 19950201
+c Object: Mountain drag interface. Made necessary because:
+C 1. in the LMD-GCM Layers are from bottom to top,
+C    contrary to most European GCM.
+c 2. the altitude above ground of each model layers
+c    needs to be known (variable zgeom)
+c======================================================================
+c Explicit Arguments:
+c ==================
+c nlon----input-I-Total number of horizontal points that get into physics
+c nlev----input-I-Number of vertical levels
+c dtime---input-R-Time-step (s)
+c paprs---input-R-Pressure in semi layers    (Pa)
+c pplay---input-R-Pressure model-layers      (Pa)
+c t-------input-R-temperature (K)
+c u-------input-R-Horizontal wind (m/s)
+c v-------input-R-Meridional wind (m/s)
+c pmea----input-R-Mean Orography (m)
+C pstd----input-R-SSO standard deviation (m)
+c psig----input-R-SSO slope
+c pgam----input-R-SSO Anisotropy
+c pthe----input-R-SSO Angle
+c ppic----input-R-SSO Peacks elevation (m)
+c pval----input-R-SSO Valleys elevation (m)
+c
+c kgwd- -input-I: Total nb of points where the orography schemes are active
+c ktest--input-I: Flags to indicate active points
+c kdx----input-I: Locate the physical location of an active point.
+
+c pulow, pvlow -output-R: Low-level wind
+c pustr, pvstr -output-R: Surface stress due to SSO drag      (Pa)
+c
+c d_t-----output-R: T increment            
+c d_u-----output-R: U increment              
+c d_v-----output-R: V increment              
+c
+c Implicit Arguments:
+c ===================
+c
+c iim--common-I: Number of longitude intervals
+c jjm--common-I: Number of latitude intervals
+c klon-common-I: Number of points seen by the physics
+c                (iim+1)*(jjm+1) for instance
+c klev-common-I: Number of vertical layers
+c======================================================================
+c Local Variables:
+c ================
+c
+c zgeom-----R: Altitude of layer above ground
+c pt, pu, pv --R: t u v from top to bottom
+c pdtdt, pdudt, pdvdt --R: t u v tendencies (from top to bottom) 
+c papmf: pressure at model layer (from top to bottom)
+c papmh: pressure at model 1/2 layer (from top to bottom)
+c 
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+c
+c  ARGUMENTS
+c
+      INTEGER nlon,nlev
+      REAL dtime
+      REAL paprs(nlon,nlev+1)
+      REAL pplay(nlon,nlev)
+      REAL pmea(nlon),pstd(nlon),psig(nlon),pgam(nlon),pthe(nlon)
+      REAL ppic(nlon),pval(nlon)
+      REAL pulow(nlon),pvlow(nlon),pustr(nlon),pvstr(nlon)
+      REAL t(nlon,nlev), u(nlon,nlev), v(nlon,nlev)
+      REAL d_t(nlon,nlev), d_u(nlon,nlev), d_v(nlon,nlev)
+c
+      INTEGER i, k, kgwd,  kdx(nlon), ktest(nlon)
+c
+c LOCAL VARIABLES:
+c
+      REAL zgeom(klon,klev)
+      REAL pdtdt(klon,klev), pdudt(klon,klev), pdvdt(klon,klev)
+      REAL pt(klon,klev), pu(klon,klev), pv(klon,klev)
+      REAL papmf(klon,klev),papmh(klon,klev+1)
+c
+c INITIALIZE OUTPUT VARIABLES 
+c
+      DO i = 1,klon
+         pulow(i) = 0.0
+         pvlow(i) = 0.0
+         pustr(i) = 0.0
+         pvstr(i) = 0.0
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_u(i,k) = 0.0
+         d_v(i,k) = 0.0
+         pdudt(i,k)=0.0
+         pdvdt(i,k)=0.0
+         pdtdt(i,k)=0.0
+      ENDDO
+      ENDDO
+c
+c PREPARE INPUT VARIABLES FOR ORODRAG (i.e., ORDERED FROM TOP TO BOTTOM)
+C CALCULATE LAYERS HEIGHT ABOVE GROUND)
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         pt(i,k) = t(i,klev-k+1) 
+         pu(i,k) = u(i,klev-k+1)
+         pv(i,k) = v(i,klev-k+1)
+         papmf(i,k) = pplay(i,klev-k+1)
+      ENDDO
+      ENDDO
+      DO k = 1, klev+1
+      DO i = 1, klon
+         papmh(i,k) = paprs(i,klev-k+2)
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         zgeom(i,klev) = RD * pt(i,klev)
+     .                  * LOG(papmh(i,klev+1)/papmf(i,klev))
+      ENDDO
+      DO k = klev-1, 1, -1
+      DO i = 1, klon
+         zgeom(i,k) = zgeom(i,k+1) + RD * (pt(i,k)+pt(i,k+1))/2.0
+     .               * LOG(papmf(i,k+1)/papmf(i,k))
+      ENDDO
+      ENDDO
+c
+c CALL SSO DRAG ROUTINES        
+c
+      CALL orodrag_strato(klon,klev,kgwd,kdx,ktest,
+     .            dtime,
+     .            papmh, papmf, zgeom,
+     .            pt, pu, pv,
+     .            pmea, pstd, psig, pgam, pthe, ppic,pval,
+     .            pulow,pvlow,
+     .            pdudt,pdvdt,pdtdt)
+C
+C COMPUTE INCREMENTS AND STRESS FROM TENDENCIES
+
+      DO k = 1, klev
+      DO i = 1, klon
+         d_u(i,klev+1-k) = dtime*pdudt(i,k)
+         d_v(i,klev+1-k) = dtime*pdvdt(i,k)
+         d_t(i,klev+1-k) = dtime*pdtdt(i,k)
+         pustr(i)        = pustr(i)
+     .                    +pdudt(i,k)*(papmh(i,k+1)-papmh(i,k))/rg
+         pvstr(i)        = pvstr(i)
+     .                    +pdvdt(i,k)*(papmh(i,k+1)-papmh(i,k))/rg
+      ENDDO
+      ENDDO
+c
+      RETURN
+      END
+
+      SUBROUTINE orodrag_strato( nlon,nlev 
+     i                 , kgwd,  kdx, ktest
+     r                 , ptsphy
+     r                 , paphm1,papm1,pgeom1,ptm1,pum1,pvm1
+     r                 , pmea, pstd, psig, pgam, pthe, ppic, pval
+c outputs
+     r                 , pulow,pvlow
+     r                 , pvom,pvol,pte )
+      
+      USE dimphy
+      IMPLICIT NONE
+c
+c
+c**** *orodrag* - does the SSO drag  parametrization.
+c
+c     purpose.
+c     --------
+c
+c     this routine computes the physical tendencies of the
+c     prognostic variables u,v  and t due to  vertical transports by
+c     subgridscale orographically excited gravity waves, and to
+c     low level blocked flow drag.
+c
+c**   interface.
+c     ----------
+c          called from *drag_noro*.
+c
+c          the routine takes its input from the long-term storage:
+c          u,v,t and p at t-1.
+c
+c        explicit arguments :
+c        --------------------
+c     ==== inputs ===
+c nlon----input-I-Total number of horizontal points that get into physics
+c nlev----input-I-Number of vertical levels
+c
+c kgwd- -input-I: Total nb of points where the orography schemes are active
+c ktest--input-I: Flags to indicate active points
+c kdx----input-I: Locate the physical location of an active point.
+c ptsphy--input-R-Time-step (s)
+c paphm1--input-R: pressure at model 1/2 layer
+c papm1---input-R: pressure at model layer
+c pgeom1--input-R: Altitude of layer above ground
+c ptm1, pum1, pvm1--R-: t, u and v
+c pmea----input-R-Mean Orography (m)
+C pstd----input-R-SSO standard deviation (m)
+c psig----input-R-SSO slope
+c pgam----input-R-SSO Anisotropy
+c pthe----input-R-SSO Angle
+c ppic----input-R-SSO Peacks elevation (m)
+c pval----input-R-SSO Valleys elevation (m)
+
+      integer nlon,nlev,kgwd
+      real ptsphy
+
+c     ==== outputs ===
+c pulow, pvlow -output-R: Low-level wind
+c
+c pte -----output-R: T tendency
+c pvom-----output-R: U tendency
+c pvol-----output-R: V tendency
+c
+c
+c Implicit Arguments:
+c ===================
+c
+c klon-common-I: Number of points seen by the physics
+c klev-common-I: Number of vertical layers
+c
+c     method.
+c     -------
+c
+c     externals.
+c     ----------
+      integer ismin, ismax
+      external ismin, ismax
+c
+c     reference.
+c     ----------
+c
+c     author.
+c     -------
+c     m.miller + b.ritter   e.c.m.w.f.     15/06/86.
+c
+c     f.lott + m. miller    e.c.m.w.f.     22/11/94
+c-----------------------------------------------------------------------
+c
+c
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+c-----------------------------------------------------------------------
+c
+c*       0.1   arguments
+c              ---------
+c
+c
+      real  pte(nlon,nlev),
+     *      pvol(nlon,nlev),
+     *      pvom(nlon,nlev),
+     *      pulow(nlon),
+     *      pvlow(nlon)
+      real  pum1(nlon,nlev),
+     *      pvm1(nlon,nlev),
+     *      ptm1(nlon,nlev),
+     *      pmea(nlon),pstd(nlon),psig(nlon),
+     *      pgam(nlon),pthe(nlon),ppic(nlon),pval(nlon),
+     *      pgeom1(nlon,nlev),
+     *      papm1(nlon,nlev),
+     *      paphm1(nlon,nlev+1)
+c
+      integer  kdx(nlon),ktest(nlon)
+c-----------------------------------------------------------------------
+c
+c*       0.2   local arrays
+c              ------------
+      integer  isect(klon),
+     *         icrit(klon),
+     *         ikcrith(klon),
+     *         ikenvh(klon),
+     *         iknu(klon),
+     *         iknu2(klon),
+     *         ikcrit(klon),
+     *         ikhlim(klon)
+c
+      real   ztau(klon,klev+1),
+     *       zstab(klon,klev+1),
+     *       zvph(klon,klev+1),
+     *       zrho(klon,klev+1),
+     *       zri(klon,klev+1),
+     *       zpsi(klon,klev+1),
+     *       zzdep(klon,klev)
+      real   zdudt(klon),
+     *       zdvdt(klon),
+     *       zdtdt(klon),
+     *       zdedt(klon),
+     *       zvidis(klon),
+     *       ztfr(klon),
+     *       znu(klon),
+     *       zd1(klon),
+     *       zd2(klon),
+     *       zdmod(klon)
+
+
+c local quantities:
+
+      integer jl,jk,ji
+      real ztmst,zdelp,ztemp,zforc,ztend,rover                
+      real zb,zc,zconb,zabsv,zzd1,ratio,zbet,zust,zvst,zdis
+   
+c
+c------------------------------------------------------------------
+c
+c*         1.    initialization
+c                --------------
+c
+c        print *,' in orodrag'
+ 100  continue
+c
+c     ------------------------------------------------------------------
+c
+c*         1.1   computational constants
+c                -----------------------
+c
+ 110  continue
+c
+c     ztmst=twodt
+c     if(nstep.eq.nstart) ztmst=0.5*twodt
+      ztmst=ptsphy
+c     ------------------------------------------------------------------
+c
+ 120  continue
+c
+c     ------------------------------------------------------------------
+c
+c*         1.3   check whether row contains point for printing
+c                ---------------------------------------------
+c
+ 130  continue
+c
+c     ------------------------------------------------------------------
+c
+c*         2.     precompute basic state variables.
+c*                ---------- ----- ----- ----------
+c*                define low level wind, project winds in plane of
+c*                low level wind, determine sector in which to take
+c*                the variance and set indicator for critical levels.
+c
+
+  200 continue
+c
+c
+c
+      call orosetup_strato
+     *     ( nlon, nlev , ktest 
+     *     , ikcrit, ikcrith, icrit, isect, ikhlim, ikenvh,iknu,iknu2
+     *     , paphm1, papm1 , pum1   , pvm1 , ptm1 , pgeom1, pstd
+     *     , zrho  , zri   , zstab  , ztau , zvph , zpsi, zzdep
+     *     , pulow, pvlow 
+     *     , pthe,pgam,pmea,ppic,pval,znu  ,zd1,  zd2,  zdmod )
+
+
+c
+c
+c
+c***********************************************************
+c
+c
+c*         3.      compute low level stresses using subcritical and
+c*                 supercritical forms.computes anisotropy coefficient
+c*                 as measure of orographic twodimensionality.
+c
+  300 continue
+c
+      call gwstress_strato
+     *    ( nlon  , nlev
+     *    , ikcrit, isect, ikhlim, ktest, ikcrith, icrit, ikenvh, iknu
+     *    , zrho  , zstab, zvph  , pstd,  psig, pmea, ppic, pval
+     *    , ztfr   , ztau 
+     *    , pgeom1,pgam,zd1,zd2,zdmod,znu)
+
+c
+c
+c*         4.      compute stress profile including
+c                  trapped waves, wave breaking,
+c                  linear decay in stratosphere.
+c
+  400 continue
+c
+c
+
+      call gwprofil_strato
+     *       (  nlon , nlev
+     *       , kgwd   , kdx  , ktest
+     *       , ikcrit, ikcrith, icrit  , ikenvh, iknu
+     *       ,iknu2 , paphm1, zrho   , zstab , ztfr   , zvph
+     *       , zri   , ztau 
+ 
+     *       , zdmod , znu    , psig  , pgam , pstd , ppic , pval)
+
+c
+c*         5.      Compute tendencies from waves stress profile.
+c                  Compute low level blocked flow drag. 
+c*                 --------------------------------------------
+c
+  500 continue
+
+      
+c
+c  explicit solution at all levels for the gravity wave
+c  implicit solution for the blocked levels
+
+      do 510 jl=kidia,kfdia
+      zvidis(jl)=0.0
+      zdudt(jl)=0.0
+      zdvdt(jl)=0.0
+      zdtdt(jl)=0.0
+  510 continue
+c
+
+      do 524 jk=1,klev
+c
+
+C  WAVE STRESS 
+C-------------
+c
+c
+      do 523 ji=kidia,kfdia
+
+      if(ktest(ji).eq.1) then
+
+      zdelp=paphm1(ji,jk+1)-paphm1(ji,jk)
+      ztemp=-rg*(ztau(ji,jk+1)-ztau(ji,jk))/(zvph(ji,klev+1)*zdelp)
+
+      zdudt(ji)=(pulow(ji)*zd1(ji)-pvlow(ji)*zd2(ji))*ztemp/zdmod(ji)
+      zdvdt(ji)=(pvlow(ji)*zd1(ji)+pulow(ji)*zd2(ji))*ztemp/zdmod(ji)
+c
+c Control Overshoots
+c
+
+      if(jk.ge.nstra)then
+        rover=0.10
+        if(abs(zdudt(ji)).gt.rover*abs(pum1(ji,jk))/ztmst)
+     C    zdudt(ji)=rover*abs(pum1(ji,jk))/ztmst*
+     C              zdudt(ji)/(abs(zdudt(ji))+1.E-10)
+        if(abs(zdvdt(ji)).gt.rover*abs(pvm1(ji,jk))/ztmst)
+     C    zdvdt(ji)=rover*abs(pvm1(ji,jk))/ztmst*
+     C              zdvdt(ji)/(abs(zdvdt(ji))+1.E-10)
+      endif 
+
+      rover=0.25
+      zforc=sqrt(zdudt(ji)**2+zdvdt(ji)**2)        
+      ztend=sqrt(pum1(ji,jk)**2+pvm1(ji,jk)**2)/ztmst                      
+
+      if(zforc.ge.rover*ztend)then
+        zdudt(ji)=rover*ztend/zforc*zdudt(ji)
+        zdvdt(ji)=rover*ztend/zforc*zdvdt(ji)
+      endif
+c
+c BLOCKED FLOW DRAG:
+C -----------------
+c
+      if(jk.gt.ikenvh(ji)) then
+         zb=1.0-0.18*pgam(ji)-0.04*pgam(ji)**2
+         zc=0.48*pgam(ji)+0.3*pgam(ji)**2
+         zconb=2.*ztmst*gkwake*psig(ji)/(4.*pstd(ji))
+         zabsv=sqrt(pum1(ji,jk)**2+pvm1(ji,jk)**2)/2.
+         zzd1=zb*cos(zpsi(ji,jk))**2+zc*sin(zpsi(ji,jk))**2
+         ratio=(cos(zpsi(ji,jk))**2+pgam(ji)*sin(zpsi(ji,jk))**2)/
+     *   (pgam(ji)*cos(zpsi(ji,jk))**2+sin(zpsi(ji,jk))**2)
+         zbet=max(0.,2.-1./ratio)*zconb*zzdep(ji,jk)*zzd1*zabsv
+c
+c OPPOSED TO THE WIND
+c
+         zdudt(ji)=-pum1(ji,jk)/ztmst
+         zdvdt(ji)=-pvm1(ji,jk)/ztmst
+c
+c PERPENDICULAR TO THE SSO MAIN AXIS:
+C                            
+cmod     zdudt(ji)=-(pum1(ji,jk)*cos(pthe(ji)*rpi/180.)
+cmod *              +pvm1(ji,jk)*sin(pthe(ji)*rpi/180.))
+cmod *              *cos(pthe(ji)*rpi/180.)/ztmst
+cmod     zdvdt(ji)=-(pum1(ji,jk)*cos(pthe(ji)*rpi/180.)
+cmod *              +pvm1(ji,jk)*sin(pthe(ji)*rpi/180.))
+cmod *              *sin(pthe(ji)*rpi/180.)/ztmst
+C
+         zdudt(ji)=zdudt(ji)*(zbet/(1.+zbet))
+         zdvdt(ji)=zdvdt(ji)*(zbet/(1.+zbet))
+      end if
+      pvom(ji,jk)=zdudt(ji)
+      pvol(ji,jk)=zdvdt(ji)
+      zust=pum1(ji,jk)+ztmst*zdudt(ji)
+      zvst=pvm1(ji,jk)+ztmst*zdvdt(ji)
+      zdis=0.5*(pum1(ji,jk)**2+pvm1(ji,jk)**2-zust**2-zvst**2)
+      zdedt(ji)=zdis/ztmst
+      zvidis(ji)=zvidis(ji)+zdis*zdelp
+      zdtdt(ji)=zdedt(ji)/rcpd
+c
+c  NO TENDENCIES ON TEMPERATURE .....
+c
+c  Instead of, pte(ji,jk)=zdtdt(ji), due to mechanical dissipation
+c
+      pte(ji,jk)=0.0
+
+      endif
+
+  523 continue
+  524 continue
+c
+c
+  501 continue
+
+      return
+      end
+      SUBROUTINE orosetup_strato
+     *         ( nlon   , nlev  , ktest
+     *         , kkcrit, kkcrith, kcrit, ksect , kkhlim
+     *         , kkenvh, kknu  , kknu2
+     *         , paphm1, papm1 , pum1   , pvm1 , ptm1  , pgeom1, pstd
+     *         , prho  , pri   , pstab  , ptau , pvph  ,ppsi, pzdep
+     *         , pulow , pvlow  
+     *         , ptheta, pgam, pmea, ppic, pval
+     *         , pnu  ,  pd1  ,  pd2  ,pdmod  )
+C
+c**** *gwsetup*
+c
+c     purpose.
+c     --------
+c     SET-UP THE ESSENTIAL PARAMETERS OF THE SSO DRAG SCHEME:
+C     DEPTH OF LOW WBLOCKED LAYER, LOW-LEVEL FLOW, BACKGROUND
+C     STRATIFICATION.....
+c
+c**   interface.
+c     ----------
+c          from *orodrag*
+c
+c        explicit arguments :
+c        --------------------
+c     ==== inputs ===
+c 
+c nlon----input-I-Total number of horizontal points that get into physics
+c nlev----input-I-Number of vertical levels
+c ktest--input-I: Flags to indicate active points
+c
+c ptsphy--input-R-Time-step (s)
+c paphm1--input-R: pressure at model 1/2 layer
+c papm1---input-R: pressure at model layer
+c pgeom1--input-R: Altitude of layer above ground
+c ptm1, pum1, pvm1--R-: t, u and v
+c pmea----input-R-Mean Orography (m)
+C pstd----input-R-SSO standard deviation (m)
+c psig----input-R-SSO slope
+c pgam----input-R-SSO Anisotropy
+c pthe----input-R-SSO Angle
+c ppic----input-R-SSO Peacks elevation (m)
+c pval----input-R-SSO Valleys elevation (m)
+
+c     ==== outputs ===
+c pulow, pvlow -output-R: Low-level wind
+c kkcrit----I-: Security value for top of low level flow
+c kcrit-----I-: Critical level 
+c ksect-----I-: Not used
+c kkhlim----I-: Not used
+c kkenvh----I-: Top of blocked flow layer
+c kknu------I-: Layer that sees mountain peacks
+c kknu2-----I-: Layer that sees mountain peacks above mountain mean
+c kknub-----I-: Layer that sees mountain mean above valleys
+c prho------R-: Density at 1/2 layers
+c pri-------R-: Background Richardson Number, Wind shear measured along GW stress
+c pstab-----R-: Brunt-Vaisala freq. at 1/2 layers
+c pvph------R-: Wind in  plan of GW stress, Half levels.
+c ppsi------R-: Angle between low level wind and SS0 main axis.
+c pd1-------R-| Compared the ratio of the stress
+c pd2-------R-| that is along the wind to that Normal to it.
+c               pdi define the plane of low level stress
+c               compared to the low level wind.
+c see p. 108 Lott & Miller (1997).                      
+c pdmod-----R-: Norme of pdi
+
+c     === local arrays ===
+c
+c zvpf------R-: Wind projected in the plan of the low-level stress.
+
+c     ==== outputs ===
+c
+c        implicit arguments :   none
+c        --------------------
+c
+c     method.
+c     -------
+c
+c
+c     externals.
+c     ----------
+c
+c
+c     reference.
+c     ----------
+c
+c        see ecmwf research department documentation of the "i.f.s."
+c
+c     author.
+c     -------
+c
+c     modifications.
+c     --------------
+c     f.lott  for the new-gwdrag scheme november 1993
+c
+c-----------------------------------------------------------------------
+      USE dimphy
+      implicit none
+c
+
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+
+c-----------------------------------------------------------------------
+c
+c*       0.1   arguments
+c              ---------
+c
+      integer nlon,nlev
+      integer kkcrit(nlon),kkcrith(nlon),kcrit(nlon),ksect(nlon),
+     *        kkhlim(nlon),ktest(nlon),kkenvh(nlon)
+
+c
+      real paphm1(nlon,klev+1),papm1(nlon,klev),pum1(nlon,klev),
+     *     pvm1(nlon,klev),ptm1(nlon,klev),pgeom1(nlon,klev),
+     *     prho(nlon,klev+1),pri(nlon,klev+1),pstab(nlon,klev+1),
+     *     ptau(nlon,klev+1),pvph(nlon,klev+1),ppsi(nlon,klev+1),
+     *     pzdep(nlon,klev)
+       real pulow(nlon),pvlow(nlon),ptheta(nlon),pgam(nlon),pnu(nlon),
+     *     pd1(nlon),pd2(nlon),pdmod(nlon)
+      real pstd(nlon),pmea(nlon),ppic(nlon),pval(nlon)
+c
+c-----------------------------------------------------------------------
+c
+c*       0.2   local arrays
+c              ------------
+c
+c
+      integer ilevh ,jl,jk
+      real zcons1,zcons2,zhgeo,zu,zphi
+      real zvt1,zvt2,zdwind,zwind,zdelp
+      real zstabm,zstabp,zrhom,zrhop
+      logical lo 
+      logical ll1(klon,klev+1)
+      integer kknu(klon),kknu2(klon),kknub(klon),kknul(klon),
+     *        kentp(klon),ncount(klon)  
+c
+      real zhcrit(klon,klev),zvpf(klon,klev),
+     *     zdp(klon,klev)
+      real znorm(klon),zb(klon),zc(klon),
+     *      zulow(klon),zvlow(klon),znup(klon),znum(klon)
+c       
+c     ------------------------------------------------------------------
+c
+c*         1.    initialization
+c                --------------
+c
+c       PRINT *,' in orosetup'
+ 100  continue
+c
+c     ------------------------------------------------------------------
+c
+c*         1.1   computational constants
+c                -----------------------
+c
+ 110  continue
+c
+      ilevh =klev/3
+c
+      zcons1=1./rd
+      zcons2=rg**2/rcpd
+c
+c
+c     ------------------------------------------------------------------
+c
+c*         2.
+c                --------------
+c
+ 200  continue
+c
+c     ------------------------------------------------------------------
+c
+c*         2.1     define low level wind, project winds in plane of
+c*                 low level wind, determine sector in which to take
+c*                 the variance and set indicator for critical levels.
+c
+c
+c
+      do 2001 jl=kidia,kfdia
+      kknu(jl)    =klev
+      kknu2(jl)   =klev
+      kknub(jl)   =klev
+      kknul(jl)   =klev
+      pgam(jl) =max(pgam(jl),gtsec)
+      ll1(jl,klev+1)=.false.
+ 2001 continue
+c
+c Ajouter une initialisation (L. Li, le 23fev99):
+c
+      do jk=klev,ilevh,-1
+      do jl=kidia,kfdia
+      ll1(jl,jk)= .false.
+      ENDDO
+      ENDDO
+c
+c*      define top of low level flow
+c       ----------------------------
+      do 2002 jk=klev,ilevh,-1
+      do 2003 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      lo=(paphm1(jl,jk)/paphm1(jl,klev+1)).ge.gsigcr
+      if(lo) then
+        kkcrit(jl)=jk
+      endif
+      zhcrit(jl,jk)=ppic(jl)-pval(jl)           
+      zhgeo=pgeom1(jl,jk)/rg
+      ll1(jl,jk)=(zhgeo.gt.zhcrit(jl,jk))
+      if(ll1(jl,jk).neqv.ll1(jl,jk+1)) then
+        kknu(jl)=jk
+      endif
+      if(.not.ll1(jl,ilevh))kknu(jl)=ilevh
+      endif
+ 2003 continue
+ 2002 continue
+      do 2004 jk=klev,ilevh,-1
+      do 2005 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      zhcrit(jl,jk)=ppic(jl)-pmea(jl)
+      zhgeo=pgeom1(jl,jk)/rg
+      ll1(jl,jk)=(zhgeo.gt.zhcrit(jl,jk))
+      if(ll1(jl,jk).neqv.ll1(jl,jk+1)) then
+        kknu2(jl)=jk
+      endif
+      if(.not.ll1(jl,ilevh))kknu2(jl)=ilevh
+      endif
+ 2005 continue
+ 2004 continue
+      do 2006 jk=klev,ilevh,-1
+      do 2007 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      zhcrit(jl,jk)=amin1(ppic(jl)-pmea(jl),pmea(jl)-pval(jl))
+      zhgeo=pgeom1(jl,jk)/rg
+      ll1(jl,jk)=(zhgeo.gt.zhcrit(jl,jk))
+      if(ll1(jl,jk).neqv.ll1(jl,jk+1)) then
+        kknub(jl)=jk
+      endif
+      if(.not.ll1(jl,ilevh))kknub(jl)=ilevh
+      endif
+ 2007 continue
+ 2006 continue
+c
+      do 2010 jl=kidia,kfdia  
+      if(ktest(jl).eq.1) then
+      kknu(jl)=min(kknu(jl),nktopg)
+      kknu2(jl)=min(kknu2(jl),nktopg)
+      kknub(jl)=min(kknub(jl),nktopg)
+      kknul(jl)=klev
+      endif
+ 2010 continue      
+c
+ 210  continue
+c
+cc*     initialize various arrays
+c
+      do 2107 jl=kidia,kfdia
+      prho(jl,klev+1)  =0.0
+cym correction en attendant mieux
+      prho(jl,1)  =0.0      
+      pstab(jl,klev+1) =0.0
+      pstab(jl,1)      =0.0
+      pri(jl,klev+1)   =9999.0
+      ppsi(jl,klev+1)  =0.0
+      pri(jl,1)        =0.0
+      pvph(jl,1)       =0.0
+      pvph(jl,klev+1)  =0.0
+cym correction en attendant mieux
+cym      pvph(jl,klev)    =0.0
+      pulow(jl)        =0.0
+      pvlow(jl)        =0.0
+      zulow(jl)        =0.0
+      zvlow(jl)        =0.0
+      kkcrith(jl)      =klev
+      kkenvh(jl)       =klev
+      kentp(jl)        =klev
+      kcrit(jl)        =1
+      ncount(jl)       =0
+      ll1(jl,klev+1)   =.false.
+ 2107 continue
+c
+c*     define flow density and stratification (rho and N2)
+c      at semi layers.
+c      -------------------------------------------------------
+c
+      do 223 jk=klev,2,-1
+      do 222 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+        zdp(jl,jk)=papm1(jl,jk)-papm1(jl,jk-1)
+        prho(jl,jk)=2.*paphm1(jl,jk)*zcons1/(ptm1(jl,jk)+ptm1(jl,jk-1))
+        pstab(jl,jk)=2.*zcons2/(ptm1(jl,jk)+ptm1(jl,jk-1))*
+     *  (1.-rcpd*prho(jl,jk)*(ptm1(jl,jk)-ptm1(jl,jk-1))/zdp(jl,jk))
+        pstab(jl,jk)=max(pstab(jl,jk),gssec)
+      endif
+  222 continue
+  223 continue
+c
+c********************************************************************
+c
+c*     define Low level flow (between ground and peacks-valleys)
+c      ---------------------------------------------------------
+      do 2115 jk=klev,ilevh,-1
+      do 2116 jl=kidia,kfdia
+      if(ktest(jl).eq.1)  then
+      if(jk.ge.kknu2(jl).and.jk.le.kknul(jl)) then
+        pulow(jl)=pulow(jl)+pum1(jl,jk)*(paphm1(jl,jk+1)-paphm1(jl,jk))
+        pvlow(jl)=pvlow(jl)+pvm1(jl,jk)*(paphm1(jl,jk+1)-paphm1(jl,jk))
+        pstab(jl,klev+1)=pstab(jl,klev+1)
+     c                   +pstab(jl,jk)*(paphm1(jl,jk+1)-paphm1(jl,jk))
+        prho(jl,klev+1)=prho(jl,klev+1)
+     c                   +prho(jl,jk)*(paphm1(jl,jk+1)-paphm1(jl,jk))
+      end if
+      endif
+ 2116 continue
+ 2115 continue
+      do 2110 jl=kidia,kfdia
+      if(ktest(jl).eq.1)  then
+      pulow(jl)=pulow(jl)/(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknu2(jl)))
+      pvlow(jl)=pvlow(jl)/(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknu2(jl)))
+      znorm(jl)=max(sqrt(pulow(jl)**2+pvlow(jl)**2),gvsec)
+      pvph(jl,klev+1)=znorm(jl)
+      pstab(jl,klev+1)=pstab(jl,klev+1)
+     c                /(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknu2(jl)))
+      prho(jl,klev+1)=prho(jl,klev+1)
+     c                /(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknu2(jl)))
+      endif
+ 2110 continue
+
+c
+c*******  setup orography orientation relative to the low level
+C       wind and define parameters of the Anisotropic wave stress.
+c
+      do 2112 jl=kidia,kfdia
+      if(ktest(jl).eq.1)  then
+        lo=(pulow(jl).lt.gvsec).and.(pulow(jl).ge.-gvsec)
+        if(lo) then
+          zu=pulow(jl)+2.*gvsec
+        else
+          zu=pulow(jl)
+        endif
+        zphi=atan(pvlow(jl)/zu)
+        ppsi(jl,klev+1)=ptheta(jl)*rpi/180.-zphi
+        zb(jl)=1.-0.18*pgam(jl)-0.04*pgam(jl)**2
+        zc(jl)=0.48*pgam(jl)+0.3*pgam(jl)**2
+        pd1(jl)=zb(jl)-(zb(jl)-zc(jl))*(sin(ppsi(jl,klev+1))**2)
+        pd2(jl)=(zb(jl)-zc(jl))*sin(ppsi(jl,klev+1))
+     *                         *cos(ppsi(jl,klev+1))
+        pdmod(jl)=sqrt(pd1(jl)**2+pd2(jl)**2)
+      endif
+ 2112 continue
+c
+c  ************ projet flow in plane of lowlevel stress *************
+C  ************ Find critical levels...                 *************
+c
+      do 213 jk=1,klev
+      do 212 jl=kidia,kfdia
+      if(ktest(jl).eq.1)  then
+        zvt1       =pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk)
+        zvt2       =-pvlow(jl)*pum1(jl,jk)+pulow(jl)*pvm1(jl,jk)
+        zvpf(jl,jk)=(zvt1*pd1(jl)+zvt2*pd2(jl))/(znorm(jl)*pdmod(jl))
+      endif
+      ptau(jl,jk)  =0.0
+      pzdep(jl,jk) =0.0
+      ppsi(jl,jk)  =0.0
+      ll1(jl,jk)   =.false.
+  212 continue
+  213 continue
+      do 215 jk=2,klev
+      do 214 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+        zdp(jl,jk)=papm1(jl,jk)-papm1(jl,jk-1)
+        pvph(jl,jk)=((paphm1(jl,jk)-papm1(jl,jk-1))*zvpf(jl,jk)+
+     *            (papm1(jl,jk)-paphm1(jl,jk))*zvpf(jl,jk-1))
+     *            /zdp(jl,jk)
+        if(pvph(jl,jk).lt.gvsec) then
+          pvph(jl,jk)=gvsec
+          kcrit(jl)=jk
+        endif
+      endif
+  214 continue
+  215 continue
+c
+c*         2.3     mean flow richardson number.
+c
+  230 continue
+c
+      do 232 jk=2,klev
+      do 231 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+        zdwind=max(abs(zvpf(jl,jk)-zvpf(jl,jk-1)),gvsec)
+        pri(jl,jk)=pstab(jl,jk)*(zdp(jl,jk)
+     *          /(rg*prho(jl,jk)*zdwind))**2
+        pri(jl,jk)=max(pri(jl,jk),grcrit)
+      endif
+  231 continue
+  232 continue
+  
+c
+c
+c*      define top of 'envelope' layer
+c       ----------------------------
+
+      do 233 jl=kidia,kfdia
+      pnu (jl)=0.0
+      znum(jl)=0.0
+ 233  continue
+      
+      do 234 jk=2,klev-1
+      do 234 jl=kidia,kfdia
+      
+      if(ktest(jl).eq.1) then
+       
+      if (jk.ge.kknu2(jl)) then
+          
+            znum(jl)=pnu(jl)
+            zwind=(pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk))/
+     *            max(sqrt(pulow(jl)**2+pvlow(jl)**2),gvsec)
+            zwind=max(sqrt(zwind**2),gvsec)
+            zdelp=paphm1(jl,jk+1)-paphm1(jl,jk)
+            zstabm=sqrt(max(pstab(jl,jk  ),gssec))
+            zstabp=sqrt(max(pstab(jl,jk+1),gssec))
+            zrhom=prho(jl,jk  )
+            zrhop=prho(jl,jk+1)
+            pnu(jl) = pnu(jl) + (zdelp/rg)*
+     *            ((zstabp/zrhop+zstabm/zrhom)/2.)/zwind     
+            if((znum(jl).le.gfrcrit).and.(pnu(jl).gt.gfrcrit)
+     *                          .and.(kkenvh(jl).eq.klev))
+     *      kkenvh(jl)=jk
+     
+      endif    
+
+      endif
+      
+ 234  continue
+      
+c  calculation of a dynamical mixing height for when the waves
+C  BREAK AT LOW LEVEL: The drag will be repartited over
+C  a depths that depends on waves vertical wavelength,
+C  not just between two adjacent model layers.
+c  of gravity waves:
+
+      do 235 jl=kidia,kfdia
+      znup(jl)=0.0
+      znum(jl)=0.0
+ 235  continue
+
+      do 236 jk=klev-1,2,-1
+      do 236 jl=kidia,kfdia
+      
+      if(ktest(jl).eq.1) then
+
+            znum(jl)=znup(jl)
+            zwind=(pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk))/
+     *            max(sqrt(pulow(jl)**2+pvlow(jl)**2),gvsec)
+            zwind=max(sqrt(zwind**2),gvsec)
+            zdelp=paphm1(jl,jk+1)-paphm1(jl,jk)
+            zstabm=sqrt(max(pstab(jl,jk  ),gssec))
+            zstabp=sqrt(max(pstab(jl,jk+1),gssec))
+            zrhom=prho(jl,jk  )
+            zrhop=prho(jl,jk+1)
+            znup(jl) = znup(jl) + (zdelp/rg)*
+     *            ((zstabp/zrhop+zstabm/zrhom)/2.)/zwind     
+            if((znum(jl).le.rpi/4.).and.(znup(jl).gt.rpi/4.)
+     *                          .and.(kkcrith(jl).eq.klev))
+     *      kkcrith(jl)=jk
+     
+      endif
+      
+ 236  continue
+ 
+      do 237 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      kkcrith(jl)=max0(kkcrith(jl),ilevh*2)
+      kkcrith(jl)=max0(kkcrith(jl),kknu(jl))
+      if(kcrit(jl).ge.kkcrith(jl))kcrit(jl)=1
+      endif
+ 237  continue         
+c
+c     directional info for flow blocking ************************* 
+c
+      do 251 jk=1,klev    
+      do 252 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      lo=(pum1(jl,jk).lt.gvsec).and.(pum1(jl,jk).ge.-gvsec)
+      if(lo) then
+        zu=pum1(jl,jk)+2.*gvsec
+      else
+        zu=pum1(jl,jk)
+      endif
+       zphi=atan(pvm1(jl,jk)/zu)
+       ppsi(jl,jk)=ptheta(jl)*rpi/180.-zphi
+      endif
+ 252  continue
+ 251  continue
+
+c      forms the vertical 'leakiness' **************************
+
+      do 254  jk=ilevh,klev
+      do 253  jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      pzdep(jl,jk)=0
+      if(jk.ge.kkenvh(jl).and.kkenvh(jl).ne.klev) then
+        pzdep(jl,jk)=(pgeom1(jl,kkenvh(jl)  )-pgeom1(jl,  jk))/
+     *               (pgeom1(jl,kkenvh(jl)  )-pgeom1(jl,klev))
+      end if
+      endif
+ 253  continue
+ 254  continue
+
+      return
+      end
+      SUBROUTINE gwstress_strato
+     *         (  nlon  , nlev
+     *         , kkcrit, ksect, kkhlim, ktest, kkcrith, kcrit, kkenvh
+     *         , kknu
+     *         , prho  , pstab , pvph  , pstd, psig
+     *         , pmea , ppic , pval  , ptfr  , ptau  
+     *         , pgeom1 , pgamma , pd1  , pd2   , pdmod , pnu )
+c
+c**** *gwstress*
+c
+c     purpose.
+c     --------
+c  Compute the surface stress due to Gravity Waves, according
+c  to the Phillips (1979) theory of 3-D flow above 
+c  anisotropic elliptic ridges.
+
+C  The stress is reduced two account for cut-off flow over
+C  hill.  The flow only see that part of the ridge located
+c  above the blocked layer (see zeff).
+c
+c**   interface.
+c     ----------
+c     call *gwstress*  from *gwdrag*
+c
+c        explicit arguments :
+c        --------------------
+c     ==== inputs ===
+c     ==== outputs ===
+c
+c        implicit arguments :   none
+c        --------------------
+c
+c     method.
+c     -------
+c
+c
+c     externals.
+c     ----------
+c
+c
+c     reference.
+c     ----------
+c
+c   LOTT and MILLER (1997)  &  LOTT (1999)
+c
+c     author.
+c     -------
+c
+c     modifications.
+c     --------------
+c     f. lott put the new gwd on ifs      22/11/93
+c
+c-----------------------------------------------------------------------
+      USE dimphy
+      implicit none
+
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+
+c-----------------------------------------------------------------------
+c
+c*       0.1   arguments
+c              ---------
+c
+      integer nlon,nlev
+      integer kkcrit(nlon),kkcrith(nlon),kcrit(nlon),ksect(nlon),
+     *        kkhlim(nlon),ktest(nlon),kkenvh(nlon),kknu(nlon)
+c
+      real prho(nlon,nlev+1),pstab(nlon,nlev+1),ptau(nlon,nlev+1),
+     *     pvph(nlon,nlev+1),ptfr(nlon),
+     *     pgeom1(nlon,nlev),pstd(nlon)
+c
+      real pd1(nlon),pd2(nlon),pnu(nlon),psig(nlon),pgamma(nlon)
+      real pmea(nlon),ppic(nlon),pval(nlon)
+      real pdmod(nlon)
+c
+c-----------------------------------------------------------------------
+c
+c*       0.2   local arrays
+c              ------------
+c  zeff--real: effective height seen by the flow when there is blocking
+
+      integer jl
+      real zeff  
+c
+c-----------------------------------------------------------------------
+c
+c*       0.3   functions
+c              ---------
+c     ------------------------------------------------------------------
+c
+c*         1.    initialization
+c                --------------
+c
+c      PRINT *,' in gwstress'
+ 100  continue
+c
+c*         3.1     gravity wave stress.
+c
+  300 continue
+c
+c
+      do 301 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      
+c  effective mountain height above the blocked flow
+  
+         zeff=ppic(jl)-pval(jl)
+         if(kkenvh(jl).lt.klev)then
+         zeff=amin1(GFRCRIT*pvph(jl,klev+1)/sqrt(pstab(jl,klev+1))
+     c              ,zeff)
+         endif
+
+      
+        ptau(jl,klev+1)=gkdrag*prho(jl,klev+1)
+     *     *psig(jl)*pdmod(jl)/4./pstd(jl)
+     *     *pvph(jl,klev+1)*sqrt(pstab(jl,klev+1))
+     *     *zeff**2
+
+
+c  too small value of stress or  low level flow include critical level
+c  or low level flow:  gravity wave stress nul.
+                
+c       lo=(ptau(jl,klev+1).lt.gtsec).or.(kcrit(jl).ge.kknu(jl))
+c    *      .or.(pvph(jl,klev+1).lt.gvcrit)
+c       if(lo) ptau(jl,klev+1)=0.0
+      
+c      print *,jl,ptau(jl,klev+1)
+
+      else
+      
+          ptau(jl,klev+1)=0.0
+          
+      endif
+
+  301 continue
+
+c      write(21)(ptau(jl,klev+1),jl=kidia,kfdia)
+ 
+      return
+      end
+
+      subroutine gwprofil_strato
+     *         ( nlon, nlev
+     *         , kgwd ,kdx  , ktest
+     *         , kkcrit, kkcrith, kcrit ,  kkenvh, kknu,kknu2
+     *         , paphm1, prho   , pstab , ptfr , pvph , pri , ptau
+     *         , pdmod   , pnu   , psig ,pgamma, pstd, ppic,pval)
+
+C**** *gwprofil*
+C
+C     purpose.
+C     --------
+C
+C**   interface.
+C     ----------
+C          from *gwdrag*
+C
+C        explicit arguments :
+C        --------------------
+C     ==== inputs ===
+C
+C     ==== outputs ===
+C
+C        implicit arguments :   none
+C        --------------------
+C
+C     method:
+C     -------
+C     the stress profile for gravity waves is computed as follows:
+C     it decreases linearly with heights from the ground 
+C     to the low-level indicated by kkcrith,
+C     to simulates lee waves or 
+C     low-level gravity wave breaking.
+C     above it is constant, except when the waves encounter a critical
+C     level (kcrit) or when they break.
+C     The stress is also uniformly distributed above the level
+C     nstra.                                          
+C
+      USE dimphy
+      IMPLICIT NONE
+
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+
+C-----------------------------------------------------------------------
+C
+C*       0.1   ARGUMENTS
+C              ---------
+C
+      integer nlon,nlev,kgwd
+      integer kkcrit(nlon),kkcrith(nlon),kcrit(nlon)
+     *       ,kdx(nlon),ktest(nlon)
+     *       ,kkenvh(nlon),kknu(nlon),kknu2(nlon)
+C
+      real paphm1(nlon,nlev+1), pstab(nlon,nlev+1),
+     *     prho  (nlon,nlev+1), pvph (nlon,nlev+1),
+     *     pri   (nlon,nlev+1), ptfr (nlon), ptau(nlon,nlev+1)
+     
+      real pdmod (nlon) , pnu (nlon) , psig(nlon),
+     *     pgamma(nlon) , pstd(nlon) , ppic(nlon), pval(nlon)
+     
+C-----------------------------------------------------------------------
+C
+C*       0.2   local arrays
+C              ------------
+C
+      integer jl,jk
+      real zsqr,zalfa,zriw,zdel,zb,zalpha,zdz2n,zdelp,zdelpt
+
+      real zdz2 (klon,klev) , znorm(klon) , zoro(klon)
+      real ztau (klon,klev+1)
+C
+C-----------------------------------------------------------------------
+C
+C*         1.    INITIALIZATION
+C                --------------
+C
+C      print *,' entree gwprofil' 
+ 100  CONTINUE
+C
+C
+C*    COMPUTATIONAL CONSTANTS.
+C     ------------- ----------
+C
+      do 400 jl=kidia,kfdia
+      if(ktest(jl).eq.1)then
+      zoro(jl)=psig(jl)*pdmod(jl)/4./pstd(jl)
+      ztau(jl,klev+1)=ptau(jl,klev+1)
+c     print *,jl,ptau(jl,klev+1)
+      ztau(jl,kkcrith(jl))=grahilo*ptau(jl,klev+1)
+      endif
+  400 continue
+  
+C
+      do 430 jk=klev+1,1,-1
+C
+C
+C*         4.1    constant shear stress until top of the
+C                 low-level breaking/trapped layer
+  410 CONTINUE
+C
+      do 411 jl=kidia,kfdia
+      if(ktest(jl).eq.1)then
+           if(jk.gt.kkcrith(jl)) then
+           zdelp=paphm1(jl,jk)-paphm1(jl,klev+1) 
+           zdelpt=paphm1(jl,kkcrith(jl))-paphm1(jl,klev+1) 
+           ptau(jl,jk)=ztau(jl,klev+1)+zdelp/zdelpt*
+     c                 (ztau(jl,kkcrith(jl))-ztau(jl,klev+1))
+           else                    
+           ptau(jl,jk)=ztau(jl,kkcrith(jl))
+           endif
+       endif
+ 411  continue             
+C
+C*         4.15   constant shear stress until the top of the
+C                 low level flow layer.
+ 415  continue
+C        
+C
+C*         4.2    wave displacement at next level.
+C
+  420 continue
+C
+  430 continue
+
+C
+C*         4.4    wave richardson number, new wave displacement
+C*                and stress:  breaking evaluation and critical 
+C                 level
+C
+                          
+      do 440 jk=klev,1,-1
+
+      do 441 jl=kidia,kfdia
+      if(ktest(jl).eq.1)then
+      znorm(jl)=prho(jl,jk)*sqrt(pstab(jl,jk))*pvph(jl,jk)
+      zdz2(jl,jk)=ptau(jl,jk)/amax1(znorm(jl),gssec)/zoro(jl)
+      endif
+  441 continue
+
+      do 442 jl=kidia,kfdia
+      if(ktest(jl).eq.1)then
+          if(jk.lt.kkcrith(jl)) then
+          if((ptau(jl,jk+1).lt.gtsec).or.(jk.le.kcrit(jl))) then
+             ptau(jl,jk)=0.0
+          else
+               zsqr=sqrt(pri(jl,jk))
+               zalfa=sqrt(pstab(jl,jk)*zdz2(jl,jk))/pvph(jl,jk)
+               zriw=pri(jl,jk)*(1.-zalfa)/(1+zalfa*zsqr)**2
+               if(zriw.lt.grcrit) then
+C                 print *,' breaking!!!',ptau(jl,jk)
+                  zdel=4./zsqr/grcrit+1./grcrit**2+4./grcrit
+                  zb=1./grcrit+2./zsqr
+                  zalpha=0.5*(-zb+sqrt(zdel))
+                  zdz2n=(pvph(jl,jk)*zalpha)**2/pstab(jl,jk)
+                  ptau(jl,jk)=znorm(jl)*zdz2n*zoro(jl)
+               endif
+                
+               ptau(jl,jk)=amin1(ptau(jl,jk),ptau(jl,jk+1))
+                  
+          endif
+          endif
+      endif
+  442 continue
+  440 continue
+
+C  REORGANISATION OF THE STRESS PROFILE AT LOW LEVEL
+
+      do 530 jl=kidia,kfdia
+      if(ktest(jl).eq.1)then
+         ztau(jl,kkcrith(jl)-1)=ptau(jl,kkcrith(jl)-1)
+         ztau(jl,nstra)=ptau(jl,nstra)
+      endif
+ 530  continue      
+
+      do 531 jk=1,klev
+      
+      do 532 jl=kidia,kfdia
+      if(ktest(jl).eq.1)then
+                
+         if(jk.gt.kkcrith(jl)-1)then
+
+          zdelp=paphm1(jl,jk)-paphm1(jl,klev+1    )
+          zdelpt=paphm1(jl,kkcrith(jl)-1)-paphm1(jl,klev+1    )
+          ptau(jl,jk)=ztau(jl,klev+1    ) +
+     .                (ztau(jl,kkcrith(jl)-1)-ztau(jl,klev+1    ) )*
+     .                zdelp/zdelpt
+     
+        endif
+      endif
+            
+ 532  continue    
+ 
+C  REORGANISATION AT THE MODEL TOP....
+
+      do 533 jl=kidia,kfdia
+      if(ktest(jl).eq.1)then
+
+         if(jk.lt.nstra)then
+
+          zdelp =paphm1(jl,nstra)
+          zdelpt=paphm1(jl,jk)
+          ptau(jl,jk)=ztau(jl,nstra)*zdelpt/zdelp 
+c         ptau(jl,jk)=ztau(jl,nstra)                
+
+        endif
+
+      endif
+
+ 533  continue
+
+ 
+ 531  continue        
+
+
+ 123   format(i4,1x,20(f6.3,1x))
+
+
+      return
+      end
+      subroutine lift_noro_strato (nlon,nlev,dtime,paprs,pplay,      
+     i                   plat,pmea,pstd, psig, pgam, pthe, ppic,pval,
+     i                   kgwd,kdx,ktest,
+     i                   t, u, v,
+     o                   pulow, pvlow, pustr, pvstr,
+     o                   d_t, d_u, d_v)
+c
+      USE dimphy
+      implicit none
+c======================================================================
+c Auteur(s): F.Lott (LMD/CNRS) date: 19950201
+c Object: Mountain lift interface (enhanced vortex stretching).
+c         Made necessary because:
+C 1. in the LMD-GCM Layers are from bottom to top,
+C    contrary to most European GCM.
+c 2. the altitude above ground of each model layers
+c    needs to be known (variable zgeom)
+c======================================================================
+c Explicit Arguments:
+c ==================
+c nlon----input-I-Total number of horizontal points that get into physics
+c nlev----input-I-Number of vertical levels
+c dtime---input-R-Time-step (s)
+c paprs---input-R-Pressure in semi layers    (Pa)
+c pplay---input-R-Pressure model-layers      (Pa)
+c t-------input-R-temperature (K)
+c u-------input-R-Horizontal wind (m/s)
+c v-------input-R-Meridional wind (m/s)
+c pmea----input-R-Mean Orography (m)
+C pstd----input-R-SSO standard deviation (m)
+c psig----input-R-SSO slope
+c pgam----input-R-SSO Anisotropy
+c pthe----input-R-SSO Angle
+c ppic----input-R-SSO Peacks elevation (m)
+c pval----input-R-SSO Valleys elevation (m)
+c
+c kgwd- -input-I: Total nb of points where the orography schemes are active
+c ktest--input-I: Flags to indicate active points
+c kdx----input-I: Locate the physical location of an active point.
+
+c pulow, pvlow -output-R: Low-level wind
+c pustr, pvstr -output-R: Surface stress due to SSO drag      (Pa)
+c
+c d_t-----output-R: T increment
+c d_u-----output-R: U increment
+c d_v-----output-R: V increment
+c
+c Implicit Arguments:
+c ===================
+c
+c iim--common-I: Number of longitude intervals
+c jjm--common-I: Number of latitude intervals
+c klon-common-I: Number of points seen by the physics
+c                (iim+1)*(jjm+1) for instance
+c klev-common-I: Number of vertical layers
+c======================================================================
+c Local Variables:
+c ================
+c
+c zgeom-----R: Altitude of layer above ground
+c pt, pu, pv --R: t u v from top to bottom
+c pdtdt, pdudt, pdvdt --R: t u v tendencies (from top to bottom)
+c papmf: pressure at model layer (from top to bottom)
+c papmh: pressure at model 1/2 layer (from top to bottom)
+c
+c======================================================================
+
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+c
+c ARGUMENTS
+c
+      INTEGER nlon,nlev
+      REAL dtime
+      REAL paprs(klon,klev+1)
+      REAL pplay(klon,klev)
+      REAL plat(nlon),pmea(nlon)
+      REAL pstd(nlon),psig(nlon),pgam(nlon),pthe(nlon)
+      REAL ppic(nlon),pval(nlon)
+      REAL pulow(nlon),pvlow(nlon),pustr(nlon),pvstr(nlon)
+      REAL t(nlon,nlev), u(nlon,nlev), v(nlon,nlev)
+      REAL d_t(nlon,nlev), d_u(nlon,nlev), d_v(nlon,nlev)
+c
+      INTEGER i, k, kgwd,  kdx(nlon), ktest(nlon)
+c
+c Variables locales:
+c
+      REAL zgeom(klon,klev)
+      REAL pdtdt(klon,klev), pdudt(klon,klev), pdvdt(klon,klev)
+      REAL pt(klon,klev), pu(klon,klev), pv(klon,klev)
+      REAL papmf(klon,klev),papmh(klon,klev+1)
+c
+c initialiser les variables de sortie (pour securite)
+c
+
+c     print *,'in lift_noro'
+      DO i = 1,klon
+         pulow(i) = 0.0
+         pvlow(i) = 0.0
+         pustr(i) = 0.0
+         pvstr(i) = 0.0
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_u(i,k) = 0.0
+         d_v(i,k) = 0.0
+         pdudt(i,k)=0.0
+         pdvdt(i,k)=0.0
+         pdtdt(i,k)=0.0
+      ENDDO
+      ENDDO
+c
+c preparer les variables d'entree (attention: l'ordre des niveaux 
+c verticaux augmente du haut vers le bas)
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         pt(i,k) = t(i,klev-k+1) 
+         pu(i,k) = u(i,klev-k+1)
+         pv(i,k) = v(i,klev-k+1)
+         papmf(i,k) = pplay(i,klev-k+1)
+      ENDDO
+      ENDDO
+      DO k = 1, klev+1
+      DO i = 1, klon
+         papmh(i,k) = paprs(i,klev-k+2)
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         zgeom(i,klev) = RD * pt(i,klev)
+     .                  * LOG(papmh(i,klev+1)/papmf(i,klev))
+      ENDDO
+      DO k = klev-1, 1, -1
+      DO i = 1, klon
+         zgeom(i,k) = zgeom(i,k+1) + RD * (pt(i,k)+pt(i,k+1))/2.0
+     .               * LOG(papmf(i,k+1)/papmf(i,k))
+      ENDDO
+      ENDDO
+c
+c appeler la routine principale
+c
+
+      CALL OROLIFT_strato(klon,klev,kgwd,kdx,ktest,
+     .            dtime,
+     .            papmh, papmf, zgeom,
+     .            pt, pu, pv,
+     .            plat,pmea, pstd, psig, pgam, pthe, ppic,pval,
+     .            pulow,pvlow,
+     .            pdudt,pdvdt,pdtdt)
+C
+      DO k = 1, klev
+      DO i = 1, klon
+         d_u(i,klev+1-k) = dtime*pdudt(i,k)
+         d_v(i,klev+1-k) = dtime*pdvdt(i,k)
+         d_t(i,klev+1-k) = dtime*pdtdt(i,k)
+         pustr(i)        = pustr(i)
+     .                    +pdudt(i,k)*(papmh(i,k+1)-papmh(i,k))/rg
+         pvstr(i)        = pvstr(i)
+     .                    +pdvdt(i,k)*(papmh(i,k+1)-papmh(i,k))/rg
+      ENDDO
+      ENDDO
+
+c     print *,' out lift_noro'
+c
+      RETURN
+      END
+      subroutine orolift_strato( nlon,nlev
+     I                 , kgwd, kdx, ktest
+     R                 , ptsphy
+     R                 , paphm1,papm1,pgeom1,ptm1,pum1,pvm1
+     R                 , plat
+     R                 , pmea, pstd, psig, pgam, pthe,ppic,pval
+C OUTPUTS
+     R                 , pulow,pvlow
+     R                 , pvom,pvol,pte )
+
+C
+C**** *OROLIFT: SIMULATE THE GEOSTROPHIC LIFT.
+C
+C     PURPOSE.
+C     --------
+C this routine computes the physical tendencies of the
+C prognostic variables u,v  when enhanced vortex stretching
+C is needed.
+C
+C**   INTERFACE.
+C     ----------
+C          CALLED FROM *lift_noro
+c        explicit arguments :
+c        --------------------
+c     ==== inputs ===
+c nlon----input-I-Total number of horizontal points that get into physics
+c nlev----input-I-Number of vertical levels
+c
+c kgwd- -input-I: Total nb of points where the orography schemes are active
+c ktest--input-I: Flags to indicate active points
+c kdx----input-I: Locate the physical location of an active point.
+c ptsphy--input-R-Time-step (s)
+c paphm1--input-R: pressure at model 1/2 layer
+c papm1---input-R: pressure at model layer
+c pgeom1--input-R: Altitude of layer above ground
+c ptm1, pum1, pvm1--R-: t, u and v
+c pmea----input-R-Mean Orography (m)
+C pstd----input-R-SSO standard deviation (m)
+c psig----input-R-SSO slope
+c pgam----input-R-SSO Anisotropy
+c pthe----input-R-SSO Angle
+c ppic----input-R-SSO Peacks elevation (m)
+c pval----input-R-SSO Valleys elevation (m)
+c plat----input-R-Latitude (degree)
+c
+c     ==== outputs ===
+c pulow, pvlow -output-R: Low-level wind
+c
+c pte -----output-R: T tendency
+c pvom-----output-R: U tendency
+c pvol-----output-R: V tendency
+c
+c
+c Implicit Arguments:
+c ===================
+c
+c klon-common-I: Number of points seen by the physics
+c klev-common-I: Number of vertical layers
+c
+
+C     ----------
+C
+C     AUTHOR.
+C     -------
+C     F.LOTT  LMD 22/11/95
+C
+       USE dimphy
+       implicit none
+C
+C
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+C-----------------------------------------------------------------------
+C
+C*       0.1   ARGUMENTS
+C              ---------
+C
+C
+      integer nlon,nlev,kgwd
+      real ptsphy
+      real  pte(nlon,nlev),
+     *      pvol(nlon,nlev),
+     *      pvom(nlon,nlev),
+     *      pulow(nlon),
+     *      pvlow(nlon)
+      real  pum1(nlon,nlev),
+     *      pvm1(nlon,nlev),
+     *      ptm1(nlon,nlev),
+     *      plat(nlon),pmea(nlon),
+     *      pstd(nlon),psig(nlon),pgam(nlon),
+     *      pthe(nlon),ppic(nlon),pval(nlon),
+     *      pgeom1(nlon,nlev),
+     *      papm1(nlon,nlev),
+     *      paphm1(nlon,nlev+1)
+C
+      INTEGER  KDX(NLON),KTEST(NLON)
+C-----------------------------------------------------------------------
+C
+C*       0.2   local arrays
+
+      integer jl,ilevh,jk
+      real zhgeo,zdelp,zslow,zsqua,zscav,zbet
+C              ------------
+      integer  iknub(klon),
+     *         iknul(klon)
+      logical ll1(klon,klev+1)
+C
+      real   ztau(klon,klev+1),
+     *       ztav(klon,klev+1),
+     *       zrho(klon,klev+1)
+      real   zdudt(klon),
+     *       zdvdt(klon)
+      real zhcrit(klon,klev)
+
+      logical lifthigh
+      real zcons1,ztmst
+
+C-----------------------------------------------------------------------
+C
+C*         1.1  initialisations
+C               ---------------
+
+      lifthigh=.false.
+
+      if(nlon.ne.klon.or.nlev.ne.klev)stop
+      zcons1=1./rd
+      ztmst=ptsphy
+C
+      do 1001 jl=kidia,kfdia
+      zrho(jl,klev+1)  =0.0
+      pulow(jl)        =0.0
+      pvlow(jl)        =0.0
+      iknub(JL)   =klev
+      iknul(JL)   =klev
+      ilevh=klev/3
+      ll1(jl,klev+1)=.false.
+      do 1000 jk=1,klev
+      pvom(jl,jk)=0.0
+      pvol(jl,jk)=0.0
+      pte (jl,jk)=0.0
+ 1000 continue
+ 1001 continue
+
+C
+C*         2.1     DEFINE LOW LEVEL WIND, PROJECT WINDS IN PLANE OF
+C*                 LOW LEVEL WIND, DETERMINE SECTOR IN WHICH TO TAKE
+C*                 THE VARIANCE AND SET INDICATOR FOR CRITICAL LEVELS.
+C
+C
+C
+      do 2006 jk=klev,1,-1
+      do 2007 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      zhcrit(jl,jk)=amax1(ppic(jl)-pval(jl),100.)
+      zhgeo=pgeom1(jl,jk)/rg
+      ll1(jl,jk)=(zhgeo.gt.zhcrit(jl,jk))
+      if(ll1(jl,jk).neqv.ll1(jl,jk+1)) then
+        iknub(jl)=jk
+      endif
+      endif
+ 2007 continue
+ 2006 continue
+C
+
+      do 2010 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      iknub(jl)=max(iknub(jl),klev/2)
+      iknul(jl)=max(iknul(jl),2*klev/3)
+      if(iknub(jl).gt.nktopg) iknub(jl)=nktopg
+      if(iknub(jl).eq.nktopg) iknul(jl)=klev
+      if(iknub(jl).eq.iknul(jl)) iknub(jl)=iknul(jl)-1
+      endif
+ 2010 continue
+
+      do 223 jk=klev,2,-1
+      do 222 jl=kidia,kfdia
+        zrho(jl,jk)=2.*paphm1(jl,jk)*zcons1/(ptm1(jl,jk)+ptm1(jl,jk-1))
+  222 continue
+  223 continue
+c     print *,'  dans orolift: 223'
+
+C********************************************************************
+C
+c*     define low level flow
+C      -------------------
+      do 2115 jk=klev,1,-1
+      do 2116 jl=kidia,kfdia
+      if(ktest(jl).eq.1) THEN
+      if(jk.ge.iknub(jl).and.jk.le.iknul(jl)) then
+        pulow(JL)=pulow(JL)+pum1(jl,jk)*(paphm1(jl,jk+1)-paphm1(jl,jk))
+        pvlow(JL)=pvlow(JL)+pvm1(jl,jk)*(paphm1(jl,jk+1)-paphm1(jl,jk))
+        zrho(JL,klev+1)=zrho(JL,klev+1)
+     *                 +zrho(JL,JK)*(paphm1(jl,jk+1)-paphm1(jl,jk))
+      endif
+      endif
+ 2116 continue
+ 2115 continue
+      do 2110 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      pulow(JL)=pulow(JL)/(paphm1(jl,iknul(jl)+1)-paphm1(jl,iknub(jl)))
+      pvlow(JL)=pvlow(JL)/(paphm1(jl,iknul(jl)+1)-paphm1(jl,iknub(jl)))
+      zrho(JL,klev+1)=zrho(Jl,klev+1)
+     *               /(paphm1(jl,iknul(jl)+1)-paphm1(jl,iknub(jl)))
+      endif
+ 2110 continue
+
+
+200   continue
+
+C***********************************************************
+C
+C*         3.      COMPUTE MOUNTAIN LIFT
+C
+  300 continue
+C
+      do 301 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+       ztau(jl,klev+1)= - gklift*zrho(jl,klev+1)*2.*romega*
+c    *                 (2*pstd(jl)+pmea(jl))*
+     *                 2*pstd(jl)*
+     *                 sin(rpi/180.*plat(jl))*pvlow(jl)
+       ztav(jl,klev+1)=   gklift*zrho(jl,klev+1)*2.*romega*
+c    *                 (2*pstd(jl)+pmea(jl))*
+     *                 2*pstd(jl)*
+     *                 sin(rpi/180.*plat(jl))*pulow(jl)
+      else
+       ztau(jl,klev+1)=0.0
+       ztav(jl,klev+1)=0.0
+      endif
+301   continue
+
+C
+C*         4.      COMPUTE LIFT PROFILE         
+C*                 --------------------   
+C
+
+  400 continue
+
+      do 401 jk=1,klev
+      do 401 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      ztau(jl,jk)=ztau(jl,klev+1)*paphm1(jl,jk)/paphm1(jl,klev+1)
+      ztav(jl,jk)=ztav(jl,klev+1)*paphm1(jl,jk)/paphm1(jl,klev+1)
+      else
+      ztau(jl,jk)=0.0
+      ztav(jl,jk)=0.0
+      endif
+401   continue
+C
+C
+C*         5.      COMPUTE TENDENCIES.
+C*                 -------------------
+      if(lifthigh)then
+C
+  500 continue
+C
+C  EXPLICIT SOLUTION AT ALL LEVELS
+C
+      do 524 jk=1,klev
+      do 523 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      zdelp=paphm1(jl,jk+1)-paphm1(jl,jk)
+      zdudt(jl)=-rg*(ztau(jl,jk+1)-ztau(jl,jk))/zdelp
+      zdvdt(jl)=-rg*(ztav(jl,jk+1)-ztav(jl,jk))/zdelp
+      endif  
+  523 continue
+  524 continue
+C
+C  PROJECT PERPENDICULARLY TO U NOT TO DESTROY ENERGY
+C
+      do 530 jk=1,klev
+      do 530 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+
+        zslow=sqrt(pulow(jl)**2+pvlow(jl)**2)
+        zsqua=amax1(sqrt(pum1(jl,jk)**2+pvm1(jl,jk)**2),gvsec)
+        zscav=-zdudt(jl)*pvm1(jl,jk)+zdvdt(jl)*pum1(jl,jk)
+        if(zsqua.gt.gvsec)then
+          pvom(jl,jk)=-zscav*pvm1(jl,jk)/zsqua**2
+          pvol(jl,jk)= zscav*pum1(jl,jk)/zsqua**2
+        else
+          pvom(jl,jk)=0.0
+          pvol(jl,jk)=0.0      
+        endif  
+        zsqua=sqrt(pum1(jl,jk)**2+pum1(jl,jk)**2)               
+        if(zsqua.lt.zslow)then
+          pvom(jl,jk)=zsqua/zslow*pvom(jl,jk)
+          pvol(jl,jk)=zsqua/zslow*pvol(jl,jk)
+        endif 
+
+      endif  
+530   continue
+C
+C  6.  LOW LEVEL LIFT, SEMI IMPLICIT:
+C  ----------------------------------
+
+      else
+
+        do 601 jl=kidia,kfdia
+        if(ktest(jl).eq.1) then
+          do jk=klev,iknub(jl),-1
+          zbet=gklift*2.*romega*sin(rpi/180.*plat(jl))*ztmst*
+     *        (pgeom1(jl,iknub(jl)-1)-pgeom1(jl,  jk))/
+     *        (pgeom1(jl,iknub(jl)-1)-pgeom1(jl,klev))
+          zdudt(jl)=-pum1(jl,jk)/ztmst/(1+zbet**2)
+          zdvdt(jl)=-pvm1(jl,jk)/ztmst/(1+zbet**2)
+          pvom(jl,jk)= zbet**2*zdudt(jl) - zbet   *zdvdt(jl)
+          pvol(jl,jk)= zbet   *zdudt(jl) + zbet**2*zdvdt(jl)    
+          enddo
+        endif
+ 601    continue
+
+      endif
+
+c     print *,' out orolift'
+
+      return
+      end
+      SUBROUTINE SUGWD_strato(NLON,NLEV,paprs,pplay)
+C     
+C
+C**** *SUGWD* INITIALIZE COMMON YOEGWD CONTROLLING GRAVITY WAVE DRAG
+C
+C     PURPOSE.
+C     --------
+C           INITIALIZE YOEGWD, THE COMMON THAT CONTROLS THE
+C           GRAVITY WAVE DRAG PARAMETRIZATION.
+C    VERY IMPORTANT:
+C    ______________
+C           THIS ROUTINE SET_UP THE "TUNABLE PARAMETERS" OF THE
+C           VARIOUS SSO SCHEMES
+C
+C**   INTERFACE.
+C     ----------
+C        CALL *SUGWD* FROM *SUPHEC*
+C              -----        ------
+C
+C        EXPLICIT ARGUMENTS :
+C        --------------------
+C        PAPRS,PPLAY : Pressure at semi and full model levels
+C        NLEV        : number of model levels
+c        NLON        : number of points treated in the physics
+C
+C        IMPLICIT ARGUMENTS :
+C        --------------------
+C        COMMON YOEGWD
+C-GFRCRIT-R:  Critical Non-dimensional mountain Height
+C             (HNC in (1),    LOTT 1999)
+C-GKWAKE--R:  Bluff-body drag coefficient for low level wake
+C             (Cd in (2),     LOTT 1999)
+C-GRCRIT--R:  Critical Richardson Number 
+C             (Ric, End of first column p791 of LOTT 1999) 
+C-GKDRAG--R:  Gravity wave drag coefficient
+C             (G in (3),      LOTT 1999)
+C-GKLIFT--R:  Mountain Lift coefficient
+C             (Cl in (4),     LOTT 1999)
+C-GHMAX---R:  Not used
+C-GRAHILO-R:  Set-up the trapped waves fraction
+C             (Beta , End of first column,  LOTT 1999)
+C
+C-GSIGCR--R:  Security value for blocked flow depth
+C-NKTOPG--I:  Security value for blocked flow level
+C-nstra----I:  An estimate to qualify the upper levels of
+C             the model where one wants to impose strees
+C             profiles
+C-GSSECC--R:  Security min value for low-level B-V frequency
+C-GTSEC---R:  Security min value for anisotropy and GW stress.
+C-GVSEC---R:  Security min value for ulow
+C         
+C
+C     METHOD.
+C     -------
+C        SEE DOCUMENTATION
+C
+C     EXTERNALS.
+C     ----------
+C        NONE
+C
+C     REFERENCE.
+C     ----------
+C     Lott, 1999: Alleviation of stationary biases in a GCM through...
+C                 Monthly Weather Review, 127, pp 788-801.
+C
+C     AUTHOR.
+C     -------
+C        FRANCOIS LOTT        *LMD*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 90-01-01 (MARTIN MILLER, ECMWF)
+C        LAST:  99-07-09     (FRANCOIS LOTT,LMD)
+C     ------------------------------------------------------------------
+      USE dimphy
+      USE mod_phys_lmdz_para
+      USE mod_grid_phy_lmdz
+      IMPLICIT NONE
+C
+C     -----------------------------------------------------------------
+#include "YOEGWD.h"
+C      ----------------------------------------------------------------
+C
+C  ARGUMENTS
+      integer nlon,nlev
+      REAL paprs(nlon,nlev+1)
+      REAL pplay(nlon,nlev)
+C
+      INTEGER JK
+      REAL ZPR,ZTOP,ZSIGT,ZPM1R
+      REAL :: pplay_glo(klon_glo,nlev)
+      REAL :: paprs_glo(klon_glo,nlev+1)
+
+C
+C*       1.    SET THE VALUES OF THE PARAMETERS
+C              --------------------------------
+C
+ 100  CONTINUE
+C
+      PRINT *,' DANS SUGWD NLEV=',NLEV
+      GHMAX=10000.
+C
+      ZPR=100000.
+      ZTOP=0.001 
+      ZSIGT=0.94
+cold  ZPR=80000.
+cold  ZSIGT=0.85
+C
+      CALL gather(pplay,pplay_glo)
+      CALL bcast(pplay_glo)
+      CALL gather(paprs,paprs_glo)
+      CALL bcast(paprs_glo)
+
+      DO 110 JK=1,NLEV
+      ZPM1R=pplay_glo(klon_glo/2,jk)/paprs_glo(klon_glo/2,1) 
+      IF(ZPM1R.GE.ZSIGT)THEN
+         nktopg=JK
+      ENDIF
+      ZPM1R=pplay_glo(klon_glo/2,jk)/paprs_glo(klon_glo/2,1) 
+      IF(ZPM1R.GE.ZTOP)THEN
+         nstra=JK
+      ENDIF
+  110 CONTINUE
+c
+c  inversion car dans orodrag on compte les niveaux a l'envers
+      nktopg=nlev-nktopg+1
+      nstra=nlev-nstra
+      print *,' DANS SUGWD nktopg=', nktopg
+      print *,' DANS SUGWD nstra=', nstra
+C
+      GSIGCR=0.80
+C
+      GKDRAG=0.1875
+      GRAHILO=0.1   
+      GRCRIT=1.00 
+      GFRCRIT=1.00
+      GKWAKE=0.50
+C
+      GKLIFT=0.25
+      GVCRIT =0.1
+
+      WRITE(UNIT=6,FMT='('' *** SSO essential constants ***'')')
+      WRITE(UNIT=6,FMT='('' *** SPECIFIED IN SUGWD ***'')')
+      WRITE(UNIT=6,FMT='('' Gravity wave ct '',E13.7,'' '')')GKDRAG
+      WRITE(UNIT=6,FMT='('' Trapped/total wave dag '',E13.7,'' '')')
+     S      GRAHILO
+      WRITE(UNIT=6,FMT='('' Critical Richardson   = '',E13.7,'' '')')
+     S                  GRCRIT
+      WRITE(UNIT=6,FMT='('' Critical Froude'',e13.7)') GFRCRIT
+      WRITE(UNIT=6,FMT='('' Low level Wake bluff cte'',e13.7)') GKWAKE
+      WRITE(UNIT=6,FMT='('' Low level lift  cte'',e13.7)') GKLIFT
+
+C
+C
+C      ----------------------------------------------------------------
+C
+C*       2.    SET VALUES OF SECURITY PARAMETERS
+C              ---------------------------------
+C
+ 200  CONTINUE
+C
+      GVSEC=0.10
+      GSSEC=0.0001
+C
+      GTSEC=0.00001
+C
+      RETURN
+      END
+
Index: /LMDZ4/trunk/libf/phylmd/phyetat0.F
===================================================================
--- /LMDZ4/trunk/libf/phylmd/phyetat0.F	(revision 1000)
+++ /LMDZ4/trunk/libf/phylmd/phyetat0.F	(revision 1001)
@@ -17,5 +17,6 @@
       USE surface_data,     ONLY : type_ocean
       USE phys_state_var_mod
-
+      USE iostart
+      USE write_field_phy
       IMPLICIT none
 c======================================================================
@@ -35,57 +36,16 @@
 
 c les variables globales lues dans le fichier restart
-      REAL rlat_glo(klon_glo), rlon_glo(klon_glo)
-      REAL pctsrf_glo(klon_glo, nbsrf)
-      REAL tsol_glo(klon_glo,nbsrf)
-      REAL alb1_glo(klon_glo,nbsrf)
-      REAL alb2_glo(klon_glo,nbsrf)
-      REAL rain_fall_glo(klon_glo)
-      REAL snow_fall_glo(klon_glo)
-      real solsw_glo(klon_glo)
-      real sollw_glo(klon_glo)
-      REAL radsol_glo(klon_glo)
-      REAL zmea_glo(klon_glo)
-      REAL zstd_glo(klon_glo)
-      REAL zsig_glo(klon_glo)
-      REAL zgam_glo(klon_glo)
-      REAL zthe_glo(klon_glo)
-      REAL zpic_glo(klon_glo)
-      REAL zval_glo(klon_glo)
-      REAL rugsrel_glo(klon_glo)
-      REAL t_ancien_glo(klon_glo,klev), q_ancien_glo(klon_glo,klev)
-      REAL clwcon_glo(klon_glo,klev)
-      REAL rnebcon_glo(klon_glo,klev) 
-      REAL ratqs_glo(klon_glo,klev)
-      REAL pbl_tke_glo(klon_glo,klev+1,nbsrf)
-      REAL zmax0_glo(klon_glo), f0_glo(klon)
-      REAL ema_work1_glo(klon_glo, klev), ema_work2_glo(klon_glo, klev)
-      REAL wake_deltat_glo(klon_glo,klev)
-      REAL wake_deltaq_glo(klon_glo,klev)
-      REAL wake_s_glo(klon_glo), wake_cstar_glo(klon_glo)
-      REAL wake_fip_glo(klon_glo)
-      REAL tsoil_p(klon,nsoilmx,nbsrf)
-      REAL qsurf_p(klon,nbsrf)
-      REAL qsol_p(klon)
-      REAL snow_p(klon,nbsrf)
-      REAL evap_p(klon,nbsrf)
-      real fder_p(klon)
-      REAL frugs_p(klon,nbsrf)
-      REAL agesno_p(klon,nbsrf)
-      REAL run_off_lic_0_p(klon)
-      
-      LOGICAL,SAVE ::  ancien_ok_glo
-!$OMP THREADPRIVATE(ancien_ok_glo)  
-    
-      REAL zmasq_glo(klon_glo)
-      REAL tsoil(klon_glo,nsoilmx,nbsrf)
-      REAL qsurf(klon_glo,nbsrf)
-      REAL qsol(klon_glo)
-      REAL snow(klon_glo,nbsrf)
-      REAL evap(klon_glo,nbsrf)
-      real fder(klon_glo)
-      REAL frugs(klon_glo,nbsrf)
-      REAL agesno(klon_glo,nbsrf)
-      REAL fractint(klon_glo)
-      REAL run_off_lic_0(klon_glo)
+
+      REAL tsoil(klon,nsoilmx,nbsrf)
+      REAL tslab(klon), seaice(klon)
+      REAL qsurf(klon,nbsrf)
+      REAL qsol(klon)
+      REAL snow(klon,nbsrf)
+      REAL evap(klon,nbsrf)
+      real fder(klon)
+      REAL frugs(klon,nbsrf)
+      REAL agesno(klon,nbsrf)
+      REAL run_off_lic_0(klon)
+      REAL fractint(klon)
 
       CHARACTER*6 ocean_in
@@ -105,4 +65,5 @@
       CHARACTER*7 str7
       CHARACTER*2 str2
+      LOGICAL :: found
 
 c FH1D
@@ -113,44 +74,12 @@
 c
 
-c$OMP MASTER
-      print *,'MASTER -x , omp_rank=',omp_rank
-c$OMP END MASTER
-
-c$OMP MASTER
-      IF (is_mpi_root) THEN
-        print*,'fichnom ',fichnom
-        ierr = NF_OPEN (fichnom, NF_NOWRITE,nid)
-        IF (ierr.NE.NF_NOERR) THEN
-          write(6,*)' Pb d''ouverture du fichier '//fichnom
-          write(6,*)' ierr = ', ierr
-          CALL ABORT
-        ENDIF
-      ENDIF
-c$OMP END MASTER
+     
+      CALL open_startphy(fichnom)
+      
+
 c
 c Lecture des parametres de controle:
 c
-c$OMP MASTER
-      IF (is_mpi_root) THEN
-      
-      ierr = NF_INQ_VARID (nid, "controle", nvarid)
-      IF (ierr.NE.NF_NOERR) THEN
-         PRINT*, 'phyetat0: Le champ <controle> est absent'
-         CALL abort
-      ENDIF
-#ifdef NC_DOUBLE
-      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tab_cntrl)
-#else
-      ierr = NF_GET_VAR_REAL(nid, nvarid, tab_cntrl)
-#endif
-      IF (ierr.NE.NF_NOERR) THEN
-         PRINT*, 'phyetat0: Lecture echouee pour <controle>'
-         CALL abort
-      ENDIF
-      ENDIF
-
-c$OMP END MASTER
-       
-       CALL bcast(tab_cntrl)
+      CALL get_var("controle",tab_cntrl)
        
 c
@@ -225,58 +154,19 @@
 c Lecture des latitudes (coordonnees):
 c
-      IF (is_mpi_root .AND. is_omp_root) THEN
-      
-      ierr = NF_INQ_VARID (nid, "latitude", nvarid)
-      IF (ierr.NE.NF_NOERR) THEN
-         PRINT*, 'phyetat0: Le champ <latitude> est absent'
-         CALL abort
-      ENDIF
-#ifdef NC_DOUBLE
-      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlat_glo)
-#else
-      ierr = NF_GET_VAR_REAL(nid, nvarid, rlat_glo)
-#endif
-      IF (ierr.NE.NF_NOERR) THEN
-         PRINT*, 'phyetat0: Lecture echouee pour <latitude>'
-         CALL abort
-      ENDIF
+      CALL get_field("latitude",rlat)
 
 c
 c Lecture des longitudes (coordonnees):
 c
-      ierr = NF_INQ_VARID (nid, "longitude", nvarid)
-      IF (ierr.NE.NF_NOERR) THEN
-         PRINT*, 'phyetat0: Le champ <longitude> est absent'
-         CALL abort
-      ENDIF
-#ifdef NC_DOUBLE
-      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlon_glo)
-#else
-      ierr = NF_GET_VAR_REAL(nid, nvarid, rlon_glo)
-#endif
-      IF (ierr.NE.NF_NOERR) THEN
-         PRINT*, 'phyetat0: Lecture echouee pour <latitude>'
-         CALL abort
-      ENDIF
+      CALL get_field("longitude",rlon)
+
 C
 C
 C Lecture du masque terre mer
 C
-
-      ierr = NF_INQ_VARID (nid, "masque", nvarid)
-      IF (ierr .EQ.  NF_NOERR) THEN
-#ifdef NC_DOUBLE
-          ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zmasq_glo)
-#else
-          ierr = NF_GET_VAR_REAL(nid, nvarid, zmasq_glo)
-#endif
-          IF (ierr.NE.NF_NOERR) THEN
-              PRINT*, 'phyetat0: Lecture echouee pour <masque>'
-              CALL abort
-          ENDIF
-      else
-          PRINT*, 'phyetat0: Le champ <masque> est absent'
-          PRINT*, 'fichier startphy non compatible avec phyetat0'
-C      CALL abort
+      CALL get_field("masque",zmasq,found)
+      IF (.NOT. found) THEN
+        PRINT*, 'phyetat0: Le champ <masque> est absent'
+        PRINT *, 'fichier startphy non compatible avec phyetat0'
       ENDIF
 
@@ -291,103 +181,44 @@
 C
 
-      ierr = NF_INQ_VARID (nid, "FTER", nvarid)
-      IF (ierr .EQ.  NF_NOERR) THEN
-#ifdef NC_DOUBLE
-          ierr = NF_GET_VAR_DOUBLE(nid, nvarid,        
-     .                             pctsrf_glo(1 : klon_glo,is_ter))
-#else
-          ierr = NF_GET_VAR_REAL(nid, nvarid, 
-     .                           pctsrf_glo(1 : klon_glo,is_ter))
-#endif
-          IF (ierr.NE.NF_NOERR) THEN
-              PRINT*, 'phyetat0: Lecture echouee pour <FTER>'
-              CALL abort
-          ENDIF
-      else
-          PRINT*, 'phyetat0: Le champ <FTER> est absent'
-c@$$         CALL abort
-      ENDIF
+      CALL get_field("FTER",pctsrf(:,is_ter),found)
+      IF (.NOT. found) PRINT*, 'phyetat0: Le champ <FTER> est absent'
 
 C
 C fraction de glace de terre
 C
-      ierr = NF_INQ_VARID (nid, "FLIC", nvarid)
-      IF (ierr .EQ.  NF_NOERR) THEN
-#ifdef NC_DOUBLE
-          ierr = NF_GET_VAR_DOUBLE(nid, nvarid, 
-     .                             pctsrf_glo(1 : klon_glo,is_lic))
-#else
-          ierr = NF_GET_VAR_REAL(nid, nvarid, 
-     .                           pctsrf_glo(1 : klon_glo,is_lic))
-#endif
-          IF (ierr.NE.NF_NOERR) THEN
-              PRINT*, 'phyetat0: Lecture echouee pour <FLIC>'
-              CALL abort
-          ENDIF
-      else
-          PRINT*, 'phyetat0: Le champ <FLIC> est absent'
-c@$$         CALL abort
-      ENDIF
+      CALL get_field("FLIC",pctsrf(:,is_lic),found)
+      IF (.NOT. found) PRINT*, 'phyetat0: Le champ <FLIC> est absent'
+
 C
 C fraction d'ocean
 C
-      ierr = NF_INQ_VARID (nid, "FOCE", nvarid)
-      IF (ierr .EQ.  NF_NOERR) THEN
-#ifdef NC_DOUBLE
-          ierr = NF_GET_VAR_DOUBLE(nid, nvarid, 
-     .                             pctsrf_glo(1 : klon_glo,is_oce))
-#else
-          ierr = NF_GET_VAR_REAL(nid, nvarid, 
-     .                           pctsrf_glo(1 : klon_glo,is_oce))
-#endif
-          IF (ierr.NE.NF_NOERR) THEN
-              PRINT*, 'phyetat0: Lecture echouee pour <FOCE>'
-              CALL abort
-          ENDIF
-      else
-          PRINT*, 'phyetat0: Le champ <FOCE> est absent'
-c@$$         CALL abort
-      ENDIF
+      CALL get_field("FOCE",pctsrf(:,is_oce),found)
+      IF (.NOT. found) PRINT*, 'phyetat0: Le champ <FOCE> est absent'
 
 C
 C fraction glace de mer
 C
-      ierr = NF_INQ_VARID (nid, "FSIC", nvarid)
-      IF (ierr .EQ.  NF_NOERR) THEN
-#ifdef NC_DOUBLE
-          ierr = NF_GET_VAR_DOUBLE(nid, nvarid, 
-     .                             pctsrf_glo(1 : klon_glo,is_sic))
-#else
-          ierr = NF_GET_VAR_REAL(nid, nvarid, 
-     .                           pctsrf_glo(1 : klon_glo, is_sic))
-#endif
-          IF (ierr.NE.NF_NOERR) THEN
-              PRINT*, 'phyetat0: Lecture echouee pour <FSIC>'
-              CALL abort
-          ENDIF
-      else
-          PRINT*, 'phyetat0: Le champ <FSIC> est absent'
-c@$$         CALL abort
-      ENDIF
+      CALL get_field("FSIC",pctsrf(:,is_sic),found)
+      IF (.NOT. found) PRINT*, 'phyetat0: Le champ <FSIC> est absent'
 
 C
 C  Verification de l'adequation entre le masque et les sous-surfaces
 C
-      fractint( 1 : klon_glo) = pctsrf_glo(1 : klon_glo, is_ter) 
-     $    + pctsrf_glo(1 : klon_glo, is_lic)
-      DO i = 1 , klon_glo
-        IF ( abs(fractint(i) - zmasq_glo(i) ) .GT. EPSFRA ) THEN
+      fractint( 1 : klon) = pctsrf(1 : klon, is_ter) 
+     $    + pctsrf(1 : klon, is_lic)
+      DO i = 1 , klon
+        IF ( abs(fractint(i) - zmasq(i) ) .GT. EPSFRA ) THEN
             WRITE(*,*) 'phyetat0: attention fraction terre pas ', 
-     $          'coherente ', i, zmasq_glo(i), pctsrf_glo(i, is_ter)
-     $          ,pctsrf_glo(i, is_lic)
+     $          'coherente ', i, zmasq(i), pctsrf(i, is_ter)
+     $          ,pctsrf(i, is_lic)
         ENDIF 
       END DO 
-      fractint (1 : klon_glo) =  pctsrf_glo(1 : klon_glo, is_oce) 
-     $    + pctsrf_glo(1 : klon_glo, is_sic)
-      DO i = 1 , klon_glo
-        IF ( abs( fractint(i) - (1. - zmasq_glo(i))) .GT. EPSFRA ) THEN
+      fractint (1 : klon) =  pctsrf(1 : klon, is_oce) 
+     $    + pctsrf(1 : klon, is_sic)
+      DO i = 1 , klon
+        IF ( abs( fractint(i) - (1. - zmasq(i))) .GT. EPSFRA ) THEN
             WRITE(*,*) 'phyetat0 attention fraction ocean pas ', 
-     $          'coherente ', i, zmasq_glo(i) , pctsrf_glo(i, is_oce)
-     $          ,pctsrf_glo(i, is_sic)
+     $          'coherente ', i, zmasq(i) , pctsrf(i, is_oce)
+     $          ,pctsrf(i, is_sic)
         ENDIF 
       END DO 
@@ -397,6 +228,6 @@
 c
 
-      ierr = NF_INQ_VARID (nid, "TS", nvarid)
-      IF (ierr.NE.NF_NOERR) THEN
+       CALL get_field("TS",ftsol(:,1),found)
+       IF (.NOT. found) THEN
          PRINT*, 'phyetat0: Le champ <TS> est absent'
          PRINT*, '          Mais je vais essayer de lire TS**'
@@ -407,24 +238,11 @@
            ENDIF
            WRITE(str2,'(i2.2)') nsrf
-           ierr = NF_INQ_VARID (nid, "TS"//str2, nvarid)
-           IF (ierr.NE.NF_NOERR) THEN
-              PRINT*, "phyetat0: Le champ <TS"//str2//"> est absent"
-              CALL abort
-           ENDIF
-#ifdef NC_DOUBLE
-           ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tsol_glo(1,nsrf))
-#else
-           ierr = NF_GET_VAR_REAL(nid, nvarid, tsol_glo(1,nsrf))
-#endif
-           IF (ierr.NE.NF_NOERR) THEN
-             PRINT*, "phyetat0: Lecture echouee pour <TS"//str2//">"
-             CALL abort
-           ENDIF
+           CALL get_field("TS"//str2,ftsol(:,nsrf))
 
            xmin = 1.0E+20
            xmax = -1.0E+20
-           DO i = 1, klon_glo
-              xmin = MIN(tsol_glo(i,nsrf),xmin)
-              xmax = MAX(tsol_glo(i,nsrf),xmax)
+           DO i = 1, klon
+              xmin = MIN(ftsol(i,nsrf),xmin)
+              xmax = MAX(ftsol(i,nsrf),xmax)
            ENDDO
            PRINT*,'Temperature du sol TS**:', nsrf, xmin, xmax
@@ -433,23 +251,14 @@
          PRINT*, 'phyetat0: Le champ <TS> est present'
          PRINT*, '          J ignore donc les autres temperatures TS**'
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tsol_glo(1,1))
-#else
-         ierr = NF_GET_VAR_REAL(nid, nvarid, tsol_glo(1,1))
-#endif
-         IF (ierr.NE.NF_NOERR) THEN
-            PRINT*, "phyetat0: Lecture echouee pour <TS>"
-            CALL abort
-         ENDIF
          xmin = 1.0E+20
          xmax = -1.0E+20
-         DO i = 1, klon_glo
-            xmin = MIN(tsol_glo(i,1),xmin)
-            xmax = MAX(tsol_glo(i,1),xmax)
+         DO i = 1, klon
+            xmin = MIN(ftsol(i,1),xmin)
+            xmax = MAX(ftsol(i,1),xmax)
          ENDDO
          PRINT*,'Temperature du sol <TS>', xmin, xmax
          DO nsrf = 2, nbsrf
-         DO i = 1, klon_glo
-            tsol_glo(i,nsrf) = tsol_glo(i,1)
+         DO i = 1, klon
+            ftsol(i,nsrf) = ftsol(i,1)
          ENDDO
          ENDDO
@@ -460,35 +269,27 @@
 c
       DO nsrf = 1, nbsrf
-      DO isoil=1, nsoilmx
-      IF (isoil.GT.99 .AND. nsrf.GT.99) THEN
-         PRINT*, "Trop de couches ou sous-mailles"
-         CALL abort
-      ENDIF
-      WRITE(str7,'(i2.2,"srf",i2.2)') isoil, nsrf
-      ierr = NF_INQ_VARID (nid, 'Tsoil'//str7, nvarid)
-      IF (ierr.NE.NF_NOERR) THEN
-         PRINT*, "phyetat0: Le champ <Tsoil"//str7//"> est absent"
-         PRINT*, "          Il prend donc la valeur de surface"
-         DO i=1, klon_glo
-             tsoil(i,isoil,nsrf)=tsol_glo(i,nsrf)
-         ENDDO
-      ELSE
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tsoil(1,isoil,nsrf))
-#else
-         ierr = NF_GET_VAR_REAL(nid, nvarid, tsoil(1,isoil,nsrf))
-#endif
-         IF (ierr.NE.NF_NOERR) THEN
-            PRINT*, "Lecture echouee pour <Tsoil"//str7//">"
+        DO isoil=1, nsoilmx
+          IF (isoil.GT.99 .AND. nsrf.GT.99) THEN
+            PRINT*, "Trop de couches ou sous-mailles"
             CALL abort
-         ENDIF
-      ENDIF
-      ENDDO
+          ENDIF
+          WRITE(str7,'(i2.2,"srf",i2.2)') isoil, nsrf
+          
+          CALL get_field('Tsoil'//str7,tsoil(:,isoil,nsrf),found)
+          IF (.NOT. found) THEN
+            PRINT*, "phyetat0: Le champ <Tsoil"//str7//"> est absent"
+            PRINT*, "          Il prend donc la valeur de surface"
+            DO i=1, klon
+               tsoil(i,isoil,nsrf)=ftsol(i,nsrf)
+            ENDDO
+          ENDIF
+        ENDDO
       ENDDO
 c
 c Lecture de l'humidite de l'air juste au dessus du sol:
 c
-      ierr = NF_INQ_VARID (nid, "QS", nvarid)
-      IF (ierr.NE.NF_NOERR) THEN
+
+      CALL get_field("QS",qsurf(:,1),found)
+      IF (.NOT. found) THEN
          PRINT*, 'phyetat0: Le champ <QS> est absent'
          PRINT*, '          Mais je vais essayer de lire QS**'
@@ -499,21 +300,8 @@
            ENDIF
            WRITE(str2,'(i2.2)') nsrf
-           ierr = NF_INQ_VARID (nid, "QS"//str2, nvarid)
-           IF (ierr.NE.NF_NOERR) THEN
-              PRINT*, "phyetat0: Le champ <QS"//str2//"> est absent"
-              CALL abort
-           ENDIF
-#ifdef NC_DOUBLE
-           ierr = NF_GET_VAR_DOUBLE(nid, nvarid, qsurf(1,nsrf))
-#else
-           ierr = NF_GET_VAR_REAL(nid, nvarid, qsurf(1,nsrf))
-#endif
-           IF (ierr.NE.NF_NOERR) THEN
-             PRINT*, "phyetat0: Lecture echouee pour <QS"//str2//">"
-             CALL abort
-           ENDIF
+           CALL get_field("QS"//str2,qsurf(:,nsrf))
            xmin = 1.0E+20
            xmax = -1.0E+20
-           DO i = 1, klon_glo
+           DO i = 1, klon
               xmin = MIN(qsurf(i,nsrf),xmin)
               xmax = MAX(qsurf(i,nsrf),xmax)
@@ -524,16 +312,7 @@
          PRINT*, 'phyetat0: Le champ <QS> est present'
          PRINT*, '          J ignore donc les autres humidites QS**'
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, qsurf(1,1))
-#else
-         ierr = NF_GET_VAR_REAL(nid, nvarid, qsurf(1,1))
-#endif
-         IF (ierr.NE.NF_NOERR) THEN
-            PRINT*, "phyetat0: Lecture echouee pour <QS>"
-            CALL abort
-         ENDIF
          xmin = 1.0E+20
          xmax = -1.0E+20
-         DO i = 1, klon_glo
+         DO i = 1, klon
             xmin = MIN(qsurf(i,1),xmin)
             xmax = MAX(qsurf(i,1),xmax)
@@ -541,86 +320,57 @@
          PRINT*,'Humidite pres du sol <QS>', xmin, xmax
          DO nsrf = 2, nbsrf
-         DO i = 1, klon_glo
-            qsurf(i,nsrf) = qsurf(i,1)
-         ENDDO
-         ENDDO
-      ENDIF
+           DO i = 1, klon
+             qsurf(i,nsrf) = qsurf(i,1)
+           ENDDO
+         ENDDO
+      ENDIF
+
 C
 C Eau dans le sol (pour le modele de sol "bucket")
 C
-      ierr = NF_INQ_VARID (nid, "QSOL", nvarid)
-      IF (ierr .EQ.  NF_NOERR) THEN
-#ifdef NC_DOUBLE
-          ierr = NF_GET_VAR_DOUBLE(nid, nvarid, qsol)
-#else
-          ierr = NF_GET_VAR_REAL(nid, nvarid, qsol)
-#endif
-          IF (ierr.NE.NF_NOERR) THEN
-              PRINT*, 'phyetat0: Lecture echouee pour <QSOL>'
-              CALL abort
-          ENDIF
-      else
-          PRINT*, 'phyetat0: Le champ <QSOL> est absent'
-          PRINT*, '          Valeur par defaut nulle'
+      CALL get_field("QSOL",qsol,found)
+      IF (.NOT. found) THEN
+        PRINT*, 'phyetat0: Le champ <QSOL> est absent'
+        PRINT*, '          Valeur par defaut nulle'
           qsol(:)=0.
-c@$$         CALL abort
-      ENDIF
-      xmin = 1.0E+20
-      xmax = -1.0E+20
-      DO i = 1, klon_glo
+      ENDIF
+
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
         xmin = MIN(qsol(i),xmin)
         xmax = MAX(qsol(i),xmax)
       ENDDO
       PRINT*,'Eau dans le sol (mm) <QSOL>', xmin, xmax
+
 c
 c Lecture de neige au sol:
 c
-      ierr = NF_INQ_VARID (nid, "SNOW", nvarid)
-      IF (ierr.NE.NF_NOERR) THEN
-         PRINT*, 'phyetat0: Le champ <SNOW> est absent'
-         PRINT*, '          Mais je vais essayer de lire SNOW**'
-         DO nsrf = 1, nbsrf
-           IF (nsrf.GT.99) THEN
-             PRINT*, "Trop de sous-mailles"
-             CALL abort
-           ENDIF
-           WRITE(str2,'(i2.2)') nsrf
-           ierr = NF_INQ_VARID (nid, "SNOW"//str2, nvarid)
-           IF (ierr.NE.NF_NOERR) THEN
-              PRINT*, "phyetat0: Le champ <SNOW"//str2//"> est absent"
-              CALL abort
-           ENDIF
-#ifdef NC_DOUBLE
-           ierr = NF_GET_VAR_DOUBLE(nid, nvarid, snow(1,nsrf))
-#else
-           ierr = NF_GET_VAR_REAL(nid, nvarid, snow(1,nsrf))
-#endif
-           IF (ierr.NE.NF_NOERR) THEN
-             PRINT*, "phyetat0: Lecture echouee pour <SNOW"//str2//">"
-             CALL abort
-           ENDIF
-           xmin = 1.0E+20
-           xmax = -1.0E+20
-           DO i = 1, klon_glo
-              xmin = MIN(snow(i,nsrf),xmin)
-              xmax = MAX(snow(i,nsrf),xmax)
-           ENDDO
-           PRINT*,'Neige du sol SNOW**:', nsrf, xmin, xmax
-         ENDDO
+
+      CALL get_field("SNOW",snow(:,nsrf),found)
+      IF (.NOT. found) THEN
+        PRINT*, 'phyetat0: Le champ <SNOW> est absent'
+        PRINT*, '          Mais je vais essayer de lire SNOW**'
+        DO nsrf = 1, nbsrf
+          IF (nsrf.GT.99) THEN
+            PRINT*, "Trop de sous-mailles"
+            CALL abort
+          ENDIF
+          WRITE(str2,'(i2.2)') nsrf
+          CALL get_field( "SNOW"//str2,snow(:,nsrf))
+          xmin = 1.0E+20
+          xmax = -1.0E+20
+          DO i = 1, klon
+            xmin = MIN(snow(i,nsrf),xmin)
+            xmax = MAX(snow(i,nsrf),xmax)
+          ENDDO
+          PRINT*,'Neige du sol SNOW**:', nsrf, xmin, xmax
+        ENDDO
       ELSE
          PRINT*, 'phyetat0: Le champ <SNOW> est present'
          PRINT*, '          J ignore donc les autres neiges SNOW**'
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, snow(1,1))
-#else
-         ierr = NF_GET_VAR_REAL(nid, nvarid, snow(1,1))
-#endif
-         IF (ierr.NE.NF_NOERR) THEN
-            PRINT*, "phyetat0: Lecture echouee pour <SNOW>"
-            CALL abort
-         ENDIF
          xmin = 1.0E+20
          xmax = -1.0E+20
-         DO i = 1, klon_glo
+         DO i = 1, klon
             xmin = MIN(snow(i,1),xmin)
             xmax = MAX(snow(i,1),xmax)
@@ -628,5 +378,5 @@
          PRINT*,'Neige du sol <SNOW>', xmin, xmax
          DO nsrf = 2, nbsrf
-         DO i = 1, klon_glo
+         DO i = 1, klon
             snow(i,nsrf) = snow(i,1)
          ENDDO
@@ -636,6 +386,6 @@
 c Lecture de albedo de l'interval visible au sol:
 c
-      ierr = NF_INQ_VARID (nid, "ALBE", nvarid)
-      IF (ierr.NE.NF_NOERR) THEN
+      CALL get_field("ALBE",falb1(:,1),found)
+      IF (.NOT. found) THEN
          PRINT*, 'phyetat0: Le champ <ALBE> est absent'
          PRINT*, '          Mais je vais essayer de lire ALBE**'
@@ -646,23 +396,10 @@
            ENDIF
            WRITE(str2,'(i2.2)') nsrf
-           ierr = NF_INQ_VARID (nid, "ALBE"//str2, nvarid)
-           IF (ierr.NE.NF_NOERR) THEN
-              PRINT*, "phyetat0: Le champ <ALBE"//str2//"> est absent"
-              CALL abort
-           ENDIF
-#ifdef NC_DOUBLE
-           ierr = NF_GET_VAR_DOUBLE(nid, nvarid, alb1_glo(1,nsrf))
-#else
-           ierr = NF_GET_VAR_REAL(nid, nvarid, alb1_glo(1,nsrf))
-#endif
-           IF (ierr.NE.NF_NOERR) THEN
-             PRINT*, "phyetat0: Lecture echouee pour <ALBE"//str2//">"
-             CALL abort
-           ENDIF
+           CALL get_field("ALBE"//str2,falb1(:,nsrf))
            xmin = 1.0E+20
            xmax = -1.0E+20
-           DO i = 1, klon_glo
-              xmin = MIN(alb1_glo(i,nsrf),xmin)
-              xmax = MAX(alb1_glo(i,nsrf),xmax)
+           DO i = 1, klon
+              xmin = MIN(falb1(i,nsrf),xmin)
+              xmax = MAX(falb1(i,nsrf),xmax)
            ENDDO
            PRINT*,'Albedo du sol ALBE**:', nsrf, xmin, xmax
@@ -671,24 +408,15 @@
          PRINT*, 'phyetat0: Le champ <ALBE> est present'
          PRINT*, '          J ignore donc les autres ALBE**'
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, alb1_glo(1,1))
-#else
-         ierr = NF_GET_VAR_REAL(nid, nvarid, alb1_glo(1,1))
-#endif
-         IF (ierr.NE.NF_NOERR) THEN
-            PRINT*, "phyetat0: Lecture echouee pour <ALBE>"
-            CALL abort
-         ENDIF
          xmin = 1.0E+20
          xmax = -1.0E+20
-         DO i = 1, klon_glo
-            xmin = MIN(alb1_glo(i,1),xmin)
-            xmax = MAX(alb1_glo(i,1),xmax)
+         DO i = 1, klon
+            xmin = MIN(falb1(i,1),xmin)
+            xmax = MAX(falb1(i,1),xmax)
          ENDDO
          PRINT*,'Neige du sol <ALBE>', xmin, xmax
          DO nsrf = 2, nbsrf
-         DO i = 1, klon_glo
-            alb1_glo(i,nsrf) = alb1_glo(i,1)
-         ENDDO
+           DO i = 1, klon
+            falb1(i,nsrf) = falb1(i,1)
+           ENDDO
          ENDDO
       ENDIF
@@ -697,12 +425,11 @@
 c Lecture de albedo au sol dans l'interval proche infra-rouge:
 c
-      ierr = NF_INQ_VARID (nid, "ALBLW", nvarid)
-      IF (ierr.NE.NF_NOERR) THEN
+      CALL get_field("ALBLW",falb2(:,1),found)
+      IF (.NOT. found) THEN
          PRINT*, 'phyetat0: Le champ <ALBLW> est absent'
-c        PRINT*, '          Mais je vais essayer de lire ALBLW**'
          PRINT*, '          Mais je vais prendre ALBE**'
          DO nsrf = 1, nbsrf
-           DO i = 1, klon_glo
-             alb2_glo(i,nsrf) = alb1_glo(i,nsrf)
+           DO i = 1, klon
+             falb2(i,nsrf) = falb1(i,nsrf)
            ENDDO
          ENDDO
@@ -710,24 +437,15 @@
          PRINT*, 'phyetat0: Le champ <ALBLW> est present'
          PRINT*, '          J ignore donc les autres ALBLW**'
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, alb2_glo(1,1))
-#else
-         ierr = NF_GET_VAR_REAL(nid, nvarid, alb2_glo(1,1))
-#endif
-         IF (ierr.NE.NF_NOERR) THEN
-            PRINT*, "phyetat0: Lecture echouee pour <ALBLW>"
-            CALL abort
-         ENDIF
          xmin = 1.0E+20
          xmax = -1.0E+20
-         DO i = 1, klon_glo
-            xmin = MIN(alb2_glo(i,1),xmin)
-            xmax = MAX(alb2_glo(i,1),xmax)
+         DO i = 1, klon
+            xmin = MIN(falb2(i,1),xmin)
+            xmax = MAX(falb2(i,1),xmax)
          ENDDO
          PRINT*,'Neige du sol <ALBLW>', xmin, xmax
          DO nsrf = 2, nbsrf
-         DO i = 1, klon_glo
-            alb2_glo(i,nsrf) = alb2_glo(i,1)
-         ENDDO
+           DO i = 1, klon
+             falb2(i,nsrf) = falb2(i,1)
+           ENDDO
          ENDDO
       ENDIF
@@ -735,6 +453,6 @@
 c Lecture de evaporation:  
 c
-      ierr = NF_INQ_VARID (nid, "EVAP", nvarid)
-      IF (ierr.NE.NF_NOERR) THEN
+      CALL get_field("EVAP",evap(:,1),found)
+      IF (.NOT. found) THEN
          PRINT*, 'phyetat0: Le champ <EVAP> est absent'
          PRINT*, '          Mais je vais essayer de lire EVAP**'
@@ -745,21 +463,8 @@
            ENDIF
            WRITE(str2,'(i2.2)') nsrf
-           ierr = NF_INQ_VARID (nid, "EVAP"//str2, nvarid)
-           IF (ierr.NE.NF_NOERR) THEN
-              PRINT*, "phyetat0: Le champ <EVAP"//str2//"> est absent"
-              CALL abort
-           ENDIF
-#ifdef NC_DOUBLE
-           ierr = NF_GET_VAR_DOUBLE(nid, nvarid, evap(1,nsrf))
-#else
-           ierr = NF_GET_VAR_REAL(nid, nvarid, evap(1,nsrf))
-#endif
-           IF (ierr.NE.NF_NOERR) THEN
-             PRINT*, "phyetat0: Lecture echouee pour <EVAP"//str2//">"
-             CALL abort
-           ENDIF
+           CALL get_field("EVAP"//str2, evap(:,nsrf))
            xmin = 1.0E+20
            xmax = -1.0E+20
-           DO i = 1, klon_glo
+           DO i = 1, klon
               xmin = MIN(evap(i,nsrf),xmin)
               xmax = MAX(evap(i,nsrf),xmax)
@@ -770,16 +475,7 @@
          PRINT*, 'phyetat0: Le champ <EVAP> est present'
          PRINT*, '          J ignore donc les autres EVAP**'
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, evap(1,1))
-#else
-         ierr = NF_GET_VAR_REAL(nid, nvarid, evap(1,1))
-#endif
-         IF (ierr.NE.NF_NOERR) THEN
-            PRINT*, "phyetat0: Lecture echouee pour <EVAP>"
-            CALL abort
-         ENDIF
          xmin = 1.0E+20
          xmax = -1.0E+20
-         DO i = 1, klon_glo
+         DO i = 1, klon
             xmin = MIN(evap(i,1),xmin)
             xmax = MAX(evap(i,1),xmax)
@@ -787,5 +483,5 @@
          PRINT*,'Evap du sol <EVAP>', xmin, xmax
          DO nsrf = 2, nbsrf
-         DO i = 1, klon_glo
+         DO i = 1, klon
             evap(i,nsrf) = evap(i,1)
          ENDDO
@@ -795,23 +491,10 @@
 c Lecture precipitation liquide:
 c
-      ierr = NF_INQ_VARID (nid, "rain_f", nvarid)
-      IF (ierr.NE.NF_NOERR) THEN
-         PRINT*, 'phyetat0: Le champ <rain_f> est absent'
-         CALL abort
-      ENDIF
-#ifdef NC_DOUBLE
-      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rain_fall_glo)
-#else
-      ierr = NF_GET_VAR_REAL(nid, nvarid, rain_fall_glo)
-#endif
-      IF (ierr.NE.NF_NOERR) THEN
-         PRINT*, 'phyetat0: Lecture echouee pour <rain_f>'
-         CALL abort
-      ENDIF
-      xmin = 1.0E+20
-      xmax = -1.0E+20
-      DO i = 1, klon_glo
-         xmin = MIN(rain_fall_glo(i),xmin)
-         xmax = MAX(rain_fall_glo(i),xmax)
+      CALL get_field("rain_f",rain_fall)
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+         xmin = MIN(rain_fall(i),xmin)
+         xmax = MAX(rain_fall(i),xmax)
       ENDDO
       PRINT*,'Precipitation liquide rain_f:', xmin, xmax
@@ -819,23 +502,10 @@
 c Lecture precipitation solide:
 c
-      ierr = NF_INQ_VARID (nid, "snow_f", nvarid)
-      IF (ierr.NE.NF_NOERR) THEN
-         PRINT*, 'phyetat0: Le champ <snow_f> est absent'
-         CALL abort
-      ENDIF
-#ifdef NC_DOUBLE
-      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, snow_fall_glo)
-#else
-      ierr = NF_GET_VAR_REAL(nid, nvarid, snow_fall_glo)
-#endif
-      IF (ierr.NE.NF_NOERR) THEN
-         PRINT*, 'phyetat0: Lecture echouee pour <snow_f>'
-         CALL abort
-      ENDIF
-      xmin = 1.0E+20
-      xmax = -1.0E+20
-      DO i = 1, klon_glo
-         xmin = MIN(snow_fall_glo(i),xmin)
-         xmax = MAX(snow_fall_glo(i),xmax)
+      CALL get_field("snow_f",snow_fall)
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+         xmin = MIN(snow_fall(i),xmin)
+         xmax = MAX(snow_fall(i),xmax)
       ENDDO
       PRINT*,'Precipitation solide snow_f:', xmin, xmax
@@ -843,25 +513,15 @@
 c Lecture rayonnement solaire au sol:
 c
-      ierr = NF_INQ_VARID (nid, "solsw", nvarid)
-      IF (ierr.NE.NF_NOERR) THEN
+      CALL get_field("solsw",solsw,found)
+      IF (.NOT. found) THEN
          PRINT*, 'phyetat0: Le champ <solsw> est absent'
          PRINT*, 'mis a zero'
-         solsw_glo = 0.
-      ELSE
-#ifdef NC_DOUBLE
-        ierr = NF_GET_VAR_DOUBLE(nid, nvarid, solsw_glo)
-#else
-        ierr = NF_GET_VAR_REAL(nid, nvarid, solsw_glo)
-#endif
-        IF (ierr.NE.NF_NOERR) THEN
-          PRINT*, 'phyetat0: Lecture echouee pour <solsw>'
-          CALL abort
-        ENDIF
-      ENDIF
-      xmin = 1.0E+20
-      xmax = -1.0E+20
-      DO i = 1, klon_glo
-         xmin = MIN(solsw_glo(i),xmin)
-         xmax = MAX(solsw_glo(i),xmax)
+         solsw(:) = 0.
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+         xmin = MIN(solsw(i),xmin)
+         xmax = MAX(solsw(i),xmax)
       ENDDO
       PRINT*,'Rayonnement solaire au sol solsw:', xmin, xmax
@@ -869,25 +529,15 @@
 c Lecture rayonnement IF au sol:
 c
-      ierr = NF_INQ_VARID (nid, "sollw", nvarid)
-      IF (ierr.NE.NF_NOERR) THEN
+      CALL get_field("sollw",sollw,found)
+      IF (.NOT. found) THEN
          PRINT*, 'phyetat0: Le champ <sollw> est absent'
          PRINT*, 'mis a zero'
-         sollw_glo = 0.
-      ELSE
-#ifdef NC_DOUBLE
-        ierr = NF_GET_VAR_DOUBLE(nid, nvarid, sollw_glo)
-#else
-        ierr = NF_GET_VAR_REAL(nid, nvarid, sollw_glo)
-#endif
-        IF (ierr.NE.NF_NOERR) THEN
-          PRINT*, 'phyetat0: Lecture echouee pour <sollw>'
-          CALL abort
-        ENDIF
-      ENDIF
-      xmin = 1.0E+20
-      xmax = -1.0E+20
-      DO i = 1, klon_glo
-         xmin = MIN(sollw_glo(i),xmin)
-         xmax = MAX(sollw_glo(i),xmax)
+         sollw = 0.
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+         xmin = MIN(sollw(i),xmin)
+         xmax = MAX(sollw(i),xmax)
       ENDDO
       PRINT*,'Rayonnement IF au sol sollw:', xmin, xmax
@@ -896,23 +546,13 @@
 c Lecture derive des flux:
 c
-      ierr = NF_INQ_VARID (nid, "fder", nvarid)
-      IF (ierr.NE.NF_NOERR) THEN
+      CALL get_field("fder",fder,found)
+      IF (.NOT. found) THEN
          PRINT*, 'phyetat0: Le champ <fder> est absent'
          PRINT*, 'mis a zero'
          fder = 0.
-      ELSE
-#ifdef NC_DOUBLE
-        ierr = NF_GET_VAR_DOUBLE(nid, nvarid, fder)
-#else
-        ierr = NF_GET_VAR_REAL(nid, nvarid, fder)
-#endif
-        IF (ierr.NE.NF_NOERR) THEN
-          PRINT*, 'phyetat0: Lecture echouee pour <fder>'
-          CALL abort
-        ENDIF
-      ENDIF
-      xmin = 1.0E+20
-      xmax = -1.0E+20
-      DO i = 1, klon_glo
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
          xmin = MIN(fder(i),xmin)
          xmax = MAX(fder(i),xmax)
@@ -923,23 +563,10 @@
 c Lecture du rayonnement net au sol:
 c
-      ierr = NF_INQ_VARID (nid, "RADS", nvarid)
-      IF (ierr.NE.NF_NOERR) THEN
-         PRINT*, 'phyetat0: Le champ <RADS> est absent'
-         CALL abort
-      ENDIF
-#ifdef NC_DOUBLE
-      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, radsol_glo)
-#else
-      ierr = NF_GET_VAR_REAL(nid, nvarid, radsol_glo)
-#endif
-      IF (ierr.NE.NF_NOERR) THEN
-         PRINT*, 'phyetat0: Lecture echouee pour <RADS>'
-         CALL abort
-      ENDIF
-      xmin = 1.0E+20
-      xmax = -1.0E+20
-      DO i = 1, klon_glo
-         xmin = MIN(radsol_glo(i),xmin)
-         xmax = MAX(radsol_glo(i),xmax)
+      CALL get_field("RADS",radsol)
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+         xmin = MIN(radsol(i),xmin)
+         xmax = MAX(radsol(i),xmax)
       ENDDO
       PRINT*,'Rayonnement net au sol radsol:', xmin, xmax
@@ -948,6 +575,6 @@
 c
 c
-      ierr = NF_INQ_VARID (nid, "RUG", nvarid)
-      IF (ierr.NE.NF_NOERR) THEN
+      CALL get_field("RUG",frugs(:,1),found)
+      IF (.NOT. found) THEN
          PRINT*, 'phyetat0: Le champ <RUG> est absent'
          PRINT*, '          Mais je vais essayer de lire RUG**'
@@ -958,21 +585,8 @@
            ENDIF
            WRITE(str2,'(i2.2)') nsrf
-           ierr = NF_INQ_VARID (nid, "RUG"//str2, nvarid)
-           IF (ierr.NE.NF_NOERR) THEN
-              PRINT*, "phyetat0: Le champ <RUG"//str2//"> est absent"
-              CALL abort
-           ENDIF
-#ifdef NC_DOUBLE
-           ierr = NF_GET_VAR_DOUBLE(nid, nvarid, frugs(1,nsrf))
-#else
-           ierr = NF_GET_VAR_REAL(nid, nvarid, frugs(1,nsrf))
-#endif
-           IF (ierr.NE.NF_NOERR) THEN
-             PRINT*, "phyetat0: Lecture echouee pour <RUG"//str2//">"
-             CALL abort
-           ENDIF
+           CALL get_field("RUG"//str2,frugs(:,nsrf))
            xmin = 1.0E+20
            xmax = -1.0E+20
-           DO i = 1, klon_glo
+           DO i = 1, klon
               xmin = MIN(frugs(i,nsrf),xmin)
               xmax = MAX(frugs(i,nsrf),xmax)
@@ -983,16 +597,7 @@
          PRINT*, 'phyetat0: Le champ <RUG> est present'
          PRINT*, '          J ignore donc les autres RUG**'
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, frugs(1,1))
-#else
-         ierr = NF_GET_VAR_REAL(nid, nvarid, frugs(1,1))
-#endif
-         IF (ierr.NE.NF_NOERR) THEN
-            PRINT*, "phyetat0: Lecture echouee pour <RUG>"
-            CALL abort
-         ENDIF
          xmin = 1.0E+20
          xmax = -1.0E+20
-         DO i = 1, klon_glo
+         DO i = 1, klon
             xmin = MIN(frugs(i,1),xmin)
             xmax = MAX(frugs(i,1),xmax)
@@ -1000,5 +605,5 @@
          PRINT*,'rugosite <RUG>', xmin, xmax
          DO nsrf = 2, nbsrf
-         DO i = 1, klon_glo
+         DO i = 1, klon
             frugs(i,nsrf) = frugs(i,1)
          ENDDO
@@ -1009,6 +614,6 @@
 c Lecture de l'age de la neige:
 c
-      ierr = NF_INQ_VARID (nid, "AGESNO", nvarid)
-      IF (ierr.NE.NF_NOERR) THEN
+      CALL get_field("AGESNO",agesno(:,1),found)
+      IF (.NOT. found) THEN
          PRINT*, 'phyetat0: Le champ <AGESNO> est absent'
          PRINT*, '          Mais je vais essayer de lire AGESNO**'
@@ -1019,21 +624,12 @@
            ENDIF
            WRITE(str2,'(i2.2)') nsrf
-           ierr = NF_INQ_VARID (nid, "AGESNO"//str2, nvarid)
-           IF (ierr.NE.NF_NOERR) THEN
+           CALL get_field("AGESNO"//str2,agesno(:,nsrf),found)
+           IF (.NOT. found) THEN
               PRINT*, "phyetat0: Le champ <AGESNO"//str2//"> est absent"
               agesno = 50.0
            ENDIF
-#ifdef NC_DOUBLE
-           ierr = NF_GET_VAR_DOUBLE(nid, nvarid, agesno(1,nsrf))
-#else
-           ierr = NF_GET_VAR_REAL(nid, nvarid, agesno(1,nsrf))
-#endif
-           IF (ierr.NE.NF_NOERR) THEN
-             PRINT*, "phyetat0: Lecture echouee pour <AGESNO"//str2//">"
-             CALL abort
-           ENDIF
            xmin = 1.0E+20
            xmax = -1.0E+20
-           DO i = 1, klon_glo
+           DO i = 1, klon
               xmin = MIN(agesno(i,nsrf),xmin)
               xmax = MAX(agesno(i,nsrf),xmax)
@@ -1044,16 +640,7 @@
          PRINT*, 'phyetat0: Le champ <AGESNO> est present'
          PRINT*, '          J ignore donc les autres AGESNO**'
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, agesno(1,1))
-#else
-         ierr = NF_GET_VAR_REAL(nid, nvarid, agesno(1,1))
-#endif
-         IF (ierr.NE.NF_NOERR) THEN
-            PRINT*, "phyetat0: Lecture echouee pour <AGESNO>"
-            CALL abort
-         ENDIF
          xmin = 1.0E+20
          xmax = -1.0E+20
-         DO i = 1, klon_glo
+         DO i = 1, klon
             xmin = MIN(agesno(i,1),xmin)
             xmax = MAX(agesno(i,1),xmax)
@@ -1061,5 +648,5 @@
          PRINT*,'Age de la neige <AGESNO>', xmin, xmax
          DO nsrf = 2, nbsrf
-         DO i = 1, klon_glo
+         DO i = 1, klon
             agesno(i,nsrf) = agesno(i,1)
          ENDDO
@@ -1068,267 +655,126 @@
 
 c
-      ierr = NF_INQ_VARID (nid, "ZMEA", nvarid)
-      IF (ierr.NE.NF_NOERR) THEN
-         PRINT*, 'phyetat0: Le champ <ZMEA> est absent'
-         CALL abort
-      ENDIF
-#ifdef NC_DOUBLE
-      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zmea_glo)
-#else
-      ierr = NF_GET_VAR_REAL(nid, nvarid, zmea_glo)
-#endif
-      IF (ierr.NE.NF_NOERR) THEN
-         PRINT*, 'phyetat0: Lecture echouee pour <ZMEA>'
-         CALL abort
-      ENDIF
-      xmin = 1.0E+20
-      xmax = -1.0E+20
-      DO i = 1, klon_glo
-         xmin = MIN(zmea_glo(i),xmin)
-         xmax = MAX(zmea_glo(i),xmax)
+      CALL get_field("ZMEA", zmea)
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+         xmin = MIN(zmea(i),xmin)
+         xmax = MAX(zmea(i),xmax)
       ENDDO
       PRINT*,'OROGRAPHIE SOUS-MAILLE zmea:', xmin, xmax
 c
 c
-      ierr = NF_INQ_VARID (nid, "ZSTD", nvarid)
-      IF (ierr.NE.NF_NOERR) THEN
-         PRINT*, 'phyetat0: Le champ <ZSTD> est absent'
-         CALL abort
-      ENDIF
-#ifdef NC_DOUBLE
-      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zstd_glo)
-#else
-      ierr = NF_GET_VAR_REAL(nid, nvarid, zstd_glo)
-#endif
-      IF (ierr.NE.NF_NOERR) THEN
-         PRINT*, 'phyetat0: Lecture echouee pour <ZSTD>'
-         CALL abort
-      ENDIF
-      xmin = 1.0E+20
-      xmax = -1.0E+20
-      DO i = 1, klon_glo
-         xmin = MIN(zstd_glo(i),xmin)
-         xmax = MAX(zstd_glo(i),xmax)
+      CALL get_field("ZSTD",zstd)
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+         xmin = MIN(zstd(i),xmin)
+         xmax = MAX(zstd(i),xmax)
       ENDDO
       PRINT*,'OROGRAPHIE SOUS-MAILLE zstd:', xmin, xmax
 c
 c
-      ierr = NF_INQ_VARID (nid, "ZSIG", nvarid)
-      IF (ierr.NE.NF_NOERR) THEN
-         PRINT*, 'phyetat0: Le champ <ZSIG> est absent'
-         CALL abort
-      ENDIF
-#ifdef NC_DOUBLE
-      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zsig_glo)
-#else
-      ierr = NF_GET_VAR_REAL(nid, nvarid, zsig_glo)
-#endif
-      IF (ierr.NE.NF_NOERR) THEN
-         PRINT*, 'phyetat0: Lecture echouee pour <ZSIG>'
-         CALL abort
-      ENDIF
-      xmin = 1.0E+20
-      xmax = -1.0E+20
-      DO i = 1, klon_glo
-         xmin = MIN(zsig_glo(i),xmin)
-         xmax = MAX(zsig_glo(i),xmax)
+      CALL get_field("ZSIG",zsig)
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+         xmin = MIN(zsig(i),xmin)
+         xmax = MAX(zsig(i),xmax)
       ENDDO
       PRINT*,'OROGRAPHIE SOUS-MAILLE zsig:', xmin, xmax
 c
 c
-      ierr = NF_INQ_VARID (nid, "ZGAM", nvarid)
-      IF (ierr.NE.NF_NOERR) THEN
-         PRINT*, 'phyetat0: Le champ <ZGAM> est absent'
-         CALL abort
-      ENDIF
-#ifdef NC_DOUBLE
-      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zgam_glo)
-#else
-      ierr = NF_GET_VAR_REAL(nid, nvarid, zgam_glo)
-#endif
-      IF (ierr.NE.NF_NOERR) THEN
-         PRINT*, 'phyetat0: Lecture echouee pour <ZGAM>'
-         CALL abort
-      ENDIF
-      xmin = 1.0E+20
-      xmax = -1.0E+20
-      DO i = 1, klon_glo
-         xmin = MIN(zgam_glo(i),xmin)
-         xmax = MAX(zgam_glo(i),xmax)
+      CALL get_field("ZGAM",zgam)
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+         xmin = MIN(zgam(i),xmin)
+         xmax = MAX(zgam(i),xmax)
       ENDDO
       PRINT*,'OROGRAPHIE SOUS-MAILLE zgam:', xmin, xmax
 c
 c
-      ierr = NF_INQ_VARID (nid, "ZTHE", nvarid)
-      IF (ierr.NE.NF_NOERR) THEN
-         PRINT*, 'phyetat0: Le champ <ZTHE> est absent'
-         CALL abort
-      ENDIF
-#ifdef NC_DOUBLE
-      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zthe_glo)
-#else
-      ierr = NF_GET_VAR_REAL(nid, nvarid, zthe_glo)
-#endif
-      IF (ierr.NE.NF_NOERR) THEN
-         PRINT*, 'phyetat0: Lecture echouee pour <ZTHE>'
-         CALL abort
-      ENDIF
-      xmin = 1.0E+20
-      xmax = -1.0E+20
-      DO i = 1, klon_glo
-         xmin = MIN(zthe_glo(i),xmin)
-         xmax = MAX(zthe_glo(i),xmax)
+      CALL get_field("ZTHE",zthe)
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+         xmin = MIN(zthe(i),xmin)
+         xmax = MAX(zthe(i),xmax)
       ENDDO
       PRINT*,'OROGRAPHIE SOUS-MAILLE zthe:', xmin, xmax
 c
 c
-      ierr = NF_INQ_VARID (nid, "ZPIC", nvarid)
-      IF (ierr.NE.NF_NOERR) THEN
-         PRINT*, 'phyetat0: Le champ <ZPIC> est absent'
-         CALL abort
-      ENDIF
-#ifdef NC_DOUBLE
-      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zpic_glo)
-#else
-      ierr = NF_GET_VAR_REAL(nid, nvarid, zpic_glo)
-#endif
-      IF (ierr.NE.NF_NOERR) THEN
-         PRINT*, 'phyetat0: Lecture echouee pour <ZPIC>'
-         CALL abort
-      ENDIF
-      xmin = 1.0E+20
-      xmax = -1.0E+20
-      DO i = 1, klon_glo
-         xmin = MIN(zpic_glo(i),xmin)
-         xmax = MAX(zpic_glo(i),xmax)
+      CALL get_field("ZPIC",zpic)
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+         xmin = MIN(zpic(i),xmin)
+         xmax = MAX(zpic(i),xmax)
       ENDDO
       PRINT*,'OROGRAPHIE SOUS-MAILLE zpic:', xmin, xmax
 c
-      ierr = NF_INQ_VARID (nid, "ZVAL", nvarid)
-      IF (ierr.NE.NF_NOERR) THEN
-         PRINT*, 'phyetat0: Le champ <ZVAL> est absent'
-         CALL abort
-      ENDIF
-#ifdef NC_DOUBLE
-      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zval_glo)
-#else
-      ierr = NF_GET_VAR_REAL(nid, nvarid, zval_glo)
-#endif
-      IF (ierr.NE.NF_NOERR) THEN
-         PRINT*, 'phyetat0: Lecture echouee pour <ZVAL>'
-         CALL abort
-      ENDIF
-      xmin = 1.0E+20
-      xmax = -1.0E+20
-      DO i = 1, klon_glo
-         xmin = MIN(zval_glo(i),xmin)
-         xmax = MAX(zval_glo(i),xmax)
+      CALL get_field("ZVAL",zval)
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+         xmin = MIN(zval(i),xmin)
+         xmax = MAX(zval(i),xmax)
       ENDDO
       PRINT*,'OROGRAPHIE SOUS-MAILLE zval:', xmin, xmax
 c
 c
-      ierr = NF_INQ_VARID (nid, "RUGSREL", nvarid)
-      IF (ierr.NE.NF_NOERR) THEN
-         PRINT*, 'phyetat0: Le champ <RUGSREL> est absent'
-         CALL abort
-      ENDIF
-#ifdef NC_DOUBLE
-      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rugsrel_glo)
-#else
-      ierr = NF_GET_VAR_REAL(nid, nvarid, rugsrel_glo)
-#endif
-      IF (ierr.NE.NF_NOERR) THEN
-         PRINT*, 'phyetat0: Lecture echouee pour <RUGSREL>'
-         CALL abort
-      ENDIF
-      xmin = 1.0E+20
-      xmax = -1.0E+20
-      DO i = 1, klon_glo
-         xmin = MIN(rugsrel_glo(i),xmin)
-         xmax = MAX(rugsrel_glo(i),xmax)
+      CALL get_field("RUGSREL",rugoro)
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+         xmin = MIN(rugoro(i),xmin)
+         xmax = MAX(rugoro(i),xmax)
       ENDDO
       PRINT*,'Rugosite relief (ecart-type) rugsrel:', xmin, xmax
 c
 c
-      ancien_ok_glo = .TRUE.
-c
-      ierr = NF_INQ_VARID (nid, "TANCIEN", nvarid)
-      IF (ierr.NE.NF_NOERR) THEN
+     
+c
+      ancien_ok = .TRUE.
+
+      CALL get_field("TANCIEN",t_ancien,found)
+      IF (.NOT. found) THEN
          PRINT*, "phyetat0: Le champ <TANCIEN> est absent"
          PRINT*, "Depart legerement fausse. Mais je continue"
-         ancien_ok_glo = .FALSE.
-      ELSE
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, t_ancien_glo)
-#else
-         ierr = NF_GET_VAR_REAL(nid, nvarid, t_ancien_glo)
-#endif
-         IF (ierr.NE.NF_NOERR) THEN
-            PRINT*, "phyetat0: Lecture echouee pour <TANCIEN>"
-            CALL abort
-         ENDIF
-      ENDIF
-c
-      ierr = NF_INQ_VARID (nid, "QANCIEN", nvarid)
-      IF (ierr.NE.NF_NOERR) THEN
+         ancien_ok = .FALSE.
+      ENDIF
+
+
+      CALL get_field("QANCIEN",q_ancien,found)
+      IF (.NOT. found) THEN
          PRINT*, "phyetat0: Le champ <QANCIEN> est absent"
          PRINT*, "Depart legerement fausse. Mais je continue"
-         ancien_ok_glo = .FALSE.
-      ELSE
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, q_ancien_glo)
-#else
-         ierr = NF_GET_VAR_REAL(nid, nvarid, q_ancien_glo)
-#endif
-         IF (ierr.NE.NF_NOERR) THEN
-            PRINT*, "phyetat0: Lecture echouee pour <QANCIEN>"
-            CALL abort
-         ENDIF
-      ENDIF
-c
-      clwcon_glo=0.
-      ierr = NF_INQ_VARID (nid, "CLWCON", nvarid)
-      IF (ierr.NE.NF_NOERR) THEN
+         ancien_ok = .FALSE.
+      ENDIF
+
+c
+
+      clwcon=0.
+      CALL get_field("CLWCON",clwcon(:,1),found)
+      IF (.NOT. found) THEN
          PRINT*, "phyetat0: Le champ CLWCON est absent"
          PRINT*, "Depart legerement fausse. Mais je continue"
-c        clwcon_glo = 0.
-      ELSE
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, clwcon_glo)
-#else
-         ierr = NF_GET_VAR_REAL(nid, nvarid, clwcon_glo)
-#endif
-         IF (ierr.NE.NF_NOERR) THEN
-            PRINT*, "phyetat0: Lecture echouee pour <CLWCON>"
-            CALL abort
-         ENDIF
-      ENDIF
-      xmin = 1.0E+20
-      xmax = -1.0E+20
-      xmin = MINval(clwcon_glo)
-      xmax = MAXval(clwcon_glo)
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINval(clwcon)
+      xmax = MAXval(clwcon)
       PRINT*,'Eau liquide convective (ecart-type) clwcon:', xmin, xmax
 c
-      rnebcon_glo = 0.
-      ierr = NF_INQ_VARID (nid, "RNEBCON", nvarid)
-      IF (ierr.NE.NF_NOERR) THEN
+      rnebcon = 0.
+      CALL get_field("RNEBCON",rnebcon(:,1),found)
+      IF (.NOT. found) THEN
          PRINT*, "phyetat0: Le champ RNEBCON est absent"
          PRINT*, "Depart legerement fausse. Mais je continue"
-c        rnebcon_glo = 0.
-      ELSE
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rnebcon_glo)
-#else
-         ierr = NF_GET_VAR_REAL(nid, nvarid, rnebcon_glo)
-#endif
-         IF (ierr.NE.NF_NOERR) THEN
-            PRINT*, "phyetat0: Lecture echouee pour <RNEBCON>"
-            CALL abort
-         ENDIF
-      ENDIF
-      xmin = 1.0E+20
-      xmax = -1.0E+20
-      xmin = MINval(rnebcon_glo)
-      xmax = MAXval(rnebcon_glo)
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINval(rnebcon)
+      xmax = MAXval(rnebcon)
       PRINT*,'Nebulosite convective (ecart-type) rnebcon:', xmin, xmax
 
@@ -1336,44 +782,23 @@
 c Lecture ratqs
 c
-      ratqs_glo=0.
-      ierr = NF_INQ_VARID (nid, "RATQS", nvarid)
-      IF (ierr.NE.NF_NOERR) THEN
+      ratqs=0.
+      CALL get_field("RATQS",ratqs(:,1),found)
+      IF (.NOT. found) THEN
          PRINT*, "phyetat0: Le champ <RATQS> est absent"
          PRINT*, "Depart legerement fausse. Mais je continue"
-         ratqs_glo = 0.
-      ELSE
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, ratqs_glo)
-#else
-         ierr = NF_GET_VAR_REAL(nid, nvarid, ratqs_glo)
-#endif
-         IF (ierr.NE.NF_NOERR) THEN
-            PRINT*, "phyetat0: Lecture echouee pour <RATQS>"
-            CALL abort
-         ENDIF
-      ENDIF
-      xmin = 1.0E+20
-      xmax = -1.0E+20
-      xmin = MINval(ratqs_glo)
-      xmax = MAXval(ratqs_glo)
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINval(ratqs)
+      xmax = MAXval(ratqs)
       PRINT*,'(ecart-type) ratqs:', xmin, xmax
 c
 c Lecture run_off_lic_0
 c
-      ierr = NF_INQ_VARID (nid, "RUNOFFLIC0", nvarid)
-      IF (ierr.NE.NF_NOERR) THEN
+      CALL get_field("RUNOFFLIC0",run_off_lic_0,found)
+      IF (.NOT. found) THEN
          PRINT*, "phyetat0: Le champ <RUNOFFLIC0> est absent"
          PRINT*, "Depart legerement fausse. Mais je continue"
          run_off_lic_0 = 0.
-      ELSE
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, run_off_lic_0)
-#else
-         ierr = NF_GET_VAR_REAL(nid, nvarid, run_off_lic_0)
-#endif
-         IF (ierr.NE.NF_NOERR) THEN
-            PRINT*, "phyetat0: Lecture echouee pour <RUNOFFLIC0>"
-            CALL abort
-         ENDIF
       ENDIF
       xmin = 1.0E+20
@@ -1388,352 +813,184 @@
 
       IF (iflag_pbl>1) then
-         PRINT*, 'phyetat0: Le champ <TKE> est absent'
-         PRINT*, '          Mais je vais essayer de lire TKE**'
-         DO nsrf = 1, nbsrf
-           IF (nsrf.GT.99) THEN
-             PRINT*, "Trop de sous-mailles"
-             CALL abort
-           ENDIF
-           WRITE(str2,'(i2.2)') nsrf
-           ierr = NF_INQ_VARID (nid, "TKE"//str2, nvarid)
-           IF (ierr.NE.NF_NOERR) THEN
-              PRINT*, "WARNING phyetat0: <TKE"//str2//"> est absent"
-              pbl_tke_glo(:,:,nsrf)=1.e-8
-           ELSE
-#ifdef NC_DOUBLE
-              ierr = NF_GET_VAR_DOUBLE(nid, nvarid, 
-     &                                pbl_tke_glo(1,1,nsrf))
-#else
-              ierr = NF_GET_VAR_REAL(nid, nvarid, pbl_tke_glo(1,1,nsrf))
-#endif
-              IF (ierr.NE.NF_NOERR) THEN
-                PRINT*, "WARNING phyetat0: echec lect <TKE"//str2//">"
-                CALL abort
-              ENDIF
-           ENDIF
-
-           xmin = 1.0E+20
-           xmax = -1.0E+20
-           DO k = 1, klev
-           DO i = 1, klon_glo
-              xmin = MIN(pbl_tke_glo(i,k,nsrf),xmin)
-              xmax = MAX(pbl_tke_glo(i,k,nsrf),xmax)
-           ENDDO
-           ENDDO
-           PRINT*,'Temperature du sol TKE**:', nsrf, xmin, xmax
-         ENDDO
+        DO nsrf = 1, nbsrf
+          IF (nsrf.GT.99) THEN
+            PRINT*, "Trop de sous-mailles"
+            CALL abort
+          ENDIF
+          WRITE(str2,'(i2.2)') nsrf
+          CALL get_field("TKE"//str2,pbl_tke(:,1:klev,nsrf),found)
+          IF (.NOT. found) THEN
+            PRINT*, "phyetat0: <TKE"//str2//"> est absent"
+            pbl_tke(:,:,nsrf)=1.e-8
+          ENDIF
+          xmin = 1.0E+20
+          xmax = -1.0E+20
+          DO k = 1, klev
+            DO i = 1, klon
+              xmin = MIN(pbl_tke(i,k,nsrf),xmin)
+              xmax = MAX(pbl_tke(i,k,nsrf),xmax)
+            ENDDO
+          ENDDO
+          PRINT*,'Temperature du sol TKE**:', nsrf, xmin, xmax
+        ENDDO
       ENDIF
 c
 c zmax0
-      ierr = NF_INQ_VARID (nid, "ZMAX0", nvarid)
-      IF (ierr.NE.NF_NOERR) THEN
-         PRINT*, "phyetat0: Le champ <ZMAX0> est absent"
-         PRINT*, "Depart legerement fausse. Mais je continue"
-         zmax0_glo=40.
-      ELSE
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zmax0_glo)
-#else
-         ierr = NF_GET_VAR_REAL(nid, nvarid, zmax0_glo)
-#endif
-         IF (ierr.NE.NF_NOERR) THEN
-            PRINT*, "phyetat0: Lecture echouee pour <ZMAX0>"
-            CALL abort
-         ENDIF
-      ENDIF
-      xmin = 1.0E+20
-      xmax = -1.0E+20
-      xmin = MINval(zmax0_glo)
-      xmax = MAXval(zmax0_glo)
+      CALL get_field("ZMAX0",zmax0,found)
+      IF (.NOT. found) THEN
+        PRINT*, "phyetat0: Le champ <ZMAX0> est absent"
+        PRINT*, "Depart legerement fausse. Mais je continue"
+        zmax0=40.
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINval(zmax0)
+      xmax = MAXval(zmax0)
       PRINT*,'(ecart-type) zmax0:', xmin, xmax
 c
 c           f0(ig)=1.e-5
 c f0
-      ierr = NF_INQ_VARID (nid, "f0", nvarid)
-      IF (ierr.NE.NF_NOERR) THEN
+      CALL get_field("f0",f0,found)
+      IF (.NOT. found) THEN
          PRINT*, "phyetat0: Le champ <f0> est absent"
          PRINT*, "Depart legerement fausse. Mais je continue"
-         f0_glo=1.e-5
-      ELSE
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, f0_glo)
-#else
-         ierr = NF_GET_VAR_REAL(nid, nvarid, f0_glo)
-#endif
-         IF (ierr.NE.NF_NOERR) THEN
-            PRINT*, "phyetat0: Lecture echouee pour <f0>"
-            CALL abort
-         ENDIF
-      ENDIF
-      xmin = 1.0E+20
-      xmax = -1.0E+20
-      xmin = MINval(f0_glo)
-      xmax = MAXval(f0_glo)
+         f0=1.e-5
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINval(f0)
+      xmax = MAXval(f0)
       PRINT*,'(ecart-type) f0:', xmin, xmax
 c
 c ema_work1
 c
-      ierr = NF_INQ_VARID (nid, "EMA_WORK1", nvarid)
-      IF (ierr.NE.NF_NOERR) THEN
-         PRINT*, "phyetat0: Le champ <EMA_WORK1> est absent"
-         PRINT*, "Depart legerement fausse. Mais je continue"
-         ema_work1_glo=0.
-      ELSE
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, ema_work1_glo)
-#else
-         ierr = NF_GET_VAR_REAL(nid, nvarid, ema_work1_glo)
-#endif
-         IF (ierr.NE.NF_NOERR) THEN
-            PRINT*, "phyetat0: Lecture echouee pour <EMA_WORK1>"
-            CALL abort
-         ENDIF
-           xmin = 1.0E+20
-           xmax = -1.0E+20
-           DO k = 1, klev
-           DO i = 1, klon
-              xmin = MIN(ema_work1_glo(i,k),xmin)
-              xmax = MAX(ema_work1_glo(i,k),xmax)
-           ENDDO
-           ENDDO
-           PRINT*,'ema_work1:', xmin, xmax
+      CALL get_field("EMA_WORK1",ema_work1,found)
+      IF (.NOT. found) THEN
+        PRINT*, "phyetat0: Le champ <EMA_WORK1> est absent"
+        PRINT*, "Depart legerement fausse. Mais je continue"
+        ema_work1=0.
+      ELSE
+        xmin = 1.0E+20
+        xmax = -1.0E+20
+        DO k = 1, klev
+          DO i = 1, klon
+            xmin = MIN(ema_work1(i,k),xmin)
+            xmax = MAX(ema_work1(i,k),xmax)
+          ENDDO
+        ENDDO
+        PRINT*,'ema_work1:', xmin, xmax
       ENDIF
 c
 c ema_work2
 c
-      ierr = NF_INQ_VARID (nid, "EMA_WORK2", nvarid)
-      IF (ierr.NE.NF_NOERR) THEN
-         PRINT*, "phyetat0: Le champ <EMA_WORK2> est absent"
-         PRINT*, "Depart legerement fausse. Mais je continue"
-         ema_work2_glo=0.
-      ELSE
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, ema_work2_glo)
-#else
-         ierr = NF_GET_VAR_REAL(nid, nvarid, ema_work2_glo)
-#endif
-         IF (ierr.NE.NF_NOERR) THEN
-            PRINT*, "phyetat0: Lecture echouee pour <EMA_WORK2>"
-            CALL abort
-         ENDIF
-           xmin = 1.0E+20
-           xmax = -1.0E+20
-           DO k = 1, klev
-           DO i = 1, klon
-              xmin = MIN(ema_work2_glo(i,k),xmin)
-              xmax = MAX(ema_work2_glo(i,k),xmax)
-           ENDDO
-           ENDDO
-           PRINT*,'ema_work2:', xmin, xmax
+      CALL get_field("EMA_WORK2",ema_work2,found)
+      IF (.NOT. found) THEN
+        PRINT*, "phyetat0: Le champ <EMA_WORK2> est absent"
+        PRINT*, "Depart legerement fausse. Mais je continue"
+        ema_work2=0.
+      ELSE
+        xmin = 1.0E+20
+        xmax = -1.0E+20
+        DO k = 1, klev
+          DO i = 1, klon
+            xmin = MIN(ema_work2(i,k),xmin)
+            xmax = MAX(ema_work2(i,k),xmax)
+          ENDDO
+        ENDDO
+        PRINT*,'ema_work2:', xmin, xmax
       ENDIF
 c
 c wake_deltat
 c
-      ierr = NF_INQ_VARID (nid, "WAKE_DELTAT", nvarid)
-      IF (ierr.NE.NF_NOERR) THEN
-         PRINT*, "phyetat0: Le champ <WAKE_DELTAT> est absent"
-         PRINT*, "Depart legerement fausse. Mais je continue"
-         wake_deltat_glo=0.
-      ELSE
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, wake_deltat_glo)
-#else
-         ierr = NF_GET_VAR_REAL(nid, nvarid, wake_deltat_glo)
-#endif
-         IF (ierr.NE.NF_NOERR) THEN
-            PRINT*, "phyetat0: Lecture echouee pour <WAKE_DELTAT>"
-            CALL abort
-         ENDIF
-           xmin = 1.0E+20
-           xmax = -1.0E+20
-           DO k = 1, klev
-           DO i = 1, klon_glo
-              xmin = MIN(wake_deltat_glo(i,k),xmin)
-              xmax = MAX(wake_deltat_glo(i,k),xmax)
-           ENDDO
-           ENDDO
-           PRINT*,'wake_deltat:', xmin, xmax
+      CALL get_field("WAKE_DELTAT",wake_deltat,found)
+      IF (.NOT. found) THEN
+        PRINT*, "phyetat0: Le champ <WAKE_DELTAT> est absent"
+        PRINT*, "Depart legerement fausse. Mais je continue"
+        wake_deltat=0.
+      ELSE
+        xmin = 1.0E+20
+        xmax = -1.0E+20
+        DO k = 1, klev
+          DO i = 1, klon
+            xmin = MIN(wake_deltat(i,k),xmin)
+            xmax = MAX(wake_deltat(i,k),xmax)
+          ENDDO
+        ENDDO
+        PRINT*,'wake_deltat:', xmin, xmax
       ENDIF
 c
 c wake_deltaq
-c
-      ierr = NF_INQ_VARID (nid, "WAKE_DELTAQ", nvarid)
-      IF (ierr.NE.NF_NOERR) THEN
-         PRINT*, "phyetat0: Le champ <WAKE_DELTAQ> est absent"
-         PRINT*, "Depart legerement fausse. Mais je continue"
-         wake_deltaq_glo=0.
-      ELSE
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, wake_deltaq_glo)
-#else
-         ierr = NF_GET_VAR_REAL(nid, nvarid, wake_deltaq_glo)
-#endif
-         IF (ierr.NE.NF_NOERR) THEN
-            PRINT*, "phyetat0: Lecture echouee pour <WAKE_DELTAQ>"
-            CALL abort
-         ENDIF
-           xmin = 1.0E+20
-           xmax = -1.0E+20
-           DO k = 1, klev
-           DO i = 1, klon_glo
-              xmin = MIN(wake_deltaq_glo(i,k),xmin)
-              xmax = MAX(wake_deltaq_glo(i,k),xmax)
-           ENDDO
-           ENDDO
-           PRINT*,'wake_deltaq:', xmin, xmax
+c   
+      CALL get_field("WAKE_DELTAQ",wake_deltaq,found)
+      IF (.NOT. found) THEN
+        PRINT*, "phyetat0: Le champ <WAKE_DELTAQ> est absent"
+        PRINT*, "Depart legerement fausse. Mais je continue"
+        wake_deltaq=0.
+      ELSE
+        xmin = 1.0E+20
+        xmax = -1.0E+20
+        DO k = 1, klev
+          DO i = 1, klon
+            xmin = MIN(wake_deltaq(i,k),xmin)
+            xmax = MAX(wake_deltaq(i,k),xmax)
+          ENDDO
+        ENDDO
+        PRINT*,'wake_deltaq:', xmin, xmax
       ENDIF
 c
 c wake_s
 c
-      ierr = NF_INQ_VARID (nid, "WAKE_S", nvarid)
-      IF (ierr.NE.NF_NOERR) THEN
-         PRINT*, "phyetat0: Le champ <WAKE_S> est absent"
-         PRINT*, "Depart legerement fausse. Mais je continue"
-         wake_s_glo=0.
-      ELSE
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, wake_s_glo)
-#else
-         ierr = NF_GET_VAR_REAL(nid, nvarid, wake_s_glo)
-#endif
-         IF (ierr.NE.NF_NOERR) THEN
-            PRINT*, "phyetat0: Lecture echouee pour <WAKE_S>"
-            CALL abort
-         ENDIF
-      ENDIF
-      xmin = 1.0E+20
-      xmax = -1.0E+20
-      xmin = MINval(wake_s_glo)
-      xmax = MAXval(wake_s_glo)
+      CALL get_field("WAKE_S",wake_s,found)
+      IF (.NOT. found) THEN
+        PRINT*, "phyetat0: Le champ <WAKE_S> est absent"
+        PRINT*, "Depart legerement fausse. Mais je continue"
+        wake_s=0.
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINval(wake_s)
+      xmax = MAXval(wake_s)
       PRINT*,'(ecart-type) wake_s:', xmin, xmax
 c
 c wake_cstar
 c
-      ierr = NF_INQ_VARID (nid, "WAKE_CSTAR", nvarid)
-      IF (ierr.NE.NF_NOERR) THEN
+      CALL get_field("WAKE_CSTAR",wake_cstar,found)
+      IF (.NOT. found) THEN
          PRINT*, "phyetat0: Le champ <WAKE_CSTAR> est absent"
          PRINT*, "Depart legerement fausse. Mais je continue"
-         wake_cstar_glo=0.
-      ELSE
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, wake_cstar_glo)
-#else
-         ierr = NF_GET_VAR_REAL(nid, nvarid, wake_cstar_glo)
-#endif
-         IF (ierr.NE.NF_NOERR) THEN
-            PRINT*, "phyetat0: Lecture echouee pour <WAKE_CSTAR>"
-            CALL abort
-         ENDIF
-      ENDIF
-      xmin = 1.0E+20
-      xmax = -1.0E+20
-      xmin = MINval(wake_cstar_glo)
-      xmax = MAXval(wake_cstar_glo)
+         wake_cstar=0.
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINval(wake_cstar)
+      xmax = MAXval(wake_cstar)
       PRINT*,'(ecart-type) wake_cstar:', xmin, xmax
 c
 c wake_fip
 c
-      ierr = NF_INQ_VARID (nid, "WAKE_FIP", nvarid)
-      IF (ierr.NE.NF_NOERR) THEN
+      CALL get_field("WAKE_FIP",wake_fip,found)
+      IF (.NOT. found) THEN
          PRINT*, "phyetat0: Le champ <WAKE_FIP> est absent"
          PRINT*, "Depart legerement fausse. Mais je continue"
-         wake_fip_glo=0.
-      ELSE
-#ifdef NC_DOUBLE
-         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, wake_fip_glo)
-#else
-         ierr = NF_GET_VAR_REAL(nid, nvarid, wake_fip_glo)
-#endif
-         IF (ierr.NE.NF_NOERR) THEN
-            PRINT*, "phyetat0: Lecture echouee pour <WAKE_FIP>"
-            CALL abort
-         ENDIF
-      ENDIF
-      xmin = 1.0E+20
-      xmax = -1.0E+20
-      xmin = MINval(wake_fip_glo)
-      xmax = MAXval(wake_fip_glo)
+         wake_fip=0.
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINval(wake_fip)
+      xmax = MAXval(wake_fip)
       PRINT*,'(ecart-type) wake_fip:', xmin, xmax
 c
-c Fermer le fichier:
-c
-      ierr = NF_CLOSE(nid)
-      ENDIF ! is_mpi_root .AND. is_omp_root
-c
-
-c$OMP MASTER
-cym  en attendant mieux
-        iolat(1)=rlat_glo(1)
-
-!FH1D   
-!iolat(jjm+1)=rlat(klon_glo)
-	iolat(jjm+1-1/iim)=rlat_glo(klon_glo)
-        if (iim.gt.1) then
-	do i=2,jjm
-	  iolat(i)=rlat_glo(2+(i-2)*iim)
-	enddo
-        endif
-
-	CALL bcast_mpi(iolat)
-	CALL bcast_mpi(rlon_glo)
-
-!FH1D
-!       call init_iophy(iolat,rlon(2:iim+1))
-        call init_iophy(iolat,rlon_glo(2-1/iim:iim+1-1/iim))
-       
-c$OMP END MASTER
+
+c on ferme le fichier
+      CALL close_startphy
+
+      CALL init_iophy_new(rlat,rlon)
       	
-      call Scatter( rlat_glo,rlat)
-      call Scatter( rlon_glo,rlon)
-      call Scatter( tsol_glo,ftsol)
-      IF (iflag_pbl>1) then
-         call Scatter( pbl_tke_glo,pbl_tke)
-      endif
-      call Scatter( zmax0_glo,zmax0)
-      call Scatter( f0_glo,f0)
-      call Scatter( ema_work1_glo, ema_work1)
-      call Scatter( ema_work2_glo, ema_work2)
-      call Scatter( wake_deltat_glo, wake_deltat)
-      call Scatter( wake_deltaq_glo, wake_deltaq)
-      call Scatter( wake_s_glo, wake_s)
-      call Scatter( wake_cstar_glo, wake_cstar)
-      call Scatter( wake_fip_glo, wake_fip)
-      call Scatter( tsoil,tsoil_p)
-      call Scatter( qsurf,qsurf_p)
-      call Scatter( qsol,qsol_p)
-      call Scatter( snow,snow_p)
-      call Scatter( alb1_glo,falb1)
-      call Scatter( alb2_glo,falb2)
-      call Scatter( evap,evap_p)
-      call Scatter( radsol_glo,radsol)
-      call Scatter( rain_fall_glo,rain_fall)
-      call Scatter( snow_fall_glo,snow_fall)
-      call Scatter( sollw_glo,sollw)
-      call Scatter( solsw_glo,solsw)
-      call Scatter( fder,fder_p)
-      call Scatter( frugs,frugs_p)
-      call Scatter( agesno,agesno_p)
-      call Scatter( zmea_glo,zmea)
-      call Scatter( zstd_glo,zstd)
-      call Scatter( zsig_glo,zsig)
-      call Scatter( zgam_glo,zgam)
-      call Scatter( zthe_glo,zthe)
-      call Scatter( zpic_glo,zpic)
-      call Scatter( zval_glo,zval)
-      call Scatter( rugsrel_glo,rugoro)
-      call Scatter( pctsrf_glo,pctsrf)
-      call Scatter( run_off_lic_0,run_off_lic_0_p)
-      call Scatter( t_ancien_glo,t_ancien)
-      call Scatter( q_ancien_glo,q_ancien)
-      call Scatter( rnebcon_glo,rnebcon)
-      call Scatter( clwcon_glo,clwcon)
-      call Scatter( ratqs_glo,ratqs)
-      call Scatter( zmasq_glo,zmasq)
 
 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)
+      CALL pbl_surface_init(qsol, fder, snow, qsurf,
+     $     evap, frugs, agesno, tsoil)
 
 c Initialize module ocean_cpl_mod for the case of coupled ocean
@@ -1744,6 +1001,5 @@
 c Initilialize module fonte_neige_mod      
 c
-      CALL fonte_neige_init(run_off_lic_0_p)
-
+      CALL fonte_neige_init(run_off_lic_0)
 
       RETURN
Index: /LMDZ4/trunk/libf/phylmd/phyredem.F
===================================================================
--- /LMDZ4/trunk/libf/phylmd/phyredem.F	(revision 1000)
+++ /LMDZ4/trunk/libf/phylmd/phyredem.F	(revision 1001)
@@ -11,4 +11,5 @@
       USE pbl_surface_mod,  ONLY : pbl_surface_final
       USE phys_state_var_mod
+      USE iostart
 
       IMPLICIT none
@@ -29,53 +30,16 @@
 
 c les variables globales ecrites dans le fichier restart
-      REAL rlat_glo(klon_glo), rlon_glo(klon_glo)
-      REAL pctsrf_glo(klon_glo, nbsrf)
-      REAL tsol_glo(klon_glo,nbsrf)
-      REAL alb1_glo(klon_glo,nbsrf)
-      REAL alb2_glo(klon_glo,nbsrf)
-      REAL rain_fall_glo(klon_glo)
-      REAL snow_fall_glo(klon_glo)
-      real solsw_glo(klon_glo)
-      real sollw_glo(klon_glo)
-      REAL radsol_glo(klon_glo)
-      REAL zmea_glo(klon_glo)
-      REAL zstd_glo(klon_glo)
-      REAL zsig_glo(klon_glo)
-      REAL zgam_glo(klon_glo)
-      REAL zthe_glo(klon_glo)
-      REAL zpic_glo(klon_glo)
-      REAL zval_glo(klon_glo)
-      REAL rugsrel_glo(klon_glo)
-      REAL t_ancien_glo(klon_glo,klev), q_ancien_glo(klon_glo,klev)
-      REAL clwcon_glo(klon_glo,klev)
-      REAL rnebcon_glo(klon_glo,klev) 
-      REAL ratqs_glo(klon_glo,klev)
-      REAL pbl_tke_glo(klon_glo,klev+1,nbsrf)
-      REAL zmax0_glo(klon_glo), f0_glo(klon)
-      REAL ema_work1_glo(klon_glo, klev), ema_work2_glo(klon_glo, klev)
-      REAL wake_deltat_glo(klon_glo,klev),wake_deltaq_glo(klon_glo,klev)
-      REAL wake_s_glo(klon_glo), wake_cstar_glo(klon_glo)
-      REAL wake_fip_glo(klon_glo)
-
-      REAL tsoil_p(klon,nsoilmx,nbsrf)
-      REAL qsurf_p(klon,nbsrf)
-      REAL qsol_p(klon)
-      REAL snow_p(klon,nbsrf)
-      REAL evap_p(klon,nbsrf)
-      real fder_p(klon)
-      REAL frugs_p(klon,nbsrf)
-      REAL agesno_p(klon,nbsrf)
-      REAL run_off_lic_0_p(klon)
-      
-      REAL tsoil(klon_glo,nsoilmx,nbsrf)
-      REAL qsurf(klon_glo,nbsrf)
-      REAL qsol(klon_glo)
-      REAL snow(klon_glo,nbsrf)
-      REAL evap(klon_glo,nbsrf)
-      real fder(klon_glo)
-      REAL frugs(klon_glo,nbsrf)
-      REAL agesno(klon_glo,nbsrf)
-      REAL run_off_lic_0(klon_glo)
-      REAL masq(klon_glo)
+
+      
+      REAL tsoil(klon,nsoilmx,nbsrf)
+      REAL tslab(klon), seaice(klon)
+      REAL qsurf(klon,nbsrf)
+      REAL qsol(klon)
+      REAL snow(klon,nbsrf)
+      REAL evap(klon,nbsrf)
+      real fder(klon)
+      REAL frugs(klon,nbsrf)
+      REAL agesno(klon,nbsrf)
+      REAL run_off_lic_0(klon)
 c
       INTEGER nid, nvarid, idim1, idim2, idim3
@@ -93,77 +57,14 @@
 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)
+      CALL pbl_surface_final(qsol, fder, snow, qsurf, 
+     $     evap, frugs, agesno, tsoil)
 
 c Get a variable calculated in module fonte_neige_mod
-      CALL fonte_neige_final(run_off_lic_0_p)
-
-c======================================================================
-
-      call Gather( rlat,rlat_glo)
-      call Gather( rlon,rlon_glo)
-      call Gather( pctsrf,pctsrf_glo)
-      call Gather( ftsol,tsol_glo)
-      call Gather( falb1,alb1_glo)
-      call Gather( falb2,alb2_glo)
-      call Gather( rain_fall,rain_fall_glo)
-      call Gather( snow_fall,snow_fall_glo)
-      call Gather( sollw,sollw_glo)
-      call Gather( solsw,solsw_glo)
-      call Gather( radsol,radsol_glo)
-      call Gather( zmea,zmea_glo)
-      call Gather( zstd,zstd_glo)
-      call Gather( zsig,zsig_glo)
-      call Gather( zgam,zgam_glo)
-      call Gather( zthe,zthe_glo)
-      call Gather( zpic,zpic_glo)
-      call Gather( zval,zval_glo)
-      call Gather( rugoro,rugsrel_glo)
-      call Gather( t_ancien,t_ancien_glo)
-      call Gather( q_ancien,q_ancien_glo)
-      call Gather( clwcon,clwcon_glo)
-      call Gather( rnebcon,rnebcon_glo)
-      call Gather( ratqs,ratqs_glo)
-      call Gather( pbl_tke,pbl_tke_glo)
-      call Gather( zmax0,zmax0_glo)
-      call Gather( f0,f0_glo)
-      call Gather( ema_work1, ema_work1_glo)
-      call Gather( ema_work2, ema_work2_glo)
-      call Gather( wake_deltat, wake_deltat_glo)
-      call Gather( wake_deltaq, wake_deltaq_glo)
-      call Gather( wake_s, wake_s_glo)
-      call Gather( wake_cstar, wake_cstar_glo)
-      call Gather( wake_fip, wake_fip_glo)
-
-      call Gather( tsoil_p,tsoil)
-      call Gather( qsurf_p,qsurf)
-      call Gather( qsol_p,qsol)
-      call Gather( snow_p,snow)
-      call Gather( evap_p,evap)
-      call Gather( fder_p,fder)
-      call Gather( frugs_p,frugs)
-      call Gather( agesno_p,agesno)
-      call Gather( run_off_lic_0_p,run_off_lic_0)
-      call Gather( zmasq,masq)
-      
-c$OMP MASTER
-      IF (is_mpi_root) THEN
-      
-      ierr = NF_CREATE(fichnom, NF_CLOBBER, nid)
-      IF (ierr.NE.NF_NOERR) THEN
-        write(6,*)' Pb d''ouverture du fichier '//fichnom
-        write(6,*)' ierr = ', ierr
-        CALL ABORT
-      ENDIF
-c
-      ierr = NF_PUT_ATT_TEXT (nid, NF_GLOBAL, "title", 28,
-     .                       "Fichier redemmarage physique")
-c
-      ierr = NF_DEF_DIM (nid, "index", length, idim1)
-      ierr = NF_DEF_DIM (nid, "points_physiques", klon_glo, idim2)
-      ierr = NF_DEF_DIM (nid, "horizon_vertical", klon_glo*klev, idim3)
-c
-      ierr = NF_ENDDEF(nid)
-c
+      CALL fonte_neige_final(run_off_lic_0)
+
+c======================================================================
+
+      CALL open_restartphy(fichnom)
+      
       DO ierr = 1, length
          tab_cntrl(ierr) = 0.0
@@ -186,442 +87,142 @@
       tab_cntrl(15) = itau_phy
 c
-      ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-      ierr = NF_DEF_VAR (nid, "controle", NF_DOUBLE, 1, idim1,nvarid)
-#else
-      ierr = NF_DEF_VAR (nid, "controle", NF_FLOAT, 1, idim1,nvarid)
-#endif
-      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 22,
-     .                        "Parametres de controle")
-      ierr = NF_ENDDEF(nid)
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tab_cntrl)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,tab_cntrl)
-#endif
-c
-      ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-      ierr = NF_DEF_VAR (nid, "longitude", NF_DOUBLE, 1, idim2,nvarid)
-#else
-      ierr = NF_DEF_VAR (nid, "longitude", NF_FLOAT, 1, idim2,nvarid)
-#endif
-      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 32,
-     .                        "Longitudes de la grille physique")
-      ierr = NF_ENDDEF(nid)
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlon_glo)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlon_glo)
-#endif
-c
-      ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-      ierr = NF_DEF_VAR (nid, "latitude", NF_DOUBLE, 1, idim2,nvarid)
-#else
-      ierr = NF_DEF_VAR (nid, "latitude", NF_FLOAT, 1, idim2,nvarid)
-#endif
-      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 31,
-     .                        "Latitudes de la grille physique")
-      ierr = NF_ENDDEF(nid)
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlat_glo)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlat_glo)
-#endif
+      CALL put_var("controle","Parametres de controle",tab_cntrl)
+c
+
+      CALL put_field("longitude",
+     .               "Longitudes de la grille physique",rlon)
+     
+      CALL put_field("latitude","Latitudes de la grille physique",rlat)
+
 c
 C PB ajout du masque terre/mer
 C
-      ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-      ierr = NF_DEF_VAR (nid, "masque", NF_DOUBLE, 1, idim2,nvarid)
-#else
-      ierr = NF_DEF_VAR (nid, "masque", NF_FLOAT, 1, idim2,nvarid)
-#endif
-      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 16,
-     .                        "masque terre mer")
-      ierr = NF_ENDDEF(nid)
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,masq)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,masq)
-#endif      
+      CALL put_field("masque","masque terre mer",zmasq)
+
 c BP ajout des fraction de chaque sous-surface
 C
 C 1. fraction de terre 
 C
-      ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-      ierr = NF_DEF_VAR (nid, "FTER", NF_DOUBLE, 1, idim2,nvarid)
-#else
-      ierr = NF_DEF_VAR (nid, "FTER", NF_FLOAT, 1, idim2,nvarid)
-#endif
-      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 21,
-     .                        "fraction de continent")
-      ierr = NF_ENDDEF(nid)
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,pctsrf_glo(1 : klon_glo,     &
-     &   is_ter))
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,pctsrf_glo(1 : klon_glo,       &
-     &    is_ter))
-#endif
+      CALL put_field("FTER","fraction de continent",pctsrf(:,is_ter))
 C 
 C 2. Fraction de glace de terre
 C 
-      ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-      ierr = NF_DEF_VAR (nid, "FLIC", NF_DOUBLE, 1, idim2,nvarid)
-#else
-      ierr = NF_DEF_VAR (nid, "FLIC", NF_FLOAT, 1, idim2,nvarid)
-#endif
-      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 24,
-     .                        "fraction glace de terre")
-      ierr = NF_ENDDEF(nid)
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,pctsrf_glo(1 : klon_glo,
-     &                          is_lic))
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,pctsrf_glo(1 : klon_glo, 
-     &                        is_lic))
-#endif
+      CALL put_field("FLIC","fraction glace de terre",pctsrf(:,is_lic))
 C
 C 3. fraction ocean
 C
-      ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-      ierr = NF_DEF_VAR (nid, "FOCE", NF_DOUBLE, 1, idim2,nvarid)
-#else
-      ierr = NF_DEF_VAR (nid, "FOCE", NF_FLOAT, 1, idim2,nvarid)
-#endif
-      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 14,
-     .                        "fraction ocean")
-      ierr = NF_ENDDEF(nid)
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,pctsrf_glo(1 : klon_glo,
-     &                          is_oce))
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,pctsrf_glo(1 : klon_glo,
-     &                        is_oce))
-#endif
+      CALL put_field("FOCE","fraction ocean",pctsrf(:,is_oce))
 C
 C 4. Fraction glace de mer
 C
-      ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-      ierr = NF_DEF_VAR (nid, "FSIC", NF_DOUBLE, 1, idim2,nvarid)
-#else
-      ierr = NF_DEF_VAR (nid, "FSIC", NF_FLOAT, 1, idim2,nvarid)
-#endif
-      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 18,
-     .                        "fraction glace mer")
-      ierr = NF_ENDDEF(nid)
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,pctsrf_glo(1 : klon_glo, 
-     &                          is_sic))
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,pctsrf_glo(1 : klon_glo,
-     &                         is_sic))
-#endif
-C
-C
+      CALL put_field("FSIC","fraction glace mer",pctsrf(:,is_sic))
+C
+C
+c
+      DO nsrf = 1, nbsrf
+        IF (nsrf.LE.99) THEN
+          WRITE(str2,'(i2.2)') nsrf
+          CALL put_field("TS"//str2,"Temperature de surface No."//str2,
+     .                    ftsol(:,nsrf))
+        ELSE
+          PRINT*, "Trop de sous-mailles"
+          CALL abort
+        ENDIF
+      ENDDO
+c
+      DO nsrf = 1, nbsrf
+        DO isoil=1, nsoilmx
+          IF (isoil.LE.99 .AND. nsrf.LE.99) THEN
+            WRITE(str7,'(i2.2,"srf",i2.2)') isoil,nsrf
+            CALL put_field("Tsoil"//str7,"Temperature du sol No."//str7,
+     .                     tsoil(:,isoil,nsrf))
+          ELSE
+            PRINT*, "Trop de couches"
+            CALL abort
+          ENDIF
+        ENDDO
+      ENDDO
+c
+      DO nsrf = 1, nbsrf
+        IF (nsrf.LE.99) THEN
+          WRITE(str2,'(i2.2)') nsrf
+          CALL put_field("QS"//str2,"Humidite de surface No."//str2,
+     .                   qsurf(:,nsrf))
+        ELSE
+          PRINT*, "Trop de sous-mailles"
+          CALL abort
+        ENDIF
+      END DO
+C
+      CALL put_field("QSOL","Eau dans le sol (mm)",qsol)
+c
+      DO nsrf = 1, nbsrf
+        IF (nsrf.LE.99) THEN
+          WRITE(str2,'(i2.2)') nsrf
+          CALL put_field("ALBE"//str2,"albedo de surface No."//str2,
+     .                   falb1(:,nsrf))
+        ELSE
+          PRINT*, "Trop de sous-mailles"
+          CALL abort
+        ENDIF
+      ENDDO
+
+      DO nsrf = 1, nbsrf
+        IF (nsrf.LE.99) THEN
+          WRITE(str2,'(i2.2)') nsrf
+          CALL put_field("ALBLW"//str2,"albedo LW de surface No."//str2,
+     .                   falb2(:,nsrf))
+        ELSE
+          PRINT*, "Trop de sous-mailles"
+          CALL abort
+        ENDIF
+      ENDDO
+c
+c
+      DO nsrf = 1, nbsrf
+        IF (nsrf.LE.99) THEN
+          WRITE(str2,'(i2.2)') nsrf
+          CALL put_field("EVAP"//str2,"Evaporation de surface No."//str2
+     .                   ,evap(:,nsrf))
+        ELSE
+          PRINT*, "Trop de sous-mailles"
+          CALL abort
+        ENDIF
+      ENDDO
+
+c
+      DO nsrf = 1, nbsrf
+        IF (nsrf.LE.99) THEN
+          WRITE(str2,'(i2.2)') nsrf
+          CALL put_field("SNOW"//str2,"Neige de surface No."//str2,
+     .                   snow(:,nsrf))
+        ELSE
+          PRINT*, "Trop de sous-mailles"
+          CALL abort
+        ENDIF
+      ENDDO
+
+c
+      CALL put_field("RADS","Rayonnement net a la surface",radsol)
+c
+      CALL put_field("solsw","Rayonnement solaire a la surface",solsw)
+c
+      CALL put_field("sollw","Rayonnement IF a la surface",sollw)
+c
+      CALL put_field("fder","Derive de flux",fder)
+c
+      CALL put_field("rain_f","precipitation liquide",rain_fall)
+c
+      CALL put_field("snow_f", "precipitation solide",snow_fall)
 c
       DO nsrf = 1, nbsrf
         IF (nsrf.LE.99) THEN
         WRITE(str2,'(i2.2)') nsrf
-        ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-        ierr = NF_DEF_VAR (nid, "TS"//str2, NF_DOUBLE, 1, idim2,nvarid)
-#else
-        ierr = NF_DEF_VAR (nid, "TS"//str2, NF_FLOAT, 1, idim2,nvarid)
-#endif
-        ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 28,
-     .                        "Temperature de surface No."//str2)
-        ierr = NF_ENDDEF(nid)
-        ELSE
-        PRINT*, "Trop de sous-mailles"
-        CALL abort
-        ENDIF
-#ifdef NC_DOUBLE
-        ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tsol_glo(1,nsrf))
-#else
-        ierr = NF_PUT_VAR_REAL (nid,nvarid,tsol_glo(1,nsrf))
-#endif
-      ENDDO
-c
-      DO nsrf = 1, nbsrf
-      DO isoil=1, nsoilmx
-        IF (isoil.LE.99 .AND. nsrf.LE.99) THEN
-        WRITE(str7,'(i2.2,"srf",i2.2)') isoil,nsrf
-        ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-        ierr = NF_DEF_VAR (nid, "Tsoil"//str7,NF_DOUBLE,1,idim2,nvarid)
-#else
-        ierr = NF_DEF_VAR (nid, "Tsoil"//str7,NF_FLOAT,1,idim2,nvarid)
-#endif
-        ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 29,
-     .                        "Temperature du sol No."//str7)
-        ierr = NF_ENDDEF(nid)
-        ELSE
-        PRINT*, "Trop de couches"
-        CALL abort
-        ENDIF
-#ifdef NC_DOUBLE
-        ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tsoil(1,isoil,nsrf))
-#else
-        ierr = NF_PUT_VAR_REAL (nid,nvarid,tsoil(1,isoil,nsrf))
-#endif
-      ENDDO
-      ENDDO
-c
-      DO nsrf = 1, nbsrf
-        IF (nsrf.LE.99) THEN
-        WRITE(str2,'(i2.2)') nsrf
-        ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-        ierr = NF_DEF_VAR (nid,"QS"//str2,NF_DOUBLE,1,idim2,nvarid)
-#else
-        ierr = NF_DEF_VAR (nid,"QS"//str2,NF_FLOAT,1,idim2,nvarid)
-#endif
-        ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 25,
-     .                        "Humidite de surface No."//str2)
-        ierr = NF_ENDDEF(nid)
-        ELSE
-        PRINT*, "Trop de sous-mailles"
-        CALL abort
-        ENDIF
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,qsurf(1,nsrf))
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,qsurf(1,nsrf))
-#endif
-      END DO
-C
-      ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-      ierr = NF_DEF_VAR (nid,"QSOL",NF_DOUBLE,1,idim2,nvarid)
-#else
-      ierr = NF_DEF_VAR (nid,"QSOL",NF_FLOAT,1,idim2,nvarid)
-#endif
-      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 20,
-     .    "Eau dans le sol (mm)")
-      ierr = NF_ENDDEF(nid)
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,qsol)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,qsol)
-#endif
-c
-      DO nsrf = 1, nbsrf
-        IF (nsrf.LE.99) THEN
-        WRITE(str2,'(i2.2)') nsrf
-        ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-        ierr = NF_DEF_VAR (nid,"ALBE"//str2,NF_DOUBLE,1,idim2,nvarid)
-#else
-        ierr = NF_DEF_VAR (nid,"ALBE"//str2,NF_FLOAT,1,idim2,nvarid)
-#endif
-        ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 23,
-     .                        "albedo de surface No."//str2)
-        ierr = NF_ENDDEF(nid)
-        ELSE
-        PRINT*, "Trop de sous-mailles"
-        CALL abort
-        ENDIF
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,alb1_glo(1,nsrf))
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,alb1_glo(1,nsrf))
-#endif
-      ENDDO
-
-        DO nsrf = 1, nbsrf
-        IF (nsrf.LE.99) THEN
-        WRITE(str2,'(i2.2)') nsrf
-        ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-        ierr = NF_DEF_VAR (nid,"ALBLW"//str2,NF_DOUBLE,1,idim2,nvarid)
-#else
-        ierr = NF_DEF_VAR (nid,"ALBLW"//str2,NF_FLOAT,1,idim2,nvarid)
-#endif
-        ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 23,
-     .                        "albedo LW de surface No."//str2)
-        ierr = NF_ENDDEF(nid)
-        ELSE
-        PRINT*, "Trop de sous-mailles"
-        CALL abort
-        ENDIF
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,alb2_glo(1,nsrf))
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,alb2_glo(1,nsrf))
-#endif
-      ENDDO
-c
-c
-      DO nsrf = 1, nbsrf
-        IF (nsrf.LE.99) THEN
-        WRITE(str2,'(i2.2)') nsrf
-        ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-        ierr = NF_DEF_VAR (nid,"EVAP"//str2,NF_DOUBLE,1,idim2,nvarid)
-#else
-        ierr = NF_DEF_VAR (nid,"EVAP"//str2,NF_FLOAT,1,idim2,nvarid)
-#endif
-        ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 28,
-     .                        "Evaporation de surface No."//str2)
-        ierr = NF_ENDDEF(nid)
-        ELSE
-        PRINT*, "Trop de sous-mailles"
-        CALL abort
-        ENDIF
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,evap(1,nsrf))
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,evap(1,nsrf))
-#endif
-      ENDDO
-
-c
-      DO nsrf = 1, nbsrf
-        IF (nsrf.LE.99) THEN
-        WRITE(str2,'(i2.2)') nsrf
-        ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-        ierr = NF_DEF_VAR (nid,"SNOW"//str2,NF_DOUBLE,1,idim2,nvarid)
-#else
-        ierr = NF_DEF_VAR (nid,"SNOW"//str2,NF_FLOAT,1,idim2,nvarid)
-#endif
-        ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 22,
-     .                        "Neige de surface No."//str2)
-        ierr = NF_ENDDEF(nid)
-        ELSE
-        PRINT*, "Trop de sous-mailles"
-        CALL abort
-        ENDIF
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,snow(1,nsrf))
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,snow(1,nsrf))
-#endif
-      ENDDO
-
-c
-      ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-      ierr = NF_DEF_VAR (nid, "RADS", NF_DOUBLE, 1, idim2,nvarid)
-#else
-      ierr = NF_DEF_VAR (nid, "RADS", NF_FLOAT, 1, idim2,nvarid)
-#endif
-      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 28,
-     .                        "Rayonnement net a la surface")
-      ierr = NF_ENDDEF(nid)
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,radsol_glo)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,radsol_glo)
-#endif
-c
-      ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-      ierr = NF_DEF_VAR (nid, "solsw", NF_DOUBLE, 1, idim2,nvarid)
-#else
-      ierr = NF_DEF_VAR (nid, "solsw", NF_FLOAT, 1, idim2,nvarid)
-#endif
-      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 32,
-     .                        "Rayonnement solaire a la surface")
-      ierr = NF_ENDDEF(nid)
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,solsw_glo)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,solsw_glo)
-#endif
-c
-      ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-      ierr = NF_DEF_VAR (nid, "sollw", NF_DOUBLE, 1, idim2,nvarid)
-#else
-      ierr = NF_DEF_VAR (nid, "sollw", NF_FLOAT, 1, idim2,nvarid)
-#endif
-      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 27,
-     .                        "Rayonnement IF a la surface")
-      ierr = NF_ENDDEF(nid)
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,sollw_glo)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,sollw_glo)
-#endif
-c
-      ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-      ierr = NF_DEF_VAR (nid, "fder", NF_DOUBLE, 1, idim2,nvarid)
-#else
-      ierr = NF_DEF_VAR (nid, "fder", NF_FLOAT, 1, idim2,nvarid)
-#endif
-      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 14,
-     .                        "Derive de flux")
-      ierr = NF_ENDDEF(nid)
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,fder)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,fder)
-#endif
-c
-      ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-      ierr = NF_DEF_VAR (nid, "rain_f", NF_DOUBLE, 1, idim2,nvarid)
-#else
-      ierr = NF_DEF_VAR (nid, "rain_f", NF_FLOAT, 1, idim2,nvarid)
-#endif
-      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 21,
-     .                        "precipitation liquide")
-      ierr = NF_ENDDEF(nid)
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rain_fall_glo)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,rain_fall_glo)
-#endif
-c
-      ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-      ierr = NF_DEF_VAR (nid, "snow_f", NF_DOUBLE, 1, idim2,nvarid)
-#else
-      ierr = NF_DEF_VAR (nid, "snow_f", NF_FLOAT, 1, idim2,nvarid)
-#endif
-      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 20,
-     .                        "precipitation solide")
-      ierr = NF_ENDDEF(nid)
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,snow_fall_glo)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,snow_fall_glo)
-#endif
-c
-       endif
-c$OMP END MASTER
-cc ----> necessaire pour eviter bug openMP sur SX6
-c$OMP MASTER
-      if (is_mpi_root) then
-      DO nsrf = 1, nbsrf
-        IF (nsrf.LE.99) THEN
-        WRITE(str2,'(i2.2)') nsrf
-        ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-        ierr = NF_DEF_VAR (nid,"RUG"//str2,NF_DOUBLE,1,idim2,nvarid)
-#else
-        ierr = NF_DEF_VAR (nid,"RUG"//str2,NF_FLOAT,1,idim2,nvarid)
-#endif
-        ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 23,
-     .                        "rugosite de surface No."//str2)
-        ierr = NF_ENDDEF(nid)
-        ELSE
-        PRINT*, "Trop de sous-mailles"
-        CALL abort
-        ENDIF
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,frugs(1,nsrf))
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,frugs(1,nsrf))
-#endif
+          CALL put_field("RUG"//str2,"rugosite de surface No."//str2,
+     .         frugs(:,nsrf))
+        ELSE
+          PRINT*, "Trop de sous-mailles"
+          CALL abort
+        ENDIF
       ENDDO
 c
@@ -629,226 +230,45 @@
         IF (nsrf.LE.99) THEN
             WRITE(str2,'(i2.2)') nsrf
-            ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-            ierr = NF_DEF_VAR (nid,"AGESNO"//str2,NF_DOUBLE,1,idim2
-     $          ,nvarid)
-#else
-            ierr = NF_DEF_VAR (nid,"AGESNO"//str2,NF_FLOAT,1,idim2
-     $          ,nvarid)
-#endif
-            ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 15,
-     .                        "Age de la neige surface No."//str2)
-            ierr = NF_ENDDEF(nid)
+            CALL put_field("AGESNO"//str2,
+     .                     "Age de la neige surface No."//str2,
+     .                     agesno(:,nsrf))
         ELSE
             PRINT*, "Trop de sous-mailles"
             CALL abort
         ENDIF
-#ifdef NC_DOUBLE
-        ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,agesno(1,nsrf))
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,agesno(1,nsrf))
-#endif
-      ENDDO
-c
-      ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-      ierr = NF_DEF_VAR (nid, "ZMEA", NF_DOUBLE, 1, idim2,nvarid)
-#else
-      ierr = NF_DEF_VAR (nid, "ZMEA", NF_FLOAT, 1, idim2,nvarid)
-#endif
-      ierr = NF_ENDDEF(nid)
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zmea_glo)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,zmea_glo)
-#endif
-c
-      ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-      ierr = NF_DEF_VAR (nid, "ZSTD", NF_DOUBLE, 1, idim2,nvarid)
-#else
-      ierr = NF_DEF_VAR (nid, "ZSTD", NF_FLOAT, 1, idim2,nvarid)
-#endif
-      ierr = NF_ENDDEF(nid)
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zstd_glo)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,zstd_glo)
-#endif
-      ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-      ierr = NF_DEF_VAR (nid, "ZSIG", NF_DOUBLE, 1, idim2,nvarid)
-#else
-      ierr = NF_DEF_VAR (nid, "ZSIG", NF_FLOAT, 1, idim2,nvarid)
-#endif
-      ierr = NF_ENDDEF(nid)
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zsig_glo)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,zsig_glo)
-#endif
-      ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-      ierr = NF_DEF_VAR (nid, "ZGAM", NF_DOUBLE, 1, idim2,nvarid)
-#else
-      ierr = NF_DEF_VAR (nid, "ZGAM", NF_FLOAT, 1, idim2,nvarid)
-#endif
-      ierr = NF_ENDDEF(nid)
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zgam_glo)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,zgam_glo)
-#endif
-      ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-      ierr = NF_DEF_VAR (nid, "ZTHE", NF_DOUBLE, 1, idim2,nvarid)
-#else
-      ierr = NF_DEF_VAR (nid, "ZTHE", NF_FLOAT, 1, idim2,nvarid)
-#endif
-      ierr = NF_ENDDEF(nid)
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zthe_glo)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,zthe_glo)
-#endif
-      ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-      ierr = NF_DEF_VAR (nid, "ZPIC", NF_DOUBLE, 1, idim2,nvarid)
-#else
-      ierr = NF_DEF_VAR (nid, "ZPIC", NF_FLOAT, 1, idim2,nvarid)
-#endif
-      ierr = NF_ENDDEF(nid)
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zpic_glo)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,zpic_glo)
-#endif
-      ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-      ierr = NF_DEF_VAR (nid, "ZVAL", NF_DOUBLE, 1, idim2,nvarid)
-#else
-      ierr = NF_DEF_VAR (nid, "ZVAL", NF_FLOAT, 1, idim2,nvarid)
-#endif
-      ierr = NF_ENDDEF(nid)
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zval_glo)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,zval_glo)
-#endif
-      ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-      ierr = NF_DEF_VAR (nid, "RUGSREL", NF_DOUBLE, 1, idim2,nvarid)
-#else
-      ierr = NF_DEF_VAR (nid, "RUGSREL", NF_FLOAT, 1, idim2,nvarid)
-#endif
-      ierr = NF_ENDDEF(nid)
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rugsrel_glo)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,rugsrel_glo)
-#endif
-c
-      ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-      ierr = NF_DEF_VAR (nid, "TANCIEN", NF_DOUBLE, 1, idim3,nvarid)
-#else
-      ierr = NF_DEF_VAR (nid, "TANCIEN", NF_FLOAT, 1, idim3,nvarid)
-#endif
-      ierr = NF_ENDDEF(nid)
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,t_ancien_glo)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,t_ancien_glo)
-#endif
-c
-      ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-      ierr = NF_DEF_VAR (nid, "QANCIEN", NF_DOUBLE, 1, idim3,nvarid)
-#else
-      ierr = NF_DEF_VAR (nid, "QANCIEN", NF_FLOAT, 1, idim3,nvarid)
-#endif
-      ierr = NF_ENDDEF(nid)
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,q_ancien_glo)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,q_ancien_glo)
-#endif
-c
-      ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-      ierr = NF_DEF_VAR (nid, "RUGMER", NF_DOUBLE, 1, idim2,nvarid)
-#else
-      ierr = NF_DEF_VAR (nid, "RUGMER", NF_FLOAT, 1, idim2,nvarid)
-#endif
-      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 28,
-     .                        "Longueur de rugosite sur mer")
-      ierr = NF_ENDDEF(nid)
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,frugs(1,is_oce))
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,frugs(1,is_oce))
-#endif
-c
-      ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-      ierr = NF_DEF_VAR (nid, "CLWCON", NF_DOUBLE, 1, idim2,nvarid)
-#else
-      ierr = NF_DEF_VAR (nid, "CLWCON", NF_FLOAT, 1, idim2,nvarid)
-#endif
-      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 28,
-     .                        "Eau liquide convective")
-      ierr = NF_ENDDEF(nid)
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,clwcon_glo)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,clwcon_glo)
-#endif
-c
-      ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-      ierr = NF_DEF_VAR (nid, "RNEBCON", NF_DOUBLE, 1, idim2,nvarid)
-#else
-      ierr = NF_DEF_VAR (nid, "RNEBCON", NF_FLOAT, 1, idim2,nvarid)
-#endif
-      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 28,
-     .                        "Nebulosite convective")
-      ierr = NF_ENDDEF(nid)
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rnebcon_glo)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,rnebcon_glo)
-#endif
-c
-      ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-      ierr = NF_DEF_VAR (nid, "RATQS", NF_DOUBLE, 1, idim2,nvarid)
-#else
-      ierr = NF_DEF_VAR (nid, "RATQS", NF_FLOAT, 1, idim2,nvarid)
-#endif
-      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 28,
-     .                        "Ratqs")
-      ierr = NF_ENDDEF(nid)
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ratqs_glo)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,ratqs_glo)
-#endif
+      ENDDO
+c
+      CALL put_field("ZMEA","",zmea)
+c
+      CALL put_field("ZSTD","",zstd)
+      
+      CALL put_field("ZSIG","",zsig)
+      
+      CALL put_field("ZGAM","",zgam)
+      
+      CALL put_field("ZTHE","",zthe)
+      
+      CALL put_field("ZPIC","",zpic)
+      
+      CALL put_field("ZVAL","",zval)
+      
+      CALL put_field("RUGSREL","RUGSREL",rugoro)
+      
+      CALL put_field("TANCIEN","",t_ancien)
+      
+      CALL put_field("QANCIEN","",q_ancien)
+      
+      CALL put_field("RUGMER","Longueur de rugosite sur mer",
+     .               frugs(:,is_oce))
+      
+      CALL put_field("CLWCON","Eau liquide convective",clwcon(:,1))
+      
+      CALL put_field("RNEBCON","Nebulosite convective",rnebcon(:,1))
+      
+      CALL put_field("RATQS", "Ratqs",ratqs(:,1))
 c
 c run_off_lic_0
 c
-      ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-      ierr=NF_DEF_VAR(nid,"RUNOFFLIC0",NF_DOUBLE,1,idim2,nvarid)
-#else
-      ierr=NF_DEF_VAR(nid,"RUNOFFLIC0",NF_FLOAT, 1,idim2,nvarid)
-#endif
-      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 10,
-     .                        "Runofflic0")
-      ierr = NF_ENDDEF(nid)
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,run_off_lic_0)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,run_off_lic_0)
-#endif
+      CALL put_field("RUNOFFLIC0","Runofflic0",run_off_lic_0)
 c
 c
@@ -856,28 +276,14 @@
 c
       IF (iflag_pbl>1) then
-      DO nsrf = 1, nbsrf
-        IF (nsrf.LE.99) THEN
+        DO nsrf = 1, nbsrf
+          IF (nsrf.LE.99) THEN
             WRITE(str2,'(i2.2)') nsrf
-            ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-            ierr = NF_DEF_VAR (nid,"TKE"//str2,NF_DOUBLE,1,idim3
-     $          ,nvarid)
-#else
-            ierr = NF_DEF_VAR (nid,"TKE"//str2,NF_FLOAT,1,idim3
-     $          ,nvarid)
-#endif
-            ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 15,
-     .                        "Energ. Cineti. Turb."//str2)
-            ierr = NF_ENDDEF(nid)
-        ELSE
+            CALL put_field("TKE"//str2,"Energ. Cineti. Turb."//str2,
+     .                     pbl_tke(:,1:klev,nsrf))
+          ELSE
             PRINT*, "Trop de sous-mailles"
             CALL abort
-        ENDIF
-#ifdef NC_DOUBLE
-        ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,pbl_tke_glo(:,:,nsrf))
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,pbl_tke_glo(:,:,nsrf))
-#endif
-      ENDDO
+          ENDIF
+        ENDDO
       ENDIF
 
@@ -885,125 +291,26 @@
 cIM ajout zmax0, f0, ema_work1, ema_work2
 cIM wake_deltat, wake_deltaq, wake_s, wake_cstar, wake_fip
-      ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-      ierr = NF_DEF_VAR (nid, "ZMAX0", NF_DOUBLE, 1, idim2,nvarid)
-#else
-      ierr = NF_DEF_VAR (nid, "ZMAX0", NF_FLOAT, 1, idim2,nvarid)
-#endif
-      ierr = NF_ENDDEF(nid)
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zmax0_glo)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,zmax0_glo)
-#endif
-c
-      ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-      ierr = NF_DEF_VAR (nid, "F0", NF_DOUBLE, 1, idim2,nvarid)
-#else
-      ierr = NF_DEF_VAR (nid, "F0", NF_FLOAT, 1, idim2,nvarid)
-#endif
-      ierr = NF_ENDDEF(nid)
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,f0_glo)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,f0_glo)
-#endif
-c ema_work1
-      ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-      ierr = NF_DEF_VAR (nid, "EMA_WORK1", NF_DOUBLE, 1, idim3,nvarid)
-#else
-      ierr = NF_DEF_VAR (nid, "EMA_WORK1", NF_FLOAT, 1, idim3,nvarid)
-#endif
-      ierr = NF_ENDDEF(nid)
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ema_work1_glo)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,ema_work1_glo)
-#endif
-c ema_work2
-      ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-      ierr = NF_DEF_VAR (nid, "EMA_WORK2", NF_DOUBLE, 1, idim3,nvarid)
-#else
-      ierr = NF_DEF_VAR (nid, "EMA_WORK2", NF_FLOAT, 1, idim3,nvarid)
-#endif
-      ierr = NF_ENDDEF(nid)
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ema_work2_glo)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,ema_work2_glo)
-#endif
+      
+      CALL put_field("ZMAX0","",zmax0)
+      
+      CALL put_field("F0","",f0)
+      
+      CALL put_field("EMA_WORK1","",ema_work1)
+      
+      CALL put_field("EMA_WORK2","",ema_work2)
+      
 c wake_deltat
-      ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-      ierr = NF_DEF_VAR (nid, "WAKE_DELTAT", NF_DOUBLE, 1, idim3,nvarid)
-#else
-      ierr = NF_DEF_VAR (nid, "WAKE_DELTAT", NF_FLOAT, 1, idim3,nvarid)
-#endif
-      ierr = NF_ENDDEF(nid)
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,wake_deltat_glo)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,wake_deltat_glo)
-#endif
-c wake_deltaq
-      ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-      ierr = NF_DEF_VAR (nid, "WAKE_DELTAQ", NF_DOUBLE, 1, idim3,nvarid)
-#else
-      ierr = NF_DEF_VAR (nid, "WAKE_DELTAQ", NF_FLOAT, 1, idim3,nvarid)
-#endif
-      ierr = NF_ENDDEF(nid)
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,wake_deltaq_glo)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,wake_deltaq_glo)
-#endif
-c wake_s
-      ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-      ierr = NF_DEF_VAR (nid, "WAKE_S", NF_DOUBLE, 1, idim2,nvarid)
-#else
-      ierr = NF_DEF_VAR (nid, "WAKE_S", NF_FLOAT, 1, idim2,nvarid)
-#endif
-      ierr = NF_ENDDEF(nid)
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,wake_s_glo)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,wake_s_glo)
-#endif
-c wake_cstar
-      ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-      ierr = NF_DEF_VAR (nid, "WAKE_CSTAR", NF_DOUBLE, 1, idim2,nvarid)
-#else
-      ierr = NF_DEF_VAR (nid, "WAKE_CSTAR", NF_FLOAT, 1, idim2,nvarid)
-#endif
-      ierr = NF_ENDDEF(nid)
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,wake_cstar_glo)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,wake_cstar_glo)
-#endif
-c wake_fip
-      ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-      ierr = NF_DEF_VAR (nid, "WAKE_FIP", NF_DOUBLE, 1, idim2,nvarid)
-#else
-      ierr = NF_DEF_VAR (nid, "WAKE_FIP", NF_FLOAT, 1, idim2,nvarid)
-#endif
-      ierr = NF_ENDDEF(nid)
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,wake_fip_glo)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,wake_fip_glo)
-#endif
-c
-      ierr = NF_CLOSE(nid)
-c
-      endif   ! is_mpi_root
-c$OMP END MASTER
+      CALL put_field("WAKE_DELTAT","",wake_deltat)
+
+      CALL put_field("WAKE_DELTAQ","",wake_deltaq)
+      
+      CALL put_field("WAKE_S","",wake_s)
+      
+      CALL put_field("WAKE_CSTAR","",wake_cstar)
+      
+      CALL put_field("WAKE_FIP","",wake_fip)
+
+      CALL close_restartphy
+!$OMP BARRIER
       RETURN
       END
Index: /LMDZ4/trunk/libf/phylmd/phys_local_var_mod.F90
===================================================================
--- /LMDZ4/trunk/libf/phylmd/phys_local_var_mod.F90	(revision 1000)
+++ /LMDZ4/trunk/libf/phylmd/phys_local_var_mod.F90	(revision 1001)
@@ -51,4 +51,12 @@
       REAL, SAVE, ALLOCATABLE :: d_u_lif(:,:), d_v_lif(:,:)
       !$OMP THREADPRIVATE(d_u_lif, d_v_lif)
+! Tendances Ondes de G non oro (runs strato).
+      REAL, SAVE, ALLOCATABLE :: d_u_hin(:,:)
+      !$OMP THREADPRIVATE(d_u_hin)
+      REAL, SAVE, ALLOCATABLE :: d_v_hin(:,:)
+      !$OMP THREADPRIVATE(d_v_hin)
+      REAL, SAVE, ALLOCATABLE :: d_t_hin(:,:)
+      !$OMP THREADPRIVATE(d_t_hin)
+
 ! tendance du a la conersion Ec -> E thermique
       REAL, SAVE, ALLOCATABLE :: d_t_ec(:,:)
Index: /LMDZ4/trunk/libf/phylmd/physiq.F
===================================================================
--- /LMDZ4/trunk/libf/phylmd/physiq.F	(revision 1000)
+++ /LMDZ4/trunk/libf/phylmd/physiq.F	(revision 1001)
@@ -94,5 +94,5 @@
 #include "clesphys.h"
 #include "control.h"
-#include "logic.h"
+!#include "logic.h"
 #include "temps.h"
 cym#include "comgeomphy.h"
@@ -943,4 +943,5 @@
       REAL zustrli(klon), zvstrli(klon)
       REAL zustrph(klon), zvstrph(klon)
+      REAL zustrhi(klon), zvstrhi(klon)
       REAL aam, torsfc
 cIM 141004 END
@@ -1377,6 +1378,10 @@
 !           ENDDO
 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-           CALL SUGWD(klon,klev,paprs,pplay)
+           IF (ok_strato) THEN
+             CALL SUGWD_strato(klon,klev,paprs,pplay)
+           ELSE
+             CALL SUGWD(klon,klev,paprs,pplay)
+           ENDIF
+           
            DO i=1,klon
              zuthe(i)=0.
@@ -2932,11 +2937,21 @@
 c        igwdim=MAX(1,igwd)
 c
+        IF (ok_strato) THEN
+        
+          CALL drag_noro_strato(klon,klev,dtime,paprs,pplay,
+     e                   zmea,zstd, zsig, zgam, zthe,zpic,zval,
+     e                   igwd,idx,itest,
+     e                   t_seri, u_seri, v_seri,
+     s                   zulow, zvlow, zustrdr, zvstrdr,
+     s                   d_t_oro, d_u_oro, d_v_oro)
+
+       ELSE
         CALL drag_noro(klon,klev,dtime,paprs,pplay,
      e                   zmea,zstd, zsig, zgam, zthe,zpic,zval,
      e                   igwd,idx,itest,
      e                   t_seri, u_seri, v_seri,
-cIM 141004    s                   zulow, zvlow, zustr, zvstr,
      s                   zulow, zvlow, zustrdr, zvstrdr,
      s                   d_t_oro, d_u_oro, d_v_oro)
+       ENDIF
 c
 c  ajout des tendances
@@ -2969,5 +2984,15 @@
 c        igwdim=MAX(1,igwd)
 c
-        CALL lift_noro(klon,klev,dtime,paprs,pplay,
+        IF (ok_strato) THEN
+
+          CALL lift_noro_strato(klon,klev,dtime,paprs,pplay,
+     e                   rlat,zmea,zstd,zpic,zgam,zthe,zpic,zval,
+     e                   igwd,idx,itest,
+     e                   t_seri, u_seri, v_seri,
+     s                   zulow, zvlow, zustrli, zvstrli,
+     s                   d_t_lif, d_u_lif, d_v_lif               )
+        
+        ELSE
+          CALL lift_noro(klon,klev,dtime,paprs,pplay,
      e                   rlat,zmea,zstd,zpic,
      e                   itest,
@@ -2975,5 +3000,6 @@
      s                   zulow, zvlow, zustrli, zvstrli,
      s                   d_t_lif, d_u_lif, d_v_lif)
-c
+       ENDIF
+c   
 !-----------------------------------------------------------------------------------------
 ! ajout des tendances de la portance de l'orographie
@@ -2982,4 +3008,19 @@
 c
       ENDIF ! fin de test sur ok_orolf
+C  HINES GWD PARAMETRIZATION
+
+       IF (ok_hines) then
+
+         CALL hines_gwd(klon,klev,dtime,paprs,pplay,
+     i                  rlat,t_seri,u_seri,v_seri,
+     o                  zustrhi,zvstrhi,
+     o                  d_t_hin, d_u_hin, d_v_hin)
+c
+c  ajout des tendances
+        CALL add_phys_tend(d_u_hin,d_v_hin,d_t_hin,dq0,dql0,'lif')
+
+      ENDIF
+c
+
 c
 cIM cf. FLott BEG
@@ -3368,7 +3409,7 @@
          itau_phy = itau_phy + itap
          CALL phyredem ("restartphy.nc")
-         open(97,form="unformatted",file="finbin")
-         write(97) u_seri,v_seri,t_seri,q_seri
-         close(97)
+!         open(97,form="unformatted",file="finbin")
+!         write(97) u_seri,v_seri,t_seri,q_seri
+!         close(97)
       ENDIF
       
Index: /LMDZ4/trunk/libf/phylmd/surf_land_orchidee_mod.F90
===================================================================
--- /LMDZ4/trunk/libf/phylmd/surf_land_orchidee_mod.F90	(revision 1000)
+++ /LMDZ4/trunk/libf/phylmd/surf_land_orchidee_mod.F90	(revision 1001)
@@ -480,5 +480,5 @@
   USE  mod_surf_para
       
-#ifdef CPP_PARA
+#ifdef CPP_MPI
     INCLUDE 'mpif.h'
 #endif    
@@ -502,5 +502,5 @@
       ENDIF
     
-#ifdef CPP_PARA    
+#ifdef CPP_MPI    
       CALL MPI_COMM_SPLIT(COMM_LMDZ_PHY,color,mpi_rank,orch_comm,ierr)
 #endif
@@ -529,5 +529,5 @@
     INCLUDE "indicesol.h"
 
-#ifdef CPP_PARA
+#ifdef CPP_MPI
     INCLUDE 'mpif.h'
 #endif    
