mode_write_surf_bin.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_bin
!
INTERFACE write_surf0_bin
        MODULE PROCEDURE write_surfx0_bin
        MODULE PROCEDURE write_surfn0_bin
        MODULE PROCEDURE write_surfl0_bin
        MODULE PROCEDURE write_surfc0_bin
END INTERFACE
INTERFACE write_surfx_bin
        MODULE PROCEDURE write_surfx1_bin
        MODULE PROCEDURE write_surfx2_bin
END INTERFACE
INTERFACE write_surfn_bin
        MODULE PROCEDURE write_surfn1_bin
        MODULE PROCEDURE write_surfl1_bin
END INTERFACE
INTERFACE write_surft_bin
        MODULE PROCEDURE write_surft0_bin
        MODULE PROCEDURE write_surft2_bin
END INTERFACE
!
 CONTAINS
!
!     #############################################################
      SUBROUTINE write_surfx0_bin(HREC,PFIELD,KRESP,HCOMMENT)
!     #############################################################
!
!!****  * - routine to write a real scalar
!
USE modi_error_write_surf_bin
!
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
!
REAL(KIND=JPRB) :: zhook_handle
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_BIN:WRITE_SURFX0_BIN',0,zhook_handle)
!
kresp=0
!
!plm WRITE(NUNIT,FMT=*,ERR=100) '&'//CMASK//' '//HREC
!plm WRITE(NUNIT,FMT='(A50)',ERR=100) HCOMMENT(1:50)
!plm WRITE(NUNIT,FMT=*,ERR=100) PFIELD

IF (lhook) CALL dr_hook('MODE_WRITE_SURF_BIN:WRITE_SURFX0_BIN',1,zhook_handle)
RETURN
!
100 CONTINUE
 CALL error_write_surf_bin(hrec,kresp)
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_BIN:WRITE_SURFX0_BIN',1,zhook_handle)
!
END SUBROUTINE write_surfx0_bin
!
!     #############################################################
      SUBROUTINE write_surfn0_bin(HREC,KFIELD,KRESP,HCOMMENT)
!     #############################################################
!
!!****  * - routine to write an integer
!
USE modi_error_write_surf_bin
!
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
!
REAL(KIND=JPRB) :: zhook_handle
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_BIN:WRITE_SURFN0_BIN',0,zhook_handle)
!
kresp=0
!
!plm WRITE(NUNIT,FMT=*,ERR=100) '&'//CMASK//' '//HREC
!plm WRITE(NUNIT,FMT='(A50)',ERR=100) HCOMMENT(1:50)
!plm WRITE(NUNIT,FMT=*,ERR=100) KFIELD
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_BIN:WRITE_SURFN0_BIN',1,zhook_handle)
RETURN
!
100 CONTINUE
 CALL error_write_surf_bin(hrec,kresp)
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_BIN:WRITE_SURFN0_BIN',1,zhook_handle)
!
END SUBROUTINE write_surfn0_bin
!
!     #############################################################
      SUBROUTINE write_surfl0_bin(HREC,OFIELD,KRESP,HCOMMENT)
!     #############################################################
!
!!****  * - routine to write a logical
!
USE modi_error_write_surf_bin
!
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
!
REAL(KIND=JPRB) :: zhook_handle
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_BIN:WRITE_SURFL0_BIN',0,zhook_handle)
!
kresp=0
!
!plm WRITE(NUNIT,FMT=*,ERR=100) '&'//CMASK//' '//HREC
!plm WRITE(NUNIT,FMT='(A50)',ERR=100) HCOMMENT(1:50)
!plm WRITE(NUNIT,FMT=*,ERR=100) OFIELD

IF (lhook) CALL dr_hook('MODE_WRITE_SURF_BIN:WRITE_SURFL0_BIN',1,zhook_handle)
RETURN
!
100 CONTINUE
 CALL error_write_surf_bin(hrec,kresp)
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_BIN:WRITE_SURFL0_BIN',1,zhook_handle)
!
END SUBROUTINE write_surfl0_bin
!
!     #############################################################
      SUBROUTINE write_surfc0_bin(HREC,HFIELD,KRESP,HCOMMENT)
