b0e0d736916551010fc59f0aea57bc0cf28c6e99
[MNH-git_open_source-lfs.git] / src / MNH / write_surf_mnh.f90
1 !MNH_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
2 !MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
3 !MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt  
4 !MNH_LIC for details. version 1.
5 !-----------------------------------------------------------------
6 !--------------- special set of characters for RCS information
7 !-----------------------------------------------------------------
8 ! $Source$ $Revision$
9 !-----------------------------------------------------------------
10 !     #############################################################
11       SUBROUTINE WRITE_SURFX0_MNH(HREC,PFIELD,KRESP,HCOMMENT)
12 !     #############################################################
13 !
14 !!****  *READX0* - routine to read a real scalar
15 !!
16 !!    PURPOSE
17 !!    -------
18 !
19 !       The purpose of READX0 is
20 !
21 !!**  METHOD
22 !!    ------
23 !!
24 !!    EXTERNAL
25 !!    --------
26 !!
27 !!
28 !!
29 !!    IMPLICIT ARGUMENTS
30 !!    ------------------
31 !!
32 !!
33 !!    REFERENCE
34 !!    ---------
35 !!
36 !!
37 !!    AUTHOR
38 !!    ------
39 !!
40 !!      S.Malardel      *METEO-FRANCE*
41 !!
42 !!    MODIFICATIONS
43 !!    -------------
44 !!
45 !!      original                                                     01/08/03
46 !!        06/08 P. Peyrille, V. Masson : change test for writing 
47 !!                                       YY, XY, DX, DY in 1D or 2D configuration
48 !!        03/09, G.Tanguy              : add write_surft1_mnh
49 !!                                       replace ZUNDEF(surfex) by XUNDEF(MNH)
50 !!        08/2015 M.Moge    write the COVERS as 2D fields because SURFEX cannot write/read 3D fields 
51 !!                          with Z-splitting using NB_PROC_IO_W / NB_PROC_IO_W
52 !!        J.Escobar : 15/09/2015 : WENO5 & JPHEXT <> 1
53 !----------------------------------------------------------------------------
54 !
55 !*      0.    DECLARATIONS
56 !             ------------
57 !
58 USE MODE_FM
59 USE MODE_FMWRIT
60 !
61 USE MODD_IO_SURF_MNH,        ONLY : COUT, COUTFILE, NLUOUT
62 USE MODD_CONF_n,               ONLY : CSTORAGE_TYPE
63 !
64 IMPLICIT NONE
65 !
66 !*      0.1   Declarations of arguments
67 !
68 CHARACTER(LEN=12), INTENT(IN)  :: HREC     ! name of the article to be read
69 REAL,              INTENT(IN)  :: PFIELD   ! the real scalar to be read
70 INTEGER,           INTENT(OUT) :: KRESP    ! KRESP  : return-code if a problem appears
71 CHARACTER(LEN=100),INTENT(IN)  :: HCOMMENT ! Comment string
72 !
73 !*      0.2   Declarations of local variables
74 !
75 !-------------------------------------------------------------------------------
76 !
77
78 IF( ( HREC=='LAT0' .OR. HREC=='LON0' .OR. HREC=='RPK' .OR. HREC=='BETA'  &
79                  .OR. HREC=='LATORI'.OR. HREC=='LONORI'                  )&
80    .AND. CSTORAGE_TYPE/='PG' .AND. CSTORAGE_TYPE/='SU'                   ) THEN
81
82 !    WRITE(NLUOUT,*) ' MESO-NH writing'
83 !    WRITE(NLUOUT,*) '-------'
84 !    WRITE(NLUOUT,*) ' '
85 !    WRITE(NLUOUT,*) 'article ', HREC
86 !    WRITE(NLUOUT,*) 'not written in file by externalized surface'
87 !    WRITE(NLUOUT,*) ' '
88     RETURN
89 !
90 ELSE
91
92   CALL FMWRIT(COUTFILE,HREC,COUT,'--',PFIELD,0,LEN(HCOMMENT),HCOMMENT,KRESP)
93
94   IF (KRESP /=0) THEN
95 !
96     WRITE(NLUOUT,*) ' '
97     WRITE(NLUOUT,*) 'WARNING'
98     WRITE(NLUOUT,*) '-------'
99     WRITE(NLUOUT,*) ' '
100     WRITE(NLUOUT,*) 'error when writing article', HREC,'KRESP=',KRESP
101     WRITE(NLUOUT,*) ' '
102  !callabortstop
103     CALL ABORT
104     STOP
105
106   END IF
107 END IF
108
109 !-------------------------------------------------------------------------------
110 END SUBROUTINE WRITE_SURFX0_MNH
111 !
112 !     #############################################################
113       SUBROUTINE WRITE_SURFX1_MNH(HREC,KL,PFIELD,KRESP,HCOMMENT,HDIR)
114 !     #############################################################
115 !
116 !!****  *READX1* - routine to fill a real 1D array for the externalised surface
117 !!
118 !!    PURPOSE
119 !!    -------
120 !
121 !       The purpose of WRITE_SURFX1 is
122 !
123 !!**  METHOD
124 !!    ------
125 !!
126 !!    EXTERNAL
127 !!    --------
128 !!
129 !!
130 !!
131 !!    IMPLICIT ARGUMENTS
132 !!    ------------------
133 !!
134 !!
135 !!    REFERENCE
136 !!    ---------
137 !!
138 !!
139 !!    AUTHOR
140 !!    ------
141 !!
142 !!      S.Malardel      *METEO-FRANCE*
143 !!
144 !!    MODIFICATIONS
145 !!    -------------
146 !!
147 !!      original                                                     01/08/03
148 !----------------------------------------------------------------------------
149 !
150 !*      0.    DECLARATIONS
151 !             ------------
152 !
153 USE MODE_FM
154 USE MODE_FMWRIT
155 USE MODE_ll
156 USE MODE_IO_ll
157 !
158 USE MODD_PARAMETERS,  ONLY : XUNDEF, JPHEXT
159 USE MODD_CONF_n,        ONLY : CSTORAGE_TYPE
160 !
161 USE MODD_IO_SURF_MNH, ONLY :COUT, COUTFILE , NLUOUT, NMASK, CMASK, &
162                             NIU, NJU, NIB, NJB, NIE, NJE,          &
163                             NIU_ALL, NJU_ALL, NIB_ALL, NJB_ALL,    &
164                             NIE_ALL, NJE_ALL, NMASK_ALL, NHALO
165
166 USE MODI_UNPACK_1D_2D
167 !
168 USE MODI_GET_SURF_UNDEF
169 !
170 IMPLICIT NONE
171 !
172 !*      0.1   Declarations of arguments
173 !
174 CHARACTER(LEN=12),   INTENT(IN)  :: HREC     ! name of the article to be read
175 INTEGER,             INTENT(IN)  :: KL       ! number of points
176 REAL, DIMENSION(KL), INTENT(IN)  :: PFIELD   ! array containing the data field
177 INTEGER,             INTENT(OUT) :: KRESP    ! KRESP  : return-code if a problem appears
178 CHARACTER(LEN=100),  INTENT(IN)  :: HCOMMENT ! Comment string
179 CHARACTER(LEN=1),    INTENT(IN)  :: HDIR     ! type of field :
180 !                                            ! 'H' : field with
181 !                                            !       horizontal spatial dim.
182 !                                            ! 'A' : entire field with
183 !                                            !       horizontal spatial dim. :
184 !                                            !       It is not distributed on
185 !                                            !       the processors
186 !                                            ! '-' : no horizontal dim.
187 !
188 !*      0.2   Declarations of local variables
189 !
190 INTEGER           :: IGRID          ! IGRID : grid indicator
191 INTEGER           :: J1D            ! loop counter
192 INTEGER           :: I1D            ! 1D array size
193 INTEGER           :: JILOOP,JJLOOP  ! loop indexes
194
195 REAL, DIMENSION(:,:), ALLOCATABLE :: ZWORK  ! work array read in the file
196 REAL, DIMENSION(:),   ALLOCATABLE :: ZW1D   ! 1D work array
197 !
198 INTEGER           :: IIU, IJU, IIB, IJB, IIE, IJE ! dimensions of horizontal fields
199 INTEGER, DIMENSION(:), ALLOCATABLE :: IMASK       ! mask for unpacking
200 REAL              :: ZUNDEF         ! undefined value in SURFEX
201
202 !-------------------------------------------------------------------------------
203 !
204 !*       1.    Special cases with no writing
205 !        -----------------------------------
206 !
207 IF(        HREC=='LAT'                                  &
208       .OR. HREC=='LON'                                  &
209       .OR. HREC=='MESH_SIZE'                            &
210       .OR. HREC=='DX'                                   &
211       .OR. HREC=='DY'                                   ) THEN
212
213 !    WRITE(NLUOUT,*) ' MESO-NH writing'
214 !    WRITE(NLUOUT,*) '-------'
215 !    WRITE(NLUOUT,*) ' '
216 !    WRITE(NLUOUT,*) 'article ', HREC,'  with mask ', CMASK
217 !    WRITE(NLUOUT,*) 'not written in file by externalized surface'
218 !    WRITE(NLUOUT,*) ' '
219     RETURN
220 !
221 ELSE IF( (   (CSTORAGE_TYPE/='PG' .AND. CSTORAGE_TYPE/='SU') &
222               .OR. CMASK/='FULL  ')                          &
223           .AND. ( HREC=='ZS' .OR. HREC=='XX' .OR. HREC=='YY') ) THEN
224
225 !    WRITE(NLUOUT,*) ' MESO-NH writing'
226 !    WRITE(NLUOUT,*) '-------'
227 !    WRITE(NLUOUT,*) ' '
228 !    WRITE(NLUOUT,*) 'article ', HREC,'  with mask ', CMASK
229 !    WRITE(NLUOUT,*) 'not written in file by externalized surface'
230 !    WRITE(NLUOUT,*) ' '
231     RETURN
232 !
233 END IF
234 !
235 !*       2.    Ecriture
236 !        --------------
237 !
238 !
239 IF (HDIR=='A') THEN
240   IIU = NIU_ALL
241   IJU = NJU_ALL
242   IIB = NIB_ALL
243   IJB = NJB_ALL
244   IIE = NIE_ALL
245   IJE = NJE_ALL
246   ALLOCATE(IMASK(SIZE(NMASK_ALL)))
247   IMASK = NMASK_ALL
248 ELSE
249   IIU = NIU+2*NHALO
250   IJU = NJU+2*NHALO
251   IIB = NIB
252   IJB = NJB
253   IIE = NIE+2*NHALO
254   IJE = NJE+2*NHALO
255   ALLOCATE(IMASK(SIZE(NMASK)))
256   IMASK = NMASK
257 END IF
258 !
259 ALLOCATE(ZWORK(IIU,IJU))
260 ZWORK(:,:) = XUNDEF
261 !
262 IF (HDIR=='H' .OR. HDIR=='A') THEN
263   CALL UNPACK_1D_2D(IMASK,PFIELD,ZWORK(IIB:IIE,IJB:IJE))
264   IF ( HREC=='ZS' ) THEN
265     IF (LWEST_ll())  THEN
266       DO JILOOP = 1,JPHEXT
267         ZWORK(JILOOP,:) = ZWORK(IIB,:)
268       END DO
269     END IF
270     IF (LEAST_ll()) THEN
271       DO JILOOP = IIU-JPHEXT+1,IIU
272         ZWORK(JILOOP,:)=ZWORK(IIU-JPHEXT,:)
273       END DO
274     END IF
275     IF (LSOUTH_ll()) THEN
276       DO JJLOOP = 1,JPHEXT
277         ZWORK(:,JJLOOP)=ZWORK(:,IJB)
278       END DO
279     END IF
280     IF (LNORTH_ll()) THEN
281       DO JJLOOP =IJU-JPHEXT+1,IJU
282         ZWORK(:,JJLOOP)=ZWORK(:,IJU-JPHEXT)
283       END DO
284     END IF
285   END IF
286 END IF
287
288 IGRID=4
289
290  CALL GET_SURF_UNDEF(ZUNDEF)
291  WHERE (ZWORK==ZUNDEF) ZWORK=XUNDEF
292 !
293 !! Add cases in 2D (IJB=IJE) and 1D (IJB=IJE and IIB=IIE) 
294 !! to write the correct mesh
295 IF (      (CSTORAGE_TYPE=='PG' .OR. CSTORAGE_TYPE=='SU')  &
296     .AND. CMASK=='FULL  ' .AND. (HREC=='XX' .OR. HREC=='DX') ) THEN
297   ALLOCATE(ZW1D(IIU))
298   IF (IIB<IIE .AND. HREC=='XX') THEN
299     ZW1D(IIB+1:IIE) = 0.5 * ZWORK(IIB:IIE-1,1+JPHEXT) + 0.5 * ZWORK(IIB+1:IIE,1+JPHEXT)
300     ZW1D(IIB)       = 1.5 * ZWORK(IIB      ,1+JPHEXT) - 0.5 * ZWORK(IIB+1    ,1+JPHEXT)
301     DO J1D=JPHEXT,1,-1
302       ZW1D(      J1D) = 2. * ZW1D(J1D+1)   - ZW1D(J1D+2)
303       ZW1D(IIU+1-J1D) = 2. * ZW1D(IIU-J1D) - ZW1D(IIU-J1D-1)
304     END DO
305   ELSE IF (IIB==IIE .AND. HREC=='DX') THEN
306     ZW1D(IIB-1) = - 0.5 * ZWORK(IIB,1+JPHEXT)
307     ZW1D(IIB)   =   0.5 * ZWORK(IIB,1+JPHEXT)
308     ZW1D(IIB+1) =   1.5 * ZWORK(IIB,1+JPHEXT)
309   END IF
310 !
311   IF (HDIR=='A') &
312   CALL FMWRIT(COUTFILE,'XHAT',COUT,'--', ZW1D(:),4,LEN(HCOMMENT),HCOMMENT,KRESP)
313   IF (HDIR=='H') &
314   CALL FMWRIT(COUTFILE,'XHAT',COUT,'XX', ZW1D(1+NHALO:IIU-NHALO),4,LEN(HCOMMENT),HCOMMENT,KRESP)
315   DEALLOCATE(ZW1D)
316 ELSE IF ( (CSTORAGE_TYPE=='PG' .OR. CSTORAGE_TYPE=='SU')  &
317          .AND. CMASK=='FULL  ' .AND. (HREC=='YY' .OR. HREC=='DY') ) THEN
318   ALLOCATE(ZW1D(IJU))
319   IF (IJB<IJE .AND. HREC=='YY') THEN
320     ZW1D(IJB+1:IJE) = 0.5 * ZWORK(1+JPHEXT,IJB:IJE-1) + 0.5 * ZWORK(1+JPHEXT,IJB+1:IJE)
321     ZW1D(IJB)       = 1.5 * ZWORK(1+JPHEXT,IJB      ) - 0.5 * ZWORK(1+JPHEXT,IJB+1    )
322     DO J1D=JPHEXT,1,-1
323       ZW1D(      J1D) = 2. * ZW1D(J1D+1)   - ZW1D(J1D+2)
324       ZW1D(IJU+1-J1D) = 2. * ZW1D(IJU-J1D) - ZW1D(IJU-J1D-1)
325     END DO
326   ELSE IF (IJB==IJE .AND. (HREC=='DY' .OR. HREC=='YY')) THEN
327     ZW1D(IJB-1) = - 0.5 * ZWORK(1+JPHEXT,IJB)
328     ZW1D(IJB)   =   0.5 * ZWORK(1+JPHEXT,IJB)
329     ZW1D(IJB+1) =   1.5 * ZWORK(1+JPHEXT,IJB)
330   END IF
331   IF (HDIR=='A') &
332   CALL FMWRIT(COUTFILE,'YHAT',COUT,'--', ZW1D(:),4,LEN(HCOMMENT),HCOMMENT,KRESP)
333   IF (HDIR=='H') &
334   CALL FMWRIT(COUTFILE,'YHAT',COUT,'YY', ZW1D(1+NHALO:IJU-NHALO),4,LEN(HCOMMENT),HCOMMENT,KRESP)
335   DEALLOCATE(ZW1D)
336 ELSE IF (HDIR=='H') THEN
337   CALL FMWRIT(COUTFILE,HREC,COUT,'XY', ZWORK(1+NHALO:IIU-NHALO,1+NHALO:IJU-NHALO),IGRID,LEN(HCOMMENT),HCOMMENT,KRESP)
338 ELSE IF (HDIR=='A') THEN
339   CALL FMWRIT(COUTFILE,HREC,COUT,'--', ZWORK(:,:),IGRID,LEN(HCOMMENT),HCOMMENT,KRESP)
340 ELSE
341   CALL FMWRIT(COUTFILE,HREC,COUT,'--', PFIELD(:),IGRID,LEN(HCOMMENT),HCOMMENT,KRESP)
342 END IF
343 !
344
345  IF (KRESP /=0) THEN
346 !
347     WRITE(NLUOUT,*) ' '
348     WRITE(NLUOUT,*) 'WARNING'
349     WRITE(NLUOUT,*) '-------'
350     WRITE(NLUOUT,*) ' '
351     WRITE(NLUOUT,*) 'error when writing article', HREC,'KRESP=',KRESP
352     WRITE(NLUOUT,*) ' '
353     CALL ABORT
354     stop
355
356  END IF
357 !
358 DEALLOCATE(ZWORK)
359 DEALLOCATE(IMASK)
360 !
361 !-------------------------------------------------------------------------------
362 END SUBROUTINE WRITE_SURFX1_MNH
363 !
364 !     #############################################################
365       SUBROUTINE WRITE_SURFX2COV_MNH(HREC,KL1,KL2,PFIELD,OFLAG,KRESP,HCOMMENT,HDIR)
366 !     #############################################################
367 !
368 !!****  *READX1* - routine to fill a real 1D array for the externalised surface
369 !!
370 !!    PURPOSE
371 !!    -------
372 !
373 !       The purpose of WRITE_SURFX1 is
374 !
375 !!**  METHOD
376 !!    ------
377 !!
378 !!    EXTERNAL
379 !!    --------
380 !!
381 !!
382 !!
383 !!    IMPLICIT ARGUMENTS
384 !!    ------------------
385 !!
386 !!
387 !!    REFERENCE
388 !!    ---------
389 !!
390 !!
391 !!    AUTHOR
392 !!    ------
393 !!
394 !!      S.Malardel      *METEO-FRANCE*
395 !!
396 !!    MODIFICATIONS
397 !!    -------------
398 !!
399 !!      original                                                     01/08/03
400 !----------------------------------------------------------------------------
401 !
402 !*      0.    DECLARATIONS
403 !             ------------
404 !
405 USE MODE_FM
406 USE MODE_FMWRIT
407 USE MODE_ll
408 USE MODE_IO_ll
409 !
410 USE MODD_PARAMETERS,  ONLY : XUNDEF, JPHEXT
411 USE MODD_CONF_n,        ONLY : CSTORAGE_TYPE
412 USE MODD_CONFZ ,        ONLY : NB_PROCIO_W
413 !
414 USE MODD_IO_SURF_MNH, ONLY :COUT, COUTFILE , NLUOUT, NMASK, CMASK, &
415                             NIU, NJU, NIB, NJB, NIE, NJE,          &
416                             NIU_ALL, NJU_ALL, NIB_ALL, NJB_ALL,    &
417                             NIE_ALL, NJE_ALL, NMASK_ALL, NHALO
418
419 USE MODI_UNPACK_1D_2D
420 !
421 IMPLICIT NONE
422 !
423 !*      0.1   Declarations of arguments
424 !
425 CHARACTER(LEN=12),   INTENT(IN)  :: HREC     ! name of the article to be read
426 INTEGER,             INTENT(IN)  :: KL1,KL2       ! number of points
427 REAL, DIMENSION(KL1,KL2), INTENT(IN)  :: PFIELD   ! array containing the data field
428 LOGICAL,DIMENSION(KL2),   INTENT(IN)  ::OFLAG  ! mask for array filling
429 INTEGER,             INTENT(OUT) :: KRESP    ! KRESP  : return-code if a problem appears
430 CHARACTER(LEN=100),  INTENT(IN)  :: HCOMMENT ! Comment string
431 CHARACTER(LEN=1),    INTENT(IN)  :: HDIR     ! type of field :
432 !                                            ! 'H' : field with
433 !                                            !       horizontal spatial dim.
434 !                                            ! 'A' : entire field with
435 !                                            !       horizontal spatial dim. :
436 !                                            !       It is not distributed on
437 !                                            !       the processors
438 !                                            ! '-' : no horizontal dim.
439 !
440 !*      0.2   Declarations of local variables
441 !
442 INTEGER           :: IGRID          ! IGRID : grid indicator
443 INTEGER           :: J1D            ! loop counter
444 INTEGER           :: I1D            ! 1D array size
445 INTEGER           :: JILOOP,JJLOOP  ! loop indexes
446
447 REAL, DIMENSION(:,:), ALLOCATABLE :: ZWORK  ! work array read in the file
448 REAL, DIMENSION(:),   ALLOCATABLE :: ZW1D   ! 1D work array
449 !
450 INTEGER           :: IIU, IJU, IIB, IJB, IIE, IJE ! dimensions of horizontal fields
451 INTEGER, DIMENSION(:), ALLOCATABLE :: IMASK       ! mask for unpacking
452 !
453 CHARACTER(LEN=16) :: YREC
454 CHARACTER(LEN=100):: YCOMMENT
455 !JUANZ
456 INTEGER           :: NCOVER,ICOVER,IKL2, JL2
457 REAL,DIMENSION(:,:,:), ALLOCATABLE :: ZWORK3D
458 !JUANZ
459 CHARACTER(LEN=2)  :: YDIR
460 LOGICAL           :: GCOVER_PACKED   ! .T. if cover fields are all packed together
461 !-------------------------------------------------------------------------------
462 !
463 !*       2.    Ecriture
464 !        --------------
465 !
466 IF (CMASK/='FULL') RETURN
467 !
468 IF (HDIR=='A') THEN
469   YDIR='--'
470   IIU = NIU_ALL
471   IJU = NJU_ALL
472   IIB = NIB_ALL
473   IJB = NJB_ALL
474   IIE = NIE_ALL
475   IJE = NJE_ALL
476   ALLOCATE(IMASK(SIZE(NMASK_ALL)))
477   IMASK = NMASK_ALL
478 ELSE
479   YDIR='XY'
480   IIU = NIU+2*NHALO
481   IJU = NJU+2*NHALO
482   IIB = NIB
483   IJB = NJB
484   IIE = NIE+2*NHALO
485   IJE = NJE+2*NHALO
486   ALLOCATE(IMASK(SIZE(NMASK)))
487   IMASK = NMASK
488 END IF
489 !
490 ! we write the COVERS as 2D fields because SURFEX cannot write/read 3D fields 
491 ! with Z-splitting using NB_PROC_IO_W / NB_PROC_IO_W, so we do not use GCOVER_PACKED 
492 !GCOVER_PACKED = ( NB_PROCIO_W /= 1 )
493 GCOVER_PACKED = .FALSE.
494 IGRID=0
495 YREC='COVER_PACKED'
496 YCOMMENT=''
497 CALL FMWRIT(COUTFILE,YREC,COUT,'--',GCOVER_PACKED,IGRID,LEN(YCOMMENT),YCOMMENT,KRESP)
498 !
499 ALLOCATE(ZWORK(IIU,IJU))
500 ZWORK(:,:) = XUNDEF
501 NCOVER=COUNT(OFLAG)
502 ALLOCATE(ZWORK3D(IIU,IJU,NCOVER))
503 ZWORK3D = XUNDEF
504 !
505 ICOVER=0
506 DO IKL2=1,KL2
507   IF (OFLAG(IKL2)) THEN
508     ICOVER=ICOVER+1   
509     CALL UNPACK_1D_2D(IMASK,PFIELD(:,IKL2),ZWORK3D(IIB:IIE,IJB:IJE,ICOVER))
510   END IF
511 END DO
512
513 IGRID=4
514
515 IF (.NOT. GCOVER_PACKED) THEN
516   ICOVER=0
517   DO JL2=1,KL2
518     WRITE(YREC,'(A5,I3.3)') 'COVER',JL2
519     IF (OFLAG(JL2)) THEN
520       ICOVER=ICOVER+1
521       CALL FMWRIT(COUTFILE,YREC,COUT,YDIR, ZWORK3D(1+NHALO:IIU-NHALO,1+NHALO:IJU-NHALO,ICOVER),IGRID,LEN(HCOMMENT),HCOMMENT,KRESP)
522     END IF
523   END DO
524 ELSE 
525   CALL FMWRIT(COUTFILE,HREC,COUT,YDIR, ZWORK3D(1+NHALO:IIU-NHALO,1+NHALO:IJU-NHALO,:),IGRID,LEN(HCOMMENT),HCOMMENT,KRESP)
526 END IF
527 !
528 DEALLOCATE(ZWORK3D)
529
530  IF (KRESP /=0) THEN
531 !
532     WRITE(NLUOUT,*) ' '
533     WRITE(NLUOUT,*) 'WARNING'
534     WRITE(NLUOUT,*) '-------'
535     WRITE(NLUOUT,*) ' '
536     WRITE(NLUOUT,*) 'error when writing article', HREC,'KRESP=',KRESP
537     WRITE(NLUOUT,*) ' '
538     stop
539
540  END IF
541 !
542 DEALLOCATE(ZWORK)
543 DEALLOCATE(IMASK)
544 !
545 !-------------------------------------------------------------------------------
546 END SUBROUTINE WRITE_SURFX2COV_MNH
547 !
548 !     #############################################################
549       SUBROUTINE WRITE_SURFX2_MNH(HREC,KL1,KL2,PFIELD,KRESP,HCOMMENT,HDIR)
550 !     #############################################################
551 !
552 !!****  *READX2* - routine to fill a real 2D array for the externalised surface
553 !!
554 !!    PURPOSE
555 !!    -------
556 !
557 !       The purpose of WRITE_SURFX2 is
558 !
559 !!**  METHOD
560 !!    ------
561 !!
562 !!    EXTERNAL
563 !!    --------
564 !!
565 !!
566 !!
567 !!    IMPLICIT ARGUMENTS
568 !!    ------------------
569 !!
570 !!
571 !!    REFERENCE
572 !!    ---------
573 !!
574 !!
575 !!    AUTHOR
576 !!    ------
577 !!
578 !!      S.Malardel      *METEO-FRANCE*
579 !!
580 !!    MODIFICATIONS
581 !!    -------------
582 !!
583 !!      original                                                     01/08/03
584 !!      G.TANGUY 03/2009   add replace ZUNDEF(surfex) by XUNDEF(MNH)
585 !----------------------------------------------------------------------------
586 !
587 !*      0.    DECLARATIONS
588 !             ------------
589 !
590 USE MODE_FM
591 USE MODE_FMWRIT
592 USE MODE_ll
593 USE MODE_IO_ll
594 !
595 USE MODD_PARAMETERS,     ONLY : XUNDEF
596 !
597 USE MODD_IO_SURF_MNH, ONLY :COUT, COUTFILE , NLUOUT, NMASK,        &
598                             NIU, NJU, NIB, NJB, NIE, NJE,          &
599                             NIU_ALL, NJU_ALL, NIB_ALL, NJB_ALL,    &
600                             NIE_ALL, NJE_ALL, NMASK_ALL, NHALO
601 !
602 !
603 USE MODI_UNPACK_1D_2D
604 !
605 USE MODI_GET_SURF_UNDEF
606 !
607 IMPLICIT NONE
608 !
609 !*      0.1   Declarations of arguments
610 !
611 CHARACTER(LEN=12),        INTENT(IN)  :: HREC     ! name of the article to be read
612 INTEGER,                  INTENT(IN)  :: KL1      ! number of points
613 INTEGER,                  INTENT(IN)  :: KL2      ! 2nd dimension
614 REAL, DIMENSION(KL1,KL2), INTENT(IN)  :: PFIELD   ! array containing the data field
615 INTEGER,                  INTENT(OUT) :: KRESP    ! KRESP  : return-code if a problem appears
616 CHARACTER(LEN=100),       INTENT(IN)  :: HCOMMENT ! Comment string
617 CHARACTER(LEN=1),         INTENT(IN)  :: HDIR     ! type of field :
618 !                                                 ! 'H' : field with
619 !                                                 !       horizontal spatial dim.
620 !                                                 ! 'A' : entire field with
621 !                                                 !       horizontal spatial dim. :
622 !                                                 !       It is not distributed on
623 !                                                 !       the processors
624 !                                                 ! '-' : no horizontal dim.
625 !
626 !*      0.2   Declarations of local variables
627 !
628 INTEGER           :: IGRID          ! IGRID : grid indicator
629
630 REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZWORK  ! work array read in the file
631 REAL, DIMENSION(:,:), ALLOCATABLE :: ZFIELD  ! work array read in the file
632 INTEGER, DIMENSION(:), ALLOCATABLE :: IMASK       ! mask for unpacking
633 REAL              :: ZUNDEF         ! undefined value in SURFEX
634
635 INTEGER           :: IIU, IJU, IIB, IJB, IIE, IJE ! dimensions of horizontal fields
636 !-------------------------------------------------------------------------------
637 !
638 IF (HDIR=='A') THEN
639   IIU = NIU_ALL
640   IJU = NJU_ALL
641   IIB = NIB_ALL
642   IJB = NJB_ALL
643   IIE = NIE_ALL
644   IJE = NJE_ALL
645   ALLOCATE(IMASK(SIZE(NMASK_ALL)))
646   IMASK = NMASK_ALL
647 ELSE
648   IIU = NIU+2*NHALO
649   IJU = NJU+2*NHALO
650   IIB = NIB
651   IJB = NJB
652   IIE = NIE+2*NHALO
653   IJE = NJE+2*NHALO
654   ALLOCATE(IMASK(SIZE(NMASK)))
655   IMASK = NMASK
656 END IF
657 !
658 IGRID=4
659 CALL GET_SURF_UNDEF(ZUNDEF)
660
661 IF (HDIR=='H' .OR. HDIR=='A') THEN
662   ALLOCATE(ZWORK(IIU,IJU,SIZE(PFIELD,2)))
663   ZWORK(:,:,:) = XUNDEF
664   CALL UNPACK_1D_2D(NMASK,PFIELD(:,:),ZWORK(IIB:IIE,IJB:IJE,:))
665   WHERE (ZWORK==ZUNDEF) ZWORK=XUNDEF
666
667   IF (HDIR=='H') &
668   CALL FMWRIT(COUTFILE,HREC,COUT,'XY', ZWORK(1+NHALO:IIU-NHALO,1+NHALO:IJU-NHALO,:),IGRID,LEN(HCOMMENT),HCOMMENT,KRESP)
669   IF (HDIR=='A') &
670   CALL FMWRIT(COUTFILE,HREC,COUT,'--', ZWORK(:,:,:),IGRID,LEN(HCOMMENT),HCOMMENT,KRESP)
671
672   DEALLOCATE(ZWORK)
673   DEALLOCATE(IMASK)
674 ELSE IF (HDIR=='-') THEN
675   ALLOCATE(ZFIELD(KL1,KL2))
676   ZFIELD=PFIELD
677   WHERE (ZFIELD==ZUNDEF) ZFIELD=XUNDEF
678   CALL FMWRIT(COUTFILE,HREC,COUT,'--', ZFIELD(:,:),IGRID,LEN(HCOMMENT),HCOMMENT,KRESP)
679   DEALLOCATE(ZFIELD)
680 END IF
681 !
682 !
683 IF (KRESP /=0) THEN
684 !
685     WRITE(NLUOUT,*) ' '
686     WRITE(NLUOUT,*) 'WARNING'
687     WRITE(NLUOUT,*) '-------'
688     WRITE(NLUOUT,*) ' '
689     WRITE(NLUOUT,*) 'error when writing article', HREC,'KRESP=',KRESP
690     WRITE(NLUOUT,*) ' '
691     CALL ABORT
692     STOP
693
694  END IF
695 !
696 !
697 !-------------------------------------------------------------------------------
698 END SUBROUTINE WRITE_SURFX2_MNH
699 !
700 !     #############################################################
701       SUBROUTINE WRITE_SURFN0_MNH(HREC,KFIELD,KRESP,HCOMMENT)
702 !     #############################################################
703 !
704 !!****  *READN0* - routine to read an integer
705 !!
706 !!    PURPOSE
707 !!    -------
708 !
709 !       The purpose of READN0 is
710 !
711 !!**  METHOD
712 !!    ------
713 !!
714 !!    EXTERNAL
715 !!    --------
716 !!
717 !!
718 !!
719 !!    IMPLICIT ARGUMENTS
720 !!    ------------------
721 !!
722 !!
723 !!    REFERENCE
724 !!    ---------
725 !!
726 !!
727 !!    AUTHOR
728 !!    ------
729 !!
730 !!      S.Malardel      *METEO-FRANCE*
731 !!
732 !!    MODIFICATIONS
733 !!    -------------
734 !!
735 !!      original                                                     01/08/03
736 !----------------------------------------------------------------------------
737 !
738 !*      0.    DECLARATIONS
739 !             ------------
740 !
741 USE MODE_FM
742 USE MODE_FMWRIT
743 USE MODE_ll
744 USE MODE_IO_ll
745 !
746 !
747 USE MODD_PARAMETERS,     ONLY : XUNDEF
748 !
749 USE MODD_IO_SURF_MNH,    ONLY : COUT, COUTFILE, NLUOUT, NIU_ALL, NJU_ALL
750 USE MODD_CONF_n,           ONLY : CSTORAGE_TYPE
751 !
752 !
753 USE MODI_UNPACK_1D_2D
754 !
755 USE MODD_PARAMETERS, ONLY : JPHEXT
756 !
757 IMPLICIT NONE
758 !
759 !*      0.1   Declarations of arguments
760 !
761 CHARACTER(LEN=12),   INTENT(IN)  :: HREC     ! name of the article to be read
762 INTEGER,             INTENT(IN)  :: KFIELD   ! the integer to be read
763 INTEGER,             INTENT(OUT) :: KRESP    ! KRESP  : return-code if a problem appears
764 CHARACTER(LEN=100),  INTENT(IN)  :: HCOMMENT ! Comment string
765 !
766 !*      0.2   Declarations of local variables
767 !
768 INTEGER :: IFIELD
769 !-------------------------------------------------------------------------------
770 !
771 IF( (HREC=='IMAX' .OR. HREC=='JMAX' .OR. HREC=='KMAX') .AND.  &
772      CSTORAGE_TYPE/='PG' .AND. CSTORAGE_TYPE/='SU'            ) THEN
773
774
775 !    WRITE(NLUOUT,*) ' MESO-NH writing'
776 !    WRITE(NLUOUT,*) '-------'
777 !    WRITE(NLUOUT,*) ' '
778 !    WRITE(NLUOUT,*) 'article ', HREC
779 !    WRITE(NLUOUT,*) 'not written in file by externalized surface'
780 !    WRITE(NLUOUT,*) ' '
781     RETURN
782 !
783 ELSE
784   IFIELD = KFIELD
785   IF (HREC=='IMAX') IFIELD = NIU_ALL-2*JPHEXT
786   IF (HREC=='JMAX') IFIELD = NJU_ALL-2*JPHEXT
787   CALL FMWRIT(COUTFILE,HREC,COUT,'--',IFIELD,0,LEN(HCOMMENT),HCOMMENT,KRESP)
788
789   IF (KRESP /=0) THEN
790 !
791     WRITE(NLUOUT,*) ' '
792     WRITE(NLUOUT,*) 'WARNING'
793     WRITE(NLUOUT,*) '-------'
794     WRITE(NLUOUT,*) ' '
795     WRITE(NLUOUT,*) 'error when writing article', HREC,'KRESP=',KRESP
796     WRITE(NLUOUT,*) ' '
797     CALL ABORT
798     STOP
799
800   END IF
801  END IF
802
803 !-------------------------------------------------------------------------------
804 END SUBROUTINE WRITE_SURFN0_MNH
805 !
806 !     #############################################################
807       SUBROUTINE WRITE_SURFN1_MNH(HREC,KL,KFIELD,KRESP,HCOMMENT,HDIR)
808 !     #############################################################
809 !
810 !!****  *READN0* - routine to read an integer
811 !!
812 !!    PURPOSE
813 !!    -------
814 !
815 !       The purpose of READN0 is
816 !
817 !!**  METHOD
818 !!    ------
819 !!
820 !!    EXTERNAL
821 !!    --------
822 !!
823 !!
824 !!
825 !!    IMPLICIT ARGUMENTS
826 !!    ------------------
827 !!
828 !!
829 !!    REFERENCE
830 !!    ---------
831 !!
832 !!
833 !!    AUTHOR
834 !!    ------
835 !!
836 !!      S.Malardel      *METEO-FRANCE*
837 !!
838 !!    MODIFICATIONS
839 !!    -------------
840 !!
841 !!      original                                                     01/08/03
842 !----------------------------------------------------------------------------
843 !
844 !*      0.    DECLARATIONS
845 !             ------------
846 !
847 USE MODE_FM
848 USE MODE_FMWRIT
849 USE MODE_ll
850 USE MODE_IO_ll
851 !
852 !
853 USE MODD_PARAMETERS,  ONLY : NUNDEF
854 !
855 USE MODD_IO_SURF_MNH, ONLY :COUT, COUTFILE , NLUOUT, NMASK, CMASK, &
856                             NIU, NJU, NIB, NJB, NIE, NJE
857 !
858 !
859 USE MODI_UNPACK_1D_2D
860 !
861 IMPLICIT NONE
862 !
863 !*      0.1   Declarations of arguments
864 !
865 CHARACTER(LEN=12),      INTENT(IN)  :: HREC     ! name of the article to be read
866 INTEGER,                INTENT(IN)  :: KL       ! number of points
867 INTEGER, DIMENSION(KL), INTENT(IN)  :: KFIELD   ! the integer to be read
868 INTEGER,                INTENT(OUT) :: KRESP    ! KRESP  : return-code if a problem appears
869 CHARACTER(LEN=100),     INTENT(IN)  :: HCOMMENT ! Comment string
870 CHARACTER(LEN=1),       INTENT(IN)  :: HDIR     ! type of field :
871 !                                               ! 'H' : field with
872 !                                               !       horizontal spatial dim.
873 !                                               ! '-' : no horizontal dim.
874 !
875 !*      0.2   Declarations of local variables
876 !
877
878 INTEGER, DIMENSION(:,:), ALLOCATABLE :: IWORK  ! work array written in the file
879 !
880 !-------------------------------------------------------------------------------
881 !
882 IF (HDIR=='-') THEN
883 !
884  CALL FMWRIT(COUTFILE,HREC,COUT,'--',KFIELD,0,LEN(HCOMMENT),HCOMMENT,KRESP)
885 !
886 ELSE IF (HDIR=='H') THEN
887
888   ALLOCATE(IWORK(NIU,NJU))
889   IWORK(:,:) = NUNDEF
890   !
891   !
892   CALL UNPACK_1D_2D(NMASK,KFIELD,IWORK(NIB:NIE,NJB:NJE))
893
894   CALL FMWRIT(COUTFILE,HREC,COUT,'XY', IWORK(:,:),4,LEN(HCOMMENT),HCOMMENT,KRESP)
895   !
896   DEALLOCATE(IWORK)
897
898   IF (KRESP /=0) THEN
899 !
900     WRITE(NLUOUT,*) ' '
901     WRITE(NLUOUT,*) 'WARNING'
902     WRITE(NLUOUT,*) '-------'
903     WRITE(NLUOUT,*) ' '
904     WRITE(NLUOUT,*) 'error when writing article', HREC,'KRESP=',KRESP
905     WRITE(NLUOUT,*) ' '
906     CALL ABORT
907     STOP
908
909   END IF
910
911 END IF
912
913 !-------------------------------------------------------------------------------
914 END SUBROUTINE WRITE_SURFN1_MNH
915 !
916 !     #############################################################
917       SUBROUTINE WRITE_SURFC0_MNH(HREC,HFIELD,KRESP,HCOMMENT)
918 !     #############################################################
919 !
920 !!****  *READC0* - routine to read an integer
921 !!
922 !!    PURPOSE
923 !!    -------
924 !
925 !       The purpose of READC0 is
926 !
927 !!**  METHOD
928 !!    ------
929 !!
930 !!    EXTERNAL
931 !!    --------
932 !!
933 !!
934 !!
935 !!    IMPLICIT ARGUMENTS
936 !!    ------------------
937 !!
938 !!
939 !!    REFERENCE
940 !!    ---------
941 !!
942 !!
943 !!    AUTHOR
944 !!    ------
945 !!
946 !!      S.Malardel      *METEO-FRANCE*
947 !!
948 !!    MODIFICATIONS
949 !!    -------------
950 !!
951 !!      original                                                     01/08/03
952 !----------------------------------------------------------------------------
953 !
954 !*      0.    DECLARATIONS
955 !             ------------
956 !
957 USE MODE_FM
958 USE MODE_FMWRIT
959 !
960 USE MODD_CONF_n,               ONLY : CSTORAGE_TYPE
961 USE MODD_IO_SURF_MNH,        ONLY : COUT, COUTFILE, NLUOUT
962 !
963 !
964 IMPLICIT NONE
965 !
966 !*      0.1   Declarations of arguments
967 !
968 CHARACTER(LEN=12),  INTENT(IN)  :: HREC     ! name of the article to be read
969 CHARACTER(LEN=40),  INTENT(IN)  :: HFIELD   ! the integer to be read
970 INTEGER,            INTENT(OUT) :: KRESP    ! KRESP  : return-code if a problem appears
971 CHARACTER(LEN=100), INTENT(IN)  :: HCOMMENT ! Comment string
972 !
973 !*      0.2   Declarations of local variables
974 !
975 LOGICAL            :: GCARTESIAN
976 CHARACTER(LEN=100) :: YCOMMENT
977 !-------------------------------------------------------------------------------
978 !
979 IF ( (CSTORAGE_TYPE=='PG' .OR. CSTORAGE_TYPE=='SU')  &
980      .AND. HREC=='GRID_TYPE       '                  ) THEN
981   IF (HFIELD(1:10)=='CONF PROJ ') THEN
982     GCARTESIAN = .FALSE.
983   ELSE IF (HFIELD(1:10)=='CARTESIAN ') THEN
984     GCARTESIAN = .TRUE.
985   END IF
986   YCOMMENT = '(-)'
987   CALL FMWRIT(COUTFILE,'CARTESIAN',COUT,'--',GCARTESIAN,0,LEN(YCOMMENT),YCOMMENT,KRESP)
988 END IF
989
990 CALL FMWRIT(COUTFILE,HREC,COUT,'--',HFIELD,0,LEN(HCOMMENT),HCOMMENT,KRESP)
991
992  IF (KRESP /=0) THEN
993 !
994     WRITE(NLUOUT,*) ' '
995     WRITE(NLUOUT,*) 'WARNING'
996     WRITE(NLUOUT,*) '-------'
997     WRITE(NLUOUT,*) ' '
998     WRITE(NLUOUT,*) 'error when writing article', HREC,'KRESP=',KRESP
999     WRITE(NLUOUT,*) ' '
1000     CALL ABORT
1001     STOP
1002
1003  END IF
1004 !-------------------------------------------------------------------------------
1005 END SUBROUTINE WRITE_SURFC0_MNH
1006 !
1007 !     #############################################################
1008       SUBROUTINE WRITE_SURFL1_MNH(HREC,KL,OFIELD,KRESP,HCOMMENT,HDIR)
1009 !     #############################################################
1010 !
1011 !!****  *READL1* - routine to read a logical array
1012 !!
1013 !!    PURPOSE
1014 !!    -------
1015 !
1016 !       The purpose of READL1 is
1017 !
1018 !!**  METHOD
1019 !!    ------
1020 !!
1021 !!    EXTERNAL
1022 !!    --------
1023 !!
1024 !!
1025 !!
1026 !!    IMPLICIT ARGUMENTS
1027 !!    ------------------
1028 !!
1029 !!
1030 !!    REFERENCE
1031 !!    ---------
1032 !!
1033 !!
1034 !!    AUTHOR
1035 !!    ------
1036 !!
1037 !!      S.Malardel      *METEO-FRANCE*
1038 !!
1039 !!    MODIFICATIONS
1040 !!    -------------
1041 !!
1042 !!      original                                                     01/08/03
1043 !----------------------------------------------------------------------------
1044 !
1045 !*      0.    DECLARATIONS
1046 !             ------------
1047 !
1048 USE MODE_FM
1049 USE MODE_FMWRIT
1050 USE MODI_UNPACK_1D_2D
1051 !
1052 USE MODD_IO_SURF_MNH, ONLY :COUT, COUTFILE , NLUOUT, NMASK, CMASK, &
1053                             NIU, NJU, NIB, NJB, NIE, NJE
1054 !
1055 !
1056 IMPLICIT NONE
1057 !
1058 !*      0.1   Declarations of arguments
1059 !
1060 CHARACTER(LEN=12),      INTENT(IN)  :: HREC     ! name of the article to be read
1061 INTEGER,                INTENT(IN)  :: KL       ! number of points
1062 LOGICAL, DIMENSION(KL), INTENT(IN)  :: OFIELD   ! array containing the data field
1063 INTEGER,                INTENT(OUT) :: KRESP    ! KRESP  : return-code if a problem appears
1064 CHARACTER(LEN=100),     INTENT(IN)  :: HCOMMENT ! Comment string
1065 CHARACTER(LEN=1),       INTENT(IN)  :: HDIR     ! type of field :
1066 !                                               ! 'H' : field with
1067 !                                               !       horizontal spatial dim.
1068 !                                               ! '-' : no horizontal dim.
1069 !
1070 !*      0.2   Declarations of local variables
1071 !
1072 LOGICAL, DIMENSION(:,:), ALLOCATABLE :: GWORK  ! work array written in the file
1073 INTEGER, DIMENSION(:,:), ALLOCATABLE :: IWORK  ! work array written in the file
1074
1075 !-------------------------------------------------------------------------------
1076
1077 IF (HDIR=='-') THEN
1078   IF( (CMASK /= 'FULL  ').AND. (HREC=='COVER') ) THEN
1079 !    WRITE(NLUOUT,*) ' MESO-NH writing'
1080 !    WRITE(NLUOUT,*) '-------'
1081 !    WRITE(NLUOUT,*) ' '
1082 !    WRITE(NLUOUT,*) 'article ', HREC,'  with MASK ',CMASK
1083 !    WRITE(NLUOUT,*) 'not written in file by externalized surface'
1084 !    WRITE(NLUOUT,*) ' '
1085     RETURN
1086   !
1087   ELSE
1088     CALL FMWRIT(COUTFILE,HREC,COUT,'--',OFIELD(:),0,LEN(HCOMMENT),HCOMMENT,KRESP)
1089
1090     IF (KRESP /=0) THEN
1091 !
1092       WRITE(NLUOUT,*) ' '
1093       WRITE(NLUOUT,*) 'WARNING'
1094       WRITE(NLUOUT,*) '-------'
1095       WRITE(NLUOUT,*) ' '
1096       WRITE(NLUOUT,*) 'error when writing article', HREC,'KRESP=',KRESP
1097       WRITE(NLUOUT,*) ' '
1098       CALL ABORT
1099       STOP
1100
1101     END IF
1102
1103   END IF
1104
1105 ELSE IF (HDIR=='H') THEN
1106
1107   ALLOCATE(GWORK(NIU,NJU))
1108   GWORK(:,:) = .FALSE.
1109   !
1110   !
1111   CALL UNPACK_1D_2D(NMASK,OFIELD,GWORK(NIB:NIE,NJB:NJE))
1112
1113   ALLOCATE(IWORK(NIU,NJU))
1114   IWORK = 0
1115   WHERE(GWORK) IWORK = 1
1116   CALL FMWRIT(COUTFILE,HREC,COUT,'XY', IWORK(:,:),4,LEN(HCOMMENT),HCOMMENT,KRESP)
1117   DEALLOCATE(IWORK)
1118   !
1119   DEALLOCATE(GWORK)
1120
1121   IF (KRESP /=0) THEN
1122 !
1123     WRITE(NLUOUT,*) ' '
1124     WRITE(NLUOUT,*) 'WARNING'
1125     WRITE(NLUOUT,*) '-------'
1126     WRITE(NLUOUT,*) ' '
1127     WRITE(NLUOUT,*) 'error when writing article', HREC,'KRESP=',KRESP
1128     WRITE(NLUOUT,*) ' '
1129     CALL ABORT
1130     STOP
1131
1132   END IF
1133
1134 END IF
1135 !
1136 !-------------------------------------------------------------------------------
1137 END SUBROUTINE WRITE_SURFL1_MNH
1138 !
1139 !
1140 !     #############################################################
1141       SUBROUTINE WRITE_SURFL0_MNH(HREC,OFIELD,KRESP,HCOMMENT)
1142 !     #############################################################
1143 !
1144 !!****  *WRITEL1* - routine to read a logical
1145 !!
1146 !!    PURPOSE
1147 !!    -------
1148 !
1149 !
1150 !!**  METHOD
1151 !!    ------
1152 !!
1153 !!    EXTERNAL
1154 !!    --------
1155 !!
1156 !!
1157 !!
1158 !!    IMPLICIT ARGUMENTS
1159 !!    ------------------
1160 !!
1161 !!
1162 !!    REFERENCE
1163 !!    ---------
1164 !!
1165 !!
1166 !!    AUTHOR
1167 !!    ------
1168 !!
1169 !!      S.Malardel      *METEO-FRANCE*
1170 !!
1171 !!    MODIFICATIONS
1172 !!    -------------
1173 !!
1174 !!      original                                                     01/08/03
1175 !----------------------------------------------------------------------------
1176 !
1177 !*      0.    DECLARATIONS
1178 !             ------------
1179 !
1180 USE MODE_FM
1181 USE MODE_FMWRIT
1182 !
1183 USE MODD_IO_SURF_MNH,        ONLY : COUT, COUTFILE, NLUOUT, CMASK
1184 !
1185 !
1186 IMPLICIT NONE
1187 !
1188 !*      0.1   Declarations of arguments
1189 !
1190 CHARACTER(LEN=12),  INTENT(IN)  :: HREC     ! name of the article to be read
1191 LOGICAL,            INTENT(IN)  :: OFIELD   ! array containing the data field
1192 INTEGER,            INTENT(OUT) :: KRESP    ! KRESP  : return-code if a problem appears
1193 CHARACTER(LEN=100), INTENT(IN)  :: HCOMMENT ! Comment string
1194 !
1195 !*      0.2   Declarations of local variables
1196 !
1197
1198
1199 IF( (CMASK /= 'FULL  ').AND. (HREC=='COVER') ) THEN
1200 !    WRITE(NLUOUT,*) ' MESO-NH writing'
1201 !    WRITE(NLUOUT,*) '-------'
1202 !    WRITE(NLUOUT,*) ' '
1203 !    WRITE(NLUOUT,*) 'article ', HREC,'  with MASK ',CMASK
1204 !    WRITE(NLUOUT,*) 'not written in file by externalized surface'
1205 !    WRITE(NLUOUT,*) ' '
1206     RETURN
1207 !
1208 ELSE
1209 CALL FMWRIT(COUTFILE,HREC,COUT,'--',OFIELD,0,LEN(HCOMMENT),HCOMMENT,KRESP)
1210
1211  IF (KRESP /=0) THEN
1212 !
1213     WRITE(NLUOUT,*) ' '
1214     WRITE(NLUOUT,*) 'WARNING'
1215     WRITE(NLUOUT,*) '-------'
1216     WRITE(NLUOUT,*) ' '
1217     WRITE(NLUOUT,*) 'error when writing article', HREC,'KRESP=',KRESP
1218     WRITE(NLUOUT,*) ' '
1219     CALL ABORT
1220     STOP
1221
1222  END IF
1223
1224 END IF
1225 !-------------------------------------------------------------------------------
1226 END SUBROUTINE WRITE_SURFL0_MNH
1227 !
1228 !     #############################################################
1229       SUBROUTINE WRITE_SURFT0_MNH(HREC,KYEAR,KMONTH,KDAY,PTIME,KRESP,HCOMMENT)
1230 !     #############################################################
1231 !
1232 !!****  *READT0* - routine to read a MESO-NH date_time scalar
1233 !!
1234 !!    PURPOSE
1235 !!    -------
1236 !
1237 !       The purpose of READT0 is
1238 !
1239 !!**  METHOD
1240 !!    ------
1241 !!
1242 !!    EXTERNAL
1243 !!    --------
1244 !!
1245 !!
1246 !!
1247 !!    IMPLICIT ARGUMENTS
1248 !!    ------------------
1249 !!
1250 !!
1251 !!    REFERENCE
1252 !!    ---------
1253 !!
1254 !!
1255 !!    AUTHOR
1256 !!    ------
1257 !!
1258 !!      V. MASSON      *METEO-FRANCE*
1259 !!
1260 !!    MODIFICATIONS
1261 !!    -------------
1262 !!
1263 !!      original                                                     18/08/97
1264 !----------------------------------------------------------------------------
1265 !
1266 !*      0.    DECLARATIONS
1267 !             ------------
1268 !
1269 USE MODE_FM
1270 USE MODE_FMWRIT
1271 !
1272 USE MODD_IO_SURF_MNH,        ONLY : COUT, COUTFILE, NLUOUT
1273 USE MODD_CONF_n,               ONLY : CSTORAGE_TYPE
1274 !
1275 !
1276 IMPLICIT NONE
1277 !
1278 !*      0.1   Declarations of arguments
1279 !
1280 CHARACTER(LEN=12),  INTENT(IN)  :: HREC     ! name of the article to be read
1281 INTEGER,            INTENT(IN)  :: KYEAR    ! year
1282 INTEGER,            INTENT(IN)  :: KMONTH   ! month
1283 INTEGER,            INTENT(IN)  :: KDAY     ! day
1284 REAL,               INTENT(IN)  :: PTIME    ! time
1285 INTEGER,            INTENT(OUT) :: KRESP    ! KRESP  : return-code if a problem appears
1286 CHARACTER(LEN=100), INTENT(IN)  :: HCOMMENT ! Comment string
1287
1288 !*      0.2   Declarations of local variables
1289 !
1290 !
1291 CHARACTER(LEN=16)      :: YRECFM    ! Name of the article to be written
1292 INTEGER, DIMENSION(3)  :: ITDATE
1293 !-------------------------------------------------------------------------------
1294 !
1295 !
1296 IF( HREC=='DTCUR' .AND. CSTORAGE_TYPE/='SU' ) THEN
1297 !    WRITE(NLUOUT,*) ' MESO-NH writing'
1298 !    WRITE(NLUOUT,*) '-------'
1299 !    WRITE(NLUOUT,*) ' '
1300 !    WRITE(NLUOUT,*) 'article ', HREC
1301 !    WRITE(NLUOUT,*) 'not written in file by externalized surface'
1302 !    WRITE(NLUOUT,*) ' '
1303     RETURN
1304 !
1305 ELSE
1306
1307
1308 YRECFM=TRIM(HREC)//'%TDATE'
1309 !
1310 ITDATE(1)=KYEAR
1311 ITDATE(2)=KMONTH
1312 ITDATE(3)=KDAY
1313 CALL FMWRIT(COUTFILE,YRECFM,COUT,'--',ITDATE,0,LEN(HCOMMENT),HCOMMENT,KRESP)
1314
1315  IF (KRESP /=0) THEN
1316 !
1317     WRITE(NLUOUT,*) ' '
1318     WRITE(NLUOUT,*) 'WARNING'
1319     WRITE(NLUOUT,*) '-------'
1320     WRITE(NLUOUT,*) ' '
1321     WRITE(NLUOUT,*) 'error when writing article', HREC,'KRESP=',KRESP
1322     WRITE(NLUOUT,*) ' '
1323     CALL ABORT
1324     STOP
1325
1326  END IF
1327 !
1328 YRECFM=TRIM(HREC)//'%TIME'
1329 CALL FMWRIT(COUTFILE,YRECFM,COUT,'--',PTIME,0,LEN(HCOMMENT),HCOMMENT,KRESP)
1330
1331  IF (KRESP /=0) THEN
1332 !
1333     WRITE(NLUOUT,*) ' '
1334     WRITE(NLUOUT,*) 'WARNING'
1335     WRITE(NLUOUT,*) '-------'
1336     WRITE(NLUOUT,*) ' '
1337     WRITE(NLUOUT,*) 'error when writing article', HREC,'KRESP=',KRESP
1338     WRITE(NLUOUT,*) ' '
1339     CALL ABORT
1340     STOP
1341
1342  END IF
1343
1344 END IF
1345
1346 END SUBROUTINE WRITE_SURFT0_MNH
1347
1348 !     #############################################################
1349       SUBROUTINE WRITE_SURFT1_MNH(HREC,KL1,KYEAR,KMONTH,KDAY,PTIME,KRESP,HCOMMENT)
1350 !     #############################################################
1351 !
1352 !!****  * - routine to write a date vector
1353 !!
1354 !!    PURPOSE
1355 !!    -------
1356 !
1357 !
1358 !!**  METHOD
1359 !!    ------
1360 !!
1361 !!    EXTERNAL
1362 !!    --------
1363 !!
1364 !!
1365 !!
1366 !!    IMPLICIT ARGUMENTS
1367 !!    ------------------
1368 !!
1369 !!
1370 !!    REFERENCE
1371 !!    ---------
1372 !!
1373 !!
1374 !!    AUTHOR
1375 !!    ------
1376 !!
1377 !!      G.TANGUY      *METEO-FRANCE*
1378 !!
1379 !!    MODIFICATIONS
1380 !!    -------------
1381 !!
1382 !!      original                                                     03/03/09
1383 !----------------------------------------------------------------------------
1384 !
1385 !*      0.    DECLARATIONS
1386 !             ------------
1387 !
1388 USE MODE_FM
1389 USE MODE_FMWRIT
1390 !
1391 USE MODD_IO_SURF_MNH,        ONLY : COUT, COUTFILE, NLUOUT
1392 USE MODD_CONF_n,               ONLY : CSTORAGE_TYPE
1393 !
1394 !
1395 IMPLICIT NONE
1396 !
1397 !*      0.1   Declarations of arguments
1398 !
1399 CHARACTER(LEN=12),  INTENT(IN) :: HREC     ! name of the article to be read
1400 INTEGER,            INTENT(IN) :: KL1       ! number of points
1401 INTEGER, DIMENSION(KL1), INTENT(IN)  :: KYEAR    ! year
1402 INTEGER, DIMENSION(KL1), INTENT(IN)  :: KMONTH   ! month
1403 INTEGER, DIMENSION(KL1), INTENT(IN)  :: KDAY     ! day
1404 REAL,    DIMENSION(KL1), INTENT(IN)  :: PTIME    ! time
1405 INTEGER,            INTENT(OUT) :: KRESP    ! KRESP  : return-code if a problem appears
1406 CHARACTER(LEN=100), INTENT(IN)  :: HCOMMENT ! Comment string
1407
1408 !*      0.2   Declarations of local variables
1409 !
1410 !
1411 CHARACTER(LEN=16)      :: YRECFM    ! Name of the article to be written
1412 INTEGER, DIMENSION(3,KL1)  :: ITDATE
1413 !-------------------------------------------------------------------------------
1414 !
1415 !
1416 IF( HREC=='DTCUR' .AND. CSTORAGE_TYPE/='SU' ) THEN
1417 !    WRITE(NLUOUT,*) ' MESO-NH writing'
1418 !    WRITE(NLUOUT,*) '-------'
1419 !    WRITE(NLUOUT,*) ' '
1420 !    WRITE(NLUOUT,*) 'article ', HREC
1421 !    WRITE(NLUOUT,*) 'not written in file by externalized surface'
1422 !    WRITE(NLUOUT,*) ' '
1423     RETURN
1424 !
1425 ELSE
1426
1427
1428 YRECFM=TRIM(HREC)//'%TDATE'
1429 !
1430 ITDATE(1,:) = KYEAR  (:)
1431 ITDATE(2,:) = KMONTH (:)
1432 ITDATE(3,:) = KDAY   (:)
1433 CALL FMWRIT(COUTFILE,YRECFM,COUT,'--',ITDATE(:,:),0,LEN(HCOMMENT),HCOMMENT,KRESP)
1434
1435  IF (KRESP /=0) THEN
1436 !
1437     WRITE(NLUOUT,*) ' '
1438     WRITE(NLUOUT,*) 'WARNING'
1439     WRITE(NLUOUT,*) '-------'
1440     WRITE(NLUOUT,*) ' '
1441     WRITE(NLUOUT,*) 'error when writing article', HREC,'KRESP=',KRESP
1442     WRITE(NLUOUT,*) ' '
1443     stop
1444
1445  END IF
1446 !
1447 YRECFM=TRIM(HREC)//'%TIME'
1448 CALL FMWRIT(COUTFILE,YRECFM,COUT,'--',PTIME(:),0,LEN(HCOMMENT),HCOMMENT,KRESP)
1449
1450  IF (KRESP /=0) THEN
1451 !
1452     WRITE(NLUOUT,*) ' '
1453     WRITE(NLUOUT,*) 'WARNING'
1454     WRITE(NLUOUT,*) '-------'
1455     WRITE(NLUOUT,*) ' '
1456     WRITE(NLUOUT,*) 'error when writing article', HREC,'KRESP=',KRESP
1457     WRITE(NLUOUT,*) ' '
1458     stop
1459
1460  END IF
1461
1462 END IF
1463
1464 END SUBROUTINE WRITE_SURFT1_MNH