mode_write_surf_fa.F90

Go to the documentation of this file.

!SFX_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
!SFX_LIC This is part of the SURFEX software governed by the CeCILL-C licence
!SFX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt  
!SFX_LIC for details. version 1.
MODULE mode_write_surf_fa
!
INTERFACE write_surf0_fa
        MODULE PROCEDURE write_surfx0_fa
        MODULE PROCEDURE write_surfn0_fa
        MODULE PROCEDURE write_surfl0_fa
        MODULE PROCEDURE write_surfc0_fa
END INTERFACE
INTERFACE write_surfn_fa
        MODULE PROCEDURE write_surfx1_fa
        MODULE PROCEDURE write_surfn1_fa
        MODULE PROCEDURE write_surfl1_fa
        MODULE PROCEDURE write_surfx2_fa
END INTERFACE
INTERFACE write_surft_fa
        MODULE PROCEDURE write_surft0_fa
        MODULE PROCEDURE write_surft2_fa
END INTERFACE
!
 CONTAINS
!
!     #############################################################
      SUBROUTINE write_surfx0_fa (&
                                  hrec,pfield,kresp,hcomment)
!     #############################################################
!
!!****  * - routine to write a real scalar
!
!
!
!
USE modd_surfex_omp, ONLY : lwork0
!
USE modd_io_surf_fa, ONLY : nunit_fa, cprefix1d, lfanocompact
!
USE mode_fasurfex
!
USE modi_io_buff
USE modi_error_write_surf_fa
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
!*      0.1   Declarations of arguments
!
!
!
 CHARACTER(LEN=12),  INTENT(IN) :: hrec     ! name of the article to be read
REAL,               INTENT(IN) :: pfield   ! the real scalar to be read
INTEGER,            INTENT(OUT):: kresp    ! KRESP  : return-code if a problem appears
 CHARACTER(LEN=100), INTENT(IN) :: hcomment ! comment string
!
!*      0.2   Declarations of local variables
!
 CHARACTER(LEN=18):: yname                  ! Field Name
INTEGER          :: ingrib,inbpdg,inbcsp,istron,ipuila,idmopl
REAL(KIND=JPRB)  :: zhook_handle
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_FA:ERROR_WRITE_SURF_FA:WRITE_SURFX0_FA',0,zhook_handle)
!
kresp=0
!
 CALL io_buff(&
                hrec,'W',lwork0)
IF (lwork0 .AND. lhook) CALL dr_hook('MODE_WRITE_SURF_FA:WRITE_SURFX0_FA',1,zhook_handle)
IF (lwork0) RETURN
!
IF(lfanocompact)THEN
  CALL faveur(kresp,nunit_fa,ingrib,inbpdg,inbcsp,istron,ipuila,idmopl)
  ! -- Pour ecrire sans compactage
  CALL fagote(kresp,nunit_fa,-1,inbpdg,inbcsp,istron,ipuila,idmopl)
ENDIF
!
yname=trim(cprefix1d)//trim(hrec)
 CALL  faecr_r(kresp,nunit_fa,yname,pfield)
IF (kresp/=0) THEN
  CALL error_write_surf_fa(hrec,kresp)
ENDIF
!
IF(lfanocompact)THEN
  ! On remet la valeur par defaut 
  CALL fagote(kresp,nunit_fa,ingrib,inbpdg,inbcsp,istron,ipuila,idmopl)
ENDIF
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_FA:WRITE_SURFX0_FA',1,zhook_handle)
!
END SUBROUTINE write_surfx0_fa
!
!     #############################################################
      SUBROUTINE write_surfn0_fa (&
                                  hrec,kfield,kresp,hcomment)
!     #############################################################
!
!!****  * - routine to write an integer
!
!
!
!
USE modd_surfex_omp, ONLY : lwork0
!
USE modd_io_surf_fa, ONLY : nunit_fa, nmask, cprefix1d, lfanocompact
!
USE mode_fasurfex
!
USE modi_io_buff
USE modi_error_write_surf_fa
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
!*      0.1   Declarations of arguments
!
!
!
 CHARACTER(LEN=12),  INTENT(IN) :: hrec     ! name of the article to be read
INTEGER,            INTENT(IN) :: kfield   ! the integer to be read
INTEGER,            INTENT(OUT):: kresp    ! KRESP  : return-code if a problem appears
 CHARACTER(LEN=100), INTENT(IN) :: hcomment ! comment string
