mode_write_surf_ol.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_ol
!
INTERFACE write_surf0_ol
        MODULE PROCEDURE write_surfx0_ol
        MODULE PROCEDURE write_surfn0_ol
        MODULE PROCEDURE write_surfc0_ol
        MODULE PROCEDURE write_surfl0_ol
END INTERFACE
INTERFACE write_surf0_time_ol
        MODULE PROCEDURE write_surfx0_time_ol
END INTERFACE
INTERFACE write_surfx1n1_ol
        MODULE PROCEDURE write_surfx1_ol
        MODULE PROCEDURE write_surfn1_ol
END INTERFACE
INTERFACE write_surfl1x2_ol
        MODULE PROCEDURE write_surfl1_ol
        MODULE PROCEDURE write_surfx2_ol
END INTERFACE
INTERFACE write_surft_ol
        MODULE PROCEDURE write_surft0_ol
END INTERFACE
!
 CONTAINS
!
!     #############################################################
      SUBROUTINE write_surfx0_ol(HREC,PFIELD,KRESP,HCOMMENT)
!     #############################################################
!
!!****  *WRITEX0* - routine to read a real scalar
!
USE modi_ol_find_file_write
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
include "netcdf.inc"
!
!*      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
!
!*      0.2   Declarations of local variables
!
INTEGER              :: ifile_id,ivar_id,jret
INTEGER,DIMENSION(2) :: iret
REAL(KIND=JPRB) :: zhook_handle
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_OL:WRITE_SURFX0_OL',0,zhook_handle)
!
kresp=0
!
! 0. find filename
! -----------------
 CALL ol_find_file_write(hrec,ifile_id)
! 
IF (ifile_id /= 0) THEN        
  ! 1. Find id of the variable
  !----------------------------
  iret(1)=nf_inq_varid(ifile_id,hrec,ivar_id)  
  ! 2. Put variable
  !----------------------------
  iret(2)=nf_put_var_double(ifile_id,ivar_id,pfield)
ENDIF
!
! 3. Check for errors
!--------------------
DO jret=1,2
  IF (ifile_id==0 .OR. iret(jret).NE.nf_noerr) kresp=1
ENDDO
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_OL:WRITE_SURFX0_OL',1,zhook_handle)
!
END SUBROUTINE write_surfx0_ol
!
!     #############################################################
      SUBROUTINE write_surfn0_ol(HREC,KFIELD,KRESP,HCOMMENT)
!     #############################################################
!
!!****  *WRITEN0* - routine to read an integer
!
USE modi_ol_find_file_write
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
include "netcdf.inc"
!
!*      0.1   Declarations of arguments
!
 CHARACTER(LEN=12),  INTENT(IN)  :: hrec     ! name of the article to be read
INTEGER,            INTENT(IN)  :: kfield   ! the integer scalar to be read
INTEGER,            INTENT(OUT) :: kresp    ! KRESP  : return-code if a problem appears
 CHARACTER(LEN=100), INTENT(IN)  :: hcomment
!
!*      0.2   Declarations of local variables
!
INTEGER              :: ifile_id, ivar_id, jret
INTEGER,DIMENSION(2) :: iret
REAL(KIND=JPRB) :: zhook_handle
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_OL:WRITE_SURFN0_OL',0,zhook_handle)
!
kresp=0
!
! 0. find filename
! -----------------
 CALL ol_find_file_write(hrec,ifile_id)
!
IF (ifile_id /= 0) THEN    
  ! 1. Find id of the variable
  !----------------------------
  iret(1)=nf_inq_varid(ifile_id,hrec,ivar_id)   
  ! 2. Get variable
  !----------------------------
  iret(2)=nf_put_var_int(ifile_id,ivar_id,kfield)  
ENDIF
!
! 3. Check for errors
!--------------------
DO jret=1,2
  IF (ifile_id==0 .OR. iret(jret).NE.nf_noerr) kresp=1
