mode_write_surf_txt.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_txt
!
USE modi_init_write_txt
INTERFACE write_surf0_txt
        MODULE PROCEDURE write_surfx0_txt
        MODULE PROCEDURE write_surfn0_txt
        MODULE PROCEDURE write_surfc0_txt
        MODULE PROCEDURE write_surfl0_txt
END INTERFACE
INTERFACE write_surfx_txt
        MODULE PROCEDURE write_surfx1_txt
        MODULE PROCEDURE write_surfx2_txt
END INTERFACE
INTERFACE write_surfn_txt
        MODULE PROCEDURE write_surfn1_txt
        MODULE PROCEDURE write_surfl1_txt
END INTERFACE
INTERFACE write_surft_txt
        MODULE PROCEDURE write_surft0_txt
        MODULE PROCEDURE write_surft2_txt
END INTERFACE
!
 CONTAINS
!
!     #############################################################
      SUBROUTINE write_surfx0_txt(HREC,PFIELD,KRESP,HCOMMENT)
!     #############################################################
!
!!****  * - routine to write a real scalar
!
USE modi_error_write_surf_txt
!
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
REAL(KIND=JPRB) :: zhook_handle
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_TXT:WRITE_SURFX0_TXT',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_TXT:WRITE_SURFX0_TXT',1,zhook_handle)
RETURN
!
100 CONTINUE
 CALL error_write_surf_txt(hrec,kresp)
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_TXT:WRITE_SURFX0_TXT',1,zhook_handle)
!
END SUBROUTINE write_surfx0_txt
!
!     #############################################################
      SUBROUTINE write_surfn0_txt(HREC,KFIELD,KRESP,HCOMMENT)
!     #############################################################
!
!!****  * - routine to write an integer
!
USE modi_error_write_surf_txt
!
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
REAL(KIND=JPRB) :: zhook_handle
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_TXT:WRITE_SURFN0_TXT',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_TXT:WRITE_SURFN0_TXT',1,zhook_handle)
RETURN
!
100 CONTINUE
 CALL error_write_surf_txt(hrec,kresp)
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_TXT:WRITE_SURFN0_TXT',1,zhook_handle)
!
END SUBROUTINE write_surfn0_txt
!
!     #############################################################
      SUBROUTINE write_surfc0_txt(HREC,HFIELD,KRESP,HCOMMENT)
!     #############################################################
!
!!****  * - routine to write a character
!
USE modi_error_write_surf_txt
!
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
REAL(KIND=JPRB) :: zhook_handle
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_TXT:WRITE_SURFC0_TXT',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_TXT:WRITE_SURFC0_TXT',1,zhook_handle)
RETURN
!
100 CONTINUE
 CALL error_write_surf_txt(hrec,kresp)
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_TXT:WRITE_SURFC0_TXT',1,zhook_handle)
!
END SUBROUTINE write_surfc0_txt
!
!     #############################################################
      SUBROUTINE write_surfl0_txt(HREC,OFIELD,KRESP,HCOMMENT)