!
!*      0.2   Declarations of local variables
!
 CHARACTER(LEN=18):: yname                  ! Field Name
INTEGER          :: ingrib,inbpdg,inbcsp,istron,ipuila,idmopl
REAL(KIND=JPRB)  :: zhook_handle
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_FA:WRITE_SURFN0_FA',0,zhook_handle)
!
kresp=0
!
 CALL io_buff(&
                hrec,'W',lwork0)
IF (lwork0 .AND. lhook) CALL dr_hook('MODE_WRITE_SURF_FA:WRITE_SURFN0_FA',1,zhook_handle)
IF (lwork0) RETURN
!
IF(lfanocompact)THEN
  CALL faveur(kresp,nunit_fa,ingrib,inbpdg,inbcsp,istron,ipuila,idmopl)
  ! -- Pour ecrire sans compactage
  CALL fagote(kresp,nunit_fa,-1,inbpdg,inbcsp,istron,ipuila,idmopl)
ENDIF
!
yname=trim(cprefix1d)//trim(hrec)
 CALL  faecr_i(kresp,nunit_fa,yname,kfield)
IF (kresp/=0) THEN
  CALL error_write_surf_fa(hrec,kresp)
ENDIF
!
IF(lfanocompact)THEN
  ! On remet la valeur par defaut 
  CALL fagote(kresp,nunit_fa,ingrib,inbpdg,inbcsp,istron,ipuila,idmopl)
ENDIF
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_FA:WRITE_SURFN0_FA',1,zhook_handle)
!
END SUBROUTINE write_surfn0_fa
!
!     #############################################################
      SUBROUTINE write_surfl0_fa (&
                                  hrec,ofield,kresp,hcomment)
!     #############################################################
!
!!****  * - routine to write a logical
!
!
!
!
USE modd_surfex_omp, ONLY : lwork0
!
USE modd_io_surf_fa, ONLY : nunit_fa, cprefix1d, lfanocompact
!
USE mode_fasurfex
!
USE modi_io_buff
USE modi_error_write_surf_fa
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
!*      0.1   Declarations of arguments
!
!
!
 CHARACTER(LEN=12),  INTENT(IN) :: hrec     ! name of the article to be read
LOGICAL,            INTENT(IN) :: ofield   ! array containing the data field
INTEGER,            INTENT(OUT):: kresp    ! KRESP  : return-code if a problem appears
 CHARACTER(LEN=100), INTENT(IN) :: hcomment ! comment string
!
!*      0.2   Declarations of local variables
!
 CHARACTER(LEN=18):: yname ! Field Name
INTEGER          :: ingrib,inbpdg,inbcsp,istron,ipuila,idmopl
REAL(KIND=JPRB)  :: zhook_handle
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_FA:WRITE_SURFL0_FA',0,zhook_handle)
!
kresp=0
!
 CALL io_buff(&
                hrec,'W',lwork0)
IF (lwork0 .AND. lhook) CALL dr_hook('MODE_WRITE_SURF_FA:WRITE_SURFL0_FA',1,zhook_handle)
IF (lwork0) RETURN
!
IF(lfanocompact)THEN
  CALL faveur(kresp,nunit_fa,ingrib,inbpdg,inbcsp,istron,ipuila,idmopl)
  ! -- Pour ecrire sans compactage
  CALL fagote(kresp,nunit_fa,-1,inbpdg,inbcsp,istron,ipuila,idmopl)
ENDIF
!
yname=trim(cprefix1d)//trim(hrec)
 CALL  faecr_l(kresp,nunit_fa,yname,ofield)
IF (kresp/=0) THEN
  CALL error_write_surf_fa(hrec,kresp)
ENDIF
!
IF(lfanocompact)THEN
  ! On remet la valeur par defaut 
  CALL fagote(kresp,nunit_fa,ingrib,inbpdg,inbcsp,istron,ipuila,idmopl)
ENDIF
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_FA:WRITE_SURFL0_FA',1,zhook_handle)
!
END SUBROUTINE write_surfl0_fa
!
!     #############################################################
      SUBROUTINE write_surfc0_fa (&
                                  hrec,hfield,kresp,hcomment)