!     #############################################################
!
!!****  * - routine to write a character
!
USE modi_error_write_surf_bin
!
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
!
REAL(KIND=JPRB) :: zhook_handle
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_BIN:WRITE_SURFC0_BIN',0,zhook_handle)
!
kresp=0
!
!plm WRITE(NUNIT,FMT=*,ERR=100) '&'//CMASK//' '//HREC
!plm WRITE(NUNIT,FMT='(A50)',ERR=100) HCOMMENT(1:50)
!plm WRITE(NUNIT,FMT='(A40)',ERR=100) HFIELD

IF (lhook) CALL dr_hook('MODE_WRITE_SURF_BIN:WRITE_SURFC0_BIN',1,zhook_handle)
RETURN
!
100 CONTINUE
 CALL error_write_surf_bin(hrec,kresp)
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_BIN:WRITE_SURFC0_BIN',1,zhook_handle)
!
END SUBROUTINE write_surfc0_bin
!
!     #############################################################
      SUBROUTINE write_surfx1_bin (DGU, U, &
                                   hrec,pfield,kresp,hcomment,hdir)
!     #############################################################
!
!!****  * - routine to fill a write 1D array for the externalised surface 
!
!
!
!
USE modd_diag_surf_atm_n, ONLY : diag_surf_atm_t
USE modd_surf_atm_n, ONLY : surf_atm_t
!
USE modd_surfex_mpi, ONLY : nrank, npio, xtime_npio_write
!
USE modd_io_surf_bin,        ONLY : nmask, nfull, cmask
USE modd_write_bin,          ONLY : cvar, nvar, nind, nwrite
!
USE modi_error_write_surf_bin
USE modi_gather_and_write_mpi
USE modi_init_write_bin
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
#ifdef SFX_MPI
include "mpif.h"
#endif
!
!*      0.1   Declarations of arguments
!
!
TYPE(diag_surf_atm_t), INTENT(INOUT) :: dgu
TYPE(surf_atm_t), INTENT(INOUT) :: u
!
 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                           :: lwfl=.false.
REAL(KIND=4), DIMENSION(MAX(NFULL,SIZE(PFIELD)))    :: zwork   ! work array read in the file
DOUBLE PRECISION   :: xtime0
REAL(KIND=JPRB) :: zhook_handle
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_BIN:WRITE_SURFX1_BIN',0,zhook_handle)
!
kresp=0
!
 CALL gather_and_write_mpi(pfield,zwork,nmask)
!
IF (nrank==npio) THEN
  !
#ifdef SFX_MPI
  xtime0 = mpi_wtime()
#endif
  !
!$OMP SINGLE
  !  
  CALL init_write_bin(dgu, u, &
                      hrec,1,lwfl)
  !
  IF (lwfl) THEN 
    WRITE(nind,rec=nwrite,iostat=kresp) zwork
  ENDIF
  !
  IF (kresp/=0) CALL error_write_surf_bin(hrec,kresp)  
  !
!$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_BIN:WRITE_SURFX1_BIN',1,zhook_handle)
!
END SUBROUTINE write_surfx1_bin
!
!     #############################################################
      SUBROUTINE write_surfx2_bin (DGU, U, &
                                   hrec,pfield,kresp,hcomment,hdir)
!     #############################################################
!
!!****  * - routine to fill a write 2D array for the externalised surface 
!
!
!
!
USE modd_diag_surf_atm_n, ONLY : diag_surf_atm_t
USE modd_surf_atm_n, ONLY : surf_atm_t
!
USE modd_surfex_mpi, ONLY : nrank, npio, xtime_npio_write
!
USE modd_io_surf_bin,        ONLY : nmask, nfull
USE modd_write_bin,          ONLY : cvar, nvar, nind, nwrite
!
USE modi_error_write_surf_bin
USE modi_gather_and_write_mpi
USE modi_init_write_bin
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
#ifdef SFX_MPI
include "mpif.h"
#endif
!
!*      0.1   Declarations of arguments
!
!
TYPE(diag_surf_atm_t), INTENT(INOUT) :: dgu
TYPE(surf_atm_t), INTENT(INOUT) :: u
!
 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 :: lwfl=.false.
