Philippe 07/03/2019: IO bugfix: io_set_mnhversion must be called by all the processes
[MNH-git_open_source-lfs.git] / src / SURFEX / writesurf_tebn.F90
1 !SFX_LIC Copyright 2003-2018 CNRS, Meteo-France and Universite Paul Sabatier
2 !SFX_LIC This is part of the SURFEX software governed by the CeCILL-C licence
3 !SFX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt  
4 !SFX_LIC for details. version 1.
5 !     #########
6       SUBROUTINE WRITESURF_TEB_n (HSELECT, OSNOWDIMNC, DTCO, U, TOP, BOP, T, B, ODATA_ROAD_DIR, TPN, &
7                                   GDO, GDS, GDPEK, GRO, GRS, GRPEK, HPROGRAM,KPATCH,HWRITE)
8 !     ####################################
9 !
10 !!****  *WRITE_TEB_n* - writes TEB fields
11 !!
12 !!    PURPOSE
13 !!    -------
14 !!
15 !!**  METHOD
16 !!    ------
17 !!
18 !!    EXTERNAL
19 !!    --------
20 !!
21 !!
22 !!    IMPLICIT ARGUMENTS
23 !!    ------------------
24 !!
25 !!    REFERGREENROOFE
26 !!    ---------
27 !!
28 !!
29 !!    AUTHOR
30 !!    ------
31 !!      V. Masson   *Meteo France*
32 !!
33 !!    MODIFICATIONS
34 !!    -------------
35 !!      Original    01/2003 
36 !!      P. Wautelet 16/02/2018: bug correction: allocate some work arrays to 0,1,1 instead of 0,0,1 (crash with XLF)
37 !-------------------------------------------------------------------------------
38 !
39 !*       0.    DECLARATIONS
40 !              ------------
41 !
42 USE MODD_DATA_COVER_n, ONLY : DATA_COVER_t
43 USE MODD_SURF_ATM_n, ONLY : SURF_ATM_t
44 USE MODD_TEB_OPTION_n, ONLY : TEB_OPTIONS_t
45 USE MODD_BEM_OPTION_n, ONLY : BEM_OPTIONS_t
46 USE MODD_TEB_n, ONLY : TEB_t
47 USE MODD_BEM_n, ONLY : BEM_t
48 USE MODD_TEB_PANEL_n, ONLY : TEB_PANEL_t
49 USE MODD_ISBA_OPTIONS_n, ONLY : ISBA_OPTIONS_t
50 USE MODD_ISBA_n, ONLY : ISBA_PE_t, ISBA_S_t
51 !
52 USE MODN_PREP_SURF_ATM, ONLY : LWRITE_EXTERN
53 !
54 USE MODI_END_IO_SURF_n
55 USE MODI_INIT_IO_SURF_n
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 !RJ #ifdef SFX_MPI
69 !RJ INCLUDE "mpif.h"
70 !RJ #endif
71 !
72 !*       0.1   Declarations of arguments
73 !              -------------------------
74 !
75 !
76  CHARACTER(LEN=*), DIMENSION(:), INTENT(IN) :: HSELECT 
77 LOGICAL, INTENT(IN) :: OSNOWDIMNC
78 !
79 TYPE(DATA_COVER_t), INTENT(INOUT) :: DTCO
80 TYPE(SURF_ATM_t), INTENT(INOUT) :: U
81 TYPE(TEB_OPTIONS_t), INTENT(IN) :: TOP
82 TYPE(BEM_OPTIONS_t), INTENT(IN) :: BOP
83 TYPE(TEB_t), INTENT(IN) :: T
84 TYPE(BEM_t), INTENT(IN) :: B
85 LOGICAL, INTENT(IN) :: ODATA_ROAD_DIR
86 TYPE(TEB_PANEL_t), INTENT(INOUT) :: TPN
87 TYPE(ISBA_OPTIONS_t), INTENT(IN) :: GDO
88 TYPE(ISBA_S_t), INTENT(INOUT) :: GDS
89 TYPE(ISBA_PE_t), INTENT(IN) :: GDPEK
90 TYPE(ISBA_OPTIONS_t), INTENT(IN) :: GRO
91 TYPE(ISBA_S_t), INTENT(INOUT) :: GRS
92 TYPE(ISBA_PE_t), INTENT(IN) :: GRPEK
93 !
94  CHARACTER(LEN=6),  INTENT(IN)  :: HPROGRAM ! program calling
95 INTEGER,           INTENT(IN)  :: KPATCH   ! current TEB patch
96  CHARACTER(LEN=3),    INTENT(IN)  :: HWRITE    ! 'PREP' : does not write SBL XUNDEF fields
97 !                                             ! 'ALL' : all fields are written
98 !
99 !*       0.2   Declarations of local variables
100 !              -------------------------------
101 !
102 REAL, DIMENSION(0,1,1) :: ZWSN_WR, ZRHO_WR, ZHEA_WR, ZAGE_WR, ZSG1_WR, ZSG2_WR, ZHIS_WR
103 REAL, DIMENSION(0,1) :: ZALB_WR
104 !
105 INTEGER, DIMENSION(SIZE(T%XT_ROOF,1)) :: IMASK
106 INTEGER           :: IRESP           ! IRESP  : return-code if a problem appears
107  CHARACTER(LEN=LEN_HREC) :: YRECFM         ! Name of the article to be read
108  CHARACTER(LEN=100):: YCOMMENT       ! Comment string
109  CHARACTER(LEN=3)  :: YPATCH         ! Patch identificator
110  CHARACTER(LEN=7)  :: YDIR           ! Direction identificator
111  CHARACTER(LEN=100):: YSTRING        ! Comment string
112 !
113 INTEGER :: JLAYER, JI ! loop on surface layers
114 REAL(KIND=JPRB) :: ZHOOK_HANDLE
115 !
116 !-------------------------------------------------------------------------------
117 !
118 IF (LHOOK) CALL DR_HOOK('WRITESURF_TEB_N',0,ZHOOK_HANDLE)
119 !
120 YPATCH='   '
121 IF (TOP%NTEB_PATCH>1) WRITE(YPATCH,FMT='(A,I1,A)') 'T',KPATCH,'_'
122 !
123 !
124 !*       2.     Option for road orientation:
125 !               ---------------------------
126 !
127 YCOMMENT='Option for Road orientation in TEB scheme'
128  CALL WRITE_SURF(HSELECT,HPROGRAM,'ROAD_DIR',TOP%CROAD_DIR,IRESP,YCOMMENT)
129 YCOMMENT='Option for Wall representation in TEB scheme'
130  CALL WRITE_SURF(HSELECT,HPROGRAM,'WALL_OPT',TOP%CWALL_OPT,IRESP,YCOMMENT)
131 !
132 !*       3.     Prognostic fields:
133 !               -----------------
134 !
135 !* roof temperatures
136 !
137
138 DO JLAYER=1,TOP%NROOF_LAYER
139   WRITE(YRECFM,'(A3,A5,I1.1,A1)') YPATCH,'TROOF',JLAYER,' '
140   WRITE(YCOMMENT,'(A9,I1.1,A4)') 'X_Y_TROOF',JLAYER,' (K)'
141   YRECFM=ADJUSTL(YRECFM)
142  CALL WRITE_SURF(HSELECT,HPROGRAM,YRECFM,T%XT_ROOF(:,JLAYER),IRESP,HCOMMENT=YCOMMENT)
143 END DO
144
145 !
146 !* roof water content
147 !
148
149 YRECFM=YPATCH//'WS_ROOF'
150 YRECFM=ADJUSTL(YRECFM)
151 YCOMMENT='WS_ROOF (kg/m2)'
152  CALL WRITE_SURF(HSELECT,HPROGRAM,YRECFM,T%XWS_ROOF(:),IRESP,HCOMMENT=YCOMMENT)
153 !
154 !* road temperatures
155 !
156
157 DO JLAYER=1,TOP%NROAD_LAYER
158   WRITE(YRECFM,'(A3,A5,I1.1,A1)') YPATCH,'TROAD',JLAYER,' '
159   YRECFM=ADJUSTL(YRECFM)
160   IF (TOP%CROAD_DIR=='UNIF' .OR. ODATA_ROAD_DIR) THEN
161     YSTRING = 'X_Y_TROAD'
162   ELSEIF (SIZE(T%XROAD_DIR)>0) THEN
163     !* road direction is uniform spatially, one can then indicate it in the comment
164     CALL ROAD_DIR(T%XROAD_DIR(1),YDIR)
165     YSTRING=TRIM(YDIR)//' ROAD TEMP. LAYER '
166   ELSE
167     YSTRING='? ROAD TEMP. LAYER '
168   ENDIF
169   WRITE(YCOMMENT,'(A,I1.1,A4)') TRIM(YSTRING), JLAYER,' (K)'
170   CALL WRITE_SURF(HSELECT,HPROGRAM,YRECFM,T%XT_ROAD(:,JLAYER),IRESP,HCOMMENT=YCOMMENT)
171 END DO
172 !
173 !* road water content
174 !
175
176 YRECFM=YPATCH//'WS_ROAD'
177 YRECFM=ADJUSTL(YRECFM)
178 YCOMMENT='WS_ROAD (kg/m2)'
179  CALL WRITE_SURF(HSELECT,HPROGRAM,YRECFM,T%XWS_ROAD(:),IRESP,HCOMMENT=YCOMMENT)
180 !
181 !* wall temperatures
182 !
183
184 DO JLAYER=1,TOP%NWALL_LAYER
185  IF (TOP%CWALL_OPT=='UNIF') THEN
186   WRITE(YRECFM,'(A3,A5,I1.1,A1)') YPATCH,'TWALL',JLAYER,' '
187   YRECFM=ADJUSTL(YRECFM)
188   WRITE(YCOMMENT,'(A9,I1.1,A4)') 'X_Y_TWALL',JLAYER,' (K)'
189   CALL WRITE_SURF(HSELECT,HPROGRAM,YRECFM,T%XT_WALL_A(:,JLAYER),IRESP,HCOMMENT=YCOMMENT)
190  ELSE
191   !* Wall A
192   WRITE(YRECFM,'(A3,A6,I1.1)') YPATCH,'TWALLA',JLAYER
193   YRECFM=ADJUSTL(YRECFM)
194   IF (ODATA_ROAD_DIR) THEN
195     YSTRING = 'X_Y_TWALL_A'
196   ELSEIF (SIZE(T%XROAD_DIR)>0) THEN
197     !* wall direction is uniform spatially, one can then indicate it in the comment
198     CALL WALLA_DIR(T%XROAD_DIR(1),YDIR)
199     YSTRING=TRIM(YDIR)//'-FACING WALL TEMP. LAYER '
200   ELSE
201     YSTRING='?-FACING WALL TEMP. LAYER '
202   ENDIF
203   WRITE(YCOMMENT,'(A,I1.1,A4)') TRIM(YSTRING), JLAYER,' (K)'
204   CALL WRITE_SURF(HSELECT,HPROGRAM,YRECFM,T%XT_WALL_A(:,JLAYER),IRESP,HCOMMENT=YCOMMENT)
205   !
206   !* Wall B
207   WRITE(YRECFM,'(A3,A6,I1.1)') YPATCH,'TWALLB',JLAYER
208   YRECFM=ADJUSTL(YRECFM)
209   IF (ODATA_ROAD_DIR) THEN
210     YSTRING = 'X_Y_TWALL_B'
211   ELSEIF (SIZE(T%XROAD_DIR)>0) THEN
212     !* wall direction is uniform spatially, one can then indicate it in the comment
213     CALL WALLB_DIR(T%XROAD_DIR(1),YDIR)
214     YSTRING=TRIM(YDIR)//'-FACING WALL TEMP. LAYER '
215   ELSE
216     YSTRING='?-FACING WALL TEMP. LAYER '
217   ENDIF
218   WRITE(YCOMMENT,'(A,I1.1,A4)') TRIM(YSTRING), JLAYER,' (K)'
219   CALL WRITE_SURF(HSELECT,HPROGRAM,YRECFM,T%XT_WALL_B(:,JLAYER),IRESP,HCOMMENT=YCOMMENT)
220  END IF
221 END DO
222 !
223 IF (LWRITE_EXTERN) THEN
224   !
225   DO JLAYER=1,TOP%NROOF_LAYER
226     WRITE(YRECFM,FMT='(A,I1.1)') 'D_ROOF',JLAYER
227     YCOMMENT='Roof layer thickness'
228     CALL WRITE_SURF(HSELECT, &
229                  HPROGRAM,YRECFM,T%XD_ROOF(:,JLAYER),IRESP,HCOMMENT=YCOMMENT)
230   END DO
231   DO JLAYER=1,TOP%NWALL_LAYER
232     WRITE(YRECFM,FMT='(A,I1.1)') 'D_WALL',JLAYER
233     YCOMMENT='WALL layer thickness'
234     CALL WRITE_SURF(HSELECT,HPROGRAM,YRECFM,T%XD_WALL(:,JLAYER),IRESP,HCOMMENT=YCOMMENT)
235   END DO
236   DO JLAYER=1,TOP%NROAD_LAYER
237     WRITE(YRECFM,FMT='(A,I1.1)') 'D_ROAD',JLAYER
238     YCOMMENT='ROAD layer thickness'
239     CALL WRITE_SURF(HSELECT,HPROGRAM,YRECFM,T%XD_ROAD(:,JLAYER),IRESP,HCOMMENT=YCOMMENT)
240   END DO
241   IF (TOP%CBEM=='BEM') THEN
242     DO JLAYER=1,BOP%NFLOOR_LAYER
243       WRITE(YRECFM,FMT='(A,I1.1)') 'D_FLOOR',JLAYER
244       YCOMMENT='FLOOR layer thickness'
245       CALL WRITE_SURF(HSELECT,HPROGRAM,YRECFM,B%XD_FLOOR(:,JLAYER),IRESP,HCOMMENT=YCOMMENT)
246     END DO
247   ENDIF
248   !
249 ENDIF
250 !
251 !* internal building temperature
252 !
253 YRECFM=YPATCH//'TI_BLD'
254 YRECFM=ADJUSTL(YRECFM)
255 YCOMMENT='TI_BLD (K)'
256  CALL WRITE_SURF(HSELECT,HPROGRAM,YRECFM,B%XTI_BLD(:),IRESP,HCOMMENT=YCOMMENT)
257 !
258 !
259 !* outdoor window temperature
260 !
261 YRECFM=YPATCH//'T_WIN1'
262 YRECFM=ADJUSTL(YRECFM)
263 YCOMMENT='T_WIN1 (K)'
264  CALL WRITE_SURF(HSELECT,HPROGRAM,YRECFM,B%XT_WIN1(:),IRESP,HCOMMENT=YCOMMENT)
265 !
266 IF (TOP%CBEM=='BEM') THEN
267 !* internal building specific humidity
268 !
269 YRECFM=YPATCH//'QI_BLD'
270 YRECFM=ADJUSTL(YRECFM)
271 YCOMMENT='QI_BLD (kg/kg)'
272  CALL WRITE_SURF(HSELECT,HPROGRAM,YRECFM,B%XQI_BLD(:),IRESP,HCOMMENT=YCOMMENT)
273 !
274   !
275   !* indoor window temperature
276   !
277   YRECFM=YPATCH//'T_WIN2'
278   YRECFM=ADJUSTL(YRECFM)
279   YCOMMENT='T_WIN2 (K)'
280   CALL WRITE_SURF(HSELECT,HPROGRAM,YRECFM,B%XT_WIN2(:),IRESP,HCOMMENT=YCOMMENT)
281   !
282   !* floor temperatures
283   !
284   DO JLAYER=1,BOP%NFLOOR_LAYER
285     WRITE(YRECFM,'(A3,A5,I1.1,A1)') YPATCH,'TFLOO',JLAYER,' '
286     WRITE(YCOMMENT,'(A9,I1.1,A4)') 'X_Y_TFLOO',JLAYER,' (K)'
287     YRECFM=ADJUSTL(YRECFM)
288     CALL WRITE_SURF(HSELECT,HPROGRAM,YRECFM,B%XT_FLOOR(:,JLAYER),IRESP,HCOMMENT=YCOMMENT)
289   END DO
290   !
291   !* internal th. mass temperature
292   !
293   DO JLAYER=1,BOP%NFLOOR_LAYER
294     WRITE(YRECFM,'(A3,A5,I1.1,A1)') YPATCH,'TMASS',JLAYER,' '
295     WRITE(YCOMMENT,'(A9,I1.1,A4)') 'X_Y_TMASS',JLAYER,' (K)'
296     YRECFM=ADJUSTL(YRECFM)
297     CALL WRITE_SURF(HSELECT,HPROGRAM,YRECFM,B%XT_MASS(:,JLAYER),IRESP,HCOMMENT=YCOMMENT)
298   END DO        
299   !
300 ENDIF
301 !
302 !* deep road temperature
303 !
304 YRECFM=YPATCH//'TI_ROAD'
305 YRECFM=ADJUSTL(YRECFM)
306 YCOMMENT='TI_ROAD (K)'
307  CALL WRITE_SURF(HSELECT,HPROGRAM,YRECFM,T%XTI_ROAD(:),IRESP,HCOMMENT=YCOMMENT)
308 !
309 !* snow mantel
310 !*  
311 DO JI = 1,SIZE(T%XT_ROOF,1)
312  IMASK(JI) = JI
313 ENDDO 
314 !
315 YRECFM='RF'
316  CALL WRITESURF_GR_SNOW(OSNOWDIMNC,HSELECT,HPROGRAM,YRECFM,YPATCH,&
317                         SIZE(T%XT_ROOF,1),IMASK,0,T%TSNOW_ROOF, &
318                         ZWSN_WR,ZRHO_WR,ZHEA_WR,ZAGE_WR,ZSG1_WR, &
319                         ZSG2_WR,ZHIS_WR,ZALB_WR)
320 !
321 YRECFM='RD'
322  CALL WRITESURF_GR_SNOW(OSNOWDIMNC,HSELECT,HPROGRAM,YRECFM,YPATCH,&
323                         SIZE(T%XT_ROOF,1),IMASK,0,T%TSNOW_ROAD, &
324                         ZWSN_WR,ZRHO_WR,ZHEA_WR,ZAGE_WR,ZSG1_WR, &
325                         ZSG2_WR,ZHIS_WR,ZALB_WR)
326 !
327 !-------------------------------------------------------------------------------
328 !
329 !*       4.     Semi-prognostic fields:
330 !               ----------------------
331 !
332 !* temperature of canyon air
333 !
334 YRECFM=YPATCH//'TCANYON'
335 YRECFM=ADJUSTL(YRECFM)
336 YCOMMENT='T_CANYON (K)'
337  CALL WRITE_SURF(HSELECT,HPROGRAM,YRECFM,T%XT_CANYON(:),IRESP,HCOMMENT=YCOMMENT)
338 !
339 !* humidity of canyon air
340 !
341 YRECFM=YPATCH//'QCANYON'
342 YRECFM=ADJUSTL(YRECFM)
343 YCOMMENT='Q_CANYON (kg/kg)'
344  CALL WRITE_SURF(HSELECT,HPROGRAM,YRECFM,T%XQ_CANYON(:),IRESP,HCOMMENT=YCOMMENT)
345 !
346 !
347 !* Thermal solar panels present day production
348 !
349 IF (TOP%LSOLAR_PANEL) THEN
350   YRECFM=YPATCH//'THER_PDAY'
351   YRECFM=ADJUSTL(YRECFM)
352   YCOMMENT='Thermal Solar Panels present day production (J/m2)'
353   IF (.NOT. ASSOCIATED(TPN%XTHER_PRODC_DAY)) THEN
354     ! for PREP cases
355     ALLOCATE(TPN%XTHER_PRODC_DAY(SIZE(B%XTI_BLD)))
356     TPN%XTHER_PRODC_DAY=0.
357   END IF
358   CALL WRITE_SURF(HSELECT,HPROGRAM,YRECFM,TPN%XTHER_PRODC_DAY(:),IRESP,HCOMMENT=YCOMMENT)
359 END IF
360 !-------------------------------------------------------------------------------
361 !
362 !*       5.  Time
363 !            ----
364 !
365 IF (KPATCH==1) THEN
366   YRECFM='DTCUR'
367   YCOMMENT='s'
368   CALL WRITE_SURF(HSELECT,HPROGRAM,YRECFM,TOP%TTIME,IRESP,HCOMMENT=YCOMMENT)
369 END IF
370 !
371 !
372 !-------------------------------------------------------------------------------
373 !
374 !*       6.  Urban green areas
375 !            ------------------
376 !
377 ! Gardens
378 IF (TOP%LGARDEN) THEN
379   CALL END_IO_SURF_n(HPROGRAM)
380   CALL INIT_IO_SURF_n(DTCO, U, HPROGRAM,'TOWN  ','TEB   ','WRITE','GARDEN_PROGNOSTIC.OUT.nc')
381   CALL WRITESURF_TEB_GARDEN_n(HSELECT, OSNOWDIMNC, GDO, GDS, GDPEK, HPROGRAM,YPATCH)
382 ENDIF
383 !
384 ! Grenn roofs
385 IF (TOP%LGREENROOF) THEN
386   CALL END_IO_SURF_n(HPROGRAM)
387   CALL INIT_IO_SURF_n(DTCO, U, HPROGRAM,'TOWN  ','TEB   ','WRITE','GREENROOF_PROGNOSTIC.OUT.nc')
388   CALL WRITESURF_TEB_GREENROOF_n(HSELECT, OSNOWDIMNC, GRO, GRS, GRPEK, HPROGRAM,YPATCH)
389 ENDIF
390 !
391 IF (LHOOK) CALL DR_HOOK('WRITESURF_TEB_N',1,ZHOOK_HANDLE)
392 !
393 !
394 !-------------------------------------------------------------------------------
395 CONTAINS
396 SUBROUTINE ROAD_DIR(PDIR,HDIR)
397 REAL,             INTENT(IN)  :: PDIR
398  CHARACTER(LEN=7), INTENT(OUT) :: HDIR
399 REAL :: ZDIR
400 ZDIR=PDIR
401 IF (PDIR<0) ZDIR = PDIR +360.
402 IF (ZDIR>=  0.   .AND. ZDIR< 11.25) HDIR='N-S    '
403 IF (ZDIR>= 11.25 .AND. ZDIR< 33.75) HDIR='NNE-SSW'
404 IF (ZDIR>= 33.75 .AND. ZDIR< 56.25) HDIR='NE-SW'
405 IF (ZDIR>= 56.25 .AND. ZDIR< 78.75) HDIR='ENE-WSW'
406 IF (ZDIR>= 78.75 .AND. ZDIR<101.25) HDIR='E-W    '
407 IF (ZDIR>=101.25 .AND. ZDIR<123.75) HDIR='ESE-WNW'
408 IF (ZDIR>=123.75 .AND. ZDIR<146.25) HDIR='SE-NW  '
409 IF (ZDIR>=146.25 .AND. ZDIR<168.75) HDIR='SSE-NNW'
410 IF (ZDIR>=168.75 .AND. ZDIR<180.00) HDIR='N-S    '
411 END SUBROUTINE ROAD_DIR
412 SUBROUTINE WALLA_DIR(PDIR,HDIR)
413 REAL,             INTENT(IN)  :: PDIR
414  CHARACTER(LEN=7), INTENT(OUT) :: HDIR
415 REAL :: ZDIR
416 ZDIR=PDIR
417 IF (PDIR<0) ZDIR = PDIR +360.
418 IF (ZDIR>=  0.   .AND. ZDIR< 11.25) HDIR='E      '
419 IF (ZDIR>= 11.25 .AND. ZDIR< 33.75) HDIR='ESE    '
420 IF (ZDIR>= 33.75 .AND. ZDIR< 56.25) HDIR='SE     ' 
421 IF (ZDIR>= 56.25 .AND. ZDIR< 78.75) HDIR='SSE    '
422 IF (ZDIR>= 78.75 .AND. ZDIR<101.25) HDIR='S      '
423 IF (ZDIR>=101.25 .AND. ZDIR<123.75) HDIR='SSW    '
424 IF (ZDIR>=123.75 .AND. ZDIR<146.25) HDIR='SW     '
425 IF (ZDIR>=146.25 .AND. ZDIR<168.75) HDIR='WSW    '
426 IF (ZDIR>=168.75 .AND. ZDIR<180.00) HDIR='W      '
427 END SUBROUTINE WALLA_DIR
428 SUBROUTINE WALLB_DIR(PDIR,HDIR)
429 REAL,             INTENT(IN)  :: PDIR
430  CHARACTER(LEN=7), INTENT(OUT) :: HDIR
431 REAL :: ZDIR
432 ZDIR=PDIR
433 IF (PDIR<0) ZDIR = PDIR +360.
434 IF (ZDIR>=  0.   .AND. ZDIR< 11.25) HDIR='W      '
435 IF (ZDIR>= 11.25 .AND. ZDIR< 33.75) HDIR='WNW    '
436 IF (ZDIR>= 33.75 .AND. ZDIR< 56.25) HDIR='NW     ' 
437 IF (ZDIR>= 56.25 .AND. ZDIR< 78.75) HDIR='NNW    '
438 IF (ZDIR>= 78.75 .AND. ZDIR<101.25) HDIR='N      '
439 IF (ZDIR>=101.25 .AND. ZDIR<123.75) HDIR='NNE    '
440 IF (ZDIR>=123.75 .AND. ZDIR<146.25) HDIR='NE     '
441 IF (ZDIR>=146.25 .AND. ZDIR<168.75) HDIR='ENE    '
442 IF (ZDIR>=168.75 .AND. ZDIR<180.00) HDIR='E      '
443 END SUBROUTINE WALLB_DIR
444 !-------------------------------------------------------------------------------
445 !
446 END SUBROUTINE WRITESURF_TEB_n