!     #############################################################
!
!!****  * - routine to write a character
!
!
!
!
USE modd_surfex_omp, ONLY : lwork0
!
USE modd_io_surf_fa, ONLY : nunit_fa, cprefix1d, lfanocompact
!
USE mode_fasurfex
!
USE modi_io_buff
USE modi_error_write_surf_fa
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
!*      0.1   Declarations of arguments
!
!
!
 CHARACTER(LEN=12),  INTENT(IN)  :: hrec      ! name of the article to be read
 CHARACTER(LEN=40),  INTENT(IN)  :: hfield    ! the integer to be read
INTEGER,            INTENT(OUT) :: kresp     ! KRESP  : return-code if a problem appears
 CHARACTER(LEN=100), INTENT(IN)  :: hcomment  ! comment string
!
!*      0.2   Declarations of local variables
!
 CHARACTER,DIMENSION(40)  :: yfield
 CHARACTER(LEN=18)        :: yname ! Field Name
INTEGER                  :: ingrib,inbpdg,inbcsp,istron,ipuila,idmopl
REAL(KIND=JPRB)          :: zhook_handle
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_FA:WRITE_SURFC0_FA',0,zhook_handle)
!
kresp=0
!
 CALL io_buff(&
                hrec,'W',lwork0)
IF (lwork0.AND. lhook) CALL dr_hook('MODE_WRITE_SURF_FA:WRITE_SURFC0_FA',1,zhook_handle)
IF (lwork0) RETURN
!
IF(lfanocompact)THEN
  CALL faveur(kresp,nunit_fa,ingrib,inbpdg,inbcsp,istron,ipuila,idmopl)
  ! -- Pour ecrire sans compactage
  CALL fagote(kresp,nunit_fa,-1,inbpdg,inbcsp,istron,ipuila,idmopl)
ENDIF
!
READ(hfield,'(40A1)') yfield
yname=trim(cprefix1d)//trim(hrec)
 CALL  faecr_c(kresp,nunit_fa,yname,40,yfield)
IF (kresp/=0) THEN
  CALL error_write_surf_fa(hrec,kresp)
ENDIF
!
IF(lfanocompact)THEN
  ! On remet la valeur par defaut 
  CALL fagote(kresp,nunit_fa,ingrib,inbpdg,inbcsp,istron,ipuila,idmopl)
ENDIF
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_FA:WRITE_SURFC0_FA',1,zhook_handle)
!
END SUBROUTINE write_surfc0_fa
!
!     #############################################################
      SUBROUTINE write_surfx1_fa (&
                                  hrec,kl,pfield,kresp,hcomment,hdir)
!     #############################################################
!
!!****  * - routine to fill a write 1D array for the externalised surface 
!
!
!
!
USE modd_surfex_mpi, ONLY : nrank, npio, xtime_npio_write, wlog_mpi
!
USE modd_surfex_omp, ONLY : lwork0, nworkb
!
USE modd_io_surf_fa, ONLY : nunit_fa, nmask, nfull, cprefix1d, &
                            lfanocompact 
USE modd_surf_par,   ONLY : xundef
!
USE modi_io_buff
USE modi_error_write_surf_fa
USE modi_gather_and_write_mpi
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
#ifdef SFX_MPI
include "mpif.h"
#endif
!
!*      0.1   Declarations of arguments
!
!
!
 CHARACTER(LEN=12),   INTENT(IN) :: hrec     ! name of the article to be read
INTEGER,             INTENT(IN) :: kl       ! number of points
REAL, DIMENSION(KL), INTENT(IN) :: pfield   ! array containing the data field
INTEGER,             INTENT(OUT):: kresp    ! KRESP  : return-code if a problem appears
 CHARACTER(LEN=100),  INTENT(IN) :: hcomment ! comment string
 CHARACTER(LEN=1),    INTENT(IN) :: hdir     ! type of field :
                                            ! 'H' : field with
                                            !       horizontal spatial dim.
                                            ! '-' : no horizontal dim.
!*      0.2   Declarations of local variables
!
INTEGER                :: i,ingrib,inbpdg,inbcsp,istron,ipuila,idmopl
REAL                   :: zmean, zcount
REAL       :: xtime0
REAL, DIMENSION(MAX(NFULL,SIZE(PFIELD))) :: zwork   ! work array read in the file
REAL(KIND=JPRB)        :: zhook_handle
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_FA:WRITE_SURFX1_FA',0,zhook_handle)
!
!$OMP BARRIER
!
!$OMP SINGLE
nworkb=0
!
 CALL io_buff(&
                hrec,'W',lwork0)