ENDDO
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_OL:WRITE_SURFN0_OL',1,zhook_handle)
!
END SUBROUTINE write_surfn0_ol
!
!     #############################################################
      SUBROUTINE write_surfc0_ol(HREC,HFIELD,KRESP,HCOMMENT)
!     #############################################################
!
!!****  *WRITEC0* - routine to read a STRING
!
USE modi_ol_find_file_write
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
include "netcdf.inc"
!
!*      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 scalar to be read
INTEGER,            INTENT(OUT) :: kresp    ! KRESP  : return-code if a problem appears
 CHARACTER(LEN=100), INTENT(IN)  :: hcomment
!
!*      0.2   Declarations of local variables
!
 CHARACTER(LEN=100)   :: yfield
INTEGER              :: ifile_id, ivar_id, jret
INTEGER,DIMENSION(2) :: iret
REAL(KIND=JPRB) :: zhook_handle
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_OL:WRITE_SURFC0_OL',0,zhook_handle)
!
kresp=0
!
! 0. find filename
! -----------------
 CALL ol_find_file_write(hrec,ifile_id)
!
IF (ifile_id /= 0) THEN 
  ! 1. Find id of the variable
  !----------------------------
  iret(1)=nf_inq_varid(ifile_id,hrec,ivar_id)
  ! 2. Get variable
  !----------------------------
  yfield=hfield(:len_trim(hfield))
  iret(2)=nf_put_var_text(ifile_id,ivar_id,yfield)  
ENDIF
!
! 3. Check for errors
!--------------------
DO jret=1,2
  IF (ifile_id==0 .OR. iret(jret).NE.nf_noerr) kresp=1
ENDDO
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_OL:WRITE_SURFC0_OL',1,zhook_handle)
!
END SUBROUTINE write_surfc0_ol
!
!     #############################################################
      SUBROUTINE write_surfl0_ol(HREC,OFIELD,KRESP,HCOMMENT)
!     #############################################################
!
!!****  *WRITEL0* - routine to read a logical
!    
USE modi_ol_find_file_write
USE modi_handle_err
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
include "netcdf.inc"
!
!*      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
!
!*      0.2   Declarations of local variables
!
 CHARACTER(LEN=1)     :: yfield   ! work array read in the file
INTEGER              :: ifile_id, ivar_id, jret
INTEGER,DIMENSION(2) :: iret
REAL(KIND=JPRB) :: zhook_handle
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_OL:WRITE_SURFL0_OL',0,zhook_handle)
!
kresp=0
!
! 0. find filename
! -----------------
 CALL ol_find_file_write(hrec,ifile_id)
! 
IF (ifile_id /= 0) THEN        
  ! 1. Find id of the variable
  !----------------------------
  iret(1)=nf_inq_varid(ifile_id,hrec,ivar_id)
  IF (ofield) THEN
    yfield ='T'
  ELSE
    yfield ='F'
  ENDIF    
  ! 2. Put variable
  !----------------------------
  iret(2)=nf_put_var_text(ifile_id,ivar_id,yfield)
  CALL handle_err(iret(1),hrec)
ENDIF
!
! 3. Check for errors
!--------------------
DO jret=1,2
  IF (ifile_id==0 .OR. iret(jret).NE.nf_noerr) kresp=1
ENDDO
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_OL:WRITE_SURFL0_OL',1,zhook_handle)
!
END SUBROUTINE write_surfl0_ol
!
!     #############################################################
      SUBROUTINE write_surfx0_time_ol(PFIELD,KRESP,HCOMMENT)
!     #############################################################
!
!!****  *WRITEX1* - routine to fill a real 1D array for the externalised surface 
!
USE modd_io_surf_ol, ONLY: xstartw, xtype
USE modd_ol_fileid,  ONLY: xid_surf, xid_nature, xid_sea, xid_water, xid_town 
!
USE modi_handle_err
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
include "netcdf.inc"
!
!*      0.1   Declarations of arguments
!
REAL,                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
!
!*      0.2   Declarations of local variables
!
REAL(KIND=JPRB) :: zhook_handle
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_OL:WRITE_SURFX0_TIME_OL',0,zhook_handle)
!
kresp=0
!
IF (xtype==1) THEN
  CALL write_time_dim(xid_surf)