REAL(KIND=4), DIMENSION(MAX(NFULL,SIZE(PFIELD,1)),SIZE(PFIELD,2)) :: zwork   ! work array read in the file
DOUBLE PRECISION   :: xtime0
REAL(KIND=JPRB) :: zhook_handle
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_BIN:WRITE_SURFX2_BIN',0,zhook_handle)
!
kresp=0
!
 CALL gather_and_write_mpi(pfield,zwork,nmask)
!
IF (nrank==npio) THEN
  !
#ifdef SFX_MPI
  xtime0 = mpi_wtime()
#endif
  !
!$OMP SINGLE
  !
  CALL init_write_bin(dgu, u, &
                      hrec,SIZE(pfield,2),lwfl)
  !
  IF (lwfl) THEN
    WRITE(nind,rec=nwrite,iostat=kresp) zwork
  ENDIF
  !
  IF (kresp/=0) CALL error_write_surf_bin(hrec,kresp)
  !
!$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_BIN:WRITE_SURFX2_BIN',1,zhook_handle)
!
END SUBROUTINE write_surfx2_bin
!
!     #############################################################
      SUBROUTINE write_surfn1_bin(HREC,KFIELD,KRESP,HCOMMENT,HDIR)
!     #############################################################
!
!!****  * - routine to write an integer array
!
USE modi_error_write_surf_bin
!
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 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
!
!INTEGER, DIMENSION(NFULL) :: IWORK  ! work array read in the file
REAL(KIND=JPRB) :: zhook_handle
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_BIN:WRITE_SURFN1_BIN',0,zhook_handle)
!
kresp = 0
!
!plm IF (HREC(1:8)=="EMISTIME") THEN
  !plm WRITE(NUNIT,FMT=*,ERR=100) '&'//CMASK//' '//HREC
  !plm WRITE(NUNIT,FMT='(A50)',ERR=100) HCOMMENT(1:50)
  !plm WRITE(NUNIT,FMT='(100I8)',ERR=100) KFIELD

!plm ELSE
  !plm CALL UNPACK_SAME_RANK(NMASK,KFIELD,IWORK(:))

  !plm WRITE(NUNIT,FMT=*,ERR=100) '&'//CMASK//' '//HREC
  !plm WRITE(NUNIT,FMT='(A50)',ERR=100) HCOMMENT(1:50)
  !plm WRITE(NUNIT,FMT='(100I8)',ERR=100) IWORK
  !
!plm ENDIF
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_BIN:WRITE_SURFN1_BIN',1,zhook_handle)
RETURN
!
100 CONTINUE
 CALL error_write_surf_bin(hrec,kresp)
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_BIN:WRITE_SURFN1_BIN',1,zhook_handle)
!
END SUBROUTINE write_surfn1_bin
!
!     #############################################################
      SUBROUTINE write_surfl1_bin(HREC,OFIELD,KRESP,HCOMMENT,HDIR)
!     #############################################################
!
!!****  * - routine to write a logical array
!
USE modi_error_write_surf_bin
!
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, 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
!
REAL(KIND=JPRB) :: zhook_handle
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_BIN:WRITE_SURFL1_BIN',0,zhook_handle)
!
kresp=0
!
!plm WRITE(NUNIT,FMT=*,ERR=100) '&'//CMASK//' '//HREC
!plm WRITE(NUNIT,FMT='(A50)',ERR=100) HCOMMENT(1:50)
!plm WRITE(NUNIT,FMT=*,ERR=100) OFIELD