!$OMP END SINGLE
!
IF (lwork0 .AND. lhook) CALL dr_hook('MODE_WRITE_SURF_FA:WRITE_SURFX1_FA',1,zhook_handle)
IF (lwork0) RETURN
!
IF(hdir=='H')THEN
  CALL gather_and_write_mpi(pfield,zwork,nmask)
ELSE !no horizontal dim. case (not masked)
  zwork(1:kl)=pfield(1:kl)
  zwork(kl+1:nfull)=sum(pfield(1:kl))/REAL(kl)
ENDIF
!
IF (nrank==npio) THEN
  !
#ifdef SFX_MPI
  xtime0 = mpi_wtime()
#endif
  !
!$OMP SINGLE
  !   
  IF(lfanocompact)THEN
    CALL faveur(nworkb,nunit_fa,ingrib,inbpdg,inbcsp,istron,ipuila,idmopl)
    ! -- Pour ecrire sans compactage
    CALL fagote(nworkb,nunit_fa,-1,inbpdg,inbcsp,istron,ipuila,idmopl)
    CALL faienc(nworkb,nunit_fa,cprefix1d,0,hrec,zwork,.false.)
    IF (nworkb/=0) CALL error_write_surf_fa(hrec,nworkb)
    ! On remet la valeur par defaut 
    CALL fagote(nworkb,nunit_fa,ingrib,inbpdg,inbcsp,istron,ipuila,idmopl)
  ELSE
    zmean =0.0
    zcount=0.0
    DO i=1,nfull
      IF(zwork(i)/=xundef)THEN
        zmean =zmean+zwork(i)
        zcount=zcount+1.0
      ENDIF
    ENDDO
    IF (zcount.GT.0.0) zmean=zmean/zcount
    WHERE(zwork(:)==xundef)zwork(:)=zmean
    CALL faienc(nworkb,nunit_fa,cprefix1d,0,hrec,zwork,.false.)
    IF (nworkb/=0) CALL error_write_surf_fa(hrec,nworkb)
  ENDIF
  !
!$OMP END SINGLE
  !
#ifdef SFX_MPI
  xtime_npio_write = xtime_npio_write + (mpi_wtime() - xtime0)
#endif
  !
ENDIF
!
kresp = nworkb
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_FA:WRITE_SURFX1_FA',1,zhook_handle)
!
END SUBROUTINE write_surfx1_fa
!
!     #############################################################
      SUBROUTINE write_surfx2_fa (&
                                  hrec,kl1,kl2,pfield,kresp,hcomment,hdir)
!     #############################################################
!
!!****  * - routine to fill a write 2D array for the externalised surface 
!
!
!
!
USE modd_surfex_mpi, ONLY : nrank, npio, xtime_npio_write
!
USE modd_surfex_omp, ONLY : lwork0, nworkb
!
USE modd_io_surf_fa, ONLY : nunit_fa, nmask, nfull, &
                            cprefix2d, lfanocompact
USE modd_surf_par,   ONLY : xundef
!
USE modi_io_buff
USE modi_error_write_surf_fa
USE modi_gather_and_write_mpi
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
#ifdef SFX_MPI
include "mpif.h"
#endif
!
!*      0.1   Declarations of arguments
!
!
!
 CHARACTER(LEN=12),        INTENT(IN) :: hrec     ! name of the article to be read
INTEGER,                  INTENT(IN) :: kl1      ! number of points
INTEGER,                  INTENT(IN) :: kl2      ! 2nd dimension
REAL, DIMENSION(KL1,KL2), INTENT(IN) :: pfield   ! array containing the data field
INTEGER,                  INTENT(OUT):: kresp    ! KRESP  : return-code if a problem appears
 CHARACTER(LEN=100),       INTENT(IN) :: hcomment ! comment string
 CHARACTER(LEN=1),         INTENT(IN) :: hdir     ! type of field :
                                                 ! 'H' : field with
                                                 !       horizontal spatial dim.
                                                 ! '-' : no horizontal dim.
!*      0.2   Declarations of local variables
! 
 CHARACTER(LEN=4)  :: yprefix
 CHARACTER(LEN=3)  :: ypatch
