mode_write_surf_lfi.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.
!     ######spl
MODULE mode_write_surf_lfi
!
#ifdef SFX_LFI
!
USE modi_get_luout
INTERFACE write_surf0_lfi
        MODULE PROCEDURE write_surfx0_lfi
        MODULE PROCEDURE write_surfn0_lfi
        MODULE PROCEDURE write_surfl0_lfi
        MODULE PROCEDURE write_surfc0_lfi
END INTERFACE
INTERFACE write_surfn_lfi
        MODULE PROCEDURE write_surfx1_lfi
        MODULE PROCEDURE write_surfn1_lfi
        MODULE PROCEDURE write_surfl1_lfi
        MODULE PROCEDURE write_surfx2_lfi
        MODULE PROCEDURE write_surfx3_lfi
END INTERFACE
INTERFACE write_surft_lfi
        MODULE PROCEDURE write_surft0_lfi
        MODULE PROCEDURE write_surft1_lfi 
        MODULE PROCEDURE write_surft2_lfi        
END INTERFACE
!
CONTAINS
!
!     #############################################################
      SUBROUTINE write_surfx0_lfi (&
                                   HREC,PFIELD,KRESP,HCOMMENT)
!     #############################################################
!
!!****  * - routine to write a real scalar
!
!
USE modd_io_surf_lfi,        ONLY : cfileout_lfi, cluout_lfi
!
USE modi_io_buff
USE modi_fmwrit
USE modi_error_write_surf_lfi
!
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
!
LOGICAL :: GFOUND
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_LFI:WRITE_SURFX0_LFI',0,zhook_handle)
!
kresp=0
!
 CALL io_buff(&
                hrec,'W',gfound)
IF (gfound .AND. lhook) CALL dr_hook('MODE_WRITE_SURF_LFI:WRITE_SURFX0_LFI',1,zhook_handle)
IF (gfound) RETURN
!
 CALL fmwritx0(cfileout_lfi,hrec,cluout_lfi,1,pfield,4,100,hcomment,kresp)
!
 CALL error_write_surf_lfi(hrec,kresp)
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_LFI:WRITE_SURFX0_LFI',1,zhook_handle)
!
END SUBROUTINE write_surfx0_lfi
!
!     #############################################################
      SUBROUTINE write_surfn0_lfi (&
                                   HREC,KFIELD,KRESP,HCOMMENT)
!     #############################################################
!
!!****  * - routine to write an integer
!
USE modd_io_surf_lfi,        ONLY : cfileout_lfi, cluout_lfi, &
                                    lmnh_compatible, niu, nib, nie, nju, njb, nje
!
USE modi_io_buff
USE modi_fmwrit
USE modi_error_write_surf_lfi
!
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
!
LOGICAL :: GFOUND
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_LFI:WRITE_SURFN0_LFI',0,zhook_handle)
!
kresp=0
!
IF (lmnh_compatible .AND. hrec=='IMAX') THEN
  niu = kfield+2
  nib = 2
  nie = kfield+1
END IF
IF (lmnh_compatible .AND. hrec=='JMAX') THEN
  nju = kfield+2
  njb = 2
  nje = kfield+1
END IF
!
 CALL io_buff(&
                hrec,'W',gfound)
IF (gfound .AND. lhook) CALL dr_hook('MODE_WRITE_SURF_LFI:WRITE_SURFN0_LFI',1,zhook_handle)
IF (gfound) RETURN
!
 CALL fmwritn0(cfileout_lfi,hrec,cluout_lfi,1,kfield,4,100,hcomment,kresp)
!
 CALL error_write_surf_lfi(hrec,kresp)
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_LFI:WRITE_SURFN0_LFI',1,zhook_handle)
!
END SUBROUTINE write_surfn0_lfi
!
!     #############################################################
      SUBROUTINE write_surfl0_lfi (&
                                   HREC,OFIELD,KRESP,HCOMMENT)
!     #############################################################
!
!!****  * - routine to write a logical
!
USE modd_io_surf_lfi,        ONLY : cfileout_lfi, cluout_lfi
!
USE modi_io_buff
USE modi_fmwrit
USE modi_error_write_surf_lfi
!
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
!
LOGICAL :: GFOUND
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_LFI:WRITE_SURFL0_LFI',0,zhook_handle)
!
kresp=0
!
 CALL io_buff(&
                hrec,'W',gfound)