!     #############################################################
!
!!****  * - routine to write a logical
!
USE modi_error_write_surf_txt
!
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
REAL(KIND=JPRB) :: zhook_handle
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_TXT:WRITE_SURFL0_TXT',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_TXT:WRITE_SURFL0_TXT',1,zhook_handle)
RETURN
!
100 CONTINUE
 CALL error_write_surf_txt(hrec,kresp)
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_TXT:WRITE_SURFL0_TXT',1,zhook_handle)
!
END SUBROUTINE write_surfl0_txt
!
!     #############################################################
      SUBROUTINE write_surfx1_txt (DGU, &
                                   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_surfex_mpi, ONLY : nrank, npio, xtime_npio_write
!
USE modd_io_surf_txt,        ONLY : nmask, nfull, cmask
USE modd_write_txt,          ONLY : cvar, nvar, nind
!
USE modi_error_write_surf_txt
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
!
!
TYPE(diag_surf_atm_t), INTENT(INOUT) :: dgu
!
 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
!
INTEGER                :: isize
LOGICAL                :: lwfl=.false.
REAL, 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_TXT:WRITE_SURFX1_TXT',0,zhook_handle)
!
kresp=0
!  
IF (hdir=='-') THEN
  isize = SIZE(pfield)
  zwork(1:isize) = pfield
ELSE
  isize = SIZE(zwork)
  CALL gather_and_write_mpi(pfield,zwork,nmask)
ENDIF
!
IF (nrank==npio) THEN
  ! 
#ifdef SFX_MPI
  xtime0 = mpi_wtime()
#endif
  !
!$OMP SINGLE
  !
  CALL init_write_txt(dgu, &
                      hrec,lwfl)
  !
  IF (lwfl) WRITE(nind,fmt='(50D14.6)',iostat=kresp) zwork(1:isize)
  !
  IF (kresp/=0) CALL error_write_surf_txt(hrec,kresp)
  !
!$OMP END SINGLE NOWAIT
  !  
#ifdef SFX_MPI
  xtime_npio_write = xtime_npio_write + (mpi_wtime() - xtime0)
#endif
  !  
END IF
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_TXT:WRITE_SURFX1_TXT',1,zhook_handle)
!
END SUBROUTINE write_surfx1_txt
!
!     #############################################################
      SUBROUTINE write_surfx2_txt (DGU, &
                                   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_surfex_mpi, ONLY : nrank, npio, xtime_npio_write
!
USE modd_io_surf_txt,        ONLY : nmask, nfull
USE modd_write_txt,          ONLY : cvar, nvar, nind
!
USE modi_error_write_surf_txt
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
!
!
TYPE(diag_surf_atm_t), INTENT(INOUT) :: dgu
!
 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
! 
INTEGER :: isize
LOGICAL :: lwfl=.false.
REAL, 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_TXT:WRITE_SURFX2_TXT',0,zhook_handle)
!
kresp=0
!
IF (hdir=='-') THEN
  isize = SIZE(pfield,1)
  zwork(1:isize,:) = pfield
ELSE
  isize = SIZE(zwork,1)
  CALL gather_and_write_mpi(pfield,zwork,nmask)
ENDIF
!
IF (nrank==npio) THEN
  !
#ifdef SFX_MPI
  xtime0 = mpi_wtime()
#endif
  !  
!$OMP SINGLE
  !  
  CALL init_write_txt(dgu, &
                      hrec,lwfl)
  !
  IF (lwfl) WRITE(nind,fmt='(50D14.6)',iostat=kresp) zwork(1:isize,:)
  !
  IF (kresp/=0) CALL error_write_surf_txt(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_TXT:WRITE_SURFX2_TXT',1,zhook_handle)
!
END SUBROUTINE write_surfx2_txt
!
!     #############################################################
      SUBROUTINE write_surfn1_txt(HREC,KFIELD,KRESP,HCOMMENT,HDIR)
!     #############################################################
!
!!****  * - routine to write an integer array
!
USE modi_error_write_surf_txt
!
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_TXT:WRITE_SURFN1_TXT',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_TXT:WRITE_SURFN1_TXT',1,zhook_handle)
RETURN
!
100 CONTINUE
 CALL error_write_surf_txt(hrec,kresp)
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_TXT:WRITE_SURFN1_TXT',1,zhook_handle)
!
END SUBROUTINE write_surfn1_txt
!
!     #############################################################
      SUBROUTINE write_surfl1_txt(HREC,OFIELD,KRESP,HCOMMENT,HDIR)
!     #############################################################
!
!!****  * - routine to write a logical array
!
USE modi_error_write_surf_txt
!
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.
REAL(KIND=JPRB) :: zhook_handle
!
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_TXT:WRITE_SURFL1_TXT',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_TXT:WRITE_SURFL1_TXT',1,zhook_handle)
RETURN
!
100 CONTINUE
 CALL error_write_surf_txt(hrec,kresp)
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_TXT:WRITE_SURFL1_TXT',1,zhook_handle)
!
END SUBROUTINE write_surfl1_txt
!
!     #############################################################
      SUBROUTINE write_surft0_txt(HREC,KYEAR,KMONTH,KDAY,PTIME,KRESP,HCOMMENT)
!     #############################################################
!
!!****  * - routine to write a date
!             ------------
!
USE modi_error_write_surf_txt
!
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_TXT:WRITE_SURFT0_TXT',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_TXT:WRITE_SURFT0_TXT',1,zhook_handle)
RETURN
!
100 CONTINUE
 CALL error_write_surf_txt(hrec,kresp)
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_TXT:WRITE_SURFT0_TXT',1,zhook_handle)
!
END SUBROUTINE write_surft0_txt
!
!     #############################################################
      SUBROUTINE write_surft2_txt(HREC,KYEAR,KMONTH,KDAY,PTIME,KRESP,HCOMMENT)
!     #############################################################
!
!!****  * - routine to write a date
!
USE modi_error_write_surf_txt
!
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_TXT:WRITE_SURFT2_TXT',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_TXT:WRITE_SURFT2_TXT',1,zhook_handle)
RETURN
!
100 CONTINUE
 CALL error_write_surf_txt(hrec,kresp)
IF (lhook) CALL dr_hook('MODE_WRITE_SURF_TXT:WRITE_SURFT2_TXT',1,zhook_handle)
!
END SUBROUTINE write_surft2_txt
!
END MODULE mode_write_surf_txt