INTEGER           :: i, jl ! loop counter
INTEGER           :: ingrib,inbpdg,inbcsp,istron,ipuila,idmopl
REAL  :: xtime0
REAL, DIMENSION(MAX(NFULL,SIZE(PFIELD,1)),SIZE(PFIELD,2)) :: zwork   ! work array read in the file
REAL, DIMENSION(SIZE(PFIELD,2))       :: zmean, zcount
REAL(KIND=JPRB)   :: zhook_handle
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_FA:WRITE_SURFX2_FA',0,zhook_handle)
!
!$OMP BARRIER
!
!$OMP SINGLE
nworkb=0
!
 CALL io_buff(&
                hrec,'W',lwork0)
!$OMP END SINGLE
!
IF (lwork0 .AND. lhook) CALL dr_hook('MODE_WRITE_SURF_FA:WRITE_SURFX2_FA',1,zhook_handle)
IF (lwork0) RETURN
!
 CALL gather_and_write_mpi(pfield,zwork,nmask)
!
IF (nrank==npio) THEN
  !
#ifdef SFX_MPI
  xtime0 = mpi_wtime()
#endif
  !    
!$OMP SINGLE
  !   
  IF(lfanocompact)THEN
    CALL faveur(nworkb,nunit_fa,ingrib,inbpdg,inbcsp,istron,ipuila,idmopl)
    ! -- Pour ecrire sans compactage
    CALL fagote(nworkb,nunit_fa,-1,inbpdg,inbcsp,istron,ipuila,idmopl)
    DO jl=1,SIZE(zwork,2)
      WRITE(ypatch,'(I3.3)')jl
      yprefix=cprefix2d//ypatch//'_'
      CALL faienc(nworkb,nunit_fa,yprefix,0,hrec,zwork(:,jl),.false.)
      IF (nworkb/=0) CALL error_write_surf_fa(hrec,nworkb)
    END DO
    ! On remet la valeur par defaut 
    CALL fagote(nworkb,nunit_fa,ingrib,inbpdg,inbcsp,istron,ipuila,idmopl)
  ELSE
    zmean(:)=0.0
    zcount(:)=0.0
    DO i=1,nfull
      DO jl=1,SIZE(zwork,2)
        IF(zwork(i,jl)/=xundef) THEN
          zmean(jl)=zmean(jl)+zwork(i,jl)
          zcount(jl)=zcount(jl)+1.0
        ENDIF
      ENDDO
    ENDDO
    WHERE(zcount(:)>0.0)zmean(:)=zmean(:)/zcount(:)        
    DO jl=1,SIZE(zwork,2)
      WHERE(zwork(:,jl)==xundef)zwork(:,jl)=zmean(jl)
      WRITE(ypatch,'(I3.3)')jl
      yprefix=cprefix2d//ypatch//'_'
      CALL faienc(nworkb,nunit_fa,yprefix,0,hrec,zwork(:,jl),.false.)
      IF (nworkb/=0) CALL error_write_surf_fa(hrec,nworkb)
    END DO
  ENDIF
  !
!$OMP END SINGLE
  !  
#ifdef SFX_MPI
  xtime_npio_write = xtime_npio_write + (mpi_wtime() - xtime0)
#endif
  !  
ENDIF
!
kresp = nworkb
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_FA:WRITE_SURFX2_FA',1,zhook_handle)
!
END SUBROUTINE write_surfx2_fa
!
!     #############################################################
      SUBROUTINE write_surfn1_fa (&
                                  hrec,kl,kfield,kresp,hcomment,hdir)
!     #############################################################
!
!!****  * - routine to write an integer array
!
!
!
!
USE modd_surfex_mpi, ONLY : nrank, npio, xtime_npio_write
!
USE modd_surfex_omp, ONLY : lwork0, nworkb
!
USE modd_io_surf_fa, ONLY : nunit_fa, nmask, nfull, cprefix1d, lfanocompact
!
USE mode_fasurfex
!
USE modi_io_buff
USE modi_error_write_surf_fa
USE modi_gather_and_write_mpi
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
#ifdef SFX_MPI
include "mpif.h"
#endif
!
!*      0.1   Declarations of arguments
!
!
!
 CHARACTER(LEN=12),      INTENT(IN) :: hrec     ! name of the article to be read
INTEGER,                INTENT(IN) :: kl       ! number of points
INTEGER, DIMENSION(KL), INTENT(IN) :: kfield   ! array containing the data field
INTEGER,                INTENT(OUT):: kresp    ! KRESP  : return-code if a problem appears
 CHARACTER(LEN=100),     INTENT(IN) :: hcomment ! comment string
 CHARACTER(LEN=1),       INTENT(IN) :: hdir     ! type of field :
                                               ! 'H' : field with
                                               !       horizontal spatial dim.
                                               ! '-' : no horizontal dim.
