1ef7052c53c8657d0e5d12e5db556d92f00da8ea
[MNH-git_open_source-lfs.git] / src / SURFEX / prep_teb_garden_extern.F90
1 !SURFEX_LIC Copyright 1994-2014 Meteo-France 
2 !SURFEX_LIC This is part of the SURFEX software governed by the CeCILL-C  licence
3 !SURFEX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
4 !SURFEX_LIC for details. version 1.
5 !     #########
6 SUBROUTINE PREP_TEB_GARDEN_EXTERN(HPROGRAM,HSURF,HFILE,HFILETYPE,HFILEPGD,HFILEPGDTYPE,KLUOUT,PFIELD)
7 !     #################################################################################
8 !
9 !!****  *PREP_TEB_GARDEN_EXTERN* - initializes ISBA fields from operational GRIB
10 !!
11 !!    PURPOSE
12 !!    -------
13 !
14 !!**  METHOD
15 !!    ------
16 !!
17 !!    REFERENCE
18 !!    ---------
19 !!      
20 !!
21 !!    AUTHOR
22 !!    ------
23 !!     V. Masson 
24 !!
25 !!    MODIFICATIONS
26 !!    -------------
27 !!      Original    01/2004
28 !!      M.Moge    01/2016  using READ_SURF_FIELD2D/3D for 2D/3D surfex fields reads
29 !!------------------------------------------------------------------
30 !
31
32 !
33 USE MODE_READ_EXTERN
34 !
35 USE MODD_TYPE_DATE_SURF
36 !
37 USE MODI_PREP_GRID_EXTERN
38 USE MODI_READ_SURF
39 USE MODI_INTERP_GRID
40 USE MODI_OPEN_AUX_IO_SURF
41 USE MODI_CLOSE_AUX_IO_SURF
42 USE MODI_READ_TEB_PATCH
43 USE MODI_GET_CURRENT_TEB_PATCH
44 USE MODI_TOWN_PRESENCE
45 !
46 USE MODD_PREP,           ONLY : CINGRID_TYPE, CINTERP_TYPE
47 USE MODD_PREP_TEB_GARDEN,ONLY : XGRID_SOIL, XWR_DEF
48 USE MODD_DATA_COVER_PAR, ONLY : NVEGTYPE
49 USE MODD_SURF_PAR,       ONLY : XUNDEF
50 !
51 USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
52 USE PARKIND1  ,ONLY : JPRB
53 !
54 USE MODI_PUT_ON_ALL_VEGTYPES
55 !
56 USE MODI_READ_SURF_FIELD2D
57 !
58 IMPLICIT NONE
59 !
60 !*      0.1    declarations of arguments
61 !
62  CHARACTER(LEN=6),   INTENT(IN)  :: HPROGRAM  ! program calling surf. schemes
63  CHARACTER(LEN=7),   INTENT(IN)  :: HSURF     ! type of field
64  CHARACTER(LEN=28),  INTENT(IN)  :: HFILE     ! name of file
65  CHARACTER(LEN=6),   INTENT(IN)  :: HFILETYPE ! type of input file
66  CHARACTER(LEN=28),  INTENT(IN)  :: HFILEPGD     ! name of file
67  CHARACTER(LEN=6),   INTENT(IN)  :: HFILEPGDTYPE ! type of input file
68 INTEGER,            INTENT(IN)  :: KLUOUT    ! logical unit of output listing
69 REAL,DIMENSION(:,:,:), POINTER  :: PFIELD    ! field to interpolate horizontally (on final soil grid)
70 !
71 !*      0.2    declarations of local variables
72 !
73  CHARACTER(LEN=12) :: YRECFM        ! Name of the article to be read
74 INTEGER           :: IRESP          ! reading return code
75 INTEGER           :: INI            ! total 1D dimension
76 INTEGER           :: IPATCH         ! number of patch
77 !
78 REAL, DIMENSION(:,:,:), POINTER     :: ZFIELD         ! field read on initial MNH vertical soil grid, all patches
79 REAL, DIMENSION(:,:),   POINTER     :: ZFIELD1        ! field read on initial MNH vertical soil grid, one patch
80 REAL, DIMENSION(:,:,:), POINTER     :: ZD             ! depth of field in the soil
81 REAL, DIMENSION(:,:), POINTER       :: ZD1            ! depth of field in the soil, one patch
82 REAL, DIMENSION(:,:), ALLOCATABLE   :: ZOUT           !
83 INTEGER                             :: JPATCH         ! loop counter for patch
84 INTEGER                             :: ITEB_PATCH     ! number of TEB patches in file
85 INTEGER                             :: ICURRENT_PATCH ! current TEB patch to be initialized
86 INTEGER                             :: IVERSION       ! SURFEX version
87 INTEGER                             :: IBUGFIX        ! SURFEX bug version
88 LOGICAL                             :: GOLD_NAME      ! old name flag for temperatures
89  CHARACTER(LEN=12)                   :: YSURF     ! type of field
90  CHARACTER(LEN=3)                    :: YPATCH    ! indentificator for TEB patch
91  CHARACTER(LEN=4)                    :: YPATCH2   ! number of the patch
92 LOGICAL                         :: GTEB      ! flag if TEB fields are present
93 LOGICAL                         :: GGARDEN   ! T if gardens are present in the file
94 REAL(KIND=JPRB) :: ZHOOK_HANDLE
95 !
96 !------------------------------------------------------------------------------
97 !
98 !*      1.     Preparation of IO for reading in the file
99 !              -----------------------------------------
100 !
101 !* Note that all points are read, even those without physical meaning.
102 !  These points will not be used during the horizontal interpolation step.
103 !  Their value must be defined as XUNDEF.
104 !
105 IF (LHOOK) CALL DR_HOOK('PREP_TEB_GARDEN_EXTERN',0,ZHOOK_HANDLE)
106 !
107 !------------------------------------------------------------------------------
108 !
109 !*      2.     Reading of grid
110 !              ---------------
111 !
112  CALL OPEN_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE,'TOWN  ')
113 !
114 !* reading of version of the file being read
115  CALL READ_SURF(HFILEPGDTYPE,'VERSION',IVERSION,IRESP)
116  CALL READ_SURF(HFILEPGDTYPE,'BUG',IBUGFIX,IRESP)
117 GOLD_NAME=(IVERSION<7 .OR. (IVERSION==7 .AND. IBUGFIX<3))
118 !
119  CALL PREP_GRID_EXTERN(HFILEPGDTYPE,KLUOUT,CINGRID_TYPE,CINTERP_TYPE,INI)
120 !
121 !* reads if TEB fields exist in the input file
122  CALL TOWN_PRESENCE(HFILEPGDTYPE,GTEB)
123 !
124 IF (GTEB) THEN
125   CALL READ_TEB_PATCH(HFILEPGDTYPE,ITEB_PATCH)
126   CALL GET_CURRENT_TEB_PATCH(ICURRENT_PATCH)
127   YPATCH='   '
128   IF (ITEB_PATCH>1) THEN
129     WRITE(YPATCH,FMT='(A,I1,A)') 'T',MIN(ICURRENT_PATCH,ITEB_PATCH),'_'
130   END IF
131 END IF
132 !
133 !---------------------------------------------------------------------------------------
134 !
135 !*      3.     Transformation into physical quantity to be interpolated
136 !              --------------------------------------------------------
137 !
138 SELECT CASE(HSURF)
139 !
140 !*     3.      Orography
141 !              ---------
142 !
143   CASE('ZS     ')
144     ALLOCATE(PFIELD(INI,1,1))
145     YRECFM='ZS'
146     CALL READ_SURF(HFILEPGDTYPE,YRECFM,PFIELD(:,1,1),IRESP,HDIR='A')
147     CALL CLOSE_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE)
148 !
149 !--------------------------------------------------------------------------
150 !
151 !
152 !*      3.1    Profile of temperature, water or ice in the soil
153 !
154   CASE('TG    ','WG    ','WGI   ')
155 !* choice if one reads garden fields (if present) or ISBA fields
156     GGARDEN = .FALSE.
157     IF (GTEB) CALL READ_SURF(HFILEPGDTYPE,'GARDEN',GGARDEN,IRESP)
158     CALL CLOSE_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE)
159     IF (GGARDEN) THEN
160       YSURF = 'GD_'//HSURF(1:3)
161       IF (GOLD_NAME) YSURF = 'TWN_'//HSURF(1:3)
162       YSURF = YPATCH//YSURF
163     ELSE
164       YSURF = HSURF
165     END IF
166     YSURF=ADJUSTL(YSURF)  
167 !* reading of the profile and its depth definition
168      CALL READ_EXTERN_ISBA(HFILE,HFILETYPE,HFILEPGD,HFILEPGDTYPE,KLUOUT,INI,&
169                 HSURF,YSURF,ZFIELD,ZD)
170
171      ALLOCATE(ZFIELD1(SIZE(ZFIELD,1),SIZE(ZFIELD,2)))
172      ALLOCATE(ZD1(SIZE(ZFIELD,1),SIZE(ZFIELD,2)))
173      ALLOCATE(ZOUT(SIZE(ZFIELD,1),SIZE(XGRID_SOIL)))
174      ALLOCATE(PFIELD(SIZE(ZFIELD,1),SIZE(XGRID_SOIL),SIZE(ZFIELD,3)))
175 !
176      DO JPATCH=1,SIZE(ZFIELD,3)
177         ZFIELD1(:,:)=ZFIELD(:,:,JPATCH)
178         ZD1(:,:)=ZD(:,:,JPATCH)
179         CALL INTERP_GRID(ZD1,ZFIELD1,XGRID_SOIL,ZOUT)
180         PFIELD(:,:,JPATCH)=ZOUT(:,:)
181      END DO
182 !
183      DEALLOCATE(ZFIELD)
184      DEALLOCATE(ZOUT)
185      DEALLOCATE(ZFIELD1)
186      DEALLOCATE(ZD)
187 !
188 !--------------------------------------------------------------------------
189 !
190 !*      3.4    Water content intercepted on leaves, LAI
191 !
192   CASE('WR     ')
193      ALLOCATE(PFIELD(INI,1,NVEGTYPE))
194      !* choice if one reads garden fields (if present) or ISBA fields    
195      GGARDEN = .FALSE.
196      IF (GTEB) CALL READ_SURF(HFILEPGDTYPE,'GARDEN',GGARDEN,IRESP)
197      CALL CLOSE_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE)
198      IF (GGARDEN) THEN
199        IPATCH = 1    
200        YRECFM = 'GD_WR'
201        IF (GOLD_NAME) YRECFM = 'TWN_WR'
202        YRECFM = YPATCH//YRECFM
203        CALL OPEN_AUX_IO_SURF(HFILE,HFILETYPE,'TOWN  ')
204      ELSE            
205        YRECFM = 'PATCH_NUMBER'
206        CALL OPEN_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE,'NATURE')
207        CALL READ_SURF(HFILEPGDTYPE,YRECFM,IPATCH,IRESP)
208        CALL CLOSE_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE)
209        CALL OPEN_AUX_IO_SURF(HFILE,HFILETYPE,'NATURE')
210        YRECFM = 'WR'
211      END IF
212      YRECFM=ADJUSTL(YRECFM)
213      
214      ALLOCATE(ZFIELD(INI,1,IPATCH))
215      CALL READ_SURF_FIELD2D(HFILETYPE,ZFIELD(:,1,:),YRECFM,HDIR='A')
216      CALL CLOSE_AUX_IO_SURF(HFILE,HFILETYPE)
217      CALL PUT_ON_ALL_VEGTYPES(INI,1,1,NVEGTYPE,ZFIELD,PFIELD)
218      DEALLOCATE(ZFIELD)
219 !
220   CASE('LAI    ')
221      CALL CLOSE_AUX_IO_SURF(HFILEPGD,HFILEPGDTYPE)
222      ALLOCATE(PFIELD(INI,1,NVEGTYPE))
223      PFIELD(:,:,:) = XUNDEF
224 !
225 END SELECT
226 !
227 !
228 !---------------------------------------------------------------------------
229 !
230 !*      6.     End of IO
231 !              ---------
232 !
233 IF (LHOOK) CALL DR_HOOK('PREP_TEB_GARDEN_EXTERN',1,ZHOOK_HANDLE)
234 !
235 !---------------------------------------------------------------------------
236 !---------------------------------------------------------------------------
237 END SUBROUTINE PREP_TEB_GARDEN_EXTERN