Juan 8/12/2016: add management of LEN_HREC in MNH & SURFEX
[MNH-git_open_source-lfs.git] / src / SURFEX / writesurf_tebn.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 WRITESURF_TEB_n(HPROGRAM,KPATCH,HWRITE)
7 !     ####################################
8 !
9 !!****  *WRITE_TEB_n* - writes TEB fields
10 !!
11 !!    PURPOSE
12 !!    -------
13 !!
14 !!**  METHOD
15 !!    ------
16 !!
17 !!    EXTERNAL
18 !!    --------
19 !!
20 !!
21 !!    IMPLICIT ARGUMENTS
22 !!    ------------------
23 !!
24 !!    REFERENCE
25 !!    ---------
26 !!
27 !!
28 !!    AUTHOR
29 !!    ------
30 !!      V. Masson   *Meteo France*      
31 !!
32 !!    MODIFICATIONS
33 !!    -------------
34 !!      Original    01/2003 
35 !-------------------------------------------------------------------------------
36 !
37 !*       0.    DECLARATIONS
38 !              ------------
39 !
40 !
41 USE MODD_TEB_n,          ONLY : LGARDEN, LGREENROOF, CBEM,      &
42                                 NROOF_LAYER, XT_ROOF, XWS_ROOF, &
43                                 NROAD_LAYER, XT_ROAD, XWS_ROAD, &
44                                 NWALL_LAYER,XT_WALL_A,XT_WALL_B,&
45                                 XTI_ROAD,                       &
46                                 TSNOW_ROOF, TSNOW_ROAD,         &
47                                 XT_CANYON, XQ_CANYON,           &
48                                 TTIME, NTEB_PATCH, CROAD_DIR,   &
49                                 XROAD_DIR,                      &
50                                 CWALL_OPT, XROAD_DIR
51 USE MODD_BEM_n,          ONLY : NFLOOR_LAYER, XT_FLOOR,         &
52                                 XT_MASS, XT_WIN1, XT_WIN2,      &
53                                 XQI_BLD, XTI_BLD                                 
54 !
55 USE MODD_DATA_TEB_n,     ONLY : LDATA_ROAD_DIR
56 !
57 USE MODI_WRITE_SURF
58 USE MODI_WRITESURF_GR_SNOW
59 USE MODI_WRITESURF_TEB_GARDEN_n
60 USE MODI_WRITESURF_TEB_GREENROOF_n
61 !
62 !
63 USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
64 USE PARKIND1  ,ONLY : JPRB
65 !
66 IMPLICIT NONE
67 !
68 #ifndef NOMPI
69 INCLUDE "mpif.h"
70 #endif
71 !
72 !*       0.1   Declarations of arguments
73 !              -------------------------
74 !
75  CHARACTER(LEN=6),  INTENT(IN)  :: HPROGRAM ! program calling
76 INTEGER,           INTENT(IN)  :: KPATCH   ! current TEB patch
77  CHARACTER(LEN=3),    INTENT(IN)  :: HWRITE    ! 'PREP' : does not write SBL XUNDEF fields
78 !                                             ! 'ALL' : all fields are written
79 !
80 !*       0.2   Declarations of local variables
81 !              -------------------------------
82 !
83 INTEGER           :: IRESP           ! IRESP  : return-code if a problem appears
84  CHARACTER(LEN=LEN_HREC) :: YRECFM         ! Name of the article to be read
85  CHARACTER(LEN=100):: YCOMMENT       ! Comment string
86  CHARACTER(LEN=3)  :: YPATCH         ! Patch identificator
87  CHARACTER(LEN=7)  :: YDIR           ! Direction identificator
88  CHARACTER(LEN=100):: YSTRING        ! Comment string
89 !
90 INTEGER :: JLAYER ! loop on surface layers
91 REAL(KIND=JPRB) :: ZHOOK_HANDLE
92 !
93 !-------------------------------------------------------------------------------
94 !
95 IF (LHOOK) CALL DR_HOOK('WRITESURF_TEB_N',0,ZHOOK_HANDLE)
96 !
97 YPATCH='   '
98 IF (NTEB_PATCH>1) WRITE(YPATCH,FMT='(A,I1,A)') 'T',KPATCH,'_'
99 !
100 !
101 !*       2.     Option for road orientation:
102 !               ---------------------------
103 !
104 YCOMMENT='Option for Road orientation in TEB scheme'
105  CALL WRITE_SURF(HPROGRAM,'ROAD_DIR',CROAD_DIR,IRESP,YCOMMENT)
106 YCOMMENT='Option for Wall representation in TEB scheme'
107  CALL WRITE_SURF(HPROGRAM,'WALL_OPT',CWALL_OPT,IRESP,YCOMMENT)
108 !
109 !*       3.     Prognostic fields:
110 !               -----------------
111 !
112 !* roof temperatures
113 !
114
115 DO JLAYER=1,NROOF_LAYER
116   WRITE(YRECFM,'(A3,A5,I1.1,A1)') YPATCH,'TROOF',JLAYER,' '
117   WRITE(YCOMMENT,'(A9,I1.1,A4)') 'X_Y_TROOF',JLAYER,' (K)'
118   YRECFM=ADJUSTL(YRECFM)
119  CALL WRITE_SURF(HPROGRAM,YRECFM,XT_ROOF(:,JLAYER),IRESP,HCOMMENT=YCOMMENT)
120 END DO
121
122 !
123 !* roof water content
124 !
125
126 YRECFM=YPATCH//'WS_ROOF'
127 YRECFM=ADJUSTL(YRECFM)
128 YCOMMENT='WS_ROOF (kg/m2)'
129  CALL WRITE_SURF(HPROGRAM,YRECFM,XWS_ROOF(:),IRESP,HCOMMENT=YCOMMENT)
130 !
131 !* road temperatures
132 !
133
134 DO JLAYER=1,NROAD_LAYER
135   WRITE(YRECFM,'(A3,A5,I1.1,A1)') YPATCH,'TROAD',JLAYER,' '
136   YRECFM=ADJUSTL(YRECFM)
137   IF (CROAD_DIR=='UNIF' .OR. LDATA_ROAD_DIR) THEN
138     YSTRING = 'X_Y_TROAD'
139   ELSEIF (SIZE(XROAD_DIR)>0) THEN
140     !* road direction is uniform spatially, one can then indicate it in the comment
141     CALL ROAD_DIR(XROAD_DIR(1),YDIR)
142     YSTRING=TRIM(YDIR)//' ROAD TEMP. LAYER '
143   ELSE
144     YSTRING='? ROAD TEMP. LAYER '
145   ENDIF
146   WRITE(YCOMMENT,'(A,I1.1,A4)') TRIM(YSTRING), JLAYER,' (K)'
147   CALL WRITE_SURF(HPROGRAM,YRECFM,XT_ROAD(:,JLAYER),IRESP,HCOMMENT=YCOMMENT)
148 END DO
149 !
150 !* road water content
151 !
152
153 YRECFM=YPATCH//'WS_ROAD'
154 YRECFM=ADJUSTL(YRECFM)
155 YCOMMENT='WS_ROAD (kg/m2)'
156  CALL WRITE_SURF(HPROGRAM,YRECFM,XWS_ROAD(:),IRESP,HCOMMENT=YCOMMENT)
157 !
158 !* wall temperatures
159 !
160
161 DO JLAYER=1,NWALL_LAYER
162  IF (CWALL_OPT=='UNIF') THEN
163   WRITE(YRECFM,'(A3,A5,I1.1,A1)') YPATCH,'TWALL',JLAYER,' '
164   YRECFM=ADJUSTL(YRECFM)
165   WRITE(YCOMMENT,'(A9,I1.1,A4)') 'X_Y_TWALL',JLAYER,' (K)'
166   CALL WRITE_SURF(HPROGRAM,YRECFM,XT_WALL_A(:,JLAYER),IRESP,HCOMMENT=YCOMMENT)
167  ELSE
168   !* Wall A
169   WRITE(YRECFM,'(A3,A6,I1.1)') YPATCH,'TWALLA',JLAYER
170   YRECFM=ADJUSTL(YRECFM)
171   IF (LDATA_ROAD_DIR) THEN
172     YSTRING = 'X_Y_TWALL_A'
173   ELSEIF (SIZE(XROAD_DIR)>0) THEN
174     !* wall direction is uniform spatially, one can then indicate it in the comment
175     CALL WALLA_DIR(XROAD_DIR(1),YDIR)
176     YSTRING=TRIM(YDIR)//'-FACING WALL TEMP. LAYER '
177   ELSE
178     YSTRING='?-FACING WALL TEMP. LAYER '
179   ENDIF
180   WRITE(YCOMMENT,'(A,I1.1,A4)') TRIM(YSTRING), JLAYER,' (K)'
181   CALL WRITE_SURF(HPROGRAM,YRECFM,XT_WALL_A(:,JLAYER),IRESP,HCOMMENT=YCOMMENT)
182   !
183   !* Wall B
184   WRITE(YRECFM,'(A3,A6,I1.1)') YPATCH,'TWALLB',JLAYER
185   YRECFM=ADJUSTL(YRECFM)
186   IF (LDATA_ROAD_DIR) THEN
187     YSTRING = 'X_Y_TWALL_B'
188   ELSEIF (SIZE(XROAD_DIR)>0) THEN
189     !* wall direction is uniform spatially, one can then indicate it in the comment
190     CALL WALLB_DIR(XROAD_DIR(1),YDIR)
191     YSTRING=TRIM(YDIR)//'-FACING WALL TEMP. LAYER '
192   ELSE
193     YSTRING='?-FACING WALL TEMP. LAYER '
194   ENDIF
195   WRITE(YCOMMENT,'(A,I1.1,A4)') TRIM(YSTRING), JLAYER,' (K)'
196   CALL WRITE_SURF(HPROGRAM,YRECFM,XT_WALL_B(:,JLAYER),IRESP,HCOMMENT=YCOMMENT)
197  END IF
198 END DO
199 !
200 !* internal building temperature
201 !
202 YRECFM=YPATCH//'TI_BLD'
203 YRECFM=ADJUSTL(YRECFM)
204 YCOMMENT='TI_BLD (K)'
205  CALL WRITE_SURF(HPROGRAM,YRECFM,XTI_BLD(:),IRESP,HCOMMENT=YCOMMENT)
206 !
207 !
208 !* outdoor window temperature
209 !
210 YRECFM=YPATCH//'T_WIN1'
211 YRECFM=ADJUSTL(YRECFM)
212 YCOMMENT='T_WIN1 (K)'
213  CALL WRITE_SURF(HPROGRAM,YRECFM,XT_WIN1(:),IRESP,HCOMMENT=YCOMMENT)
214 !
215 IF (CBEM=='BEM') THEN
216 !* internal building specific humidity
217 !
218 YRECFM=YPATCH//'QI_BLD'
219 YRECFM=ADJUSTL(YRECFM)
220 YCOMMENT='QI_BLD (kg/kg)'
221  CALL WRITE_SURF(HPROGRAM,YRECFM,XQI_BLD(:),IRESP,HCOMMENT=YCOMMENT)
222 !
223   !
224   !* indoor window temperature
225   !
226   YRECFM=YPATCH//'T_WIN2'
227   YRECFM=ADJUSTL(YRECFM)
228   YCOMMENT='T_WIN2 (K)'
229   CALL WRITE_SURF(HPROGRAM,YRECFM,XT_WIN2(:),IRESP,HCOMMENT=YCOMMENT)
230   !
231   !* floor temperatures
232   !
233   DO JLAYER=1,NFLOOR_LAYER
234     WRITE(YRECFM,'(A3,A5,I1.1,A1)') YPATCH,'TFLOO',JLAYER,' '
235     WRITE(YCOMMENT,'(A9,I1.1,A4)') 'X_Y_TFLOO',JLAYER,' (K)'
236     YRECFM=ADJUSTL(YRECFM)
237     CALL WRITE_SURF(HPROGRAM,YRECFM,XT_FLOOR(:,JLAYER),IRESP,HCOMMENT=YCOMMENT)
238   END DO
239   !
240   !* internal th. mass temperature
241   !
242   DO JLAYER=1,NFLOOR_LAYER
243     WRITE(YRECFM,'(A3,A5,I1.1,A1)') YPATCH,'TMASS',JLAYER,' '
244     WRITE(YCOMMENT,'(A9,I1.1,A4)') 'X_Y_TMASS',JLAYER,' (K)'
245     YRECFM=ADJUSTL(YRECFM)
246     CALL WRITE_SURF(HPROGRAM,YRECFM,XT_MASS(:,JLAYER),IRESP,HCOMMENT=YCOMMENT)
247   END DO        
248   !
249 ENDIF
250 !
251 !* deep road temperature
252 !
253 YRECFM=YPATCH//'TI_ROAD'
254 YRECFM=ADJUSTL(YRECFM)
255 YCOMMENT='TI_ROAD (K)'
256  CALL WRITE_SURF(HPROGRAM,YRECFM,XTI_ROAD(:),IRESP,HCOMMENT=YCOMMENT)
257 !
258 !* snow mantel
259 !
260 YRECFM='RF'
261  CALL WRITESURF_GR_SNOW(HPROGRAM,YRECFM,YPATCH,TSNOW_ROOF  )
262 !
263 YRECFM='RD'
264  CALL WRITESURF_GR_SNOW(HPROGRAM,YRECFM,YPATCH,TSNOW_ROAD  )
265 !
266 !-------------------------------------------------------------------------------
267 !
268 !*       4.     Semi-prognostic fields:
269 !               ----------------------
270 !
271 !* temperature of canyon air
272 !
273 YRECFM=YPATCH//'TCANYON'
274 YRECFM=ADJUSTL(YRECFM)
275 YCOMMENT='T_CANYON (K)'
276  CALL WRITE_SURF(HPROGRAM,YRECFM,XT_CANYON(:),IRESP,HCOMMENT=YCOMMENT)
277 !
278 !* humidity of canyon air
279 !
280 YRECFM=YPATCH//'QCANYON'
281 YRECFM=ADJUSTL(YRECFM)
282 YCOMMENT='Q_CANYON (kg/kg)'
283  CALL WRITE_SURF(HPROGRAM,YRECFM,XQ_CANYON(:),IRESP,HCOMMENT=YCOMMENT)
284 !
285 !-------------------------------------------------------------------------------
286 !
287 !*       5.  Time
288 !            ----
289 !
290 IF (KPATCH==1) THEN
291   YRECFM='DTCUR'
292   YCOMMENT='s'
293   CALL WRITE_SURF(HPROGRAM,YRECFM,TTIME,IRESP,HCOMMENT=YCOMMENT)
294 END IF
295 !
296 !
297 !-------------------------------------------------------------------------------
298 !
299 !*       6.  ┬žUrban green areas
300 !            ------------------
301 !
302 ! Gardens
303 IF (LGARDEN) CALL WRITESURF_TEB_GARDEN_n(HPROGRAM,YPATCH)
304 !
305 ! Grenn roofs
306 IF (LGREENROOF) CALL WRITESURF_TEB_GREENROOF_n(HPROGRAM,YPATCH)
307 !
308 IF (LHOOK) CALL DR_HOOK('WRITESURF_TEB_N',1,ZHOOK_HANDLE)
309 !
310 !
311 !-------------------------------------------------------------------------------
312 CONTAINS
313 SUBROUTINE ROAD_DIR(PDIR,HDIR)
314 REAL,             INTENT(IN)  :: PDIR
315  CHARACTER(LEN=7), INTENT(OUT) :: HDIR
316 REAL :: ZDIR
317 ZDIR=PDIR
318 IF (PDIR<0) ZDIR = PDIR +360.
319 IF (ZDIR>=  0.   .AND. ZDIR< 11.25) HDIR='N-S    '
320 IF (ZDIR>= 11.25 .AND. ZDIR< 33.75) HDIR='NNE-SSW'
321 IF (ZDIR>= 33.75 .AND. ZDIR< 56.25) HDIR='NE-SW'
322 IF (ZDIR>= 56.25 .AND. ZDIR< 78.75) HDIR='ENE-WSW'
323 IF (ZDIR>= 78.75 .AND. ZDIR<101.25) HDIR='E-W    '
324 IF (ZDIR>=101.25 .AND. ZDIR<123.75) HDIR='ESE-WNW'
325 IF (ZDIR>=123.75 .AND. ZDIR<146.25) HDIR='SE-NW  '
326 IF (ZDIR>=146.25 .AND. ZDIR<168.75) HDIR='SSE-NNW'
327 IF (ZDIR>=168.75 .AND. ZDIR<180.00) HDIR='N-S    '
328 END SUBROUTINE ROAD_DIR
329 SUBROUTINE WALLA_DIR(PDIR,HDIR)
330 REAL,             INTENT(IN)  :: PDIR
331  CHARACTER(LEN=7), INTENT(OUT) :: HDIR
332 REAL :: ZDIR
333 ZDIR=PDIR
334 IF (PDIR<0) ZDIR = PDIR +360.
335 IF (ZDIR>=  0.   .AND. ZDIR< 11.25) HDIR='E      '
336 IF (ZDIR>= 11.25 .AND. ZDIR< 33.75) HDIR='ESE    '
337 IF (ZDIR>= 33.75 .AND. ZDIR< 56.25) HDIR='SE     ' 
338 IF (ZDIR>= 56.25 .AND. ZDIR< 78.75) HDIR='SSE    '
339 IF (ZDIR>= 78.75 .AND. ZDIR<101.25) HDIR='S      '
340 IF (ZDIR>=101.25 .AND. ZDIR<123.75) HDIR='SSW    '
341 IF (ZDIR>=123.75 .AND. ZDIR<146.25) HDIR='SW     '
342 IF (ZDIR>=146.25 .AND. ZDIR<168.75) HDIR='WSW    '
343 IF (ZDIR>=168.75 .AND. ZDIR<180.00) HDIR='W      '
344 END SUBROUTINE WALLA_DIR
345 SUBROUTINE WALLB_DIR(PDIR,HDIR)
346 REAL,             INTENT(IN)  :: PDIR
347  CHARACTER(LEN=7), INTENT(OUT) :: HDIR
348 REAL :: ZDIR
349 ZDIR=PDIR
350 IF (PDIR<0) ZDIR = PDIR +360.
351 IF (ZDIR>=  0.   .AND. ZDIR< 11.25) HDIR='W      '
352 IF (ZDIR>= 11.25 .AND. ZDIR< 33.75) HDIR='WNW    '
353 IF (ZDIR>= 33.75 .AND. ZDIR< 56.25) HDIR='NW     ' 
354 IF (ZDIR>= 56.25 .AND. ZDIR< 78.75) HDIR='NNW    '
355 IF (ZDIR>= 78.75 .AND. ZDIR<101.25) HDIR='N      '
356 IF (ZDIR>=101.25 .AND. ZDIR<123.75) HDIR='NNE    '
357 IF (ZDIR>=123.75 .AND. ZDIR<146.25) HDIR='NE     '
358 IF (ZDIR>=146.25 .AND. ZDIR<168.75) HDIR='ENE    '
359 IF (ZDIR>=168.75 .AND. ZDIR<180.00) HDIR='E      '
360 END SUBROUTINE WALLB_DIR
361 !-------------------------------------------------------------------------------
362 !
363 END SUBROUTINE WRITESURF_TEB_n