!*      0.2   Declarations of local variables
! 
 CHARACTER(LEN=18)         :: yname! Field Nam
INTEGER                   :: ingrib,inbpdg,inbcsp,istron,ipuila,idmopl
INTEGER, DIMENSION(MAX(NFULL,SIZE(KFIELD))) :: iwork  ! work array read in the file
REAL   :: xtime0
REAL(KIND=JPRB)           :: zhook_handle
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_FA:WRITE_SURFN1_FA',0,zhook_handle)
!
!$OMP SINGLE
nworkb = 0
!
 CALL io_buff(&
                hrec,'W',lwork0)
!$OMP END SINGLE
!
IF (lwork0 .AND. lhook) CALL dr_hook('MODE_WRITE_SURF_FA:WRITE_SURFN1_FA',1,zhook_handle)
IF (lwork0) RETURN
!
IF (hdir/='H' .OR. hrec=="-") THEN
  iwork(1:kl) = kfield
ELSE
  CALL gather_and_write_mpi(kfield,iwork,nmask)
ENDIF
!
IF (nrank==npio) THEN
  !
#ifdef SFX_MPI
  xtime0 = mpi_wtime()
#endif
  !    
!$OMP SINGLE
  !  
  IF(lfanocompact)THEN
    CALL faveur(nworkb,nunit_fa,ingrib,inbpdg,inbcsp,istron,ipuila,idmopl)
    ! -- Pour ecrire sans compactage
    CALL fagote(nworkb,nunit_fa,-1,inbpdg,inbcsp,istron,ipuila,idmopl)
  ENDIF
  !
  yname=trim(cprefix1d)//trim(hrec)
  !
  CALL  faecr_i_d(nworkb,nunit_fa,yname,kl,iwork(1:kl))
  IF (nworkb/=0) CALL error_write_surf_fa(hrec,nworkb)
  !
  IF(lfanocompact)THEN
    ! On remet la valeur par defaut 
    CALL fagote(nworkb,nunit_fa,ingrib,inbpdg,inbcsp,istron,ipuila,idmopl)
  ENDIF
  !
!$OMP END SINGLE
  !   
#ifdef SFX_MPI
  xtime_npio_write = xtime_npio_write + (mpi_wtime() - xtime0)
#endif
  !  
ENDIF
!
kresp = nworkb
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_FA:WRITE_SURFN1_FA',1,zhook_handle)
RETURN
!
END SUBROUTINE write_surfn1_fa
!
!     #############################################################
      SUBROUTINE write_surfl1_fa (&
                                  hrec,kl,ofield,kresp,hcomment,hdir)
!     #############################################################
!
!!****  * - routine to write a logical array
!
!
!
!
USE modd_surfex_mpi, ONLY : nrank, npio, xtime_npio_write
!
USE modd_surfex_omp, ONLY : lwork0, nworkb
!
USE modd_io_surf_fa, ONLY : nunit_fa, cprefix1d, lfanocompact
!
USE mode_fasurfex
!
USE modi_io_buff
USE modi_error_write_surf_fa
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
#ifdef SFX_MPI
include "mpif.h"
#endif
!
!*      0.1   Declarations of arguments
!
!
!
 CHARACTER(LEN=12),      INTENT(IN) :: hrec     ! name of the article to be read
INTEGER,             INTENT(IN) :: kl       ! number of points
LOGICAL, DIMENSION(KL), INTENT(IN) :: ofield   ! array containing the data field
INTEGER,                INTENT(OUT):: kresp    ! KRESP  : return-code if a problem appears
 CHARACTER(LEN=100),     INTENT(IN) :: hcomment ! comment string
 CHARACTER(LEN=1),       INTENT(IN) :: hdir     ! type of field :
                                               ! 'H' : field with
                                               !       horizontal spatial dim.
                                               ! '-' : no horizontal dim.
!*      0.2   Declarations of local variables
!
 CHARACTER(LEN=18):: yname ! Field Name
INTEGER          :: ingrib,inbpdg,inbcsp,istron,ipuila,idmopl
REAL :: xtime0
REAL(KIND=JPRB)  :: zhook_handle
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_FA:WRITE_SURFL1_FA',0,zhook_handle)
!
!$OMP SINGLE
nworkb=0
!
 CALL io_buff(&
                hrec,'W',lwork0)
