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=LEN_HREC),  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=LEN_HREC),  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=LEN_HREC),  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=LEN_HREC),  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=LEN_HREC),   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=LEN_HREC),        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=LEN_HREC),      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=LEN_HREC),      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=LEN_HREC),  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=LEN_HREC),  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