ELSEIF (xtype==2) THEN
  CALL write_time_dim(xid_nature)
ELSEIF (xtype==3) THEN
  CALL write_time_dim(xid_sea)
ELSEIF (xtype==4) THEN
  CALL write_time_dim(xid_water)
ELSEIF (xtype==5) THEN
  CALL write_time_dim(xid_town)
ENDIF
!
kresp = 0
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_OL:WRITE_SURFX0_TIME_OL',1,zhook_handle)
!
 CONTAINS
!
SUBROUTINE write_time_dim(PTAB)
!
INTEGER, DIMENSION(:), INTENT(IN) :: ptab
!
INTEGER :: ivar_id
INTEGER :: jret, jj       !loop index
REAL(KIND=JPRB) :: zhook_handle
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_OL:WRITE_SURFX0_TIME_OL:WRITE_TIME_DIM',0,zhook_handle)
!
IF (ptab(1).NE.0 .AND. xtype.NE.1) THEN
  !
  jret = nf_inq_varid(ptab(1),'time',ivar_id)
  IF (jret.EQ.nf_noerr) THEN
    jret = nf_put_vars_double(ptab(1),ivar_id,xstartw,1,1,pfield)
    CALL handle_err(jret,'time')
  ENDIF
  !
ENDIF
!  
DO jj=2,SIZE(ptab)
  !
  IF (ptab(jj).NE.ptab(jj-1) .AND. ptab(jj).NE.0) THEN
    jret = nf_inq_varid(ptab(jj),'time',ivar_id)
    IF (jret.EQ.nf_noerr) THEN
      jret = nf_put_vars_double(ptab(jj),ivar_id,xstartw,1,1,pfield)
      CALL handle_err(jret,'time')
    ENDIF
  ENDIF
  ! 
ENDDO
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_OL:WRITE_SURFX0_TIME_OL:WRITE_TIME_DIM',1,zhook_handle)
!
END SUBROUTINE write_time_dim
!
END SUBROUTINE write_surfx0_time_ol
!
!     #############################################################
      SUBROUTINE write_surfx1_ol (&
                                  hrec,pfield,kresp,hcomment,hdir)
!     #############################################################
!
!!****  *WRITEX1* - routine to fill a real 1D array for the externalised surface 
!  
!
!
!
USE modd_surfex_mpi, ONLY : nrank, npio, ncomm, nproc, xtime_npio_write, &
                            xtime_comm_write, wlog_mpi
USE modd_surfex_omp, ONLY : cwork0, nwork0, nworkvar, nworkb, nworkdims, &
                            nworkids, nworklen, lwork0
!
USE modd_io_surf_ol, ONLY: lmask, nmask, nmask_ign, xstart, &
                           xstride, lpartw, xstartw, xcountw
!
USE modi_io_buff
USE modi_ol_find_file_write
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
include "netcdf.inc"
!
#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
 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=100)    :: yname
INTEGER               :: ifile_id, ivar_id, jdim, indims
INTEGER               :: jret
INTEGER               :: infompi
INTEGER, DIMENSION(4) :: idimids
INTEGER, DIMENSION(4) :: idimlen
INTEGER,DIMENSION(5)  :: iret
DOUBLE PRECISION   :: xtime0
REAL, DIMENSION(:), ALLOCATABLE :: ztab1d
REAL, DIMENSION(:), ALLOCATABLE :: zwork_ign
REAL(KIND=JPRB) :: zhook_handle
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_OL:WRITE_SURFX1_OL',0,zhook_handle)
!
!$OMP BARRIER
!
iret(:) = 0
!
!$OMP SINGLE
!
nworkdims = 0
nworklen(:) = 0
 cwork0 = ""
nworkb=0
!
 CALL io_buff(&
                hrec,'W',lwork0)
!
!$OMP END SINGLE
!
IF (lwork0 .AND. lhook) CALL dr_hook("WRITE_SURF_OL:WRITE_SURFX1_OL",1,zhook_handle)
IF (lwork0) RETURN
!
IF (nrank==npio) THEN 
  !