!$OMP END SINGLE
!
IF (lwork0 .AND. lhook) CALL dr_hook('MODE_WRITE_SURF_FA:WRITE_SURFL1_FA',1,zhook_handle)
IF (lwork0) RETURN
!
IF (nrank==npio) THEN
  !
#ifdef SFX_MPI
  xtime0 = mpi_wtime()
#endif
  !  
!$OMP SINGLE
  !    
  IF(lfanocompact)THEN
    CALL faveur(nworkb,nunit_fa,ingrib,inbpdg,inbcsp,istron,ipuila,idmopl)
    ! -- Pour ecrire sans compactage
    CALL fagote(nworkb,nunit_fa,-1,inbpdg,inbcsp,istron,ipuila,idmopl)
  ENDIF
  !
  yname=trim(cprefix1d)//trim(hrec)
  CALL  faecr_l_d(nworkb,nunit_fa,yname,kl,ofield)
  IF (nworkb/=0) CALL error_write_surf_fa(hrec,nworkb)
  !
  IF(lfanocompact)THEN
    ! On remet la valeur par defaut 
    CALL fagote(nworkb,nunit_fa,ingrib,inbpdg,inbcsp,istron,ipuila,idmopl)
  ENDIF
  !
!$OMP END SINGLE
  !  
#ifdef SFX_MPI
  xtime_npio_write = xtime_npio_write + (mpi_wtime() - xtime0)
#endif
  !  
ENDIF
!
kresp = nworkb
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_FA:WRITE_SURFL1_FA',1,zhook_handle)
!
END SUBROUTINE write_surfl1_fa
!
!     #############################################################
      SUBROUTINE write_surft0_fa (&
                                  hrec,kyear,kmonth,kday,ptime,kresp,hcomment)
!     #############################################################
!
!!****  * - routine to write a date
!
!
!
!
USE modd_surfex_omp, ONLY : lwork0
!
USE modd_io_surf_fa, ONLY : cprefix1d, nunit_fa, lfanocompact
!
USE mode_fasurfex
!
USE modi_io_buff
USE modi_error_write_surf_fa
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
!*      0.1   Declarations of arguments
!
!
!
 CHARACTER(LEN=12),  INTENT(IN)  :: hrec     ! name of the article to be read
INTEGER,            INTENT(IN)  :: kyear    ! year
INTEGER,            INTENT(IN)  :: kmonth   ! month
INTEGER,            INTENT(IN)  :: kday     ! day
REAL,               INTENT(IN)  :: ptime    ! time
INTEGER,            INTENT(OUT) :: kresp    ! KRESP  : return-code if a problem appears
 CHARACTER(LEN=100), INTENT(IN)  :: hcomment ! comment string

!*      0.2   Declarations of local variables
!
 CHARACTER(LEN=18)     :: yname ! Field Name
INTEGER               :: iret
INTEGER               :: ihour, imin, isec
INTEGER               :: ingrib,inbpdg,inbcsp,istron,ipuila,idmopl
INTEGER, DIMENSION(3) :: itdate
REAL(KIND=JPRB) :: zhook_handle
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_FA:WRITE_SURFT0_FA',0,zhook_handle)
!
kresp=0
!
IF (hrec=='DTCUR') THEN
!        
  ihour = floor(ptime)/3600
  imin  = floor(ptime)/60 - ihour * 60
  isec  = nint(ptime) - ihour * 3600 - imin * 60
  CALL fandar(iret,nunit_fa,(/ kyear, kmonth, kday, ihour, imin, isec, 0, 0, 0, 0, 0 /))
!
ELSE
!
  CALL io_buff(&
                hrec,'W',lwork0)
  IF (lwork0 .AND. lhook) CALL dr_hook('MODE_WRITE_SURF_FA:WRITE_SURFT0_FA',1,zhook_handle)
  IF (lwork0) RETURN
!
END IF
!
itdate(1) = kyear
itdate(2) = kmonth
itdate(3) = kday
!
IF(lfanocompact)THEN
  CALL faveur(kresp,nunit_fa,ingrib,inbpdg,inbcsp,istron,ipuila,idmopl)
  ! -- Pour ecrire sans compactage
  CALL fagote(kresp,nunit_fa,-1,inbpdg,inbcsp,istron,ipuila,idmopl)