IF (gfound .AND. lhook) CALL dr_hook('MODE_WRITE_SURF_LFI:WRITE_SURFL0_LFI',1,zhook_handle)
IF (gfound) RETURN
!
 CALL fmwritl0(cfileout_lfi,hrec,cluout_lfi,1,ofield,4,100,hcomment,kresp)
!
 CALL error_write_surf_lfi(hrec,kresp)
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_LFI:WRITE_SURFL0_LFI',1,zhook_handle)
!
END SUBROUTINE write_surfl0_lfi
!
!     #############################################################
      SUBROUTINE write_surfc0_lfi (&
                                   HREC,HFIELD,KRESP,HCOMMENT)
!     #############################################################
!
!!****  * - routine to write a character
!
USE modd_io_surf_lfi,        ONLY : cfileout_lfi, cluout_lfi, lmnh_compatible, lcartesian
!
USE modi_io_buff
USE modi_fmwrit
USE modi_error_write_surf_lfi
!
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
!
LOGICAL :: GFOUND
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_LFI:WRITE_SURFC0_LFI',0,zhook_handle)
!
kresp=0
!
 CALL io_buff(&
                hrec,'W',gfound)
IF (gfound .AND. lhook) CALL dr_hook('MODE_WRITE_SURF_LFI:WRITE_SURFC0_LFI',1,zhook_handle)
IF (gfound) RETURN
!
 CALL fmwritc0(cfileout_lfi,hrec,cluout_lfi,1,hfield,4,100,hcomment,kresp)