#ifdef SFX_MPI
  xtime0 = mpi_wtime()
#endif
  !
!$OMP SINGLE
  !
  ! 0. find filename
  ! -----------------
  CALL ol_find_file_write(hrec,nwork0)
  !
  IF (nwork0 /= 0) THEN
    !
    ! 1. Find id of the variable
    !----------------------------
    iret(1)=nf_inq_varid(nwork0,hrec,nworkvar)
    iret(2)=nf_inq_varndims(nwork0,nworkvar,nworkdims)
    iret(3)=nf_inq_vardimid(nwork0,nworkvar,nworkids(1:nworkdims))
    DO jdim=1,2
      jret=nf_inq_dimlen(nwork0,nworkids(jdim),nworklen(jdim))
    ENDDO
    !
    iret(4)=nf_inq_dimname(nwork0,nworkids(1),cwork0)
    !
    ! 3. Check for errors
    !--------------------
    DO jret=1,4
      IF (nwork0==0 .OR. iret(jret).NE.nf_noerr) nworkb=1
    ENDDO
    !
  ENDIF
  ! 
!$OMP END SINGLE
  !
  ivar_id = nworkvar
  indims = nworkdims
  idimids = nworkids
  idimlen = nworklen
  yname = cwork0
  !
#ifdef SFX_MPI
  xtime_npio_write = xtime_npio_write + (mpi_wtime() - xtime0)
#endif
  !
ELSE
  ivar_id = 0
  indims = 0
  idimids(:) = 0
  idimlen(:) = 0
  yname = ""
ENDIF
!
kresp = nworkb
!
IF (nproc>1) THEN
#ifdef SFX_MPI
  xtime0 = mpi_wtime()
!$OMP SINGLE
  CALL mpi_bcast(nwork0,kind(nwork0)/4,mpi_integer,npio,ncomm,infompi)
!$OMP END SINGLE
  xtime_comm_write = xtime_comm_write + (mpi_wtime() - xtime0)
#endif
ENDIF
!
ifile_id = nwork0
!
IF (ifile_id/=0) THEN
  !
  IF (yname .EQ. 'Number_of_points') THEN
    CALL write_datax1_ol(idimlen(1),indims)
  ELSE
   CALL write_datax1_ol(idimlen(1)*idimlen(2),indims)
  ENDIF
  !
ENDIF
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_OL:WRITE_SURFX1_OL',1,zhook_handle)
!
 CONTAINS
!
SUBROUTINE write_datax1_ol(KDIM,KNDIMS)
!
USE modi_gather_and_write_mpi
USE modi_unpack_same_rank
USE modi_handle_err
!
IMPLICIT NONE
!
INTEGER, INTENT(IN) :: kdim
INTEGER, INTENT(IN) :: kndims
!
REAL, DIMENSION(KDIM) :: ztab1d
REAL, DIMENSION(KDIM) :: zwork_ign
!
INTEGER,   DIMENSION(KNDIMS) :: istart
INTEGER,   DIMENSION(KNDIMS) :: icount
INTEGER,   DIMENSION(KNDIMS) :: istride
REAL(KIND=JPRB) :: zhook_handle
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_OL:WRITE_SURFX1_OL:WRITE_DATAX1_OL',0,zhook_handle)
!
IF(.NOT.ALLOCATED(nmask_ign))THEN
  IF (lmask) THEN
    CALL gather_and_write_mpi(pfield,ztab1d,nmask)
  ELSE 
    CALL gather_and_write_mpi(pfield,ztab1d)
  ENDIF
ELSE
  !ign grid 
  IF (lmask) THEN
    CALL gather_and_write_mpi(pfield,zwork_ign(1:SIZE(nmask_ign)),nmask)
  ELSE 
    CALL gather_and_write_mpi(pfield,zwork_ign(1:SIZE(nmask_ign)))
  ENDIF
  CALL unpack_same_rank(nmask_ign,zwork_ign(1:SIZE(nmask_ign)),ztab1d)