ENDIF
!
yname=trim(cprefix1d)//trim(hrec)//'%TDATE'
 CALL  faecr_i_d(kresp,nunit_fa,yname,3,itdate)
IF (kresp/=0) THEN
  CALL error_write_surf_fa(hrec,kresp)
ENDIF
!
yname=trim(cprefix1d)//trim(hrec)//'%TIME'
 CALL  faecr_r(kresp,nunit_fa,yname,ptime)
IF (kresp/=0) THEN
  CALL error_write_surf_fa(hrec,kresp)
ENDIF
!
IF(lfanocompact)THEN
  ! On remet la valeur par defaut 
  CALL fagote(kresp,nunit_fa,ingrib,inbpdg,inbcsp,istron,ipuila,idmopl)
ENDIF
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_FA:WRITE_SURFT0_FA',1,zhook_handle)
!
END SUBROUTINE write_surft0_fa
!
!     #############################################################
      SUBROUTINE write_surft2_fa (&
                                  hrec,kl1,kl2,kyear,kmonth,kday,ptime,kresp,hcomment)
!     #############################################################
!
!!****  * - routine to write a date
!
!
!
!
USE modd_surfex_mpi, ONLY : nrank, npio, xtime_npio_write
!
USE modd_surfex_omp, ONLY : lwork0, nworkb
!
USE modd_io_surf_fa, ONLY : nunit_fa, cprefix1d, nluout
!
USE mode_fasurfex
!
USE modi_io_buff
USE modi_abor1_sfx
USE modi_error_write_surf_fa
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
#ifdef SFX_MPI
include "mpif.h"
#endif
!
!*      0.1   Declarations of arguments
!
!
!
 CHARACTER(LEN=12),  INTENT(IN)  :: hrec     ! name of the article to be read
INTEGER,                      INTENT(IN) :: kl1      ! number of points
INTEGER,                      INTENT(IN) :: kl2      ! 2nd dimension
INTEGER, DIMENSION(KL1,KL2), INTENT(IN)  :: kyear    ! year
INTEGER, DIMENSION(KL1,KL2), INTENT(IN)  :: kmonth   ! month
INTEGER, DIMENSION(KL1,KL2), INTENT(IN)  :: kday     ! day
REAL,    DIMENSION(KL1,KL2), INTENT(IN)  :: ptime    ! time
INTEGER,            INTENT(OUT) :: kresp    ! KRESP  : return-code if a problem appears
 CHARACTER(LEN=100), INTENT(IN)  :: hcomment ! comment string

!*      0.2   Declarations of local variables
!
 CHARACTER(LEN=18):: yname ! Field Name
INTEGER, DIMENSION(3,SIZE(KYEAR,1),SIZE(KYEAR,2)) :: itdate
REAL :: xtime0
REAL(KIND=JPRB) :: zhook_handle
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_FA:WRITE_SURFT2_FA',0,zhook_handle)
!
!$OMP SINGLE
nworkb = 0
!
 CALL io_buff(&
                hrec,'W',lwork0)
!$OMP END SINGLE
!
IF (lwork0 .AND. lhook) CALL dr_hook('MODE_WRITE_SURF_FA:WRITE_SURFT2_FA',1,zhook_handle)
IF (lwork0) RETURN
!
IF (nrank==npio) THEN
  !
#ifdef SFX_MPI
  xtime0 = mpi_wtime()
#endif
  !  
!$OMP SINGLE
  !
  itdate(1,:,:) = kyear(:,:)
  itdate(2,:,:) = kmonth(:,:)
  itdate(3,:,:) = kday(:,:)
  !
!$OMP END SINGLE
  !   
  yname=trim(cprefix1d)//trim(hrec)
  WRITE(nluout,*) ' WRITE_SURFT2_FA : time in 2 dimensions not yet implemented : YNAME=',yname,'ITDATE=',itdate
  CALL abor1_sfx('MODE_WRITE_SURF_FA:WRITE_SURFT2_FA: time in 2 dimensions not yet implemented')
  !
#ifdef SFX_MPI
  xtime_npio_write = xtime_npio_write + (mpi_wtime() - xtime0)
#endif
  !  
ENDIF
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_FA:WRITE_SURFT2_FA',1,zhook_handle)
!
END SUBROUTINE write_surft2_fa
!
END MODULE mode_write_surf_fa