!
IF (hrec=="GRID_TYPE") lmnh_compatible = (hfield=="CARTESIAN " .OR. hfield=="CONF PROJ ")
IF (hrec=="GRID_TYPE" .AND. lmnh_compatible) lcartesian=(hfield=="CARTESIAN ")
!
 CALL error_write_surf_lfi(hrec,kresp)
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_LFI:WRITE_SURFC0_LFI',1,zhook_handle)
!
END SUBROUTINE write_surfc0_lfi
!
!     #############################################################
      SUBROUTINE write_surfx1_lfi (&
                                   HREC,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
!
USE modd_io_surf_lfi, ONLY : cfileout_lfi, cluout_lfi, nmask, nfull, &
                             lmnh_compatible, niu, nib, nie, nju, njb, nje
!
USE modi_io_buff
USE modi_fmwrit
USE modi_error_write_surf_lfi
USE modi_gather_and_write_mpi
USE modi_get_surf_undef
!
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
REAL, DIMENSION(:),  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
!
LOGICAL :: GFOUND
 CHARACTER(LEN=20)        :: YREC
INTEGER                  :: JI, JJ
DOUBLE PRECISION         :: XTIME0
REAL                     :: ZUNDEF  ! default value
REAL, DIMENSION(MAX(NFULL,SIZE(PFIELD)))   :: ZWORK   ! work array read in the file
REAL, DIMENSION(NIU,NJU) :: ZWORK2D ! work array read in a MNH file
REAL(KIND=JPRB) :: ZHOOK_HANDLE, ZHOOK_HANDLE_OMP
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_LFI:WRITE_SURFX1_LFI',0,zhook_handle)
!
kresp=0
!
 CALL io_buff(hrec,'W',gfound)
!
IF (gfound .AND. lhook) CALL dr_hook('MODE_WRITE_SURF_LFI:WRITE_SURFX1_LFI',1,zhook_handle)
IF (gfound) RETURN
!
IF (hdir=='H') CALL gather_and_write_mpi(pfield,zwork,nmask)
!  
!
IF (nrank==npio) THEN
  !
#ifdef SFX_MPI
  xtime0 = mpi_wtime()
#endif
  !
  IF (hdir=='H') THEN
    !
    CALL get_surf_undef(zundef)
    !
    IF (.NOT. lmnh_compatible) THEN
      CALL fmwritx1(cfileout_lfi,hrec,cluout_lfi,nfull,zwork,4,100,hcomment,kresp)
      CALL error_write_surf_lfi(hrec,kresp)
    ELSE
      !
!$OMP PARALLEL PRIVATE(ZHOOK_HANDLE_OMP)  
!$OMP DO PRIVATE(JJ,JI)
      DO jj=1,nje-njb+1
        DO ji=1,nie-nib+1
          zwork2d(nib+ji-1,njb+jj-1) = zwork(ji+(nie-nib+1)*(jj-1))
        END DO
      END DO
!$OMP END DO
!$OMP END PARALLEL      
      !
      zwork2d(1:nib-1,:) = zundef
      zwork2d(:,nje+1:nju) = zundef
      zwork2d(:,1:njb-1) = zundef
      zwork2d(nie+1:niu,:) = zundef      
      !
      IF     (hrec=='DX              ' .OR. hrec=='XX              ') THEN
        yrec = 'XHAT'
        CALL write_in_lfi_x1_for_mnh(hrec,yrec,zwork2d(nib:nie,njb),kresp,hcomment,niu,nib,nie)
      ELSEIF (hrec=='DY              ' .OR. hrec=='YY              ') THEN
        yrec = 'YHAT'
        CALL write_in_lfi_x1_for_mnh(hrec,yrec,zwork2d(nib,njb:nje),kresp,hcomment,nju,njb,nje)
      ELSEIF (njb==nje) THEN
         yrec = hrec
        CALL write_in_lfi_x1_for_mnh(hrec,yrec,zwork2d(:,njb),kresp,hcomment,niu,nib,nie)
      ELSEIF (nib==nie) THEN
        yrec = hrec
        CALL write_in_lfi_x1_for_mnh(hrec,yrec,zwork2d(nib,:),kresp,hcomment,nju,njb,nje)
      ELSE
        CALL fmwritx2(cfileout_lfi,hrec,cluout_lfi,SIZE(zwork2d),zwork2d,4,100,hcomment,kresp)
        CALL error_write_surf_lfi(hrec,kresp)
      ENDIF
      !
    END IF
    !
  ELSE
    CALL fmwritx1(cfileout_lfi,hrec,cluout_lfi,SIZE(pfield),pfield,4,100,hcomment,kresp)
    CALL error_write_surf_lfi(hrec,kresp)
  END IF
  ! 
#ifdef SFX_MPI
  xtime_npio_write = xtime_npio_write + (mpi_wtime() - xtime0)
#endif
  !  
ENDIF
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_LFI:WRITE_SURFX1_LFI',1,zhook_handle)
!
CONTAINS
!
!     #############################################################
      SUBROUTINE write_in_lfi_x1_for_mnh(HREC,HREC2,PFIELD,KRESP,HCOMMENT,KU,KB,KE)
!     #############################################################
!
!!****  * - routine to fill a write 2D array for the externalised surface 
!
IMPLICIT NONE
!
!*      0.1   Declarations of arguments
!
 CHARACTER(LEN=12),        INTENT(IN) :: HREC     ! name of the article to be read
 CHARACTER(LEN=20),        INTENT(IN) :: HREC2    ! name of the article to be read
REAL, DIMENSION(:),       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
INTEGER,                  INTENT(IN) :: KU
INTEGER,                  INTENT(IN) :: KB
INTEGER,                  INTENT(IN) :: KE
!
!*      0.2   Declarations of local variables
! 
REAL, DIMENSION(KU)      :: ZWORK ! 1D work array read in the file
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_LFI:WRITE_SURFX1_LFI:WRITE_IN_LFI_X1_FOR_MNH',0,zhook_handle)
!
zwork(:) = 0.
!
SELECT CASE(hrec)
  !
  CASE('DX              ','DY              ')
    IF (kb/=ke) THEN
      IF (lhook) CALL dr_hook('MODE_WRITE_SURF_LFI:WRITE_SURFX1_LFI:WRITE_IN_LFI_X1_FOR_MNH',1,zhook_handle)
      RETURN
    ENDIF
    zwork(1) = - pfield(1)*0.5  ! 1D case
    zwork(2) =   pfield(1)*0.5
    zwork(3) =   pfield(1)*1.5
  !
  CASE('XX              ','YY              ')
    IF (kb==ke) THEN
      IF (lhook) CALL dr_hook('MODE_WRITE_SURF_LFI:WRITE_SURFX1_LFI:WRITE_IN_LFI_X1_FOR_MNH',1,zhook_handle)
      RETURN
    ENDIF          
    zwork(kb+1:ke)   = 0.5 * pfield(1:ke-2) + 0.5 * pfield(2:ke-1)
    zwork(kb)        = 1.5 * pfield(1)      - 0.5 * pfield(2)
    zwork(kb-1)      = 2. * zwork(kb) - zwork(kb+1)
    zwork(ke+1)      = 2. * zwork(ke) - zwork(ke-1)
  CASE DEFAULT
    zwork(:) = pfield(:)
  !  
END SELECT
!
 CALL fmwritx1(cfileout_lfi,hrec2,cluout_lfi,ku,zwork,4,100,hcomment,kresp)
 CALL error_write_surf_lfi(hrec2,kresp)
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_LFI:WRITE_SURFX1_LFI:WRITE_IN_LFI_X1_FOR_MNH',1,zhook_handle)
END SUBROUTINE write_in_lfi_x1_for_mnh
!
END SUBROUTINE write_surfx1_lfi
!
!     #############################################################
      SUBROUTINE write_surfx2_lfi (HREC,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_io_surf_lfi,        ONLY : cfileout_lfi, cluout_lfi, nmask, nfull, &
                                    lmnh_compatible, niu, nib, nie, nju, njb, nje
!
USE modi_io_buff
USE modi_fmwrit
USE modi_error_write_surf_lfi
USE modi_gather_and_write_mpi
USE modi_get_surf_undef
!
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
REAL, DIMENSION(:,:),     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
!
LOGICAL :: GFOUND
DOUBLE PRECISION :: XTIME0
REAL             :: ZUNDEF  ! default value
REAL, DIMENSION(MAX(NFULL,SIZE(PFIELD,1)),SIZE(PFIELD,2)) :: ZWORK   ! work array read in the file
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_LFI:WRITE_SURFX2_LFI',0,zhook_handle)
!
kresp=0
!
 CALL io_buff(&
                hrec,'W',gfound)
!
IF (gfound .AND. lhook) CALL dr_hook('MODE_WRITE_SURF_LFI:WRITE_SURFX2_LFI',1,zhook_handle)
IF (gfound) RETURN
!
IF (hdir=='H') CALL gather_and_write_mpi(pfield,zwork,nmask)
!
IF (nrank==npio) THEN
  !
#ifdef SFX_MPI
  xtime0 = mpi_wtime()
#endif
  !  
  IF (hdir=='H') THEN
    !
    CALL get_surf_undef(zundef)
    !
    IF (.NOT. lmnh_compatible) THEN
      CALL fmwritx2(cfileout_lfi,hrec,cluout_lfi,SIZE(zwork),zwork,4,100,hcomment,kresp)
      CALL error_write_surf_lfi(hrec,kresp)
    ELSE
      CALL write_in_lfi_x2_for_mnh(hrec,zwork,kresp,hcomment)
    END IF
    !
  ELSE
    CALL fmwritx2(cfileout_lfi,hrec,cluout_lfi,SIZE(pfield),pfield,4,100,hcomment,kresp)
    CALL error_write_surf_lfi(hrec,kresp)
  END IF
  !
#ifdef SFX_MPI
  xtime_npio_write = xtime_npio_write + (mpi_wtime() - xtime0)
#endif
  !  
ENDIF
!
!if (HREC=='ALBVIS_ISBA') stop
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_LFI:WRITE_SURFX2_LFI',1,zhook_handle)
!
CONTAINS
!
!     #############################################################
      SUBROUTINE write_in_lfi_x2_for_mnh(HREC,PFIELD,KRESP,HCOMMENT)
!     #############################################################
!
!!****  * - routine to fill a write 2D array for the externalised surface 
!
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, DIMENSION(:,:),     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
!
!*      0.2   Declarations of local variables
! 
INTEGER :: JI, JJ
REAL    :: ZUNDEF
REAL, DIMENSION(NIU,NJU,SIZE(PFIELD,2)) :: ZWORK3D ! work array read in a MNH file
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_LFI:WRITE_SURFX2_LFI:WRITE_IN_LFI_X2_FOR_MNH',0,zhook_handle)
!
 CALL get_surf_undef(zundef)
!
zwork3d=zundef
DO jj=1,nje-njb+1
  DO ji=1,nie-nib+1
    zwork3d(nib+ji-1,njb+jj-1,:) = pfield(ji+(nie-nib+1)*(jj-1),:)
  END DO
END DO
!
IF (nje==njb) THEN
  CALL fmwritx2(cfileout_lfi,hrec,cluout_lfi,SIZE(zwork3d,3)*niu,zwork3d(:,nje,:),4,100,hcomment,kresp)
ELSEIF (nie==nib) THEN
  CALL fmwritx2(cfileout_lfi,hrec,cluout_lfi,SIZE(zwork3d,3)*nju,zwork3d(nie,:,:),4,100,hcomment,kresp)
ELSE
  CALL fmwritx3(cfileout_lfi,hrec,cluout_lfi,SIZE(zwork3d),zwork3d,4,100,hcomment,kresp)
ENDIF
!  
 CALL error_write_surf_lfi(hrec,kresp)
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_LFI:WRITE_SURFX2_LFI:WRITE_IN_LFI_X2_FOR_MNH',1,zhook_handle)
END SUBROUTINE write_in_lfi_x2_for_mnh
!
END SUBROUTINE write_surfx2_lfi
!
!     #############################################################
      SUBROUTINE write_surfx3_lfi (HREC,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_io_surf_lfi,        ONLY : cfileout_lfi, cluout_lfi, nmask, nfull, &
                                    lmnh_compatible, niu, nib, nie, nju, njb, nje
!
USE modi_io_buff
USE modi_fmwrit
USE modi_error_write_surf_lfi
USE modi_gather_and_write_mpi
USE modi_get_surf_undef
!
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
REAL, DIMENSION(:,:,:),     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
!
LOGICAL :: GFOUND
DOUBLE PRECISION :: XTIME0
REAL             :: ZUNDEF  ! default value
REAL, DIMENSION(MAX(NFULL,SIZE(PFIELD,1)),SIZE(PFIELD,2),SIZE(PFIELD,3)) :: ZWORK   ! work array read in the file
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_LFI:WRITE_SURFX3_LFI',0,zhook_handle)
!
kresp=0
!
 CALL io_buff(&
                hrec,'W',gfound)
!
IF (gfound .AND. lhook) CALL dr_hook('MODE_WRITE_SURF_LFI:WRITE_SURFX3_LFI',1,zhook_handle)
IF (gfound) RETURN
!
IF (hdir=='H') CALL gather_and_write_mpi(pfield,zwork,nmask)
!
IF (nrank==npio) THEN
  !
#ifdef SFX_MPI
  xtime0 = mpi_wtime()
#endif
  !  
  IF (hdir=='H') THEN
    !
    CALL get_surf_undef(zundef)
    !
    IF (.NOT. lmnh_compatible) THEN
      CALL fmwritx3(cfileout_lfi,hrec,cluout_lfi,SIZE(zwork),zwork,4,100,hcomment,kresp)
      CALL error_write_surf_lfi(hrec,kresp)
    ELSE
      CALL write_in_lfi_x3_for_mnh(hrec,zwork,kresp,hcomment)
    END IF
    !
  ELSE
    CALL fmwritx3(cfileout_lfi,hrec,cluout_lfi,SIZE(pfield),pfield,4,100,hcomment,kresp)
    CALL error_write_surf_lfi(hrec,kresp)
  END IF
  !
#ifdef SFX_MPI
  xtime_npio_write = xtime_npio_write + (mpi_wtime() - xtime0)
#endif
  !  
ENDIF
!
!if (HREC=='ALBVIS_ISBA') stop
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_LFI:WRITE_SURFX3_LFI',1,zhook_handle)
!
CONTAINS
!
!     #############################################################
      SUBROUTINE write_in_lfi_x3_for_mnh(HREC,PFIELD,KRESP,HCOMMENT)
!     #############################################################
!
!!****  * - routine to fill a write 2D array for the externalised surface 
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
USE modi_abor1_sfx
!
IMPLICIT NONE
!
!*      0.1   Declarations of arguments
!
 CHARACTER(LEN=12),        INTENT(IN) :: HREC     ! name of the article to be read
REAL, DIMENSION(:,:,:),     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
!
!*      0.2   Declarations of local variables
! 
INTEGER :: JI, JJ
REAL    :: ZUNDEF
REAL, DIMENSION(NIU,NJU,SIZE(PFIELD,2),SIZE(PFIELD,3)) :: ZWORK4D ! work array read in a MNH file
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_LFI:WRITE_SURFX3_LFI:WRITE_IN_LFI_X3_FOR_MNH',0,zhook_handle)
!
 CALL get_surf_undef(zundef)
!
zwork4d=zundef
DO jj=1,nje-njb+1
  DO ji=1,nie-nib+1
    zwork4d(nib+ji-1,njb+jj-1,:,:) = pfield(ji+(nie-nib+1)*(jj-1),:,:)
  END DO
END DO
!
IF (nje==njb) THEN
  CALL fmwritx3(cfileout_lfi,hrec,cluout_lfi,SIZE(zwork4d,3)*niu,zwork4d(:,nje,:,:),4,100,hcomment,kresp)
ELSEIF (nie==nib) THEN
  CALL fmwritx3(cfileout_lfi,hrec,cluout_lfi,SIZE(zwork4d,3)*nju,zwork4d(nie,:,:,:),4,100,hcomment,kresp)
ELSE
  !CALL FMWRITX4(CFILEOUT_LFI,HREC,CLUOUT_LFI,SIZE(ZWORK3D),ZWORK4D,4,100,HCOMMENT,KRESP)
  CALL abor1_sfx("WRITE_SURFX3_LFI: NOT POSSIBLE TO WRITE 4D FIELDS IN LFI")
ENDIF
!  
 CALL error_write_surf_lfi(hrec,kresp)
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_LFI:WRITE_SURFX3_LFI:WRITE_IN_LFI_X3_FOR_MNH',1,zhook_handle)
END SUBROUTINE write_in_lfi_x3_for_mnh
!
END SUBROUTINE write_surfx3_lfi
!
!     #############################################################
      SUBROUTINE write_surfn1_lfi (&
                                   HREC,KFIELD,KRESP,HCOMMENT,HDIR)
!     #############################################################
!
!!****  * - routine to write an integer array
!
!
USE modd_surfex_mpi, ONLY : nrank, npio, xtime_npio_write
!
USE modd_io_surf_lfi, ONLY : cfileout_lfi, cluout_lfi, nmask, nfull
!
USE modi_io_buff
USE modi_fmwrit
USE modi_error_write_surf_lfi
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, DIMENSION(:),  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
 CHARACTER(LEN=1),       INTENT(IN) :: HDIR     ! type of field :
                                               ! 'H' : field with
                                               !       horizontal spatial dim.
                                               ! '-' : no horizontal dim.
!*      0.2   Declarations of local variables
!
LOGICAL :: GFOUND
INTEGER, DIMENSION(MAX(NFULL,SIZE(KFIELD))) :: IWORK  ! work array read in the file
DOUBLE PRECISION   :: XTIME0
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_LFI:WRITE_SURFN1_LFI',0,zhook_handle)
!
kresp=0
!
 CALL io_buff(&
                hrec,'W',gfound)
!
IF (gfound .AND. lhook) CALL dr_hook('MODE_WRITE_SURF_LFI:WRITE_SURFN1_LFI',1,zhook_handle)
IF (gfound) RETURN
!
IF (hdir=='H') CALL gather_and_write_mpi(kfield,iwork,nmask)
!
IF (nrank==npio) THEN
  !
#ifdef SFX_MPI
  xtime0 = mpi_wtime()
#endif
  !
  IF (hdir=='H') THEN
    CALL fmwritn1(cfileout_lfi,hrec,cluout_lfi,nfull,iwork,4,100,hcomment,kresp)
  ELSE
    CALL fmwritn1(cfileout_lfi,hrec,cluout_lfi,SIZE(kfield),kfield,4,100,hcomment,kresp)
  END IF
  !  
  CALL error_write_surf_lfi(hrec,kresp)
  !
#ifdef SFX_MPI
  xtime_npio_write = xtime_npio_write + (mpi_wtime() - xtime0)
#endif
  !   
ENDIF
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_LFI:WRITE_SURFN1_LFI',1,zhook_handle)
!
END SUBROUTINE write_surfn1_lfi
!
!     #############################################################
      SUBROUTINE write_surfl1_lfi (&
                                   HREC,OFIELD,KRESP,HCOMMENT,HDIR)
!     #############################################################
!
!!****  * - routine to write a logical array
!
!
!
!
USE modd_surfex_mpi, ONLY : nrank, npio, xtime_npio_write
!
USE modd_io_surf_lfi,        ONLY : cfileout_lfi, cluout_lfi
!
USE modi_io_buff
USE modi_get_luout
USE modi_fmwrit
USE modi_abor1_sfx
USE modi_error_write_surf_lfi
!
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
LOGICAL, DIMENSION(:),  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
!
LOGICAL :: GFOUND
INTEGER         :: ILUOUT ! listing logical unit
DOUBLE PRECISION   :: XTIME0
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_LFI:WRITE_SURFL1_LFI',0,zhook_handle)
!
kresp=0
!  
 CALL io_buff(&
                hrec,'W',gfound)
!
IF (gfound .AND. lhook) CALL dr_hook('MODE_WRITE_SURF_LFI:WRITE_SURFL1_LFI',1,zhook_handle)
IF (gfound) RETURN
!
IF (nrank==npio) THEN
  !
#ifdef SFX_MPI
  xtime0 = mpi_wtime()
#endif
  !
  IF (hdir=='H') THEN
    CALL get_luout('LFI   ',iluout)
    WRITE(iluout,*) 'Error: 1D logical vector for writing on an horizontal grid:'
    WRITE(iluout,*) 'this option is not coded in WRITE_SURFL1_LFI'
    CALL abor1_sfx('MODE_WRITE_SURF_LFI: 1D LOGICAL VECTOR FOR WRITING NOT CODED IN WRITE_SURFL1_LFI')
  ELSE
    !
    CALL fmwritl1(cfileout_lfi,hrec,cluout_lfi,SIZE(ofield),ofield,4,100,hcomment,kresp)
    !
    CALL error_write_surf_lfi(hrec,kresp)
  END IF
  !
#ifdef SFX_MPI
  xtime_npio_write = xtime_npio_write + (mpi_wtime() - xtime0)
#endif
  !  
ENDIF
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_LFI:WRITE_SURFL1_LFI',1,zhook_handle)
!
END SUBROUTINE write_surfl1_lfi
!
!     #############################################################
      SUBROUTINE write_surft0_lfi (&
                                   HREC,KYEAR,KMONTH,KDAY,PTIME,KRESP,HCOMMENT)
!     #############################################################
!
!!****  * - routine to write a date
!
!
USE modd_io_surf_lfi,        ONLY : cfileout_lfi, cluout_lfi
!
USE modi_io_buff
USE modi_get_surf_undef
USE modi_fmwrit
USE modi_error_write_surf_lfi
!
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
!
LOGICAL :: GFOUND
 CHARACTER(LEN=12)     :: YREC     ! Name of the article to be written
INTEGER, DIMENSION(3) :: ITDATE
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_LFI:WRITE_SURFT0_LFI',0,zhook_handle)
!
kresp=0
!
 CALL io_buff(&
                hrec,'W',gfound)
IF (gfound .AND. lhook) CALL dr_hook('MODE_WRITE_SURF_LFI:WRITE_SURFT0_LFI',1,zhook_handle)
IF (gfound) RETURN
!
itdate(1) = kyear
itdate(2) = kmonth
itdate(3) = kday
!
yrec=trim(hrec)//'%TDATE'
 CALL fmwritn1(cfileout_lfi,yrec,cluout_lfi,3,itdate,4,100,hcomment,kresp)
 CALL error_write_surf_lfi(hrec,kresp)
!
yrec=trim(hrec)//'%TIME'
 CALL fmwritx0(cfileout_lfi,yrec,cluout_lfi,1,ptime,4,100,hcomment,kresp)
 CALL error_write_surf_lfi(hrec,kresp)
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_LFI:WRITE_SURFT0_LFI',1,zhook_handle)
!
END SUBROUTINE write_surft0_lfi
!
!     #############################################################
      SUBROUTINE write_surft1_lfi (&
                                   HREC,KYEAR,KMONTH,KDAY,PTIME,KRESP,HCOMMENT)
!     #############################################################
!
!!****  * - routine to write a date
!
!
!
!
USE modd_surfex_mpi, ONLY : nrank, npio, xtime_npio_write
!
USE modd_io_surf_lfi,        ONLY : cfileout_lfi, cluout_lfi
!
USE modi_io_buff
USE modi_fmwrit
USE modi_error_write_surf_lfi
!
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, DIMENSION(:), INTENT(IN) :: KYEAR    ! year
INTEGER, DIMENSION(:), INTENT(IN) :: KMONTH   ! month
INTEGER, DIMENSION(:), INTENT(IN) :: KDAY     ! day
REAL,    DIMENSION(:), 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
!
LOGICAL :: GFOUND
 CHARACTER(LEN=12) :: YREC     ! Name of the article to be written
INTEGER, DIMENSION(3,SIZE(KYEAR)) :: ITDATE
DOUBLE PRECISION   :: XTIME0
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_LFI:WRITE_SURFT1_LFI',0,zhook_handle)
!
kresp = 0
!
 CALL io_buff(&
                hrec,'W',gfound)
!
IF (gfound .AND. lhook) CALL dr_hook('MODE_WRITE_SURF_LFI:WRITE_SURFT1_LFI',1,zhook_handle)
IF (gfound) RETURN
!
IF (nrank==npio) THEN
  !
#ifdef SFX_MPI
  xtime0 = mpi_wtime()
#endif
  !  
  kresp=0
  !
  itdate(1,:) = kyear(:)
  itdate(2,:) = kmonth(:)
  itdate(3,:) = kday(:)
  !
  yrec=trim(hrec)//'%TDATE'
  CALL fmwritn2(cfileout_lfi,yrec,cluout_lfi,SIZE(itdate),itdate,4,100,hcomment,kresp)
  !
  yrec=trim(hrec)//'%TIME'
  CALL fmwritx1(cfileout_lfi,yrec,cluout_lfi,SIZE(ptime),ptime,4,100,hcomment,kresp)
  !
  CALL error_write_surf_lfi(hrec,kresp)
  !
#ifdef SFX_MPI
  xtime_npio_write = xtime_npio_write + (mpi_wtime() - xtime0)
#endif
  !  
ENDIF
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_LFI:WRITE_SURFT1_LFI',1,zhook_handle)
!
END SUBROUTINE write_surft1_lfi
!
!     #############################################################
      SUBROUTINE write_surft2_lfi (&
                                   HREC,KYEAR,KMONTH,KDAY,PTIME,KRESP,HCOMMENT)
!     #############################################################
!
!!****  * - routine to write a date
!
!
!
!
USE modd_surfex_mpi, ONLY : nrank, npio, xtime_npio_write
!
USE modd_io_surf_lfi,        ONLY : cfileout_lfi, cluout_lfi
!
USE modi_io_buff
USE modi_fmwrit
USE modi_error_write_surf_lfi
!
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, DIMENSION(:,:), INTENT(IN) :: KYEAR    ! year
INTEGER, DIMENSION(:,:), INTENT(IN) :: KMONTH   ! month
INTEGER, DIMENSION(:,:), INTENT(IN) :: KDAY     ! day
REAL,    DIMENSION(:,:), 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
!
LOGICAL :: GFOUND
 CHARACTER(LEN=12) :: YREC     ! Name of the article to be written
DOUBLE PRECISION   :: XTIME0
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_LFI:WRITE_SURFT2_LFI',0,zhook_handle)
!
kresp = 0
!
 CALL io_buff(&
                hrec,'W',gfound)
!
IF (gfound .AND. lhook) CALL dr_hook('MODE_WRITE_SURF_LFI:WRITE_SURFT2_LFI',1,zhook_handle)
IF (gfound) RETURN
!
IF (nrank==npio) THEN
  !
#ifdef SFX_MPI
  xtime0 = mpi_wtime()
#endif
  !  
  kresp=0
  !
  yrec=trim(hrec)//'%YEAR'
  CALL fmwritn2(cfileout_lfi,yrec,cluout_lfi,SIZE(kyear),kyear,4,100,hcomment,kresp)
  !
  yrec=trim(hrec)//'%MONTH'
  CALL fmwritn2(cfileout_lfi,yrec,cluout_lfi,SIZE(kmonth),kmonth,4,100,hcomment,kresp)
  !
  yrec=trim(hrec)//'%DAY'
  CALL fmwritn2(cfileout_lfi,yrec,cluout_lfi,SIZE(kday),kday,4,100,hcomment,kresp)  
  !
  yrec=trim(hrec)//'%TIME'
  CALL fmwritx2(cfileout_lfi,yrec,cluout_lfi,SIZE(ptime),ptime,4,100,hcomment,kresp)
  !
  CALL error_write_surf_lfi(hrec,kresp)
  !
#ifdef SFX_MPI
  xtime_npio_write = xtime_npio_write + (mpi_wtime() - xtime0)
#endif
  !  
ENDIF
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_LFI:WRITE_SURFT2_LFI',1,zhook_handle)
!
END SUBROUTINE write_surft2_lfi
!
#endif
!
END MODULE mode_write_surf_lfi
!