ENDIF
!
IF (nrank==npio) THEN
  !
#ifdef SFX_MPI
  xtime0 = mpi_wtime()
#endif
  !
!$OMP SINGLE
  !
  IF  (lpartw) THEN
    ! write partially a time-matrix. 
    ! Have to find which of the dimension is the time dimension
    DO  jdim=1,kndims
      jret=nf_inq_dimname(ifile_id,idimids(jdim),yname)
      IF ((index(yname,'time') > 0).OR.(index(yname,'TIME') >0) &
            .OR.(index(yname,'Time')>0.)) THEN
        istart(jdim)=xstartw
        icount(jdim)=xcountw
        istride(jdim)=xstride
      ELSE
        istart(jdim)=1
        icount(jdim)=idimlen(jdim)
        istride(jdim)=1
      ENDIF
    ENDDO
    iret(5)=nf_put_vars_double(ifile_id,ivar_id,istart,icount,istride,ztab1d)
  ELSE
    iret(5)=nf_put_var_double(ifile_id,ivar_id,ztab1d)
  ENDIF
  !
  CALL handle_err(iret(5),hrec)
  !
!$OMP END SINGLE NOWAIT
  !
#ifdef SFX_MPI
  xtime_npio_write = xtime_npio_write + (mpi_wtime() - xtime0)
#endif
  !  
ENDIF
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_OL:WRITE_SURFX1_OL:WRITE_DATAX1_OL',1,zhook_handle)
!
END SUBROUTINE write_datax1_ol
!
END SUBROUTINE write_surfx1_ol
!
!     #############################################################
      SUBROUTINE write_surfx2_ol(HREC,PFIELD,KRESP,HCOMMENT,HDIR)
!     #############################################################
!
!!****  *WRITEX2* - routine to fill a real 2D array for the externalised surface 
!
USE modd_surfex_mpi, ONLY : nrank, npio, ncomm, nproc, xtime_npio_write, &
                            xtime_comm_write
!
USE modd_surfex_omp, ONLY : cwork0, nwork0, nworkvar, nworkb, nworkdims, &
                            nworkids, nworklen, nblock
!
USE modd_io_surf_ol, ONLY: lmask, nmask, nmask_ign, xstart, xstride, &
                           lpartw, xstartw, xcountw
!
USE modi_ol_find_file_write
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
include "netcdf.inc"
!
#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
 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=100)    :: yname
INTEGER               :: ifile_id, ivar_id, jdim, indims
INTEGER               :: jret
INTEGER               :: infompi
INTEGER, DIMENSION(4) :: idimids
INTEGER, DIMENSION(4) :: idimlen
INTEGER, DIMENSION(5) :: iret
DOUBLE PRECISION      :: xtime0
REAL(KIND=JPRB) :: zhook_handle
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_OL:WRITE_SURFX2_OL',0,zhook_handle)
!
!$OMP BARRIER
!
!$OMP SINGLE
nworkdims = 0
nworklen(:) = 0
 cwork0 = ""
!
nworkb=0
!$OMP END SINGLE
!
IF (nrank==npio) THEN
  !
#ifdef SFX_MPI
  xtime0 = mpi_wtime()
#endif
  !
!$OMP SINGLE
  !
  ! 0. find filename
  ! -----------------
  CALL ol_find_file_write(hrec,nwork0)
  !
  IF ( nwork0 /= 0 ) THEN
    !
    ! 1. Find id of the variable
    !----------------------------
    !
    iret(1)=nf_inq_varid(nwork0,hrec,nworkvar)
    iret(2)=nf_inq_varndims(nwork0,nworkvar,nworkdims) 

    iret(3)=nf_inq_vardimid(nwork0,nworkvar,nworkids(1:nworkdims))  
    DO jdim=1,nworkdims
      jret=nf_inq_dimlen(nwork0,nworkids(jdim),nworklen(jdim))
      IF (jret.NE.nf_noerr) nworkb=1
    ENDDO
    !
    iret(4)=nf_inq_dimname(nwork0,nworkids(1),cwork0)
    !  
  ENDIF
  !
  DO jret=1,4
    IF (nwork0==0 .OR. iret(jret).NE.nf_noerr) nworkb=1
  ENDDO
  !
