Gaelle 19/01/2016 : supression caracteres windows
authorGaelle Tanguy <gaelle.tanguy@meteo.fr>
Tue, 19 Jan 2016 11:00:39 +0000 (11:00 +0000)
committerPhilippe WAUTELET <philippe.wautelet@aero.obs-mip.fr>
Thu, 19 May 2016 14:44:49 +0000 (16:44 +0200)
32 files changed:
src/MNH/cart_compress.f90
src/MNH/fill_sonfieldn.f90
src/MNH/fill_zsmtn.f90
src/MNH/get_nb_procio_read_mnh.f90
src/MNH/get_nb_procio_write_mnh.f90
src/MNH/open_nestpgd_files.f90
src/SURFEX/build_emisstabn.F90
src/SURFEX/ch_emission_fluxn.F90
src/SURFEX/ch_init_snapn.F90
src/SURFEX/mode_read_extern.F90
src/SURFEX/prep_isba_extern.F90
src/SURFEX/prep_teb_extern.F90
src/SURFEX/prep_teb_garden_extern.F90
src/SURFEX/prep_teb_greenroof_extern.F90
src/SURFEX/read_gr_snow.F90
src/SURFEX/read_isban.F90
src/SURFEX/read_pgd_isba_parn.F90
src/SURFEX/read_surf_field2d.F90
src/SURFEX/read_surf_field3d.F90
src/SURFEX/read_surf_isba_parn.F90
src/SURFEX/regular_grid_spawn.F90
src/SURFEX/write_diag_misc_isban.F90
src/SURFEX/write_diag_pgd_isban.F90
src/SURFEX/write_diag_seb_isban.F90
src/SURFEX/write_surf_field2d.F90
src/SURFEX/write_surf_field3d.F90
src/SURFEX/writesurf_ch_emisn.F90
src/SURFEX/writesurf_gr_snow.F90
src/SURFEX/writesurf_isban.F90
src/SURFEX/writesurf_pgd_isba_parn.F90
src/SURFEX/writesurf_pgd_isban.F90
src/SURFEX/writesurf_snapn.F90

index 1461c92..d1e922e 100644 (file)
-!MNH_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier\r
-!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence\r
-!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt  \r
-!MNH_LIC for details. version 1.\r
-!-----------------------------------------------------------------\r
-!--------------- special set of characters for RCS information\r
-!-----------------------------------------------------------------\r
-! $Source$ $Revision$\r
-! masdev4_7 BUG2 2007/06/29 16:52:14\r
-!-----------------------------------------------------------------\r
-!#########################\r
- MODULE MODI_CART_COMPRESS\r
-!#########################\r
-!\r
-INTERFACE\r
-!\r
-FUNCTION CART_COMPRESS(PVARS) RESULT(PCOMPRESS)\r
-!\r
-USE MODD_BUDGET\r
-!\r
-REAL, DIMENSION(:,:,:), INTENT(IN)       :: PVARS     ! Source\r
-REAL, DIMENSION(NBUIMAX,NBUJMAX,NBUKMAX) :: PCOMPRESS ! result\r
-!\r
-END FUNCTION CART_COMPRESS\r
-!\r
-END INTERFACE\r
-!\r
-END MODULE MODI_CART_COMPRESS\r
-!     ###############################################\r
-      FUNCTION CART_COMPRESS(PVARS) RESULT(PCOMPRESS) \r
-!     ###############################################\r
-!\r
-!!****  *CART_COMPRESS* - function to compress the Source in CART case. \r
-!!                           \r
-!!\r
-!!    PURPOSE\r
-!!    -------\r
-!       This function compresses or not the Source XVARS of the VARiable\r
-!     VAR whose budget is analysed. This compression is controlled by 3 \r
-!     logical switches for the budget in I,J and K directions (LBU_ICP,\r
-!     LBU_JCP, LBU_KCP), in the budget box described by the lowest and\r
-!     highest values of the I,J and K indices.  \r
-!\r
-!!**  METHOD\r
-!!    ------\r
-!!      The source PVARS is first transfered in a local array whose \r
-!!    dimensions correspond to the budget box. Then compressions\r
-!!    are or aren't achieved depending on the logical switches.\r
-!!\r
-!!    EXTERNAL\r
-!!    --------\r
-!!       NONE\r
-!!\r
-!!    IMPLICIT ARGUMENTS\r
-!!    ------------------\r
-!!       Module MODD_BUDGET\r
-!!           LBU_ICP   : switch for compression in I direction\r
-!!           LBU_JCP   : switch for compression in J direction\r
-!!           LBU_KCP   : switch for compression in K direction\r
-!!           NBUIL     : lowest I indice value of the budget box\r
-!!           NBUJL     : lowest J indice value of the budget box\r
-!!           NBUKL     : lowest K indice value of the budget box\r
-!!           NBUIH     : highest I indice value of the budget box\r
-!!           NBUJH     : highest J indice value of the budget box\r
-!!           NBUKH     : highest K indice value of the budget box\r
-!!           NBUIMAX   : dimension along I of the budget tabular\r
-!!           NBUJMAX   : dimension along J of the budget tabular\r
-!!           NBUKMAX   : dimension along K of the budget tabular\r
-!!          \r
-!!\r
-!!\r
-!!    REFERENCE\r
-!!    ---------\r
-!!      Book2 of MESO-NH documentation (function CART_COMPRESS)\r
-!!\r
-!!\r
-!!    AUTHOR\r
-!!    ------\r
-!!     J. Nicolau       * Meteo France *\r
-!!\r
-!!    MODIFICATIONS\r
-!!    -------------\r
-!!      Original             27/02/95\r
-!!      JP Pinty & J Escobar 12/10/98 Enable vectorization and remove \r
-!!                                     SUM functions\r
-!!      V. Ducrocq           4/06/99  //\r
-!!\r
-!-------------------------------------------------------------------------------\r
-!\r
-!*       0.    DECLARATIONS\r
-!              ------------\r
-!\r
-USE MODD_BUDGET\r
-USE MODD_PARAMETERS , ONLY : JPVEXT\r
-!\r
-!\r
-IMPLICIT NONE\r
-!  \r
-!  \r
-!*       0.1   Declarations of arguments and result :\r
-!\r
-REAL, DIMENSION(:,:,:), INTENT(IN)       :: PVARS     ! Source \r
-REAL, DIMENSION(NBUIMAX,NBUJMAX,NBUKMAX) :: PCOMPRESS ! result\r
-!\r
-!*       0.2   Declarations of local variables :\r
-! \r
-! \r
-REAL, DIMENSION (NBUSIH-NBUSIL+1,NBUSJH-NBUSJL+1,NBUKH-NBUKL+1) :: ZVARS ! 3D Work \r
-                                                                     ! array\r
-REAL, DIMENSION (NBUSIH-NBUSIL+1,NBUKH-NBUKL+1) :: ZWORKIK ! 2D Work array\r
-REAL, DIMENSION (NBUSJH-NBUSJL+1,NBUKH-NBUKL+1) :: ZWORKJK ! 2D Work array\r
-REAL, DIMENSION (NBUSIH-NBUSIL+1,NBUSJH-NBUSJL+1) :: ZWORKIJ ! 2D Work array\r
-! \r
-INTEGER                                          :: JJ,JK   ! loop indexes \r
-! \r
-!\r
-!-------------------------------------------------------------------------------\r
-!\r
-!*      1.     SOURCE TRANSFERT IN A LOCAL ARRAY \r
-!              ---------------------------------\r
-!JUAN\r
-IF (SIZE (PCOMPRESS) .EQ. 0 ) RETURN\r
-!JUAN\r
-!\r
-ZVARS(1:NBUSIH-NBUSIL+1,1:NBUSJH-NBUSJL+1,1:NBUKH-NBUKL+1) = &\r
-            PVARS(NBUSIL:NBUSIH,NBUSJL:NBUSJH,NBUKL+JPVEXT:NBUKH+JPVEXT)\r
-!\r
-!-------------------------------------------------------------------------------\r
-!\r
-!*       2.     COMPRESSIONS IN I,J AND K DIRECTIONS\r
-!              ------------------------------------\r
-!                                 \r
-!\r
-IF (LBU_ICP.AND.LBU_JCP.AND.LBU_KCP) THEN\r
-  PCOMPRESS(1,1,1)=SUM(ZVARS)\r
-!\r
-ELSE IF (LBU_ICP.AND.LBU_JCP.AND..NOT.LBU_KCP) THEN\r
-  ZWORKJK(:,:)    =SUM(ZVARS,1)\r
-  PCOMPRESS(1,1,:)=SUM(ZWORKJK,1)\r
-!\r
-ELSE IF (LBU_ICP.AND..NOT.LBU_JCP.AND.LBU_KCP) THEN\r
-  ZWORKIJ(:,:)=0.0\r
-  DO JK = 1,NBUKH-NBUKL+1\r
-    ZWORKIJ(:,:) = ZWORKIJ(:,:) + ZVARS(:,:,JK)\r
-  END DO\r
-  PCOMPRESS(1,:,1)=SUM(ZWORKIJ,1)\r
-!\r
-ELSE IF (.NOT.LBU_ICP.AND.LBU_JCP.AND.LBU_KCP) THEN\r
-  ZWORKIK(:,:)=0.0\r
-  DO JJ = 1,NBUSJH-NBUSJL+1\r
-    ZWORKIK(:,:) = ZWORKIK(:,:) + ZVARS(:,JJ,:)\r
-  END DO\r
-  PCOMPRESS(:,1,1)=SUM(ZWORKIK,2)\r
-!\r
-ELSE IF (LBU_ICP.AND..NOT.LBU_JCP.AND..NOT.LBU_KCP) THEN \r
-  PCOMPRESS(1,:,:)=SUM(ZVARS,1)\r
-!\r
-ELSE IF (.NOT.LBU_ICP.AND.LBU_JCP.AND..NOT.LBU_KCP) THEN\r
-  PCOMPRESS(:,1,:)=SUM(ZVARS,2)\r
-!\r
-ELSE IF (.NOT.LBU_ICP.AND..NOT.LBU_JCP.AND.LBU_KCP) THEN\r
-  PCOMPRESS(:,:,1)=SUM(ZVARS,3)\r
-!\r
-ELSE  \r
-  PCOMPRESS=ZVARS\r
-!\r
-END IF\r
-!\r
-!\r
-END FUNCTION CART_COMPRESS                           \r
+!MNH_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
+!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
+!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt  
+!MNH_LIC for details. version 1.
+!-----------------------------------------------------------------
+!--------------- special set of characters for RCS information
+!-----------------------------------------------------------------
+! $Source$ $Revision$
+! masdev4_7 BUG2 2007/06/29 16:52:14
+!-----------------------------------------------------------------
+!#########################
+ MODULE MODI_CART_COMPRESS
+!#########################
+!
+INTERFACE
+!
+FUNCTION CART_COMPRESS(PVARS) RESULT(PCOMPRESS)
+!
+USE MODD_BUDGET
+!
+REAL, DIMENSION(:,:,:), INTENT(IN)       :: PVARS     ! Source
+REAL, DIMENSION(NBUIMAX,NBUJMAX,NBUKMAX) :: PCOMPRESS ! result
+!
+END FUNCTION CART_COMPRESS
+!
+END INTERFACE
+!
+END MODULE MODI_CART_COMPRESS
+!     ###############################################
+      FUNCTION CART_COMPRESS(PVARS) RESULT(PCOMPRESS) 
+!     ###############################################
+!
+!!****  *CART_COMPRESS* - function to compress the Source in CART case. 
+!!                           
+!!
+!!    PURPOSE
+!!    -------
+!       This function compresses or not the Source XVARS of the VARiable
+!     VAR whose budget is analysed. This compression is controlled by 3 
+!     logical switches for the budget in I,J and K directions (LBU_ICP,
+!     LBU_JCP, LBU_KCP), in the budget box described by the lowest and
+!     highest values of the I,J and K indices.  
+!
+!!**  METHOD
+!!    ------
+!!      The source PVARS is first transfered in a local array whose 
+!!    dimensions correspond to the budget box. Then compressions
+!!    are or aren't achieved depending on the logical switches.
+!!
+!!    EXTERNAL
+!!    --------
+!!       NONE
+!!
+!!    IMPLICIT ARGUMENTS
+!!    ------------------
+!!       Module MODD_BUDGET
+!!           LBU_ICP   : switch for compression in I direction
+!!           LBU_JCP   : switch for compression in J direction
+!!           LBU_KCP   : switch for compression in K direction
+!!           NBUIL     : lowest I indice value of the budget box
+!!           NBUJL     : lowest J indice value of the budget box
+!!           NBUKL     : lowest K indice value of the budget box
+!!           NBUIH     : highest I indice value of the budget box
+!!           NBUJH     : highest J indice value of the budget box
+!!           NBUKH     : highest K indice value of the budget box
+!!           NBUIMAX   : dimension along I of the budget tabular
+!!           NBUJMAX   : dimension along J of the budget tabular
+!!           NBUKMAX   : dimension along K of the budget tabular
+!!          
+!!
+!!
+!!    REFERENCE
+!!    ---------
+!!      Book2 of MESO-NH documentation (function CART_COMPRESS)
+!!
+!!
+!!    AUTHOR
+!!    ------
+!!     J. Nicolau       * Meteo France *
+!!
+!!    MODIFICATIONS
+!!    -------------
+!!      Original             27/02/95
+!!      JP Pinty & J Escobar 12/10/98 Enable vectorization and remove 
+!!                                     SUM functions
+!!      V. Ducrocq           4/06/99  //
+!!
+!-------------------------------------------------------------------------------
+!
+!*       0.    DECLARATIONS
+!              ------------
+!
+USE MODD_BUDGET
+USE MODD_PARAMETERS , ONLY : JPVEXT
+!
+!
+IMPLICIT NONE
+!  
+!  
+!*       0.1   Declarations of arguments and result :
+!
+REAL, DIMENSION(:,:,:), INTENT(IN)       :: PVARS     ! Source 
+REAL, DIMENSION(NBUIMAX,NBUJMAX,NBUKMAX) :: PCOMPRESS ! result
+!
+!*       0.2   Declarations of local variables :
+! 
+! 
+REAL, DIMENSION (NBUSIH-NBUSIL+1,NBUSJH-NBUSJL+1,NBUKH-NBUKL+1) :: ZVARS ! 3D Work 
+                                                                     ! array
+REAL, DIMENSION (NBUSIH-NBUSIL+1,NBUKH-NBUKL+1) :: ZWORKIK ! 2D Work array
+REAL, DIMENSION (NBUSJH-NBUSJL+1,NBUKH-NBUKL+1) :: ZWORKJK ! 2D Work array
+REAL, DIMENSION (NBUSIH-NBUSIL+1,NBUSJH-NBUSJL+1) :: ZWORKIJ ! 2D Work array
+! 
+INTEGER                                          :: JJ,JK   ! loop indexes 
+! 
+!
+!-------------------------------------------------------------------------------
+!
+!*      1.     SOURCE TRANSFERT IN A LOCAL ARRAY 
+!              ---------------------------------
+!JUAN
+IF (SIZE (PCOMPRESS) .EQ. 0 ) RETURN
+!JUAN
+!
+ZVARS(1:NBUSIH-NBUSIL+1,1:NBUSJH-NBUSJL+1,1:NBUKH-NBUKL+1) = &
+            PVARS(NBUSIL:NBUSIH,NBUSJL:NBUSJH,NBUKL+JPVEXT:NBUKH+JPVEXT)
+!
+!-------------------------------------------------------------------------------
+!
+!*       2.     COMPRESSIONS IN I,J AND K DIRECTIONS
+!              ------------------------------------
+!                                 
+!
+IF (LBU_ICP.AND.LBU_JCP.AND.LBU_KCP) THEN
+  PCOMPRESS(1,1,1)=SUM(ZVARS)
+!
+ELSE IF (LBU_ICP.AND.LBU_JCP.AND..NOT.LBU_KCP) THEN
+  ZWORKJK(:,:)    =SUM(ZVARS,1)
+  PCOMPRESS(1,1,:)=SUM(ZWORKJK,1)
+!
+ELSE IF (LBU_ICP.AND..NOT.LBU_JCP.AND.LBU_KCP) THEN
+  ZWORKIJ(:,:)=0.0
+  DO JK = 1,NBUKH-NBUKL+1
+    ZWORKIJ(:,:) = ZWORKIJ(:,:) + ZVARS(:,:,JK)
+  END DO
+  PCOMPRESS(1,:,1)=SUM(ZWORKIJ,1)
+!
+ELSE IF (.NOT.LBU_ICP.AND.LBU_JCP.AND.LBU_KCP) THEN
+  ZWORKIK(:,:)=0.0
+  DO JJ = 1,NBUSJH-NBUSJL+1
+    ZWORKIK(:,:) = ZWORKIK(:,:) + ZVARS(:,JJ,:)
+  END DO
+  PCOMPRESS(:,1,1)=SUM(ZWORKIK,2)
+!
+ELSE IF (LBU_ICP.AND..NOT.LBU_JCP.AND..NOT.LBU_KCP) THEN 
+  PCOMPRESS(1,:,:)=SUM(ZVARS,1)
+!
+ELSE IF (.NOT.LBU_ICP.AND.LBU_JCP.AND..NOT.LBU_KCP) THEN
+  PCOMPRESS(:,1,:)=SUM(ZVARS,2)
+!
+ELSE IF (.NOT.LBU_ICP.AND..NOT.LBU_JCP.AND.LBU_KCP) THEN
+  PCOMPRESS(:,:,1)=SUM(ZVARS,3)
+!
+ELSE  
+  PCOMPRESS=ZVARS
+!
+END IF
+!
+!
+END FUNCTION CART_COMPRESS                           
index c4163bd..be170da 100644 (file)
-!MNH_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier\r
-!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence\r
-!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt  \r
-!MNH_LIC for details. version 1.\r
-!-----------------------------------------------------------------\r
-!--------------- special set of characters for RCS information\r
-!-----------------------------------------------------------------\r
-! $Source$ $Revision$\r
-!-----------------------------------------------------------------\r
-!     ##########################\r
-      MODULE MODI_FILL_SONFIELD_n\r
-!     ##########################\r
-!\r
-INTERFACE \r
-!\r
-      SUBROUTINE FILL_SONFIELD_n(KMI,YFIELD,PNESTFIELD,KLSON)\r
-!\r
-INTEGER ,                 INTENT(IN)     :: KMI    ! son model number\r
-CHARACTER(LEN=6),         INTENT(IN)     :: YFIELD ! name of the field to nest\r
-REAL, DIMENSION(:,:,:,:), INTENT(INOUT)  :: PNESTFIELD\r
-INTEGER,                  INTENT(IN)     :: KLSON  ! rank of son model in PNESTFIELD\r
-!\r
-END SUBROUTINE FILL_SONFIELD_n\r
-END INTERFACE\r
-!\r
-END MODULE MODI_FILL_SONFIELD_n\r
-!\r
-!\r
-!\r
-!     ##################################################\r
-      SUBROUTINE FILL_SONFIELD_n(KMI,YFIELD,PNESTFIELD,KLSON)\r
-!     ##################################################\r
-!\r
-!!****  *FILL_SONFIELD_n* - fill the working array for nesting of pgd files\r
-!!                          with        son model index= _n\r
-!!\r
-!!    PURPOSE\r
-!!    -------\r
-!\r
-!!**  METHOD\r
-!!    ------\r
-!!\r
-!!    EXTERNAL\r
-!!    --------\r
-!!       \r
-!!    IMPLICIT ARGUMENTS\r
-!!    ------------------ \r
-!!\r
-!!    REFERENCE\r
-!!    ---------\r
-!!      Book2 of the documentation\r
-!!      \r
-!!\r
-!!    AUTHOR\r
-!!    ------\r
-!!     V. Masson       * Meteo France *\r
-!!\r
-!!    MODIFICATIONS\r
-!!    -------------\r
-!!      Original        27/09/96\r
-!!   J.Escobar : 15/09/2015 : WENO5 & JPHEXT <> 1 \r
-!!        M.Moge        01/2016 bug fix for parallel execution\r
-!-------------------------------------------------------------------------------\r
-!\r
-!*       0.    DECLARATIONS\r
-!\r
-USE MODD_GRID_n\r
-USE MODD_NESTING\r
-USE MODD_PARAMETERS\r
-USE MODE_SPLITTING_ll, ONLY : SPLIT2, DEF_SPLITTING2\r
-USE MODD_VAR_ll, ONLY : NPROC, IP, YSPLITTING, NMNH_COMM_WORLD\r
-USE MODD_STRUCTURE_ll, ONLY : ZONE_ll\r
-!\r
-USE MODE_MODELN_HANDLER\r
-!\r
-!USE MODE_TOOLS_ll, ONLY : GET_OR_ll\r
-!USE MODE_LS_ll\r
-!USE MODD_LSFIELD_n, ONLY : SET_LSFIELD_1WAY_ll\r
-USE MODE_ll\r
-!\r
-IMPLICIT NONE\r
-!\r
-!*       0.1   declarations of arguments\r
-!\r
-INTEGER ,                 INTENT(IN)     :: KMI    ! son model number\r
-CHARACTER(LEN=6),         INTENT(IN)     :: YFIELD ! name of the field to nest\r
-REAL, DIMENSION(:,:,:,:), INTENT(INOUT)  :: PNESTFIELD\r
-INTEGER,                  INTENT(IN)     :: KLSON  ! rank of son model in PNESTFIELD\r
-!\r
-!\r
-!*       0.2   declarations of local variables\r
-!\r
-INTEGER :: IIB1,IIE1,IJB1,IJE1 ! limits of physical domain of KDAD model\r
-INTEGER :: JI1,JJ1             ! loop counters   in domain of KDAD model\r
-!\r
-INTEGER :: JI2INF, JI2SUP      ! limits of a grid mesh of domain of KDAD model\r
-INTEGER :: JJ2INF,JJ2SUP       ! relatively to son domain\r
-INTEGER :: IMI                 ! current model index\r
-INTEGER :: JLAYER              ! loop counter\r
-INTEGER :: IINFO_ll\r
-INTEGER :: IXSIZE, IYSIZE  ! sizes of global son domain in father grid\r
-INTEGER :: IXSIZE_F, IYSIZE_F  ! sizes of global father domain\r
-TYPE(ZONE_ll), DIMENSION(:), ALLOCATABLE :: TZSPLITTING\r
-INTEGER :: IXOR, IYOR  ! origin of local subdomain\r
-INTEGER :: IXOR_C, IYOR_C, IXEND_C, IYEND_C  ! origin and end of local physical son subdomain in father grid\r
-REAL, DIMENSION(:,:), ALLOCATABLE  :: ZSUM\r
-REAL, DIMENSION(:,:), ALLOCATABLE  :: ZSUM_C\r
-INTEGER :: IDIMX_C, IDIMY_C ! size of extended local son subdomain in father grid obtained with GET_CHILD_DIM_ll\r
-INTEGER :: IXDOMAINS, IYDOMAINS               ! number of subdomains in X and Y directions\r
-LOGICAL :: GPREM                              ! needed for DEF_SPLITTING2, true if NPROC is a prime number\r
-!-------------------------------------------------------------------------------\r
-!\r
-!*       1.    initializations\r
-!              ---------------\r
-!\r
-IMI = GET_CURRENT_MODEL_INDEX()\r
-CALL GET_OR_ll( YSPLITTING, IXOR, IYOR )\r
-CALL GOTO_MODEL(KMI)\r
-CALL GO_TOMODEL_ll(KMI, IINFO_ll)\r
-!\r
-IF (KLSON/=1) THEN\r
-  ! get sizes of global son domain in father grid\r
-  IXSIZE = NXEND_ALL(KMI) - NXOR_ALL (KMI) + 1 - 2*JPHEXT ! - 1\r
-  IYSIZE = NYEND_ALL(KMI) - NYOR_ALL (KMI) + 1 - 2*JPHEXT ! - 1\r
-  ! get splitting of current model KMI in father grid\r
-  IXSIZE_F = NXEND_ALL(NDAD(KMI)) - NXOR_ALL (NDAD(KMI))  + 1 - 2*JPHEXT\r
-  IYSIZE_F = NYEND_ALL(NDAD(KMI)) - NYOR_ALL (NDAD(KMI))  + 1 - 2*JPHEXT\r
-  ALLOCATE(TZSPLITTING(NPROC))\r
-! we want the same domain partitioning for the child domain and for the father domain\r
-  CALL DEF_SPLITTING2(IXDOMAINS,IYDOMAINS,IXSIZE_F,IYSIZE_F,NPROC,GPREM)\r
-  CALL SPLIT2 ( IXSIZE, IYSIZE, 1, NPROC, TZSPLITTING, YSPLITTING, IXDOMAINS, IYDOMAINS )\r
-  IIB1 = JPHEXT + 1\r
-  IIE1 = TZSPLITTING(IP)%NXEND - TZSPLITTING(IP)%NXOR + JPHEXT + 1\r
-  IJB1 = JPHEXT + 1\r
-  IJE1 = TZSPLITTING(IP)%NYEND - TZSPLITTING(IP)%NYOR + JPHEXT + 1\r
-!  IIB1 = NXOR_ALL(KMI) + TZSPLITTING(IP)%NXOR - JPHEXT\r
-!  IIE1 = NXOR_ALL(KMI) + TZSPLITTING(IP)%NXEND - JPHEXT\r
-!  IJB1 = NYOR_ALL(KMI) + TZSPLITTING(IP)%NYOR - JPHEXT\r
-!  IJE1 = NYOR_ALL(KMI) + TZSPLITTING(IP)%NYEND - JPHEXT\r
-ENDIF\r
-!\r
-!* correct only if JPHEXT = 1\r
-!\r
-!JUAN A REVOIR TODO_JPHEXT !!!\r
-! <<<<<<< fill_sonfieldn.f90\r
-!IIB1 = NXOR_ALL (KMI)+1\r
-!IIE1 = NXEND_ALL(KMI)-1\r
-!IJB1 = NYOR_ALL (KMI)+1\r
-!IJE1 = NYEND_ALL(KMI)-1\r
-! =======\r
-!IIB1 = NXOR_ALL (KMI)+JPHEXT\r
-!IIE1 = NXEND_ALL(KMI)-JPHEXT\r
-!IJB1 = NYOR_ALL (KMI)+JPHEXT\r
-!IJE1 = NYEND_ALL(KMI)-JPHEXT\r
-! >>>>>>> 1.2.4.1.18.2.2.1\r
-!\r
-DO JLAYER=1,SIZE(PNESTFIELD,4)\r
-  PNESTFIELD(:,:,KLSON,JLAYER) = XUNDEF\r
-END DO\r
-!\r
-!-------------------------------------------------------------------------------\r
-IF (KLSON==1) THEN\r
-!\r
-!*       2.    case KLSON=1 : father itself\r
-!              ----------------------------\r
-!\r
-      SELECT CASE(YFIELD)\r
-        CASE ('ZS    ')\r
-          PNESTFIELD(:,:,KLSON,1) = XZS(:,:)\r
-         CASE ('ZSMT  ')   ! smooth topography for SLEVE coordinate\r
-          PNESTFIELD(:,:,KLSON,1) = XZSMT(:,:)\r
-        CASE DEFAULT\r
-          CALL GOTO_MODEL(IMI)\r
-          CALL GO_TOMODEL_ll(IMI, IINFO_ll)\r
-      END SELECT\r
-!\r
-!-------------------------------------------------------------------------------\r
-ELSE\r
-!\r
-!*       3.    case KLSON>1 : one son\r
-!              ----------------------\r
-!\r
-!  ALLOCATE( ZSUM(SIZE(PNESTFIELD,1), SIZE(PNESTFIELD,2)) )\r
-  ALLOCATE( ZSUM(SIZE(XZS,1), SIZE(XZS,2)) )\r
-  !\r
-  CALL GOTO_MODEL( NDAD(KMI) )\r
-  CALL GO_TOMODEL_ll( NDAD(KMI), IINFO_ll )\r
-  CALL GET_CHILD_DIM_ll(KMI, IDIMX_C, IDIMY_C, IINFO_ll)\r
-  CALL GOTO_MODEL( KMI )\r
-  CALL GO_TOMODEL_ll( KMI, IINFO_ll )\r
-  ALLOCATE( ZSUM_C(IDIMX_C, IDIMY_C) )\r
-  !\r
-  DO JI1 = IIB1,IIE1\r
-    DO JJ1 = IJB1,IJE1\r
-      JI2INF= (JI1-IIB1)  *NDXRATIO_ALL(KMI)+1+JPHEXT\r
-      JI2SUP= (JI1-IIB1+1)*NDXRATIO_ALL(KMI)  +JPHEXT\r
-      JJ2INF= (JJ1-IJB1)  *NDYRATIO_ALL(KMI)+1+JPHEXT\r
-      JJ2SUP= (JJ1-IJB1+1)*NDYRATIO_ALL(KMI)  +JPHEXT\r
-\r
-      SELECT CASE(YFIELD)\r
-         CASE ('ZS    ')\r
-           ZSUM_C(1+JPHEXT+(JI1-IIB1+1),1+JPHEXT+(JJ1-IJB1+1)) = SUM ( XZS(JI2INF:JI2SUP,JJ2INF:JJ2SUP ) )&\r
-                                     / ( NDXRATIO_ALL(KMI)*NDYRATIO_ALL(KMI) )\r
-         CASE ('ZSMT  ')  ! smooth topography for SLEVE coordinate\r
-           ZSUM_C(1+JPHEXT+(JI1-IIB1+1),1+JPHEXT+(JJ1-IJB1+1)) = SUM ( XZSMT(JI2INF:JI2SUP,JJ2INF:JJ2SUP ) )&\r
-                                     / ( NDXRATIO_ALL(KMI)*NDYRATIO_ALL(KMI) )\r
-        CASE DEFAULT\r
-          CALL GOTO_MODEL(IMI)\r
-          CALL GO_TOMODEL_ll(IMI, IINFO_ll)\r
-          RETURN\r
-      END SELECT\r
-\r
-    END DO\r
-  END DO\r
-  !switch to father model to set the LSFIELD and do the communications with LS_FEEDBACK_ll\r
-CALL GET_FEEDBACK_COORD_ll(IXOR_C,IYOR_C,IXEND_C,IYEND_C,IINFO_ll) ! physical domain's origin and end\r
-  CALL SET_LSFIELD_2WAY_ll(PNESTFIELD(IXOR_C:IXEND_C,IYOR_C:IYEND_C,KLSON,1), ZSUM_C)\r
-  CALL LS_FEEDBACK_ll(IINFO_ll)\r
-  CALL UNSET_LSFIELD_1WAY_ll()\r
-!\r
-!-------------------------------------------------------------------------------\r
-END IF\r
-!\r
-CALL GOTO_MODEL(IMI)\r
-CALL GO_TOMODEL_ll(IMI, IINFO_ll)\r
-!-------------------------------------------------------------------------------\r
-!\r
-END SUBROUTINE FILL_SONFIELD_n\r
+!MNH_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
+!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
+!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt  
+!MNH_LIC for details. version 1.
+!-----------------------------------------------------------------
+!--------------- special set of characters for RCS information
+!-----------------------------------------------------------------
+! $Source$ $Revision$
+!-----------------------------------------------------------------
+!     ##########################
+      MODULE MODI_FILL_SONFIELD_n
+!     ##########################
+!
+INTERFACE 
+!
+      SUBROUTINE FILL_SONFIELD_n(KMI,YFIELD,PNESTFIELD,KLSON)
+!
+INTEGER ,                 INTENT(IN)     :: KMI    ! son model number
+CHARACTER(LEN=6),         INTENT(IN)     :: YFIELD ! name of the field to nest
+REAL, DIMENSION(:,:,:,:), INTENT(INOUT)  :: PNESTFIELD
+INTEGER,                  INTENT(IN)     :: KLSON  ! rank of son model in PNESTFIELD
+!
+END SUBROUTINE FILL_SONFIELD_n
+END INTERFACE
+!
+END MODULE MODI_FILL_SONFIELD_n
+!
+!
+!
+!     ##################################################
+      SUBROUTINE FILL_SONFIELD_n(KMI,YFIELD,PNESTFIELD,KLSON)
+!     ##################################################
+!
+!!****  *FILL_SONFIELD_n* - fill the working array for nesting of pgd files
+!!                          with        son model index= _n
+!!
+!!    PURPOSE
+!!    -------
+!
+!!**  METHOD
+!!    ------
+!!
+!!    EXTERNAL
+!!    --------
+!!       
+!!    IMPLICIT ARGUMENTS
+!!    ------------------ 
+!!
+!!    REFERENCE
+!!    ---------
+!!      Book2 of the documentation
+!!      
+!!
+!!    AUTHOR
+!!    ------
+!!     V. Masson       * Meteo France *
+!!
+!!    MODIFICATIONS
+!!    -------------
+!!      Original        27/09/96
+!!   J.Escobar : 15/09/2015 : WENO5 & JPHEXT <> 1 
+!!        M.Moge        01/2016 bug fix for parallel execution
+!-------------------------------------------------------------------------------
+!
+!*       0.    DECLARATIONS
+!
+USE MODD_GRID_n
+USE MODD_NESTING
+USE MODD_PARAMETERS
+USE MODE_SPLITTING_ll, ONLY : SPLIT2, DEF_SPLITTING2
+USE MODD_VAR_ll, ONLY : NPROC, IP, YSPLITTING, NMNH_COMM_WORLD
+USE MODD_STRUCTURE_ll, ONLY : ZONE_ll
+!
+USE MODE_MODELN_HANDLER
+!
+!USE MODE_TOOLS_ll, ONLY : GET_OR_ll
+!USE MODE_LS_ll
+!USE MODD_LSFIELD_n, ONLY : SET_LSFIELD_1WAY_ll
+USE MODE_ll
+!
+IMPLICIT NONE
+!
+!*       0.1   declarations of arguments
+!
+INTEGER ,                 INTENT(IN)     :: KMI    ! son model number
+CHARACTER(LEN=6),         INTENT(IN)     :: YFIELD ! name of the field to nest
+REAL, DIMENSION(:,:,:,:), INTENT(INOUT)  :: PNESTFIELD
+INTEGER,                  INTENT(IN)     :: KLSON  ! rank of son model in PNESTFIELD
+!
+!
+!*       0.2   declarations of local variables
+!
+INTEGER :: IIB1,IIE1,IJB1,IJE1 ! limits of physical domain of KDAD model
+INTEGER :: JI1,JJ1             ! loop counters   in domain of KDAD model
+!
+INTEGER :: JI2INF, JI2SUP      ! limits of a grid mesh of domain of KDAD model
+INTEGER :: JJ2INF,JJ2SUP       ! relatively to son domain
+INTEGER :: IMI                 ! current model index
+INTEGER :: JLAYER              ! loop counter
+INTEGER :: IINFO_ll
+INTEGER :: IXSIZE, IYSIZE  ! sizes of global son domain in father grid
+INTEGER :: IXSIZE_F, IYSIZE_F  ! sizes of global father domain
+TYPE(ZONE_ll), DIMENSION(:), ALLOCATABLE :: TZSPLITTING
+INTEGER :: IXOR, IYOR  ! origin of local subdomain
+INTEGER :: IXOR_C, IYOR_C, IXEND_C, IYEND_C  ! origin and end of local physical son subdomain in father grid
+REAL, DIMENSION(:,:), ALLOCATABLE  :: ZSUM
+REAL, DIMENSION(:,:), ALLOCATABLE  :: ZSUM_C
+INTEGER :: IDIMX_C, IDIMY_C ! size of extended local son subdomain in father grid obtained with GET_CHILD_DIM_ll
+INTEGER :: IXDOMAINS, IYDOMAINS               ! number of subdomains in X and Y directions
+LOGICAL :: GPREM                              ! needed for DEF_SPLITTING2, true if NPROC is a prime number
+!-------------------------------------------------------------------------------
+!
+!*       1.    initializations
+!              ---------------
+!
+IMI = GET_CURRENT_MODEL_INDEX()
+CALL GET_OR_ll( YSPLITTING, IXOR, IYOR )
+CALL GOTO_MODEL(KMI)
+CALL GO_TOMODEL_ll(KMI, IINFO_ll)
+!
+IF (KLSON/=1) THEN
+  ! get sizes of global son domain in father grid
+  IXSIZE = NXEND_ALL(KMI) - NXOR_ALL (KMI) + 1 - 2*JPHEXT ! - 1
+  IYSIZE = NYEND_ALL(KMI) - NYOR_ALL (KMI) + 1 - 2*JPHEXT ! - 1
+  ! get splitting of current model KMI in father grid
+  IXSIZE_F = NXEND_ALL(NDAD(KMI)) - NXOR_ALL (NDAD(KMI))  + 1 - 2*JPHEXT
+  IYSIZE_F = NYEND_ALL(NDAD(KMI)) - NYOR_ALL (NDAD(KMI))  + 1 - 2*JPHEXT
+  ALLOCATE(TZSPLITTING(NPROC))
+! we want the same domain partitioning for the child domain and for the father domain
+  CALL DEF_SPLITTING2(IXDOMAINS,IYDOMAINS,IXSIZE_F,IYSIZE_F,NPROC,GPREM)
+  CALL SPLIT2 ( IXSIZE, IYSIZE, 1, NPROC, TZSPLITTING, YSPLITTING, IXDOMAINS, IYDOMAINS )
+  IIB1 = JPHEXT + 1
+  IIE1 = TZSPLITTING(IP)%NXEND - TZSPLITTING(IP)%NXOR + JPHEXT + 1
+  IJB1 = JPHEXT + 1
+  IJE1 = TZSPLITTING(IP)%NYEND - TZSPLITTING(IP)%NYOR + JPHEXT + 1
+!  IIB1 = NXOR_ALL(KMI) + TZSPLITTING(IP)%NXOR - JPHEXT
+!  IIE1 = NXOR_ALL(KMI) + TZSPLITTING(IP)%NXEND - JPHEXT
+!  IJB1 = NYOR_ALL(KMI) + TZSPLITTING(IP)%NYOR - JPHEXT
+!  IJE1 = NYOR_ALL(KMI) + TZSPLITTING(IP)%NYEND - JPHEXT
+ENDIF
+!
+!* correct only if JPHEXT = 1
+!
+!JUAN A REVOIR TODO_JPHEXT !!!
+! <<<<<<< fill_sonfieldn.f90
+!IIB1 = NXOR_ALL (KMI)+1
+!IIE1 = NXEND_ALL(KMI)-1
+!IJB1 = NYOR_ALL (KMI)+1
+!IJE1 = NYEND_ALL(KMI)-1
+! =======
+!IIB1 = NXOR_ALL (KMI)+JPHEXT
+!IIE1 = NXEND_ALL(KMI)-JPHEXT
+!IJB1 = NYOR_ALL (KMI)+JPHEXT
+!IJE1 = NYEND_ALL(KMI)-JPHEXT
+! >>>>>>> 1.2.4.1.18.2.2.1
+!
+DO JLAYER=1,SIZE(PNESTFIELD,4)
+  PNESTFIELD(:,:,KLSON,JLAYER) = XUNDEF
+END DO
+!
+!-------------------------------------------------------------------------------
+IF (KLSON==1) THEN
+!
+!*       2.    case KLSON=1 : father itself
+!              ----------------------------
+!
+      SELECT CASE(YFIELD)
+        CASE ('ZS    ')
+          PNESTFIELD(:,:,KLSON,1) = XZS(:,:)
+         CASE ('ZSMT  ')   ! smooth topography for SLEVE coordinate
+          PNESTFIELD(:,:,KLSON,1) = XZSMT(:,:)
+        CASE DEFAULT
+          CALL GOTO_MODEL(IMI)
+          CALL GO_TOMODEL_ll(IMI, IINFO_ll)
+      END SELECT
+!
+!-------------------------------------------------------------------------------
+ELSE
+!
+!*       3.    case KLSON>1 : one son
+!              ----------------------
+!
+!  ALLOCATE( ZSUM(SIZE(PNESTFIELD,1), SIZE(PNESTFIELD,2)) )
+  ALLOCATE( ZSUM(SIZE(XZS,1), SIZE(XZS,2)) )
+  !
+  CALL GOTO_MODEL( NDAD(KMI) )
+  CALL GO_TOMODEL_ll( NDAD(KMI), IINFO_ll )
+  CALL GET_CHILD_DIM_ll(KMI, IDIMX_C, IDIMY_C, IINFO_ll)
+  CALL GOTO_MODEL( KMI )
+  CALL GO_TOMODEL_ll( KMI, IINFO_ll )
+  ALLOCATE( ZSUM_C(IDIMX_C, IDIMY_C) )
+  !
+  DO JI1 = IIB1,IIE1
+    DO JJ1 = IJB1,IJE1
+      JI2INF= (JI1-IIB1)  *NDXRATIO_ALL(KMI)+1+JPHEXT
+      JI2SUP= (JI1-IIB1+1)*NDXRATIO_ALL(KMI)  +JPHEXT
+      JJ2INF= (JJ1-IJB1)  *NDYRATIO_ALL(KMI)+1+JPHEXT
+      JJ2SUP= (JJ1-IJB1+1)*NDYRATIO_ALL(KMI)  +JPHEXT
+
+      SELECT CASE(YFIELD)
+         CASE ('ZS    ')
+           ZSUM_C(1+JPHEXT+(JI1-IIB1+1),1+JPHEXT+(JJ1-IJB1+1)) = SUM ( XZS(JI2INF:JI2SUP,JJ2INF:JJ2SUP ) )&
+                                     / ( NDXRATIO_ALL(KMI)*NDYRATIO_ALL(KMI) )
+         CASE ('ZSMT  ')  ! smooth topography for SLEVE coordinate
+           ZSUM_C(1+JPHEXT+(JI1-IIB1+1),1+JPHEXT+(JJ1-IJB1+1)) = SUM ( XZSMT(JI2INF:JI2SUP,JJ2INF:JJ2SUP ) )&
+                                     / ( NDXRATIO_ALL(KMI)*NDYRATIO_ALL(KMI) )
+        CASE DEFAULT
+          CALL GOTO_MODEL(IMI)
+          CALL GO_TOMODEL_ll(IMI, IINFO_ll)
+          RETURN
+      END SELECT
+
+    END DO
+  END DO
+  !switch to father model to set the LSFIELD and do the communications with LS_FEEDBACK_ll
+CALL GET_FEEDBACK_COORD_ll(IXOR_C,IYOR_C,IXEND_C,IYEND_C,IINFO_ll) ! physical domain's origin and end
+  CALL SET_LSFIELD_2WAY_ll(PNESTFIELD(IXOR_C:IXEND_C,IYOR_C:IYEND_C,KLSON,1), ZSUM_C)
+  CALL LS_FEEDBACK_ll(IINFO_ll)
+  CALL UNSET_LSFIELD_1WAY_ll()
+!
+!-------------------------------------------------------------------------------
+END IF
+!
+CALL GOTO_MODEL(IMI)
+CALL GO_TOMODEL_ll(IMI, IINFO_ll)
+!-------------------------------------------------------------------------------
+!
+END SUBROUTINE FILL_SONFIELD_n
index 5bb8ae9..a959468 100644 (file)
-!MNH_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier\r
-!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence\r
-!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt  \r
-!MNH_LIC for details. version 1.\r
-!-----------------------------------------------------------------\r
-!--------------- special set of characters for RCS information\r
-!-----------------------------------------------------------------\r
-! $Source$ $Revision$\r
-! masdev4_7 BUG1 2007/06/15 17:47:17\r
-!-----------------------------------------------------------------\r
-!     ######################\r
-      MODULE MODI_FILL_ZSMTn\r
-!     ######################\r
-!\r
-INTERFACE \r
-!\r
-      SUBROUTINE FILL_ZSMT_n(HFIELD,PFIELD,KSON)\r
-!\r
-CHARACTER(LEN=6),         INTENT(IN) :: HFIELD ! name of the field to nest\r
-REAL, DIMENSION(:,:), INTENT(INOUT)  :: PFIELD\r
-INTEGER,                  INTENT(IN) :: KSON   ! son model index\r
-!\r
-END SUBROUTINE FILL_ZSMT_n\r
-!\r
-END INTERFACE\r
-!\r
-END MODULE MODI_FILL_ZSMTn\r
-!\r
-!\r
-!\r
-!     ##########################################\r
-      SUBROUTINE FILL_ZSMT_n(HFIELD,PFIELD,KSON)\r
-!     ##########################################\r
-!\r
-!!****  *FILL_ZSMT_n* - fill the working array for nesting of pgd files\r
-!!                          with KSON model index\r
-!!\r
-!!    PURPOSE\r
-!!    -------\r
-!\r
-!!**  METHOD\r
-!!    ------\r
-!!\r
-!!    EXTERNAL\r
-!!    --------\r
-!!       \r
-!!    IMPLICIT ARGUMENTS\r
-!!    ------------------ \r
-!!\r
-!!    REFERENCE\r
-!!    ---------\r
-!!      Book2 of the documentation\r
-!!      \r
-!!\r
-!!    AUTHOR\r
-!!    ------\r
-!!     V. Masson       * Meteo France *\r
-!!\r
-!!    MODIFICATIONS\r
-!!    -------------\r
-!!      Original        12/01/05\r
-!!      Modification    20/05/06 Remove Clark and Farley interpolation\r
-!!        M.Moge        01/2016 bug fix for parallel execution\r
-!-------------------------------------------------------------------------------\r
-!\r
-!*       0.    DECLARATIONS\r
-!\r
-USE MODD_GRID_n,  ONLY : XZSMT\r
-USE MODD_LUNIT_n, ONLY : CLUOUT\r
-USE MODD_LBC_n,   ONLY : CLBCX,CLBCY\r
-USE MODD_NESTING\r
-USE MODD_PARAMETERS\r
-!\r
-USE MODI_INI_BIKHARDT_n\r
-USE MODI_SPAWN_ZS\r
-USE MODE_MODELN_HANDLER\r
-!\r
-USE MODE_SPLITTING_ll, ONLY : SPLIT2, DEF_SPLITTING2\r
-USE MODD_VAR_ll, ONLY : NPROC, IP, YSPLITTING, NMNH_COMM_WORLD\r
-USE MODD_STRUCTURE_ll, ONLY : ZONE_ll\r
-!\r
-IMPLICIT NONE\r
-!\r
-!*       0.1   declarations of arguments\r
-!\r
-CHARACTER(LEN=6),     INTENT(IN)     :: HFIELD ! name of the field to fill\r
-REAL, DIMENSION(:,:), INTENT(INOUT)  :: PFIELD\r
-INTEGER,              INTENT(IN) :: KSON   ! son model index\r
-!\r
-!*       0.2   declarations of local variables\r
-!-------------------------------------------------------------------------------\r
-INTEGER :: IMI ! current model index (DAD index)\r
-!\r
-! Dummy pointers needed to correct an ifort Bug\r
-CHARACTER(LEN=4), DIMENSION(:), POINTER :: DPTR_CLBCX,DPTR_CLBCY\r
-REAL, DIMENSION(:,:),  POINTER          :: DPTR_XZSMT\r
-INTEGER :: IINFO_ll\r
-INTEGER :: IXSIZE, IYSIZE        ! sizes of global son domain in father grid\r
-INTEGER :: IXSIZE_F, IYSIZE_F    ! sizes of global father domain\r
-TYPE(ZONE_ll), DIMENSION(:), ALLOCATABLE :: TZSPLITTING\r
-INTEGER :: IXOR,IXEND,IYOR,IYEND ! limits of extended  domain of KSON model in its father's grid\r
-INTEGER :: IDIMX, IDIMY  ! dimensions of extended son subdomain in father's grid + one point in each direction\r
-INTEGER :: IXDOMAINS, IYDOMAINS               ! number of subdomains in X and Y directions\r
-LOGICAL :: GPREM                              ! needed for DEF_SPLITTING2, true if NPROC is a prime number\r
-!\r
-!*       1.    initializations\r
-!              ---------------\r
-!\r
-IMI = GET_CURRENT_MODEL_INDEX()\r
-CALL GOTO_MODEL(KSON)\r
-CALL GO_TOMODEL_ll(KSON, IINFO_ll)\r
-!\r
-! get sizes of global son domain in father grid\r
-IXSIZE = NXEND_ALL(KSON) - NXOR_ALL (KSON) + 1 - 2*JPHEXT\r
-IYSIZE = NYEND_ALL(KSON) - NYOR_ALL (KSON) + 1 - 2*JPHEXT\r
-! get splitting of current model KMI in father grid\r
-IXSIZE_F = NXEND_ALL(NDAD(KSON)) - NXOR_ALL (NDAD(KSON)) + 1 - 2*JPHEXT\r
-IYSIZE_F = NYEND_ALL(NDAD(KSON)) - NYOR_ALL (NDAD(KSON)) + 1 - 2*JPHEXT\r
-ALLOCATE(TZSPLITTING(NPROC))\r
-! we want the same domain partitioning for the child domain and for the father domain\r
-CALL DEF_SPLITTING2(IXDOMAINS,IYDOMAINS,IXSIZE_F,IYSIZE_F,NPROC,GPREM)\r
-CALL SPLIT2 ( IXSIZE, IYSIZE, 1, NPROC, TZSPLITTING, YSPLITTING, IXDOMAINS, IYDOMAINS )\r
-! get coords of extended domain of KSON in its father's grid\r
-IXOR  = NXOR_ALL(KSON) + TZSPLITTING(IP)%NXOR  -1 - JPHEXT \r
-IXEND = NXOR_ALL(KSON) + TZSPLITTING(IP)%NXEND -1 + JPHEXT \r
-IYOR  = NYOR_ALL(KSON) + TZSPLITTING(IP)%NYOR  -1 - JPHEXT \r
-IYEND = NYOR_ALL(KSON) + TZSPLITTING(IP)%NYEND -1 + JPHEXT\r
-!\r
-!IDIMX = IXEND - IXOR - 1\r
-!IDIMY = IYEND - IYOR - 1\r
-IDIMX = IXEND - IXOR + 1 +2*1 ! + 2*JPHEXT\r
-IDIMY = IYEND - IYOR + 1 +2*1 ! + 2*JPHEXT\r
-!\r
-CALL INI_BIKHARDT_n(NDXRATIO_ALL(KSON),NDYRATIO_ALL(KSON),KSON)\r
-!\r
-!-------------------------------------------------------------------------------\r
-!\r
-!*       2.    interpolation of dad field\r
-!              --------------------------\r
-!\r
-DPTR_CLBCX=>CLBCX\r
-DPTR_CLBCY=>CLBCY\r
-DPTR_XZSMT=>XZSMT\r
-CALL SPAWN_ZS(NXOR_ALL(KSON),NXEND_ALL(KSON),NYOR_ALL(KSON),NYEND_ALL(KSON), &\r
-              NDXRATIO_ALL(KSON),NDYRATIO_ALL(KSON),IDIMX,IDIMY,DPTR_CLBCX,DPTR_CLBCY,         &\r
-              CLUOUT,PFIELD,DPTR_XZSMT,HFIELD                             )\r
-!-------------------------------------------------------------------------------\r
-!\r
-CALL GOTO_MODEL(IMI)\r
-CALL GO_TOMODEL_ll(IMI, IINFO_ll)\r
-!\r
-END SUBROUTINE FILL_ZSMT_n\r
+!MNH_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
+!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
+!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt  
+!MNH_LIC for details. version 1.
+!-----------------------------------------------------------------
+!--------------- special set of characters for RCS information
+!-----------------------------------------------------------------
+! $Source$ $Revision$
+! masdev4_7 BUG1 2007/06/15 17:47:17
+!-----------------------------------------------------------------
+!     ######################
+      MODULE MODI_FILL_ZSMTn
+!     ######################
+!
+INTERFACE 
+!
+      SUBROUTINE FILL_ZSMT_n(HFIELD,PFIELD,KSON)
+!
+CHARACTER(LEN=6),         INTENT(IN) :: HFIELD ! name of the field to nest
+REAL, DIMENSION(:,:), INTENT(INOUT)  :: PFIELD
+INTEGER,                  INTENT(IN) :: KSON   ! son model index
+!
+END SUBROUTINE FILL_ZSMT_n
+!
+END INTERFACE
+!
+END MODULE MODI_FILL_ZSMTn
+!
+!
+!
+!     ##########################################
+      SUBROUTINE FILL_ZSMT_n(HFIELD,PFIELD,KSON)
+!     ##########################################
+!
+!!****  *FILL_ZSMT_n* - fill the working array for nesting of pgd files
+!!                          with KSON model index
+!!
+!!    PURPOSE
+!!    -------
+!
+!!**  METHOD
+!!    ------
+!!
+!!    EXTERNAL
+!!    --------
+!!       
+!!    IMPLICIT ARGUMENTS
+!!    ------------------ 
+!!
+!!    REFERENCE
+!!    ---------
+!!      Book2 of the documentation
+!!      
+!!
+!!    AUTHOR
+!!    ------
+!!     V. Masson       * Meteo France *
+!!
+!!    MODIFICATIONS
+!!    -------------
+!!      Original        12/01/05
+!!      Modification    20/05/06 Remove Clark and Farley interpolation
+!!        M.Moge        01/2016 bug fix for parallel execution
+!-------------------------------------------------------------------------------
+!
+!*       0.    DECLARATIONS
+!
+USE MODD_GRID_n,  ONLY : XZSMT
+USE MODD_LUNIT_n, ONLY : CLUOUT
+USE MODD_LBC_n,   ONLY : CLBCX,CLBCY
+USE MODD_NESTING
+USE MODD_PARAMETERS
+!
+USE MODI_INI_BIKHARDT_n
+USE MODI_SPAWN_ZS
+USE MODE_MODELN_HANDLER
+!
+USE MODE_SPLITTING_ll, ONLY : SPLIT2, DEF_SPLITTING2
+USE MODD_VAR_ll, ONLY : NPROC, IP, YSPLITTING, NMNH_COMM_WORLD
+USE MODD_STRUCTURE_ll, ONLY : ZONE_ll
+!
+IMPLICIT NONE
+!
+!*       0.1   declarations of arguments
+!
+CHARACTER(LEN=6),     INTENT(IN)     :: HFIELD ! name of the field to fill
+REAL, DIMENSION(:,:), INTENT(INOUT)  :: PFIELD
+INTEGER,              INTENT(IN) :: KSON   ! son model index
+!
+!*       0.2   declarations of local variables
+!-------------------------------------------------------------------------------
+INTEGER :: IMI ! current model index (DAD index)
+!
+! Dummy pointers needed to correct an ifort Bug
+CHARACTER(LEN=4), DIMENSION(:), POINTER :: DPTR_CLBCX,DPTR_CLBCY
+REAL, DIMENSION(:,:),  POINTER          :: DPTR_XZSMT
+INTEGER :: IINFO_ll
+INTEGER :: IXSIZE, IYSIZE        ! sizes of global son domain in father grid
+INTEGER :: IXSIZE_F, IYSIZE_F    ! sizes of global father domain
+TYPE(ZONE_ll), DIMENSION(:), ALLOCATABLE :: TZSPLITTING
+INTEGER :: IXOR,IXEND,IYOR,IYEND ! limits of extended  domain of KSON model in its father's grid
+INTEGER :: IDIMX, IDIMY  ! dimensions of extended son subdomain in father's grid + one point in each direction
+INTEGER :: IXDOMAINS, IYDOMAINS               ! number of subdomains in X and Y directions
+LOGICAL :: GPREM                              ! needed for DEF_SPLITTING2, true if NPROC is a prime number
+!
+!*       1.    initializations
+!              ---------------
+!
+IMI = GET_CURRENT_MODEL_INDEX()
+CALL GOTO_MODEL(KSON)
+CALL GO_TOMODEL_ll(KSON, IINFO_ll)
+!
+! get sizes of global son domain in father grid
+IXSIZE = NXEND_ALL(KSON) - NXOR_ALL (KSON) + 1 - 2*JPHEXT
+IYSIZE = NYEND_ALL(KSON) - NYOR_ALL (KSON) + 1 - 2*JPHEXT
+! get splitting of current model KMI in father grid
+IXSIZE_F = NXEND_ALL(NDAD(KSON)) - NXOR_ALL (NDAD(KSON)) + 1 - 2*JPHEXT
+IYSIZE_F = NYEND_ALL(NDAD(KSON)) - NYOR_ALL (NDAD(KSON)) + 1 - 2*JPHEXT
+ALLOCATE(TZSPLITTING(NPROC))
+! we want the same domain partitioning for the child domain and for the father domain
+CALL DEF_SPLITTING2(IXDOMAINS,IYDOMAINS,IXSIZE_F,IYSIZE_F,NPROC,GPREM)
+CALL SPLIT2 ( IXSIZE, IYSIZE, 1, NPROC, TZSPLITTING, YSPLITTING, IXDOMAINS, IYDOMAINS )
+! get coords of extended domain of KSON in its father's grid
+IXOR  = NXOR_ALL(KSON) + TZSPLITTING(IP)%NXOR  -1 - JPHEXT 
+IXEND = NXOR_ALL(KSON) + TZSPLITTING(IP)%NXEND -1 + JPHEXT 
+IYOR  = NYOR_ALL(KSON) + TZSPLITTING(IP)%NYOR  -1 - JPHEXT 
+IYEND = NYOR_ALL(KSON) + TZSPLITTING(IP)%NYEND -1 + JPHEXT
+!
+!IDIMX = IXEND - IXOR - 1
+!IDIMY = IYEND - IYOR - 1
+IDIMX = IXEND - IXOR + 1 +2*1 ! + 2*JPHEXT
+IDIMY = IYEND - IYOR + 1 +2*1 ! + 2*JPHEXT
+!
+CALL INI_BIKHARDT_n(NDXRATIO_ALL(KSON),NDYRATIO_ALL(KSON),KSON)
+!
+!-------------------------------------------------------------------------------
+!
+!*       2.    interpolation of dad field
+!              --------------------------
+!
+DPTR_CLBCX=>CLBCX
+DPTR_CLBCY=>CLBCY
+DPTR_XZSMT=>XZSMT
+CALL SPAWN_ZS(NXOR_ALL(KSON),NXEND_ALL(KSON),NYOR_ALL(KSON),NYEND_ALL(KSON), &
+              NDXRATIO_ALL(KSON),NDYRATIO_ALL(KSON),IDIMX,IDIMY,DPTR_CLBCX,DPTR_CLBCY,         &
+              CLUOUT,PFIELD,DPTR_XZSMT,HFIELD                             )
+!-------------------------------------------------------------------------------
+!
+CALL GOTO_MODEL(IMI)
+CALL GO_TOMODEL_ll(IMI, IINFO_ll)
+!
+END SUBROUTINE FILL_ZSMT_n
index baad404..b016a1c 100644 (file)
@@ -1,79 +1,79 @@
-!MNH_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier\r
-!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence\r
-!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt  \r
-!MNH_LIC for details. version 1.\r
-  SUBROUTINE GET_NB_PROCIO_READ_MNH( KNB_PROCIO, KRESP )\r
-!\r
-!!****  *GET_NB_PROCIO_READ_MNH* - gets the number of processes used for Input of file MODD_IO_SURF_MNH::CFILE\r
-!!                        \r
-!!\r
-!!    PURPOSE\r
-!!    -------\r
-!!      call GET_NB_PROCIO_READ_MNH from SURFEX to get the number of processes used \r
-!!      for Iinput of file MODD_IO_SURF_MNH::CFILE in MESO-NH (defined by user in namelist)\r
-!!\r
-!!**  METHOD\r
-!!    ------\r
-!!\r
-!!    EXTERNAL\r
-!!    --------\r
-!!\r
-!!\r
-!!    IMPLICIT ARGUMENTS\r
-!!    ------------------\r
-!!\r
-!!    REFERENCE\r
-!!    ---------\r
-!!\r
-!!\r
-!!    AUTHOR\r
-!!    ------\r
-!!     M. Moge   *LA - UPS*  08/01/2016        \r
-!!\r
-!!    MODIFICATIONS\r
-!!    -------------\r
-!!\r
-!-------------------------------------------------------------------------------\r
-!\r
-USE MODE_FD_ll,        ONLY : GETFD,JPFINL,FD_ll\r
-USE MODD_IO_SURF_MNH,  ONLY : COUT, CFILE\r
-!\r
-IMPLICIT NONE\r
-!\r
-!*      0.    DECLARATIONS\r
-!             ------------\r
-!\r
-!*      0.1   Declarations of arguments\r
-!\r
-!CHARACTER(LEN=*), INTENT(IN)  :: HFILEM  ! FM-file name\r
-INTEGER,          INTENT(OUT) :: KNB_PROCIO    ! number of processes used for IO\r
-INTEGER,          INTENT(OUT) :: KRESP   ! return-code \r
-!\r
-!*      0.2   Declarations of local variables\r
-!\r
-!----------------------------------------------------------------\r
-CHARACTER(LEN=JPFINL)        :: YFNLFI\r
-TYPE(FD_ll), POINTER         :: TZFD\r
-INTEGER                      :: IRESP\r
-INTEGER                      :: ILUPRI\r
-!\r
-!*      1. get the number of processes used for IO\r
-!\r
-IRESP = 0\r
-YFNLFI=TRIM(ADJUSTL(CFILE))//'.lfi'\r
-!\r
-TZFD=>GETFD(YFNLFI)\r
-IF (ASSOCIATED(TZFD)) THEN\r
-  KNB_PROCIO = TZFD%nb_procio\r
-ELSE\r
-  IRESP = -61\r
-END IF\r
-!----------------------------------------------------------------\r
-IF (IRESP.NE.0) THEN\r
-  CALL FMLOOK_ll(COUT,COUT,ILUPRI,IRESP)\r
-  WRITE (ILUPRI,*) ' exit from GET_NB_PROCIO_READ_MNH with RESP:',IRESP\r
-  WRITE (ILUPRI,*) '   | CFILE = ',CFILE\r
-END IF\r
-KRESP = IRESP\r
-!\r
+!MNH_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
+!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
+!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt  
+!MNH_LIC for details. version 1.
+  SUBROUTINE GET_NB_PROCIO_READ_MNH( KNB_PROCIO, KRESP )
+!
+!!****  *GET_NB_PROCIO_READ_MNH* - gets the number of processes used for Input of file MODD_IO_SURF_MNH::CFILE
+!!                        
+!!
+!!    PURPOSE
+!!    -------
+!!      call GET_NB_PROCIO_READ_MNH from SURFEX to get the number of processes used 
+!!      for Iinput of file MODD_IO_SURF_MNH::CFILE in MESO-NH (defined by user in namelist)
+!!
+!!**  METHOD
+!!    ------
+!!
+!!    EXTERNAL
+!!    --------
+!!
+!!
+!!    IMPLICIT ARGUMENTS
+!!    ------------------
+!!
+!!    REFERENCE
+!!    ---------
+!!
+!!
+!!    AUTHOR
+!!    ------
+!!     M. Moge   *LA - UPS*  08/01/2016        
+!!
+!!    MODIFICATIONS
+!!    -------------
+!!
+!-------------------------------------------------------------------------------
+!
+USE MODE_FD_ll,        ONLY : GETFD,JPFINL,FD_ll
+USE MODD_IO_SURF_MNH,  ONLY : COUT, CFILE
+!
+IMPLICIT NONE
+!
+!*      0.    DECLARATIONS
+!             ------------
+!
+!*      0.1   Declarations of arguments
+!
+!CHARACTER(LEN=*), INTENT(IN)  :: HFILEM  ! FM-file name
+INTEGER,          INTENT(OUT) :: KNB_PROCIO    ! number of processes used for IO
+INTEGER,          INTENT(OUT) :: KRESP   ! return-code 
+!
+!*      0.2   Declarations of local variables
+!
+!----------------------------------------------------------------
+CHARACTER(LEN=JPFINL)        :: YFNLFI
+TYPE(FD_ll), POINTER         :: TZFD
+INTEGER                      :: IRESP
+INTEGER                      :: ILUPRI
+!
+!*      1. get the number of processes used for IO
+!
+IRESP = 0
+YFNLFI=TRIM(ADJUSTL(CFILE))//'.lfi'
+!
+TZFD=>GETFD(YFNLFI)
+IF (ASSOCIATED(TZFD)) THEN
+  KNB_PROCIO = TZFD%nb_procio
+ELSE
+  IRESP = -61
+END IF
+!----------------------------------------------------------------
+IF (IRESP.NE.0) THEN
+  CALL FMLOOK_ll(COUT,COUT,ILUPRI,IRESP)
+  WRITE (ILUPRI,*) ' exit from GET_NB_PROCIO_READ_MNH with RESP:',IRESP
+  WRITE (ILUPRI,*) '   | CFILE = ',CFILE
+END IF
+KRESP = IRESP
+!
   END SUBROUTINE GET_NB_PROCIO_READ_MNH
\ No newline at end of file
index 3b89bc3..2e2d269 100644 (file)
@@ -1,79 +1,79 @@
-!MNH_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier\r
-!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence\r
-!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt  \r
-!MNH_LIC for details. version 1.\r
-  SUBROUTINE GET_NB_PROCIO_WRITE_MNH( KNB_PROCIO, KRESP )\r
-!\r
-!!****  *GET_NB_PROCIO_WRITE_MNH* - gets the number of processes used for Output of file MODD_IO_SURF_MNH::COUTFILE\r
-!!                        \r
-!!\r
-!!    PURPOSE\r
-!!    -------\r
-!!      call GET_NB_PROCIO_WRITE_MNH from SURFEX to get the number of processes used \r
-!!      for Output of file MODD_IO_SURF_MNH::COUTFILE in MESO-NH (defined by user in namelist)\r
-!!\r
-!!**  METHOD\r
-!!    ------\r
-!!\r
-!!    EXTERNAL\r
-!!    --------\r
-!!\r
-!!\r
-!!    IMPLICIT ARGUMENTS\r
-!!    ------------------\r
-!!\r
-!!    REFERENCE\r
-!!    ---------\r
-!!\r
-!!\r
-!!    AUTHOR\r
-!!    ------\r
-!!     M. Moge   *LA - UPS*  08/01/2016        \r
-!!\r
-!!    MODIFICATIONS\r
-!!    -------------\r
-!!\r
-!-------------------------------------------------------------------------------\r
-!\r
-USE MODE_FD_ll,        ONLY : GETFD,JPFINL,FD_ll\r
-USE MODD_IO_SURF_MNH,  ONLY : COUT, COUTFILE\r
-!\r
-IMPLICIT NONE\r
-!\r
-!*      0.    DECLARATIONS\r
-!             ------------\r
-!\r
-!*      0.1   Declarations of arguments\r
-!\r
-!CHARACTER(LEN=*), INTENT(IN)  :: HFILEM  ! FM-file name\r
-INTEGER,          INTENT(OUT) :: KNB_PROCIO    ! number of processes used for IO\r
-INTEGER,          INTENT(OUT) :: KRESP   ! return-code \r
-!\r
-!*      0.2   Declarations of local variables\r
-!\r
-!----------------------------------------------------------------\r
-CHARACTER(LEN=JPFINL)        :: YFNLFI\r
-TYPE(FD_ll), POINTER         :: TZFD\r
-INTEGER                      :: IRESP\r
-INTEGER                      :: ILUPRI\r
-!\r
-!*      1. get the number of processes used for IO\r
-!\r
-IRESP = 0\r
-YFNLFI=TRIM(ADJUSTL(COUTFILE))//'.lfi'\r
-!\r
-TZFD=>GETFD(YFNLFI)\r
-IF (ASSOCIATED(TZFD)) THEN\r
-  KNB_PROCIO = TZFD%nb_procio\r
-ELSE\r
-  IRESP = -61\r
-END IF\r
-!----------------------------------------------------------------\r
-IF (IRESP.NE.0) THEN\r
-  CALL FMLOOK_ll(COUT,COUT,ILUPRI,IRESP)\r
-  WRITE (ILUPRI,*) ' exit from GET_NB_PROCIO_WRITE_MNH with RESP:',IRESP\r
-  WRITE (ILUPRI,*) '   | COUTFILE = ',COUTFILE\r
-END IF\r
-KRESP = IRESP\r
-!\r
+!MNH_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
+!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
+!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt  
+!MNH_LIC for details. version 1.
+  SUBROUTINE GET_NB_PROCIO_WRITE_MNH( KNB_PROCIO, KRESP )
+!
+!!****  *GET_NB_PROCIO_WRITE_MNH* - gets the number of processes used for Output of file MODD_IO_SURF_MNH::COUTFILE
+!!                        
+!!
+!!    PURPOSE
+!!    -------
+!!      call GET_NB_PROCIO_WRITE_MNH from SURFEX to get the number of processes used 
+!!      for Output of file MODD_IO_SURF_MNH::COUTFILE in MESO-NH (defined by user in namelist)
+!!
+!!**  METHOD
+!!    ------
+!!
+!!    EXTERNAL
+!!    --------
+!!
+!!
+!!    IMPLICIT ARGUMENTS
+!!    ------------------
+!!
+!!    REFERENCE
+!!    ---------
+!!
+!!
+!!    AUTHOR
+!!    ------
+!!     M. Moge   *LA - UPS*  08/01/2016        
+!!
+!!    MODIFICATIONS
+!!    -------------
+!!
+!-------------------------------------------------------------------------------
+!
+USE MODE_FD_ll,        ONLY : GETFD,JPFINL,FD_ll
+USE MODD_IO_SURF_MNH,  ONLY : COUT, COUTFILE
+!
+IMPLICIT NONE
+!
+!*      0.    DECLARATIONS
+!             ------------
+!
+!*      0.1   Declarations of arguments
+!
+!CHARACTER(LEN=*), INTENT(IN)  :: HFILEM  ! FM-file name
+INTEGER,          INTENT(OUT) :: KNB_PROCIO    ! number of processes used for IO
+INTEGER,          INTENT(OUT) :: KRESP   ! return-code 
+!
+!*      0.2   Declarations of local variables
+!
+!----------------------------------------------------------------
+CHARACTER(LEN=JPFINL)        :: YFNLFI
+TYPE(FD_ll), POINTER         :: TZFD
+INTEGER                      :: IRESP
+INTEGER                      :: ILUPRI
+!
+!*      1. get the number of processes used for IO
+!
+IRESP = 0
+YFNLFI=TRIM(ADJUSTL(COUTFILE))//'.lfi'
+!
+TZFD=>GETFD(YFNLFI)
+IF (ASSOCIATED(TZFD)) THEN
+  KNB_PROCIO = TZFD%nb_procio
+ELSE
+  IRESP = -61
+END IF
+!----------------------------------------------------------------
+IF (IRESP.NE.0) THEN
+  CALL FMLOOK_ll(COUT,COUT,ILUPRI,IRESP)
+  WRITE (ILUPRI,*) ' exit from GET_NB_PROCIO_WRITE_MNH with RESP:',IRESP
+  WRITE (ILUPRI,*) '   | COUTFILE = ',COUTFILE
+END IF
+KRESP = IRESP
+!
   END SUBROUTINE GET_NB_PROCIO_WRITE_MNH
\ No newline at end of file
index 70cf5af..2875839 100644 (file)
-!MNH_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier\r
-!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence\r
-!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt  \r
-!MNH_LIC for details. version 1.\r
-!-----------------------------------------------------------------\r
-!--------------- special set of characters for RCS information\r
-!-----------------------------------------------------------------\r
-! $Source$ $Revision$\r
-!-----------------------------------------------------------------\r
-!#############################\r
-MODULE MODI_OPEN_NESTPGD_FILES\r
-!#############################\r
-!\r
-INTERFACE\r
-      SUBROUTINE OPEN_NESTPGD_FILES(HPGD,HNESTPGD)\r
-!\r
-CHARACTER(LEN=28), DIMENSION(:), INTENT(OUT) :: HPGD     ! name of the input  pgd files\r
-CHARACTER(LEN=28), DIMENSION(:), INTENT(OUT) :: HNESTPGD ! name of the output pgd files\r
-END SUBROUTINE OPEN_NESTPGD_FILES\r
-END INTERFACE\r
-END MODULE MODI_OPEN_NESTPGD_FILES\r
-!     ############################################\r
-      SUBROUTINE OPEN_NESTPGD_FILES(HPGD,HNESTPGD)\r
-!     ############################################\r
-!\r
-!!****  *OPEN_NESTPGD_FILES* - openning of the files used in PREP_NEST_PGD\r
-!!                         \r
-!!\r
-!!    PURPOSE\r
-!!    -------\r
-!!\r
-!!**  METHOD\r
-!!    ------\r
-!!\r
-!!    CAUTION:\r
-!!    This routine supposes the name of the namelist file is 'PRE_NEST_PGD1.nam'.\r
-!!\r
-!!    EXTERNAL\r
-!!    --------\r
-!!\r
-!!    Routine FMOPEN\r
-!!\r
-!!    IMPLICIT ARGUMENTS\r
-!!    ------------------\r
-!!\r
-!!      Module MODD_LUNIT     :  contains logical unit names for all models\r
-!!         CLUOUT0  : name of output-listing\r
-!!\r
-!!    REFERENCE\r
-!!    ---------\r
-!!\r
-!!      Book 2\r
-!!\r
-!!    AUTHOR\r
-!!    ------\r
-!!     \r
-!!      V.Masson  Meteo-France\r
-!!\r
-!!    MODIFICATIONS\r
-!!    -------------\r
-!!      Original     26/09/96\r
-!!                   30/07/97 (Masson) group MODI_OPEN_LUOUTn\r
-!!                   15/10/01 (I.Mallet) allow namelists in different orders\r
-!!                   07/06/2010 (J.escobar from Ivan Ristic) bug PGI\r
-!!                   30/12/2012 (S.Bielli) Add NAM_NCOUT for netcdf output\r
-!!    J.Escobar : 15/09/2015 : WENO5 & JPHEXT <> 1 \r
-!!                   11/2015 (M.Moge) disable the creation of files on multiple \r
-!!                                 Z-levels when using parallel IO for PREP_PGD\r
-!!                   01/2016 (M.Moge) Bug fix : open the output file using Z-parallel IO\r
-!-------------------------------------------------------------------------------\r
-!\r
-!*       0.    DECLARATIONS\r
-!              ------------\r
-!\r
-USE MODD_LUNIT\r
-USE MODD_CONF\r
-USE MODD_NESTING\r
-USE MODD_PARAMETERS\r
-!\r
-USE MODI_OPEN_LUOUTn\r
-!\r
-USE MODE_IO_ll\r
-USE MODE_FM\r
-USE MODE_POS\r
-!\r
-USE MODE_MODELN_HANDLER\r
-!\r
-#ifdef MNH_NCWRIT\r
-USE MODN_NCOUT\r
-#endif\r
-USE MODN_CONFIO\r
-!\r
-USE MODD_PARAMETERS, ONLY : JPHEXT  \r
-USE MODD_CONF, ONLY       : NHALO_CONF_MNH => NHALO\r
-!\r
-USE  MODN_CONFZ\r
-!\r
-IMPLICIT NONE\r
-!\r
-!*       0.1   Declaration of arguments\r
-!              ------------------------\r
-!\r
-CHARACTER(LEN=28), DIMENSION(:), INTENT(OUT) :: HPGD     ! name of the input  pgd files\r
-CHARACTER(LEN=28), DIMENSION(:), INTENT(OUT) :: HNESTPGD ! name of the output pgd files\r
-!\r
-!*       0.2   Declaration of local variables\r
-!              ------------------------------\r
-!\r
-INTEGER :: IRESP      ! return-code if problems eraised\r
-INTEGER :: ILUOUT0    ! logical unit for listing file\r
-INTEGER :: ININAR     ! number of articles initially present in a FM file\r
-LOGICAL :: GFOUND     ! Return code when searching namelist\r
-!\r
-CHARACTER(LEN=28) :: HPRE_NEST_PGD ! name of namelist file\r
-INTEGER           :: IPRE_NEST_PGD ! logical unit of namelist file\r
-!\r
-CHARACTER(LEN=28)                        :: YPGD      ! name of the pgd file for each model\r
-CHARACTER(LEN=28)                        :: YLUOUT    ! name of output listing file for each model\r
-CHARACTER(LEN=2)                         :: YNEST     ! to define the output pgd file names\r
-CHARACTER(LEN=28)                        :: YPGD1, YPGD2, YPGD3, YPGD4, &\r
-                                            YPGD5, YPGD6, YPGD7, YPGD8\r
-!                                                     ! name of all pgd files\r
-!                                                     ! in the namelist\r
-INTEGER                        :: IDAD    ! father of one model\r
-INTEGER                        :: JPGD    ! loop counter\r
-LOGICAL                        :: GADD    !\r
-CHARACTER(LEN=21), DIMENSION(JPMODELMAX) :: YSHORTPGD \r
-INTEGER                                  :: NHALO_MNH\r
-!\r
-INTEGER :: ILUNAM,ILUOUT              ! Logical unit number for the EXSPA file\r
-!\r
-!*       0.3   Declaration of namelists\r
-!              ------------------------\r
-!\r
-NAMELIST/NAM_PGD1/ YPGD1\r
-NAMELIST/NAM_PGD2/ YPGD2, IDAD\r
-NAMELIST/NAM_PGD3/ YPGD3, IDAD\r
-NAMELIST/NAM_PGD4/ YPGD4, IDAD\r
-NAMELIST/NAM_PGD5/ YPGD5, IDAD\r
-NAMELIST/NAM_PGD6/ YPGD6, IDAD\r
-NAMELIST/NAM_PGD7/ YPGD7, IDAD\r
-NAMELIST/NAM_PGD8/ YPGD8, IDAD\r
-NAMELIST/NAM_NEST_PGD/ YNEST\r
-NAMELIST/NAM_CONF_NEST/JPHEXT, NHALO_MNH\r
-!-------------------------------------------------------------------------------\r
-!\r
-!*       1.    SET DEFAULT NAMES\r
-!              -----------------\r
-!\r
-DO JPGD=1,JPMODELMAX\r
-  HPGD    (JPGD)='                           '\r
-  HNESTPGD(JPGD)='                           '\r
-END DO\r
-!\r
-HPRE_NEST_PGD='PRE_NEST_PGD1.nam'\r
-CLUOUT0='OUTPUT_LISTING0'\r
-!\r
-!-------------------------------------------------------------------------------\r
-!\r
-!*       2.    OPENNING OF CLUOUT0\r
-!              -------------------\r
-!\r
-CALL OPEN_ll(UNIT=ILUOUT0,FILE=CLUOUT0,IOSTAT=IRESP,FORM='FORMATTED',ACTION='WRITE', &\r
-     MODE=GLOBAL)\r
-!\r
-!-------------------------------------------------------------------------------\r
-!\r
-!*       3.    OPENNING OF PRE_NEST_PGD1.nam\r
-!              -----------------------------\r
-!\r
-CALL OPEN_ll(UNIT=IPRE_NEST_PGD,FILE=HPRE_NEST_PGD,IOSTAT=IRESP,FORM='FORMATTED',ACTION='READ', &\r
-     MODE=GLOBAL)\r
-!reading of NAM_CONFZ\r
-CALL FMLOOK_ll(HPRE_NEST_PGD,HPRE_NEST_PGD,ILUOUT,IRESP)\r
-CALL POSNAM(IPRE_NEST_PGD,'NAM_CONFZ',GFOUND)\r
-IF (GFOUND) READ(UNIT=IPRE_NEST_PGD,NML=NAM_CONFZ)\r
-!\r
-!JUAN\r
-CALL POSNAM(IPRE_NEST_PGD,'NAM_CONF_NEST',GFOUND)\r
-IF (GFOUND) THEN\r
-   NHALO_MNH = NHALO_CONF_MNH\r
-   READ(UNIT=IPRE_NEST_PGD,NML=NAM_CONF_NEST)\r
-   NHALO_CONF_MNH = NHALO_MNH\r
-END IF\r
-!JUAN\r
-!\r
-!-------------------------------------------------------------------------------\r
-!\r
-!*       4.    READING OF THE OTHER FILE NAMES\r
-!              -------------------------------\r
-!\r
-YPGD1='                            '\r
-YPGD2='                            '\r
-YPGD3='                            '\r
-YPGD4='                            '\r
-YPGD5='                            '\r
-YPGD6='                            '\r
-YPGD7='                            '\r
-YPGD8='                            '\r
-NDAD(:)=0\r
-GADD=.TRUE.\r
-!\r
-DO JPGD=1,JPMODELMAX\r
-  IDAD=0\r
-  IF (JPGD==1) THEN\r
-    CALL POSNAM(IPRE_NEST_PGD,'NAM_PGD1',GFOUND)\r
-    IF (GFOUND) READ(UNIT=IPRE_NEST_PGD,NML=NAM_PGD1)\r
-  END IF\r
-  IF (JPGD==2) THEN\r
-    CALL POSNAM(IPRE_NEST_PGD,'NAM_PGD2',GFOUND)\r
-    IF (GFOUND) READ(UNIT=IPRE_NEST_PGD,NML=NAM_PGD2)\r
-  END IF\r
-  IF (JPGD==3) THEN\r
-    CALL POSNAM(IPRE_NEST_PGD,'NAM_PGD3',GFOUND)\r
-    IF (GFOUND) READ(UNIT=IPRE_NEST_PGD,NML=NAM_PGD3)\r
-  END IF\r
-  IF (JPGD==4) THEN\r
-    CALL POSNAM(IPRE_NEST_PGD,'NAM_PGD4',GFOUND)\r
-    IF (GFOUND) READ(UNIT=IPRE_NEST_PGD,NML=NAM_PGD4)\r
-  END IF\r
-  IF (JPGD==5) THEN\r
-    CALL POSNAM(IPRE_NEST_PGD,'NAM_PGD5',GFOUND)\r
-    IF (GFOUND) READ(UNIT=IPRE_NEST_PGD,NML=NAM_PGD5)\r
-  END IF\r
-  IF (JPGD==6) THEN\r
-    CALL POSNAM(IPRE_NEST_PGD,'NAM_PGD6',GFOUND)\r
-    IF (GFOUND) READ(UNIT=IPRE_NEST_PGD,NML=NAM_PGD6)\r
-  END IF\r
-  IF (JPGD==7) THEN\r
-    CALL POSNAM(IPRE_NEST_PGD,'NAM_PGD7',GFOUND)\r
-    IF (GFOUND) READ(UNIT=IPRE_NEST_PGD,NML=NAM_PGD7)\r
-  END IF\r
-  IF (JPGD==8) THEN\r
-    CALL POSNAM(IPRE_NEST_PGD,'NAM_PGD8',GFOUND)\r
-    IF (GFOUND) READ(UNIT=IPRE_NEST_PGD,NML=NAM_PGD8)\r
-  END IF\r
-  !\r
-  IF (JPGD==1) YPGD=YPGD1\r
-  IF (JPGD==2) YPGD=YPGD2\r
-  IF (JPGD==3) YPGD=YPGD3\r
-  IF (JPGD==4) YPGD=YPGD4\r
-  IF (JPGD==5) YPGD=YPGD5\r
-  IF (JPGD==6) YPGD=YPGD6\r
-  IF (JPGD==7) YPGD=YPGD7\r
-  IF (JPGD==8) YPGD=YPGD8\r
-  !\r
-  IF (LEN_TRIM(YPGD) == 0) THEN\r
-    IF (JPGD==1) THEN\r
-      WRITE(ILUOUT0,*) 'No pgd file was present for model 1 in namelist NAM_PGD1'\r
-!callabortstop\r
-      CALL CLOSE_ll(CLUOUT0,IOSTAT=IRESP)\r
-      CALL ABORT\r
-      STOP\r
-    ELSE\r
-      GADD=.FALSE.\r
-      CYCLE\r
-    END IF\r
-  END IF\r
-  !\r
-  IF ( (IDAD<1 .OR. IDAD>JPMODELMAX) .AND. (JPGD>1) ) THEN\r
-      WRITE(ILUOUT0,*) 'No father indicated for model ',JPGD,' in namelist NAM_PGD',JPGD\r
-!callabortstop\r
-      CALL CLOSE_ll(CLUOUT0,IOSTAT=IRESP)\r
-      CALL ABORT\r
-      STOP\r
-  END IF\r
-  !\r
-  IF (GADD) THEN\r
-    NMODEL=JPGD\r
-    !\r
-    IF (IDAD>=JPGD) THEN\r
-      WRITE(ILUOUT0,*) 'pgd files are not correctly ordered:'\r
-      WRITE(ILUOUT0,*) ' in namelist NAM_PGD',JPGD,' was found IDAD= ', IDAD\r
-!callabortstop\r
-      CALL CLOSE_ll(CLUOUT0,IOSTAT=IRESP)\r
-      CALL ABORT\r
-      STOP\r
-    END IF\r
-    !\r
-    NDAD(JPGD)=IDAD\r
-    HPGD(JPGD)=YPGD\r
-  END IF\r
-END DO\r
-!\r
-!-------------------------------------------------------------------------------\r
-!\r
-!*       5.    NAMES OF OUTPUT PGD FILES\r
-!              -------------------------\r
-!\r
-CALL POSNAM(IPRE_NEST_PGD,'NAM_NEST_PGD',GFOUND,ILUOUT0)\r
-IF (GFOUND) READ(UNIT=IPRE_NEST_PGD,NML=NAM_NEST_PGD)\r
-HNESTPGD(:) = '                            '\r
-!\r
-YSHORTPGD(:)=HPGD(:)\r
-DO JPGD=1,NMODEL\r
-  HNESTPGD(JPGD) = ADJUSTR( YSHORTPGD(JPGD))//'.nest'//ADJUSTL(YNEST)\r
-  HNESTPGD(JPGD) = ADJUSTL(HNESTPGD(JPGD))\r
-END DO\r
-#ifdef MNH_NCWRIT\r
-CALL POSNAM(IPRE_NEST_PGD,'NAM_NCOUT',GFOUND,ILUOUT0)\r
-IF (GFOUND) READ(UNIT=IPRE_NEST_PGD,NML=NAM_NCOUT)\r
-#endif\r
-!\r
-CALL POSNAM(IPRE_NEST_PGD,'NAM_CONFIO',GFOUND,ILUOUT0)\r
-IF (GFOUND) READ(UNIT=IPRE_NEST_PGD,NML=NAM_CONFIO)\r
-CALL SET_CONFIO_ll(LCDF4, LLFIOUT, LLFIREAD)\r
-!\r
-!-------------------------------------------------------------------------------\r
-CALL CLOSE_ll(HPRE_NEST_PGD)\r
-!-------------------------------------------------------------------------------\r
-!\r
-!*       6.    OPENING OF INPUT AND OUTPUT PGD FILES\r
-!              -------------------------------------\r
-!\r
-DO JPGD=1,NMODEL\r
-  CALL FMOPEN_ll(HPGD(JPGD),'READ',CLUOUT0,0,2,NVERB,ININAR,IRESP,OPARALLELIO=.FALSE.)\r
-  CALL FMOPEN_ll(HNESTPGD(JPGD),'WRITE',CLUOUT0,0,1,NVERB,ININAR,IRESP)\r
-END DO\r
-!\r
-!-------------------------------------------------------------------------------\r
-!\r
-!*       7.    OPENING OF OUPUT LISTING FILES FOR ALL MODELS\r
-!              ----------------------------------------------\r
-!\r
-DO JPGD=1,NMODEL\r
-  CALL GOTO_MODEL(JPGD)\r
-  WRITE(YLUOUT,'("OUTPUT_LISTING",I0)') JPGD\r
-  CALL OPEN_LUOUT_n(YLUOUT)\r
-END DO\r
-!\r
-!-------------------------------------------------------------------------------\r
-!\r
-END SUBROUTINE OPEN_NESTPGD_FILES\r
+!MNH_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
+!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
+!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt  
+!MNH_LIC for details. version 1.
+!-----------------------------------------------------------------
+!--------------- special set of characters for RCS information
+!-----------------------------------------------------------------
+! $Source$ $Revision$
+!-----------------------------------------------------------------
+!#############################
+MODULE MODI_OPEN_NESTPGD_FILES
+!#############################
+!
+INTERFACE
+      SUBROUTINE OPEN_NESTPGD_FILES(HPGD,HNESTPGD)
+!
+CHARACTER(LEN=28), DIMENSION(:), INTENT(OUT) :: HPGD     ! name of the input  pgd files
+CHARACTER(LEN=28), DIMENSION(:), INTENT(OUT) :: HNESTPGD ! name of the output pgd files
+END SUBROUTINE OPEN_NESTPGD_FILES
+END INTERFACE
+END MODULE MODI_OPEN_NESTPGD_FILES
+!     ############################################
+      SUBROUTINE OPEN_NESTPGD_FILES(HPGD,HNESTPGD)
+!     ############################################
+!
+!!****  *OPEN_NESTPGD_FILES* - openning of the files used in PREP_NEST_PGD
+!!                         
+!!
+!!    PURPOSE
+!!    -------
+!!
+!!**  METHOD
+!!    ------
+!!
+!!    CAUTION:
+!!    This routine supposes the name of the namelist file is 'PRE_NEST_PGD1.nam'.
+!!
+!!    EXTERNAL
+!!    --------
+!!
+!!    Routine FMOPEN
+!!
+!!    IMPLICIT ARGUMENTS
+!!    ------------------
+!!
+!!      Module MODD_LUNIT     :  contains logical unit names for all models
+!!         CLUOUT0  : name of output-listing
+!!
+!!    REFERENCE
+!!    ---------
+!!
+!!      Book 2
+!!
+!!    AUTHOR
+!!    ------
+!!     
+!!      V.Masson  Meteo-France
+!!
+!!    MODIFICATIONS
+!!    -------------
+!!      Original     26/09/96
+!!                   30/07/97 (Masson) group MODI_OPEN_LUOUTn
+!!                   15/10/01 (I.Mallet) allow namelists in different orders
+!!                   07/06/2010 (J.escobar from Ivan Ristic) bug PGI
+!!                   30/12/2012 (S.Bielli) Add NAM_NCOUT for netcdf output
+!!    J.Escobar : 15/09/2015 : WENO5 & JPHEXT <> 1 
+!!                   11/2015 (M.Moge) disable the creation of files on multiple 
+!!                                 Z-levels when using parallel IO for PREP_PGD
+!!                   01/2016 (M.Moge) Bug fix : open the output file using Z-parallel IO
+!-------------------------------------------------------------------------------
+!
+!*       0.    DECLARATIONS
+!              ------------
+!
+USE MODD_LUNIT
+USE MODD_CONF
+USE MODD_NESTING
+USE MODD_PARAMETERS
+!
+USE MODI_OPEN_LUOUTn
+!
+USE MODE_IO_ll
+USE MODE_FM
+USE MODE_POS
+!
+USE MODE_MODELN_HANDLER
+!
+#ifdef MNH_NCWRIT
+USE MODN_NCOUT
+#endif
+USE MODN_CONFIO
+!
+USE MODD_PARAMETERS, ONLY : JPHEXT  
+USE MODD_CONF, ONLY       : NHALO_CONF_MNH => NHALO
+!
+USE  MODN_CONFZ
+!
+IMPLICIT NONE
+!
+!*       0.1   Declaration of arguments
+!              ------------------------
+!
+CHARACTER(LEN=28), DIMENSION(:), INTENT(OUT) :: HPGD     ! name of the input  pgd files
+CHARACTER(LEN=28), DIMENSION(:), INTENT(OUT) :: HNESTPGD ! name of the output pgd files
+!
+!*       0.2   Declaration of local variables
+!              ------------------------------
+!
+INTEGER :: IRESP      ! return-code if problems eraised
+INTEGER :: ILUOUT0    ! logical unit for listing file
+INTEGER :: ININAR     ! number of articles initially present in a FM file
+LOGICAL :: GFOUND     ! Return code when searching namelist
+!
+CHARACTER(LEN=28) :: HPRE_NEST_PGD ! name of namelist file
+INTEGER           :: IPRE_NEST_PGD ! logical unit of namelist file
+!
+CHARACTER(LEN=28)                        :: YPGD      ! name of the pgd file for each model
+CHARACTER(LEN=28)                        :: YLUOUT    ! name of output listing file for each model
+CHARACTER(LEN=2)                         :: YNEST     ! to define the output pgd file names
+CHARACTER(LEN=28)                        :: YPGD1, YPGD2, YPGD3, YPGD4, &
+                                            YPGD5, YPGD6, YPGD7, YPGD8
+!                                                     ! name of all pgd files
+!                                                     ! in the namelist
+INTEGER                        :: IDAD    ! father of one model
+INTEGER                        :: JPGD    ! loop counter
+LOGICAL                        :: GADD    !
+CHARACTER(LEN=21), DIMENSION(JPMODELMAX) :: YSHORTPGD 
+INTEGER                                  :: NHALO_MNH
+!
+INTEGER :: ILUNAM,ILUOUT              ! Logical unit number for the EXSPA file
+!
+!*       0.3   Declaration of namelists
+!              ------------------------
+!
+NAMELIST/NAM_PGD1/ YPGD1
+NAMELIST/NAM_PGD2/ YPGD2, IDAD
+NAMELIST/NAM_PGD3/ YPGD3, IDAD
+NAMELIST/NAM_PGD4/ YPGD4, IDAD
+NAMELIST/NAM_PGD5/ YPGD5, IDAD
+NAMELIST/NAM_PGD6/ YPGD6, IDAD
+NAMELIST/NAM_PGD7/ YPGD7, IDAD
+NAMELIST/NAM_PGD8/ YPGD8, IDAD
+NAMELIST/NAM_NEST_PGD/ YNEST
+NAMELIST/NAM_CONF_NEST/JPHEXT, NHALO_MNH
+!-------------------------------------------------------------------------------
+!
+!*       1.    SET DEFAULT NAMES
+!              -----------------
+!
+DO JPGD=1,JPMODELMAX
+  HPGD    (JPGD)='                           '
+  HNESTPGD(JPGD)='                           '
+END DO
+!
+HPRE_NEST_PGD='PRE_NEST_PGD1.nam'
+CLUOUT0='OUTPUT_LISTING0'
+!
+!-------------------------------------------------------------------------------
+!
+!*       2.    OPENNING OF CLUOUT0
+!              -------------------
+!
+CALL OPEN_ll(UNIT=ILUOUT0,FILE=CLUOUT0,IOSTAT=IRESP,FORM='FORMATTED',ACTION='WRITE', &
+     MODE=GLOBAL)
+!
+!-------------------------------------------------------------------------------
+!
+!*       3.    OPENNING OF PRE_NEST_PGD1.nam
+!              -----------------------------
+!
+CALL OPEN_ll(UNIT=IPRE_NEST_PGD,FILE=HPRE_NEST_PGD,IOSTAT=IRESP,FORM='FORMATTED',ACTION='READ', &
+     MODE=GLOBAL)
+!reading of NAM_CONFZ
+CALL FMLOOK_ll(HPRE_NEST_PGD,HPRE_NEST_PGD,ILUOUT,IRESP)
+CALL POSNAM(IPRE_NEST_PGD,'NAM_CONFZ',GFOUND)
+IF (GFOUND) READ(UNIT=IPRE_NEST_PGD,NML=NAM_CONFZ)
+!
+!JUAN
+CALL POSNAM(IPRE_NEST_PGD,'NAM_CONF_NEST',GFOUND)
+IF (GFOUND) THEN
+   NHALO_MNH = NHALO_CONF_MNH
+   READ(UNIT=IPRE_NEST_PGD,NML=NAM_CONF_NEST)
+   NHALO_CONF_MNH = NHALO_MNH
+END IF
+!JUAN
+!
+!-------------------------------------------------------------------------------
+!
+!*       4.    READING OF THE OTHER FILE NAMES
+!              -------------------------------
+!
+YPGD1='                            '
+YPGD2='                            '
+YPGD3='                            '
+YPGD4='                            '
+YPGD5='                            '
+YPGD6='                            '
+YPGD7='                            '
+YPGD8='                            '
+NDAD(:)=0
+GADD=.TRUE.
+!
+DO JPGD=1,JPMODELMAX
+  IDAD=0
+  IF (JPGD==1) THEN
+    CALL POSNAM(IPRE_NEST_PGD,'NAM_PGD1',GFOUND)
+    IF (GFOUND) READ(UNIT=IPRE_NEST_PGD,NML=NAM_PGD1)
+  END IF
+  IF (JPGD==2) THEN
+    CALL POSNAM(IPRE_NEST_PGD,'NAM_PGD2',GFOUND)
+    IF (GFOUND) READ(UNIT=IPRE_NEST_PGD,NML=NAM_PGD2)
+  END IF
+  IF (JPGD==3) THEN
+    CALL POSNAM(IPRE_NEST_PGD,'NAM_PGD3',GFOUND)
+    IF (GFOUND) READ(UNIT=IPRE_NEST_PGD,NML=NAM_PGD3)
+  END IF
+  IF (JPGD==4) THEN
+    CALL POSNAM(IPRE_NEST_PGD,'NAM_PGD4',GFOUND)
+    IF (GFOUND) READ(UNIT=IPRE_NEST_PGD,NML=NAM_PGD4)
+  END IF
+  IF (JPGD==5) THEN
+    CALL POSNAM(IPRE_NEST_PGD,'NAM_PGD5',GFOUND)
+    IF (GFOUND) READ(UNIT=IPRE_NEST_PGD,NML=NAM_PGD5)
+  END IF
+  IF (JPGD==6) THEN
+    CALL POSNAM(IPRE_NEST_PGD,'NAM_PGD6',GFOUND)
+    IF (GFOUND) READ(UNIT=IPRE_NEST_PGD,NML=NAM_PGD6)
+  END IF
+  IF (JPGD==7) THEN
+    CALL POSNAM(IPRE_NEST_PGD,'NAM_PGD7',GFOUND)
+    IF (GFOUND) READ(UNIT=IPRE_NEST_PGD,NML=NAM_PGD7)
+  END IF
+  IF (JPGD==8) THEN
+    CALL POSNAM(IPRE_NEST_PGD,'NAM_PGD8',GFOUND)
+    IF (GFOUND) READ(UNIT=IPRE_NEST_PGD,NML=NAM_PGD8)
+  END IF
+  !
+  IF (JPGD==1) YPGD=YPGD1
+  IF (JPGD==2) YPGD=YPGD2
+  IF (JPGD==3) YPGD=YPGD3
+  IF (JPGD==4) YPGD=YPGD4
+  IF (JPGD==5) YPGD=YPGD5
+  IF (JPGD==6) YPGD=YPGD6
+  IF (JPGD==7) YPGD=YPGD7
+  IF (JPGD==8) YPGD=YPGD8
+  !
+  IF (LEN_TRIM(YPGD) == 0) THEN
+    IF (JPGD==1) THEN
+      WRITE(ILUOUT0,*) 'No pgd file was present for model 1 in namelist NAM_PGD1'
+!callabortstop
+      CALL CLOSE_ll(CLUOUT0,IOSTAT=IRESP)
+      CALL ABORT
+      STOP
+    ELSE
+      GADD=.FALSE.
+      CYCLE
+    END IF
+  END IF
+  !
+  IF ( (IDAD<1 .OR. IDAD>JPMODELMAX) .AND. (JPGD>1) ) THEN
+      WRITE(ILUOUT0,*) 'No father indicated for model ',JPGD,' in namelist NAM_PGD',JPGD
+!callabortstop
+      CALL CLOSE_ll(CLUOUT0,IOSTAT=IRESP)
+      CALL ABORT
+      STOP
+  END IF
+  !
+  IF (GADD) THEN
+    NMODEL=JPGD
+    !
+    IF (IDAD>=JPGD) THEN
+      WRITE(ILUOUT0,*) 'pgd files are not correctly ordered:'
+      WRITE(ILUOUT0,*) ' in namelist NAM_PGD',JPGD,' was found IDAD= ', IDAD
+!callabortstop
+      CALL CLOSE_ll(CLUOUT0,IOSTAT=IRESP)
+      CALL ABORT
+      STOP
+    END IF
+    !
+    NDAD(JPGD)=IDAD
+    HPGD(JPGD)=YPGD
+  END IF
+END DO
+!
+!-------------------------------------------------------------------------------
+!
+!*       5.    NAMES OF OUTPUT PGD FILES
+!              -------------------------
+!
+CALL POSNAM(IPRE_NEST_PGD,'NAM_NEST_PGD',GFOUND,ILUOUT0)
+IF (GFOUND) READ(UNIT=IPRE_NEST_PGD,NML=NAM_NEST_PGD)
+HNESTPGD(:) = '                            '
+!
+YSHORTPGD(:)=HPGD(:)
+DO JPGD=1,NMODEL
+  HNESTPGD(JPGD) = ADJUSTR( YSHORTPGD(JPGD))//'.nest'//ADJUSTL(YNEST)
+  HNESTPGD(JPGD) = ADJUSTL(HNESTPGD(JPGD))
+END DO
+#ifdef MNH_NCWRIT
+CALL POSNAM(IPRE_NEST_PGD,'NAM_NCOUT',GFOUND,ILUOUT0)
+IF (GFOUND) READ(UNIT=IPRE_NEST_PGD,NML=NAM_NCOUT)
+#endif
+!
+CALL POSNAM(IPRE_NEST_PGD,'NAM_CONFIO',GFOUND,ILUOUT0)
+IF (GFOUND) READ(UNIT=IPRE_NEST_PGD,NML=NAM_CONFIO)
+CALL SET_CONFIO_ll(LCDF4, LLFIOUT, LLFIREAD)
+!
+!-------------------------------------------------------------------------------
+CALL CLOSE_ll(HPRE_NEST_PGD)
+!-------------------------------------------------------------------------------
+!
+!*       6.    OPENING OF INPUT AND OUTPUT PGD FILES
+!              -------------------------------------
+!
+DO JPGD=1,NMODEL
+  CALL FMOPEN_ll(HPGD(JPGD),'READ',CLUOUT0,0,2,NVERB,ININAR,IRESP,OPARALLELIO=.FALSE.)
+  CALL FMOPEN_ll(HNESTPGD(JPGD),'WRITE',CLUOUT0,0,1,NVERB,ININAR,IRESP)
+END DO
+!
+!-------------------------------------------------------------------------------
+!
+!*       7.    OPENING OF OUPUT LISTING FILES FOR ALL MODELS
+!              ----------------------------------------------
+!
+DO JPGD=1,NMODEL
+  CALL GOTO_MODEL(JPGD)
+  WRITE(YLUOUT,'("OUTPUT_LISTING",I0)') JPGD
+  CALL OPEN_LUOUT_n(YLUOUT)
+END DO
+!
+!-------------------------------------------------------------------------------
+!
+END SUBROUTINE OPEN_NESTPGD_FILES
index 02cb7a6..70f6a83 100644 (file)
-!     #########\r
-       SUBROUTINE BUILD_EMISSTAB_n(HPROGRAM,KCH,HEMIS_GR_NAME, KNBTIMES,&\r
-              KEMIS_GR_TIME,KOFFNDX,TPEMISS,KSIZE,KLUOUT, KVERB,PRHODREF)  \r
-!!    #####################################################################\r
-!!\r
-!!*** *BUILD_EMISSTAB*\r
-!!\r
-!!    PURPOSE\r
-!!    -------\r
-!!\r
-!!**  METHOD\r
-!!    ------\r
-!!\r
-!!    AUTHOR\r
-!!    ------\r
-!!    D. Gazen\r
-!!\r
-!!    MODIFICATIONS\r
-!!    -------------\r
-!!    Original 01/02/00\r
-!!    C. Mari  30/10/00  call of MODD_TYPE_EFUTIL and MODD_CST\r
-!!    D.Gazen  01/12/03  change emissions handling for surf. externalization!!\r
-!!    P.Tulet  01/01/04  change conversion for externalization (flux unit is\r
-!!                        molec./m2/s)\r
-!!    M.Leriche  04/14   apply conversion factor if lead = f\r
-!!    M.Moge    01/2016  using READ_SURF_FIELD2D for 2D surfex fields reads\r
-!!\r
-!!    EXTERNAL\r
-!!    --------\r
-USE MODI_CH_OPEN_INPUTB\r
-USE MODI_READ_SURF_FIELD2D\r
-!!\r
-!!    IMPLICIT ARGUMENTS\r
-!!    ------------------\r
-USE MODD_TYPE_EFUTIL, ONLY : EMISSVAR_T\r
-USE MODD_CSTS,        ONLY : NDAYSEC, XMD, XAVOGADRO\r
-USE MODD_CH_SURF_n,   ONLY : XCONVERSION\r
-!------------------------------------------------------------------------------\r
-!\r
-!*       0.   DECLARATIONS\r
-!        -----------------\r
-!\r
-USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK\r
-USE PARKIND1  ,ONLY : JPRB\r
-!\r
-USE MODI_ABOR1_SFX\r
-!\r
-IMPLICIT NONE\r
-!\r
-!*       0.1  declaration of arguments\r
-!\r
- CHARACTER(LEN=6),                INTENT(IN) :: HPROGRAM   ! Program name\r
-INTEGER,                         INTENT(IN) :: KCH\r
- CHARACTER(LEN=*),DIMENSION(:),   INTENT(IN) :: HEMIS_GR_NAME ! Offline species name\r
-INTEGER, DIMENSION(:),           INTENT(IN) :: KNBTIMES ! nb of emis times array\r
-INTEGER, DIMENSION(:),           INTENT(IN) :: KEMIS_GR_TIME\r
-INTEGER, DIMENSION(:),           INTENT(IN) :: KOFFNDX ! index of offline species\r
-TYPE(EMISSVAR_T),DIMENSION(:),   INTENT(OUT):: TPEMISS ! emission struct array to fill\r
-INTEGER,                         INTENT(IN) :: KSIZE   ! size X*Y (1D) of physical domain\r
-INTEGER,                         INTENT(IN) :: KLUOUT  ! output listing channel\r
-INTEGER,                         INTENT(IN) :: KVERB   ! verbose level\r
-REAL, DIMENSION(:),              INTENT(IN) :: PRHODREF ! dry density for ref. state\r
-!\r
-!\r
-!*       0.2  declaration of local variables\r
-!\r
- CHARACTER(LEN=3):: YUNIT       ! unit of the flux\r
-INTEGER         :: INBTS       ! Number of emis times for a species\r
-INTEGER         :: IRESP       ! I/O return value\r
-INTEGER         :: IIND1, IIND2\r
-INTEGER         :: JSPEC       ! loop index\r
-INTEGER         :: ITIME       ! loop index\r
-INTEGER         :: IWS_DEFAULT ! Default Memory window size for emission reading\r
- CHARACTER (LEN=16):: YRECFM    ! LFI article name\r
-REAL(KIND=JPRB) :: ZHOOK_HANDLE\r
-\r
-!\r
-!------------------------------------------------------------------------------\r
-!\r
-!*    EXECUTABLE STATEMENTS\r
-!     ---------------------\r
-!\r
-\r
-IF (LHOOK) CALL DR_HOOK('BUILD_EMISSTAB_N',0,ZHOOK_HANDLE)\r
-IF (KVERB >= 5) THEN\r
-  WRITE(KLUOUT,*) '********     SUBROUTINE (CHIMIE): BUILD_EMISSTAB_n     ********'\r
-END IF\r
-!\r
-!*       1.   READ DATA \r
-!        --------------\r
-!\r
- CALL CH_OPEN_INPUTB("EMISUNIT", KCH, KLUOUT)\r
-!\r
-! read unit identifier\r
-READ(KCH,'(A3)') YUNIT\r
-!\r
-!\r
-!*       2.   MAP DATA ONTO PROGNOSTIC VARIABLES\r
-!        ---------------------------------------\r
-!\r
-ALLOCATE (XCONVERSION(SIZE(PRHODREF,1)))\r
-! determine the conversion factor\r
-  XCONVERSION(:) = 1.\r
-SELECT CASE (YUNIT)\r
-CASE ('MIX') ! flux given ppp*m/s,  conversion to molec/m2/s\r
-! where 1 molecule/cm2/s = (224.14/6.022136E23) ppp*m/s\r
-  XCONVERSION(:) = XAVOGADRO * PRHODREF(:) / XMD\r
-CASE ('CON') ! flux given in molecules/cm2/s, conversion to molec/m2/s \r
-  XCONVERSION(:) =  1E4\r
-CASE ('MOL') ! flux given in microMol/m2/day, conversion to molec/m2/s  \r
-! where 1 microMol/m2/day = (22.414/86.400)*1E-12 ppp*m/s\r
-  !XCONVERSION(:) = (22.414/86.400)*1E-12 * XAVOGADRO * PRHODREF(:) / XMD\r
-  XCONVERSION(:) = 1E-6 * XAVOGADRO / 86400.\r
-\r
-CASE DEFAULT\r
-  CALL ABOR1_SFX('CH_BUILDEMISSN: UNKNOWN CONVERSION FACTOR')\r
-END SELECT\r
-!\r
-! Read Window size default value >= 2\r
-IWS_DEFAULT = 5 ! Should be set by namelist\r
-IF (IWS_DEFAULT < 2) IWS_DEFAULT = 2\r
-!\r
-IIND1 = 0\r
-IIND2 = 0\r
-DO JSPEC=1,SIZE(TPEMISS) ! loop on offline emission species\r
-!\r
-  INBTS = KNBTIMES(JSPEC)\r
-!\r
-! Fill %CNAME\r
-  TPEMISS(JSPEC)%CNAME = HEMIS_GR_NAME(KOFFNDX(JSPEC))\r
-! Allocate and Fill %NETIMES \r
-  ALLOCATE(TPEMISS(JSPEC)%NETIMES(INBTS))\r
-  IIND1 = IIND2+1\r
-  IIND2 = IIND2+INBTS\r
-  TPEMISS(JSPEC)%NETIMES(:) = KEMIS_GR_TIME(IIND1:IIND2)\r
-! \r
-! Update %NWS, %NDX, %NTX, %LREAD, %XEMISDATA\r
-  IF (INBTS <= IWS_DEFAULT) THEN\r
-! Number of times smaller than read window size allowed\r
-! Read emis data once and for all\r
-    TPEMISS(JSPEC)%NWS = INBTS\r
-    TPEMISS(JSPEC)%NDX = 1\r
-    TPEMISS(JSPEC)%NTX = 1\r
-    TPEMISS(JSPEC)%LREAD = .FALSE. ! to prevent future reading\r
-    ALLOCATE(TPEMISS(JSPEC)%XEMISDATA(KSIZE,INBTS))\r
-! Read file for emission data\r
-    YRECFM='E_'//TRIM(TPEMISS(JSPEC)%CNAME)\r
-    CALL READ_SURF_FIELD2D(HPROGRAM,TPEMISS(JSPEC)%XEMISDATA(:,:),YRECFM)\r
-!\r
-! Correction : Replace 999. with 0. value in the Emission FLUX\r
-! and apply conversion\r
-    WHERE(TPEMISS(JSPEC)%XEMISDATA(:,:) == 999.)\r
-      TPEMISS(JSPEC)%XEMISDATA(:,:) = 0. \r
-    END WHERE\r
-    WHERE(TPEMISS(JSPEC)%XEMISDATA(:,:) == 1.E20)\r
-      TPEMISS(JSPEC)%XEMISDATA(:,:) = 0. \r
-    END WHERE\r
-      DO ITIME=1,INBTS\r
-      ! XCONVERSION IS APPLIED IN CH_EMISSION_FLUXN ONLY FOR LREAD = T\r
-        TPEMISS(JSPEC)%XEMISDATA(:,ITIME) = TPEMISS(JSPEC)%XEMISDATA(:,ITIME) * XCONVERSION(:)\r
-        !TPEMISS(JSPEC)%XEMISDATA(:,ITIME) = TPEMISS(JSPEC)%XEMISDATA(:,ITIME)\r
-      END DO\r
-  ELSE\r
-! Read window size is smaller than number of emission times\r
-    TPEMISS(JSPEC)%NWS = IWS_DEFAULT\r
-    TPEMISS(JSPEC)%NDX = IWS_DEFAULT\r
-    TPEMISS(JSPEC)%NTX = 0\r
-    TPEMISS(JSPEC)%LREAD = .TRUE.\r
-    ALLOCATE(TPEMISS(JSPEC)%XEMISDATA(KSIZE,IWS_DEFAULT))\r
-  END IF\r
\r
-  IF (INBTS == 1) THEN\r
-    TPEMISS(JSPEC)%XFWORK=>TPEMISS(JSPEC)%XEMISDATA(:,1)\r
-  ELSE\r
-    ALLOCATE(TPEMISS(JSPEC)%XFWORK(KSIZE))\r
-  END IF\r
-! Compute index for periodic case\r
-  TPEMISS(JSPEC)%NPX = MAXVAL(MINLOC(TPEMISS(JSPEC)%NETIMES(:)+&\r
-         (1+(TPEMISS(JSPEC)%NETIMES(INBTS)-&\r
-         TPEMISS(JSPEC)%NETIMES(:))/NDAYSEC)*NDAYSEC))  \r
-!\r
-! Some di###ay\r
-  IF (KVERB >= 6) THEN\r
-    WRITE(KLUOUT,*) '====== Species ',TRIM(TPEMISS(JSPEC)%CNAME), ' ======'\r
-    WRITE(KLUOUT,*) '  Emission Times :' ,TPEMISS(JSPEC)%NETIMES\r
-    WRITE(KLUOUT,*) '  Current time index :' ,TPEMISS(JSPEC)%NTX\r
-    WRITE(KLUOUT,*) '  Current data index :' ,TPEMISS(JSPEC)%NDX\r
-    WRITE(KLUOUT,*) '  Periodic index = ',TPEMISS(JSPEC)%NPX,&\r
-            ' at time :',TPEMISS(JSPEC)%NETIMES(TPEMISS(JSPEC)%NPX)  \r
-    WRITE(KLUOUT,*) '  Read window size :', TPEMISS(JSPEC)%NWS\r
-    IF (TPEMISS(JSPEC)%LREAD) THEN\r
-      WRITE(KLUOUT,*) ' -> Data must be read during simulation.'\r
-    ELSE\r
-      WRITE(KLUOUT,*) ' -> Data already in memory.'\r
-    END IF\r
-  END IF\r
-END DO\r
-\r
-IF (KVERB >= 5) THEN\r
-  WRITE(KLUOUT,*) '******** END SUBROUTINE (CHIMIE) : BUILD_EMISSTAB_n     ********'\r
-END IF\r
-IF (LHOOK) CALL DR_HOOK('BUILD_EMISSTAB_N',1,ZHOOK_HANDLE)\r
-\r
-END SUBROUTINE BUILD_EMISSTAB_n\r
+!     #########
+       SUBROUTINE BUILD_EMISSTAB_n(HPROGRAM,KCH,HEMIS_GR_NAME, KNBTIMES,&
+              KEMIS_GR_TIME,KOFFNDX,TPEMISS,KSIZE,KLUOUT, KVERB,PRHODREF)  
+!!    #####################################################################
+!!
+!!*** *BUILD_EMISSTAB*
+!!
+!!    PURPOSE
+!!    -------
+!!
+!!**  METHOD
+!!    ------
+!!
+!!    AUTHOR
+!!    ------
+!!    D. Gazen
+!!
+!!    MODIFICATIONS
+!!    -------------
+!!    Original 01/02/00
+!!    C. Mari  30/10/00  call of MODD_TYPE_EFUTIL and MODD_CST
+!!    D.Gazen  01/12/03  change emissions handling for surf. externalization!!
+!!    P.Tulet  01/01/04  change conversion for externalization (flux unit is
+!!                        molec./m2/s)
+!!    M.Leriche  04/14   apply conversion factor if lead = f
+!!    M.Moge    01/2016  using READ_SURF_FIELD2D for 2D surfex fields reads
+!!
+!!    EXTERNAL
+!!    --------
+USE MODI_CH_OPEN_INPUTB
+USE MODI_READ_SURF_FIELD2D
+!!
+!!    IMPLICIT ARGUMENTS
+!!    ------------------
+USE MODD_TYPE_EFUTIL, ONLY : EMISSVAR_T
+USE MODD_CSTS,        ONLY : NDAYSEC, XMD, XAVOGADRO
+USE MODD_CH_SURF_n,   ONLY : XCONVERSION
+!------------------------------------------------------------------------------
+!
+!*       0.   DECLARATIONS
+!        -----------------
+!
+USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
+USE PARKIND1  ,ONLY : JPRB
+!
+USE MODI_ABOR1_SFX
+!
+IMPLICIT NONE
+!
+!*       0.1  declaration of arguments
+!
+ CHARACTER(LEN=6),                INTENT(IN) :: HPROGRAM   ! Program name
+INTEGER,                         INTENT(IN) :: KCH
+ CHARACTER(LEN=*),DIMENSION(:),   INTENT(IN) :: HEMIS_GR_NAME ! Offline species name
+INTEGER, DIMENSION(:),           INTENT(IN) :: KNBTIMES ! nb of emis times array
+INTEGER, DIMENSION(:),           INTENT(IN) :: KEMIS_GR_TIME
+INTEGER, DIMENSION(:),           INTENT(IN) :: KOFFNDX ! index of offline species
+TYPE(EMISSVAR_T),DIMENSION(:),   INTENT(OUT):: TPEMISS ! emission struct array to fill
+INTEGER,                         INTENT(IN) :: KSIZE   ! size X*Y (1D) of physical domain
+INTEGER,                         INTENT(IN) :: KLUOUT  ! output listing channel
+INTEGER,                         INTENT(IN) :: KVERB   ! verbose level
+REAL, DIMENSION(:),              INTENT(IN) :: PRHODREF ! dry density for ref. state
+!
+!
+!*       0.2  declaration of local variables
+!
+ CHARACTER(LEN=3):: YUNIT       ! unit of the flux
+INTEGER         :: INBTS       ! Number of emis times for a species
+INTEGER         :: IRESP       ! I/O return value
+INTEGER         :: IIND1, IIND2
+INTEGER         :: JSPEC       ! loop index
+INTEGER         :: ITIME       ! loop index
+INTEGER         :: IWS_DEFAULT ! Default Memory window size for emission reading
+ CHARACTER (LEN=16):: YRECFM    ! LFI article name
+REAL(KIND=JPRB) :: ZHOOK_HANDLE
+
+!
+!------------------------------------------------------------------------------
+!
+!*    EXECUTABLE STATEMENTS
+!     ---------------------
+!
+
+IF (LHOOK) CALL DR_HOOK('BUILD_EMISSTAB_N',0,ZHOOK_HANDLE)
+IF (KVERB >= 5) THEN
+  WRITE(KLUOUT,*) '********     SUBROUTINE (CHIMIE): BUILD_EMISSTAB_n     ********'
+END IF
+!
+!*       1.   READ DATA 
+!        --------------
+!
+ CALL CH_OPEN_INPUTB("EMISUNIT", KCH, KLUOUT)
+!
+! read unit identifier
+READ(KCH,'(A3)') YUNIT
+!
+!
+!*       2.   MAP DATA ONTO PROGNOSTIC VARIABLES
+!        ---------------------------------------
+!
+ALLOCATE (XCONVERSION(SIZE(PRHODREF,1)))
+! determine the conversion factor
+  XCONVERSION(:) = 1.
+SELECT CASE (YUNIT)
+CASE ('MIX') ! flux given ppp*m/s,  conversion to molec/m2/s
+! where 1 molecule/cm2/s = (224.14/6.022136E23) ppp*m/s
+  XCONVERSION(:) = XAVOGADRO * PRHODREF(:) / XMD
+CASE ('CON') ! flux given in molecules/cm2/s, conversion to molec/m2/s 
+  XCONVERSION(:) =  1E4
+CASE ('MOL') ! flux given in microMol/m2/day, conversion to molec/m2/s  
+! where 1 microMol/m2/day = (22.414/86.400)*1E-12 ppp*m/s
+  !XCONVERSION(:) = (22.414/86.400)*1E-12 * XAVOGADRO * PRHODREF(:) / XMD
+  XCONVERSION(:) = 1E-6 * XAVOGADRO / 86400.
+
+CASE DEFAULT
+  CALL ABOR1_SFX('CH_BUILDEMISSN: UNKNOWN CONVERSION FACTOR')
+END SELECT
+!
+! Read Window size default value >= 2
+IWS_DEFAULT = 5 ! Should be set by namelist
+IF (IWS_DEFAULT < 2) IWS_DEFAULT = 2
+!
+IIND1 = 0
+IIND2 = 0
+DO JSPEC=1,SIZE(TPEMISS) ! loop on offline emission species
+!
+  INBTS = KNBTIMES(JSPEC)
+!
+! Fill %CNAME
+  TPEMISS(JSPEC)%CNAME = HEMIS_GR_NAME(KOFFNDX(JSPEC))
+! Allocate and Fill %NETIMES 
+  ALLOCATE(TPEMISS(JSPEC)%NETIMES(INBTS))
+  IIND1 = IIND2+1
+  IIND2 = IIND2+INBTS
+  TPEMISS(JSPEC)%NETIMES(:) = KEMIS_GR_TIME(IIND1:IIND2)
+! 
+! Update %NWS, %NDX, %NTX, %LREAD, %XEMISDATA
+  IF (INBTS <= IWS_DEFAULT) THEN
+! Number of times smaller than read window size allowed
+! Read emis data once and for all
+    TPEMISS(JSPEC)%NWS = INBTS
+    TPEMISS(JSPEC)%NDX = 1
+    TPEMISS(JSPEC)%NTX = 1
+    TPEMISS(JSPEC)%LREAD = .FALSE. ! to prevent future reading
+    ALLOCATE(TPEMISS(JSPEC)%XEMISDATA(KSIZE,INBTS))
+! Read file for emission data
+    YRECFM='E_'//TRIM(TPEMISS(JSPEC)%CNAME)
+    CALL READ_SURF_FIELD2D(HPROGRAM,TPEMISS(JSPEC)%XEMISDATA(:,:),YRECFM)
+!
+! Correction : Replace 999. with 0. value in the Emission FLUX
+! and apply conversion
+    WHERE(TPEMISS(JSPEC)%XEMISDATA(:,:) == 999.)
+      TPEMISS(JSPEC)%XEMISDATA(:,:) = 0. 
+    END WHERE
+    WHERE(TPEMISS(JSPEC)%XEMISDATA(:,:) == 1.E20)
+      TPEMISS(JSPEC)%XEMISDATA(:,:) = 0. 
+    END WHERE
+      DO ITIME=1,INBTS
+      ! XCONVERSION IS APPLIED IN CH_EMISSION_FLUXN ONLY FOR LREAD = T
+        TPEMISS(JSPEC)%XEMISDATA(:,ITIME) = TPEMISS(JSPEC)%XEMISDATA(:,ITIME) * XCONVERSION(:)
+        !TPEMISS(JSPEC)%XEMISDATA(:,ITIME) = TPEMISS(JSPEC)%XEMISDATA(:,ITIME)
+      END DO
+  ELSE
+! Read window size is smaller than number of emission times
+    TPEMISS(JSPEC)%NWS = IWS_DEFAULT
+    TPEMISS(JSPEC)%NDX = IWS_DEFAULT
+    TPEMISS(JSPEC)%NTX = 0
+    TPEMISS(JSPEC)%LREAD = .TRUE.
+    ALLOCATE(TPEMISS(JSPEC)%XEMISDATA(KSIZE,IWS_DEFAULT))
+  END IF
+  IF (INBTS == 1) THEN
+    TPEMISS(JSPEC)%XFWORK=>TPEMISS(JSPEC)%XEMISDATA(:,1)
+  ELSE
+    ALLOCATE(TPEMISS(JSPEC)%XFWORK(KSIZE))
+  END IF
+! Compute index for periodic case
+  TPEMISS(JSPEC)%NPX = MAXVAL(MINLOC(TPEMISS(JSPEC)%NETIMES(:)+&
+         (1+(TPEMISS(JSPEC)%NETIMES(INBTS)-&
+         TPEMISS(JSPEC)%NETIMES(:))/NDAYSEC)*NDAYSEC))  
+!
+! Some di###ay
+  IF (KVERB >= 6) THEN
+    WRITE(KLUOUT,*) '====== Species ',TRIM(TPEMISS(JSPEC)%CNAME), ' ======'
+    WRITE(KLUOUT,*) '  Emission Times :' ,TPEMISS(JSPEC)%NETIMES
+    WRITE(KLUOUT,*) '  Current time index :' ,TPEMISS(JSPEC)%NTX
+    WRITE(KLUOUT,*) '  Current data index :' ,TPEMISS(JSPEC)%NDX
+    WRITE(KLUOUT,*) '  Periodic index = ',TPEMISS(JSPEC)%NPX,&
+            ' at time :',TPEMISS(JSPEC)%NETIMES(TPEMISS(JSPEC)%NPX)  
+    WRITE(KLUOUT,*) '  Read window size :', TPEMISS(JSPEC)%NWS
+    IF (TPEMISS(JSPEC)%LREAD) THEN
+      WRITE(KLUOUT,*) ' -> Data must be read during simulation.'
+    ELSE
+      WRITE(KLUOUT,*) ' -> Data already in memory.'
+    END IF
+  END IF
+END DO
+
+IF (KVERB >= 5) THEN
+  WRITE(KLUOUT,*) '******** END SUBROUTINE (CHIMIE) : BUILD_EMISSTAB_n     ********'
+END IF
+IF (LHOOK) CALL DR_HOOK('BUILD_EMISSTAB_N',1,ZHOOK_HANDLE)
+
+END SUBROUTINE BUILD_EMISSTAB_n
index 93b3576..71552a5 100644 (file)
-!     #########\r
-      SUBROUTINE CH_EMISSION_FLUX_n(HPROGRAM,PSIMTIME,PSFSV, PRHOA, PTSTEP, KNBTS_MAX)\r
-!     ######################################################################\r
-!!\r
-!!***  *CH_EMISSION_FLUX_n* - \r
-!!\r
-!!    PURPOSE\r
-!!    -------\r
-!!      Return a time-dependent emission flux based on tabulated values\r
-!!\r
-!!**  METHOD\r
-!!    ------\r
-!!\r
-!!    AUTHOR\r
-!!    ------\r
-!!    D. Gazen\r
-!!\r
-!!    MODIFICATIONS\r
-!!    -------------\r
-!!    Original 08/02/00\r
-!!    C. Mari  30/10/00 call to MODD_TYPE_EFUTIL and MODD_CST\r
-!!    D.Gazen  01/12/03  change emissions handling for surf. externalization\r
-!!    P.Tulet  01/01/04  change emission conversion factor\r
-!!    P.Tulet  01/01/05  add dust, orilam\r
-!!    M.Leriche    2015  suppress ZDEPOT\r
-!!    M.Moge    01/2016  using READ_SURF_FIELD2D for 2D surfex fields reads\r
-!!\r
-!!    EXTERNAL\r
-!!    --------\r
-!!\r
-!!\r
-!!    IMPLICIT ARGUMENTS\r
-!!    ------------------\r
-USE MODD_SV_n,             ONLY: CSV,NSV_CHSBEG,NSV_CHSEND, NSV_AERBEG,  NSV_AEREND\r
-USE MODD_TYPE_EFUTIL,      ONLY: EMISSVAR_T, PRONOSVAR_T\r
-USE MODD_CSTS,             ONLY: NDAYSEC\r
-USE MODD_CH_EMIS_FIELD_n,  ONLY: TSEMISS, TSPRONOSLIST, XTIME_SIMUL\r
-USE MODD_CH_SURF_n,        ONLY: XCONVERSION\r
-!\r
-USE MODI_READ_SURF_FIELD2D\r
-USE MODI_INIT_IO_SURF_n\r
-USE MODI_END_IO_SURF_n\r
-USE MODI_GET_LUOUT\r
-!UPG*AERO1\r
-USE MODD_CHS_AEROSOL, ONLY: LCH_AERO_FLUX\r
-USE MODI_CH_AER_EMISSION\r
-!UPG*AERO1\r
-!!\r
-!------------------------------------------------------------------------------\r
-!\r
-!*       0.   DECLARATIONS\r
-!        -----------------\r
-!\r
-USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK\r
-USE PARKIND1  ,ONLY : JPRB\r
-!\r
-USE MODI_ABOR1_SFX\r
-!\r
-IMPLICIT NONE\r
-!\r
-!*       0.1  declaration of arguments\r
-!\r
-CHARACTER(LEN=6),   INTENT(IN)  :: HPROGRAM    ! program calling surf. schemes\r
-REAL,               INTENT(IN)  :: PSIMTIME    ! time of simulation in sec UTC\r
-                                               ! (counting from midnight of\r
-                                               ! the current day)\r
-REAL,DIMENSION(:,:),  INTENT(INOUT) :: PSFSV   ! emission flux in ppp*m/s\r
-REAL, DIMENSION(:),   INTENT(IN)    :: PRHOA     ! air density (kg/m3)\r
-REAL,                 INTENT(IN)    :: PTSTEP    ! atmospheric time-step                 (s)\r
-INTEGER,              INTENT(IN)    :: KNBTS_MAX !max size of TEMISS%NETIMES\r
-\r
-!\r
-!*       0.2  declaration of local variables\r
-!\r
-INTEGER       :: IVERB   ! verbosity level\r
-INTEGER       :: KSIZE1D ! 1D size = X*Y physical domain \r
-INTEGER       :: JI      ! loop control\r
-REAL          :: ZALPHA  ! interpolation weight\r
-!\r
-INTEGER :: INBTS       ! Number of emission times for a species\r
-INTEGER :: ITIM1,ITIM2 ! first/last time for interpolation\r
-INTEGER :: INDX1,INDX2 ! first/next index for data interpolation\r
-INTEGER :: ISIMTIME, ITPERIOD\r
-CHARACTER (LEN=16)  :: YRECFM          ! LFI article name\r
-TYPE(PRONOSVAR_T),POINTER :: CURPRONOS !Current pronostic variable\r
-!\r
-!*       0.3  declaration of saved local variables\r
-!\r
-CHARACTER(LEN=6), DIMENSION(:), POINTER :: CNAMES\r
-REAL,DIMENSION(SIZE(PSFSV,1),KNBTS_MAX)     :: ZWORK ! temporary array for reading data\r
-REAL,DIMENSION(SIZE(PSFSV,1),SIZE(PSFSV,2)) :: ZEMIS ! interpolated in time emission flux\r
-REAL,DIMENSION(SIZE(PSFSV,1))               :: ZFCO  ! CO flux\r
-INTEGER                          :: INEQ  ! number of chemical var\r
-                                          !(=NEQ (chimie gaz) + NSV_AER (chimie aerosol)\r
-INTEGER                          :: IWS   ! window size\r
-INTEGER                          :: IRESP ! return code for I/O\r
-INTEGER                          :: ILUOUT ! Outputlisting unit\r
-LOGICAL                          :: LIOINIT ! True if I/O init done\r
-INTEGER                          :: JW\r
-INTEGER                          :: ITIME\r
-LOGICAL                          :: GCO = .FALSE. ! switch if CO emission are available\r
-REAL(KIND=JPRB) :: ZHOOK_HANDLE\r
-!\r
-!------------------------------------------------------------------------------\r
-!\r
-!*    EXECUTABLE STATEMENTS\r
-!     ---------------------\r
-!\r
-IF (LHOOK) CALL DR_HOOK('CH_EMISSION_FLUX_N',0,ZHOOK_HANDLE)\r
-CALL GET_LUOUT(HPROGRAM,ILUOUT)\r
-LIOINIT = .FALSE.\r
-IVERB   = 5\r
-KSIZE1D = SIZE(PSFSV,1)\r
-INEQ    = SIZE(PSFSV,2)\r
-!\r
-!------------------------------------------------------------------------------\r
-!\r
-!*    3.  INTERPOLATE SURFACE FLUXES IN TIME IF NEEDED\r
-!     ------------------------------------------------\r
-!\r
-IF (XTIME_SIMUL == 0.) THEN\r
-   XTIME_SIMUL = PSIMTIME\r
-ELSE\r
-   XTIME_SIMUL = XTIME_SIMUL + PTSTEP\r
-END IF\r
-\r
-IF (IVERB >= 5) WRITE(ILUOUT,*) '******** CH_EMISSION_FLUX  ********'\r
-DO JI=1,SIZE(TSEMISS)\r
-! Simulation time (counting from midnight) is saved\r
-  ISIMTIME = XTIME_SIMUL\r
-!\r
-  INBTS = SIZE(TSEMISS(JI)%NETIMES) ! \r
-  IWS   = TSEMISS(JI)%NWS           ! Window Size for I/O\r
-  INDX1 = TSEMISS(JI)%NDX           ! Current data index\r
-!\r
-  IF (INBTS == 1) THEN\r
-!   Time Constant Flux\r
-!   XFWORK already points on data (see build_emisstabn.F90)\r
-    IF (IVERB >= 6) THEN\r
-      WRITE(ILUOUT,*) 'NO interpolation for ',TRIM(TSEMISS(JI)%CNAME)\r
-      IF (IVERB >= 10 ) WRITE(ILUOUT,*) TSEMISS(JI)%XFWORK\r
-    END IF\r
-  ELSE\r
-    IF (IVERB >= 6) THEN\r
-      WRITE(ILUOUT,*) 'Interpolation (T =',ISIMTIME,') : ',TSEMISS(JI)%CNAME\r
-    END IF\r
-    IF (ISIMTIME < TSEMISS(JI)%NETIMES(1)) THEN\r
-!     Tsim < T(1)=Tmin should not happen but who knows ?\r
-      TSEMISS(JI)%NTX = 1\r
-    ELSE\r
-!     Check for periodicity when ISIMTIME is beyond last emission time\r
-!     and probably correct ISIMTIME\r
-      IF (ISIMTIME > TSEMISS(JI)%NETIMES(INBTS)) THEN \r
-!       Tsim > T(INBTS)=Tmax\r
-        ITPERIOD = (1+(TSEMISS(JI)%NETIMES(INBTS)-&\r
-                TSEMISS(JI)%NETIMES(TSEMISS(JI)%NPX))/NDAYSEC)*NDAYSEC  \r
-        ISIMTIME = MODULO(ISIMTIME-TSEMISS(JI)%NETIMES(TSEMISS(JI)%NPX),ITPERIOD)+&\r
-                TSEMISS(JI)%NETIMES(TSEMISS(JI)%NPX)  \r
-        IF (IVERB >= 6) THEN\r
-          WRITE(ILUOUT,*) '  ITPERIOD = ', ITPERIOD\r
-          WRITE(ILUOUT,*) '  ISIMTIME modifie = ', ISIMTIME\r
-        END IF\r
-        IF (TSEMISS(JI)%NTX == INBTS .AND. ISIMTIME<TSEMISS(JI)%NETIMES(INBTS)) THEN\r
-!         Update time index NTX \r
-          TSEMISS(JI)%NTX = TSEMISS(JI)%NPX\r
-!         Increment data index NDX : NDX correction will occur later\r
-!                                    to assure 1 <= NDX <= IWS\r
-          INDX1 = INDX1 + 1\r
-        END IF\r
-      END IF\r
-!\r
-!     search NTX such that : ETIMES(NTX) < ISIMTIME <= ETIMES(NTX+1)\r
-!     and make NDX follow NTX : NDX correction will occur later\r
-!                               to assure 1 <= NDX <= IWS\r
-      DO WHILE (TSEMISS(JI)%NTX < INBTS)\r
-        IF (ISIMTIME >= TSEMISS(JI)%NETIMES(TSEMISS(JI)%NTX+1)) THEN\r
-          TSEMISS(JI)%NTX = TSEMISS(JI)%NTX + 1\r
-          INDX1 = INDX1 + 1\r
-          INDX2 = INDX1 + 1\r
-        ELSE\r
-          EXIT\r
-        END IF\r
-      END DO\r
-    END IF\r
-!\r
-!   Check availability of data within memory Window (XEMISDATA(:,1:IWS))\r
-    IF (INDX1 >= IWS) THEN\r
-!\r
-!     Data index reached the memory window limits\r
-!\r
-      IF (TSEMISS(JI)%LREAD) THEN \r
-!\r
-!       File must be read to update XEMISDATA array for this species \r
-!\r
-        IF (.NOT. LIOINIT) THEN\r
-!         Must be done once before reading\r
-          CALL INIT_IO_SURF_n(HPROGRAM,'FULL  ','SURF  ','READ ')\r
-          IF (IVERB >= 6) WRITE(ILUOUT,*) 'INIT des I/O DONE.'\r
-          LIOINIT=.TRUE.\r
-        END IF\r
-        YRECFM='E_'//TRIM(TSEMISS(JI)%CNAME)\r
-        IF (IVERB >= 6)&\r
-               WRITE (ILUOUT,*) 'READ emission :',TRIM(YRECFM),&\r
-               ', SIZE(ZWORK)=',SIZE(ZWORK,1),INBTS \r
-        CALL READ_SURF_FIELD2D(HPROGRAM,ZWORK(:,1:INBTS),YRECFM)\r
-!\r
-! Correction : Replace 999. with 0. value in the Emission FLUX\r
-        WHERE(ZWORK(:,1:INBTS) == 999.)\r
-          ZWORK(:,1:INBTS) = 0. \r
-        END WHERE\r
-        WHERE(ZWORK(:,1:INBTS) == 1.E20)\r
-          ZWORK(:,1:INBTS) = 0. \r
-        END WHERE\r
-        DO ITIME=1,INBTS\r
-        ZWORK(:,ITIME) = ZWORK(:,ITIME)*XCONVERSION(:)\r
-        END DO\r
-!\r
-!       \r
-        IF ((TSEMISS(JI)%NTX+IWS-1) > INBTS) THEN\r
-!\r
-!         ===== Periodic CASE =====\r
-!\r
-          IF (IVERB >= 6)&\r
-                 WRITE (ILUOUT,*) 'Periodic CASE : NPX =',TSEMISS(JI)%NPX  \r
-          IF (IWS <  (INBTS-TSEMISS(JI)%NPX+1)) THEN\r
-!           Window size is smaller then number of periodical times\r
-!\r
-!           example : IWS=5, NPX=2, INBTS=11, NTX=9\r
-!                               NTX       NPX\r
-!                                |         |\r
-!           time index :      ...9 10 11 # 2 3 4...11 #\r
-!       old data index :[1 2 3 4 5] \r
-!       new data index :        [1  2  3   4 5]\r
-!                                |  \r
-!                               NDX    \r
-!\r
-            TSEMISS(JI)%XEMISDATA(:,1:INBTS-TSEMISS(JI)%NTX+1) = &\r
-                   ZWORK(:,TSEMISS(JI)%NTX:INBTS)  \r
-!\r
-            IF (IVERB >= 6) THEN\r
-              WRITE(ILUOUT,*) 'Window SIZE smaller than INBTS !'\r
-              WRITE(ILUOUT,*) 'Window index, Time index'\r
-              DO JW=1,INBTS-TSEMISS(JI)%NTX+1\r
-                WRITE(ILUOUT,*) JW,TSEMISS(JI)%NTX+JW-1\r
-              END DO\r
-            END IF\r
-!\r
-            TSEMISS(JI)%XEMISDATA(:,INBTS-TSEMISS(JI)%NTX+2:IWS) = &\r
-                   ZWORK(:,TSEMISS(JI)%NPX:TSEMISS(JI)%NPX+IWS-INBTS+TSEMISS(JI)%NTX-2)  \r
-!\r
-            IF (IVERB >= 6) THEN\r
-              DO JW=INBTS-TSEMISS(JI)%NTX+2,IWS\r
-                WRITE(ILUOUT,*) JW,TSEMISS(JI)%NPX+JW-(INBTS-TSEMISS(JI)%NTX+2)\r
-              END DO\r
-            END IF\r
-            INDX1 = 1\r
-            INDX2 = 2\r
-          ELSE\r
-!           Window size may get smaller AND it will be the last reading\r
-!\r
-!           example : IWS=6, NPX=7, INBTS=11, NTX=9\r
-!\r
-!                         NTX       NPX NTX\r
-!                          |         |   |\r
-!           time index: ...9 10 11 # 7 8 9 10 11 #\r
-!       old data index: ...6]\r
-!       new data index:             [1 2 3  4  5]\r
-!                                        |\r
-!                                       NDX=NTX-NPX+1\r
-!\r
-            IWS = INBTS-TSEMISS(JI)%NPX+1\r
-            TSEMISS(JI)%NWS = IWS\r
-            TSEMISS(JI)%XEMISDATA(:,1:IWS) = ZWORK(:,TSEMISS(JI)%NPX:INBTS)\r
-            IF (IVERB >= 6) THEN\r
-              WRITE(ILUOUT,*) 'Window SIZE equal or greater than INBTS !'\r
-              WRITE(ILUOUT,*) 'Window index, Time index'\r
-              DO JW=1,IWS\r
-                WRITE(ILUOUT,*) JW,TSEMISS(JI)%NPX+JW-1\r
-              END DO\r
-            END IF\r
-            INDX1 = TSEMISS(JI)%NTX-TSEMISS(JI)%NPX+1\r
-            INDX2 = MOD((INDX1+1),IWS)\r
-            TSEMISS(JI)%LREAD = .FALSE. ! no more reading\r
-          END IF\r
-        ELSE\r
-!\r
-!         ===== NON periodic (normal) CASE =====\r
-!\r
-! example : with IWS=5, the window moves forward\r
-!                             NTX\r
-!                              | \r
-!         time index : 1 2 3 4 5 6 7 8 9 10 11 ... INBTS # \r
-!     old data index :[1 2 3 4 5] \r
-!     new data index :        [1 2 3 4 5] \r
-!                              |\r
-!                             NDX\r
-!\r
-          TSEMISS(JI)%XEMISDATA(:,1:IWS) = ZWORK(:,TSEMISS(JI)%NTX:TSEMISS(JI)%NTX+IWS-1)\r
-          IF (IVERB >= 6) THEN\r
-            WRITE(ILUOUT,*) 'Window index, Time index'\r
-            DO JW=1,IWS\r
-              WRITE(ILUOUT,*) JW,TSEMISS(JI)%NTX+JW-1\r
-            END DO\r
-          END IF\r
-          INDX1 = 1\r
-          INDX2 = 2\r
-        END IF\r
-      ELSE\r
-!       Data is already in memory because window size is sufficient \r
-!       to hold INBTS emission times => simply update NDX according to NTX\r
-!       \r
-        IF (IWS==INBTS) THEN \r
-!\r
-!         'Window size' = 'Nb emis times' at INIT (ch_init_emission)\r
-!         so NDX must be set equal to NTX (the window does not move)\r
-! example :\r
-!                         NPX    NTX\r
-!                          |      | \r
-!         time index :  1  2  3  ... INBTS\r
-!         data index : [1  2  3  ... INBTS]\r
-!                                 |\r
-!                                NDX\r
-\r
-          INDX1 = TSEMISS(JI)%NTX\r
-          INDX2 = INDX1+1\r
-          IF (INDX2 > IWS) INDX2=TSEMISS(JI)%NPX\r
-        ELSE\r
-!          \r
-!         Windows size changed during periodic case\r
-!         NDX must be equal to NTX - NPX + 1\r
-!         (the window does not move)\r
-! example :\r
-!                                NTX\r
-!                                 | \r
-!         time index : NPX NPX+1 NPX+2 ... INBTS\r
-!         data index : [1    2    3    ...   IWS]\r
-!                                 |\r
-!                                NDX\r
-          INDX1 = TSEMISS(JI)%NTX-TSEMISS(JI)%NPX+1\r
-          INDX2 = MOD((INDX1+1),IWS)\r
-        END IF\r
-      END IF\r
-    ELSE ! (INDX1 < IWS)\r
-      INDX2 = INDX1+1\r
-    END IF\r
-!\r
-!   Don't forget to update NDX with new value INDX1\r
-    TSEMISS(JI)%NDX = INDX1\r
-!\r
-!   Compute both times for interpolation\r
-    IF (TSEMISS(JI)%NTX < INBTS) THEN \r
-      ITIM1 = TSEMISS(JI)%NETIMES(TSEMISS(JI)%NTX)\r
-      ITIM2 = TSEMISS(JI)%NETIMES(TSEMISS(JI)%NTX+1)\r
-    ELSE\r
-      ITIM1 = TSEMISS(JI)%NETIMES(INBTS)\r
-      ITIM2 = TSEMISS(JI)%NETIMES(TSEMISS(JI)%NPX)+ITPERIOD\r
-    END IF\r
-!\r
-! Interpolate variables in time -> update XFWORK\r
-!\r
-!\r
-!  time       :  ITIM1...Tsim...ITIM2\r
-!                  |              |  \r
-!  data index :  INDX1          INDX2\r
-!\r
-!\r
-    ZALPHA = (REAL(ISIMTIME) - ITIM1) / (ITIM2-ITIM1)\r
-    TSEMISS(JI)%XFWORK(:) = ZALPHA*TSEMISS(JI)%XEMISDATA(:,INDX2) +&\r
-            (1.-ZALPHA)*TSEMISS(JI)%XEMISDATA(:,INDX1)  \r
-    IF (IVERB >= 6) THEN\r
-      WRITE(ILUOUT,*) '  Current time INDEX : ',TSEMISS(JI)%NTX\r
-      WRITE(ILUOUT,*) '  TIME : ',ISIMTIME, ' (',ITIM1,',',ITIM2,')'\r
-      WRITE(ILUOUT,*) '  Window size : ',TSEMISS(JI)%NWS\r
-      WRITE(ILUOUT,*) '  Current data INDEX : ',INDX1,INDX2\r
-      IF (IVERB >= 10) WRITE(ILUOUT,*) '  FLUX : ',TSEMISS(JI)%XFWORK\r
-    END IF\r
-  END IF\r
-END DO\r
-! \r
-! Agregation : flux computation\r
-!\r
-ZEMIS(:,:) = 0.\r
-!\r
-! Point on head of Pronostic variable list\r
-! to cover the entire list.\r
-IF (NSV_AEREND > 0) THEN\r
-CNAMES=>CSV(NSV_CHSBEG:NSV_AEREND)\r
-ELSE\r
-CNAMES=>CSV(NSV_CHSBEG:NSV_CHSEND)\r
-END IF\r
-CURPRONOS=>TSPRONOSLIST\r
-DO WHILE(ASSOCIATED(CURPRONOS))\r
-  IF (CURPRONOS%NAMINDEX > INEQ) THEN\r
-    WRITE(ILUOUT,*) 'FATAL ERROR in CH_EMISSION_FLUXN : SIZE(ZEMIS,2) =',&\r
-           INEQ,', INDEX bugge =',CURPRONOS%NAMINDEX  \r
-    CALL ABOR1_SFX('CH_EMISSION_FLUXN: FATAL ERROR')\r
-  END IF\r
-  \r
-  ZEMIS(:,CURPRONOS%NAMINDEX) = 0.\r
-!\r
-! Loop on the number of agreg. coeff.\r
-  DO JI=1,CURPRONOS%NBCOEFF\r
-!   Compute agregated flux    \r
-    ZEMIS(:,CURPRONOS%NAMINDEX) = ZEMIS(:,CURPRONOS%NAMINDEX)+&\r
-            CURPRONOS%XCOEFF(JI)*TSEMISS(CURPRONOS%NEFINDEX(JI))%XFWORK(:)  \r
-  END DO\r
-\r
-  IF (IVERB >= 6) THEN\r
-    WRITE(ILUOUT,*) 'Agregation for ',CNAMES(CURPRONOS%NAMINDEX)\r
-    IF (IVERB >= 10) WRITE(ILUOUT,*) 'ZEMIS = ',ZEMIS(:,CURPRONOS%NAMINDEX)\r
-  END IF\r
-  IF ((CNAMES(CURPRONOS%NAMINDEX) == "CO") .AND. ANY(ZEMIS(:,CURPRONOS%NAMINDEX).GT.0.)) THEN\r
-  ZFCO(:) = ZEMIS(:,CURPRONOS%NAMINDEX)\r
-  GCO = .TRUE.\r
-  END IF\r
-\r
-  CURPRONOS=>CURPRONOS%NEXT\r
-!\r
-END DO\r
-!\r
-IF ((LCH_AERO_FLUX).AND.(NSV_AERBEG > 0)) THEN\r
-  IF (GCO) THEN\r
-    CALL CH_AER_EMISSION(ZEMIS, PRHOA, CSV, NSV_CHSBEG, PFCO=ZFCO)\r
-  ELSE\r
-    CALL CH_AER_EMISSION(ZEMIS, PRHOA, CSV, NSV_CHSBEG)\r
-  ENDIF\r
-END IF\r
-!\r
-PSFSV(:,:) = PSFSV(:,:) + ZEMIS(:,:)\r
-!\r
-IF (LIOINIT) CALL END_IO_SURF_n(HPROGRAM)\r
-!\r
-IF (IVERB >= 6) WRITE(ILUOUT,*) '******** END CH_EMISSION_FLUX  ********'\r
-IF (LHOOK) CALL DR_HOOK('CH_EMISSION_FLUX_N',1,ZHOOK_HANDLE)\r
-!\r
-END SUBROUTINE CH_EMISSION_FLUX_n\r
+!     #########
+      SUBROUTINE CH_EMISSION_FLUX_n(HPROGRAM,PSIMTIME,PSFSV, PRHOA, PTSTEP, KNBTS_MAX)
+!     ######################################################################
+!!
+!!***  *CH_EMISSION_FLUX_n* - 
+!!
+!!    PURPOSE
+!!    -------
+!!      Return a time-dependent emission flux based on tabulated values
+!!
+!!**  METHOD
+!!    ------
+!!
+!!    AUTHOR
+!!    ------
+!!    D. Gazen
+!!
+!!    MODIFICATIONS
+!!    -------------
+!!    Original 08/02/00
+!!    C. Mari  30/10/00 call to MODD_TYPE_EFUTIL and MODD_CST
+!!    D.Gazen  01/12/03  change emissions handling for surf. externalization
+!!    P.Tulet  01/01/04  change emission conversion factor
+!!    P.Tulet  01/01/05  add dust, orilam
+!!    M.Leriche    2015  suppress ZDEPOT
+!!    M.Moge    01/2016  using READ_SURF_FIELD2D for 2D surfex fields reads
+!!
+!!    EXTERNAL
+!!    --------
+!!
+!!
+!!    IMPLICIT ARGUMENTS
+!!    ------------------
+USE MODD_SV_n,             ONLY: CSV,NSV_CHSBEG,NSV_CHSEND, NSV_AERBEG,  NSV_AEREND
+USE MODD_TYPE_EFUTIL,      ONLY: EMISSVAR_T, PRONOSVAR_T
+USE MODD_CSTS,             ONLY: NDAYSEC
+USE MODD_CH_EMIS_FIELD_n,  ONLY: TSEMISS, TSPRONOSLIST, XTIME_SIMUL
+USE MODD_CH_SURF_n,        ONLY: XCONVERSION
+!
+USE MODI_READ_SURF_FIELD2D
+USE MODI_INIT_IO_SURF_n
+USE MODI_END_IO_SURF_n
+USE MODI_GET_LUOUT
+!UPG*AERO1
+USE MODD_CHS_AEROSOL, ONLY: LCH_AERO_FLUX
+USE MODI_CH_AER_EMISSION
+!UPG*AERO1
+!!
+!------------------------------------------------------------------------------
+!
+!*       0.   DECLARATIONS
+!        -----------------
+!
+USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
+USE PARKIND1  ,ONLY : JPRB
+!
+USE MODI_ABOR1_SFX
+!
+IMPLICIT NONE
+!
+!*       0.1  declaration of arguments
+!
+CHARACTER(LEN=6),   INTENT(IN)  :: HPROGRAM    ! program calling surf. schemes
+REAL,               INTENT(IN)  :: PSIMTIME    ! time of simulation in sec UTC
+                                               ! (counting from midnight of
+                                               ! the current day)
+REAL,DIMENSION(:,:),  INTENT(INOUT) :: PSFSV   ! emission flux in ppp*m/s
+REAL, DIMENSION(:),   INTENT(IN)    :: PRHOA     ! air density (kg/m3)
+REAL,                 INTENT(IN)    :: PTSTEP    ! atmospheric time-step                 (s)
+INTEGER,              INTENT(IN)    :: KNBTS_MAX !max size of TEMISS%NETIMES
+
+!
+!*       0.2  declaration of local variables
+!
+INTEGER       :: IVERB   ! verbosity level
+INTEGER       :: KSIZE1D ! 1D size = X*Y physical domain 
+INTEGER       :: JI      ! loop control
+REAL          :: ZALPHA  ! interpolation weight
+!
+INTEGER :: INBTS       ! Number of emission times for a species
+INTEGER :: ITIM1,ITIM2 ! first/last time for interpolation
+INTEGER :: INDX1,INDX2 ! first/next index for data interpolation
+INTEGER :: ISIMTIME, ITPERIOD
+CHARACTER (LEN=16)  :: YRECFM          ! LFI article name
+TYPE(PRONOSVAR_T),POINTER :: CURPRONOS !Current pronostic variable
+!
+!*       0.3  declaration of saved local variables
+!
+CHARACTER(LEN=6), DIMENSION(:), POINTER :: CNAMES
+REAL,DIMENSION(SIZE(PSFSV,1),KNBTS_MAX)     :: ZWORK ! temporary array for reading data
+REAL,DIMENSION(SIZE(PSFSV,1),SIZE(PSFSV,2)) :: ZEMIS ! interpolated in time emission flux
+REAL,DIMENSION(SIZE(PSFSV,1))               :: ZFCO  ! CO flux
+INTEGER                          :: INEQ  ! number of chemical var
+                                          !(=NEQ (chimie gaz) + NSV_AER (chimie aerosol)
+INTEGER                          :: IWS   ! window size
+INTEGER                          :: IRESP ! return code for I/O
+INTEGER                          :: ILUOUT ! Outputlisting unit
+LOGICAL                          :: LIOINIT ! True if I/O init done
+INTEGER                          :: JW
+INTEGER                          :: ITIME
+LOGICAL                          :: GCO = .FALSE. ! switch if CO emission are available
+REAL(KIND=JPRB) :: ZHOOK_HANDLE
+!
+!------------------------------------------------------------------------------
+!
+!*    EXECUTABLE STATEMENTS
+!     ---------------------
+!
+IF (LHOOK) CALL DR_HOOK('CH_EMISSION_FLUX_N',0,ZHOOK_HANDLE)
+CALL GET_LUOUT(HPROGRAM,ILUOUT)
+LIOINIT = .FALSE.
+IVERB   = 5
+KSIZE1D = SIZE(PSFSV,1)
+INEQ    = SIZE(PSFSV,2)
+!
+!------------------------------------------------------------------------------
+!
+!*    3.  INTERPOLATE SURFACE FLUXES IN TIME IF NEEDED
+!     ------------------------------------------------
+!
+IF (XTIME_SIMUL == 0.) THEN
+   XTIME_SIMUL = PSIMTIME
+ELSE
+   XTIME_SIMUL = XTIME_SIMUL + PTSTEP
+END IF
+
+IF (IVERB >= 5) WRITE(ILUOUT,*) '******** CH_EMISSION_FLUX  ********'
+DO JI=1,SIZE(TSEMISS)
+! Simulation time (counting from midnight) is saved
+  ISIMTIME = XTIME_SIMUL
+!
+  INBTS = SIZE(TSEMISS(JI)%NETIMES) ! 
+  IWS   = TSEMISS(JI)%NWS           ! Window Size for I/O
+  INDX1 = TSEMISS(JI)%NDX           ! Current data index
+!
+  IF (INBTS == 1) THEN
+!   Time Constant Flux
+!   XFWORK already points on data (see build_emisstabn.F90)
+    IF (IVERB >= 6) THEN
+      WRITE(ILUOUT,*) 'NO interpolation for ',TRIM(TSEMISS(JI)%CNAME)
+      IF (IVERB >= 10 ) WRITE(ILUOUT,*) TSEMISS(JI)%XFWORK
+    END IF
+  ELSE
+    IF (IVERB >= 6) THEN
+      WRITE(ILUOUT,*) 'Interpolation (T =',ISIMTIME,') : ',TSEMISS(JI)%CNAME
+    END IF
+    IF (ISIMTIME < TSEMISS(JI)%NETIMES(1)) THEN
+!     Tsim < T(1)=Tmin should not happen but who knows ?
+      TSEMISS(JI)%NTX = 1
+    ELSE
+!     Check for periodicity when ISIMTIME is beyond last emission time
+!     and probably correct ISIMTIME
+      IF (ISIMTIME > TSEMISS(JI)%NETIMES(INBTS)) THEN 
+!       Tsim > T(INBTS)=Tmax
+        ITPERIOD = (1+(TSEMISS(JI)%NETIMES(INBTS)-&
+                TSEMISS(JI)%NETIMES(TSEMISS(JI)%NPX))/NDAYSEC)*NDAYSEC  
+        ISIMTIME = MODULO(ISIMTIME-TSEMISS(JI)%NETIMES(TSEMISS(JI)%NPX),ITPERIOD)+&
+                TSEMISS(JI)%NETIMES(TSEMISS(JI)%NPX)  
+        IF (IVERB >= 6) THEN
+          WRITE(ILUOUT,*) '  ITPERIOD = ', ITPERIOD
+          WRITE(ILUOUT,*) '  ISIMTIME modifie = ', ISIMTIME
+        END IF
+        IF (TSEMISS(JI)%NTX == INBTS .AND. ISIMTIME<TSEMISS(JI)%NETIMES(INBTS)) THEN
+!         Update time index NTX 
+          TSEMISS(JI)%NTX = TSEMISS(JI)%NPX
+!         Increment data index NDX : NDX correction will occur later
+!                                    to assure 1 <= NDX <= IWS
+          INDX1 = INDX1 + 1
+        END IF
+      END IF
+!
+!     search NTX such that : ETIMES(NTX) < ISIMTIME <= ETIMES(NTX+1)
+!     and make NDX follow NTX : NDX correction will occur later
+!                               to assure 1 <= NDX <= IWS
+      DO WHILE (TSEMISS(JI)%NTX < INBTS)
+        IF (ISIMTIME >= TSEMISS(JI)%NETIMES(TSEMISS(JI)%NTX+1)) THEN
+          TSEMISS(JI)%NTX = TSEMISS(JI)%NTX + 1
+          INDX1 = INDX1 + 1
+          INDX2 = INDX1 + 1
+        ELSE
+          EXIT
+        END IF
+      END DO
+    END IF
+!
+!   Check availability of data within memory Window (XEMISDATA(:,1:IWS))
+    IF (INDX1 >= IWS) THEN
+!
+!     Data index reached the memory window limits
+!
+      IF (TSEMISS(JI)%LREAD) THEN 
+!
+!       File must be read to update XEMISDATA array for this species 
+!
+        IF (.NOT. LIOINIT) THEN
+!         Must be done once before reading
+          CALL INIT_IO_SURF_n(HPROGRAM,'FULL  ','SURF  ','READ ')
+          IF (IVERB >= 6) WRITE(ILUOUT,*) 'INIT des I/O DONE.'
+          LIOINIT=.TRUE.
+        END IF
+        YRECFM='E_'//TRIM(TSEMISS(JI)%CNAME)
+        IF (IVERB >= 6)&
+               WRITE (ILUOUT,*) 'READ emission :',TRIM(YRECFM),&
+               ', SIZE(ZWORK)=',SIZE(ZWORK,1),INBTS 
+        CALL READ_SURF_FIELD2D(HPROGRAM,ZWORK(:,1:INBTS),YRECFM)
+!
+! Correction : Replace 999. with 0. value in the Emission FLUX
+        WHERE(ZWORK(:,1:INBTS) == 999.)
+          ZWORK(:,1:INBTS) = 0. 
+        END WHERE
+        WHERE(ZWORK(:,1:INBTS) == 1.E20)
+          ZWORK(:,1:INBTS) = 0. 
+        END WHERE
+        DO ITIME=1,INBTS
+        ZWORK(:,ITIME) = ZWORK(:,ITIME)*XCONVERSION(:)
+        END DO
+!
+!       
+        IF ((TSEMISS(JI)%NTX+IWS-1) > INBTS) THEN
+!
+!         ===== Periodic CASE =====
+!
+          IF (IVERB >= 6)&
+                 WRITE (ILUOUT,*) 'Periodic CASE : NPX =',TSEMISS(JI)%NPX  
+          IF (IWS <  (INBTS-TSEMISS(JI)%NPX+1)) THEN
+!           Window size is smaller then number of periodical times
+!
+!           example : IWS=5, NPX=2, INBTS=11, NTX=9
+!                               NTX       NPX
+!                                |         |
+!           time index :      ...9 10 11 # 2 3 4...11 #
+!       old data index :[1 2 3 4 5] 
+!       new data index :        [1  2  3   4 5]
+!                                |  
+!                               NDX    
+!
+            TSEMISS(JI)%XEMISDATA(:,1:INBTS-TSEMISS(JI)%NTX+1) = &
+                   ZWORK(:,TSEMISS(JI)%NTX:INBTS)  
+!
+            IF (IVERB >= 6) THEN
+              WRITE(ILUOUT,*) 'Window SIZE smaller than INBTS !'
+              WRITE(ILUOUT,*) 'Window index, Time index'
+              DO JW=1,INBTS-TSEMISS(JI)%NTX+1
+                WRITE(ILUOUT,*) JW,TSEMISS(JI)%NTX+JW-1
+              END DO
+            END IF
+!
+            TSEMISS(JI)%XEMISDATA(:,INBTS-TSEMISS(JI)%NTX+2:IWS) = &
+                   ZWORK(:,TSEMISS(JI)%NPX:TSEMISS(JI)%NPX+IWS-INBTS+TSEMISS(JI)%NTX-2)  
+!
+            IF (IVERB >= 6) THEN
+              DO JW=INBTS-TSEMISS(JI)%NTX+2,IWS
+                WRITE(ILUOUT,*) JW,TSEMISS(JI)%NPX+JW-(INBTS-TSEMISS(JI)%NTX+2)
+              END DO
+            END IF
+            INDX1 = 1
+            INDX2 = 2
+          ELSE
+!           Window size may get smaller AND it will be the last reading
+!
+!           example : IWS=6, NPX=7, INBTS=11, NTX=9
+!
+!                         NTX       NPX NTX
+!                          |         |   |
+!           time index: ...9 10 11 # 7 8 9 10 11 #
+!       old data index: ...6]
+!       new data index:             [1 2 3  4  5]
+!                                        |
+!                                       NDX=NTX-NPX+1
+!
+            IWS = INBTS-TSEMISS(JI)%NPX+1
+            TSEMISS(JI)%NWS = IWS
+            TSEMISS(JI)%XEMISDATA(:,1:IWS) = ZWORK(:,TSEMISS(JI)%NPX:INBTS)
+            IF (IVERB >= 6) THEN
+              WRITE(ILUOUT,*) 'Window SIZE equal or greater than INBTS !'
+              WRITE(ILUOUT,*) 'Window index, Time index'
+              DO JW=1,IWS
+                WRITE(ILUOUT,*) JW,TSEMISS(JI)%NPX+JW-1
+              END DO
+            END IF
+            INDX1 = TSEMISS(JI)%NTX-TSEMISS(JI)%NPX+1
+            INDX2 = MOD((INDX1+1),IWS)
+            TSEMISS(JI)%LREAD = .FALSE. ! no more reading
+          END IF
+        ELSE
+!
+!         ===== NON periodic (normal) CASE =====
+!
+! example : with IWS=5, the window moves forward
+!                             NTX
+!                              | 
+!         time index : 1 2 3 4 5 6 7 8 9 10 11 ... INBTS # 
+!     old data index :[1 2 3 4 5] 
+!     new data index :        [1 2 3 4 5] 
+!                              |
+!                             NDX
+!
+          TSEMISS(JI)%XEMISDATA(:,1:IWS) = ZWORK(:,TSEMISS(JI)%NTX:TSEMISS(JI)%NTX+IWS-1)
+          IF (IVERB >= 6) THEN
+            WRITE(ILUOUT,*) 'Window index, Time index'
+            DO JW=1,IWS
+              WRITE(ILUOUT,*) JW,TSEMISS(JI)%NTX+JW-1
+            END DO
+          END IF
+          INDX1 = 1
+          INDX2 = 2
+        END IF
+      ELSE
+!       Data is already in memory because window size is sufficient 
+!       to hold INBTS emission times => simply update NDX according to NTX
+!       
+        IF (IWS==INBTS) THEN 
+!
+!         'Window size' = 'Nb emis times' at INIT (ch_init_emission)
+!         so NDX must be set equal to NTX (the window does not move)
+! example :
+!                         NPX    NTX
+!                          |      | 
+!         time index :  1  2  3  ... INBTS
+!         data index : [1  2  3  ... INBTS]
+!                                 |
+!                                NDX
+
+          INDX1 = TSEMISS(JI)%NTX
+          INDX2 = INDX1+1
+          IF (INDX2 > IWS) INDX2=TSEMISS(JI)%NPX
+        ELSE
+!          
+!         Windows size changed during periodic case
+!         NDX must be equal to NTX - NPX + 1
+!         (the window does not move)
+! example :
+!                                NTX
+!                                 | 
+!         time index : NPX NPX+1 NPX+2 ... INBTS
+!         data index : [1    2    3    ...   IWS]
+!                                 |
+!                                NDX
+          INDX1 = TSEMISS(JI)%NTX-TSEMISS(JI)%NPX+1
+          INDX2 = MOD((INDX1+1),IWS)
+        END IF
+      END IF
+    ELSE ! (INDX1 < IWS)
+      INDX2 = INDX1+1
+    END IF
+!
+!   Don't forget to update NDX with new value INDX1
+    TSEMISS(JI)%NDX = INDX1
+!
+!   Compute both times for interpolation
+    IF (TSEMISS(JI)%NTX < INBTS) THEN 
+      ITIM1 = TSEMISS(JI)%NETIMES(TSEMISS(JI)%NTX)
+      ITIM2 = TSEMISS(JI)%NETIMES(TSEMISS(JI)%NTX+1)
+    ELSE
+      ITIM1 = TSEMISS(JI)%NETIMES(INBTS)
+      ITIM2 = TSEMISS(JI)%NETIMES(TSEMISS(JI)%NPX)+ITPERIOD
+    END IF
+!
+! Interpolate variables in time -> update XFWORK
+!
+!
+!  time       :  ITIM1...Tsim...ITIM2
+!                  |              |  
+!  data index :  INDX1          INDX2
+!
+!
+    ZALPHA = (REAL(ISIMTIME) - ITIM1) / (ITIM2-ITIM1)
+    TSEMISS(JI)%XFWORK(:) = ZALPHA*TSEMISS(JI)%XEMISDATA(:,INDX2) +&
+            (1.-ZALPHA)*TSEMISS(JI)%XEMISDATA(:,INDX1)  
+    IF (IVERB >= 6) THEN
+      WRITE(ILUOUT,*) '  Current time INDEX : ',TSEMISS(JI)%NTX
+      WRITE(ILUOUT,*) '  TIME : ',ISIMTIME, ' (',ITIM1,',',ITIM2,')'
+      WRITE(ILUOUT,*) '  Window size : ',TSEMISS(JI)%NWS
+      WRITE(ILUOUT,*) '  Current data INDEX : ',INDX1,INDX2
+      IF (IVERB >= 10) WRITE(ILUOUT,*) '  FLUX : ',TSEMISS(JI)%XFWORK
+    END IF
+  END IF
+END DO
+! 
+! Agregation : flux computation
+!
+ZEMIS(:,:) = 0.
+!
+! Point on head of Pronostic variable list
+! to cover the entire list.
+IF (NSV_AEREND > 0) THEN
+CNAMES=>CSV(NSV_CHSBEG:NSV_AEREND)
+ELSE
+CNAMES=>CSV(NSV_CHSBEG:NSV_CHSEND)
+END IF
+CURPRONOS=>TSPRONOSLIST
+DO WHILE(ASSOCIATED(CURPRONOS))
+  IF (CURPRONOS%NAMINDEX > INEQ) THEN
+    WRITE(ILUOUT,*) 'FATAL ERROR in CH_EMISSION_FLUXN : SIZE(ZEMIS,2) =',&
+           INEQ,', INDEX bugge =',CURPRONOS%NAMINDEX  
+    CALL ABOR1_SFX('CH_EMISSION_FLUXN: FATAL ERROR')
+  END IF
+  
+  ZEMIS(:,CURPRONOS%NAMINDEX) = 0.
+!
+! Loop on the number of agreg. coeff.
+  DO JI=1,CURPRONOS%NBCOEFF
+!   Compute agregated flux    
+    ZEMIS(:,CURPRONOS%NAMINDEX) = ZEMIS(:,CURPRONOS%NAMINDEX)+&
+            CURPRONOS%XCOEFF(JI)*TSEMISS(CURPRONOS%NEFINDEX(JI))%XFWORK(:)  
+  END DO
+
+  IF (IVERB >= 6) THEN
+    WRITE(ILUOUT,*) 'Agregation for ',CNAMES(CURPRONOS%NAMINDEX)
+    IF (IVERB >= 10) WRITE(ILUOUT,*) 'ZEMIS = ',ZEMIS(:,CURPRONOS%NAMINDEX)
+  END IF
+  IF ((CNAMES(CURPRONOS%NAMINDEX) == "CO") .AND. ANY(ZEMIS(:,CURPRONOS%NAMINDEX).GT.0.)) THEN
+  ZFCO(:) = ZEMIS(:,CURPRONOS%NAMINDEX)
+  GCO = .TRUE.
+  END IF
+
+  CURPRONOS=>CURPRONOS%NEXT
+!
+END DO
+!
+IF ((LCH_AERO_FLUX).AND.(NSV_AERBEG > 0)) THEN
+  IF (GCO) THEN
+    CALL CH_AER_EMISSION(ZEMIS, PRHOA, CSV, NSV_CHSBEG, PFCO=ZFCO)
+  ELSE
+    CALL CH_AER_EMISSION(ZEMIS, PRHOA, CSV, NSV_CHSBEG)
+  ENDIF
+END IF
+!
+PSFSV(:,:) = PSFSV(:,:) + ZEMIS(:,:)
+!
+IF (LIOINIT) CALL END_IO_SURF_n(HPROGRAM)
+!
+IF (IVERB >= 6) WRITE(ILUOUT,*) '******** END CH_EMISSION_FLUX  ********'
+IF (LHOOK) CALL DR_HOOK('CH_EMISSION_FLUX_N',1,ZHOOK_HANDLE)
+!
+END SUBROUTINE CH_EMISSION_FLUX_n
index fe4ecaa..7cd3b5e 100644 (file)
-!     #########\r
-      SUBROUTINE CH_INIT_SNAP_n(HPROGRAM,KLU,HINIT,KCH,PRHOA)\r
-!     #######################################\r
-!\r
-!!****  *CH_INIT_EMIISION_TEMP_n* - routine to initialize chemical emissions data structure\r
-!!\r
-!!    PURPOSE\r
-!!    -------\r
-!       Allocates and initialize emission surface fields\r
-!       by reading their value in initial file.\r
-!\r
-!!**  METHOD\r
-!!    ------\r
-!!    \r
-!!    \r
-!!    AUTHOR\r
-!!    ------\r
-!!     S.QUEGUINER \r
-!!\r
-!!    MODIFICATIONS\r
-!!    -------------\r
-!!      Original        11/2011\r
-!!        M.Moge    01/2016  using READ_SURF_FIELD2D for 2D surfex fields reads\r
-!!-----------------------------------------------------------------------------\r
-!\r
-!*       0.    DECLARATIONS\r
-!\r
-USE MODD_CSTS,       ONLY : XAVOGADRO, XMD\r
-USE MODD_CH_SNAP_n\r
-USE MODI_GET_LUOUT\r
-USE MODI_READ_SURF\r
-USE MODI_READ_SURF_FIELD2D\r
-USE MODI_ABOR1_SFX\r
-USE MODI_CH_CONVERSION_FACTOR\r
-USE MODI_BUILD_PRONOSLIST_n\r
-USE MODI_CH_OPEN_INPUTB\r
-!\r
-USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK\r
-USE PARKIND1  ,ONLY : JPRB\r
-!\r
-!\r
-IMPLICIT NONE\r
-!\r
-!*       0.1   declarations of arguments\r
-!\r
- CHARACTER(LEN=6),  INTENT(IN)  :: HPROGRAM ! Program name\r
-INTEGER,           INTENT(IN)  :: KLU      ! number of points\r
- CHARACTER(LEN=3),  INTENT(IN)  :: HINIT    ! Flag to know if one initializes:\r
-!                                          ! 'ALL' : all variables for a run\r
-!                                          ! 'PRE' : only variables to build \r
-!                                          !         an initial file\r
-INTEGER,           INTENT(IN)  :: KCH      ! logical unit of input chemistry file\r
-REAL, DIMENSION(:),INTENT(IN)  :: PRHOA    ! air density\r
-!\r
-!*       0.2   declarations of local variables\r
-!\r
-INTEGER             :: IRESP                 !   File \r
-INTEGER             :: ILUOUT                ! output listing logical unit\r
- CHARACTER (LEN=16)  :: YRECFM                ! management\r
- CHARACTER (LEN=100) :: YCOMMENT              ! variables\r
-INTEGER             :: JSPEC                 ! Loop index for chemical species\r
-INTEGER             :: JSNAP                 ! Loop index for SNAP categories\r
-!\r
- CHARACTER(LEN=40)   :: YSPEC_NAME            ! species name\r
-!\r
-INTEGER             :: IVERSION       ! version of surfex file being read\r
-INTEGER             :: IBUG           ! version of SURFEX bugfix\r
-REAL(KIND=JPRB) :: ZHOOK_HANDLE\r
-!-------------------------------------------------------------------------------\r
-IF (LHOOK) CALL DR_HOOK('CH_INIT_SNAP_N',0,ZHOOK_HANDLE)\r
- CALL GET_LUOUT(HPROGRAM,ILUOUT)\r
-!\r
-!* ascendant compatibility\r
-YRECFM='VERSION'\r
- CALL READ_SURF(HPROGRAM,YRECFM,IVERSION,IRESP)\r
-YRECFM='BUG'\r
- CALL READ_SURF(HPROGRAM,YRECFM,IBUG,IRESP)\r
-!\r
-!*      1.     Chemical Emission snap configuration\r
-!              ------------------------------------\r
-!\r
-! Read the number of emission species and snaps\r
-IF (IVERSION>7 .OR. (IVERSION==7 .AND. IBUG>=3) ) THEN\r
-  CALL READ_SURF(HPROGRAM,'EMISPEC_NBR',NEMIS_NBR,IRESP)\r
-  CALL READ_SURF(HPROGRAM,'SNAP_NBR',NEMIS_SNAP,IRESP)\r
-  CALL READ_SURF(HPROGRAM,'SNAP_TIME',CSNAP_TIME_REF,IRESP)\r
-ELSE\r
-  CALL ABOR1_SFX('CH_INIT_SNAPN: NO SNAP EMISSIONS IN SURFEX FILE: FILE TOO OLD')\r
-END IF\r
-!\r
-! Number of instants for each temporal profile.\r
-! For the time being, they are constant (even for the diurnal cycle)\r
-!\r
-NSNAP_M=12 ! 12 months\r
-NSNAP_D=7  !  7 day a week\r
-NSNAP_H=24 ! 24 hours a day (=> temporal resolution = 1 hour)\r
-!\r
-!\r
-!*      2.     Chemical Emission fields\r
-!              ------------------------\r
-!\r
-ALLOCATE(CEMIS_NAME       (               NEMIS_NBR))\r
-ALLOCATE(CEMIS_COMMENT    (               NEMIS_NBR))\r
-ALLOCATE(XEMIS_FIELDS_SNAP(KLU,NEMIS_SNAP,NEMIS_NBR))\r
-ALLOCATE(XEMIS_FIELDS     (KLU,           NEMIS_NBR))\r
-LEMIS_FIELDS = .FALSE.\r
-!\r
-ALLOCATE(XSNAP_MONTHLY(NSNAP_M,NEMIS_SNAP,NEMIS_NBR))\r
-ALLOCATE(XSNAP_DAILY  (NSNAP_D,NEMIS_SNAP,NEMIS_NBR))\r
-ALLOCATE(XSNAP_HOURLY (NSNAP_H,NEMIS_SNAP,NEMIS_NBR))\r
-!\r
-IF (CSNAP_TIME_REF=='LEGAL') THEN\r
-  ALLOCATE(XDELTA_LEGAL_TIME(KLU))\r
-  YRECFM='LEGALTIME'\r
-  CALL READ_SURF(HPROGRAM,YRECFM,XDELTA_LEGAL_TIME(:),IRESP,YCOMMENT)\r
-END IF\r
-!\r
-DO JSPEC = 1,NEMIS_NBR ! Loop on the number of species\r
-!\r
-! Read the species name\r
-  WRITE(YRECFM,'("EMISNAME",I3.3)') JSPEC\r
-  CALL READ_SURF(HPROGRAM,YRECFM,YSPEC_NAME,IRESP,YCOMMENT)\r
-  CEMIS_COMMENT(JSPEC)=YCOMMENT\r
-  IF (IRESP/=0) THEN\r
-    CALL ABOR1_SFX('CH_INIT_SNAPN: PROBLEM WHEN READING NAME OF EMITTED CHEMICAL SPECIES')\r
-  END IF\r
-  WRITE(ILUOUT,*) ' Emission ',JSPEC,' : ',TRIM(YSPEC_NAME)\r
-  CEMIS_NAME(JSPEC) = YSPEC_NAME(1:12)\r
-! \r
-! Read  the potential emission of species for each snap\r
-  DO JSNAP=1,NEMIS_SNAP\r
-    WRITE(YRECFM,'("SNAP",I2.2,"_",A3)') JSNAP,CEMIS_NAME(JSPEC)\r
-    CALL READ_SURF(HPROGRAM,YRECFM,XEMIS_FIELDS_SNAP(:,JSNAP,JSPEC),IRESP,YCOMMENT)\r
-  END DO\r
-!\r
-! Read the temporal profiles of all snaps\r
-  YRECFM = "E_"//TRIM(CEMIS_NAME(JSPEC))//"_M"\r
-  YRECFM = 'ICE_STO'\r
-  CALL READ_SURF_FIELD2D(HPROGRAM,XSNAP_MONTHLY(:,:,JSPEC),YRECFM,YCOMMENT,HDIR='-')\r
-  YRECFM = "E_"//TRIM(CEMIS_NAME(JSPEC))//"_D"\r
-  CALL READ_SURF_FIELD2D(HPROGRAM,XSNAP_DAILY(:,:,JSPEC),YRECFM,YCOMMENT,HDIR='-')\r
-  YRECFM = "E_"//TRIM(CEMIS_NAME(JSPEC))//"_H"\r
-  CALL READ_SURF_FIELD2D(HPROGRAM,XSNAP_HOURLY(:,:,JSPEC),YRECFM,YCOMMENT,HDIR='-')\r
-END DO\r
-!\r
-!*      3.     Conversion factor\r
-!              -----------------\r
-!\r
-IF (HINIT=='ALL') THEN\r
-  CALL CH_OPEN_INPUTB("EMISUNIT", KCH, ILUOUT)\r
-!\r
-! read unit identifier\r
-  READ(KCH,'(A3)') CCONVERSION\r
-!\r
-  ALLOCATE (XCONVERSION(KLU))\r
-! determine the conversion factor\r
-  CALL CH_CONVERSION_FACTOR(CCONVERSION,PRHOA)\r
-!\r
-!*      4.     List of emissions to be aggregated into atm. chemical species\r
-!              -------------------------------------------------------------\r
-!\r
-  CALL BUILD_PRONOSLIST_n(NEMIS_NBR,CEMIS_NAME,TSPRONOSLIST,KCH,ILUOUT,6)\r
-!\r
-!-------------------------------------------------------------------------------\r
-END IF\r
-!\r
-IF (LHOOK) CALL DR_HOOK('CH_INIT_SNAP_N',1,ZHOOK_HANDLE)\r
-!-------------------------------------------------------------------------------\r
-!\r
-END SUBROUTINE CH_INIT_SNAP_n\r
+!     #########
+      SUBROUTINE CH_INIT_SNAP_n(HPROGRAM,KLU,HINIT,KCH,PRHOA)
+!     #######################################
+!
+!!****  *CH_INIT_EMIISION_TEMP_n* - routine to initialize chemical emissions data structure
+!!
+!!    PURPOSE
+!!    -------
+!       Allocates and initialize emission surface fields
+!       by reading their value in initial file.
+!
+!!**  METHOD
+!!    ------
+!!    
+!!    
+!!    AUTHOR
+!!    ------
+!!     S.QUEGUINER 
+!!
+!!    MODIFICATIONS
+!!    -------------
+!!      Original        11/2011
+!!        M.Moge    01/2016  using READ_SURF_FIELD2D for 2D surfex fields reads
+!!-----------------------------------------------------------------------------
+!
+!*       0.    DECLARATIONS
+!
+USE MODD_CSTS,       ONLY : XAVOGADRO, XMD
+USE MODD_CH_SNAP_n
+USE MODI_GET_LUOUT
+USE MODI_READ_SURF
+USE MODI_READ_SURF_FIELD2D
+USE MODI_ABOR1_SFX
+USE MODI_CH_CONVERSION_FACTOR
+USE MODI_BUILD_PRONOSLIST_n
+USE MODI_CH_OPEN_INPUTB
+!
+USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
+USE PARKIND1  ,ONLY : JPRB
+!
+!
+IMPLICIT NONE
+!
+!*       0.1   declarations of arguments
+!
+ CHARACTER(LEN=6),  INTENT(IN)  :: HPROGRAM ! Program name
+INTEGER,           INTENT(IN)  :: KLU      ! number of points
+ CHARACTER(LEN=3),  INTENT(IN)  :: HINIT    ! Flag to know if one initializes:
+!                                          ! 'ALL' : all variables for a run
+!                                          ! 'PRE' : only variables to build 
+!                                          !         an initial file
+INTEGER,           INTENT(IN)  :: KCH      ! logical unit of input chemistry file
+REAL, DIMENSION(:),INTENT(IN)  :: PRHOA    ! air density
+!
+!*       0.2   declarations of local variables
+!
+INTEGER             :: IRESP                 !   File 
+INTEGER             :: ILUOUT                ! output listing logical unit
+ CHARACTER (LEN=16)  :: YRECFM                ! management
+ CHARACTER (LEN=100) :: YCOMMENT              ! variables
+INTEGER             :: JSPEC                 ! Loop index for chemical species
+INTEGER             :: JSNAP                 ! Loop index for SNAP categories
+!
+ CHARACTER(LEN=40)   :: YSPEC_NAME            ! species name
+!
+INTEGER             :: IVERSION       ! version of surfex file being read
+INTEGER             :: IBUG           ! version of SURFEX bugfix
+REAL(KIND=JPRB) :: ZHOOK_HANDLE
+!-------------------------------------------------------------------------------
+IF (LHOOK) CALL DR_HOOK('CH_INIT_SNAP_N',0,ZHOOK_HANDLE)
+ CALL GET_LUOUT(HPROGRAM,ILUOUT)
+!
+!* ascendant compatibility
+YRECFM='VERSION'
+ CALL READ_SURF(HPROGRAM,YRECFM,IVERSION,IRESP)
+YRECFM='BUG'
+ CALL READ_SURF(HPROGRAM,YRECFM,IBUG,IRESP)
+!
+!*      1.     Chemical Emission snap configuration
+!              ------------------------------------
+!
+! Read the number of emission species and snaps
+IF (IVERSION>7 .OR. (IVERSION==7 .AND. IBUG>=3) ) THEN
+  CALL READ_SURF(HPROGRAM,'EMISPEC_NBR',NEMIS_NBR,IRESP)
+  CALL READ_SURF(HPROGRAM,'SNAP_NBR',NEMIS_SNAP,IRESP)
+  CALL READ_SURF(HPROGRAM,'SNAP_TIME',CSNAP_TIME_REF,IRESP)
+ELSE
+  CALL ABOR1_SFX('CH_INIT_SNAPN: NO SNAP EMISSIONS IN SURFEX FILE: FILE TOO OLD')
+END IF
+!
+! Number of instants for each temporal profile.
+! For the time being, they are constant (even for the diurnal cycle)
+!
+NSNAP_M=12 ! 12 months
+NSNAP_D=7  !  7 day a week
+NSNAP_H=24 ! 24 hours a day (=> temporal resolution = 1 hour)
+!
+!
+!*      2.     Chemical Emission fields
+!              ------------------------
+!
+ALLOCATE(CEMIS_NAME       (               NEMIS_NBR))
+ALLOCATE(CEMIS_COMMENT    (               NEMIS_NBR))
+ALLOCATE(XEMIS_FIELDS_SNAP(KLU,NEMIS_SNAP,NEMIS_NBR))
+ALLOCATE(XEMIS_FIELDS     (KLU,           NEMIS_NBR))
+LEMIS_FIELDS = .FALSE.
+!
+ALLOCATE(XSNAP_MONTHLY(NSNAP_M,NEMIS_SNAP,NEMIS_NBR))
+ALLOCATE(XSNAP_DAILY  (NSNAP_D,NEMIS_SNAP,NEMIS_NBR))
+ALLOCATE(XSNAP_HOURLY (NSNAP_H,NEMIS_SNAP,NEMIS_NBR))
+!
+IF (CSNAP_TIME_REF=='LEGAL') THEN
+  ALLOCATE(XDELTA_LEGAL_TIME(KLU))
+  YRECFM='LEGALTIME'
+  CALL READ_SURF(HPROGRAM,YRECFM,XDELTA_LEGAL_TIME(:),IRESP,YCOMMENT)
+END IF
+!
+DO JSPEC = 1,NEMIS_NBR ! Loop on the number of species
+!
+! Read the species name
+  WRITE(YRECFM,'("EMISNAME",I3.3)') JSPEC
+  CALL READ_SURF(HPROGRAM,YRECFM,YSPEC_NAME,IRESP,YCOMMENT)
+  CEMIS_COMMENT(JSPEC)=YCOMMENT
+  IF (IRESP/=0) THEN
+    CALL ABOR1_SFX('CH_INIT_SNAPN: PROBLEM WHEN READING NAME OF EMITTED CHEMICAL SPECIES')
+  END IF
+  WRITE(ILUOUT,*) ' Emission ',JSPEC,' : ',TRIM(YSPEC_NAME)
+  CEMIS_NAME(JSPEC) = YSPEC_NAME(1:12)
+! 
+! Read  the potential emission of species for each snap
+  DO JSNAP=1,NEMIS_SNAP
+    WRITE(YRECFM,'("SNAP",I2.2,"_",A3)') JSNAP,CEMIS_NAME(JSPEC)
+    CALL READ_SURF(HPROGRAM,YRECFM,XEMIS_FIELDS_SNAP(:,JSNAP,JSPEC),IRESP,YCOMMENT)
+  END DO
+!
+! Read the temporal profiles of all snaps
+  YRECFM = "E_"//TRIM(CEMIS_NAME(JSPEC))//"_M"
+  YRECFM = 'ICE_STO'
+  CALL READ_SURF_FIELD2D(HPROGRAM,XSNAP_MONTHLY(:,:,JSPEC),YRECFM,YCOMMENT,HDIR='-')
+  YRECFM = "E_"//TRIM(CEMIS_NAME(JSPEC))//"_D"
+  CALL READ_SURF_FIELD2D(HPROGRAM,XSNAP_DAILY(:,:,JSPEC),YRECFM,YCOMMENT,HDIR='-')
+  YRECFM = "E_"//TRIM(CEMIS_NAME(JSPEC))//"_H"
+  CALL READ_SURF_FIELD2D(HPROGRAM,XSNAP_HOURLY(:,:,JSPEC),YRECFM,YCOMMENT,HDIR='-')
+END DO
+!
+!*      3.     Conversion factor
+!              -----------------
+!
+IF (HINIT=='ALL') THEN
+  CALL CH_OPEN_INPUTB("EMISUNIT", KCH, ILUOUT)
+!
+! read unit identifier
+  READ(KCH,'(A3)') CCONVERSION
+!
+  ALLOCATE (XCONVERSION(KLU))
+! determine the conversion factor
+  CALL CH_CONVERSION_FACTOR(CCONVERSION,PRHOA)
+!
+!*      4.     List of emissions to be aggregated into atm. chemical species
+!              -------------------------------------------------------------
+!
+  CALL BUILD_PRONOSLIST_n(NEMIS_NBR,CEMIS_NAME,TSPRONOSLIST,KCH,ILUOUT,6)
+!
+!-------------------------------------------------------------------------------
+END IF
+!
+IF (LHOOK) CALL DR_HOOK('CH_INIT_SNAP_N',1,ZHOOK_HANDLE)
+!-------------------------------------------------------------------------------
+!
+END SUBROUTINE CH_INIT_SNAP_n
index 2384cc4..b7bf36c 100644 (file)
-!SURFEX_LIC Copyright 1994-2014 Meteo-France \r
-!SURFEX_LIC This is part of the SURFEX software governed by the CeCILL-C  licence\r
-!SURFEX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt\r
-!SURFEX_LIC for details. version 1.\r
-! Modifications :\r
-! P.Marguinaud : 11-09-2012 : shorten field name\r
-! G.Delautier : 24-06-2015 : bug for arome compressed files\r
-! M.Moge    01/2016  using READ_SURF_FIELD2D/3D for 2D/3D surfex fields reads\r
-!     #####################\r
-MODULE MODE_READ_EXTERN\r
-!     #####################\r
-!-------------------------------------------------------------------\r
-!\r
-USE MODI_READ_LECOCLIMAP\r
-!\r
-USE MODI_PUT_ON_ALL_VEGTYPES\r
-USE MODI_OLD_NAME\r
-!\r
-USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK\r
-USE PARKIND1  ,ONLY : JPRB\r
-!\r
-CONTAINS\r
-!\r
-!---------------------------------------------------------------------------------------\r
-!\r
-!     #######################\r
-      SUBROUTINE READ_EXTERN_DEPTH(HPROGRAM,KLUOUT,HISBA,HNAT,HFIELD,KNI,KLAYER, &\r
-                                   KPATCH,PSOILGRID,PDEPTH,KVERSION  )\r
-!     #######################\r
-!\r
-USE MODD_SURF_PAR,       ONLY : NUNDEF, XUNDEF\r
-USE MODD_DATA_COVER_PAR, ONLY : JPCOVER, NVEGTYPE\r
-!\r
-USE MODI_READ_SURF_ISBA_PAR_n\r
-USE MODI_READ_SURF_FIELD3D\r
-USE MODI_READ_SURF_FIELD2D\r
-USE MODI_READ_SURF\r
-USE MODI_CONVERT_COVER_ISBA\r
-USE MODI_GARDEN_SOIL_DEPTH\r
-\r
-!\r
-IMPLICIT NONE\r
-!\r
-!* dummy arguments\r
-!  ---------------\r
-!\r
- CHARACTER(LEN=6),     INTENT(IN)    :: HPROGRAM  ! type of input file\r
-INTEGER,              INTENT(IN)    :: KLUOUT    ! logical unit of output listing\r
- CHARACTER(LEN=3),     INTENT(IN)    :: HISBA     ! type of ISBA soil scheme\r
- CHARACTER(LEN=3),     INTENT(IN)    :: HNAT      ! type of surface (nature, gardens)\r
- CHARACTER(LEN=7),     INTENT(IN)    :: HFIELD    ! field name\r
-INTEGER,              INTENT(IN)    :: KNI       ! number of points\r
-INTEGER,           INTENT(INOUT)    :: KLAYER    ! number of layers\r
-INTEGER,              INTENT(IN)    :: KPATCH    ! number of patch\r
-INTEGER,              INTENT(IN)    :: KVERSION  ! surface version\r
-REAL, DIMENSION(:),   INTENT(IN)    :: PSOILGRID\r
-REAL, DIMENSION(:,:,:), POINTER     :: PDEPTH    ! middle depth of each layer\r
-!\r
-!* local variables\r
-!  ---------------\r
-!\r
- CHARACTER(LEN=12) :: YRECFM         ! Name of the article to be read\r
- CHARACTER(LEN=16) :: YRECFM2\r
- CHARACTER(LEN=100):: YCOMMENT       ! Comment string\r
-INTEGER           :: IRESP          ! reading return code\r
-INTEGER           :: ILAYER         ! number of soil layers\r
-INTEGER           :: JLAYER         ! loop counter\r
-INTEGER           :: JPATCH         ! loop counter\r
-INTEGER           :: JJ\r
-INTEGER           :: IVERSION\r
-INTEGER           :: IBUGFIX\r
-!\r
-LOGICAL, DIMENSION(JPCOVER)          :: GCOVER ! flag to read the covers\r
-REAL,    DIMENSION(:,:), ALLOCATABLE :: ZCOVER ! cover fractions\r
-REAL,    DIMENSION(:,:), ALLOCATABLE :: ZGROUND_DEPTH ! cover fractions\r
-INTEGER, DIMENSION(:,:), ALLOCATABLE :: IWG_LAYER\r
-REAL,  DIMENSION(:,:,:), ALLOCATABLE :: ZD     ! depth of each inter-layer\r
-REAL,  DIMENSION(:,:,:), ALLOCATABLE :: ZDG    ! depth of each inter-layer\r
-REAL,  DIMENSION(:,:,:), ALLOCATABLE :: ZDEPTH ! middle of each layer for each patch\r
-REAL,  DIMENSION(:,:),   ALLOCATABLE :: ZWORK  ! work array\r
-REAL,  DIMENSION(KNI)                :: ZHVEG  ! high vegetation fraction\r
-REAL,  DIMENSION(KNI)                :: ZLVEG  ! low  vegetation fraction\r
-REAL,  DIMENSION(KNI)                :: ZNVEG  ! no   vegetation fraction\r
- CHARACTER(LEN=4)                     :: YHVEG  ! type of high vegetation\r
- CHARACTER(LEN=4)                     :: YLVEG  ! type of low  vegetation\r
- CHARACTER(LEN=4)                     :: YNVEG  ! type of no   vegetation\r
-LOGICAL                              :: GECOCLIMAP ! T if ecoclimap is used\r
-LOGICAL                              :: GPAR_GARDEN! T if garden data are used\r
-LOGICAL                              :: GDATA_DG\r
-LOGICAL                              :: GDATA_GROUND_DEPTH\r
-INTEGER                              :: IHYDRO_LAYER\r
-REAL(KIND=JPRB) :: ZHOOK_HANDLE\r
-!\r
-!\r
-!------------------------------------------------------------------------------\r
-!\r
-IF (LHOOK) CALL DR_HOOK('MODE_READ_EXTERN:READ_EXTERN_DEPTH',0,ZHOOK_HANDLE)\r
-!\r
-IF (HNAT=='NAT') THEN\r
-  CALL READ_LECOCLIMAP(HPROGRAM,GECOCLIMAP)\r
-ELSE\r
-  CALL READ_SURF(HPROGRAM,'PAR_GARDEN',GPAR_GARDEN,IRESP)\r
-  GECOCLIMAP = .NOT. GPAR_GARDEN\r
-END IF\r
-!\r
-!\r
-YRECFM='VERSION'\r
- CALL READ_SURF(HPROGRAM,YRECFM,IVERSION,IRESP)\r
-!\r
-YRECFM='BUG'\r
- CALL READ_SURF(HPROGRAM,YRECFM,IBUGFIX,IRESP)\r
-!\r
-!------------------------------------------------------------------------------\r
-!\r
-ALLOCATE(ZDG   (KNI,KLAYER,KPATCH))\r
-ALLOCATE(IWG_LAYER   (KNI,KPATCH))\r
-IWG_LAYER(:,:) = NUNDEF\r
-IHYDRO_LAYER = KLAYER\r
-!\r
-IF (GECOCLIMAP) THEN\r
-\r
- IF (IVERSION<7 .OR. IVERSION==7 .AND. IBUGFIX<=3) THEN\r
-  !\r
-  !* reading of the cover to obtain the depth of inter-layers\r
-  !\r
-  CALL OLD_NAME(HPROGRAM,'COVER_LIST      ',YRECFM)\r
-  CALL READ_SURF(HPROGRAM,YRECFM,GCOVER(:),IRESP,HDIR='-')\r
-  !\r
-  ALLOCATE(ZCOVER(KNI,JPCOVER))\r
-  YRECFM='COVER'\r
-  CALL READ_SURF(HPROGRAM,YRECFM,ZCOVER(:,:),GCOVER(:),IRESP,HDIR='A')  \r
-  !\r
-  !* computes soil layers\r
-  !  \r
-  CALL CONVERT_COVER_ISBA(HISBA,NUNDEF,ZCOVER,'   ',HNAT,PSOILGRID=PSOILGRID,PDG=ZDG,KWG_LAYER=IWG_LAYER)\r
-  !\r
-  DEALLOCATE(ZCOVER)\r
- ELSE\r
-print*, '-----------------------------------------------'\r
-print*, '-----------------------------------------------'\r
-print*, '-----------------------------------------------'\r
-print*, '-----------------------------------------------'\r
-print*, 'MODE_READ_EXTERN : ==> ON NE LIT PAS LES COVERS'\r
-print*, '-----------------------------------------------'\r
-print*, '-----------------------------------------------'\r
-print*, '-----------------------------------------------'\r
-print*, '-----------------------------------------------'\r
-  IF (HNAT=='NAT') THEN\r
-    YRECFM='ECO_DG'\r
-  ELSE\r
-    YRECFM='GD_ECO_DG'\r
-  END IF\r
-  CALL READ_SURF_FIELD3D(HPROGRAM,ZDG,1,SIZE(ZDG,2),YRECFM,HDIR='A')\r
-  !\r
-  IF (HISBA=='DIF') THEN\r
-    YRECFM='ECO_WG_L'\r
-    IF (HNAT=='GRD') YRECFM='GD_ECO_WG_L'\r
-    ALLOCATE(ZWORK(KNI,KPATCH)) \r
-    CALL READ_SURF_FIELD2D(HPROGRAM,ZWORK(:,:),YRECFM,HDIR='A')\r
-    WHERE (ZWORK==XUNDEF) ZWORK=NUNDEF\r
-    IWG_LAYER=NINT(ZWORK)\r
-    DEALLOCATE(ZWORK)\r
-  END IF\r
- END IF\r
-  !\r
-  IF (HISBA=='DIF') IHYDRO_LAYER = MAXVAL(IWG_LAYER(:,:),IWG_LAYER(:,:)/=NUNDEF)\r
-ENDIF\r
-\r
-!-------------------------------------------------------------------\r
-IF (HNAT=='NAT' .AND. (IVERSION>=7 .OR. .NOT.GECOCLIMAP)) THEN\r
-  !\r
-  !* directly read soil layers in the file for nature ISBA soil layers\r
-  !\r
-  GDATA_DG = .TRUE.\r
-  IF (IVERSION>=7) THEN\r
-    YRECFM='L_DG'\r
-    YCOMMENT=YRECFM\r
-    CALL READ_SURF(HPROGRAM,YRECFM,GDATA_DG,IRESP,HCOMMENT=YCOMMENT)\r
-  ENDIF\r
-  !\r
-  IF (GDATA_DG) THEN\r
-    !\r
-    ALLOCATE(ZWORK(KNI,KPATCH))\r
-    DO JLAYER=1,KLAYER\r
-      IF (JLAYER<10)  WRITE(YRECFM,FMT='(A4,I1.1)') 'D_DG',JLAYER\r
-      IF (JLAYER>=10) WRITE(YRECFM,FMT='(A4,I2.2)') 'D_DG',JLAYER\r
-      CALL READ_SURF_ISBA_PAR_n(HPROGRAM,YRECFM,KLUOUT,KNI,ZWORK,IRESP,IVERSION,HDIR='A')\r
-      DO JPATCH=1,KPATCH\r
-        ZDG(:,JLAYER,JPATCH) = ZWORK(:,JPATCH)\r
-      END DO\r
-    END DO\r
-    DEALLOCATE(ZWORK)\r
-    !\r
-  ENDIF\r
-  !\r
-    GDATA_GROUND_DEPTH=.FALSE.\r
-  IF (IVERSION>7 .OR. IVERSION==7 .AND. IBUGFIX>=2) THEN\r
-    !\r
-    YRECFM2='L_GROUND_DEPTH'\r
-    IF (IVERSION>7 .OR. IVERSION==7 .AND. IBUGFIX>=3) YRECFM2='L_GROUND_DPT'\r
-    YCOMMENT=YRECFM2\r
-    CALL READ_SURF(HPROGRAM,YRECFM2,GDATA_GROUND_DEPTH,IRESP,HCOMMENT=YCOMMENT)\r
-    !\r
-    IF (GDATA_GROUND_DEPTH) THEN\r
-      !\r
-      YRECFM2='D_GROUND_DETPH'\r
-      IF (IVERSION>7 .OR. IVERSION==7 .AND. IBUGFIX>=3) YRECFM2='D_GROUND_DPT'\r
-      ALLOCATE(ZGROUND_DEPTH(KNI,KPATCH))\r
-      CALL READ_SURF_ISBA_PAR_n(HPROGRAM,YRECFM2,KLUOUT,KNI,ZGROUND_DEPTH(:,:),IRESP,IVERSION,HDIR='A')\r
-      !\r
-      DO JPATCH=1,KPATCH\r
-        DO JJ=1,KNI\r
-          DO JLAYER=1,KLAYER\r
-            IF ( ZDG(JJ,JLAYER,JPATCH) <= ZGROUND_DEPTH(JJ,JPATCH) .AND. ZGROUND_DEPTH(JJ,JPATCH) < XUNDEF ) &\r
-                IWG_LAYER(JJ,JPATCH) = JLAYER\r
-          ENDDO\r
-        ENDDO\r
-      ENDDO\r
-      DEALLOCATE(ZGROUND_DEPTH)\r
-      !\r
-      IF (HISBA=='DIF') IHYDRO_LAYER = MAXVAL(IWG_LAYER(:,:),IWG_LAYER(:,:)/=NUNDEF)\r
-      !\r
-    ENDIF\r
-    !\r
-  ENDIF\r
-  !\r
-ELSE IF (HNAT=='GRD' .AND. .NOT.GECOCLIMAP) THEN\r
-  !\r
-  !* computes soil layers from vegetation fractions read in the file\r
-  !\r
-  CALL READ_SURF(HPROGRAM,'D_TYPE_HVEG',YHVEG,IRESP)\r
-  CALL READ_SURF(HPROGRAM,'D_TYPE_LVEG',YLVEG,IRESP)\r
-  CALL READ_SURF(HPROGRAM,'D_TYPE_NVEG',YNVEG,IRESP)\r
-  CALL READ_SURF(HPROGRAM,'D_FRAC_HVEG',ZHVEG,IRESP,HDIR='A')\r
-  CALL READ_SURF(HPROGRAM,'D_FRAC_LVEG',ZLVEG,IRESP,HDIR='A')\r
-  CALL READ_SURF(HPROGRAM,'D_FRAC_NVEG',ZNVEG,IRESP,HDIR='A')\r
-  ! Ground layers\r
-  CALL GARDEN_SOIL_DEPTH(YNVEG,YLVEG,YHVEG,ZNVEG,ZLVEG,ZHVEG,ZDG)\r
-  !\r
-END IF\r
-!\r
-DEALLOCATE(IWG_LAYER)\r
-!\r
-IF (HFIELD=='WG    ' .OR. HFIELD=='WGI   ' .OR. HFIELD=='TWN_WG  ' .OR. HFIELD=='TWN_WGI ' .OR. &\r
-      HFIELD=='GD_WG  ' .OR. HFIELD=='GD_WGI ') THEN\r
-  KLAYER = IHYDRO_LAYER\r
-ENDIF\r
-!\r
-!-------------------------------------------------------------------\r
-!\r
-!* In force-restore ISBA, adds a layer at bottom of surface layer and a layer\r
-!  between root and deep layers.\r
-!\r
-IF (HISBA=='2-L' .OR. HISBA=='3-L') THEN\r
-  ILAYER = KLAYER + 1\r
-  IF (HISBA=='3-L') ILAYER = ILAYER + 1\r
-  ALLOCATE(ZD    (KNI,ILAYER,KPATCH))\r
-  DO JPATCH=1,KPATCH\r
-    ! for interpolations, middle of surface layer must be at least at 1cm\r
-    ZD(:,1,JPATCH) = MIN(3.*ZDG(:,1,JPATCH),MAX(ZDG(:,1,JPATCH),0.02))\r
-    ! new layer below surface layer. This layer will be at root depth layer humidity\r
-    ZD(:,2,JPATCH) = MIN(4.*ZDG(:,1,JPATCH),0.5*(ZDG(:,1,JPATCH)+ZDG(:,2,JPATCH)))\r
-    ! root layer\r
-    ZD(:,3,JPATCH) = ZDG(:,2,JPATCH)\r
-    IF (HISBA=='3-L') THEN\r
-      ! between root and deep layers. This layer will have deep soil humidity.\r
-      WHERE (ZDG(:,2,JPATCH)<ZDG(:,3,JPATCH))\r
-        ZD(:,4,JPATCH) = 0.75 * ZDG(:,2,JPATCH) + 0.25 * ZDG(:,3,JPATCH)\r
-      ELSEWHERE\r
-        ZD(:,4,JPATCH) = ZDG(:,3,JPATCH)\r
-      END WHERE\r
-      ! deep layer\r
-      ZD(:,5,JPATCH) = ZDG(:,3,JPATCH)\r
-    END IF\r
-  END DO\r
-ELSE\r
-  ILAYER = KLAYER\r
-  ALLOCATE(ZD    (KNI,ILAYER,KPATCH))\r
-  ZD(:,:,:) = ZDG(:,1:KLAYER,:)\r
-END IF\r
-!\r
-DEALLOCATE(ZDG)\r
-!\r
-!-------------------------------------------------------------------\r
-!* recovers middle layer depth (from the surface)\r
-ALLOCATE(ZDEPTH    (KNI,ILAYER,KPATCH))\r
-ZDEPTH = XUNDEF\r
-DO JPATCH=1,KPATCH\r
-  WHERE(ZD(:,1,JPATCH)/=XUNDEF) &\r
-    ZDEPTH    (:,1,JPATCH)=ZD(:,1,JPATCH)/2.  \r
-  DO JLAYER=2,ILAYER\r
-    WHERE(ZD(:,1,JPATCH)/=XUNDEF) &\r
-      ZDEPTH    (:,JLAYER,JPATCH) = (ZD(:,JLAYER-1,JPATCH) + ZD(:,JLAYER,JPATCH))/2.  \r
-  END DO\r
-END DO\r
-DEALLOCATE(ZD)\r
-!-------------------------------------------------------------------\r
-!\r
-ALLOCATE(PDEPTH    (KNI,ILAYER,NVEGTYPE))\r
- CALL PUT_ON_ALL_VEGTYPES(KNI,ILAYER,KPATCH,NVEGTYPE,ZDEPTH,PDEPTH)\r
-DEALLOCATE(ZDEPTH)\r
-\r
-IF (LHOOK) CALL DR_HOOK('MODE_READ_EXTERN:READ_EXTERN_DEPTH',1,ZHOOK_HANDLE)\r
-!-------------------------------------------------------------------\r
-!\r
-END SUBROUTINE READ_EXTERN_DEPTH\r
-!\r
-!\r
-!-------------------------------------------------------------------\r
-!---------------------------------------------------------------------------------------\r
-!\r
-!     #######################\r
-      SUBROUTINE READ_EXTERN_ISBA(HFILE,HFILETYPE,HFILEPGD,HFILEPGDTYPE,&\r
-                                  KLUOUT,KNI,HFIELD,HNAME,PFIELD,PDEPTH)\r
-!     #######################\r
-!\r
-USE MODD_DATA_COVER_PAR, ONLY : NVEGTYPE\r
-USE MODD_SURF_PAR,       ONLY : XUNDEF\r
-USE MODD_ISBA_PAR,    ONLY : XOPTIMGRID\r
-!\r
-USE MODI_OPEN_AUX_IO_SURF\r
-USE MODI_CLOSE_AUX_IO_SURF\r
-USE MODI_READ_SURF\r
-USE MODI_READ_SURF_FIELD3D\r
-USE MODE_SOIL\r
-!\r
-IMPLICIT NONE\r
-!\r
-!* dummy arguments\r
-!  ---------------\r
-!\r
- CHARACTER(LEN=28),  INTENT(IN)  :: HFILE     ! name of file\r
- CHARACTER(LEN=6),   INTENT(IN)  :: HFILETYPE ! type of input file\r
- CHARACTER(LEN=28),  INTENT(IN)  :: HFILEPGD     ! name of file\r
- CHARACTER(LEN=6),   INTENT(IN)  :: HFILEPGDTYPE ! type of input file\r
-INTEGER,              INTENT(IN)    :: KLUOUT    ! logical unit of output listing\r
-INTEGER,              INTENT(IN)    :: KNI       ! number of points\r
- CHARACTER(LEN=7),     INTENT(IN)    :: HFIELD    ! field name\r
- CHARACTER(LEN=*),     INTENT(IN)    :: HNAME     ! field name in the file\r
-REAL, DIMENSION(:,:,:), POINTER       :: PFIELD    ! field to initialize\r
-REAL, DIMENSION(:,:,:), POINTER       :: PDEPTH    ! middle depth of each layer\r
-!\r
-!\r
-!* local variables\r
-!  ---------------\r
-!\r
- CHARACTER(LEN=12) :: YRECFM         ! Name of the article to be read\r
- CHARACTER(LEN=4)  :: YLVL\r
-#ifdef MNH_PARALLEL\r
- CHARACTER(LEN=8)  :: YPATCH\r
-#endif\r
- CHARACTER(LEN=3)  :: YISBA          ! type of ISBA soil scheme\r
- CHARACTER(LEN=3)  :: YNAT           ! type of surface (nature, garden)\r
- CHARACTER(LEN=4)  :: YPEDOTF        ! type of pedo-transfert function\r
-INTEGER           :: IRESP          ! reading return code\r
-INTEGER           :: ILAYER         ! number of layers\r
-INTEGER           :: JLAYER         ! loop counter\r
-INTEGER           :: IPATCH         ! number of patch\r
-INTEGER           :: JPATCH         ! loop counter\r
-INTEGER           :: JVEGTYPE       ! loop counter\r
-LOGICAL           :: GTEB           ! TEB field\r
-!\r
-REAL,  DIMENSION(:,:,:), ALLOCATABLE :: ZFIELD ! field read, one level, all patches\r
-REAL,  DIMENSION(:,:),   ALLOCATABLE :: ZWORK  ! field read, one level, all patches\r
-!\r
-REAL,  DIMENSION(:,:,:), ALLOCATABLE :: ZVAR      ! profile of physical variable\r
-REAL,  DIMENSION(:),   ALLOCATABLE   :: ZCLAY     ! clay fraction\r
-REAL,  DIMENSION(:),   ALLOCATABLE   :: ZSAND     ! sand fraction\r
-REAL,  DIMENSION(:),   ALLOCATABLE   :: ZWWILT    ! wilting point\r
-REAL,  DIMENSION(:),   ALLOCATABLE   :: ZWFC      ! field capacity\r
-REAL,  DIMENSION(:),   ALLOCATABLE   :: ZWSAT     ! saturation\r
-REAL,  DIMENSION(:),   ALLOCATABLE   :: ZSOILGRID\r
-REAL,  DIMENSION(:),   ALLOCATABLE   :: ZNAT      ! natural surface fraction \r
-!\r
-INTEGER :: IVERSION   ! surface version\r
-INTEGER :: IBUGFIX\r
-!\r
-REAL(KIND=JPRB) :: ZHOOK_HANDLE\r
-!-------------------------------------------------------------------------------\r
-IF (LHOOK) CALL DR_HOOK('MODE_READ_EXTERN:READ_EXTERN_ISBA',0,ZHOOK_HANDLE)\r
-WRITE  (KLUOUT,*) ' | Reading ',HFIELD,' in externalized file'\r
-!\r
-GTEB = (HNAME(1:3)=='TWN' .OR. HNAME(1:3)=='GD_' .OR. HNAME(1:3)=='GR_' &\r
-        .OR. HNAME(4:6)=='GD_' .OR. HNAME(4:6)=='GR_')\r
-!\r
-!------------------------------------------------------------------------------\r
-!\r
-IF (GTEB) THEN\r
-  CALL OPEN_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE,'TOWN  ')\r
-ELSE\r
-  CALL OPEN_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE,'NATURE')\r
-ENDIF\r
-!\r
-YRECFM='VERSION'\r
- CALL READ_SURF(HFILEPGDTYPE,YRECFM,IVERSION,IRESP)\r
-!\r
-YRECFM='BUG'\r
- CALL READ_SURF(HFILEPGDTYPE,YRECFM,IBUGFIX,IRESP)\r
-!\r
-!* Read number of soil layers\r
-!\r
-YRECFM='GROUND_LAYER'\r
-IF (GTEB) THEN \r
-  YRECFM='TWN_LAYER'\r
-  IF (IVERSION>7 .OR. IVERSION==7 .AND. IBUGFIX>=3) YRECFM='GD_LAYER'\r
-ENDIF\r
- CALL READ_SURF(HFILEPGDTYPE,YRECFM,ILAYER,IRESP)\r
-!\r
-!* number of tiles\r
-!\r
-IPATCH=1\r
-IF (.NOT. GTEB) THEN\r
-  YRECFM='PATCH_NUMBER'\r
-  CALL READ_SURF(HFILEPGDTYPE,YRECFM,IPATCH,IRESP)\r
-END IF\r
-!\r
-!* soil scheme\r
-!\r
-YRECFM='ISBA'\r
-IF (GTEB) THEN \r
-  YRECFM='TWN_ISBA'\r
-  IF (IVERSION>7 .OR. IVERSION==7 .AND. IBUGFIX>=3) YRECFM='GD_ISBA'\r
-ENDIF\r
- CALL READ_SURF(HFILEPGDTYPE,YRECFM,YISBA,IRESP)\r
-!\r
-IF (IVERSION>=7) THEN\r
-  !\r
-  !* Pedo-transfert function\r
-  !\r
-  YRECFM='PEDOTF'\r
-  IF (GTEB) THEN \r
-    YRECFM='TWN_PEDOTF'\r
-    IF (IVERSION>7 .OR. IVERSION==7 .AND. IBUGFIX>=3) YRECFM='GD_PEDOTF'\r
-  ENDIF\r
-  CALL READ_SURF(HFILEPGDTYPE,YRECFM,YPEDOTF,IRESP)\r
-  !\r
-ELSE\r
-  YPEDOTF = 'CH78'\r
-ENDIF\r
-!\r
-!Only Brook and Corey with Force-Restore scheme\r
-IF(YISBA/='DIF')THEN\r
-  YPEDOTF='CH78'\r
-ENDIF\r
-!\r
-!-------------------------------------------------------------------------------\r
-!\r
-! *.  Read clay fraction\r
-!     ------------------\r
-!\r
-ALLOCATE(ZCLAY(KNI))\r
-YRECFM='CLAY'\r
-IF (GTEB) THEN \r
-  YRECFM='TWN_CLAY'\r
-  IF (IVERSION>7 .OR. IVERSION==7 .AND. IBUGFIX>=3) YRECFM='GD_CLAY'\r
-ENDIF\r
- CALL READ_SURF(HFILEPGDTYPE,YRECFM,ZCLAY(:),IRESP,HDIR='A')\r
-!\r
-!-------------------------------------------------------------------------------\r
-!\r
-! *.  Read sand fraction\r
-!     ------------------\r
-!\r
-ALLOCATE(ZSAND(KNI))\r
-YRECFM='SAND'\r
-IF (GTEB) THEN \r
-  YRECFM='TWN_SAND'\r
-  IF (IVERSION>7 .OR. IVERSION==7 .AND. IBUGFIX>=3) YRECFM='GD_SAND'\r
-ENDIF\r
- CALL READ_SURF(HFILEPGDTYPE,YRECFM,ZSAND(:),IRESP,HDIR='A')\r
-!\r
-!-------------------------------------------------------------------------------\r
-!\r
-! *.  Read soil grid\r
-!     --------------\r
-!\r
-!* Reference grid for DIF\r
-!\r
-IF(YISBA=='DIF') THEN\r
-  ALLOCATE(ZSOILGRID(ILAYER))\r
-  ZSOILGRID=XUNDEF\r
-  IF (IVERSION>7 .OR. IVERSION==7 .AND. IBUGFIX>=2) THEN\r
-    YRECFM='SOILGRID'\r
-    IF (GTEB) THEN \r
-      YRECFM='TWN_SOILGRID'\r
-      IF (IVERSION>7 .OR. IVERSION==7 .AND. IBUGFIX>=3) YRECFM='GD_SOILGRID'\r
-    ENDIF\r
-    CALL READ_SURF(HFILEPGDTYPE,YRECFM,ZSOILGRID,IRESP,HDIR='-')\r
-  ELSE\r
-    ZSOILGRID(1:ILAYER) = XOPTIMGRID(1:ILAYER)\r
-  ENDIF\r
-ELSE\r
-  ALLOCATE(ZSOILGRID(0))\r
-ENDIF\r
-!\r
-IF ((HFIELD=='TG    ') .AND. (YISBA=='2-L' .OR. YISBA=='3-L')) THEN\r
-  ALLOCATE(PDEPTH    (KNI,ILAYER,NVEGTYPE))\r
-  DO JVEGTYPE=1,NVEGTYPE\r
-    PDEPTH(:,1,JVEGTYPE) = 0.\r
-    PDEPTH(:,2,JVEGTYPE) = 0.2\r
-    IF (ILAYER==3) PDEPTH(:,3,JVEGTYPE) = 3.\r
-  END DO\r
-ELSE\r
-  YNAT='NAT'\r
-  IF (GTEB) YNAT='GRD'\r
-  CALL READ_EXTERN_DEPTH(HFILEPGDTYPE,KLUOUT,YISBA,YNAT,HFIELD,KNI,ILAYER,IPATCH,&\r
-                         ZSOILGRID,PDEPTH,IVERSION)\r
-END IF\r
-!\r
-DEALLOCATE(ZSOILGRID)\r
-!\r
-! *.  Read fraction of nature\r
-!     --------------\r
-!\r
-ALLOCATE(ZNAT(KNI))\r
-IF (IVERSION>=7) THEN\r
-  CALL READ_SURF(HFILEPGDTYPE,'FRAC_NATURE',ZNAT,IRESP,HDIR='A')\r
-ELSE\r
-  ZNAT=1.0  \r
-ENDIF\r
-\r
-!\r
- CALL CLOSE_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE)\r
-!\r
-!* Allocate soil variable profile\r
-!  ------------------------------\r
-!\r
-!\r
-ALLOCATE(ZVAR(KNI,ILAYER,IPATCH))\r
-ALLOCATE(ZWORK(KNI,IPATCH))\r
-ZWORK(:,:) = XUNDEF\r
-!\r
-! *.  Read soil variable profile\r
-!     --------------------------\r
-!\r
-IF (GTEB) THEN\r
-  CALL OPEN_AUX_IO_SURF(HFILE,HFILETYPE,'TOWN  ')\r
-ELSE\r
-  CALL OPEN_AUX_IO_SURF(HFILE,HFILETYPE,'NATURE')\r
-ENDIF\r
-!\r
-  YRECFM=TRIM(HNAME)\r
-  CALL READ_SURF_FIELD3D(HFILETYPE,ZVAR,1,ILAYER,YRECFM,HDIR='A')\r
-!\r
- CALL CLOSE_AUX_IO_SURF(HFILE,HFILETYPE)\r
-!\r
-DEALLOCATE(ZWORK)\r
-!\r
-!\r
-! *.  Compute relative humidity from units kg/m^2 (SWI)\r
-!     ------------------------------------------------\r
-!\r
-!* In case of force-restore ISBA, adds one layer at bottom of surface layer\r
-IF ((HFIELD=='WG    ' .OR. HFIELD=='WGI   ') .AND. (YISBA=='2-L' .OR. YISBA=='3-L')) THEN\r
-  ALLOCATE(ZFIELD(KNI,ILAYER,IPATCH))\r
-  ZFIELD(:,:,:) = ZVAR(:,:,:)\r
-  DEALLOCATE(ZVAR)\r
-  !\r
-  ILAYER = ILAYER + 1\r
-  IF ( YISBA=='3-L' ) ILAYER = ILAYER + 1\r
-  ALLOCATE(ZVAR(KNI,ILAYER,IPATCH))\r
-  DO JPATCH=1,IPATCH\r
-    ZVAR(:,1,JPATCH)=ZFIELD(:,1,JPATCH)\r
-    ZVAR(:,2,JPATCH)=ZFIELD(:,2,JPATCH)  ! new layer at root layer humidity but below surface layer\r
-    ZVAR(:,3,JPATCH)=ZFIELD(:,2,JPATCH)\r
-    IF ( YISBA=='3-L' ) THEN\r
-      ZVAR(:,4,JPATCH)=ZFIELD(:,3,JPATCH)\r
-      ZVAR(:,5,JPATCH)=ZFIELD(:,3,JPATCH)\r
-    END IF\r
-  END DO\r
-  DEALLOCATE(ZFIELD)\r
-END IF\r
-!\r
-ALLOCATE(ZFIELD(KNI,ILAYER,IPATCH))\r
-ZFIELD = ZVAR\r
-!\r
-IF (HFIELD=='WG    ' .OR. HFIELD=='WGI   ') THEN\r
-  !\r
-  ! Compute ISBA model constants\r
-  !\r
-  ALLOCATE (ZWFC  (KNI))\r
-  ALLOCATE (ZWWILT(KNI))\r
-  ALLOCATE (ZWSAT (KNI))\r
-  !\r
-  ZWSAT (:) = WSAT_FUNC (ZCLAY(:),ZSAND(:),YPEDOTF)\r
-  ZWWILT(:) = WWILT_FUNC(ZCLAY(:),ZSAND(:),YPEDOTF)\r
-  ZWFC  (:) = WFC_FUNC  (ZCLAY(:),ZSAND(:),YPEDOTF)\r
-  !\r
-  DEALLOCATE (ZSAND)\r
-  DEALLOCATE (ZCLAY)\r
-\r
-  ZFIELD(:,:,:) = XUNDEF\r
-  !\r
-  IF (HFIELD=='WG    ') THEN\r
-    DO JPATCH=1,IPATCH\r
-      DO JLAYER=1,ILAYER\r
-        WHERE(ZNAT(:)>0.0 .AND. ZVAR(:,JLAYER,JPATCH)/=XUNDEF)\r
-          ZVAR(:,JLAYER,JPATCH) = MAX(MIN(ZVAR(:,JLAYER,JPATCH),ZWSAT(:)),0.)\r
-          !\r
-          ZFIELD(:,JLAYER,JPATCH) = (ZVAR(:,JLAYER,JPATCH) - ZWWILT(:)) / (ZWFC(:) - ZWWILT(:))\r
-        END WHERE\r
-      END DO\r
-    END DO\r
-  ELSE IF (HFIELD=='WGI   ') THEN\r
-    DO JPATCH=1,IPATCH\r
-      DO JLAYER=1,ILAYER\r
-        WHERE(ZNAT(:)>0.0 .AND. ZVAR(:,JLAYER,JPATCH)/=XUNDEF)\r
-          ZFIELD(:,JLAYER,JPATCH) = ZVAR(:,JLAYER,JPATCH) / ZWSAT(:)  \r
-        END WHERE \r
-      END DO\r
-    END DO\r
-  END IF\r
-!\r
-  DEALLOCATE (ZNAT)\r
-  DEALLOCATE (ZWSAT)\r
-  DEALLOCATE (ZWWILT)\r
-  DEALLOCATE (ZWFC)\r
-!\r
-!\r
-END IF\r
-!\r
-DEALLOCATE(ZVAR)\r
-!-------------------------------------------------------------------------------\r
-!\r
-! *.  Set the field on all vegtypes\r
-!     -----------------------------\r
-!\r
-ALLOCATE(PFIELD(KNI,ILAYER,NVEGTYPE))\r
- CALL PUT_ON_ALL_VEGTYPES(KNI,ILAYER,IPATCH,NVEGTYPE,ZFIELD,PFIELD)\r
-DEALLOCATE(ZFIELD)\r
-IF (LHOOK) CALL DR_HOOK('MODE_READ_EXTERN:READ_EXTERN_ISBA',1,ZHOOK_HANDLE)\r
-!\r
-!------------------------------------------------------------------------------\r
-!\r
-END SUBROUTINE READ_EXTERN_ISBA\r
-!\r
-!------------------------------------------------------------------------------\r
-!\r
-END MODULE MODE_READ_EXTERN                       \r
+!SURFEX_LIC Copyright 1994-2014 Meteo-France 
+!SURFEX_LIC This is part of the SURFEX software governed by the CeCILL-C  licence
+!SURFEX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
+!SURFEX_LIC for details. version 1.
+! Modifications :
+! P.Marguinaud : 11-09-2012 : shorten field name
+! G.Delautier : 24-06-2015 : bug for arome compressed files
+! M.Moge    01/2016  using READ_SURF_FIELD2D/3D for 2D/3D surfex fields reads
+!     #####################
+MODULE MODE_READ_EXTERN
+!     #####################
+!-------------------------------------------------------------------
+!
+USE MODI_READ_LECOCLIMAP
+!
+USE MODI_PUT_ON_ALL_VEGTYPES
+USE MODI_OLD_NAME
+!
+USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
+USE PARKIND1  ,ONLY : JPRB
+!
+CONTAINS
+!
+!---------------------------------------------------------------------------------------
+!
+!     #######################
+      SUBROUTINE READ_EXTERN_DEPTH(HPROGRAM,KLUOUT,HISBA,HNAT,HFIELD,KNI,KLAYER, &
+                                   KPATCH,PSOILGRID,PDEPTH,KVERSION  )
+!     #######################
+!
+USE MODD_SURF_PAR,       ONLY : NUNDEF, XUNDEF
+USE MODD_DATA_COVER_PAR, ONLY : JPCOVER, NVEGTYPE
+!
+USE MODI_READ_SURF_ISBA_PAR_n
+USE MODI_READ_SURF_FIELD3D
+USE MODI_READ_SURF_FIELD2D
+USE MODI_READ_SURF
+USE MODI_CONVERT_COVER_ISBA
+USE MODI_GARDEN_SOIL_DEPTH
+
+!
+IMPLICIT NONE
+!
+!* dummy arguments
+!  ---------------
+!
+ CHARACTER(LEN=6),     INTENT(IN)    :: HPROGRAM  ! type of input file
+INTEGER,              INTENT(IN)    :: KLUOUT    ! logical unit of output listing
+ CHARACTER(LEN=3),     INTENT(IN)    :: HISBA     ! type of ISBA soil scheme
+ CHARACTER(LEN=3),     INTENT(IN)    :: HNAT      ! type of surface (nature, gardens)
+ CHARACTER(LEN=7),     INTENT(IN)    :: HFIELD    ! field name
+INTEGER,              INTENT(IN)    :: KNI       ! number of points
+INTEGER,           INTENT(INOUT)    :: KLAYER    ! number of layers
+INTEGER,              INTENT(IN)    :: KPATCH    ! number of patch
+INTEGER,              INTENT(IN)    :: KVERSION  ! surface version
+REAL, DIMENSION(:),   INTENT(IN)    :: PSOILGRID
+REAL, DIMENSION(:,:,:), POINTER     :: PDEPTH    ! middle depth of each layer
+!
+!* local variables
+!  ---------------
+!
+ CHARACTER(LEN=12) :: YRECFM         ! Name of the article to be read
+ CHARACTER(LEN=16) :: YRECFM2
+ CHARACTER(LEN=100):: YCOMMENT       ! Comment string
+INTEGER           :: IRESP          ! reading return code
+INTEGER           :: ILAYER         ! number of soil layers
+INTEGER           :: JLAYER         ! loop counter
+INTEGER           :: JPATCH         ! loop counter
+INTEGER           :: JJ
+INTEGER           :: IVERSION
+INTEGER           :: IBUGFIX
+!
+LOGICAL, DIMENSION(JPCOVER)          :: GCOVER ! flag to read the covers
+REAL,    DIMENSION(:,:), ALLOCATABLE :: ZCOVER ! cover fractions
+REAL,    DIMENSION(:,:), ALLOCATABLE :: ZGROUND_DEPTH ! cover fractions
+INTEGER, DIMENSION(:,:), ALLOCATABLE :: IWG_LAYER
+REAL,  DIMENSION(:,:,:), ALLOCATABLE :: ZD     ! depth of each inter-layer
+REAL,  DIMENSION(:,:,:), ALLOCATABLE :: ZDG    ! depth of each inter-layer
+REAL,  DIMENSION(:,:,:), ALLOCATABLE :: ZDEPTH ! middle of each layer for each patch
+REAL,  DIMENSION(:,:),   ALLOCATABLE :: ZWORK  ! work array
+REAL,  DIMENSION(KNI)                :: ZHVEG  ! high vegetation fraction
+REAL,  DIMENSION(KNI)                :: ZLVEG  ! low  vegetation fraction
+REAL,  DIMENSION(KNI)                :: ZNVEG  ! no   vegetation fraction
+ CHARACTER(LEN=4)                     :: YHVEG  ! type of high vegetation
+ CHARACTER(LEN=4)                     :: YLVEG  ! type of low  vegetation
+ CHARACTER(LEN=4)                     :: YNVEG  ! type of no   vegetation
+LOGICAL                              :: GECOCLIMAP ! T if ecoclimap is used
+LOGICAL                              :: GPAR_GARDEN! T if garden data are used
+LOGICAL                              :: GDATA_DG
+LOGICAL                              :: GDATA_GROUND_DEPTH
+INTEGER                              :: IHYDRO_LAYER
+REAL(KIND=JPRB) :: ZHOOK_HANDLE
+!
+!
+!------------------------------------------------------------------------------
+!
+IF (LHOOK) CALL DR_HOOK('MODE_READ_EXTERN:READ_EXTERN_DEPTH',0,ZHOOK_HANDLE)
+!
+IF (HNAT=='NAT') THEN
+  CALL READ_LECOCLIMAP(HPROGRAM,GECOCLIMAP)
+ELSE
+  CALL READ_SURF(HPROGRAM,'PAR_GARDEN',GPAR_GARDEN,IRESP)
+  GECOCLIMAP = .NOT. GPAR_GARDEN
+END IF
+!
+!
+YRECFM='VERSION'
+ CALL READ_SURF(HPROGRAM,YRECFM,IVERSION,IRESP)
+!
+YRECFM='BUG'
+ CALL READ_SURF(HPROGRAM,YRECFM,IBUGFIX,IRESP)
+!
+!------------------------------------------------------------------------------
+!
+ALLOCATE(ZDG   (KNI,KLAYER,KPATCH))
+ALLOCATE(IWG_LAYER   (KNI,KPATCH))
+IWG_LAYER(:,:) = NUNDEF
+IHYDRO_LAYER = KLAYER
+!
+IF (GECOCLIMAP) THEN
+
+ IF (IVERSION<7 .OR. IVERSION==7 .AND. IBUGFIX<=3) THEN
+  !
+  !* reading of the cover to obtain the depth of inter-layers
+  !
+  CALL OLD_NAME(HPROGRAM,'COVER_LIST      ',YRECFM)
+  CALL READ_SURF(HPROGRAM,YRECFM,GCOVER(:),IRESP,HDIR='-')
+  !
+  ALLOCATE(ZCOVER(KNI,JPCOVER))
+  YRECFM='COVER'
+  CALL READ_SURF(HPROGRAM,YRECFM,ZCOVER(:,:),GCOVER(:),IRESP,HDIR='A')  
+  !
+  !* computes soil layers
+  !  
+  CALL CONVERT_COVER_ISBA(HISBA,NUNDEF,ZCOVER,'   ',HNAT,PSOILGRID=PSOILGRID,PDG=ZDG,KWG_LAYER=IWG_LAYER)
+  !
+  DEALLOCATE(ZCOVER)
+ ELSE
+print*, '-----------------------------------------------'
+print*, '-----------------------------------------------'
+print*, '-----------------------------------------------'
+print*, '-----------------------------------------------'
+print*, 'MODE_READ_EXTERN : ==> ON NE LIT PAS LES COVERS'
+print*, '-----------------------------------------------'
+print*, '-----------------------------------------------'
+print*, '-----------------------------------------------'
+print*, '-----------------------------------------------'
+  IF (HNAT=='NAT') THEN
+    YRECFM='ECO_DG'
+  ELSE
+    YRECFM='GD_ECO_DG'
+  END IF
+  CALL READ_SURF_FIELD3D(HPROGRAM,ZDG,1,SIZE(ZDG,2),YRECFM,HDIR='A')
+  !
+  IF (HISBA=='DIF') THEN
+    YRECFM='ECO_WG_L'
+    IF (HNAT=='GRD') YRECFM='GD_ECO_WG_L'
+    ALLOCATE(ZWORK(KNI,KPATCH)) 
+    CALL READ_SURF_FIELD2D(HPROGRAM,ZWORK(:,:),YRECFM,HDIR='A')
+    WHERE (ZWORK==XUNDEF) ZWORK=NUNDEF
+    IWG_LAYER=NINT(ZWORK)
+    DEALLOCATE(ZWORK)
+  END IF
+ END IF
+  !
+  IF (HISBA=='DIF') IHYDRO_LAYER = MAXVAL(IWG_LAYER(:,:),IWG_LAYER(:,:)/=NUNDEF)
+ENDIF
+
+!-------------------------------------------------------------------
+IF (HNAT=='NAT' .AND. (IVERSION>=7 .OR. .NOT.GECOCLIMAP)) THEN
+  !
+  !* directly read soil layers in the file for nature ISBA soil layers
+  !
+  GDATA_DG = .TRUE.
+  IF (IVERSION>=7) THEN
+    YRECFM='L_DG'
+    YCOMMENT=YRECFM
+    CALL READ_SURF(HPROGRAM,YRECFM,GDATA_DG,IRESP,HCOMMENT=YCOMMENT)
+  ENDIF
+  !
+  IF (GDATA_DG) THEN
+    !
+    ALLOCATE(ZWORK(KNI,KPATCH))
+    DO JLAYER=1,KLAYER
+      IF (JLAYER<10)  WRITE(YRECFM,FMT='(A4,I1.1)') 'D_DG',JLAYER
+      IF (JLAYER>=10) WRITE(YRECFM,FMT='(A4,I2.2)') 'D_DG',JLAYER
+      CALL READ_SURF_ISBA_PAR_n(HPROGRAM,YRECFM,KLUOUT,KNI,ZWORK,IRESP,IVERSION,HDIR='A')
+      DO JPATCH=1,KPATCH
+        ZDG(:,JLAYER,JPATCH) = ZWORK(:,JPATCH)
+      END DO
+    END DO
+    DEALLOCATE(ZWORK)
+    !
+  ENDIF
+  !
+    GDATA_GROUND_DEPTH=.FALSE.
+  IF (IVERSION>7 .OR. IVERSION==7 .AND. IBUGFIX>=2) THEN
+    !
+    YRECFM2='L_GROUND_DEPTH'
+    IF (IVERSION>7 .OR. IVERSION==7 .AND. IBUGFIX>=3) YRECFM2='L_GROUND_DPT'
+    YCOMMENT=YRECFM2
+    CALL READ_SURF(HPROGRAM,YRECFM2,GDATA_GROUND_DEPTH,IRESP,HCOMMENT=YCOMMENT)
+    !
+    IF (GDATA_GROUND_DEPTH) THEN
+      !
+      YRECFM2='D_GROUND_DETPH'
+      IF (IVERSION>7 .OR. IVERSION==7 .AND. IBUGFIX>=3) YRECFM2='D_GROUND_DPT'
+      ALLOCATE(ZGROUND_DEPTH(KNI,KPATCH))
+      CALL READ_SURF_ISBA_PAR_n(HPROGRAM,YRECFM2,KLUOUT,KNI,ZGROUND_DEPTH(:,:),IRESP,IVERSION,HDIR='A')
+      !
+      DO JPATCH=1,KPATCH
+        DO JJ=1,KNI
+          DO JLAYER=1,KLAYER
+            IF ( ZDG(JJ,JLAYER,JPATCH) <= ZGROUND_DEPTH(JJ,JPATCH) .AND. ZGROUND_DEPTH(JJ,JPATCH) < XUNDEF ) &
+                IWG_LAYER(JJ,JPATCH) = JLAYER
+          ENDDO
+        ENDDO
+      ENDDO
+      DEALLOCATE(ZGROUND_DEPTH)
+      !
+      IF (HISBA=='DIF') IHYDRO_LAYER = MAXVAL(IWG_LAYER(:,:),IWG_LAYER(:,:)/=NUNDEF)
+      !
+    ENDIF
+    !
+  ENDIF
+  !
+ELSE IF (HNAT=='GRD' .AND. .NOT.GECOCLIMAP) THEN
+  !
+  !* computes soil layers from vegetation fractions read in the file
+  !
+  CALL READ_SURF(HPROGRAM,'D_TYPE_HVEG',YHVEG,IRESP)
+  CALL READ_SURF(HPROGRAM,'D_TYPE_LVEG',YLVEG,IRESP)
+  CALL READ_SURF(HPROGRAM,'D_TYPE_NVEG',YNVEG,IRESP)
+  CALL READ_SURF(HPROGRAM,'D_FRAC_HVEG',ZHVEG,IRESP,HDIR='A')
+  CALL READ_SURF(HPROGRAM,'D_FRAC_LVEG',ZLVEG,IRESP,HDIR='A')
+  CALL READ_SURF(HPROGRAM,'D_FRAC_NVEG',ZNVEG,IRESP,HDIR='A')
+  ! Ground layers
+  CALL GARDEN_SOIL_DEPTH(YNVEG,YLVEG,YHVEG,ZNVEG,ZLVEG,ZHVEG,ZDG)
+  !
+END IF
+!
+DEALLOCATE(IWG_LAYER)
+!
+IF (HFIELD=='WG    ' .OR. HFIELD=='WGI   ' .OR. HFIELD=='TWN_WG  ' .OR. HFIELD=='TWN_WGI ' .OR. &
+      HFIELD=='GD_WG  ' .OR. HFIELD=='GD_WGI ') THEN
+  KLAYER = IHYDRO_LAYER
+ENDIF
+!
+!-------------------------------------------------------------------
+!
+!* In force-restore ISBA, adds a layer at bottom of surface layer and a layer
+!  between root and deep layers.
+!
+IF (HISBA=='2-L' .OR. HISBA=='3-L') THEN
+  ILAYER = KLAYER + 1
+  IF (HISBA=='3-L') ILAYER = ILAYER + 1
+  ALLOCATE(ZD    (KNI,ILAYER,KPATCH))
+  DO JPATCH=1,KPATCH
+    ! for interpolations, middle of surface layer must be at least at 1cm
+    ZD(:,1,JPATCH) = MIN(3.*ZDG(:,1,JPATCH),MAX(ZDG(:,1,JPATCH),0.02))
+    ! new layer below surface layer. This layer will be at root depth layer humidity
+    ZD(:,2,JPATCH) = MIN(4.*ZDG(:,1,JPATCH),0.5*(ZDG(:,1,JPATCH)+ZDG(:,2,JPATCH)))
+    ! root layer
+    ZD(:,3,JPATCH) = ZDG(:,2,JPATCH)
+    IF (HISBA=='3-L') THEN
+      ! between root and deep layers. This layer will have deep soil humidity.
+      WHERE (ZDG(:,2,JPATCH)<ZDG(:,3,JPATCH))
+        ZD(:,4,JPATCH) = 0.75 * ZDG(:,2,JPATCH) + 0.25 * ZDG(:,3,JPATCH)
+      ELSEWHERE
+        ZD(:,4,JPATCH) = ZDG(:,3,JPATCH)
+      END WHERE
+      ! deep layer
+      ZD(:,5,JPATCH) = ZDG(:,3,JPATCH)
+    END IF
+  END DO
+ELSE
+  ILAYER = KLAYER
+  ALLOCATE(ZD    (KNI,ILAYER,KPATCH))
+  ZD(:,:,:) = ZDG(:,1:KLAYER,:)
+END IF
+!
+DEALLOCATE(ZDG)
+!
+!-------------------------------------------------------------------
+!* recovers middle layer depth (from the surface)
+ALLOCATE(ZDEPTH    (KNI,ILAYER,KPATCH))
+ZDEPTH = XUNDEF
+DO JPATCH=1,KPATCH
+  WHERE(ZD(:,1,JPATCH)/=XUNDEF) &
+    ZDEPTH    (:,1,JPATCH)=ZD(:,1,JPATCH)/2.  
+  DO JLAYER=2,ILAYER
+    WHERE(ZD(:,1,JPATCH)/=XUNDEF) &
+      ZDEPTH    (:,JLAYER,JPATCH) = (ZD(:,JLAYER-1,JPATCH) + ZD(:,JLAYER,JPATCH))/2.  
+  END DO
+END DO
+DEALLOCATE(ZD)
+!-------------------------------------------------------------------
+!
+ALLOCATE(PDEPTH    (KNI,ILAYER,NVEGTYPE))
+ CALL PUT_ON_ALL_VEGTYPES(KNI,ILAYER,KPATCH,NVEGTYPE,ZDEPTH,PDEPTH)
+DEALLOCATE(ZDEPTH)
+
+IF (LHOOK) CALL DR_HOOK('MODE_READ_EXTERN:READ_EXTERN_DEPTH',1,ZHOOK_HANDLE)
+!-------------------------------------------------------------------
+!
+END SUBROUTINE READ_EXTERN_DEPTH
+!
+!
+!-------------------------------------------------------------------
+!---------------------------------------------------------------------------------------
+!
+!     #######################
+      SUBROUTINE READ_EXTERN_ISBA(HFILE,HFILETYPE,HFILEPGD,HFILEPGDTYPE,&
+                                  KLUOUT,KNI,HFIELD,HNAME,PFIELD,PDEPTH)
+!     #######################
+!
+USE MODD_DATA_COVER_PAR, ONLY : NVEGTYPE
+USE MODD_SURF_PAR,       ONLY : XUNDEF
+USE MODD_ISBA_PAR,    ONLY : XOPTIMGRID
+!
+USE MODI_OPEN_AUX_IO_SURF
+USE MODI_CLOSE_AUX_IO_SURF
+USE MODI_READ_SURF
+USE MODI_READ_SURF_FIELD3D
+USE MODE_SOIL
+!
+IMPLICIT NONE
+!
+!* dummy arguments
+!  ---------------
+!
+ CHARACTER(LEN=28),  INTENT(IN)  :: HFILE     ! name of file
+ CHARACTER(LEN=6),   INTENT(IN)  :: HFILETYPE ! type of input file
+ CHARACTER(LEN=28),  INTENT(IN)  :: HFILEPGD     ! name of file
+ CHARACTER(LEN=6),   INTENT(IN)  :: HFILEPGDTYPE ! type of input file
+INTEGER,              INTENT(IN)    :: KLUOUT    ! logical unit of output listing
+INTEGER,              INTENT(IN)    :: KNI       ! number of points
+ CHARACTER(LEN=7),     INTENT(IN)    :: HFIELD    ! field name
+ CHARACTER(LEN=*),     INTENT(IN)    :: HNAME     ! field name in the file
+REAL, DIMENSION(:,:,:), POINTER       :: PFIELD    ! field to initialize
+REAL, DIMENSION(:,:,:), POINTER       :: PDEPTH    ! middle depth of each layer
+!
+!
+!* local variables
+!  ---------------
+!
+ CHARACTER(LEN=12) :: YRECFM         ! Name of the article to be read
+ CHARACTER(LEN=4)  :: YLVL
+#ifdef MNH_PARALLEL
+ CHARACTER(LEN=8)  :: YPATCH
+#endif
+ CHARACTER(LEN=3)  :: YISBA          ! type of ISBA soil scheme
+ CHARACTER(LEN=3)  :: YNAT           ! type of surface (nature, garden)
+ CHARACTER(LEN=4)  :: YPEDOTF        ! type of pedo-transfert function
+INTEGER           :: IRESP          ! reading return code
+INTEGER           :: ILAYER         ! number of layers
+INTEGER           :: JLAYER         ! loop counter
+INTEGER           :: IPATCH         ! number of patch
+INTEGER           :: JPATCH         ! loop counter
+INTEGER           :: JVEGTYPE       ! loop counter
+LOGICAL           :: GTEB           ! TEB field
+!
+REAL,  DIMENSION(:,:,:), ALLOCATABLE :: ZFIELD ! field read, one level, all patches
+REAL,  DIMENSION(:,:),   ALLOCATABLE :: ZWORK  ! field read, one level, all patches
+!
+REAL,  DIMENSION(:,:,:), ALLOCATABLE :: ZVAR      ! profile of physical variable
+REAL,  DIMENSION(:),   ALLOCATABLE   :: ZCLAY     ! clay fraction
+REAL,  DIMENSION(:),   ALLOCATABLE   :: ZSAND     ! sand fraction
+REAL,  DIMENSION(:),   ALLOCATABLE   :: ZWWILT    ! wilting point
+REAL,  DIMENSION(:),   ALLOCATABLE   :: ZWFC      ! field capacity
+REAL,  DIMENSION(:),   ALLOCATABLE   :: ZWSAT     ! saturation
+REAL,  DIMENSION(:),   ALLOCATABLE   :: ZSOILGRID
+REAL,  DIMENSION(:),   ALLOCATABLE   :: ZNAT      ! natural surface fraction 
+!
+INTEGER :: IVERSION   ! surface version
+INTEGER :: IBUGFIX
+!
+REAL(KIND=JPRB) :: ZHOOK_HANDLE
+!-------------------------------------------------------------------------------
+IF (LHOOK) CALL DR_HOOK('MODE_READ_EXTERN:READ_EXTERN_ISBA',0,ZHOOK_HANDLE)
+WRITE  (KLUOUT,*) ' | Reading ',HFIELD,' in externalized file'
+!
+GTEB = (HNAME(1:3)=='TWN' .OR. HNAME(1:3)=='GD_' .OR. HNAME(1:3)=='GR_' &
+        .OR. HNAME(4:6)=='GD_' .OR. HNAME(4:6)=='GR_')
+!
+!------------------------------------------------------------------------------
+!
+IF (GTEB) THEN
+  CALL OPEN_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE,'TOWN  ')
+ELSE
+  CALL OPEN_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE,'NATURE')
+ENDIF
+!
+YRECFM='VERSION'
+ CALL READ_SURF(HFILEPGDTYPE,YRECFM,IVERSION,IRESP)
+!
+YRECFM='BUG'
+ CALL READ_SURF(HFILEPGDTYPE,YRECFM,IBUGFIX,IRESP)
+!
+!* Read number of soil layers
+!
+YRECFM='GROUND_LAYER'
+IF (GTEB) THEN 
+  YRECFM='TWN_LAYER'
+  IF (IVERSION>7 .OR. IVERSION==7 .AND. IBUGFIX>=3) YRECFM='GD_LAYER'
+ENDIF
+ CALL READ_SURF(HFILEPGDTYPE,YRECFM,ILAYER,IRESP)
+!
+!* number of tiles
+!
+IPATCH=1
+IF (.NOT. GTEB) THEN
+  YRECFM='PATCH_NUMBER'
+  CALL READ_SURF(HFILEPGDTYPE,YRECFM,IPATCH,IRESP)
+END IF
+!
+!* soil scheme
+!
+YRECFM='ISBA'
+IF (GTEB) THEN 
+  YRECFM='TWN_ISBA'
+  IF (IVERSION>7 .OR. IVERSION==7 .AND. IBUGFIX>=3) YRECFM='GD_ISBA'
+ENDIF
+ CALL READ_SURF(HFILEPGDTYPE,YRECFM,YISBA,IRESP)
+!
+IF (IVERSION>=7) THEN
+  !
+  !* Pedo-transfert function
+  !
+  YRECFM='PEDOTF'
+  IF (GTEB) THEN 
+    YRECFM='TWN_PEDOTF'
+    IF (IVERSION>7 .OR. IVERSION==7 .AND. IBUGFIX>=3) YRECFM='GD_PEDOTF'
+  ENDIF
+  CALL READ_SURF(HFILEPGDTYPE,YRECFM,YPEDOTF,IRESP)
+  !
+ELSE
+  YPEDOTF = 'CH78'
+ENDIF
+!
+!Only Brook and Corey with Force-Restore scheme
+IF(YISBA/='DIF')THEN
+  YPEDOTF='CH78'
+ENDIF
+!
+!-------------------------------------------------------------------------------
+!
+! *.  Read clay fraction
+!     ------------------
+!
+ALLOCATE(ZCLAY(KNI))
+YRECFM='CLAY'
+IF (GTEB) THEN 
+  YRECFM='TWN_CLAY'
+  IF (IVERSION>7 .OR. IVERSION==7 .AND. IBUGFIX>=3) YRECFM='GD_CLAY'
+ENDIF
+ CALL READ_SURF(HFILEPGDTYPE,YRECFM,ZCLAY(:),IRESP,HDIR='A')
+!
+!-------------------------------------------------------------------------------
+!
+! *.  Read sand fraction
+!     ------------------
+!
+ALLOCATE(ZSAND(KNI))
+YRECFM='SAND'
+IF (GTEB) THEN 
+  YRECFM='TWN_SAND'
+  IF (IVERSION>7 .OR. IVERSION==7 .AND. IBUGFIX>=3) YRECFM='GD_SAND'
+ENDIF
+ CALL READ_SURF(HFILEPGDTYPE,YRECFM,ZSAND(:),IRESP,HDIR='A')
+!
+!-------------------------------------------------------------------------------
+!
+! *.  Read soil grid
+!     --------------
+!
+!* Reference grid for DIF
+!
+IF(YISBA=='DIF') THEN
+  ALLOCATE(ZSOILGRID(ILAYER))
+  ZSOILGRID=XUNDEF
+  IF (IVERSION>7 .OR. IVERSION==7 .AND. IBUGFIX>=2) THEN
+    YRECFM='SOILGRID'
+    IF (GTEB) THEN 
+      YRECFM='TWN_SOILGRID'
+      IF (IVERSION>7 .OR. IVERSION==7 .AND. IBUGFIX>=3) YRECFM='GD_SOILGRID'
+    ENDIF
+    CALL READ_SURF(HFILEPGDTYPE,YRECFM,ZSOILGRID,IRESP,HDIR='-')
+  ELSE
+    ZSOILGRID(1:ILAYER) = XOPTIMGRID(1:ILAYER)
+  ENDIF
+ELSE
+  ALLOCATE(ZSOILGRID(0))
+ENDIF
+!
+IF ((HFIELD=='TG    ') .AND. (YISBA=='2-L' .OR. YISBA=='3-L')) THEN
+  ALLOCATE(PDEPTH    (KNI,ILAYER,NVEGTYPE))
+  DO JVEGTYPE=1,NVEGTYPE
+    PDEPTH(:,1,JVEGTYPE) = 0.
+    PDEPTH(:,2,JVEGTYPE) = 0.2
+    IF (ILAYER==3) PDEPTH(:,3,JVEGTYPE) = 3.
+  END DO
+ELSE
+  YNAT='NAT'
+  IF (GTEB) YNAT='GRD'
+  CALL READ_EXTERN_DEPTH(HFILEPGDTYPE,KLUOUT,YISBA,YNAT,HFIELD,KNI,ILAYER,IPATCH,&
+                         ZSOILGRID,PDEPTH,IVERSION)
+END IF
+!
+DEALLOCATE(ZSOILGRID)
+!
+! *.  Read fraction of nature
+!     --------------
+!
+ALLOCATE(ZNAT(KNI))
+IF (IVERSION>=7) THEN
+  CALL READ_SURF(HFILEPGDTYPE,'FRAC_NATURE',ZNAT,IRESP,HDIR='A')
+ELSE
+  ZNAT=1.0  
+ENDIF
+
+!
+ CALL CLOSE_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE)
+!
+!* Allocate soil variable profile
+!  ------------------------------
+!
+!
+ALLOCATE(ZVAR(KNI,ILAYER,IPATCH))
+ALLOCATE(ZWORK(KNI,IPATCH))
+ZWORK(:,:) = XUNDEF
+!
+! *.  Read soil variable profile
+!     --------------------------
+!
+IF (GTEB) THEN
+  CALL OPEN_AUX_IO_SURF(HFILE,HFILETYPE,'TOWN  ')
+ELSE
+  CALL OPEN_AUX_IO_SURF(HFILE,HFILETYPE,'NATURE')
+ENDIF
+!
+  YRECFM=TRIM(HNAME)
+  CALL READ_SURF_FIELD3D(HFILETYPE,ZVAR,1,ILAYER,YRECFM,HDIR='A')
+!
+ CALL CLOSE_AUX_IO_SURF(HFILE,HFILETYPE)
+!
+DEALLOCATE(ZWORK)
+!
+!
+! *.  Compute relative humidity from units kg/m^2 (SWI)
+!     ------------------------------------------------
+!
+!* In case of force-restore ISBA, adds one layer at bottom of surface layer
+IF ((HFIELD=='WG    ' .OR. HFIELD=='WGI   ') .AND. (YISBA=='2-L' .OR. YISBA=='3-L')) THEN
+  ALLOCATE(ZFIELD(KNI,ILAYER,IPATCH))
+  ZFIELD(:,:,:) = ZVAR(:,:,:)
+  DEALLOCATE(ZVAR)
+  !
+  ILAYER = ILAYER + 1
+  IF ( YISBA=='3-L' ) ILAYER = ILAYER + 1
+  ALLOCATE(ZVAR(KNI,ILAYER,IPATCH))
+  DO JPATCH=1,IPATCH
+    ZVAR(:,1,JPATCH)=ZFIELD(:,1,JPATCH)
+    ZVAR(:,2,JPATCH)=ZFIELD(:,2,JPATCH)  ! new layer at root layer humidity but below surface layer
+    ZVAR(:,3,JPATCH)=ZFIELD(:,2,JPATCH)
+    IF ( YISBA=='3-L' ) THEN
+      ZVAR(:,4,JPATCH)=ZFIELD(:,3,JPATCH)
+      ZVAR(:,5,JPATCH)=ZFIELD(:,3,JPATCH)
+    END IF
+  END DO
+  DEALLOCATE(ZFIELD)
+END IF
+!
+ALLOCATE(ZFIELD(KNI,ILAYER,IPATCH))
+ZFIELD = ZVAR
+!
+IF (HFIELD=='WG    ' .OR. HFIELD=='WGI   ') THEN
+  !
+  ! Compute ISBA model constants
+  !
+  ALLOCATE (ZWFC  (KNI))
+  ALLOCATE (ZWWILT(KNI))
+  ALLOCATE (ZWSAT (KNI))
+  !
+  ZWSAT (:) = WSAT_FUNC (ZCLAY(:),ZSAND(:),YPEDOTF)
+  ZWWILT(:) = WWILT_FUNC(ZCLAY(:),ZSAND(:),YPEDOTF)
+  ZWFC  (:) = WFC_FUNC  (ZCLAY(:),ZSAND(:),YPEDOTF)
+  !
+  DEALLOCATE (ZSAND)
+  DEALLOCATE (ZCLAY)
+
+  ZFIELD(:,:,:) = XUNDEF
+  !
+  IF (HFIELD=='WG    ') THEN
+    DO JPATCH=1,IPATCH
+      DO JLAYER=1,ILAYER
+        WHERE(ZNAT(:)>0.0 .AND. ZVAR(:,JLAYER,JPATCH)/=XUNDEF)
+          ZVAR(:,JLAYER,JPATCH) = MAX(MIN(ZVAR(:,JLAYER,JPATCH),ZWSAT(:)),0.)
+          !
+          ZFIELD(:,JLAYER,JPATCH) = (ZVAR(:,JLAYER,JPATCH) - ZWWILT(:)) / (ZWFC(:) - ZWWILT(:))
+        END WHERE
+      END DO
+    END DO
+  ELSE IF (HFIELD=='WGI   ') THEN
+    DO JPATCH=1,IPATCH
+      DO JLAYER=1,ILAYER
+        WHERE(ZNAT(:)>0.0 .AND. ZVAR(:,JLAYER,JPATCH)/=XUNDEF)
+          ZFIELD(:,JLAYER,JPATCH) = ZVAR(:,JLAYER,JPATCH) / ZWSAT(:)  
+        END WHERE 
+      END DO
+    END DO
+  END IF
+!
+  DEALLOCATE (ZNAT)
+  DEALLOCATE (ZWSAT)
+  DEALLOCATE (ZWWILT)
+  DEALLOCATE (ZWFC)
+!
+!
+END IF
+!
+DEALLOCATE(ZVAR)
+!-------------------------------------------------------------------------------
+!
+! *.  Set the field on all vegtypes
+!     -----------------------------
+!
+ALLOCATE(PFIELD(KNI,ILAYER,NVEGTYPE))
+ CALL PUT_ON_ALL_VEGTYPES(KNI,ILAYER,IPATCH,NVEGTYPE,ZFIELD,PFIELD)
+DEALLOCATE(ZFIELD)
+IF (LHOOK) CALL DR_HOOK('MODE_READ_EXTERN:READ_EXTERN_ISBA',1,ZHOOK_HANDLE)
+!
+!------------------------------------------------------------------------------
+!
+END SUBROUTINE READ_EXTERN_ISBA
+!
+!------------------------------------------------------------------------------
+!
+END MODULE MODE_READ_EXTERN                       
index 710e8c0..73a70b4 100644 (file)
-!SURFEX_LIC Copyright 1994-2014 Meteo-France \r
-!SURFEX_LIC This is part of the SURFEX software governed by the CeCILL-C  licence\r
-!SURFEX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt\r
-!SURFEX_LIC for details. version 1.\r
-!     #########\r
-SUBROUTINE PREP_ISBA_EXTERN(HPROGRAM,HSURF,HFILE,HFILETYPE,HFILEPGD,HFILEPGDTYPE,KLUOUT,PFIELD)\r
-!     #################################################################################\r
-!\r
-!!****  *PREP_ISBA_EXTERN* - initializes ISBA fields from operational GRIB\r
-!!\r
-!!    PURPOSE\r
-!!    -------\r
-!\r
-!!**  METHOD\r
-!!    ------\r
-!!\r
-!!    REFERENCE\r
-!!    ---------\r
-!!      \r
-!!\r
-!!    AUTHOR\r
-!!    ------\r
-!!     V. Masson \r
-!!\r
-!!    MODIFICATIONS\r
-!!    -------------\r
-!!      Original    01/2004\r
-!!        M.Moge    01/2016  using READ_SURF_FIELD2D for 2D surfex fields reads\r
-!!------------------------------------------------------------------\r
-!\r
-\r
-!\r
-USE MODE_READ_EXTERN\r
-!\r
-USE MODD_TYPE_DATE_SURF\r
-!\r
-USE MODI_PREP_GRID_EXTERN\r
-USE MODI_READ_SURF\r
-USE MODI_INTERP_GRID\r
-USE MODI_OPEN_AUX_IO_SURF\r
-USE MODI_CLOSE_AUX_IO_SURF\r
-!\r
-USE MODD_PREP,           ONLY : CINGRID_TYPE, CINTERP_TYPE\r
-USE MODD_PREP_ISBA,      ONLY : XGRID_SOIL, XWR_DEF\r
-USE MODD_DATA_COVER_PAR, ONLY : NVEGTYPE\r
-USE MODD_SURF_PAR,       ONLY : XUNDEF\r
-!\r
-USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK\r
-USE PARKIND1  ,ONLY : JPRB\r
-!\r
-USE MODI_PUT_ON_ALL_VEGTYPES\r
-!\r
-USE MODI_READ_SURF_FIELD2D\r
-!\r
-IMPLICIT NONE\r
-!\r
-!*      0.1    declarations of arguments\r
-!\r
- CHARACTER(LEN=6),   INTENT(IN)  :: HPROGRAM  ! program calling surf. schemes\r
- CHARACTER(LEN=7),   INTENT(IN)  :: HSURF     ! type of field\r
- CHARACTER(LEN=28),  INTENT(IN)  :: HFILE     ! name of file\r
- CHARACTER(LEN=6),   INTENT(IN)  :: HFILETYPE ! type of input file\r
- CHARACTER(LEN=28),  INTENT(IN)  :: HFILEPGD     ! name of file\r
- CHARACTER(LEN=6),   INTENT(IN)  :: HFILEPGDTYPE ! type of input file\r
-INTEGER,            INTENT(IN)  :: KLUOUT    ! logical unit of output listing\r
-REAL,DIMENSION(:,:,:), POINTER  :: PFIELD    ! field to interpolate horizontally (on final soil grid)\r
-!\r
-!*      0.2    declarations of local variables\r
-!\r
- CHARACTER(LEN=12) :: YRECFM         ! Name of the article to be read\r
-INTEGER           :: IRESP          ! reading return code\r
-INTEGER           :: INI            ! total 1D dimension\r
-INTEGER           :: IPATCH         ! number of patch\r
-!\r
-REAL, DIMENSION(:,:,:), POINTER     :: ZFIELD         ! field read on initial MNH vertical soil grid, all patches\r
-REAL, DIMENSION(:,:),   POINTER     :: ZFIELD1        ! field read on initial MNH vertical soil grid, one patch\r
-REAL, DIMENSION(:,:,:), POINTER     :: ZD             ! depth of field in the soil\r
-REAL, DIMENSION(:,:), POINTER     :: ZD1            ! depth of field in the soil, one patch\r
-REAL, DIMENSION(:,:), ALLOCATABLE   :: ZOUT         !\r
-INTEGER                             :: JVEGTYPE        ! loop counter for patch\r
-REAL(KIND=JPRB) :: ZHOOK_HANDLE\r
-!\r
-!------------------------------------------------------------------------------\r
-!\r
-!*      1.     Preparation of IO for reading in the file\r
-!              -----------------------------------------\r
-!\r
-!* Note that all points are read, even those without physical meaning.\r
-!  These points will not be used during the horizontal interpolation step.\r
-!  Their value must be defined as XUNDEF.\r
-!\r
-IF (LHOOK) CALL DR_HOOK('PREP_ISBA_EXTERN',0,ZHOOK_HANDLE)\r
-!\r
-!------------------------------------------------------------------------------\r
-!\r
-!*      2.     Reading of grid\r
-!              ---------------\r
-!\r
- CALL OPEN_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE,'NATURE')\r
-!\r
- CALL PREP_GRID_EXTERN(HFILEPGDTYPE,KLUOUT,CINGRID_TYPE,CINTERP_TYPE,INI)\r
-!\r
-!---------------------------------------------------------------------------------------\r
-!\r
-!*      3.     Transformation into physical quantity to be interpolated\r
-!              --------------------------------------------------------\r
-!\r
-SELECT CASE(HSURF)\r
-!\r
-!*     3.      Orography\r
-!              ---------\r
-!\r
-  CASE('ZS     ')\r
-    ALLOCATE(PFIELD(INI,1,1))\r
-    YRECFM='ZS'\r
-    CALL READ_SURF(HFILEPGDTYPE,YRECFM,PFIELD(:,1,1),IRESP,HDIR='A')\r
-    CALL CLOSE_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE)\r
-!\r
-!--------------------------------------------------------------------------\r
-!\r
-!\r
-!*      3.1    Profile of temperature, water or ice in the soil\r
-!\r
-  CASE('TG    ','WG    ','WGI   ')\r
-     CALL CLOSE_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE)\r
-!* reading of the profile and its depth definition\r
-     CALL READ_EXTERN_ISBA(HFILE,HFILETYPE,HFILEPGD,HFILEPGDTYPE,&\r
-                           KLUOUT,INI,HSURF,HSURF,ZFIELD,ZD)\r
-! \r
-     ALLOCATE(ZFIELD1(SIZE(ZFIELD,1),SIZE(ZFIELD,2)))\r
-     ALLOCATE(ZD1(SIZE(ZFIELD,1),SIZE(ZFIELD,2)))\r
-     ALLOCATE(ZOUT(SIZE(ZFIELD,1),SIZE(XGRID_SOIL)))\r
-     ALLOCATE(PFIELD(SIZE(ZFIELD,1),SIZE(XGRID_SOIL),SIZE(ZFIELD,3)))\r
-!\r
-     DO JVEGTYPE=1,SIZE(ZFIELD,3)\r
-        ZFIELD1(:,:)=ZFIELD(:,:,JVEGTYPE)\r
-        ZD1(:,:)=ZD(:,:,JVEGTYPE)\r
-        CALL INTERP_GRID(ZD1,ZFIELD1,XGRID_SOIL,ZOUT)\r
-        PFIELD(:,:,JVEGTYPE)=ZOUT(:,:)\r
-     END DO\r
-   \r
-!\r
-     DEALLOCATE(ZFIELD)\r
-     DEALLOCATE(ZOUT)\r
-     DEALLOCATE(ZFIELD1)\r
-     DEALLOCATE(ZD)\r
-!\r
-!--------------------------------------------------------------------------\r
-!\r
-!*      3.4    Water content intercepted on leaves, LAI\r
-!\r
-  CASE('WR     ')\r
-     ALLOCATE(PFIELD(INI,1,NVEGTYPE))\r
-     !* number of tiles\r
-     YRECFM='PATCH_NUMBER'\r
-     CALL READ_SURF(HFILEPGDTYPE,YRECFM,IPATCH,IRESP)\r
-     CALL CLOSE_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE)\r
-     ALLOCATE(ZFIELD(INI,1,IPATCH))\r
-     YRECFM = 'WR'\r
-     CALL OPEN_AUX_IO_SURF(HFILE,HFILETYPE,'NATURE')\r
-     CALL READ_SURF_FIELD2D(HFILETYPE,ZFIELD(:,1,:),YRECFM,HDIR='A')\r
-     CALL CLOSE_AUX_IO_SURF(HFILE,HFILETYPE)\r
-     CALL PUT_ON_ALL_VEGTYPES(INI,1,IPATCH,NVEGTYPE,ZFIELD,PFIELD)\r
-     DEALLOCATE(ZFIELD)\r
-!\r
-  CASE('LAI    ')\r
-     CALL CLOSE_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE)\r
-     ALLOCATE(PFIELD(INI,1,NVEGTYPE))\r
-     PFIELD(:,:,:) = XUNDEF\r
-!\r
-END SELECT\r
-!\r
-!\r
-!---------------------------------------------------------------------------\r
-!\r
-!*      6.     End of IO\r
-!              ---------\r
-!\r
-IF (LHOOK) CALL DR_HOOK('PREP_ISBA_EXTERN',1,ZHOOK_HANDLE)\r
-!\r
-!---------------------------------------------------------------------------\r
-!---------------------------------------------------------------------------\r
-END SUBROUTINE PREP_ISBA_EXTERN\r
+!SURFEX_LIC Copyright 1994-2014 Meteo-France 
+!SURFEX_LIC This is part of the SURFEX software governed by the CeCILL-C  licence
+!SURFEX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
+!SURFEX_LIC for details. version 1.
+!     #########
+SUBROUTINE PREP_ISBA_EXTERN(HPROGRAM,HSURF,HFILE,HFILETYPE,HFILEPGD,HFILEPGDTYPE,KLUOUT,PFIELD)
+!     #################################################################################
+!
+!!****  *PREP_ISBA_EXTERN* - initializes ISBA fields from operational GRIB
+!!
+!!    PURPOSE
+!!    -------
+!
+!!**  METHOD
+!!    ------
+!!
+!!    REFERENCE
+!!    ---------
+!!      
+!!
+!!    AUTHOR
+!!    ------
+!!     V. Masson 
+!!
+!!    MODIFICATIONS
+!!    -------------
+!!      Original    01/2004
+!!        M.Moge    01/2016  using READ_SURF_FIELD2D for 2D surfex fields reads
+!!------------------------------------------------------------------
+!
+
+!
+USE MODE_READ_EXTERN
+!
+USE MODD_TYPE_DATE_SURF
+!
+USE MODI_PREP_GRID_EXTERN
+USE MODI_READ_SURF
+USE MODI_INTERP_GRID
+USE MODI_OPEN_AUX_IO_SURF
+USE MODI_CLOSE_AUX_IO_SURF
+!
+USE MODD_PREP,           ONLY : CINGRID_TYPE, CINTERP_TYPE
+USE MODD_PREP_ISBA,      ONLY : XGRID_SOIL, XWR_DEF
+USE MODD_DATA_COVER_PAR, ONLY : NVEGTYPE
+USE MODD_SURF_PAR,       ONLY : XUNDEF
+!
+USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
+USE PARKIND1  ,ONLY : JPRB
+!
+USE MODI_PUT_ON_ALL_VEGTYPES
+!
+USE MODI_READ_SURF_FIELD2D
+!
+IMPLICIT NONE
+!
+!*      0.1    declarations of arguments
+!
+ CHARACTER(LEN=6),   INTENT(IN)  :: HPROGRAM  ! program calling surf. schemes
+ CHARACTER(LEN=7),   INTENT(IN)  :: HSURF     ! type of field
+ CHARACTER(LEN=28),  INTENT(IN)  :: HFILE     ! name of file
+ CHARACTER(LEN=6),   INTENT(IN)  :: HFILETYPE ! type of input file
+ CHARACTER(LEN=28),  INTENT(IN)  :: HFILEPGD     ! name of file
+ CHARACTER(LEN=6),   INTENT(IN)  :: HFILEPGDTYPE ! type of input file
+INTEGER,            INTENT(IN)  :: KLUOUT    ! logical unit of output listing
+REAL,DIMENSION(:,:,:), POINTER  :: PFIELD    ! field to interpolate horizontally (on final soil grid)
+!
+!*      0.2    declarations of local variables
+!
+ CHARACTER(LEN=12) :: YRECFM         ! Name of the article to be read
+INTEGER           :: IRESP          ! reading return code
+INTEGER           :: INI            ! total 1D dimension
+INTEGER           :: IPATCH         ! number of patch
+!
+REAL, DIMENSION(:,:,:), POINTER     :: ZFIELD         ! field read on initial MNH vertical soil grid, all patches
+REAL, DIMENSION(:,:),   POINTER     :: ZFIELD1        ! field read on initial MNH vertical soil grid, one patch
+REAL, DIMENSION(:,:,:), POINTER     :: ZD             ! depth of field in the soil
+REAL, DIMENSION(:,:), POINTER     :: ZD1            ! depth of field in the soil, one patch
+REAL, DIMENSION(:,:), ALLOCATABLE   :: ZOUT         !
+INTEGER                             :: JVEGTYPE        ! loop counter for patch
+REAL(KIND=JPRB) :: ZHOOK_HANDLE
+!
+!------------------------------------------------------------------------------
+!
+!*      1.     Preparation of IO for reading in the file
+!              -----------------------------------------
+!
+!* Note that all points are read, even those without physical meaning.
+!  These points will not be used during the horizontal interpolation step.
+!  Their value must be defined as XUNDEF.
+!
+IF (LHOOK) CALL DR_HOOK('PREP_ISBA_EXTERN',0,ZHOOK_HANDLE)
+!
+!------------------------------------------------------------------------------
+!
+!*      2.     Reading of grid
+!              ---------------
+!
+ CALL OPEN_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE,'NATURE')
+!
+ CALL PREP_GRID_EXTERN(HFILEPGDTYPE,KLUOUT,CINGRID_TYPE,CINTERP_TYPE,INI)
+!
+!---------------------------------------------------------------------------------------
+!
+!*      3.     Transformation into physical quantity to be interpolated
+!              --------------------------------------------------------
+!
+SELECT CASE(HSURF)
+!
+!*     3.      Orography
+!              ---------
+!
+  CASE('ZS     ')
+    ALLOCATE(PFIELD(INI,1,1))
+    YRECFM='ZS'
+    CALL READ_SURF(HFILEPGDTYPE,YRECFM,PFIELD(:,1,1),IRESP,HDIR='A')
+    CALL CLOSE_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE)
+!
+!--------------------------------------------------------------------------
+!
+!
+!*      3.1    Profile of temperature, water or ice in the soil
+!
+  CASE('TG    ','WG    ','WGI   ')
+     CALL CLOSE_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE)
+!* reading of the profile and its depth definition
+     CALL READ_EXTERN_ISBA(HFILE,HFILETYPE,HFILEPGD,HFILEPGDTYPE,&
+                           KLUOUT,INI,HSURF,HSURF,ZFIELD,ZD)
+! 
+     ALLOCATE(ZFIELD1(SIZE(ZFIELD,1),SIZE(ZFIELD,2)))
+     ALLOCATE(ZD1(SIZE(ZFIELD,1),SIZE(ZFIELD,2)))
+     ALLOCATE(ZOUT(SIZE(ZFIELD,1),SIZE(XGRID_SOIL)))
+     ALLOCATE(PFIELD(SIZE(ZFIELD,1),SIZE(XGRID_SOIL),SIZE(ZFIELD,3)))
+!
+     DO JVEGTYPE=1,SIZE(ZFIELD,3)
+        ZFIELD1(:,:)=ZFIELD(:,:,JVEGTYPE)
+        ZD1(:,:)=ZD(:,:,JVEGTYPE)
+        CALL INTERP_GRID(ZD1,ZFIELD1,XGRID_SOIL,ZOUT)
+        PFIELD(:,:,JVEGTYPE)=ZOUT(:,:)
+     END DO
+   
+!
+     DEALLOCATE(ZFIELD)
+     DEALLOCATE(ZOUT)
+     DEALLOCATE(ZFIELD1)
+     DEALLOCATE(ZD)
+!
+!--------------------------------------------------------------------------
+!
+!*      3.4    Water content intercepted on leaves, LAI
+!
+  CASE('WR     ')
+     ALLOCATE(PFIELD(INI,1,NVEGTYPE))
+     !* number of tiles
+     YRECFM='PATCH_NUMBER'
+     CALL READ_SURF(HFILEPGDTYPE,YRECFM,IPATCH,IRESP)
+     CALL CLOSE_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE)
+     ALLOCATE(ZFIELD(INI,1,IPATCH))
+     YRECFM = 'WR'
+     CALL OPEN_AUX_IO_SURF(HFILE,HFILETYPE,'NATURE')
+     CALL READ_SURF_FIELD2D(HFILETYPE,ZFIELD(:,1,:),YRECFM,HDIR='A')
+     CALL CLOSE_AUX_IO_SURF(HFILE,HFILETYPE)
+     CALL PUT_ON_ALL_VEGTYPES(INI,1,IPATCH,NVEGTYPE,ZFIELD,PFIELD)
+     DEALLOCATE(ZFIELD)
+!
+  CASE('LAI    ')
+     CALL CLOSE_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE)
+     ALLOCATE(PFIELD(INI,1,NVEGTYPE))
+     PFIELD(:,:,:) = XUNDEF
+!
+END SELECT
+!
+!
+!---------------------------------------------------------------------------
+!
+!*      6.     End of IO
+!              ---------
+!
+IF (LHOOK) CALL DR_HOOK('PREP_ISBA_EXTERN',1,ZHOOK_HANDLE)
+!
+!---------------------------------------------------------------------------
+!---------------------------------------------------------------------------
+END SUBROUTINE PREP_ISBA_EXTERN
index 74c1ed9..20fa380 100644 (file)
-!SURFEX_LIC Copyright 1994-2014 Meteo-France \r
-!SURFEX_LIC This is part of the SURFEX software governed by the CeCILL-C  licence\r
-!SURFEX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt\r
-!SURFEX_LIC for details. version 1.\r
-!!\r
-!!    MODIFICATIONS\r
-!!    -------------\r
-!!      M.Moge    01/2016  using READ_SURF_FIELD2D/3D for 2D/3D surfex fields reads\r
-!     #########\r
-SUBROUTINE PREP_TEB_EXTERN(HPROGRAM,HSURF,HFILE,HFILETYPE,HFILEPGD,HFILEPGDTYPE,KLUOUT,PFIELD)\r
-!     #################################################################################\r
-!\r
-USE MODD_TYPE_DATE_SURF\r
-!\r
-USE MODI_PREP_GRID_EXTERN\r
-USE MODI_READ_SURF\r
-USE MODI_GET_TEB_DEPTHS\r
-USE MODI_INTERP_GRID\r
-USE MODI_OPEN_AUX_IO_SURF\r
-USE MODI_CLOSE_AUX_IO_SURF\r
-USE MODI_TOWN_PRESENCE\r
-USE MODI_READ_TEB_PATCH\r
-USE MODI_GET_CURRENT_TEB_PATCH\r
-USE MODI_READ_SURF_FIELD2D\r
-!\r
-USE MODD_PREP,       ONLY : CINGRID_TYPE, CINTERP_TYPE\r
-USE MODD_PREP_TEB,   ONLY : XGRID_ROAD, XGRID_WALL, XGRID_ROOF, &\r
-                            XGRID_FLOOR, XWS_ROOF, XWS_ROAD, &\r
-                            XTI_BLD_DEF, XWS_ROOF_DEF, XWS_ROAD_DEF, XHUI_BLD_DEF\r
-USE MODD_DATA_COVER_PAR, ONLY : JPCOVER\r
-USE MODD_SURF_PAR, ONLY: XUNDEF\r
-!\r
-USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK\r
-USE PARKIND1  ,ONLY : JPRB\r
-!\r
-IMPLICIT NONE\r
-!\r
-!*      0.1    declarations of arguments\r
-!\r
- CHARACTER(LEN=6),   INTENT(IN)  :: HPROGRAM  ! program calling surf. schemes\r
- CHARACTER(LEN=7),   INTENT(IN)  :: HSURF     ! type of field\r
- CHARACTER(LEN=28),  INTENT(IN)  :: HFILE     ! name of file\r
- CHARACTER(LEN=6),   INTENT(IN)  :: HFILETYPE ! type of input file\r
- CHARACTER(LEN=28),  INTENT(IN)  :: HFILEPGD     ! name of file\r
- CHARACTER(LEN=6),   INTENT(IN)  :: HFILEPGDTYPE ! type of input file\r
-INTEGER,            INTENT(IN)  :: KLUOUT    ! logical unit of output listing\r
-REAL,DIMENSION(:,:), POINTER    :: PFIELD    ! field to interpolate horizontally\r
-!\r
-!*      0.2    declarations of local variables\r
-!\r
-REAL, DIMENSION(:,:), ALLOCATABLE :: ZFIELD         ! field read\r
-REAL, DIMENSION(:,:), ALLOCATABLE :: ZDEPTH         ! depth of each layer\r
-REAL, DIMENSION(:),   ALLOCATABLE :: ZDEPTH_TOT     ! total depth of surface\r
-!\r
-REAL, DIMENSION(:,:),   ALLOCATABLE :: ZD  ! intermediate array\r
-!\r
- CHARACTER(LEN=12) :: YRECFM         ! Name of the article to be read\r
-INTEGER           :: IRESP          ! reading return code\r
-INTEGER           :: ILAYER         ! number of layers\r
-INTEGER           :: JLAYER         ! loop counter\r
-INTEGER           :: IVERSION       ! SURFEX version\r
-INTEGER           :: IBUGFIX        ! SURFEX bug version\r
-LOGICAL           :: GOLD_NAME      ! old name flag for temperatures\r
- CHARACTER(LEN=4)  :: YWALL_OPT      ! option of walls\r
- CHARACTER(LEN=6)  :: YSURF          ! Surface type\r
- CHARACTER(LEN=3)  :: YBEM ! key of the building energy model DEF for DEFault (Masson et al. 2002) ,\r
-                          ! BEM for Building Energy Model (Bueno et al. 2012)\r
-!\r
-INTEGER           :: INI            ! total 1D dimension\r
-!\r
-LOGICAL                              :: GTEB      ! flag if TEB fields are present\r
-INTEGER                              :: IPATCH    ! number of soil temperature patches\r
-INTEGER                              :: ITEB_PATCH! number of TEB patches in file\r
-INTEGER                              :: ICURRENT_PATCH! current TEB patch to be initialized\r
- CHARACTER(LEN=3)                     :: YPATCH    ! indentificator for TEB patch\r
-REAL(KIND=JPRB) :: ZHOOK_HANDLE\r
-!-------------------------------------------------------------------------------------\r
-!\r
-!*      1.     Preparation of IO for reading in the file\r
-!              -----------------------------------------\r
-!\r
-!* Note that all points are read, even those without physical meaning.\r
-!  These points will not be used during the horizontal interpolation step.\r
-!  Their value must be defined as XUNDEF.\r
-!\r
-IF (LHOOK) CALL DR_HOOK('PREP_TEB_EXTERN',0,ZHOOK_HANDLE)\r
-!\r
- CALL OPEN_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE,'TOWN  ')\r
-!\r
-!* reading of version of the file being read\r
- CALL READ_SURF(HFILEPGDTYPE,'VERSION',IVERSION,IRESP)\r
- CALL READ_SURF(HFILEPGDTYPE,'BUG',IBUGFIX,IRESP)\r
-GOLD_NAME=(IVERSION<7 .OR. (IVERSION==7 .AND. IBUGFIX<3))\r
-!\r
-IF (.NOT.GOLD_NAME) THEN\r
-   YRECFM='BEM'\r
-   CALL READ_SURF(HFILEPGDTYPE,YRECFM,YBEM,IRESP)\r
-ELSE\r
-   YBEM='DEF'\r
-ENDIF\r
-!-------------------------------------------------------------------------------------\r
-!\r
-!*      2.     Reading of grid\r
-!              ---------------\r
-!\r
-!* reads the grid\r
- CALL PREP_GRID_EXTERN(HFILEPGDTYPE,KLUOUT,CINGRID_TYPE,CINTERP_TYPE,INI)\r
-!\r
-!\r
-!* reads if TEB fields exist in the input file\r
- CALL TOWN_PRESENCE(HFILEPGDTYPE,GTEB)\r
-!\r
-!---------------------------------------------------------------------------------------\r
-!\r
-!*     3.      Orography\r
-!              ---------\r
-!\r
-IF (HSURF=='ZS     ') THEN\r
-  !\r
-  ALLOCATE(PFIELD(INI,1))\r
-  YRECFM='ZS'\r
-  CALL READ_SURF(HFILEPGDTYPE,YRECFM,PFIELD(:,1),IRESP,HDIR='A')\r
-  CALL CLOSE_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE)\r
-  !\r
-  !---------------------------------------------------------------------------------------\r
-ELSE\r
-!---------------------------------------------------------------------------------------\r
-!\r
-!*     4.     TEB fields are read\r
-!             -------------------\r
-!\r
-  IF (GTEB) THEN\r
-!\r
-    CALL READ_TEB_PATCH(HFILEPGDTYPE,ITEB_PATCH)\r
-    CALL GET_CURRENT_TEB_PATCH(ICURRENT_PATCH)\r
-    YPATCH='   '\r
-    IF (ITEB_PATCH>1) THEN\r
-      WRITE(YPATCH,FMT='(A,I1,A)') 'T',MIN(ICURRENT_PATCH,ITEB_PATCH),'_'\r
-    END IF\r
-!---------------------------------------------------------------------------------------\r
-    SELECT CASE(HSURF)\r
-!---------------------------------------------------------------------------------------\r
-!\r
-!*     4.1    Profile of temperatures in roads, roofs or walls\r
-!             ------------------------------------------------\r
-!\r
-    CASE('T_ROAD','T_ROOF','T_WALLA','T_WALLB','T_FLOOR','T_MASS')\r
-      YSURF=HSURF(1:6)\r
-      !* reading of number of layers\r
-      IF (YSURF=='T_ROAD') YRECFM='ROAD_LAYER'\r
-      IF (YSURF=='T_ROOF') YRECFM='ROOF_LAYER'\r
-      IF (YSURF=='T_WALL') YRECFM='WALL_LAYER'\r
-      IF (YSURF=='T_FLOO' .OR. YSURF=='T_MASS') THEN \r
-        IF (YBEM=='DEF') THEN\r
-          YRECFM='ROAD_LAYER'\r
-        ELSE\r
-          YRECFM='FLOOR_LAYER'\r
-        END IF\r
-      END IF\r
-      CALL READ_SURF(HFILEPGDTYPE,YRECFM,ILAYER,IRESP)\r
-      !\r
-      ALLOCATE(ZD(INI,ILAYER))\r
-      IF (YSURF=='T_ROAD') CALL GET_TEB_DEPTHS(HFILEPGDTYPE,PD_ROAD=ZD)\r
-      IF (YSURF=='T_ROOF') CALL GET_TEB_DEPTHS(HFILEPGDTYPE,PD_ROOF=ZD)\r
-      IF (YSURF=='T_WALL') CALL GET_TEB_DEPTHS(HFILEPGDTYPE,PD_WALL=ZD)\r
-      IF (YSURF=='T_MASS') CALL GET_TEB_DEPTHS(HFILEPGDTYPE,PD_FLOOR=ZD)\r
-      IF (YSURF=='T_FLOO') CALL GET_TEB_DEPTHS(HFILEPGDTYPE,PD_FLOOR=ZD)\r
-      !\r
-      CALL CLOSE_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE)\r
-      CALL OPEN_AUX_IO_SURF(HFILE,HFILETYPE,'TOWN  ')\r
-      !\r
-      !* reading option for road orientation\r
-      YWALL_OPT = 'UNIF'\r
-      IF (YSURF =='T_WALL' .AND. .NOT. GOLD_NAME) THEN\r
-        CALL READ_SURF(HFILETYPE,'WALL_OPT',YWALL_OPT,IRESP)\r
-      END IF\r
-      !\r
-      !* reading of the profile\r
-      ALLOCATE(ZFIELD(INI,ILAYER))\r
-      DO JLAYER=1,ILAYER\r
-        IF (GOLD_NAME) THEN\r
-          WRITE(YRECFM,'(A6,I1.1)') HSURF(1:6),JLAYER\r
-        ELSE\r
-          WRITE(YRECFM,'(A1,A4,I1.1)') HSURF(1:1),HSURF(3:6),JLAYER\r
-          IF (YSURF =='T_WALL' .AND. YWALL_OPT/='UNIF') &\r
-            WRITE(YRECFM,'(A1,A5,I1.1)') HSURF(1:1),HSURF(3:7),JLAYER\r
-          IF ((HSURF=='T_FLOOR' .OR. HSURF=='T_MASS') .AND. YBEM=='DEF') THEN\r
-            IF (HSURF=='T_FLOOR' .AND. JLAYER>1) THEN \r
-              WRITE(YRECFM,'(A5,I1.1)') 'TROAD',JLAYER\r
-            ELSE\r
-              WRITE(YRECFM,'(A6)') 'TI_BLD'\r
-            ENDIF\r
-          END IF\r
-        END IF\r
-        YRECFM=YPATCH//YRECFM\r
-        YRECFM=ADJUSTL(YRECFM)\r
-        CALL READ_SURF(HFILETYPE,YRECFM,ZFIELD(:,JLAYER),IRESP,HDIR='A')\r
-      END DO\r
-      CALL CLOSE_AUX_IO_SURF(HFILE,HFILETYPE)\r
-      !\r
-      !* recovers middle layer depth (from the surface)\r
-      ALLOCATE(ZDEPTH    (INI,ILAYER))\r
-      ALLOCATE(ZDEPTH_TOT(INI))\r
-      ZDEPTH    (:,1)=ZD(:,1)/2.\r
-      ZDEPTH_TOT(:)  =ZD(:,1)\r
-      DO JLAYER=2,ILAYER\r
-        ZDEPTH    (:,JLAYER) = ZDEPTH_TOT(:) + ZD(:,JLAYER)/2.\r
-        ZDEPTH_TOT(:) = ZDEPTH_TOT(:) + ZD(:,JLAYER)\r
-      END DO\r
-      !\r
-      !* in case of wall or roof, normalizes by total wall or roof thickness\r
-      IF (YSURF=='T_ROOF' .OR. YSURF=='T_WALL' .OR. HSURF == 'T_FLOOR' .OR. HSURF == 'T_MASS') THEN\r
-        DO JLAYER=1,ILAYER\r
-          ZDEPTH(:,JLAYER) = ZDEPTH(:,JLAYER) / ZDEPTH_TOT(:)\r
-        END DO\r
-      END IF\r
-      !\r
-      !* interpolation on the fine vertical grid\r
-      IF (YSURF=='T_ROAD') THEN\r
-        ALLOCATE(PFIELD(SIZE(ZFIELD,1),SIZE(XGRID_ROAD)))\r
-        CALL INTERP_GRID(ZDEPTH,ZFIELD,XGRID_ROAD,PFIELD)\r
-      ELSEIF (YSURF=='T_ROOF') THEN\r
-        ALLOCATE(PFIELD(SIZE(ZFIELD,1),SIZE(XGRID_ROOF)))\r
-        CALL INTERP_GRID(ZDEPTH,ZFIELD,XGRID_ROOF,PFIELD)\r
-      ELSEIF (YSURF=='T_WALL') THEN\r
-        ALLOCATE(PFIELD(SIZE(ZFIELD,1),SIZE(XGRID_WALL)))\r
-        CALL INTERP_GRID(ZDEPTH,ZFIELD,XGRID_WALL,PFIELD)\r
-      ELSEIF (YSURF=='T_FLOO' .OR. YSURF=='T_MASS') THEN\r
-        ALLOCATE(PFIELD(SIZE(ZFIELD,1),SIZE(XGRID_FLOOR)))\r
-        CALL INTERP_GRID(ZDEPTH,ZFIELD,XGRID_FLOOR,PFIELD)\r
-      END IF\r
-      !\r
-      !* end\r
-      DEALLOCATE(ZD)\r
-      DEALLOCATE(ZFIELD)\r
-      DEALLOCATE(ZDEPTH)\r
-      DEALLOCATE(ZDEPTH_TOT)\r
-!---------------------------------------------------------------------------------------\r
-!\r
-!*      4.2    Internal moisture\r
-!              ---------------\r
-!\r
-    CASE('QI_BLD ')\r
-      ALLOCATE(PFIELD(INI,1))\r
-      IF (YBEM=='BEM') THEN\r
-        YRECFM='QI_BLD'\r
-        YRECFM=YPATCH//YRECFM\r
-        YRECFM=ADJUSTL(YRECFM)\r
-        CALL CLOSE_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE)\r
-        CALL OPEN_AUX_IO_SURF(HFILE,HFILETYPE,'TOWN  ')\r
-        CALL READ_SURF(HFILETYPE,YRECFM,PFIELD(:,1),IRESP,HDIR='A')\r
-        CALL CLOSE_AUX_IO_SURF(HFILE,HFILETYPE)\r
-      ELSE\r
-        PFIELD(:,1) = XUNDEF\r
-      ENDIF\r
-!\r
-!---------------------------------------------------------------------------------------\r
-!\r
-!*      4.2    Other variables\r
-!              ---------------\r
-!\r
-    CASE DEFAULT\r
-      ALLOCATE(PFIELD(INI,1))\r
-      YRECFM=HSURF\r
-      IF (HSURF=='T_CAN  ') THEN\r
-        YRECFM='TCANYON'\r
-        IF (GOLD_NAME) YRECFM='T_CANYON'\r
-      ELSEIF (HSURF=='Q_CAN  ') THEN\r
-        YRECFM='QCANYON'\r
-        IF (GOLD_NAME) YRECFM='Q_CANYON'\r
-      ELSEIF (HSURF=='T_WIN2 ' .OR. HSURF=='T_WIN1') THEN\r
-        IF (YBEM=='BEM') THEN\r
-          YRECFM=HSURF\r
-        ELSE\r
-          YRECFM='TI_BLD'\r
-        ENDIF\r
-      ENDIF\r
-      YRECFM=YPATCH//YRECFM\r
-      YRECFM=ADJUSTL(YRECFM)\r
-      CALL CLOSE_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE)\r
-      CALL OPEN_AUX_IO_SURF(HFILE,HFILETYPE,'TOWN  ')\r
-      CALL READ_SURF(HFILETYPE,YRECFM,PFIELD(:,1),IRESP,HDIR='A')\r
-      CALL CLOSE_AUX_IO_SURF(HFILE,HFILETYPE)\r
-!\r
-!---------------------------------------------------------------------------------------\r
-    END SELECT\r
-!---------------------------------------------------------------------------------------\r
-!\r
-!*     5.     Subtitutes if TEB fields do not exist\r
-!             -------------------------------------\r
-!\r
-  ELSE\r
-\r
-    CALL CLOSE_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE)\r
-\r
-    SELECT CASE(HSURF)\r
-\r
-    !* temperature profiles\r
-    CASE('T_ROAD','T_ROOF','T_WALL','T_WIN1','T_FLOOR','T_CAN','TI_ROAD')\r
-      YSURF=HSURF(1:6)\r
-      !* reading of the soil surface temperature\r
-      CALL OPEN_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE,'NATURE')\r
-      CALL READ_SURF(HFILEPGDTYPE,'PATCH_NUMBER',IPATCH,IRESP)\r
-      CALL CLOSE_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE)\r
-      ALLOCATE(ZFIELD(INI,IPATCH))\r
-      CALL OPEN_AUX_IO_SURF(HFILE,HFILETYPE,'NATURE')\r
-      IF (YSURF=='T_FLOO' .OR. YSURF=='T_CAN ' .OR. YSURF=='TI_ROA') THEN\r
-        YRECFM='TG2'\r
-        CALL READ_SURF_FIELD2D(HFILETYPE,ZFIELD(:,:),YRECFM,HDIR='A')\r
-      ELSE\r
-        YRECFM='TG1'\r
-        CALL READ_SURF_FIELD2D(HFILETYPE,ZFIELD(:,:),YRECFM,HDIR='A')\r
-      ENDIF\r
-      CALL CLOSE_AUX_IO_SURF(HFILE,HFILETYPE)\r
-      !* fills the whole temperature profile by this soil temperature\r
-      IF (YSURF=='T_ROAD') ILAYER=SIZE(XGRID_ROAD)\r
-      IF (YSURF=='T_ROOF') ILAYER=SIZE(XGRID_ROOF)\r
-      IF (YSURF=='T_WALL') ILAYER=SIZE(XGRID_WALL)\r
-      IF (YSURF=='T_FLOO') ILAYER=SIZE(XGRID_FLOOR)\r
-      IF (YSURF=='T_WIN1' .OR. YSURF=='T_CAN ' .OR. YSURF=='TI_ROA') ILAYER=1\r
-      ALLOCATE(PFIELD(INI,ILAYER))\r
-      IF (YSURF=='T_FLOO') THEN\r
-        !* sets the temperature equal to this deep soil temperature\r
-        PFIELD(:,1) = XTI_BLD_DEF\r
-      ELSE\r
-        PFIELD(:,1) = ZFIELD(:,1)\r
-      ENDIF\r
-      DO JLAYER=2,ILAYER\r
-        PFIELD(:,JLAYER) = ZFIELD(:,1)\r
-      END DO\r
-      DEALLOCATE(ZFIELD)\r
-\r
-    CASE('T_MASS','TI_BLD','T_WIN2')\r
-      YSURF=HSURF(1:6)\r
-      IF (YSURF=='T_MASS') ILAYER = SIZE(XGRID_FLOOR)\r
-      IF (YSURF=='TI_BLD'.OR.YSURF=='T_WIN2') ILAYER=1\r
-      ALLOCATE(PFIELD(INI, ILAYER))\r
-      PFIELD(:,:) = XTI_BLD_DEF\r
\r
-    !* building moisture\r
-    CASE('QI_BLD ')\r
-      ALLOCATE(PFIELD(INI,1))\r
-      PFIELD(:,1) = XUNDEF\r
-\r
-    !* water reservoirs\r
-    CASE('WS_ROOF','WS_ROAD')\r
-      ALLOCATE(PFIELD(INI,1))\r
-      IF (HSURF=='WS_ROOF') PFIELD = XWS_ROOF_DEF\r
-      IF (HSURF=='WS_ROAD') PFIELD = XWS_ROAD_DEF\r
-\r
-   !* other fields\r
-    CASE DEFAULT\r
-      ALLOCATE(PFIELD(INI,1))\r
-      PFIELD = 0.\r
-\r
-    END SELECT\r
-\r
-  END IF\r
-!-------------------------------------------------------------------------------------\r
-END IF\r
-!-------------------------------------------------------------------------------------\r
-!\r
-!*      6.     End of IO\r
-!              ---------\r
-!\r
-IF (LHOOK) CALL DR_HOOK('PREP_TEB_EXTERN',1,ZHOOK_HANDLE)\r
-!\r
-!---------------------------------------------------------------------------------------\r
-!\r
-END SUBROUTINE PREP_TEB_EXTERN\r
+!SURFEX_LIC Copyright 1994-2014 Meteo-France 
+!SURFEX_LIC This is part of the SURFEX software governed by the CeCILL-C  licence
+!SURFEX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
+!SURFEX_LIC for details. version 1.
+!!
+!!    MODIFICATIONS
+!!    -------------
+!!      M.Moge    01/2016  using READ_SURF_FIELD2D/3D for 2D/3D surfex fields reads
+!     #########
+SUBROUTINE PREP_TEB_EXTERN(HPROGRAM,HSURF,HFILE,HFILETYPE,HFILEPGD,HFILEPGDTYPE,KLUOUT,PFIELD)
+!     #################################################################################
+!
+USE MODD_TYPE_DATE_SURF
+!
+USE MODI_PREP_GRID_EXTERN
+USE MODI_READ_SURF
+USE MODI_GET_TEB_DEPTHS
+USE MODI_INTERP_GRID
+USE MODI_OPEN_AUX_IO_SURF
+USE MODI_CLOSE_AUX_IO_SURF
+USE MODI_TOWN_PRESENCE
+USE MODI_READ_TEB_PATCH
+USE MODI_GET_CURRENT_TEB_PATCH
+USE MODI_READ_SURF_FIELD2D
+!
+USE MODD_PREP,       ONLY : CINGRID_TYPE, CINTERP_TYPE
+USE MODD_PREP_TEB,   ONLY : XGRID_ROAD, XGRID_WALL, XGRID_ROOF, &
+                            XGRID_FLOOR, XWS_ROOF, XWS_ROAD, &
+                            XTI_BLD_DEF, XWS_ROOF_DEF, XWS_ROAD_DEF, XHUI_BLD_DEF
+USE MODD_DATA_COVER_PAR, ONLY : JPCOVER
+USE MODD_SURF_PAR, ONLY: XUNDEF
+!
+USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
+USE PARKIND1  ,ONLY : JPRB
+!
+IMPLICIT NONE
+!
+!*      0.1    declarations of arguments
+!
+ CHARACTER(LEN=6),   INTENT(IN)  :: HPROGRAM  ! program calling surf. schemes
+ CHARACTER(LEN=7),   INTENT(IN)  :: HSURF     ! type of field
+ CHARACTER(LEN=28),  INTENT(IN)  :: HFILE     ! name of file
+ CHARACTER(LEN=6),   INTENT(IN)  :: HFILETYPE ! type of input file
+ CHARACTER(LEN=28),  INTENT(IN)  :: HFILEPGD     ! name of file
+ CHARACTER(LEN=6),   INTENT(IN)  :: HFILEPGDTYPE ! type of input file
+INTEGER,            INTENT(IN)  :: KLUOUT    ! logical unit of output listing
+REAL,DIMENSION(:,:), POINTER    :: PFIELD    ! field to interpolate horizontally
+!
+!*      0.2    declarations of local variables
+!
+REAL, DIMENSION(:,:), ALLOCATABLE :: ZFIELD         ! field read
+REAL, DIMENSION(:,:), ALLOCATABLE :: ZDEPTH         ! depth of each layer
+REAL, DIMENSION(:),   ALLOCATABLE :: ZDEPTH_TOT     ! total depth of surface
+!
+REAL, DIMENSION(:,:),   ALLOCATABLE :: ZD  ! intermediate array
+!
+ CHARACTER(LEN=12) :: YRECFM         ! Name of the article to be read
+INTEGER           :: IRESP          ! reading return code
+INTEGER           :: ILAYER         ! number of layers
+INTEGER           :: JLAYER         ! loop counter
+INTEGER           :: IVERSION       ! SURFEX version
+INTEGER           :: IBUGFIX        ! SURFEX bug version
+LOGICAL           :: GOLD_NAME      ! old name flag for temperatures
+ CHARACTER(LEN=4)  :: YWALL_OPT      ! option of walls
+ CHARACTER(LEN=6)  :: YSURF          ! Surface type
+ CHARACTER(LEN=3)  :: YBEM ! key of the building energy model DEF for DEFault (Masson et al. 2002) ,
+                          ! BEM for Building Energy Model (Bueno et al. 2012)
+!
+INTEGER           :: INI            ! total 1D dimension
+!
+LOGICAL                              :: GTEB      ! flag if TEB fields are present
+INTEGER                              :: IPATCH    ! number of soil temperature patches
+INTEGER                              :: ITEB_PATCH! number of TEB patches in file
+INTEGER                              :: ICURRENT_PATCH! current TEB patch to be initialized
+ CHARACTER(LEN=3)                     :: YPATCH    ! indentificator for TEB patch
+REAL(KIND=JPRB) :: ZHOOK_HANDLE
+!-------------------------------------------------------------------------------------
+!
+!*      1.     Preparation of IO for reading in the file
+!              -----------------------------------------
+!
+!* Note that all points are read, even those without physical meaning.
+!  These points will not be used during the horizontal interpolation step.
+!  Their value must be defined as XUNDEF.
+!
+IF (LHOOK) CALL DR_HOOK('PREP_TEB_EXTERN',0,ZHOOK_HANDLE)
+!
+ CALL OPEN_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE,'TOWN  ')
+!
+!* reading of version of the file being read
+ CALL READ_SURF(HFILEPGDTYPE,'VERSION',IVERSION,IRESP)
+ CALL READ_SURF(HFILEPGDTYPE,'BUG',IBUGFIX,IRESP)
+GOLD_NAME=(IVERSION<7 .OR. (IVERSION==7 .AND. IBUGFIX<3))
+!
+IF (.NOT.GOLD_NAME) THEN
+   YRECFM='BEM'
+   CALL READ_SURF(HFILEPGDTYPE,YRECFM,YBEM,IRESP)
+ELSE
+   YBEM='DEF'
+ENDIF
+!-------------------------------------------------------------------------------------
+!
+!*      2.     Reading of grid
+!              ---------------
+!
+!* reads the grid
+ CALL PREP_GRID_EXTERN(HFILEPGDTYPE,KLUOUT,CINGRID_TYPE,CINTERP_TYPE,INI)
+!
+!
+!* reads if TEB fields exist in the input file
+ CALL TOWN_PRESENCE(HFILEPGDTYPE,GTEB)
+!
+!---------------------------------------------------------------------------------------
+!
+!*     3.      Orography
+!              ---------
+!
+IF (HSURF=='ZS     ') THEN
+  !
+  ALLOCATE(PFIELD(INI,1))
+  YRECFM='ZS'
+  CALL READ_SURF(HFILEPGDTYPE,YRECFM,PFIELD(:,1),IRESP,HDIR='A')
+  CALL CLOSE_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE)
+  !
+  !---------------------------------------------------------------------------------------
+ELSE
+!---------------------------------------------------------------------------------------
+!
+!*     4.     TEB fields are read
+!             -------------------
+!
+  IF (GTEB) THEN
+!
+    CALL READ_TEB_PATCH(HFILEPGDTYPE,ITEB_PATCH)
+    CALL GET_CURRENT_TEB_PATCH(ICURRENT_PATCH)
+    YPATCH='   '
+    IF (ITEB_PATCH>1) THEN
+      WRITE(YPATCH,FMT='(A,I1,A)') 'T',MIN(ICURRENT_PATCH,ITEB_PATCH),'_'
+    END IF
+!---------------------------------------------------------------------------------------
+    SELECT CASE(HSURF)
+!---------------------------------------------------------------------------------------
+!
+!*     4.1    Profile of temperatures in roads, roofs or walls
+!             ------------------------------------------------
+!
+    CASE('T_ROAD','T_ROOF','T_WALLA','T_WALLB','T_FLOOR','T_MASS')
+      YSURF=HSURF(1:6)
+      !* reading of number of layers
+      IF (YSURF=='T_ROAD') YRECFM='ROAD_LAYER'
+      IF (YSURF=='T_ROOF') YRECFM='ROOF_LAYER'
+      IF (YSURF=='T_WALL') YRECFM='WALL_LAYER'
+      IF (YSURF=='T_FLOO' .OR. YSURF=='T_MASS') THEN 
+        IF (YBEM=='DEF') THEN
+          YRECFM='ROAD_LAYER'
+        ELSE
+          YRECFM='FLOOR_LAYER'
+        END IF
+      END IF
+      CALL READ_SURF(HFILEPGDTYPE,YRECFM,ILAYER,IRESP)
+      !
+      ALLOCATE(ZD(INI,ILAYER))
+      IF (YSURF=='T_ROAD') CALL GET_TEB_DEPTHS(HFILEPGDTYPE,PD_ROAD=ZD)
+      IF (YSURF=='T_ROOF') CALL GET_TEB_DEPTHS(HFILEPGDTYPE,PD_ROOF=ZD)
+      IF (YSURF=='T_WALL') CALL GET_TEB_DEPTHS(HFILEPGDTYPE,PD_WALL=ZD)
+      IF (YSURF=='T_MASS') CALL GET_TEB_DEPTHS(HFILEPGDTYPE,PD_FLOOR=ZD)
+      IF (YSURF=='T_FLOO') CALL GET_TEB_DEPTHS(HFILEPGDTYPE,PD_FLOOR=ZD)
+      !
+      CALL CLOSE_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE)
+      CALL OPEN_AUX_IO_SURF(HFILE,HFILETYPE,'TOWN  ')
+      !
+      !* reading option for road orientation
+      YWALL_OPT = 'UNIF'
+      IF (YSURF =='T_WALL' .AND. .NOT. GOLD_NAME) THEN
+        CALL READ_SURF(HFILETYPE,'WALL_OPT',YWALL_OPT,IRESP)
+      END IF
+      !
+      !* reading of the profile
+      ALLOCATE(ZFIELD(INI,ILAYER))
+      DO JLAYER=1,ILAYER
+        IF (GOLD_NAME) THEN
+          WRITE(YRECFM,'(A6,I1.1)') HSURF(1:6),JLAYER
+        ELSE
+          WRITE(YRECFM,'(A1,A4,I1.1)') HSURF(1:1),HSURF(3:6),JLAYER
+          IF (YSURF =='T_WALL' .AND. YWALL_OPT/='UNIF') &
+            WRITE(YRECFM,'(A1,A5,I1.1)') HSURF(1:1),HSURF(3:7),JLAYER
+          IF ((HSURF=='T_FLOOR' .OR. HSURF=='T_MASS') .AND. YBEM=='DEF') THEN
+            IF (HSURF=='T_FLOOR' .AND. JLAYER>1) THEN 
+              WRITE(YRECFM,'(A5,I1.1)') 'TROAD',JLAYER
+            ELSE
+              WRITE(YRECFM,'(A6)') 'TI_BLD'
+            ENDIF
+          END IF
+        END IF
+        YRECFM=YPATCH//YRECFM
+        YRECFM=ADJUSTL(YRECFM)
+        CALL READ_SURF(HFILETYPE,YRECFM,ZFIELD(:,JLAYER),IRESP,HDIR='A')
+      END DO
+      CALL CLOSE_AUX_IO_SURF(HFILE,HFILETYPE)
+      !
+      !* recovers middle layer depth (from the surface)
+      ALLOCATE(ZDEPTH    (INI,ILAYER))
+      ALLOCATE(ZDEPTH_TOT(INI))
+      ZDEPTH    (:,1)=ZD(:,1)/2.
+      ZDEPTH_TOT(:)  =ZD(:,1)
+      DO JLAYER=2,ILAYER
+        ZDEPTH    (:,JLAYER) = ZDEPTH_TOT(:) + ZD(:,JLAYER)/2.
+        ZDEPTH_TOT(:) = ZDEPTH_TOT(:) + ZD(:,JLAYER)
+      END DO
+      !
+      !* in case of wall or roof, normalizes by total wall or roof thickness
+      IF (YSURF=='T_ROOF' .OR. YSURF=='T_WALL' .OR. HSURF == 'T_FLOOR' .OR. HSURF == 'T_MASS') THEN
+        DO JLAYER=1,ILAYER
+          ZDEPTH(:,JLAYER) = ZDEPTH(:,JLAYER) / ZDEPTH_TOT(:)
+        END DO
+      END IF
+      !
+      !* interpolation on the fine vertical grid
+      IF (YSURF=='T_ROAD') THEN
+        ALLOCATE(PFIELD(SIZE(ZFIELD,1),SIZE(XGRID_ROAD)))
+        CALL INTERP_GRID(ZDEPTH,ZFIELD,XGRID_ROAD,PFIELD)
+      ELSEIF (YSURF=='T_ROOF') THEN
+        ALLOCATE(PFIELD(SIZE(ZFIELD,1),SIZE(XGRID_ROOF)))
+        CALL INTERP_GRID(ZDEPTH,ZFIELD,XGRID_ROOF,PFIELD)
+      ELSEIF (YSURF=='T_WALL') THEN
+        ALLOCATE(PFIELD(SIZE(ZFIELD,1),SIZE(XGRID_WALL)))
+        CALL INTERP_GRID(ZDEPTH,ZFIELD,XGRID_WALL,PFIELD)
+      ELSEIF (YSURF=='T_FLOO' .OR. YSURF=='T_MASS') THEN
+        ALLOCATE(PFIELD(SIZE(ZFIELD,1),SIZE(XGRID_FLOOR)))
+        CALL INTERP_GRID(ZDEPTH,ZFIELD,XGRID_FLOOR,PFIELD)
+      END IF
+      !
+      !* end
+      DEALLOCATE(ZD)
+      DEALLOCATE(ZFIELD)
+      DEALLOCATE(ZDEPTH)
+      DEALLOCATE(ZDEPTH_TOT)
+!---------------------------------------------------------------------------------------
+!
+!*      4.2    Internal moisture
+!              ---------------
+!
+    CASE('QI_BLD ')
+      ALLOCATE(PFIELD(INI,1))
+      IF (YBEM=='BEM') THEN
+        YRECFM='QI_BLD'
+        YRECFM=YPATCH//YRECFM
+        YRECFM=ADJUSTL(YRECFM)
+        CALL CLOSE_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE)
+        CALL OPEN_AUX_IO_SURF(HFILE,HFILETYPE,'TOWN  ')
+        CALL READ_SURF(HFILETYPE,YRECFM,PFIELD(:,1),IRESP,HDIR='A')
+        CALL CLOSE_AUX_IO_SURF(HFILE,HFILETYPE)
+      ELSE
+        PFIELD(:,1) = XUNDEF
+      ENDIF
+!
+!---------------------------------------------------------------------------------------
+!
+!*      4.2    Other variables
+!              ---------------
+!
+    CASE DEFAULT
+      ALLOCATE(PFIELD(INI,1))
+      YRECFM=HSURF
+      IF (HSURF=='T_CAN  ') THEN
+        YRECFM='TCANYON'
+        IF (GOLD_NAME) YRECFM='T_CANYON'
+      ELSEIF (HSURF=='Q_CAN  ') THEN
+        YRECFM='QCANYON'
+        IF (GOLD_NAME) YRECFM='Q_CANYON'
+      ELSEIF (HSURF=='T_WIN2 ' .OR. HSURF=='T_WIN1') THEN
+        IF (YBEM=='BEM') THEN
+          YRECFM=HSURF
+        ELSE
+          YRECFM='TI_BLD'
+        ENDIF
+      ENDIF
+      YRECFM=YPATCH//YRECFM
+      YRECFM=ADJUSTL(YRECFM)
+      CALL CLOSE_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE)
+      CALL OPEN_AUX_IO_SURF(HFILE,HFILETYPE,'TOWN  ')
+      CALL READ_SURF(HFILETYPE,YRECFM,PFIELD(:,1),IRESP,HDIR='A')
+      CALL CLOSE_AUX_IO_SURF(HFILE,HFILETYPE)
+!
+!---------------------------------------------------------------------------------------
+    END SELECT
+!---------------------------------------------------------------------------------------
+!
+!*     5.     Subtitutes if TEB fields do not exist
+!             -------------------------------------
+!
+  ELSE
+
+    CALL CLOSE_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE)
+
+    SELECT CASE(HSURF)
+
+    !* temperature profiles
+    CASE('T_ROAD','T_ROOF','T_WALL','T_WIN1','T_FLOOR','T_CAN','TI_ROAD')
+      YSURF=HSURF(1:6)
+      !* reading of the soil surface temperature
+      CALL OPEN_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE,'NATURE')
+      CALL READ_SURF(HFILEPGDTYPE,'PATCH_NUMBER',IPATCH,IRESP)
+      CALL CLOSE_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE)
+      ALLOCATE(ZFIELD(INI,IPATCH))
+      CALL OPEN_AUX_IO_SURF(HFILE,HFILETYPE,'NATURE')
+      IF (YSURF=='T_FLOO' .OR. YSURF=='T_CAN ' .OR. YSURF=='TI_ROA') THEN
+        YRECFM='TG2'
+        CALL READ_SURF_FIELD2D(HFILETYPE,ZFIELD(:,:),YRECFM,HDIR='A')
+      ELSE
+        YRECFM='TG1'
+        CALL READ_SURF_FIELD2D(HFILETYPE,ZFIELD(:,:),YRECFM,HDIR='A')
+      ENDIF
+      CALL CLOSE_AUX_IO_SURF(HFILE,HFILETYPE)
+      !* fills the whole temperature profile by this soil temperature
+      IF (YSURF=='T_ROAD') ILAYER=SIZE(XGRID_ROAD)
+      IF (YSURF=='T_ROOF') ILAYER=SIZE(XGRID_ROOF)
+      IF (YSURF=='T_WALL') ILAYER=SIZE(XGRID_WALL)
+      IF (YSURF=='T_FLOO') ILAYER=SIZE(XGRID_FLOOR)
+      IF (YSURF=='T_WIN1' .OR. YSURF=='T_CAN ' .OR. YSURF=='TI_ROA') ILAYER=1
+      ALLOCATE(PFIELD(INI,ILAYER))
+      IF (YSURF=='T_FLOO') THEN
+        !* sets the temperature equal to this deep soil temperature
+        PFIELD(:,1) = XTI_BLD_DEF
+      ELSE
+        PFIELD(:,1) = ZFIELD(:,1)
+      ENDIF
+      DO JLAYER=2,ILAYER
+        PFIELD(:,JLAYER) = ZFIELD(:,1)
+      END DO
+      DEALLOCATE(ZFIELD)
+
+    CASE('T_MASS','TI_BLD','T_WIN2')
+      YSURF=HSURF(1:6)
+      IF (YSURF=='T_MASS') ILAYER = SIZE(XGRID_FLOOR)
+      IF (YSURF=='TI_BLD'.OR.YSURF=='T_WIN2') ILAYER=1
+      ALLOCATE(PFIELD(INI, ILAYER))
+      PFIELD(:,:) = XTI_BLD_DEF
+    !* building moisture
+    CASE('QI_BLD ')
+      ALLOCATE(PFIELD(INI,1))
+      PFIELD(:,1) = XUNDEF
+
+    !* water reservoirs
+    CASE('WS_ROOF','WS_ROAD')
+      ALLOCATE(PFIELD(INI,1))
+      IF (HSURF=='WS_ROOF') PFIELD = XWS_ROOF_DEF
+      IF (HSURF=='WS_ROAD') PFIELD = XWS_ROAD_DEF
+
+   !* other fields
+    CASE DEFAULT
+      ALLOCATE(PFIELD(INI,1))
+      PFIELD = 0.
+
+    END SELECT
+
+  END IF
+!-------------------------------------------------------------------------------------
+END IF
+!-------------------------------------------------------------------------------------
+!
+!*      6.     End of IO
+!              ---------
+!
+IF (LHOOK) CALL DR_HOOK('PREP_TEB_EXTERN',1,ZHOOK_HANDLE)
+!
+!---------------------------------------------------------------------------------------
+!
+END SUBROUTINE PREP_TEB_EXTERN
index 3b1bc61..1ef7052 100644 (file)
-!SURFEX_LIC Copyright 1994-2014 Meteo-France \r
-!SURFEX_LIC This is part of the SURFEX software governed by the CeCILL-C  licence\r
-!SURFEX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt\r
-!SURFEX_LIC for details. version 1.\r
-!     #########\r
-SUBROUTINE PREP_TEB_GARDEN_EXTERN(HPROGRAM,HSURF,HFILE,HFILETYPE,HFILEPGD,HFILEPGDTYPE,KLUOUT,PFIELD)\r
-!     #################################################################################\r
-!\r
-!!****  *PREP_TEB_GARDEN_EXTERN* - initializes ISBA fields from operational GRIB\r
-!!\r
-!!    PURPOSE\r
-!!    -------\r
-!\r
-!!**  METHOD\r
-!!    ------\r
-!!\r
-!!    REFERENCE\r
-!!    ---------\r
-!!      \r
-!!\r
-!!    AUTHOR\r
-!!    ------\r
-!!     V. Masson \r
-!!\r
-!!    MODIFICATIONS\r
-!!    -------------\r
-!!      Original    01/2004\r
-!!      M.Moge    01/2016  using READ_SURF_FIELD2D/3D for 2D/3D surfex fields reads\r
-!!------------------------------------------------------------------\r
-!\r
-\r
-!\r
-USE MODE_READ_EXTERN\r
-!\r
-USE MODD_TYPE_DATE_SURF\r
-!\r
-USE MODI_PREP_GRID_EXTERN\r
-USE MODI_READ_SURF\r
-USE MODI_INTERP_GRID\r
-USE MODI_OPEN_AUX_IO_SURF\r
-USE MODI_CLOSE_AUX_IO_SURF\r
-USE MODI_READ_TEB_PATCH\r
-USE MODI_GET_CURRENT_TEB_PATCH\r
-USE MODI_TOWN_PRESENCE\r
-!\r
-USE MODD_PREP,           ONLY : CINGRID_TYPE, CINTERP_TYPE\r
-USE MODD_PREP_TEB_GARDEN,ONLY : XGRID_SOIL, XWR_DEF\r
-USE MODD_DATA_COVER_PAR, ONLY : NVEGTYPE\r
-USE MODD_SURF_PAR,       ONLY : XUNDEF\r
-!\r
-USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK\r
-USE PARKIND1  ,ONLY : JPRB\r
-!\r
-USE MODI_PUT_ON_ALL_VEGTYPES\r
-!\r
-USE MODI_READ_SURF_FIELD2D\r
-!\r
-IMPLICIT NONE\r
-!\r
-!*      0.1    declarations of arguments\r
-!\r
- CHARACTER(LEN=6),   INTENT(IN)  :: HPROGRAM  ! program calling surf. schemes\r
- CHARACTER(LEN=7),   INTENT(IN)  :: HSURF     ! type of field\r
- CHARACTER(LEN=28),  INTENT(IN)  :: HFILE     ! name of file\r
- CHARACTER(LEN=6),   INTENT(IN)  :: HFILETYPE ! type of input file\r
- CHARACTER(LEN=28),  INTENT(IN)  :: HFILEPGD     ! name of file\r
- CHARACTER(LEN=6),   INTENT(IN)  :: HFILEPGDTYPE ! type of input file\r
-INTEGER,            INTENT(IN)  :: KLUOUT    ! logical unit of output listing\r
-REAL,DIMENSION(:,:,:), POINTER  :: PFIELD    ! field to interpolate horizontally (on final soil grid)\r
-!\r
-!*      0.2    declarations of local variables\r
-!\r
- CHARACTER(LEN=12) :: YRECFM        ! Name of the article to be read\r
-INTEGER           :: IRESP          ! reading return code\r
-INTEGER           :: INI            ! total 1D dimension\r
-INTEGER           :: IPATCH         ! number of patch\r
-!\r
-REAL, DIMENSION(:,:,:), POINTER     :: ZFIELD         ! field read on initial MNH vertical soil grid, all patches\r
-REAL, DIMENSION(:,:),   POINTER     :: ZFIELD1        ! field read on initial MNH vertical soil grid, one patch\r
-REAL, DIMENSION(:,:,:), POINTER     :: ZD             ! depth of field in the soil\r
-REAL, DIMENSION(:,:), POINTER       :: ZD1            ! depth of field in the soil, one patch\r
-REAL, DIMENSION(:,:), ALLOCATABLE   :: ZOUT           !\r
-INTEGER                             :: JPATCH         ! loop counter for patch\r
-INTEGER                             :: ITEB_PATCH     ! number of TEB patches in file\r
-INTEGER                             :: ICURRENT_PATCH ! current TEB patch to be initialized\r
-INTEGER                             :: IVERSION       ! SURFEX version\r
-INTEGER                             :: IBUGFIX        ! SURFEX bug version\r
-LOGICAL                             :: GOLD_NAME      ! old name flag for temperatures\r
- CHARACTER(LEN=12)                   :: YSURF     ! type of field\r
- CHARACTER(LEN=3)                    :: YPATCH    ! indentificator for TEB patch\r
- CHARACTER(LEN=4)                    :: YPATCH2   ! number of the patch\r
-LOGICAL                         :: GTEB      ! flag if TEB fields are present\r
-LOGICAL                         :: GGARDEN   ! T if gardens are present in the file\r
-REAL(KIND=JPRB) :: ZHOOK_HANDLE\r
-!\r
-!------------------------------------------------------------------------------\r
-!\r
-!*      1.     Preparation of IO for reading in the file\r
-!              -----------------------------------------\r
-!\r
-!* Note that all points are read, even those without physical meaning.\r
-!  These points will not be used during the horizontal interpolation step.\r
-!  Their value must be defined as XUNDEF.\r
-!\r
-IF (LHOOK) CALL DR_HOOK('PREP_TEB_GARDEN_EXTERN',0,ZHOOK_HANDLE)\r
-!\r
-!------------------------------------------------------------------------------\r
-!\r
-!*      2.     Reading of grid\r
-!              ---------------\r
-!\r
- CALL OPEN_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE,'TOWN  ')\r
-!\r
-!* reading of version of the file being read\r
- CALL READ_SURF(HFILEPGDTYPE,'VERSION',IVERSION,IRESP)\r
- CALL READ_SURF(HFILEPGDTYPE,'BUG',IBUGFIX,IRESP)\r
-GOLD_NAME=(IVERSION<7 .OR. (IVERSION==7 .AND. IBUGFIX<3))\r
-!\r
- CALL PREP_GRID_EXTERN(HFILEPGDTYPE,KLUOUT,CINGRID_TYPE,CINTERP_TYPE,INI)\r
-!\r
-!* reads if TEB fields exist in the input file\r
- CALL TOWN_PRESENCE(HFILEPGDTYPE,GTEB)\r
-!\r
-IF (GTEB) THEN\r
-  CALL READ_TEB_PATCH(HFILEPGDTYPE,ITEB_PATCH)\r
-  CALL GET_CURRENT_TEB_PATCH(ICURRENT_PATCH)\r
-  YPATCH='   '\r
-  IF (ITEB_PATCH>1) THEN\r
-    WRITE(YPATCH,FMT='(A,I1,A)') 'T',MIN(ICURRENT_PATCH,ITEB_PATCH),'_'\r
-  END IF\r
-END IF\r
-!\r
-!---------------------------------------------------------------------------------------\r
-!\r
-!*      3.     Transformation into physical quantity to be interpolated\r
-!              --------------------------------------------------------\r
-!\r
-SELECT CASE(HSURF)\r
-!\r
-!*     3.      Orography\r
-!              ---------\r
-!\r
-  CASE('ZS     ')\r
-    ALLOCATE(PFIELD(INI,1,1))\r
-    YRECFM='ZS'\r
-    CALL READ_SURF(HFILEPGDTYPE,YRECFM,PFIELD(:,1,1),IRESP,HDIR='A')\r
-    CALL CLOSE_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE)\r
-!\r
-!--------------------------------------------------------------------------\r
-!\r
-!\r
-!*      3.1    Profile of temperature, water or ice in the soil\r
-!\r
-  CASE('TG    ','WG    ','WGI   ')\r
-!* choice if one reads garden fields (if present) or ISBA fields\r
-    GGARDEN = .FALSE.\r
-    IF (GTEB) CALL READ_SURF(HFILEPGDTYPE,'GARDEN',GGARDEN,IRESP)\r
-    CALL CLOSE_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE)\r
-    IF (GGARDEN) THEN\r
-      YSURF = 'GD_'//HSURF(1:3)\r
-      IF (GOLD_NAME) YSURF = 'TWN_'//HSURF(1:3)\r
-      YSURF = YPATCH//YSURF\r
-    ELSE\r
-      YSURF = HSURF\r
-    END IF\r
-    YSURF=ADJUSTL(YSURF)  \r
-!* reading of the profile and its depth definition\r
-     CALL READ_EXTERN_ISBA(HFILE,HFILETYPE,HFILEPGD,HFILEPGDTYPE,KLUOUT,INI,&\r
-                HSURF,YSURF,ZFIELD,ZD)\r
-! \r
-     ALLOCATE(ZFIELD1(SIZE(ZFIELD,1),SIZE(ZFIELD,2)))\r
-     ALLOCATE(ZD1(SIZE(ZFIELD,1),SIZE(ZFIELD,2)))\r
-     ALLOCATE(ZOUT(SIZE(ZFIELD,1),SIZE(XGRID_SOIL)))\r
-     ALLOCATE(PFIELD(SIZE(ZFIELD,1),SIZE(XGRID_SOIL),SIZE(ZFIELD,3)))\r
-!\r
-     DO JPATCH=1,SIZE(ZFIELD,3)\r
-        ZFIELD1(:,:)=ZFIELD(:,:,JPATCH)\r
-        ZD1(:,:)=ZD(:,:,JPATCH)\r
-        CALL INTERP_GRID(ZD1,ZFIELD1,XGRID_SOIL,ZOUT)\r
-        PFIELD(:,:,JPATCH)=ZOUT(:,:)\r
-     END DO\r
-!\r
-     DEALLOCATE(ZFIELD)\r
-     DEALLOCATE(ZOUT)\r
-     DEALLOCATE(ZFIELD1)\r
-     DEALLOCATE(ZD)\r
-!\r
-!--------------------------------------------------------------------------\r
-!\r
-!*      3.4    Water content intercepted on leaves, LAI\r
-!\r
-  CASE('WR     ')\r
-     ALLOCATE(PFIELD(INI,1,NVEGTYPE))\r
-     !* choice if one reads garden fields (if present) or ISBA fields    \r
-     GGARDEN = .FALSE.\r
-     IF (GTEB) CALL READ_SURF(HFILEPGDTYPE,'GARDEN',GGARDEN,IRESP)\r
-     CALL CLOSE_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE)\r
-     IF (GGARDEN) THEN\r
-       IPATCH = 1    \r
-       YRECFM = 'GD_WR'\r
-       IF (GOLD_NAME) YRECFM = 'TWN_WR'\r
-       YRECFM = YPATCH//YRECFM\r
-       CALL OPEN_AUX_IO_SURF(HFILE,HFILETYPE,'TOWN  ')\r
-     ELSE            \r
-       YRECFM = 'PATCH_NUMBER'\r
-       CALL OPEN_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE,'NATURE')\r
-       CALL READ_SURF(HFILEPGDTYPE,YRECFM,IPATCH,IRESP)\r
-       CALL CLOSE_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE)\r
-       CALL OPEN_AUX_IO_SURF(HFILE,HFILETYPE,'NATURE')\r
-       YRECFM = 'WR'\r
-     END IF\r
-     YRECFM=ADJUSTL(YRECFM)\r
-     \r
-     ALLOCATE(ZFIELD(INI,1,IPATCH))\r
-     CALL READ_SURF_FIELD2D(HFILETYPE,ZFIELD(:,1,:),YRECFM,HDIR='A')\r
-     CALL CLOSE_AUX_IO_SURF(HFILE,HFILETYPE)\r
-     CALL PUT_ON_ALL_VEGTYPES(INI,1,1,NVEGTYPE,ZFIELD,PFIELD)\r
-     DEALLOCATE(ZFIELD)\r
-!\r
-  CASE('LAI    ')\r
-     CALL CLOSE_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE)\r
-     ALLOCATE(PFIELD(INI,1,NVEGTYPE))\r
-     PFIELD(:,:,:) = XUNDEF\r
-!\r
-END SELECT\r
-!\r
-!\r
-!---------------------------------------------------------------------------\r
-!\r
-!*      6.     End of IO\r
-!              ---------\r
-!\r
-IF (LHOOK) CALL DR_HOOK('PREP_TEB_GARDEN_EXTERN',1,ZHOOK_HANDLE)\r
-!\r
-!---------------------------------------------------------------------------\r
-!---------------------------------------------------------------------------\r
-END SUBROUTINE PREP_TEB_GARDEN_EXTERN\r
+!SURFEX_LIC Copyright 1994-2014 Meteo-France 
+!SURFEX_LIC This is part of the SURFEX software governed by the CeCILL-C  licence
+!SURFEX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
+!SURFEX_LIC for details. version 1.
+!     #########
+SUBROUTINE PREP_TEB_GARDEN_EXTERN(HPROGRAM,HSURF,HFILE,HFILETYPE,HFILEPGD,HFILEPGDTYPE,KLUOUT,PFIELD)
+!     #################################################################################
+!
+!!****  *PREP_TEB_GARDEN_EXTERN* - initializes ISBA fields from operational GRIB
+!!
+!!    PURPOSE
+!!    -------
+!
+!!**  METHOD
+!!    ------
+!!
+!!    REFERENCE
+!!    ---------
+!!      
+!!
+!!    AUTHOR
+!!    ------
+!!     V. Masson 
+!!
+!!    MODIFICATIONS
+!!    -------------
+!!      Original    01/2004
+!!      M.Moge    01/2016  using READ_SURF_FIELD2D/3D for 2D/3D surfex fields reads
+!!------------------------------------------------------------------
+!
+
+!
+USE MODE_READ_EXTERN
+!
+USE MODD_TYPE_DATE_SURF
+!
+USE MODI_PREP_GRID_EXTERN
+USE MODI_READ_SURF
+USE MODI_INTERP_GRID
+USE MODI_OPEN_AUX_IO_SURF
+USE MODI_CLOSE_AUX_IO_SURF
+USE MODI_READ_TEB_PATCH
+USE MODI_GET_CURRENT_TEB_PATCH
+USE MODI_TOWN_PRESENCE
+!
+USE MODD_PREP,           ONLY : CINGRID_TYPE, CINTERP_TYPE
+USE MODD_PREP_TEB_GARDEN,ONLY : XGRID_SOIL, XWR_DEF
+USE MODD_DATA_COVER_PAR, ONLY : NVEGTYPE
+USE MODD_SURF_PAR,       ONLY : XUNDEF
+!
+USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
+USE PARKIND1  ,ONLY : JPRB
+!
+USE MODI_PUT_ON_ALL_VEGTYPES
+!
+USE MODI_READ_SURF_FIELD2D
+!
+IMPLICIT NONE
+!
+!*      0.1    declarations of arguments
+!
+ CHARACTER(LEN=6),   INTENT(IN)  :: HPROGRAM  ! program calling surf. schemes
+ CHARACTER(LEN=7),   INTENT(IN)  :: HSURF     ! type of field
+ CHARACTER(LEN=28),  INTENT(IN)  :: HFILE     ! name of file
+ CHARACTER(LEN=6),   INTENT(IN)  :: HFILETYPE ! type of input file
+ CHARACTER(LEN=28),  INTENT(IN)  :: HFILEPGD     ! name of file
+ CHARACTER(LEN=6),   INTENT(IN)  :: HFILEPGDTYPE ! type of input file
+INTEGER,            INTENT(IN)  :: KLUOUT    ! logical unit of output listing
+REAL,DIMENSION(:,:,:), POINTER  :: PFIELD    ! field to interpolate horizontally (on final soil grid)
+!
+!*      0.2    declarations of local variables
+!
+ CHARACTER(LEN=12) :: YRECFM        ! Name of the article to be read
+INTEGER           :: IRESP          ! reading return code
+INTEGER           :: INI            ! total 1D dimension
+INTEGER           :: IPATCH         ! number of patch
+!
+REAL, DIMENSION(:,:,:), POINTER     :: ZFIELD         ! field read on initial MNH vertical soil grid, all patches
+REAL, DIMENSION(:,:),   POINTER     :: ZFIELD1        ! field read on initial MNH vertical soil grid, one patch
+REAL, DIMENSION(:,:,:), POINTER     :: ZD             ! depth of field in the soil
+REAL, DIMENSION(:,:), POINTER       :: ZD1            ! depth of field in the soil, one patch
+REAL, DIMENSION(:,:), ALLOCATABLE   :: ZOUT           !
+INTEGER                             :: JPATCH         ! loop counter for patch
+INTEGER                             :: ITEB_PATCH     ! number of TEB patches in file
+INTEGER                             :: ICURRENT_PATCH ! current TEB patch to be initialized
+INTEGER                             :: IVERSION       ! SURFEX version
+INTEGER                             :: IBUGFIX        ! SURFEX bug version
+LOGICAL                             :: GOLD_NAME      ! old name flag for temperatures
+ CHARACTER(LEN=12)                   :: YSURF     ! type of field
+ CHARACTER(LEN=3)                    :: YPATCH    ! indentificator for TEB patch
+ CHARACTER(LEN=4)                    :: YPATCH2   ! number of the patch
+LOGICAL                         :: GTEB      ! flag if TEB fields are present
+LOGICAL                         :: GGARDEN   ! T if gardens are present in the file
+REAL(KIND=JPRB) :: ZHOOK_HANDLE
+!
+!------------------------------------------------------------------------------
+!
+!*      1.     Preparation of IO for reading in the file
+!              -----------------------------------------
+!
+!* Note that all points are read, even those without physical meaning.
+!  These points will not be used during the horizontal interpolation step.
+!  Their value must be defined as XUNDEF.
+!
+IF (LHOOK) CALL DR_HOOK('PREP_TEB_GARDEN_EXTERN',0,ZHOOK_HANDLE)
+!
+!------------------------------------------------------------------------------
+!
+!*      2.     Reading of grid
+!              ---------------
+!
+ CALL OPEN_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE,'TOWN  ')
+!
+!* reading of version of the file being read
+ CALL READ_SURF(HFILEPGDTYPE,'VERSION',IVERSION,IRESP)
+ CALL READ_SURF(HFILEPGDTYPE,'BUG',IBUGFIX,IRESP)
+GOLD_NAME=(IVERSION<7 .OR. (IVERSION==7 .AND. IBUGFIX<3))
+!
+ CALL PREP_GRID_EXTERN(HFILEPGDTYPE,KLUOUT,CINGRID_TYPE,CINTERP_TYPE,INI)
+!
+!* reads if TEB fields exist in the input file
+ CALL TOWN_PRESENCE(HFILEPGDTYPE,GTEB)
+!
+IF (GTEB) THEN
+  CALL READ_TEB_PATCH(HFILEPGDTYPE,ITEB_PATCH)
+  CALL GET_CURRENT_TEB_PATCH(ICURRENT_PATCH)
+  YPATCH='   '
+  IF (ITEB_PATCH>1) THEN
+    WRITE(YPATCH,FMT='(A,I1,A)') 'T',MIN(ICURRENT_PATCH,ITEB_PATCH),'_'
+  END IF
+END IF
+!
+!---------------------------------------------------------------------------------------
+!
+!*      3.     Transformation into physical quantity to be interpolated
+!              --------------------------------------------------------
+!
+SELECT CASE(HSURF)
+!
+!*     3.      Orography
+!              ---------
+!
+  CASE('ZS     ')
+    ALLOCATE(PFIELD(INI,1,1))
+    YRECFM='ZS'
+    CALL READ_SURF(HFILEPGDTYPE,YRECFM,PFIELD(:,1,1),IRESP,HDIR='A')
+    CALL CLOSE_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE)
+!
+!--------------------------------------------------------------------------
+!
+!
+!*      3.1    Profile of temperature, water or ice in the soil
+!
+  CASE('TG    ','WG    ','WGI   ')
+!* choice if one reads garden fields (if present) or ISBA fields
+    GGARDEN = .FALSE.
+    IF (GTEB) CALL READ_SURF(HFILEPGDTYPE,'GARDEN',GGARDEN,IRESP)
+    CALL CLOSE_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE)
+    IF (GGARDEN) THEN
+      YSURF = 'GD_'//HSURF(1:3)
+      IF (GOLD_NAME) YSURF = 'TWN_'//HSURF(1:3)
+      YSURF = YPATCH//YSURF
+    ELSE
+      YSURF = HSURF
+    END IF
+    YSURF=ADJUSTL(YSURF)  
+!* reading of the profile and its depth definition
+     CALL READ_EXTERN_ISBA(HFILE,HFILETYPE,HFILEPGD,HFILEPGDTYPE,KLUOUT,INI,&
+                HSURF,YSURF,ZFIELD,ZD)
+! 
+     ALLOCATE(ZFIELD1(SIZE(ZFIELD,1),SIZE(ZFIELD,2)))
+     ALLOCATE(ZD1(SIZE(ZFIELD,1),SIZE(ZFIELD,2)))
+     ALLOCATE(ZOUT(SIZE(ZFIELD,1),SIZE(XGRID_SOIL)))
+     ALLOCATE(PFIELD(SIZE(ZFIELD,1),SIZE(XGRID_SOIL),SIZE(ZFIELD,3)))
+!
+     DO JPATCH=1,SIZE(ZFIELD,3)
+        ZFIELD1(:,:)=ZFIELD(:,:,JPATCH)
+        ZD1(:,:)=ZD(:,:,JPATCH)
+        CALL INTERP_GRID(ZD1,ZFIELD1,XGRID_SOIL,ZOUT)
+        PFIELD(:,:,JPATCH)=ZOUT(:,:)
+     END DO
+!
+     DEALLOCATE(ZFIELD)
+     DEALLOCATE(ZOUT)
+     DEALLOCATE(ZFIELD1)
+     DEALLOCATE(ZD)
+!
+!--------------------------------------------------------------------------
+!
+!*      3.4    Water content intercepted on leaves, LAI
+!
+  CASE('WR     ')
+     ALLOCATE(PFIELD(INI,1,NVEGTYPE))
+     !* choice if one reads garden fields (if present) or ISBA fields    
+     GGARDEN = .FALSE.
+     IF (GTEB) CALL READ_SURF(HFILEPGDTYPE,'GARDEN',GGARDEN,IRESP)
+     CALL CLOSE_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE)
+     IF (GGARDEN) THEN
+       IPATCH = 1    
+       YRECFM = 'GD_WR'
+       IF (GOLD_NAME) YRECFM = 'TWN_WR'
+       YRECFM = YPATCH//YRECFM
+       CALL OPEN_AUX_IO_SURF(HFILE,HFILETYPE,'TOWN  ')
+     ELSE            
+       YRECFM = 'PATCH_NUMBER'
+       CALL OPEN_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE,'NATURE')
+       CALL READ_SURF(HFILEPGDTYPE,YRECFM,IPATCH,IRESP)
+       CALL CLOSE_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE)
+       CALL OPEN_AUX_IO_SURF(HFILE,HFILETYPE,'NATURE')
+       YRECFM = 'WR'
+     END IF
+     YRECFM=ADJUSTL(YRECFM)
+     
+     ALLOCATE(ZFIELD(INI,1,IPATCH))
+     CALL READ_SURF_FIELD2D(HFILETYPE,ZFIELD(:,1,:),YRECFM,HDIR='A')
+     CALL CLOSE_AUX_IO_SURF(HFILE,HFILETYPE)
+     CALL PUT_ON_ALL_VEGTYPES(INI,1,1,NVEGTYPE,ZFIELD,PFIELD)
+     DEALLOCATE(ZFIELD)
+!
+  CASE('LAI    ')
+     CALL CLOSE_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE)
+     ALLOCATE(PFIELD(INI,1,NVEGTYPE))
+     PFIELD(:,:,:) = XUNDEF
+!
+END SELECT
+!
+!
+!---------------------------------------------------------------------------
+!
+!*      6.     End of IO
+!              ---------
+!
+IF (LHOOK) CALL DR_HOOK('PREP_TEB_GARDEN_EXTERN',1,ZHOOK_HANDLE)
+!
+!---------------------------------------------------------------------------
+!---------------------------------------------------------------------------
+END SUBROUTINE PREP_TEB_GARDEN_EXTERN
index 54420b6..3ee00d7 100644 (file)
-!SURFEX_LIC Copyright 1994-2014 Meteo-France \r
-!SURFEX_LIC This is part of the SURFEX software governed by the CeCILL-C  licence\r
-!SURFEX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt\r
-!SURFEX_LIC for details. version 1.\r
-!     #########\r
-SUBROUTINE PREP_TEB_GREENROOF_EXTERN(HPROGRAM,HSURF,HFILE,HFILETYPE,HFILEPGD,HFILEPGDTYPE,KLUOUT,PFIELD)\r
-!     #################################################################################\r
-!\r
-!!****  *PREP_TEB_GREENROOF_EXTERN* - initializes ISBA fields from operational GRIB\r
-!!\r
-!!    PURPOSE\r
-!!    -------\r
-!\r
-!!**  METHOD\r
-!!    ------\r
-!!    Based on "prep_teb_garden_extern"\r
-!!\r
-!!    REFERENCE\r
-!!    ---------\r
-!!      \r
-!!\r
-!!    AUTHOR\r
-!!    ------\r
-!!    A. Lemonsu & C. de Munck \r
-!!\r
-!!    MODIFICATIONS\r
-!!    -------------\r
-!!      Original    07/2011\r
-!!      M.Moge    01/2016  using READ_SURF_FIELD2D/3D for 2D/3D surfex fields reads\r
-!!------------------------------------------------------------------\r
-!\r
-\r
-!\r
-USE MODE_READ_EXTERN\r
-!\r
-USE MODD_TYPE_DATE_SURF\r
-!\r
-USE MODI_PREP_GRID_EXTERN\r
-USE MODI_READ_SURF\r
-USE MODI_INTERP_GRID\r
-USE MODI_OPEN_AUX_IO_SURF\r
-USE MODI_CLOSE_AUX_IO_SURF\r
-USE MODI_READ_TEB_PATCH\r
-USE MODI_GET_CURRENT_TEB_PATCH\r
-USE MODI_TOWN_PRESENCE\r
-!\r
-USE MODD_PREP,               ONLY : CINGRID_TYPE, CINTERP_TYPE\r
-USE MODD_PREP_TEB_GREENROOF, ONLY : XGRID_SOIL, XWR_DEF\r
-USE MODD_DATA_COVER_PAR,     ONLY : NVEGTYPE\r
-USE MODD_SURF_PAR,           ONLY : XUNDEF\r
-!\r
-USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK\r
-USE PARKIND1  ,ONLY : JPRB\r
-!\r
-USE MODI_PUT_ON_ALL_VEGTYPES\r
-!\r
-USE MODI_READ_SURF_FIELD2D\r
-!\r
-IMPLICIT NONE\r
-!\r
-!*      0.1    declarations of arguments\r
-!\r
- CHARACTER(LEN=6),   INTENT(IN)  :: HPROGRAM  ! program calling surf. schemes\r
- CHARACTER(LEN=7),   INTENT(IN)  :: HSURF     ! type of field\r
- CHARACTER(LEN=28),  INTENT(IN)  :: HFILE     ! name of file\r
- CHARACTER(LEN=6),   INTENT(IN)  :: HFILETYPE ! type of input file\r
- CHARACTER(LEN=28),  INTENT(IN)  :: HFILEPGD     ! name of file\r
- CHARACTER(LEN=6),   INTENT(IN)  :: HFILEPGDTYPE ! type of input file\r
-INTEGER,            INTENT(IN)  :: KLUOUT    ! logical unit of output listing\r
-REAL,DIMENSION(:,:,:), POINTER  :: PFIELD    ! field to interpolate horizontally (on final soil grid)\r
-!\r
-!*      0.2    declarations of local variables\r
-!\r
- CHARACTER(LEN=12) :: YRECFM         ! Name of the article to be read\r
-INTEGER           :: IRESP          ! reading return code\r
-INTEGER           :: INI            ! total 1D dimension\r
-INTEGER           :: IPATCH         ! number of patch\r
-!\r
-REAL, DIMENSION(:,:,:), POINTER     :: ZFIELD         ! field read on initial MNH vertical soil grid, all patches\r
-REAL, DIMENSION(:,:),   POINTER     :: ZFIELD1        ! field read on initial MNH vertical soil grid, one patch\r
-REAL, DIMENSION(:,:,:), POINTER     :: ZD             ! depth of field in the soil\r
-REAL, DIMENSION(:,:), POINTER       :: ZD1            ! depth of field in the soil, one patch\r
-REAL, DIMENSION(:,:), ALLOCATABLE   :: ZOUT           !\r
-LOGICAL                             :: GTEB           ! flag if TEB fields are present\r
-INTEGER                             :: JPATCH         ! loop counter for patch\r
- CHARACTER(LEN=12)                   :: YSURF          ! type of field\r
-INTEGER                             :: ITEB_PATCH     ! number of TEB patches in file\r
-INTEGER                             :: ICURRENT_PATCH ! current TEB patch to be initialized\r
-INTEGER                             :: IVERSION       ! SURFEX version\r
-INTEGER                             :: IBUGFIX        ! SURFEX bug version\r
-LOGICAL                             :: GOLD_NAME      ! old name flag for temperatures\r
- CHARACTER(LEN=3)                    :: YPATCH         ! indentificator for TEB patch\r
- CHARACTER(LEN=4)                    :: YPATCH2   ! number of the patch\r
-LOGICAL                             :: GGREENROOF     ! T if gardens are present in the file\r
-!\r
-REAL(KIND=JPRB) :: ZHOOK_HANDLE\r
-!\r
-!------------------------------------------------------------------------------\r
-!\r
-!*      1.     Preparation of IO for reading in the file\r
-!              -----------------------------------------\r
-!\r
-!* Note that all points are read, even those without physical meaning.\r
-!  These points will not be used during the horizontal interpolation step.\r
-!  Their value must be defined as XUNDEF.\r
-!\r
-IF (LHOOK) CALL DR_HOOK('PREP_TEB_GREENROOF_EXTERN',0,ZHOOK_HANDLE)\r
- CALL OPEN_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE,'TOWN  ')\r
-!\r
-!* reading of version of the file being read\r
- CALL READ_SURF(HFILEPGDTYPE,'VERSION',IVERSION,IRESP)\r
- CALL READ_SURF(HFILEPGDTYPE,'BUG',IBUGFIX,IRESP)\r
-GOLD_NAME=(IVERSION<7 .OR. (IVERSION==7 .AND. IBUGFIX<3))\r
-!\r
-!------------------------------------------------------------------------------\r
-!\r
-!*      2.     Reading of grid\r
-!              ---------------\r
-!\r
- CALL PREP_GRID_EXTERN(HFILEPGDTYPE,KLUOUT,CINGRID_TYPE,CINTERP_TYPE,INI)\r
-!\r
-!* reads if TEB fields exist in the input file\r
- CALL TOWN_PRESENCE(HFILEPGDTYPE,GTEB)\r
-!\r
-IF (GTEB) THEN\r
-  CALL READ_TEB_PATCH(HFILEPGDTYPE,ITEB_PATCH)\r
-  CALL GET_CURRENT_TEB_PATCH(ICURRENT_PATCH)\r
-  YPATCH='   '\r
-  IF (ITEB_PATCH>1) THEN\r
-    WRITE(YPATCH,FMT='(A,I1,A)') 'T',MIN(ICURRENT_PATCH,ITEB_PATCH),'_'\r
-  END IF\r
-END IF\r
-!\r
-! A FAIRE : VERIFIER QUE LES MODIFS DES PATCH/GTEB/GGREENROOF SONT CORRECTES\r
-!---------------------------------------------------------------------------------------\r
-!\r
-!*      3.     Transformation into physical quantity to be interpolated\r
-!              --------------------------------------------------------\r
-!\r
-SELECT CASE(HSURF)\r
-!\r
-!*     3.      Orography\r
-!              ---------\r
-!\r
-  CASE('ZS     ')\r
-    ALLOCATE(PFIELD(INI,1,1))\r
-    YRECFM='ZS'\r
-    CALL READ_SURF(HFILEPGDTYPE,YRECFM,PFIELD(:,1,1),IRESP,HDIR='A')\r
-    CALL CLOSE_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE)\r
-!\r
-!--------------------------------------------------------------------------\r
-!\r
-!\r
-!*      3.1    Profile of temperature, water or ice in the soil\r
-!\r
-  CASE('TG    ','WG    ','WGI   ')\r
-!* choice if one reads garden fields (if present) or ISBA fields\r
-     GGREENROOF = .FALSE.\r
-     IF (GTEB) CALL READ_SURF(HFILEPGDTYPE,'LGREENROOF',GGREENROOF,IRESP)\r
-     CALL CLOSE_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE)\r
-     IF (GGREENROOF) THEN\r
-        YSURF = 'GR_'//HSURF(1:3)  \r
-        YSURF=YPATCH//YSURF      \r
-     ELSE\r
-       YSURF = HSURF\r
-     END IF\r
-     YSURF=ADJUSTL(YSURF)\r
-!* reading of the profile and its depth definition\r
-     CALL READ_EXTERN_ISBA(HFILE,HFILETYPE,HFILEPGD,HFILEPGDTYPE,KLUOUT,INI,&\r
-        HSURF,YSURF,ZFIELD,ZD)\r
-! \r
-     ALLOCATE(ZFIELD1(SIZE(ZFIELD,1),SIZE(ZFIELD,2)))\r
-     ALLOCATE(ZD1(SIZE(ZFIELD,1),SIZE(ZFIELD,2)))\r
-     ALLOCATE(ZOUT(SIZE(ZFIELD,1),SIZE(XGRID_SOIL)))\r
-     ALLOCATE(PFIELD(SIZE(ZFIELD,1),SIZE(XGRID_SOIL),SIZE(ZFIELD,3)))\r
-!\r
-     DO JPATCH=1,SIZE(ZFIELD,3)\r
-        ZFIELD1(:,:)=ZFIELD(:,:,JPATCH)\r
-        ZD1(:,:)=ZD(:,:,JPATCH)\r
-        CALL INTERP_GRID(ZD1,ZFIELD1,XGRID_SOIL,ZOUT)\r
-        PFIELD(:,:,JPATCH)=ZOUT(:,:)\r
-     END DO\r
-!\r
-     DEALLOCATE(ZFIELD)\r
-     DEALLOCATE(ZOUT)\r
-     DEALLOCATE(ZFIELD1)\r
-     DEALLOCATE(ZD)\r
-!\r
-!--------------------------------------------------------------------------\r
-!\r
-!*      3.4    Water content intercepted on leaves, LAI\r
-!\r
-  CASE('WR     ')\r
-     ALLOCATE(PFIELD(INI,1,NVEGTYPE))\r
-     !* choice if one reads garden fields (if present) or ISBA fields\r
-     GGREENROOF = .FALSE.\r
-     IF (GTEB) CALL READ_SURF(HFILEPGDTYPE,'LGREENROOF',GGREENROOF,IRESP)\r
-     CALL CLOSE_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE)\r
-     IF (GGREENROOF) THEN\r
-       IPATCH = 1             \r
-       YRECFM = 'GD_WR'\r
-       YRECFM=YPATCH//YRECFM\r
-       CALL OPEN_AUX_IO_SURF(HFILE,HFILETYPE,'TOWN  ')\r
-     ELSE\r
-       YRECFM = 'PATCH_NUMBER'\r
-       CALL OPEN_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE,'NATURE')\r
-       CALL READ_SURF(HFILEPGDTYPE,YRECFM,IPATCH,IRESP)\r
-       CALL CLOSE_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE)\r
-       CALL OPEN_AUX_IO_SURF(HFILE,HFILETYPE,'NATURE')\r
-       YRECFM = 'WR'\r
-     END IF\r
-     YRECFM=ADJUSTL(YRECFM)\r
-     ALLOCATE(ZFIELD(INI,1,IPATCH))\r
-     CALL READ_SURF_FIELD2D(HFILETYPE,ZFIELD(:,1,:),YRECFM,HDIR='A')\r
-     CALL CLOSE_AUX_IO_SURF(HFILE,HFILETYPE)\r
-     CALL PUT_ON_ALL_VEGTYPES(INI,1,1,NVEGTYPE,ZFIELD,PFIELD)\r
-     DEALLOCATE(ZFIELD)\r
-!\r
-  CASE('LAI    ')\r
-     CALL CLOSE_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE)\r
-     ALLOCATE(PFIELD(INI,1,NVEGTYPE))\r
-     PFIELD(:,:,:) = XUNDEF\r
-!\r
-END SELECT\r
-!\r
-!\r
-!---------------------------------------------------------------------------\r
-!\r
-!*      6.     End of IO\r
-!              ---------\r
-!\r
-IF (LHOOK) CALL DR_HOOK('PREP_TEB_GREENROOF_EXTERN',1,ZHOOK_HANDLE)\r
-!\r
-!---------------------------------------------------------------------------\r
-!---------------------------------------------------------------------------\r
-END SUBROUTINE PREP_TEB_GREENROOF_EXTERN\r
+!SURFEX_LIC Copyright 1994-2014 Meteo-France 
+!SURFEX_LIC This is part of the SURFEX software governed by the CeCILL-C  licence
+!SURFEX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
+!SURFEX_LIC for details. version 1.
+!     #########
+SUBROUTINE PREP_TEB_GREENROOF_EXTERN(HPROGRAM,HSURF,HFILE,HFILETYPE,HFILEPGD,HFILEPGDTYPE,KLUOUT,PFIELD)
+!     #################################################################################
+!
+!!****  *PREP_TEB_GREENROOF_EXTERN* - initializes ISBA fields from operational GRIB
+!!
+!!    PURPOSE
+!!    -------
+!
+!!**  METHOD
+!!    ------
+!!    Based on "prep_teb_garden_extern"
+!!
+!!    REFERENCE
+!!    ---------
+!!      
+!!
+!!    AUTHOR
+!!    ------
+!!    A. Lemonsu & C. de Munck 
+!!
+!!    MODIFICATIONS
+!!    -------------
+!!      Original    07/2011
+!!      M.Moge    01/2016  using READ_SURF_FIELD2D/3D for 2D/3D surfex fields reads
+!!------------------------------------------------------------------
+!
+
+!
+USE MODE_READ_EXTERN
+!
+USE MODD_TYPE_DATE_SURF
+!
+USE MODI_PREP_GRID_EXTERN
+USE MODI_READ_SURF
+USE MODI_INTERP_GRID
+USE MODI_OPEN_AUX_IO_SURF
+USE MODI_CLOSE_AUX_IO_SURF
+USE MODI_READ_TEB_PATCH
+USE MODI_GET_CURRENT_TEB_PATCH
+USE MODI_TOWN_PRESENCE
+!
+USE MODD_PREP,               ONLY : CINGRID_TYPE, CINTERP_TYPE
+USE MODD_PREP_TEB_GREENROOF, ONLY : XGRID_SOIL, XWR_DEF
+USE MODD_DATA_COVER_PAR,     ONLY : NVEGTYPE
+USE MODD_SURF_PAR,           ONLY : XUNDEF
+!
+USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
+USE PARKIND1  ,ONLY : JPRB
+!
+USE MODI_PUT_ON_ALL_VEGTYPES
+!
+USE MODI_READ_SURF_FIELD2D
+!
+IMPLICIT NONE
+!
+!*      0.1    declarations of arguments
+!
+ CHARACTER(LEN=6),   INTENT(IN)  :: HPROGRAM  ! program calling surf. schemes
+ CHARACTER(LEN=7),   INTENT(IN)  :: HSURF     ! type of field
+ CHARACTER(LEN=28),  INTENT(IN)  :: HFILE     ! name of file
+ CHARACTER(LEN=6),   INTENT(IN)  :: HFILETYPE ! type of input file
+ CHARACTER(LEN=28),  INTENT(IN)  :: HFILEPGD     ! name of file
+ CHARACTER(LEN=6),   INTENT(IN)  :: HFILEPGDTYPE ! type of input file
+INTEGER,            INTENT(IN)  :: KLUOUT    ! logical unit of output listing
+REAL,DIMENSION(:,:,:), POINTER  :: PFIELD    ! field to interpolate horizontally (on final soil grid)
+!
+!*      0.2    declarations of local variables
+!
+ CHARACTER(LEN=12) :: YRECFM         ! Name of the article to be read
+INTEGER           :: IRESP          ! reading return code
+INTEGER           :: INI            ! total 1D dimension
+INTEGER           :: IPATCH         ! number of patch
+!
+REAL, DIMENSION(:,:,:), POINTER     :: ZFIELD         ! field read on initial MNH vertical soil grid, all patches
+REAL, DIMENSION(:,:),   POINTER     :: ZFIELD1        ! field read on initial MNH vertical soil grid, one patch
+REAL, DIMENSION(:,:,:), POINTER     :: ZD             ! depth of field in the soil
+REAL, DIMENSION(:,:), POINTER       :: ZD1            ! depth of field in the soil, one patch
+REAL, DIMENSION(:,:), ALLOCATABLE   :: ZOUT           !
+LOGICAL                             :: GTEB           ! flag if TEB fields are present
+INTEGER                             :: JPATCH         ! loop counter for patch
+ CHARACTER(LEN=12)                   :: YSURF          ! type of field
+INTEGER                             :: ITEB_PATCH     ! number of TEB patches in file
+INTEGER                             :: ICURRENT_PATCH ! current TEB patch to be initialized
+INTEGER                             :: IVERSION       ! SURFEX version
+INTEGER                             :: IBUGFIX        ! SURFEX bug version
+LOGICAL                             :: GOLD_NAME      ! old name flag for temperatures
+ CHARACTER(LEN=3)                    :: YPATCH         ! indentificator for TEB patch
+ CHARACTER(LEN=4)                    :: YPATCH2   ! number of the patch
+LOGICAL                             :: GGREENROOF     ! T if gardens are present in the file
+!
+REAL(KIND=JPRB) :: ZHOOK_HANDLE
+!
+!------------------------------------------------------------------------------
+!
+!*      1.     Preparation of IO for reading in the file
+!              -----------------------------------------
+!
+!* Note that all points are read, even those without physical meaning.
+!  These points will not be used during the horizontal interpolation step.
+!  Their value must be defined as XUNDEF.
+!
+IF (LHOOK) CALL DR_HOOK('PREP_TEB_GREENROOF_EXTERN',0,ZHOOK_HANDLE)
+ CALL OPEN_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE,'TOWN  ')
+!
+!* reading of version of the file being read
+ CALL READ_SURF(HFILEPGDTYPE,'VERSION',IVERSION,IRESP)
+ CALL READ_SURF(HFILEPGDTYPE,'BUG',IBUGFIX,IRESP)
+GOLD_NAME=(IVERSION<7 .OR. (IVERSION==7 .AND. IBUGFIX<3))
+!
+!------------------------------------------------------------------------------
+!
+!*      2.     Reading of grid
+!              ---------------
+!
+ CALL PREP_GRID_EXTERN(HFILEPGDTYPE,KLUOUT,CINGRID_TYPE,CINTERP_TYPE,INI)
+!
+!* reads if TEB fields exist in the input file
+ CALL TOWN_PRESENCE(HFILEPGDTYPE,GTEB)
+!
+IF (GTEB) THEN
+  CALL READ_TEB_PATCH(HFILEPGDTYPE,ITEB_PATCH)
+  CALL GET_CURRENT_TEB_PATCH(ICURRENT_PATCH)
+  YPATCH='   '
+  IF (ITEB_PATCH>1) THEN
+    WRITE(YPATCH,FMT='(A,I1,A)') 'T',MIN(ICURRENT_PATCH,ITEB_PATCH),'_'
+  END IF
+END IF
+!
+! A FAIRE : VERIFIER QUE LES MODIFS DES PATCH/GTEB/GGREENROOF SONT CORRECTES
+!---------------------------------------------------------------------------------------
+!
+!*      3.     Transformation into physical quantity to be interpolated
+!              --------------------------------------------------------
+!
+SELECT CASE(HSURF)
+!
+!*     3.      Orography
+!              ---------
+!
+  CASE('ZS     ')
+    ALLOCATE(PFIELD(INI,1,1))
+    YRECFM='ZS'
+    CALL READ_SURF(HFILEPGDTYPE,YRECFM,PFIELD(:,1,1),IRESP,HDIR='A')
+    CALL CLOSE_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE)
+!
+!--------------------------------------------------------------------------
+!
+!
+!*      3.1    Profile of temperature, water or ice in the soil
+!
+  CASE('TG    ','WG    ','WGI   ')
+!* choice if one reads garden fields (if present) or ISBA fields
+     GGREENROOF = .FALSE.
+     IF (GTEB) CALL READ_SURF(HFILEPGDTYPE,'LGREENROOF',GGREENROOF,IRESP)
+     CALL CLOSE_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE)
+     IF (GGREENROOF) THEN
+        YSURF = 'GR_'//HSURF(1:3)  
+        YSURF=YPATCH//YSURF      
+     ELSE
+       YSURF = HSURF
+     END IF
+     YSURF=ADJUSTL(YSURF)
+!* reading of the profile and its depth definition
+     CALL READ_EXTERN_ISBA(HFILE,HFILETYPE,HFILEPGD,HFILEPGDTYPE,KLUOUT,INI,&
+        HSURF,YSURF,ZFIELD,ZD)
+! 
+     ALLOCATE(ZFIELD1(SIZE(ZFIELD,1),SIZE(ZFIELD,2)))
+     ALLOCATE(ZD1(SIZE(ZFIELD,1),SIZE(ZFIELD,2)))
+     ALLOCATE(ZOUT(SIZE(ZFIELD,1),SIZE(XGRID_SOIL)))
+     ALLOCATE(PFIELD(SIZE(ZFIELD,1),SIZE(XGRID_SOIL),SIZE(ZFIELD,3)))
+!
+     DO JPATCH=1,SIZE(ZFIELD,3)
+        ZFIELD1(:,:)=ZFIELD(:,:,JPATCH)
+        ZD1(:,:)=ZD(:,:,JPATCH)
+        CALL INTERP_GRID(ZD1,ZFIELD1,XGRID_SOIL,ZOUT)
+        PFIELD(:,:,JPATCH)=ZOUT(:,:)
+     END DO
+!
+     DEALLOCATE(ZFIELD)
+     DEALLOCATE(ZOUT)
+     DEALLOCATE(ZFIELD1)
+     DEALLOCATE(ZD)
+!
+!--------------------------------------------------------------------------
+!
+!*      3.4    Water content intercepted on leaves, LAI
+!
+  CASE('WR     ')
+     ALLOCATE(PFIELD(INI,1,NVEGTYPE))
+     !* choice if one reads garden fields (if present) or ISBA fields
+     GGREENROOF = .FALSE.
+     IF (GTEB) CALL READ_SURF(HFILEPGDTYPE,'LGREENROOF',GGREENROOF,IRESP)
+     CALL CLOSE_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE)
+     IF (GGREENROOF) THEN
+       IPATCH = 1             
+       YRECFM = 'GD_WR'
+       YRECFM=YPATCH//YRECFM
+       CALL OPEN_AUX_IO_SURF(HFILE,HFILETYPE,'TOWN  ')
+     ELSE
+       YRECFM = 'PATCH_NUMBER'
+       CALL OPEN_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE,'NATURE')
+       CALL READ_SURF(HFILEPGDTYPE,YRECFM,IPATCH,IRESP)
+       CALL CLOSE_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE)
+       CALL OPEN_AUX_IO_SURF(HFILE,HFILETYPE,'NATURE')
+       YRECFM = 'WR'
+     END IF
+     YRECFM=ADJUSTL(YRECFM)
+     ALLOCATE(ZFIELD(INI,1,IPATCH))
+     CALL READ_SURF_FIELD2D(HFILETYPE,ZFIELD(:,1,:),YRECFM,HDIR='A')
+     CALL CLOSE_AUX_IO_SURF(HFILE,HFILETYPE)
+     CALL PUT_ON_ALL_VEGTYPES(INI,1,1,NVEGTYPE,ZFIELD,PFIELD)
+     DEALLOCATE(ZFIELD)
+!
+  CASE('LAI    ')
+     CALL CLOSE_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE)
+     ALLOCATE(PFIELD(INI,1,NVEGTYPE))
+     PFIELD(:,:,:) = XUNDEF
+!
+END SELECT
+!
+!
+!---------------------------------------------------------------------------
+!
+!*      6.     End of IO
+!              ---------
+!
+IF (LHOOK) CALL DR_HOOK('PREP_TEB_GREENROOF_EXTERN',1,ZHOOK_HANDLE)
+!
+!---------------------------------------------------------------------------
+!---------------------------------------------------------------------------
+END SUBROUTINE PREP_TEB_GREENROOF_EXTERN
index d6afdea..3c3675b 100644 (file)
-!SURFEX_LIC Copyright 1994-2014 Meteo-France \r
-!SURFEX_LIC This is part of the SURFEX software governed by the CeCILL-C  licence\r
-!SURFEX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt\r
-!SURFEX_LIC for details. version 1.\r
-!     #########\r
-      SUBROUTINE READ_GR_SNOW(HPROGRAM,HSURFTYPE,HPREFIX,     &\r
-                              KLU,KPATCH,TPSNOW,HDIR)  \r
-!     ##########################################################\r
-!\r
-!!****  *READ_GR_SNOW* - routine to read snow surface fields\r
-!!\r
-!!    PURPOSE\r
-!!    -------\r
-!       Initialize snow surface fields.\r
-!\r
-!!**  METHOD\r
-!!    ------\r
-!!    \r
-!!    \r
-!!\r
-!!    EXTERNAL\r
-!!    --------\r
-!!      \r
-!!       \r
-!!    IMPLICIT ARGUMENTS\r
-!!    ------------------ \r
-!!\r
-!!    REFERENCE\r
-!!    ---------\r
-!!      \r
-!!      \r
-!!\r
-!!    AUTHOR\r
-!!    ------\r
-!!     V. Masson       * Meteo France *\r
-!!\r
-!!    MODIFICATIONS\r
-!!    -------------\r
-!!      Original       20/01/99\r
-!       F.solmon       06/00 adaptation for patch\r
-!       V.Masson       01/03 new version of ISBA\r
-!       B. Decharme    2008  If no WSNOW, WSNOW = XUNDEF\r
-!!      M.Moge    01/2016  using READ_SURF_FIELD2D/3D for 2D/3D surfex fields reads\r
-!-----------------------------------------------------------------------------\r
-!\r
-!*       0.    DECLARATIONS\r
-!\r
-USE MODD_TYPE_SNOW\r
-!\r
-USE MODI_READ_SURF\r
-USE MODI_READ_SURF_FIELD2D\r
-USE MODI_READ_SURF_FIELD3D\r
-!\r
-USE MODI_ALLOCATE_GR_SNOW\r
-!\r
-USE MODD_SURF_PAR, ONLY : XUNDEF\r
-USE MODD_PREP_SNOW, ONLY : LSNOW_FRAC_TOT\r
-!\r
-USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK\r
-USE PARKIND1  ,ONLY : JPRB\r
-!\r
-IMPLICIT NONE\r
-!\r
-!*       0.1   declarations of arguments\r
-!\r
- CHARACTER(LEN=6),   INTENT(IN)           :: HPROGRAM  ! calling program\r
- CHARACTER (LEN=*),  INTENT(IN)           :: HSURFTYPE ! generic name used for\r
-                                                      ! snow characteristics\r
-                                                      ! storage in file\r
- CHARACTER (LEN=3),  INTENT(IN)           :: HPREFIX   ! generic name for patch\r
-!                                                     ! identification                      \r
-INTEGER,            INTENT(IN)           :: KLU       ! horizontal size of snow var.\r
-INTEGER,            INTENT(IN)           :: KPATCH    ! number of tiles\r
-TYPE(SURF_SNOW)                          :: TPSNOW    ! snow characteristics\r
- CHARACTER (LEN=1),  INTENT(IN), OPTIONAL :: HDIR      ! type of reading\r
-!                                                     ! HDIR = 'A' : entire field on All processors\r
-!                                                     ! HDIR = 'H' : distribution on each processor\r
-!\r
-!*       0.2   declarations of local variables\r
-!\r
-INTEGER             :: IRESP               ! Error code after redding\r
- CHARACTER(LEN=12)   :: YRECFM              ! Name of the article to be read\r
- CHARACTER(LEN=16)   :: YRECFM2 \r
-!\r
- CHARACTER (LEN=100) :: YFMT                ! format for writing\r
-INTEGER             :: ISURFTYPE_LEN       ! \r
-LOGICAL             :: GSNOW               ! snow written in the file\r
-INTEGER             :: JLAYER              ! loop counter\r
-CHARACTER(LEN=4)    :: YPATCH              ! number of the patch\r
-REAL, DIMENSION(:,:),ALLOCATABLE  :: ZWORK ! 2D array to write data in file\r
- CHARACTER(LEN=1)    :: YDIR                ! type of reading\r
- CHARACTER(LEN=4)    :: YNLAYER     !Format depending on the number of layers\r
-INTEGER             :: IVERSION, IBUGFIX\r
-REAL(KIND=JPRB) :: ZHOOK_HANDLE\r
-!-------------------------------------------------------------------------------\r
-!\r
-IF (LHOOK) CALL DR_HOOK('READ_GR_SNOW',0,ZHOOK_HANDLE)\r
-YDIR = 'H'\r
-IF (PRESENT(HDIR)) YDIR = HDIR\r
-!\r
-!-------------------------------------------------------------------------------\r
- CALL READ_SURF(HPROGRAM,'VERSION',IVERSION,IRESP)\r
- CALL READ_SURF(HPROGRAM,'BUG',IBUGFIX,IRESP)\r
-!-------------------------------------------------------------------------------\r
-!\r
-!*       1.    Type of snow scheme\r
-!              -------------------\r
-!\r
-ISURFTYPE_LEN=LEN_TRIM(HSURFTYPE)\r
-IF (IVERSION <=2 .OR. (IVERSION==3 .AND. IBUGFIX<=4)) THEN\r
-  WRITE(YFMT,'(A5,I1,A4)')     '(A5,A',ISURFTYPE_LEN,',A5)'\r
-  WRITE(YRECFM2,YFMT) 'SNOW_',HSURFTYPE,'_TYPE'\r
-ELSE\r
-  IF (IVERSION<7 .OR. IVERSION==7 .AND. IBUGFIX<3) THEN\r
-    WRITE(YFMT,'(A5,I1,A4)')     '(A3,A',ISURFTYPE_LEN,',A5)'\r
-    WRITE(YRECFM2,YFMT) 'SN_',HSURFTYPE,'_TYPE'\r
-  ELSE\r
-    WRITE(YFMT,'(A5,I1,A4)')     '(A3,A',ISURFTYPE_LEN,',A4)'\r
-    WRITE(YRECFM2,YFMT) 'SN_',HSURFTYPE,'_TYP'\r
-    YRECFM2=ADJUSTL(HPREFIX//YRECFM2)\r
-  ENDIF\r
-END IF\r
-!\r
- CALL READ_SURF(HPROGRAM,YRECFM2,TPSNOW%SCHEME,IRESP)\r
-!\r
-!*       2.    Snow levels\r
-!              -----------\r
-!\r
-!\r
-IF (IVERSION <=2 .OR. (IVERSION==3 .AND. IBUGFIX<=4)) THEN\r
-  WRITE(YFMT,'(A5,I1,A4)')     '(A5,A',ISURFTYPE_LEN,',A6)'\r
-  WRITE(YRECFM2,YFMT) 'SNOW_',HSURFTYPE,'_LAYER'\r
-ELSE\r
-  WRITE(YFMT,'(A5,I1,A4)')     '(A3,A',ISURFTYPE_LEN,',A2)'\r
-  WRITE(YRECFM2,YFMT) 'SN_',HSURFTYPE,'_N'\r
-  IF (IVERSION>7 .OR. IVERSION==7 .AND. IBUGFIX>=3) YRECFM2=ADJUSTL(HPREFIX//YRECFM2)\r
-END IF\r
-!\r
- CALL READ_SURF(HPROGRAM,YRECFM2,TPSNOW%NLAYER,IRESP)\r
-!\r
-!*       2.    Presence of snow fields in the file\r
-!              -----------------------------------\r
-!\r
-IF (IVERSION >6 .OR. (IVERSION==6 .AND. IBUGFIX>=1)) THEN\r
-  WRITE(YFMT,'(A5,I1,A1)')     '(A3,A',ISURFTYPE_LEN,')'\r
-  WRITE(YRECFM,YFMT) 'SN_',HSURFTYPE\r
-  IF (IVERSION>7 .OR. IVERSION==7 .AND. IBUGFIX>=3) YRECFM=ADJUSTL(HPREFIX//YRECFM)\r
-  CALL READ_SURF(HPROGRAM,YRECFM,GSNOW,IRESP)\r
-ELSE\r
-  IF (TPSNOW%NLAYER==0) THEN\r
-    GSNOW = .FALSE.\r
-    IF (TPSNOW%SCHEME=='D95' .OR. TPSNOW%SCHEME=='1-L' .OR. TPSNOW%SCHEME=='EBA') TPSNOW%NLAYER=1\r
-    IF (TPSNOW%SCHEME=='3-L' .OR. TPSNOW%SCHEME=='CRO'                          ) TPSNOW%NLAYER=3\r
-  ELSE\r
-    GSNOW = .TRUE.\r
-  END IF\r
-END IF\r
-!\r
-!-------------------------------------------------------------------------------\r
-!\r
-!*       3.    Allocations\r
-!              -----------\r
-!\r
- CALL ALLOCATE_GR_SNOW(TPSNOW,KLU,KPATCH)\r
-!\r
-IF (.NOT. GSNOW) THEN\r
-  IF (LHOOK) CALL DR_HOOK('READ_GR_SNOW',1,ZHOOK_HANDLE)\r
-  RETURN\r
-END IF\r
-!-------------------------------------------------------------------------------\r
-!\r
-!*       4.    Additional key\r
-!              ---------------\r
-!\r
-IF (IVERSION >= 7 .AND. HSURFTYPE=='VEG') CALL READ_SURF(HPROGRAM,'LSNOW_FRAC_T',LSNOW_FRAC_TOT,IRESP)\r
-!\r
-!-------------------------------------------------------------------------------\r
-!\r
-!*       5.    Snow reservoir\r
-!              --------------\r
-!\r
-ALLOCATE(ZWORK(SIZE(TPSNOW%WSNOW,1),SIZE(TPSNOW%WSNOW,3)))\r
-!\r
-  IF (TPSNOW%SCHEME=='1-L' .OR. TPSNOW%SCHEME=='D95' .OR. TPSNOW%SCHEME=='EBA' .OR. TPSNOW%SCHEME=='3-L' &\r
-     .OR. TPSNOW%SCHEME=='CRO') THEN  \r
-!\r
-    IF (IVERSION<7 .OR. IVERSION==7 .AND. IBUGFIX<3) THEN\r
-      YRECFM='WSNOW_'//HSURFTYPE\r
-    ELSE\r
-      YRECFM=ADJUSTL(HPREFIX//'WSN_'//HSURFTYPE)\r
-    ENDIF\r
-    CALL READ_SURF_FIELD3D(HPROGRAM,TPSNOW%WSNOW,1,TPSNOW%NLAYER,YRECFM,HDIR=YDIR)\r
-  END IF\r
-!\r
-!*       6.    Snow density\r
-!              ------------\r
-!\r
-  IF (TPSNOW%SCHEME=='1-L' .OR. TPSNOW%SCHEME=='D95' .OR. TPSNOW%SCHEME=='EBA' .OR. TPSNOW%SCHEME=='3-L' &\r
-     .OR. TPSNOW%SCHEME=='CRO') THEN  \r
-    IF (IVERSION<7 .OR. IVERSION==7 .AND. IBUGFIX<3) THEN\r
-      YRECFM='RSNOW_'//HSURFTYPE\r
-    ELSE\r
-      YRECFM=ADJUSTL(HPREFIX//'RSN_'//HSURFTYPE)\r
-    ENDIF\r
-    CALL READ_SURF_FIELD3D(HPROGRAM,TPSNOW%RHO,1,TPSNOW%NLAYER,YRECFM,HDIR=YDIR)\r
-    WHERE(TPSNOW%WSNOW(:,1:TPSNOW%NLAYER,:)==0.0)TPSNOW%RHO(:,1:TPSNOW%NLAYER,:)=XUNDEF\r
-  END IF\r
-!\r
-!*       7.    Snow temperature\r
-!              ----------------\r
-!\r
-  IF (TPSNOW%SCHEME=='1-L') THEN\r
-    IF (IVERSION<7 .OR. IVERSION==7 .AND. IBUGFIX<3) THEN\r
-      YRECFM='TSNOW_'//HSURFTYPE\r
-    ELSE\r
-      YRECFM=ADJUSTL(HPREFIX//'TSN_'//HSURFTYPE)\r
-    ENDIF\r
-    CALL READ_SURF_FIELD3D(HPROGRAM,TPSNOW%T,1,TPSNOW%NLAYER,YRECFM,HDIR=YDIR)\r
-    DO JLAYER = 1,TPSNOW%NLAYER\r
-      WHERE (TPSNOW%WSNOW(:,1,:) == 0.0) TPSNOW%T(:,JLAYER,:) = XUNDEF\r
-    ENDDO\r
-  END IF\r
-!\r
-!*       8.    Heat content\r
-!              ------------\r
-!\r
-  IF (TPSNOW%SCHEME=='3-L' .OR. TPSNOW%SCHEME=='CRO') THEN\r
-    IF (IVERSION<7 .OR. IVERSION==7 .AND. IBUGFIX<3) THEN\r
-      YRECFM='HSNOW_'//HSURFTYPE\r
-    ELSE\r
-      YRECFM=ADJUSTL(HPREFIX//'HSN_'//HSURFTYPE)\r
-    ENDIF\r
-    CALL READ_SURF_FIELD3D(HPROGRAM,TPSNOW%HEAT,1,TPSNOW%NLAYER,YRECFM,HDIR=YDIR)\r
-    DO JLAYER = 1,TPSNOW%NLAYER\r
-      WHERE (TPSNOW%WSNOW(:,1,:) == 0.0) TPSNOW%HEAT(:,JLAYER,:) = XUNDEF\r
-    ENDDO\r
-  END IF\r
-!\r
-!*       9.    Snow Gran1\r
-!              ------------\r
-!\r
-  IF (TPSNOW%SCHEME=='CRO') THEN\r
-    IF (IVERSION<7 .OR. IVERSION==7 .AND. IBUGFIX<3) THEN\r
-      YRECFM='SGRAN1_'//HSURFTYPE\r
-    ELSE\r
-      YRECFM=ADJUSTL(HPREFIX//'SG1_'//HSURFTYPE)\r
-    ENDIF\r
-    CALL READ_SURF_FIELD3D(HPROGRAM,TPSNOW%GRAN1,1,TPSNOW%NLAYER,YRECFM,HDIR=YDIR)\r
-    DO JLAYER = 1,TPSNOW%NLAYER\r
-      WHERE (TPSNOW%WSNOW(:,1,:) == 0.0) TPSNOW%GRAN1(:,JLAYER,:) = XUNDEF\r
-    ENDDO\r
-  END IF\r
-!\r
-!*       10.    Snow Gran2\r
-!              ------------\r
-!\r
-  IF (TPSNOW%SCHEME=='CRO') THEN\r
-    IF (IVERSION<7 .OR. IVERSION==7 .AND. IBUGFIX<3) THEN\r
-      YRECFM='SGRAN2_'//HSURFTYPE\r
-    ELSE\r
-      YRECFM=ADJUSTL(HPREFIX//'SG2_'//HSURFTYPE)\r
-    ENDIF\r
-    CALL READ_SURF_FIELD3D(HPROGRAM,TPSNOW%GRAN2,1,TPSNOW%NLAYER,YRECFM,HDIR=YDIR)\r
-    DO JLAYER = 1,TPSNOW%NLAYER\r
-      WHERE (TPSNOW%WSNOW(:,1,:) == 0.0) TPSNOW%GRAN2(:,JLAYER,:) = XUNDEF\r
-    ENDDO\r
-  END IF\r
-!\r
-!*       11.    Historical parameter\r
-!              -------------------\r
-!\r
-  IF (TPSNOW%SCHEME=='CRO') THEN\r
-    IF (IVERSION<7 .OR. IVERSION==7 .AND. IBUGFIX<3) THEN\r
-      YRECFM='SHIST_'//HSURFTYPE\r
-    ELSE\r
-      YRECFM=ADJUSTL(HPREFIX//'SHI_'//HSURFTYPE)\r
-    ENDIF\r
-    CALL READ_SURF_FIELD3D(HPROGRAM,TPSNOW%HIST,1,TPSNOW%NLAYER,YRECFM,HDIR=YDIR)\r
-    DO JLAYER = 1,TPSNOW%NLAYER\r
-      WHERE (TPSNOW%WSNOW(:,1,:) == 0.0) TPSNOW%HIST(:,JLAYER,:) = XUNDEF\r
-    ENDDO\r
-  END IF\r
-!\r
-!*       12.    Age parameter\r
-!              -------------------\r
-!\r
-  IF (TPSNOW%SCHEME=='CRO') THEN\r
-    IF (IVERSION<7 .OR. IVERSION==7 .AND. IBUGFIX<3) THEN\r
-      YRECFM='SAGE_'//HSURFTYPE\r
-    ELSE\r
-      YRECFM=ADJUSTL(HPREFIX//'SAG_'//HSURFTYPE)\r
-    ENDIF\r
-    CALL READ_SURF_FIELD3D(HPROGRAM,TPSNOW%AGE,1,TPSNOW%NLAYER,YRECFM,HDIR=YDIR)\r
-    DO JLAYER = 1,TPSNOW%NLAYER\r
-      WHERE (TPSNOW%WSNOW(:,1,:) == 0.0) TPSNOW%AGE(:,JLAYER,:) = XUNDEF\r
-    ENDDO\r
-  END IF\r
-!-------------------------------------------------------------------------------\r
-!\r
-!\r
-DEALLOCATE(ZWORK)\r
-!-------------------------------------------------------------------------------\r
-!\r
-!*       13.    Albedo\r
-!              ------\r
-!\r
-IF (TPSNOW%SCHEME=='D95' .OR. TPSNOW%SCHEME=='EBA' .OR. TPSNOW%SCHEME=='1-L' .OR. TPSNOW%SCHEME=='3-L' &\r
-    .OR. TPSNOW%SCHEME=='CRO') THEN  \r
-\r
-  IF (IVERSION<7 .OR. IVERSION==7 .AND. IBUGFIX<3) THEN\r
-    YRECFM='ASNOW_'//HSURFTYPE\r
-  ELSE\r
-    YRECFM=ADJUSTL(HPREFIX//'ASN_'//HSURFTYPE)\r
-  ENDIF\r
-  CALL READ_SURF_FIELD2D(HPROGRAM,TPSNOW%ALB,YRECFM,HDIR=YDIR)\r
-  WHERE (TPSNOW%WSNOW(:,1,:) == 0.0) TPSNOW%ALB(:,:) = XUNDEF\r
-END IF\r
-IF (LHOOK) CALL DR_HOOK('READ_GR_SNOW',1,ZHOOK_HANDLE)\r
-!\r
-!-------------------------------------------------------------------------------\r
-!\r
-END SUBROUTINE READ_GR_SNOW\r
+!SURFEX_LIC Copyright 1994-2014 Meteo-France 
+!SURFEX_LIC This is part of the SURFEX software governed by the CeCILL-C  licence
+!SURFEX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
+!SURFEX_LIC for details. version 1.
+!     #########
+      SUBROUTINE READ_GR_SNOW(HPROGRAM,HSURFTYPE,HPREFIX,     &
+                              KLU,KPATCH,TPSNOW,HDIR)  
+!     ##########################################################
+!
+!!****  *READ_GR_SNOW* - routine to read snow surface fields
+!!
+!!    PURPOSE
+!!    -------
+!       Initialize snow surface fields.
+!
+!!**  METHOD
+!!    ------
+!!    
+!!    
+!!
+!!    EXTERNAL
+!!    --------
+!!      
+!!       
+!!    IMPLICIT ARGUMENTS
+!!    ------------------ 
+!!
+!!    REFERENCE
+!!    ---------
+!!      
+!!      
+!!
+!!    AUTHOR
+!!    ------
+!!     V. Masson       * Meteo France *
+!!
+!!    MODIFICATIONS
+!!    -------------
+!!      Original       20/01/99
+!       F.solmon       06/00 adaptation for patch
+!       V.Masson       01/03 new version of ISBA
+!       B. Decharme    2008  If no WSNOW, WSNOW = XUNDEF
+!!      M.Moge    01/2016  using READ_SURF_FIELD2D/3D for 2D/3D surfex fields reads
+!-----------------------------------------------------------------------------
+!
+!*       0.    DECLARATIONS
+!
+USE MODD_TYPE_SNOW
+!
+USE MODI_READ_SURF
+USE MODI_READ_SURF_FIELD2D
+USE MODI_READ_SURF_FIELD3D
+!
+USE MODI_ALLOCATE_GR_SNOW
+!
+USE MODD_SURF_PAR, ONLY : XUNDEF
+USE MODD_PREP_SNOW, ONLY : LSNOW_FRAC_TOT
+!
+USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
+USE PARKIND1  ,ONLY : JPRB
+!
+IMPLICIT NONE
+!
+!*       0.1   declarations of arguments
+!
+ CHARACTER(LEN=6),   INTENT(IN)           :: HPROGRAM  ! calling program
+ CHARACTER (LEN=*),  INTENT(IN)           :: HSURFTYPE ! generic name used for
+                                                      ! snow characteristics
+                                                      ! storage in file
+ CHARACTER (LEN=3),  INTENT(IN)           :: HPREFIX   ! generic name for patch
+!                                                     ! identification                      
+INTEGER,            INTENT(IN)           :: KLU       ! horizontal size of snow var.
+INTEGER,            INTENT(IN)           :: KPATCH    ! number of tiles
+TYPE(SURF_SNOW)                          :: TPSNOW    ! snow characteristics
+ CHARACTER (LEN=1),  INTENT(IN), OPTIONAL :: HDIR      ! type of reading
+!                                                     ! HDIR = 'A' : entire field on All processors
+!                                                     ! HDIR = 'H' : distribution on each processor
+!
+!*       0.2   declarations of local variables
+!
+INTEGER             :: IRESP               ! Error code after redding
+ CHARACTER(LEN=12)   :: YRECFM              ! Name of the article to be read
+ CHARACTER(LEN=16)   :: YRECFM2 
+!
+ CHARACTER (LEN=100) :: YFMT                ! format for writing
+INTEGER             :: ISURFTYPE_LEN       ! 
+LOGICAL             :: GSNOW               ! snow written in the file
+INTEGER             :: JLAYER              ! loop counter
+CHARACTER(LEN=4)    :: YPATCH              ! number of the patch
+REAL, DIMENSION(:,:),ALLOCATABLE  :: ZWORK ! 2D array to write data in file
+ CHARACTER(LEN=1)    :: YDIR                ! type of reading
+ CHARACTER(LEN=4)    :: YNLAYER     !Format depending on the number of layers
+INTEGER             :: IVERSION, IBUGFIX
+REAL(KIND=JPRB) :: ZHOOK_HANDLE
+!-------------------------------------------------------------------------------
+!
+IF (LHOOK) CALL DR_HOOK('READ_GR_SNOW',0,ZHOOK_HANDLE)
+YDIR = 'H'
+IF (PRESENT(HDIR)) YDIR = HDIR
+!
+!-------------------------------------------------------------------------------
+ CALL READ_SURF(HPROGRAM,'VERSION',IVERSION,IRESP)
+ CALL READ_SURF(HPROGRAM,'BUG',IBUGFIX,IRESP)
+!-------------------------------------------------------------------------------
+!
+!*       1.    Type of snow scheme
+!              -------------------
+!
+ISURFTYPE_LEN=LEN_TRIM(HSURFTYPE)
+IF (IVERSION <=2 .OR. (IVERSION==3 .AND. IBUGFIX<=4)) THEN
+  WRITE(YFMT,'(A5,I1,A4)')     '(A5,A',ISURFTYPE_LEN,',A5)'
+  WRITE(YRECFM2,YFMT) 'SNOW_',HSURFTYPE,'_TYPE'
+ELSE
+  IF (IVERSION<7 .OR. IVERSION==7 .AND. IBUGFIX<3) THEN
+    WRITE(YFMT,'(A5,I1,A4)')     '(A3,A',ISURFTYPE_LEN,',A5)'
+    WRITE(YRECFM2,YFMT) 'SN_',HSURFTYPE,'_TYPE'
+  ELSE
+    WRITE(YFMT,'(A5,I1,A4)')     '(A3,A',ISURFTYPE_LEN,',A4)'
+    WRITE(YRECFM2,YFMT) 'SN_',HSURFTYPE,'_TYP'
+    YRECFM2=ADJUSTL(HPREFIX//YRECFM2)
+  ENDIF
+END IF
+!
+ CALL READ_SURF(HPROGRAM,YRECFM2,TPSNOW%SCHEME,IRESP)
+!
+!*       2.    Snow levels
+!              -----------
+!
+!
+IF (IVERSION <=2 .OR. (IVERSION==3 .AND. IBUGFIX<=4)) THEN
+  WRITE(YFMT,'(A5,I1,A4)')     '(A5,A',ISURFTYPE_LEN,',A6)'
+  WRITE(YRECFM2,YFMT) 'SNOW_',HSURFTYPE,'_LAYER'
+ELSE
+  WRITE(YFMT,'(A5,I1,A4)')     '(A3,A',ISURFTYPE_LEN,',A2)'
+  WRITE(YRECFM2,YFMT) 'SN_',HSURFTYPE,'_N'
+  IF (IVERSION>7 .OR. IVERSION==7 .AND. IBUGFIX>=3) YRECFM2=ADJUSTL(HPREFIX//YRECFM2)
+END IF
+!
+ CALL READ_SURF(HPROGRAM,YRECFM2,TPSNOW%NLAYER,IRESP)
+!
+!*       2.    Presence of snow fields in the file
+!              -----------------------------------
+!
+IF (IVERSION >6 .OR. (IVERSION==6 .AND. IBUGFIX>=1)) THEN
+  WRITE(YFMT,'(A5,I1,A1)')     '(A3,A',ISURFTYPE_LEN,')'
+  WRITE(YRECFM,YFMT) 'SN_',HSURFTYPE
+  IF (IVERSION>7 .OR. IVERSION==7 .AND. IBUGFIX>=3) YRECFM=ADJUSTL(HPREFIX//YRECFM)
+  CALL READ_SURF(HPROGRAM,YRECFM,GSNOW,IRESP)
+ELSE
+  IF (TPSNOW%NLAYER==0) THEN
+    GSNOW = .FALSE.
+    IF (TPSNOW%SCHEME=='D95' .OR. TPSNOW%SCHEME=='1-L' .OR. TPSNOW%SCHEME=='EBA') TPSNOW%NLAYER=1
+    IF (TPSNOW%SCHEME=='3-L' .OR. TPSNOW%SCHEME=='CRO'                          ) TPSNOW%NLAYER=3
+  ELSE
+    GSNOW = .TRUE.
+  END IF
+END IF
+!
+!-------------------------------------------------------------------------------
+!
+!*       3.    Allocations
+!              -----------
+!
+ CALL ALLOCATE_GR_SNOW(TPSNOW,KLU,KPATCH)
+!
+IF (.NOT. GSNOW) THEN
+  IF (LHOOK) CALL DR_HOOK('READ_GR_SNOW',1,ZHOOK_HANDLE)
+  RETURN
+END IF
+!-------------------------------------------------------------------------------
+!
+!*       4.    Additional key
+!              ---------------
+!
+IF (IVERSION >= 7 .AND. HSURFTYPE=='VEG') CALL READ_SURF(HPROGRAM,'LSNOW_FRAC_T',LSNOW_FRAC_TOT,IRESP)
+!
+!-------------------------------------------------------------------------------
+!
+!*       5.    Snow reservoir
+!              --------------
+!
+ALLOCATE(ZWORK(SIZE(TPSNOW%WSNOW,1),SIZE(TPSNOW%WSNOW,3)))
+!
+  IF (TPSNOW%SCHEME=='1-L' .OR. TPSNOW%SCHEME=='D95' .OR. TPSNOW%SCHEME=='EBA' .OR. TPSNOW%SCHEME=='3-L' &
+     .OR. TPSNOW%SCHEME=='CRO') THEN  
+!
+    IF (IVERSION<7 .OR. IVERSION==7 .AND. IBUGFIX<3) THEN
+      YRECFM='WSNOW_'//HSURFTYPE
+    ELSE
+      YRECFM=ADJUSTL(HPREFIX//'WSN_'//HSURFTYPE)
+    ENDIF
+    CALL READ_SURF_FIELD3D(HPROGRAM,TPSNOW%WSNOW,1,TPSNOW%NLAYER,YRECFM,HDIR=YDIR)
+  END IF
+!
+!*       6.    Snow density
+!              ------------
+!
+  IF (TPSNOW%SCHEME=='1-L' .OR. TPSNOW%SCHEME=='D95' .OR. TPSNOW%SCHEME=='EBA' .OR. TPSNOW%SCHEME=='3-L' &
+     .OR. TPSNOW%SCHEME=='CRO') THEN  
+    IF (IVERSION<7 .OR. IVERSION==7 .AND. IBUGFIX<3) THEN
+      YRECFM='RSNOW_'//HSURFTYPE
+    ELSE
+      YRECFM=ADJUSTL(HPREFIX//'RSN_'//HSURFTYPE)
+    ENDIF
+    CALL READ_SURF_FIELD3D(HPROGRAM,TPSNOW%RHO,1,TPSNOW%NLAYER,YRECFM,HDIR=YDIR)
+    WHERE(TPSNOW%WSNOW(:,1:TPSNOW%NLAYER,:)==0.0)TPSNOW%RHO(:,1:TPSNOW%NLAYER,:)=XUNDEF
+  END IF
+!
+!*       7.    Snow temperature
+!              ----------------
+!
+  IF (TPSNOW%SCHEME=='1-L') THEN
+    IF (IVERSION<7 .OR. IVERSION==7 .AND. IBUGFIX<3) THEN
+      YRECFM='TSNOW_'//HSURFTYPE
+    ELSE
+      YRECFM=ADJUSTL(HPREFIX//'TSN_'//HSURFTYPE)
+    ENDIF
+    CALL READ_SURF_FIELD3D(HPROGRAM,TPSNOW%T,1,TPSNOW%NLAYER,YRECFM,HDIR=YDIR)
+    DO JLAYER = 1,TPSNOW%NLAYER
+      WHERE (TPSNOW%WSNOW(:,1,:) == 0.0) TPSNOW%T(:,JLAYER,:) = XUNDEF
+    ENDDO
+  END IF
+!
+!*       8.    Heat content
+!              ------------
+!
+  IF (TPSNOW%SCHEME=='3-L' .OR. TPSNOW%SCHEME=='CRO') THEN
+    IF (IVERSION<7 .OR. IVERSION==7 .AND. IBUGFIX<3) THEN
+      YRECFM='HSNOW_'//HSURFTYPE
+    ELSE
+      YRECFM=ADJUSTL(HPREFIX//'HSN_'//HSURFTYPE)
+    ENDIF
+    CALL READ_SURF_FIELD3D(HPROGRAM,TPSNOW%HEAT,1,TPSNOW%NLAYER,YRECFM,HDIR=YDIR)
+    DO JLAYER = 1,TPSNOW%NLAYER
+      WHERE (TPSNOW%WSNOW(:,1,:) == 0.0) TPSNOW%HEAT(:,JLAYER,:) = XUNDEF
+    ENDDO
+  END IF
+!
+!*       9.    Snow Gran1
+!              ------------
+!
+  IF (TPSNOW%SCHEME=='CRO') THEN
+    IF (IVERSION<7 .OR. IVERSION==7 .AND. IBUGFIX<3) THEN
+      YRECFM='SGRAN1_'//HSURFTYPE
+    ELSE
+      YRECFM=ADJUSTL(HPREFIX//'SG1_'//HSURFTYPE)
+    ENDIF
+    CALL READ_SURF_FIELD3D(HPROGRAM,TPSNOW%GRAN1,1,TPSNOW%NLAYER,YRECFM,HDIR=YDIR)
+    DO JLAYER = 1,TPSNOW%NLAYER
+      WHERE (TPSNOW%WSNOW(:,1,:) == 0.0) TPSNOW%GRAN1(:,JLAYER,:) = XUNDEF
+    ENDDO
+  END IF
+!
+!*       10.    Snow Gran2
+!              ------------
+!
+  IF (TPSNOW%SCHEME=='CRO') THEN
+    IF (IVERSION<7 .OR. IVERSION==7 .AND. IBUGFIX<3) THEN
+      YRECFM='SGRAN2_'//HSURFTYPE
+    ELSE
+      YRECFM=ADJUSTL(HPREFIX//'SG2_'//HSURFTYPE)
+    ENDIF
+    CALL READ_SURF_FIELD3D(HPROGRAM,TPSNOW%GRAN2,1,TPSNOW%NLAYER,YRECFM,HDIR=YDIR)
+    DO JLAYER = 1,TPSNOW%NLAYER
+      WHERE (TPSNOW%WSNOW(:,1,:) == 0.0) TPSNOW%GRAN2(:,JLAYER,:) = XUNDEF
+    ENDDO
+  END IF
+!
+!*       11.    Historical parameter
+!              -------------------
+!
+  IF (TPSNOW%SCHEME=='CRO') THEN
+    IF (IVERSION<7 .OR. IVERSION==7 .AND. IBUGFIX<3) THEN
+      YRECFM='SHIST_'//HSURFTYPE
+    ELSE
+      YRECFM=ADJUSTL(HPREFIX//'SHI_'//HSURFTYPE)
+    ENDIF
+    CALL READ_SURF_FIELD3D(HPROGRAM,TPSNOW%HIST,1,TPSNOW%NLAYER,YRECFM,HDIR=YDIR)
+    DO JLAYER = 1,TPSNOW%NLAYER
+      WHERE (TPSNOW%WSNOW(:,1,:) == 0.0) TPSNOW%HIST(:,JLAYER,:) = XUNDEF
+    ENDDO
+  END IF
+!
+!*       12.    Age parameter
+!              -------------------
+!
+  IF (TPSNOW%SCHEME=='CRO') THEN
+    IF (IVERSION<7 .OR. IVERSION==7 .AND. IBUGFIX<3) THEN
+      YRECFM='SAGE_'//HSURFTYPE
+    ELSE
+      YRECFM=ADJUSTL(HPREFIX//'SAG_'//HSURFTYPE)
+    ENDIF
+    CALL READ_SURF_FIELD3D(HPROGRAM,TPSNOW%AGE,1,TPSNOW%NLAYER,YRECFM,HDIR=YDIR)
+    DO JLAYER = 1,TPSNOW%NLAYER
+      WHERE (TPSNOW%WSNOW(:,1,:) == 0.0) TPSNOW%AGE(:,JLAYER,:) = XUNDEF
+    ENDDO
+  END IF
+!-------------------------------------------------------------------------------
+!
+!
+DEALLOCATE(ZWORK)
+!-------------------------------------------------------------------------------
+!
+!*       13.    Albedo
+!              ------
+!
+IF (TPSNOW%SCHEME=='D95' .OR. TPSNOW%SCHEME=='EBA' .OR. TPSNOW%SCHEME=='1-L' .OR. TPSNOW%SCHEME=='3-L' &
+    .OR. TPSNOW%SCHEME=='CRO') THEN  
+
+  IF (IVERSION<7 .OR. IVERSION==7 .AND. IBUGFIX<3) THEN
+    YRECFM='ASNOW_'//HSURFTYPE
+  ELSE
+    YRECFM=ADJUSTL(HPREFIX//'ASN_'//HSURFTYPE)
+  ENDIF
+  CALL READ_SURF_FIELD2D(HPROGRAM,TPSNOW%ALB,YRECFM,HDIR=YDIR)
+  WHERE (TPSNOW%WSNOW(:,1,:) == 0.0) TPSNOW%ALB(:,:) = XUNDEF
+END IF
+IF (LHOOK) CALL DR_HOOK('READ_GR_SNOW',1,ZHOOK_HANDLE)
+!
+!-------------------------------------------------------------------------------
+!
+END SUBROUTINE READ_GR_SNOW
index 9c84ca7..a617418 100644 (file)
-!SURFEX_LIC Copyright 1994-2014 Meteo-France \r
-!SURFEX_LIC This is part of the SURFEX software governed by the CeCILL-C  licence\r
-!SURFEX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt\r
-!SURFEX_LIC for details. version 1.\r
-!     #########\r
-      SUBROUTINE READ_ISBA_n(HPROGRAM)\r
-!     ##################################\r
-!\r
-!!****  *READ_ISBA_n* - routine to initialise ISBA variables\r
-!!                         \r
-!!\r
-!!    PURPOSE\r
-!!    -------\r
-!!\r
-!!**  METHOD\r
-!!    ------\r
-!!\r
-!!    EXTERNAL\r
-!!    --------\r
-!!\r
-!!\r
-!!    IMPLICIT ARGUMENTS\r
-!!    ------------------\r
-!!\r
-!!    REFERENCE\r
-!!    ---------\r
-!!\r
-!!\r
-!!    AUTHOR\r
-!!    ------\r
-!!     V. Masson   *Meteo France*      \r
-!!\r
-!!    MODIFICATIONS\r
-!!    -------------\r
-!!      Original    01/2003\r
-!!\r
-!!      READ_SURF for general reading : 08/2003 (S.Malardel)\r
-!!      B. Decharme  2008    : Floodplains\r
-!!      B. Decharme  01/2009 : Optional Arpege deep soil temperature read\r
-!!      A.L. Gibelin   03/09 : modifications for CENTURY model \r
-!!      A.L. Gibelin    04/2009 : BIOMASS and RESP_BIOMASS arrays \r
-!!      A.L. Gibelin    06/2009 : Soil carbon variables for CNT option\r
-!!      B. Decharme  09/2012 : suppress NWG_LAYER (parallelization problems)\r
-!!     M.Moge    01/2016  using READ_SURF_FIELD2D/3D for 2D/3D surfex fields reads\r
-!!\r
-!-------------------------------------------------------------------------------\r
-!\r
-!*       0.    DECLARATIONS\r
-!              ------------\r
-!\r
-!\r
-USE MODD_CO2V_PAR,       ONLY : XANFMINIT, XCONDCTMIN\r
-USE MODD_ISBA_n,         ONLY : NGROUND_LAYER, NPATCH, NNBIOMASS,   &\r
-                                  NNLITTER, NNLITTLEVS, NNSOILCARB,   &\r
-                                  CPHOTO, CRESPSL, XTSRAD_NAT,        &\r
-                                  XTG, XWG, XWGI, XWR, XLAI, TSNOW,   &\r
-                                  XRESA, XANFM, XAN, XLE, XANDAY,     &\r
-                                  XBSLAI, XBIOMASS, XRESP_BIOMASS,    &\r
-                                  XLITTER, XSOILCARB, XLIGNIN_STRUC,  &\r
-                                  LFLOOD, XZ0_FLOOD, LTEMP_ARP,       &\r
-                                  NTEMPLAYER_ARP, LGLACIER, XICE_STO  \r
-!                                \r
-USE MODD_SURF_PAR,       ONLY : XUNDEF, NUNDEF\r
-USE MODD_SNOW_PAR,       ONLY : XZ0SN\r
-!\r
-USE MODI_READ_SURF\r
-USE MODI_READ_SURF_FIELD3D\r
-USE MODI_READ_SURF_FIELD2D\r
-!\r
-USE MODI_READ_GR_SNOW\r
-!\r
-USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK\r
-USE PARKIND1  ,ONLY : JPRB\r
-!\r
-USE MODI_GET_TYPE_DIM_n\r
-!\r
-IMPLICIT NONE\r
-!\r
-!*       0.1   Declarations of arguments\r
-!              -------------------------\r
-!\r
- CHARACTER(LEN=6),  INTENT(IN)  :: HPROGRAM ! calling program\r
-!\r
-!*       0.2   Declarations of local variables\r
-!              -------------------------------\r
-INTEGER           :: ILU          ! 1D physical dimension\r
-!\r
-INTEGER           :: IRESP          ! Error code after redding\r
-!\r
- CHARACTER(LEN=12) :: YRECFM         ! Name of the article to be read\r
-!\r
- CHARACTER(LEN=4)  :: YLVL\r
- CHARACTER(LEN=8)  :: YPATCH\r
-!\r
-REAL, DIMENSION(:,:),ALLOCATABLE  :: ZWORK      ! 2D array to write data in file\r
-!\r
-INTEGER :: IWORK   ! Work integer\r
-!\r
-INTEGER :: JP, JL, JNBIOMASS, JNLITTER, JNSOILCARB, JNLITTLEVS  ! loop counter on layers\r
-!\r
-INTEGER           :: IVERSION       ! surface version\r
-INTEGER           :: IBUGFIX\r
-!\r
-REAL(KIND=JPRB) :: ZHOOK_HANDLE\r
-!\r
-!-------------------------------------------------------------------------------\r
-!\r