IF (lhook) CALL dr_hook('MODE_WRITE_SURF_BIN:WRITE_SURFL1_BIN',1,zhook_handle)
RETURN
!
100 CONTINUE
 CALL error_write_surf_bin(hrec,kresp)
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_BIN:WRITE_SURFL1_BIN',1,zhook_handle)
!
END SUBROUTINE write_surfl1_bin
!
!     #############################################################
      SUBROUTINE write_surft0_bin(HREC,KYEAR,KMONTH,KDAY,PTIME,KRESP,HCOMMENT)
!     #############################################################
!
!!****  * - routine to write a date
!
USE modi_error_write_surf_bin
!
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
!
INTEGER, DIMENSION(3) :: itdate
REAL(KIND=JPRB) :: zhook_handle
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_BIN:WRITE_SURFT0_BIN',0,zhook_handle)
kresp=0
!
!plm ITDATE(1) = KYEAR
!plm ITDATE(2) = KMONTH
!plm ITDATE(3) = KDAY

!plm WRITE(NUNIT,FMT=*,ERR=100) '&'//CMASK//' '//TRIM(HREC)//'%TDATE'
!plm WRITE(NUNIT,FMT='(A50)',ERR=100) HCOMMENT(1:50)
!plm WRITE(NUNIT,FMT=*,ERR=100) ITDATE(:)

!-------------------------------------------------------------------------------
!
!plm WRITE(NUNIT,FMT=*,ERR=100) '&'//CMASK//' '//TRIM(HREC)//'%TIME'
!plm WRITE(NUNIT,FMT='(A50)',ERR=100) HCOMMENT(1:50)
!plm WRITE(NUNIT,FMT=*,ERR=100) PTIME

!-------------------------------------------------------------------------------
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_BIN:WRITE_SURFT0_BIN',1,zhook_handle)
RETURN
!
100 CONTINUE
 CALL error_write_surf_bin(hrec,kresp)
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_BIN:WRITE_SURFT0_BIN',1,zhook_handle)
!
END SUBROUTINE write_surft0_bin
!
!     #############################################################
      SUBROUTINE write_surft2_bin(HREC,KYEAR,KMONTH,KDAY,PTIME,KRESP,HCOMMENT)
!     #############################################################
!
!!****  * - routine to write a date
!
USE modi_error_write_surf_bin
!
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)  :: 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
!
INTEGER, DIMENSION(3,SIZE(KYEAR,1),SIZE(KYEAR,2)) :: itdate
REAL(KIND=JPRB) :: zhook_handle
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_BIN:WRITE_SURFT2_BIN',0,zhook_handle)
kresp=0
!
!plm ITDATE(1,:,:) = KYEAR  (:,:)
!plm ITDATE(2,:,:) = KMONTH (:,:)
!plm ITDATE(3,:,:) = KDAY   (:,:)

!plm WRITE(NUNIT,FMT=*,ERR=100) '&'//CMASK//' '//TRIM(HREC)//'%TDATE'
!plm WRITE(NUNIT,FMT='(A50)',ERR=100) HCOMMENT(1:50)
!plm WRITE(NUNIT,FMT=*,ERR=100) ITDATE(:,:,:)

!-------------------------------------------------------------------------------
!
!plm WRITE(NUNIT,FMT=*,ERR=100) '&'//CMASK//' '//TRIM(HREC)//'%TIME'
!plm WRITE(NUNIT,FMT='(A50)',ERR=100) HCOMMENT(1:50)
!plm WRITE(NUNIT,FMT=*,ERR=100) PTIME

!-------------------------------------------------------------------------------
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_BIN:WRITE_SURFT2_BIN',1,zhook_handle)
RETURN
!
100 CONTINUE
 CALL error_write_surf_bin(hrec,kresp)
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_BIN:WRITE_SURFT2_BIN',1,zhook_handle)
!
END SUBROUTINE write_surft2_bin

END MODULE mode_write_surf_bin