!$OMP END SINGLE
  !
  ivar_id = nworkvar
  indims = nworkdims
  idimids = nworkids
  idimlen = nworklen
  yname = cwork0
  !
#ifdef SFX_MPI
  xtime_npio_write = xtime_npio_write + (mpi_wtime() - xtime0)
#endif
  !
ELSE
  ivar_id = 0
  indims = 0
  idimids(:) = 0
  idimlen(:) = SIZE(pfield,2)
  yname = "" 
ENDIF
!
!
kresp = nworkb
!
IF (nproc>1) THEN
#ifdef SFX_MPI
  xtime0 = mpi_wtime()
!$OMP SINGLE
  CALL mpi_bcast(nwork0,kind(nwork0)/4,mpi_integer,npio,ncomm,infompi)
!$OMP END SINGLE
  xtime_comm_write = xtime_comm_write + (mpi_wtime() - xtime0)  
#endif
ENDIF
!
ifile_id = nwork0
!
IF (ifile_id/=0) THEN
  !
  IF (yname .EQ. 'Number_of_points') THEN
    CALL write_datax2_ol(idimlen(1),idimlen(2),indims)
  ELSE
    CALL write_datax2_ol(idimlen(1)*idimlen(2),idimlen(3),indims)
  ENDIF
  !
ENDIF
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_OL:WRITE_SURFX2_OL',1,zhook_handle)
!
 CONTAINS
!
SUBROUTINE write_datax2_ol(KDIM1,KDIM2,KNDIMS)
!
USE modd_surf_par, ONLY : xundef
!
USE modi_gather_and_write_mpi
USE modi_unpack_same_rank
USE modi_handle_err
!
IMPLICIT NONE
!
INTEGER, INTENT(IN) :: kdim1
INTEGER, INTENT(IN) :: kdim2
INTEGER, INTENT(IN) :: kndims
!
REAL, DIMENSION(KDIM1,KDIM2) :: ztab2d    ! work array read in the file
REAL, DIMENSION(KDIM1,SIZE(PFIELD,2)) :: zwork_ign ! work array read in the file
INTEGER,         DIMENSION(KNDIMS) :: istart
INTEGER,         DIMENSION(KNDIMS) :: istride
INTEGER,         DIMENSION(KNDIMS) :: icount
REAL(KIND=JPRB) :: zhook_handle
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_OL:WRITE_SURFX2_OL:WRITE_DATAX2_OL',0,zhook_handle)
!
ztab2d(:,:) = xundef
!
IF(.NOT.ALLOCATED(nmask_ign))THEN
  IF (lmask) THEN
    CALL gather_and_write_mpi(pfield,ztab2d(:,1:SIZE(pfield,2)),nmask)
  ELSE 
    CALL gather_and_write_mpi(pfield,ztab2d(:,1:SIZE(pfield,2)))
  ENDIF
ELSE
  !ign grid 
  IF (lmask) THEN
    CALL gather_and_write_mpi(pfield,zwork_ign(1:SIZE(nmask_ign),:),nmask)
  ELSE 
    CALL gather_and_write_mpi(pfield,zwork_ign(1:SIZE(nmask_ign),:))
  ENDIF
  CALL unpack_same_rank(nmask_ign,zwork_ign(1:SIZE(nmask_ign),:),ztab2d(:,1:SIZE(pfield,2)))
ENDIF
!
IF (nrank==npio) THEN
  !
#ifdef SFX_MPI
  xtime0 = mpi_wtime()
#endif
  !
