88fbe2dffb59a0cf4804e8edff10b3a783aedacb
[MNH-git_open_source-lfs.git] / src / SURFEX / mode_write_surf_fa.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 MODULE MODE_WRITE_SURF_FA
6 !
7 INTERFACE WRITE_SURF0_FA
8         MODULE PROCEDURE WRITE_SURFX0_FA
9         MODULE PROCEDURE WRITE_SURFN0_FA
10         MODULE PROCEDURE WRITE_SURFL0_FA
11         MODULE PROCEDURE WRITE_SURFC0_FA
12 END INTERFACE
13 INTERFACE WRITE_SURFN_FA
14         MODULE PROCEDURE WRITE_SURFX1_FA
15         MODULE PROCEDURE WRITE_SURFN1_FA
16         MODULE PROCEDURE WRITE_SURFL1_FA
17         MODULE PROCEDURE WRITE_SURFX2_FA
18 END INTERFACE
19 INTERFACE WRITE_SURFT_FA
20         MODULE PROCEDURE WRITE_SURFT0_FA
21         MODULE PROCEDURE WRITE_SURFT2_FA
22 END INTERFACE
23 !
24 CONTAINS
25 !
26 !     #############################################################
27       SUBROUTINE WRITE_SURFX0_FA(HREC,PFIELD,KRESP,HCOMMENT)
28 !     #############################################################
29 !
30 !!****  * - routine to write a real scalar
31 !
32 USE MODD_SURFEX_OMP, ONLY : LWORK0
33 !
34 USE MODD_IO_SURF_FA, ONLY : NUNIT_FA, CMASK, LFANOCOMPACT
35 !
36 USE MODE_FASURFEX
37 !
38 USE MODI_IO_BUFF_n
39 USE MODI_ERROR_WRITE_SURF_FA
40 !
41 USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
42 USE PARKIND1  ,ONLY : JPRB
43 !
44 IMPLICIT NONE
45 !
46 !*      0.1   Declarations of arguments
47 !
48  CHARACTER(LEN=12),  INTENT(IN) :: HREC     ! name of the article to be read
49 REAL,               INTENT(IN) :: PFIELD   ! the real scalar to be read
50 INTEGER,            INTENT(OUT):: KRESP    ! KRESP  : return-code if a problem appears
51  CHARACTER(LEN=100), INTENT(IN) :: HCOMMENT ! comment string
52 !
53 !*      0.2   Declarations of local variables
54 !
55  CHARACTER(LEN=18):: YNAME                  ! Field Name
56 INTEGER          :: INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL
57 REAL(KIND=JPRB)  :: ZHOOK_HANDLE
58 !
59 IF (LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:ERROR_WRITE_SURF_FA:WRITE_SURFX0_FA',0,ZHOOK_HANDLE)
60 !
61 KRESP=0
62 !
63  CALL IO_BUFF_n(HREC,'W',LWORK0)
64 IF (LWORK0 .AND. LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:WRITE_SURFX0_FA',1,ZHOOK_HANDLE)
65 IF (LWORK0) RETURN
66 !
67 IF(LFANOCOMPACT)THEN
68   CALL FAVEUR(KRESP,NUNIT_FA,INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL)
69   ! -- Pour ecrire sans compactage
70   CALL FAGOTE(KRESP,NUNIT_FA,-1,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL)
71 ENDIF
72 !
73 YNAME=TRIM(CMASK)//TRIM(HREC)
74  CALL  FAECR_R(KRESP,NUNIT_FA,YNAME,PFIELD)
75 IF (KRESP/=0) THEN
76   CALL ERROR_WRITE_SURF_FA(HREC,KRESP)
77 ENDIF
78 !
79 IF(LFANOCOMPACT)THEN
80   ! On remet la valeur par defaut 
81   CALL FAGOTE(KRESP,NUNIT_FA,INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL)
82 ENDIF
83 !
84 IF (LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:WRITE_SURFX0_FA',1,ZHOOK_HANDLE)
85 !
86 END SUBROUTINE WRITE_SURFX0_FA
87 !
88 !     #############################################################
89       SUBROUTINE WRITE_SURFN0_FA(HREC,KFIELD,KRESP,HCOMMENT)
90 !     #############################################################
91 !
92 !!****  * - routine to write an integer
93 !
94 USE MODD_SURFEX_OMP, ONLY : LWORK0
95 !
96 USE MODD_IO_SURF_FA, ONLY : NUNIT_FA, NMASK, CMASK, LFANOCOMPACT
97 !
98 USE MODE_FASURFEX
99 !
100 USE MODI_IO_BUFF_n
101 USE MODI_ERROR_WRITE_SURF_FA
102 !
103 USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
104 USE PARKIND1  ,ONLY : JPRB
105 !
106 IMPLICIT NONE
107 !
108 !*      0.1   Declarations of arguments
109 !
110  CHARACTER(LEN=12),  INTENT(IN) :: HREC     ! name of the article to be read
111 INTEGER,            INTENT(IN) :: KFIELD   ! the integer to be read
112 INTEGER,            INTENT(OUT):: KRESP    ! KRESP  : return-code if a problem appears
113  CHARACTER(LEN=100), INTENT(IN) :: HCOMMENT ! comment string
114 !
115 !*      0.2   Declarations of local variables
116 !
117  CHARACTER(LEN=18):: YNAME                  ! Field Name
118 INTEGER          :: INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL
119 REAL(KIND=JPRB)  :: ZHOOK_HANDLE
120 !
121 IF (LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:WRITE_SURFN0_FA',0,ZHOOK_HANDLE)
122 !
123 KRESP=0
124 !
125  CALL IO_BUFF_n(HREC,'W',LWORK0)
126 IF (LWORK0 .AND. LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:WRITE_SURFN0_FA',1,ZHOOK_HANDLE)
127 IF (LWORK0) RETURN
128 !
129 IF(LFANOCOMPACT)THEN
130   CALL FAVEUR(KRESP,NUNIT_FA,INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL)
131   ! -- Pour ecrire sans compactage
132   CALL FAGOTE(KRESP,NUNIT_FA,-1,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL)
133 ENDIF
134 !
135 YNAME=TRIM(CMASK)//TRIM(HREC)
136  CALL  FAECR_I(KRESP,NUNIT_FA,YNAME,KFIELD)
137 IF (KRESP/=0) THEN
138   CALL ERROR_WRITE_SURF_FA(HREC,KRESP)
139 ENDIF
140 !
141 IF(LFANOCOMPACT)THEN
142   ! On remet la valeur par defaut 
143   CALL FAGOTE(KRESP,NUNIT_FA,INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL)
144 ENDIF
145 !
146 IF (LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:WRITE_SURFN0_FA',1,ZHOOK_HANDLE)
147 !
148 END SUBROUTINE WRITE_SURFN0_FA
149 !
150 !     #############################################################
151       SUBROUTINE WRITE_SURFL0_FA(HREC,OFIELD,KRESP,HCOMMENT)
152 !     #############################################################
153 !
154 !!****  * - routine to write a logical
155 !
156 USE MODD_SURFEX_OMP, ONLY : LWORK0
157 !
158 USE MODD_IO_SURF_FA, ONLY : NUNIT_FA, CMASK, LFANOCOMPACT
159 !
160 USE MODE_FASURFEX
161 !
162 USE MODI_IO_BUFF_n
163 USE MODI_ERROR_WRITE_SURF_FA
164 !
165 USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
166 USE PARKIND1  ,ONLY : JPRB
167 !
168 IMPLICIT NONE
169 !
170 !*      0.1   Declarations of arguments
171 !
172  CHARACTER(LEN=12),  INTENT(IN) :: HREC     ! name of the article to be read
173 LOGICAL,            INTENT(IN) :: OFIELD   ! array containing the data field
174 INTEGER,            INTENT(OUT):: KRESP    ! KRESP  : return-code if a problem appears
175  CHARACTER(LEN=100), INTENT(IN) :: HCOMMENT ! comment string
176 !
177 !*      0.2   Declarations of local variables
178 !
179  CHARACTER(LEN=18):: YNAME ! Field Name
180 INTEGER          :: INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL
181 REAL(KIND=JPRB)  :: ZHOOK_HANDLE
182 !
183 IF (LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:WRITE_SURFL0_FA',0,ZHOOK_HANDLE)
184 !
185 KRESP=0
186 !
187  CALL IO_BUFF_n(HREC,'W',LWORK0)
188 IF (LWORK0 .AND. LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:WRITE_SURFL0_FA',1,ZHOOK_HANDLE)
189 IF (LWORK0) RETURN
190 !
191 IF(LFANOCOMPACT)THEN
192   CALL FAVEUR(KRESP,NUNIT_FA,INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL)
193   ! -- Pour ecrire sans compactage
194   CALL FAGOTE(KRESP,NUNIT_FA,-1,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL)
195 ENDIF
196 !
197 YNAME=TRIM(CMASK)//TRIM(HREC)
198  CALL  FAECR_L(KRESP,NUNIT_FA,YNAME,OFIELD)
199 IF (KRESP/=0) THEN
200   CALL ERROR_WRITE_SURF_FA(HREC,KRESP)
201 ENDIF
202 !
203 IF(LFANOCOMPACT)THEN
204   ! On remet la valeur par defaut 
205   CALL FAGOTE(KRESP,NUNIT_FA,INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL)
206 ENDIF
207 !
208 IF (LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:WRITE_SURFL0_FA',1,ZHOOK_HANDLE)
209 !
210 END SUBROUTINE WRITE_SURFL0_FA
211 !
212 !     #############################################################
213       SUBROUTINE WRITE_SURFC0_FA(HREC,HFIELD,KRESP,HCOMMENT)
214 !     #############################################################
215 !
216 !!****  * - routine to write a character
217 !
218 USE MODD_SURFEX_OMP, ONLY : LWORK0
219 !
220 USE MODD_IO_SURF_FA, ONLY : NUNIT_FA, CMASK, LFANOCOMPACT
221 !
222 USE MODE_FASURFEX
223 !
224 USE MODI_IO_BUFF_n
225 USE MODI_ERROR_WRITE_SURF_FA
226 !
227 USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
228 USE PARKIND1  ,ONLY : JPRB
229 !
230 IMPLICIT NONE
231 !
232 !*      0.1   Declarations of arguments
233 !
234  CHARACTER(LEN=12),  INTENT(IN)  :: HREC      ! name of the article to be read
235  CHARACTER(LEN=40),  INTENT(IN)  :: HFIELD    ! the integer to be read
236 INTEGER,            INTENT(OUT) :: KRESP     ! KRESP  : return-code if a problem appears
237  CHARACTER(LEN=100), INTENT(IN)  :: HCOMMENT  ! comment string
238 !
239 !*      0.2   Declarations of local variables
240 !
241  CHARACTER,DIMENSION(40)  :: YFIELD
242  CHARACTER(LEN=18)        :: YNAME ! Field Name
243 INTEGER                  :: INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL
244 REAL(KIND=JPRB)          :: ZHOOK_HANDLE
245 !
246 IF (LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:WRITE_SURFC0_FA',0,ZHOOK_HANDLE)
247 !
248 KRESP=0
249 !
250  CALL IO_BUFF_n(HREC,'W',LWORK0)
251 IF (LWORK0.AND. LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:WRITE_SURFC0_FA',1,ZHOOK_HANDLE)
252 IF (LWORK0) RETURN
253 !
254 IF(LFANOCOMPACT)THEN
255   CALL FAVEUR(KRESP,NUNIT_FA,INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL)
256   ! -- Pour ecrire sans compactage
257   CALL FAGOTE(KRESP,NUNIT_FA,-1,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL)
258 ENDIF
259 !
260 READ(HFIELD,'(40A1)') YFIELD
261 YNAME=TRIM(CMASK)//TRIM(HREC)
262  CALL  FAECR_C(KRESP,NUNIT_FA,YNAME,40,YFIELD)
263 IF (KRESP/=0) THEN
264   CALL ERROR_WRITE_SURF_FA(HREC,KRESP)
265 ENDIF
266 !
267 IF(LFANOCOMPACT)THEN
268   ! On remet la valeur par defaut 
269   CALL FAGOTE(KRESP,NUNIT_FA,INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL)
270 ENDIF
271 !
272 IF (LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:WRITE_SURFC0_FA',1,ZHOOK_HANDLE)
273 !
274 END SUBROUTINE WRITE_SURFC0_FA
275 !
276 !     #############################################################
277       SUBROUTINE WRITE_SURFX1_FA(HREC,KL,PFIELD,KRESP,HCOMMENT,HDIR)
278 !     #############################################################
279 !
280 !!****  * - routine to fill a write 1D array for the externalised surface 
281 !
282 USE MODD_SURFEX_MPI, ONLY : NRANK, NPIO, XTIME_NPIO_WRITE, WLOG_MPI
283 !
284 USE MODD_SURFEX_OMP, ONLY : LWORK0, NWORKB
285 !
286 USE MODD_IO_SURF_FA, ONLY : NUNIT_FA, NMASK, NFULL, CMASK, &
287                             LFANOCOMPACT 
288 USE MODD_SURF_PAR,   ONLY : XUNDEF
289 !
290 USE MODI_IO_BUFF_n
291 USE MODI_ERROR_WRITE_SURF_FA
292 USE MODI_GATHER_AND_WRITE_MPI
293 !
294 USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
295 USE PARKIND1  ,ONLY : JPRB
296 !
297 IMPLICIT NONE
298 !
299 #ifndef NOMPI
300 INCLUDE "mpif.h"
301 #endif
302 !
303 !*      0.1   Declarations of arguments
304 !
305  CHARACTER(LEN=12),   INTENT(IN) :: HREC     ! name of the article to be read
306 INTEGER,             INTENT(IN) :: KL       ! number of points
307 REAL, DIMENSION(KL), INTENT(IN) :: PFIELD   ! array containing the data field
308 INTEGER,             INTENT(OUT):: KRESP    ! KRESP  : return-code if a problem appears
309  CHARACTER(LEN=100),  INTENT(IN) :: HCOMMENT ! comment string
310  CHARACTER(LEN=1),    INTENT(IN) :: HDIR     ! type of field :
311                                             ! 'H' : field with
312                                             !       horizontal spatial dim.
313                                             ! '-' : no horizontal dim.
314 !*      0.2   Declarations of local variables
315 !
316 INTEGER                :: I,INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL
317 REAL                   :: ZMEAN, ZCOUNT
318 REAL       :: XTIME0
319 REAL, DIMENSION(MAX(NFULL,SIZE(PFIELD))) :: ZWORK   ! work array read in the file
320 REAL(KIND=JPRB)        :: ZHOOK_HANDLE
321 !
322 IF (LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:WRITE_SURFX1_FA',0,ZHOOK_HANDLE)
323 !
324 !$OMP SINGLE
325 NWORKB=0
326 !
327  CALL IO_BUFF_n(HREC,'W',LWORK0)
328 !$OMP END SINGLE
329 !
330 IF (LWORK0 .AND. LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:WRITE_SURFX1_FA',1,ZHOOK_HANDLE)
331 IF (LWORK0) RETURN
332 !
333 IF(HDIR=='H')THEN
334   CALL GATHER_AND_WRITE_MPI(PFIELD,ZWORK,NMASK)
335 ELSE !no horizontal dim. case (not masked)
336   ZWORK(1:KL)=PFIELD(1:KL)
337   ZWORK(KL+1:NFULL)=SUM(PFIELD(1:KL))/REAL(KL)
338 ENDIF
339 !
340 IF (NRANK==NPIO) THEN
341   !
342 #ifndef NOMPI  
343   XTIME0 = MPI_WTIME()
344 #endif
345   !
346 !$OMP SINGLE
347   !   
348   IF(LFANOCOMPACT)THEN
349     CALL FAVEUR(NWORKB,NUNIT_FA,INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL)
350     ! -- Pour ecrire sans compactage
351     CALL FAGOTE(NWORKB,NUNIT_FA,-1,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL)
352     CALL FAIENC(NWORKB,NUNIT_FA,'S1D_',0,HREC,ZWORK,.FALSE.)
353     IF (NWORKB/=0) CALL ERROR_WRITE_SURF_FA(HREC,NWORKB)
354     ! On remet la valeur par defaut 
355     CALL FAGOTE(NWORKB,NUNIT_FA,INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL)
356   ELSE
357     ZMEAN =0.0
358     ZCOUNT=0.0
359     DO I=1,NFULL
360       IF(ZWORK(I)/=XUNDEF)THEN
361         ZMEAN =ZMEAN+ZWORK(I)
362         ZCOUNT=ZCOUNT+1.0
363       ENDIF
364     ENDDO
365     IF (ZCOUNT.GT.0.0) ZMEAN=ZMEAN/ZCOUNT
366     WHERE(ZWORK(:)==XUNDEF)ZWORK(:)=ZMEAN
367     CALL FAIENC(NWORKB,NUNIT_FA,'S1D_',0,HREC,ZWORK,.FALSE.)
368     IF (NWORKB/=0) CALL ERROR_WRITE_SURF_FA(HREC,NWORKB)
369   ENDIF
370   !
371 !$OMP END SINGLE
372   !    
373 #ifndef NOMPI  
374   XTIME_NPIO_WRITE = XTIME_NPIO_WRITE + (MPI_WTIME() - XTIME0)
375 #endif
376   !
377 ENDIF
378 !
379 KRESP = NWORKB
380 !
381 IF (LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:WRITE_SURFX1_FA',1,ZHOOK_HANDLE)
382 !
383 END SUBROUTINE WRITE_SURFX1_FA
384 !
385 !     #############################################################
386       SUBROUTINE WRITE_SURFX2_FA(HREC,KL1,KL2,PFIELD,KRESP,HCOMMENT,HDIR)
387 !     #############################################################
388 !
389 !!****  * - routine to fill a write 2D array for the externalised surface 
390 !
391 USE MODD_SURFEX_MPI, ONLY : NRANK, NPIO, XTIME_NPIO_WRITE
392 !
393 USE MODD_SURFEX_OMP, ONLY : LWORK0, NWORKB
394 !
395 USE MODD_IO_SURF_FA, ONLY : NUNIT_FA, NMASK, NFULL, &
396                             CMASK, LFANOCOMPACT
397 USE MODD_SURF_PAR,   ONLY : XUNDEF
398 !
399 USE MODI_IO_BUFF_n
400 USE MODI_ERROR_WRITE_SURF_FA
401 USE MODI_GATHER_AND_WRITE_MPI
402 !
403 USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
404 USE PARKIND1  ,ONLY : JPRB
405 !
406 IMPLICIT NONE
407 !
408 #ifndef NOMPI
409 INCLUDE "mpif.h"
410 #endif
411 !
412 !*      0.1   Declarations of arguments
413 !
414  CHARACTER(LEN=12),        INTENT(IN) :: HREC     ! name of the article to be read
415 INTEGER,                  INTENT(IN) :: KL1      ! number of points
416 INTEGER,                  INTENT(IN) :: KL2      ! 2nd dimension
417 REAL, DIMENSION(KL1,KL2), INTENT(IN) :: PFIELD   ! array containing the data field
418 INTEGER,                  INTENT(OUT):: KRESP    ! KRESP  : return-code if a problem appears
419  CHARACTER(LEN=100),       INTENT(IN) :: HCOMMENT ! comment string
420  CHARACTER(LEN=1),         INTENT(IN) :: HDIR     ! type of field :
421                                                  ! 'H' : field with
422                                                  !       horizontal spatial dim.
423                                                  ! '-' : no horizontal dim.
424 !*      0.2   Declarations of local variables
425
426  CHARACTER(LEN=4)  :: YSUFFIX
427  CHARACTER(LEN=2)  :: YPATCH
428 INTEGER           :: I, JL ! loop counter
429 INTEGER           :: INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL
430 REAL  :: XTIME0
431 REAL, DIMENSION(MAX(NFULL,SIZE(PFIELD,1)),SIZE(PFIELD,2)) :: ZWORK   ! work array read in the file
432 REAL, DIMENSION(SIZE(PFIELD,2))       :: ZMEAN, ZCOUNT
433 REAL(KIND=JPRB)   :: ZHOOK_HANDLE
434 !
435 IF (LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:WRITE_SURFX2_FA',0,ZHOOK_HANDLE)
436 !
437 !$OMP SINGLE
438 NWORKB=0
439 !
440  CALL IO_BUFF_n(HREC,'W',LWORK0)
441 !$OMP END SINGLE
442 !
443 IF (LWORK0 .AND. LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:WRITE_SURFX2_FA',1,ZHOOK_HANDLE)
444 IF (LWORK0) RETURN
445 !
446  CALL GATHER_AND_WRITE_MPI(PFIELD,ZWORK,NMASK)
447 !
448 IF (NRANK==NPIO) THEN
449   !
450 #ifndef NOMPI
451   XTIME0 = MPI_WTIME()
452 #endif
453   !    
454 !$OMP SINGLE
455   !   
456   IF(LFANOCOMPACT)THEN
457     CALL FAVEUR(NWORKB,NUNIT_FA,INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL)
458     ! -- Pour ecrire sans compactage
459     CALL FAGOTE(NWORKB,NUNIT_FA,-1,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL)
460     DO JL=1,SIZE(ZWORK,2)
461       WRITE(YPATCH,'(I2.2)')JL
462       YSUFFIX='S'//YPATCH//'_'
463       CALL FAIENC(NWORKB,NUNIT_FA,YSUFFIX,0,HREC,ZWORK(:,JL),.FALSE.)
464       IF (NWORKB/=0) CALL ERROR_WRITE_SURF_FA(HREC,NWORKB)
465     END DO
466     ! On remet la valeur par defaut 
467     CALL FAGOTE(NWORKB,NUNIT_FA,INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL)
468   ELSE
469     ZMEAN (:)=0.0
470     ZCOUNT(:)=0.0
471     DO I=1,NFULL
472       DO JL=1,SIZE(ZWORK,2)
473         IF(ZWORK(I,JL)/=XUNDEF) THEN
474           ZMEAN (JL)=ZMEAN(JL)+ZWORK(I,JL)
475           ZCOUNT(JL)=ZCOUNT(JL)+1.0
476         ENDIF
477       ENDDO
478     ENDDO
479     WHERE(ZCOUNT(:)>0.0)ZMEAN(:)=ZMEAN(:)/ZCOUNT(:)        
480     DO JL=1,SIZE(ZWORK,2)
481       WHERE(ZWORK(:,JL)==XUNDEF)ZWORK(:,JL)=ZMEAN(JL)
482       WRITE(YPATCH,'(I2.2)')JL
483       YSUFFIX='S'//YPATCH//'_'
484       CALL FAIENC(NWORKB,NUNIT_FA,YSUFFIX,0,HREC,ZWORK(:,JL),.FALSE.)
485       IF (NWORKB/=0) CALL ERROR_WRITE_SURF_FA(HREC,NWORKB)
486     END DO
487   ENDIF
488   !
489 !$OMP END SINGLE
490   !  
491 #ifndef NOMPI
492   XTIME_NPIO_WRITE = XTIME_NPIO_WRITE + (MPI_WTIME() - XTIME0)
493 #endif
494   !  
495 ENDIF
496 !
497 KRESP = NWORKB
498 !
499 IF (LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:WRITE_SURFX2_FA',1,ZHOOK_HANDLE)
500 !
501 END SUBROUTINE WRITE_SURFX2_FA
502 !
503 !     #############################################################
504       SUBROUTINE WRITE_SURFN1_FA(HREC,KL,KFIELD,KRESP,HCOMMENT,HDIR)
505 !     #############################################################
506 !
507 !!****  * - routine to write an integer array
508 !
509 USE MODD_SURFEX_MPI, ONLY : NRANK, NPIO, XTIME_NPIO_WRITE
510 !
511 USE MODD_SURFEX_OMP, ONLY : LWORK0, NWORKB
512 !
513 USE MODD_IO_SURF_FA, ONLY : NUNIT_FA, NMASK, NFULL, CMASK, LFANOCOMPACT
514 !
515 USE MODE_FASURFEX
516 !
517 USE MODI_IO_BUFF_n
518 USE MODI_ERROR_WRITE_SURF_FA
519 USE MODI_GATHER_AND_WRITE_MPI
520 !
521 USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
522 USE PARKIND1  ,ONLY : JPRB
523 !
524 IMPLICIT NONE
525 !
526 #ifndef NOMPI
527 INCLUDE "mpif.h"
528 #endif
529 !
530 !*      0.1   Declarations of arguments
531 !
532  CHARACTER(LEN=12),      INTENT(IN) :: HREC     ! name of the article to be read
533 INTEGER,                INTENT(IN) :: KL       ! number of points
534 INTEGER, DIMENSION(KL), INTENT(IN) :: KFIELD   ! array containing the data field
535 INTEGER,                INTENT(OUT):: KRESP    ! KRESP  : return-code if a problem appears
536  CHARACTER(LEN=100),     INTENT(IN) :: HCOMMENT ! comment string
537  CHARACTER(LEN=1),       INTENT(IN) :: HDIR     ! type of field :
538                                                ! 'H' : field with
539                                                !       horizontal spatial dim.
540                                                ! '-' : no horizontal dim.
541 !*      0.2   Declarations of local variables
542
543  CHARACTER(LEN=18)         :: YNAME! Field Nam
544 INTEGER                   :: INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL
545 INTEGER, DIMENSION(MAX(NFULL,SIZE(KFIELD))) :: IWORK  ! work array read in the file
546 REAL   :: XTIME0
547 REAL(KIND=JPRB)           :: ZHOOK_HANDLE
548 !
549 IF (LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:WRITE_SURFN1_FA',0,ZHOOK_HANDLE)
550 !
551 !$OMP SINGLE
552 NWORKB = 0
553 !
554  CALL IO_BUFF_n(HREC,'W',LWORK0)
555 !$OMP END SINGLE
556 !
557 IF (LWORK0 .AND. LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:WRITE_SURFN1_FA',1,ZHOOK_HANDLE)
558 IF (LWORK0) RETURN
559 !
560 IF (HDIR/='H' .OR. HREC=="-") THEN
561   IWORK(1:KL) = KFIELD
562 ELSE
563   CALL GATHER_AND_WRITE_MPI(KFIELD,IWORK,NMASK)
564 ENDIF
565 !
566 IF (NRANK==NPIO) THEN
567   !
568 #ifndef NOMPI
569   XTIME0 = MPI_WTIME()
570 #endif
571   !    
572 !$OMP SINGLE
573   !  
574   IF(LFANOCOMPACT)THEN
575     CALL FAVEUR(NWORKB,NUNIT_FA,INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL)
576     ! -- Pour ecrire sans compactage
577     CALL FAGOTE(NWORKB,NUNIT_FA,-1,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL)
578   ENDIF
579   !
580   YNAME=TRIM(CMASK)//TRIM(HREC)
581   !
582   CALL  FAECR_I_D(NWORKB,NUNIT_FA,YNAME,KL,IWORK(1:KL))
583   IF (NWORKB/=0) CALL ERROR_WRITE_SURF_FA(HREC,NWORKB)
584   !
585   IF(LFANOCOMPACT)THEN
586     ! On remet la valeur par defaut 
587     CALL FAGOTE(NWORKB,NUNIT_FA,INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL)
588   ENDIF
589   !
590 !$OMP END SINGLE
591   !   
592 #ifndef NOMPI
593   XTIME_NPIO_WRITE = XTIME_NPIO_WRITE + (MPI_WTIME() - XTIME0)
594 #endif
595   !  
596 ENDIF
597 !
598 KRESP = NWORKB
599 !
600 IF (LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:WRITE_SURFN1_FA',1,ZHOOK_HANDLE)
601 RETURN
602 !
603 END SUBROUTINE WRITE_SURFN1_FA
604 !
605 !     #############################################################
606       SUBROUTINE WRITE_SURFL1_FA(HREC,KL,OFIELD,KRESP,HCOMMENT,HDIR)
607 !     #############################################################
608 !
609 !!****  * - routine to write a logical array
610 !
611 USE MODD_SURFEX_MPI, ONLY : NRANK, NPIO, XTIME_NPIO_WRITE
612 !
613 USE MODD_SURFEX_OMP, ONLY : LWORK0, NWORKB
614 !
615 USE MODD_IO_SURF_FA, ONLY : NUNIT_FA, CMASK, LFANOCOMPACT
616 !
617 USE MODE_FASURFEX
618 !
619 USE MODI_IO_BUFF_n
620 USE MODI_ERROR_WRITE_SURF_FA
621 !
622 USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
623 USE PARKIND1  ,ONLY : JPRB
624 !
625 IMPLICIT NONE
626 !
627 #ifndef NOMPI
628 INCLUDE "mpif.h"
629 #endif
630 !
631 !*      0.1   Declarations of arguments
632 !
633  CHARACTER(LEN=12),      INTENT(IN) :: HREC     ! name of the article to be read
634 INTEGER,             INTENT(IN) :: KL       ! number of points
635 LOGICAL, DIMENSION(KL), INTENT(IN) :: OFIELD   ! array containing the data field
636 INTEGER,                INTENT(OUT):: KRESP    ! KRESP  : return-code if a problem appears
637  CHARACTER(LEN=100),     INTENT(IN) :: HCOMMENT ! comment string
638  CHARACTER(LEN=1),       INTENT(IN) :: HDIR     ! type of field :
639                                                ! 'H' : field with
640                                                !       horizontal spatial dim.
641                                                ! '-' : no horizontal dim.
642 !*      0.2   Declarations of local variables
643 !
644  CHARACTER(LEN=18):: YNAME ! Field Name
645 INTEGER          :: INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL
646 REAL :: XTIME0
647 REAL(KIND=JPRB)  :: ZHOOK_HANDLE
648 !
649 IF (LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:WRITE_SURFL1_FA',0,ZHOOK_HANDLE)
650 !
651 !$OMP SINGLE
652 NWORKB=0
653 !
654  CALL IO_BUFF_n(HREC,'W',LWORK0)
655 !$OMP END SINGLE
656 !
657 IF (LWORK0 .AND. LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:WRITE_SURFL1_FA',1,ZHOOK_HANDLE)
658 IF (LWORK0) RETURN
659 !
660 IF (NRANK==NPIO) THEN
661   !
662 #ifndef NOMPI
663   XTIME0 = MPI_WTIME()
664 #endif
665   !  
666 !$OMP SINGLE
667   !    
668   IF(LFANOCOMPACT)THEN
669     CALL FAVEUR(NWORKB,NUNIT_FA,INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL)
670     ! -- Pour ecrire sans compactage
671     CALL FAGOTE(NWORKB,NUNIT_FA,-1,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL)
672   ENDIF
673   !
674   YNAME=TRIM(CMASK)//TRIM(HREC)
675   CALL  FAECR_L_D(NWORKB,NUNIT_FA,YNAME,KL,OFIELD)
676   IF (NWORKB/=0) CALL ERROR_WRITE_SURF_FA(HREC,NWORKB)
677   !
678   IF(LFANOCOMPACT)THEN
679     ! On remet la valeur par defaut 
680     CALL FAGOTE(NWORKB,NUNIT_FA,INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL)
681   ENDIF
682   !
683 !$OMP END SINGLE
684   !  
685 #ifndef NOMPI
686   XTIME_NPIO_WRITE = XTIME_NPIO_WRITE + (MPI_WTIME() - XTIME0)
687 #endif
688   !  
689 ENDIF
690 !
691 KRESP = NWORKB
692 !
693 IF (LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:WRITE_SURFL1_FA',1,ZHOOK_HANDLE)
694 !
695 END SUBROUTINE WRITE_SURFL1_FA
696 !
697 !     #############################################################
698       SUBROUTINE WRITE_SURFT0_FA(HREC,KYEAR,KMONTH,KDAY,PTIME,KRESP,HCOMMENT)
699 !     #############################################################
700 !
701 !!****  * - routine to write a date
702 !
703 USE MODD_SURFEX_OMP, ONLY : LWORK0
704 !
705 USE MODD_IO_SURF_FA, ONLY : CMASK, NUNIT_FA, LFANOCOMPACT
706 !
707 USE MODE_FASURFEX
708 !
709 USE MODI_IO_BUFF_n
710 USE MODI_ERROR_WRITE_SURF_FA
711 !
712 USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
713 USE PARKIND1  ,ONLY : JPRB
714 !
715 IMPLICIT NONE
716 !
717 !*      0.1   Declarations of arguments
718 !
719  CHARACTER(LEN=12),  INTENT(IN)  :: HREC     ! name of the article to be read
720 INTEGER,            INTENT(IN)  :: KYEAR    ! year
721 INTEGER,            INTENT(IN)  :: KMONTH   ! month
722 INTEGER,            INTENT(IN)  :: KDAY     ! day
723 REAL,               INTENT(IN)  :: PTIME    ! time
724 INTEGER,            INTENT(OUT) :: KRESP    ! KRESP  : return-code if a problem appears
725  CHARACTER(LEN=100), INTENT(IN)  :: HCOMMENT ! comment string
726
727 !*      0.2   Declarations of local variables
728 !
729  CHARACTER(LEN=18)     :: YNAME ! Field Name
730 INTEGER               :: IRET
731 INTEGER               :: IHOUR, IMIN, ISEC
732 INTEGER               :: INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL
733 INTEGER, DIMENSION(3) :: ITDATE
734 REAL(KIND=JPRB) :: ZHOOK_HANDLE
735 !
736 IF (LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:WRITE_SURFT0_FA',0,ZHOOK_HANDLE)
737 !
738 KRESP=0
739 !
740 IF (HREC=='DTCUR') THEN
741 !        
742   IHOUR = FLOOR(PTIME)/3600
743   IMIN  = FLOOR(PTIME)/60 - IHOUR * 60
744   ISEC  = NINT(PTIME) - IHOUR * 3600 - IMIN * 60
745   CALL FANDAR(IRET,NUNIT_FA,(/ KYEAR, KMONTH, KDAY, IHOUR, IMIN, ISEC, 0, 0, 0, 0, 0 /))
746 !
747 ELSE
748 !
749   CALL IO_BUFF_n(HREC,'W',LWORK0)
750   IF (LWORK0 .AND. LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:WRITE_SURFT0_FA',1,ZHOOK_HANDLE)
751   IF (LWORK0) RETURN
752 !
753 END IF
754 !
755 ITDATE(1) = KYEAR
756 ITDATE(2) = KMONTH
757 ITDATE(3) = KDAY
758 !
759 IF(LFANOCOMPACT)THEN
760   CALL FAVEUR(KRESP,NUNIT_FA,INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL)
761   ! -- Pour ecrire sans compactage
762   CALL FAGOTE(KRESP,NUNIT_FA,-1,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL)
763 ENDIF
764 !
765 YNAME=TRIM(CMASK)//TRIM(HREC)//'%TDATE'
766  CALL  FAECR_I_D(KRESP,NUNIT_FA,YNAME,3,ITDATE)
767 IF (KRESP/=0) THEN
768   CALL ERROR_WRITE_SURF_FA(HREC,KRESP)
769 ENDIF
770 !
771 YNAME=TRIM(CMASK)//TRIM(HREC)//'%TIME'
772  CALL  FAECR_R(KRESP,NUNIT_FA,YNAME,PTIME)
773 IF (KRESP/=0) THEN
774   CALL ERROR_WRITE_SURF_FA(HREC,KRESP)
775 ENDIF
776 !
777 IF(LFANOCOMPACT)THEN
778   ! On remet la valeur par defaut 
779   CALL FAGOTE(KRESP,NUNIT_FA,INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL)
780 ENDIF
781 !
782 IF (LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:WRITE_SURFT0_FA',1,ZHOOK_HANDLE)
783 !
784 END SUBROUTINE WRITE_SURFT0_FA
785 !
786 !     #############################################################
787       SUBROUTINE WRITE_SURFT2_FA(HREC,KL1,KL2,KYEAR,KMONTH,KDAY,PTIME,KRESP,HCOMMENT)
788 !     #############################################################
789 !
790 !!****  * - routine to write a date
791 !
792 USE MODD_SURFEX_MPI, ONLY : NRANK, NPIO, XTIME_NPIO_WRITE
793 !
794 USE MODD_SURFEX_OMP, ONLY : LWORK0, NWORKB
795 !
796 USE MODD_IO_SURF_FA, ONLY : NUNIT_FA, CMASK, NLUOUT
797 !
798 USE MODE_FASURFEX
799 !
800 USE MODI_IO_BUFF_n
801 USE MODI_ABOR1_SFX
802 USE MODI_ERROR_WRITE_SURF_FA
803 !
804 USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
805 USE PARKIND1  ,ONLY : JPRB
806 !
807 IMPLICIT NONE
808 !
809 #ifndef NOMPI
810 INCLUDE "mpif.h"
811 #endif
812 !
813 !*      0.1   Declarations of arguments
814 !
815  CHARACTER(LEN=12),  INTENT(IN)  :: HREC     ! name of the article to be read
816 INTEGER,                      INTENT(IN) :: KL1      ! number of points
817 INTEGER,                      INTENT(IN) :: KL2      ! 2nd dimension
818 INTEGER, DIMENSION(KL1,KL2), INTENT(IN)  :: KYEAR    ! year
819 INTEGER, DIMENSION(KL1,KL2), INTENT(IN)  :: KMONTH   ! month
820 INTEGER, DIMENSION(KL1,KL2), INTENT(IN)  :: KDAY     ! day
821 REAL,    DIMENSION(KL1,KL2), INTENT(IN)  :: PTIME    ! time
822 INTEGER,            INTENT(OUT) :: KRESP    ! KRESP  : return-code if a problem appears
823  CHARACTER(LEN=100), INTENT(IN)  :: HCOMMENT ! comment string
824
825 !*      0.2   Declarations of local variables
826 !
827  CHARACTER(LEN=18):: YNAME ! Field Name
828 INTEGER, DIMENSION(3,SIZE(KYEAR,1),SIZE(KYEAR,2)) :: ITDATE
829 REAL :: XTIME0
830 REAL(KIND=JPRB) :: ZHOOK_HANDLE
831 !
832 IF (LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:WRITE_SURFT2_FA',0,ZHOOK_HANDLE)
833 !
834 !$OMP SINGLE
835 NWORKB = 0
836 !
837 CALL IO_BUFF_n(HREC,'W',LWORK0)
838 !$OMP END SINGLE
839 !
840 IF (LWORK0 .AND. LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:WRITE_SURFT2_FA',1,ZHOOK_HANDLE)
841 IF (LWORK0) RETURN
842 !
843 IF (NRANK==NPIO) THEN
844   !
845 #ifndef NOMPI
846   XTIME0 = MPI_WTIME()
847 #endif
848   !  
849 !$OMP SINGLE
850   !
851   ITDATE(1,:,:) = KYEAR  (:,:)
852   ITDATE(2,:,:) = KMONTH (:,:)
853   ITDATE(3,:,:) = KDAY   (:,:)
854   !
855 !$OMP END SINGLE
856   !   
857   YNAME=TRIM(CMASK)//TRIM(HREC)
858   WRITE(NLUOUT,*) ' WRITE_SURFT2_FA : time in 2 dimensions not yet implemented : YNAME=',YNAME,'ITDATE=',ITDATE
859   CALL ABOR1_SFX('MODE_WRITE_SURF_FA:WRITE_SURFT2_FA: time in 2 dimensions not yet implemented')
860   !
861 #ifndef NOMPI
862   XTIME_NPIO_WRITE = XTIME_NPIO_WRITE + (MPI_WTIME() - XTIME0)
863 #endif
864   !  
865 ENDIF
866 !
867 IF (LHOOK) CALL DR_HOOK('MODE_WRITE_SURF_FA:WRITE_SURFT2_FA',1,ZHOOK_HANDLE)
868 !
869 END SUBROUTINE WRITE_SURFT2_FA
870 !
871 END MODULE MODE_WRITE_SURF_FA