!$OMP SINGLE
  !
  ! 2. Put variable
  !----------------------------
  IF (lpartw) THEN
    ! write partially a time-matrix. 
    ! Have to find which of the dimension is the time dimension
    DO  jdim=1,kndims
      jret=nf_inq_dimname(ifile_id,idimids(jdim),yname)
      IF ((index(yname,'time') > 0).OR.(index(yname,'TIME') >0) &
         .OR.(index(yname,'Time')>0.)) THEN  
        istart(jdim)=xstartw
        icount(jdim)=xcountw
        istride(jdim)=xstride
      ELSE
        istart(jdim)=1
        icount(jdim)=idimlen(jdim)
        istride(jdim)=1
      ENDIF
    ENDDO
    iret(5)=nf_put_vars_double(ifile_id,ivar_id,istart,icount,istride,ztab2d)
  ELSE
    iret(5)=nf_put_var_double(ifile_id,ivar_id,ztab2d)
  ENDIF
  !    
  CALL handle_err(iret(5),hrec)  
  !
!$OMP END SINGLE NOWAIT
  !
#ifdef SFX_MPI
  xtime_npio_write = xtime_npio_write + (mpi_wtime() - xtime0)
#endif
  !
ENDIF
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_OL:WRITE_SURFX2_OL:WRITE_DATAX2_OL',1,zhook_handle)
!
END SUBROUTINE write_datax2_ol
!
END SUBROUTINE write_surfx2_ol

!     #############################################################
      SUBROUTINE write_surfn1_ol (&
                                  hrec,kfield,kresp,hcomment,hdir)
!     #############################################################
!
!!****  *WRITEN0* - routine to read an integer
!
!
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, DIMENSION(:),  INTENT(IN)  :: kfield   ! the integer scalar to be read
INTEGER,                INTENT(OUT) :: kresp    ! KRESP  : return-code if a problem appears
 CHARACTER(LEN=100),     INTENT(IN)  :: hcomment
 CHARACTER(LEN=1),       INTENT(IN) :: hdir     ! type of field :
                                               ! 'H' : field with
                                               !       horizontal spatial dim.
                                               ! '-' : no horizontal dim.
!*      0.2   Declarations of local variables
!
REAL, DIMENSION(SIZE(KFIELD)) :: zfield 
REAL(KIND=JPRB) :: zhook_handle
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_OL:WRITE_SURFN1_OL',0,zhook_handle)
!
zfield=float(kfield)
 CALL write_surfx1_ol(&
                      hrec,zfield,kresp,hcomment,hdir)
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_OL:WRITE_SURFN1_OL',1,zhook_handle)
!
END SUBROUTINE write_surfn1_ol
!
!     #############################################################
      SUBROUTINE write_surfl1_ol(HREC,OFIELD,KRESP,HCOMMENT,HDIR)
!     #############################################################
!
!!****  *WRITEL1* - routine to read a logical array
!    
USE modd_surfex_mpi, ONLY : nrank, npio, xtime_npio_write
!
USE modi_ol_find_file_write
USE modi_handle_err
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
include "netcdf.inc"
!
#ifdef SFX_MPI
include "mpif.h"
#endif
!
!*      0.1   Declarations of arguments
!
 CHARACTER(LEN=*),      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
 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               :: ifile_id, ivar_id, jdim, indims
INTEGER               :: jret
INTEGER, DIMENSION(4) :: idimids
INTEGER, DIMENSION(1) :: idimlen
INTEGER, DIMENSION(4) :: iret
DOUBLE PRECISION      :: xtime0
REAL(KIND=JPRB) :: zhook_handle
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_OL:WRITE_SURFL1_OL',0,zhook_handle)
!
!$OMP BARRIER
!
kresp=0
!
IF ( nrank==npio ) THEN
  !
#ifdef SFX_MPI
  xtime0 = mpi_wtime()
#endif

  !
!$OMP SINGLE
  !   
  ! 0. find filename
  ! -----------------
  CALL ol_find_file_write(hrec,ifile_id)
  ! 
  IF (ifile_id /= 0) THEN
    !       
    ! 1. Find id of the variable
    !----------------------------
    iret(1)=nf_inq_varid(ifile_id,hrec,ivar_id)
    iret(2)=nf_inq_varndims(ifile_id,ivar_id,indims)
    iret(3)=nf_inq_vardimid(ifile_id,ivar_id,idimids(1:indims))
    DO jdim=1,1
      jret=nf_inq_dimlen(ifile_id,idimids(jdim),idimlen(jdim))
    ENDDO  
    !
    CALL write_datal1_ol(idimlen(1))
    !
  ENDIF
  !
  ! 3. Check for errors
  !--------------------
  DO jret=1,4
    IF (ifile_id==0 .OR. iret(jret).NE.nf_noerr) kresp=1
  ENDDO
  !
!$OMP END SINGLE
  !
#ifdef SFX_MPI
  xtime_npio_write = xtime_npio_write + (mpi_wtime() - xtime0)
#endif
  !
ENDIF
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_OL:WRITE_SURFL1_OL',1,zhook_handle)
!
 CONTAINS
!
SUBROUTINE write_datal1_ol(KDIM)
!
INTEGER, INTENT(IN) :: kdim
!
 CHARACTER(LEN=1), DIMENSION(KDIM) :: ytab1d  ! work array read in the file
REAL(KIND=JPRB) :: zhook_handle
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_OL:WRITE_SURFL1_OL:WRITE_DATAL1_OL',0,zhook_handle)
!
DO jret=1,kdim
  IF (ofield(jret)) THEN
    ytab1d(jret) ='T'
  ELSE
    ytab1d(jret) ='F'
  ENDIF
ENDDO  
!
! 2. Put variable
!-----------------
iret(4)=nf_put_var_text(ifile_id,ivar_id,ytab1d)
!
 CALL handle_err(iret(4),hrec)
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_OL:WRITE_SURFL1_OL:WRITE_DATAL1_OL',1,zhook_handle)
END SUBROUTINE write_datal1_ol
!
END SUBROUTINE write_surfl1_ol
!
!
!     #############################################################
      SUBROUTINE write_surft0_ol(HREC,KYEAR,KMONTH,KDAY,PTIME,KRESP,HCOMMENT)
!     #############################################################
!
!!****  *WRITET0* - routine to read a NETCDF  date_time scalar
!
USE modd_type_date_surf
!
USE modi_ol_find_file_write
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
include "netcdf.inc"
!
!*      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
!
!*      0.2   Declarations of local variables
!
 CHARACTER(LEN=12) :: yrecfm    ! Name of the article to be written
INTEGER :: ifile_id, ivar_id, jret, jwrk
INTEGER :: jlen
INTEGER,DIMENSION(3) :: itdate  ! work array read in the file
INTEGER,DIMENSION(4) :: iret
REAL(KIND=JPRB) :: zhook_handle
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_OL:WRITE_SURFT0_OL',0,zhook_handle)
!
kresp=0
!
DO jwrk=1,2
  !
  IF (jwrk == 1) THEN 
    yrecfm=trim(hrec)//'-TDATE'
    jlen=3
  ELSE
    yrecfm=trim(hrec)//'-TIME'
    jlen=1
  ENDIF
  ! 0. find filename
  ! -----------------
  CALL ol_find_file_write(yrecfm,ifile_id)
  !
  IF (ifile_id /= 0) THEN
    !    
    ! 1. Find id of the variable
    !----------------------------
    iret(1+jwrk*2)=nf_inq_varid(ifile_id,yrecfm,ivar_id)
    IF (jwrk == 1) THEN 
      itdate(1)=kyear
      itdate(2)=kmonth
      itdate(3)=kday
      iret(jwrk)=nf_put_var_int(ifile_id,ivar_id,itdate)
    ELSE
      jlen=1
      iret(jwrk)=nf_put_var_double(ifile_id,ivar_id,ptime)
    ENDIF
  ENDIF
ENDDO
!
! 3. Check for errors
!--------------------
DO jret=1,4
  IF (ifile_id==0.OR.iret(jret).NE.nf_noerr) kresp=1
ENDDO
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_OL:WRITE_SURFT0_OL',1,zhook_handle)
!
END SUBROUTINE write_surft0_ol

END MODULE mode_write_surf_ol