write_surf_mnh.f90

!!    EXTERNAL
!!    --------
!!
!!
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------
!!
!!
!!    REFERENCE
!!    ---------
!!
!!
!!    AUTHOR
!!    ------
!!
!!      S.Malardel      *METEO-FRANCE*
!!
!!    MODIFICATIONS
!!    -------------
!!
!!      original                                                     01/08/03
!!  Philippe Wautelet: 05/2016-04/2018: new data structures and calls for I/O
!----------------------------------------------------------------------------
!
!*      0.    DECLARATIONS
!             ------------
!
use modd_field,          only: tfieldmetadata, TYPEINT
USE MODD_IO,             ONLY: TFILE_SURFEX
USE MODD_IO_SURF_MNH,    ONLY: NMASK, CMASK, &
                               NIU, NJU, NIB, NJB, NIE, NJE
USE MODD_PARAMETERS,     ONLY: NUNDEF

use MODE_IO_FIELD_WRITE, only: IO_Field_write
USE MODE_MSG
USE MODE_WRITE_SURF_MNH_TOOLS

USE MODI_UNPACK_1D_2D

IMPLICIT NONE
!
!*      0.1   Declarations of arguments
!
CHARACTER(LEN=MNH_LEN_HREC),INTENT(IN)  :: HREC     ! name of the article to write
INTEGER,                INTENT(IN)  :: KL       ! number of points
INTEGER, DIMENSION(KL), INTENT(IN)  :: KFIELD   ! the integers to be written
INTEGER,                INTENT(OUT) :: 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(:,:), ALLOCATABLE :: IWORK  ! work array written in the file
!
CHARACTER(LEN=5)     :: YMSG
TYPE(TFIELDMETADATA) :: TZFIELD
!-------------------------------------------------------------------------------
!
CALL PRINT_MSG(NVERB_DEBUG,'IO','WRITE_SURFN1_MNH',TRIM(TFILE_SURFEX%CNAME)//': writing '//TRIM(HREC))
!
IF (HDIR=='-') THEN
!
  CALL PREPARE_METADATA_WRITE_SURF(HREC,'--',HCOMMENT,0,TYPEINT,1,'WRITE_SURFN1_MNH',TZFIELD)
  CALL IO_Field_write(TFILE_SURFEX,TZFIELD,KFIELD,KRESP)
!
ELSE IF (HDIR=='H') THEN
!
  ALLOCATE(IWORK(NIU,NJU))
  IWORK(:,:) = NUNDEF
!
  CALL UNPACK_1D_2D(NMASK,KFIELD,IWORK(NIB:NIE,NJB:NJE))
!
  CALL PREPARE_METADATA_WRITE_SURF(HREC,'XY',HCOMMENT,4,TYPEINT,2,'WRITE_SURFN1_MNH',TZFIELD)
  CALL IO_Field_write(TFILE_SURFEX,TZFIELD,IWORK(:,:),KRESP)
!
  DEALLOCATE(IWORK)
END IF
!
IF (KRESP /=0) THEN
  WRITE ( YMSG, '( I5 )' ) KRESP
  CALL PRINT_MSG(NVERB_ERROR,'IO','WRITE_SURFN1_MNH','error when writing article '//TRIM(HREC)//' KRESP='//YMSG)
END IF
!-------------------------------------------------------------------------------
END SUBROUTINE WRITE_SURFN1_MNH
!
!     #############################################################
      SUBROUTINE WRITE_SURFC0_MNH(HREC,HFIELD,KRESP,HCOMMENT)
!     #############################################################
!
!!****  *WRITEC0* - routine to write an integer
!!
!!    PURPOSE
!!    -------
!
!       The purpose of WRITEC0 is
!
!!**  METHOD
!!    ------
!!
!!    EXTERNAL
!!    --------
!!
!!
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------
!!
!!
!!    REFERENCE
!!    ---------
!!
!!
!!    AUTHOR
!!    ------
!!
!!      S.Malardel      *METEO-FRANCE*
!!
!!    MODIFICATIONS
!!    -------------
!!
!!      original                                                     01/08/03
!!  Philippe Wautelet: 05/2016-04/2018: new data structures and calls for I/O
!----------------------------------------------------------------------------
!
!*      0.    DECLARATIONS
!             ------------
!
USE MODD_CONF_n,         ONLY: CSTORAGE_TYPE
use modd_field,          only: tfieldmetadata, TYPECHAR, TYPELOG
USE MODD_IO,             ONLY: TFILE_SURFEX
USE MODD_IO_SURF_MNH,    ONLY: NIU_ALL, NJU_ALL

use MODE_IO_FIELD_WRITE, only: IO_Field_write
USE MODE_MSG
USE MODE_WRITE_SURF_MNH_TOOLS

IMPLICIT NONE
!
!*      0.1   Declarations of arguments
!
CHARACTER(LEN=MNH_LEN_HREC),INTENT(IN)  :: HREC     ! name of the article to write
CHARACTER(LEN=40),      INTENT(IN)  :: HFIELD   ! the string to write
INTEGER,                INTENT(OUT) :: KRESP    ! return-code if a problem appears
CHARACTER(LEN=100),     INTENT(IN)  :: HCOMMENT ! Comment string
!
!*      0.2   Declarations of local variables
!
LOGICAL              :: GCARTESIAN
TYPE(TFIELDMETADATA) :: TZFIELD
CHARACTER(LEN=5)     :: YMSG
!-------------------------------------------------------------------------------
!
CALL PRINT_MSG(NVERB_DEBUG,'IO','WRITE_SURFC0_MNH',TRIM(TFILE_SURFEX%CNAME)//': writing '//TRIM(HREC))
!
IF ( (CSTORAGE_TYPE=='PG' .OR. CSTORAGE_TYPE=='SU')  &
     .AND. HREC=='GRID_TYPE       '                  ) THEN
  IF (HFIELD(1:10)=='CONF PROJ ') THEN
    GCARTESIAN = .FALSE.
  ELSE IF (HFIELD(1:10)=='CARTESIAN ') THEN
    GCARTESIAN = .TRUE.
  END IF
  !
  CALL IO_Field_write(TFILE_SURFEX,'CARTESIAN',GCARTESIAN,KRESP)
  !
  IF (KRESP /=0) THEN
    WRITE ( YMSG, '( I5 )' ) KRESP
    CALL PRINT_MSG(NVERB_ERROR,'IO','WRITE_SURFC0_MNH','error when writing article '//TRIM(HREC)//' KRESP='//YMSG)
  END IF
  !
END IF
!
CALL PREPARE_METADATA_WRITE_SURF(HREC,'--',HCOMMENT,0,TYPECHAR,0,'WRITE_SURFC0_MNH',TZFIELD)
CALL IO_Field_write(TFILE_SURFEX,TZFIELD,HFIELD,KRESP)
!
IF (KRESP /=0) THEN
  WRITE ( YMSG, '( I5 )' ) KRESP
  CALL PRINT_MSG(NVERB_ERROR,'IO','WRITE_SURFC0_MNH','error when writing article '//TRIM(HREC)//' KRESP='//YMSG)
END IF
!-------------------------------------------------------------------------------
END SUBROUTINE WRITE_SURFC0_MNH
!
!     #############################################################
      SUBROUTINE WRITE_SURFL1_MNH(HREC,KL,OFIELD,KRESP,HCOMMENT,HDIR)
!     #############################################################
!
!!****  *WRITEL1* - routine to write a logical array
!!
!!    PURPOSE
!!    -------
!
!       The purpose of WRITEL1 is
!
!!**  METHOD
!!    ------
!!
!!    EXTERNAL
!!    --------
!!
!!
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------
!!
!!
!!    REFERENCE
!!    ---------
!!
!!
!!    AUTHOR
!!    ------
!!
!!      S.Malardel      *METEO-FRANCE*
!!
!!    MODIFICATIONS
!!    -------------
!!
!!      original                                                     01/08/03
!!  Philippe Wautelet: 05/2016-04/2018: new data structures and calls for I/O
!----------------------------------------------------------------------------
!
!*      0.    DECLARATIONS
!             ------------
!
USE MODD_CONF_n,         ONLY: CSTORAGE_TYPE
use modd_field,          only: tfieldmetadata, TYPEINT, TYPELOG
USE MODD_IO,             ONLY: TFILE_SURFEX
USE MODD_IO_SURF_MNH,    ONLY: NMASK, CMASK, &
                               NIU, NJU, NIB, NJB, NIE, NJE

use MODE_IO_FIELD_WRITE, only: IO_Field_write
USE MODE_MSG
USE MODE_WRITE_SURF_MNH_TOOLS

USE MODI_UNPACK_1D_2D

IMPLICIT NONE
!
!*      0.1   Declarations of arguments
!
CHARACTER(LEN=MNH_LEN_HREC),INTENT(IN)  :: HREC     ! name of the article to write
INTEGER,                INTENT(IN)  :: KL       ! number of points
LOGICAL, DIMENSION(KL), INTENT(IN)  :: OFIELD   ! array containing the data field
INTEGER,                INTENT(OUT) :: 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, DIMENSION(:,:), ALLOCATABLE :: GWORK  ! work array written in the file
INTEGER, DIMENSION(:,:), ALLOCATABLE :: IWORK  ! work array written in the file
!
CHARACTER(LEN=5)     :: YMSG
TYPE(TFIELDMETADATA) :: TZFIELD
!-------------------------------------------------------------------------------
!
CALL PRINT_MSG(NVERB_DEBUG,'IO','WRITE_SURFL1_MNH',TRIM(TFILE_SURFEX%CNAME)//': writing '//TRIM(HREC))
!
IF (HDIR=='-') THEN
  IF( (CMASK /= 'FULL  ').AND. (HREC=='COVER') ) THEN
    CALL PRINT_MSG(NVERB_DEBUG,'IO','WRITE_SURFL1_MNH',TRIM(HREC)//' with mask '// &
                   TRIM(CMASK)//' not written in file by externalized surface')
    RETURN
  ELSE
    CALL PREPARE_METADATA_WRITE_SURF(HREC,'--',HCOMMENT,0,TYPELOG,1,'WRITE_SURFL1_MNH',TZFIELD)
    CALL IO_Field_write(TFILE_SURFEX,TZFIELD,OFIELD(:),KRESP)
  END IF
!
ELSE IF (HDIR=='H') THEN
!
  ALLOCATE(GWORK(NIU,NJU))
  GWORK(:,:) = .FALSE.
!
  CALL UNPACK_1D_2D(NMASK,OFIELD,GWORK(NIB:NIE,NJB:NJE))
!
  ALLOCATE(IWORK(NIU,NJU))
  IWORK = 0
  WHERE(GWORK) IWORK = 1
!
  CALL PREPARE_METADATA_WRITE_SURF(HREC,'XY',HCOMMENT,4,TYPEINT,2,'WRITE_SURFL1_MNH',TZFIELD)
  CALL IO_Field_write(TFILE_SURFEX,TZFIELD,IWORK(:,:),KRESP)
  !
  DEALLOCATE(IWORK)
  DEALLOCATE(GWORK)
!
END IF
!
IF (KRESP /=0) THEN
  WRITE ( YMSG, '( I5 )' ) KRESP
  CALL PRINT_MSG(NVERB_ERROR,'IO','WRITE_SURFL1_MNH','error when writing article '//TRIM(HREC)//' KRESP='//YMSG)
END IF
!-------------------------------------------------------------------------------
END SUBROUTINE WRITE_SURFL1_MNH
!
!
!     #############################################################
      SUBROUTINE WRITE_SURFL0_MNH(HREC,OFIELD,KRESP,HCOMMENT)
!     #############################################################
!
!!****  *WRITEL1* - routine to write a logical
!!
!!    PURPOSE
!!    -------
!
!
!!**  METHOD
!!    ------
!!
!!    EXTERNAL
!!    --------
!!
!!
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------
!!
!!
!!    REFERENCE
!!    ---------
!!
!!
!!    AUTHOR
!!    ------
!!
!!      S.Malardel      *METEO-FRANCE*
!!
!!    MODIFICATIONS
!!    -------------
!!
!!      original                                                     01/08/03
!!  Philippe Wautelet: 05/2016-04/2018: new data structures and calls for I/O
!----------------------------------------------------------------------------
!
!*      0.    DECLARATIONS
!             ------------
!
USE MODD_CONF_n,         ONLY: CSTORAGE_TYPE
use modd_field,          only: tfieldmetadata, TYPELOG
USE MODD_IO,             ONLY: TFILE_SURFEX
USE MODD_IO_SURF_MNH,    ONLY: CMASK

use MODE_IO_FIELD_WRITE, only: IO_Field_write
USE MODE_MSG
USE MODE_WRITE_SURF_MNH_TOOLS

IMPLICIT NONE
!
!*      0.1   Declarations of arguments
!
CHARACTER(LEN=MNH_LEN_HREC),INTENT(IN)  :: HREC     ! name of the article to write
LOGICAL,                INTENT(IN)  :: OFIELD   ! array containing the data field
INTEGER,                INTENT(OUT) :: KRESP    ! return-code if a problem appears
CHARACTER(LEN=100),     INTENT(IN)  :: HCOMMENT ! Comment string
!
!*      0.2   Declarations of local variables
!
CHARACTER(LEN=4), PARAMETER :: YSUFFIX = '_SFX'

CHARACTER(LEN=5)     :: YMSG
TYPE(TFIELDMETADATA) :: TZFIELD
!
CALL PRINT_MSG(NVERB_DEBUG,'IO','WRITE_SURFL0_MNH',TRIM(TFILE_SURFEX%CNAME)//': writing '//TRIM(HREC))
!
IF( (CMASK /= 'FULL  ').AND. (HREC=='COVER') ) THEN
  CALL PRINT_MSG(NVERB_DEBUG,'IO','WRITE_SURFL0_MNH',TRIM(HREC)//' with mask '// &
                 TRIM(CMASK)//' not written in file by externalized surface')
  RETURN
ELSE
  ! Add a suffix to logical variables coming from SURFEX
  ! This is done because some variables can have the same name than MesoNH variables
  ! This suffix has been added in MesoNH 5.6.0
  CALL PREPARE_METADATA_WRITE_SURF(TRIM(HREC)//YSUFFIX,'--',HCOMMENT,0,TYPELOG,0,'WRITE_SURFL0_MNH',TZFIELD)
  CALL IO_Field_write(TFILE_SURFEX,TZFIELD,OFIELD,KRESP)
END IF
!
IF (KRESP /=0) THEN
  WRITE ( YMSG, '( I5 )' ) KRESP
  CALL PRINT_MSG(NVERB_ERROR,'IO','WRITE_SURFL0_MNH','error when writing article '//TRIM(HREC)//' KRESP='//YMSG)
END IF
!-------------------------------------------------------------------------------
END SUBROUTINE WRITE_SURFL0_MNH
!
!     #############################################################
      SUBROUTINE WRITE_SURFT0_MNH(HREC,KYEAR,KMONTH,KDAY,PTIME,KRESP,HCOMMENT)
!     #############################################################
!
!!****  *WRITET0* - routine to write a MESO-NH date_time scalar
!!
!!    PURPOSE
!!    -------
!
!       The purpose of WRITET0 is
!
!!**  METHOD
!!    ------
!!
!!    EXTERNAL
!!    --------
!!
!!
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------
!!
!!
!!    REFERENCE
!!    ---------
!!
!!
!!    AUTHOR
!!    ------
!!
!!      V. MASSON      *METEO-FRANCE*
!!
!!    MODIFICATIONS
!!    -------------
!!
!!      original                                                     18/08/97
!!  Philippe Wautelet: 05/2016-04/2018: new data structures and calls for I/O
!----------------------------------------------------------------------------
!
!*      0.    DECLARATIONS
!             ------------
!
USE MODD_CONF_n,         ONLY: CSTORAGE_TYPE
use modd_field,          only: tfieldmetadata, TYPEDATE
USE MODD_IO,             ONLY: TFILE_SURFEX
USE MODD_TYPE_DATE

use MODE_IO_FIELD_WRITE, only: IO_Field_write
USE MODE_IO_FILE
USE MODE_MSG
USE MODE_WRITE_SURF_MNH_TOOLS

IMPLICIT NONE
!
!*      0.1   Declarations of arguments
!
CHARACTER(LEN=MNH_LEN_HREC),  INTENT(IN)  :: HREC     ! name of the article to be written
INTEGER,            INTENT(IN)  :: KYEAR    ! year
INTEGER,            INTENT(IN)  :: KMONTH   ! month
INTEGER,            INTENT(IN)  :: KDAY     ! day
REAL,               INTENT(IN)  :: PTIME    ! time
INTEGER,            INTENT(OUT) :: KRESP    ! KRESP  : return-code if a problem appears
CHARACTER(LEN=100), INTENT(IN)  :: HCOMMENT ! Comment string

!*      0.2   Declarations of local variables
!
!
CHARACTER(LEN=MNH_LEN_HREC) :: YRECFM    ! Name of the article to be written
INTEGER, DIMENSION(3)   :: ITDATE
CHARACTER(LEN=5)        :: YMSG
TYPE (DATE_TIME)        :: TZDATA
TYPE(TFIELDMETADATA)    :: TZFIELD
!-------------------------------------------------------------------------------
!
CALL PRINT_MSG(NVERB_DEBUG,'IO','WRITE_SURFT0_MNH',TRIM(TFILE_SURFEX%CNAME)//': writing '//TRIM(HREC))
!
IF( HREC=='DTCUR' .AND. CSTORAGE_TYPE/='SU' ) THEN
  CALL PRINT_MSG(NVERB_DEBUG,'IO','WRITE_SURFT0_MNH',TRIM(HREC)//' not written in file by externalized surface')
  RETURN
ELSE
  TZDATA%nyear  = kyear
  TZDATA%nmonth = kmonth
  TZDATA%nday   = kday
  TZDATA%xtime  = PTIME
  !  
  CALL PREPARE_METADATA_WRITE_SURF(HREC,'--',HCOMMENT,0,TYPEDATE,0,'WRITE_SURFT0_MNH',TZFIELD)
  CALL IO_Field_write(TFILE_SURFEX,TZFIELD,TZDATA,KRESP)
END IF
!
IF (KRESP /=0) THEN
  WRITE ( YMSG, '( I5 )' ) KRESP
  CALL PRINT_MSG(NVERB_ERROR,'IO','WRITE_SURFT0_MNH','error when writing article '//TRIM(HREC)//' KRESP='//YMSG)
END IF
!
END SUBROUTINE WRITE_SURFT0_MNH
!
!     #############################################################
      SUBROUTINE WRITE_SURFT1_MNH(HREC,KL1,KYEAR,KMONTH,KDAY,PTIME,KRESP,HCOMMENT)
!     #############################################################
!
!!****  * - routine to write a date vector
!!
!!    PURPOSE
!!    -------
!
!
!!**  METHOD
!!    ------
!!
!!    EXTERNAL
!!    --------
!!
!!
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------
!!
!!
!!    REFERENCE
!!    ---------
!!
!!
!!    AUTHOR
!!    ------
!!
!!      G.TANGUY      *METEO-FRANCE*
!!
!!    MODIFICATIONS
!!    -------------
!!
!!      original                                                     03/03/09
!!  Philippe Wautelet: 05/2016-04/2018: new data structures and calls for I/O
!----------------------------------------------------------------------------
!
!*      0.    DECLARATIONS
!             ------------
!
use modd_field,          only: tfieldmetadata, TYPEINT, TYPEREAL
USE MODD_IO,             ONLY: TFILE_SURFEX
USE MODD_CONF_n,         ONLY: CSTORAGE_TYPE

use MODE_IO_FIELD_WRITE, only: IO_Field_write
USE MODE_IO_FILE
USE MODE_MSG

IMPLICIT NONE
!
!*      0.1   Declarations of arguments
!
CHARACTER(LEN=MNH_LEN_HREC),  INTENT(IN) :: HREC     ! name of the article to be written
INTEGER,            INTENT(IN) :: KL1       ! number of points
INTEGER, DIMENSION(KL1), INTENT(IN)  :: KYEAR    ! year
INTEGER, DIMENSION(KL1), INTENT(IN)  :: KMONTH   ! month
INTEGER, DIMENSION(KL1), INTENT(IN)  :: KDAY     ! day
REAL,    DIMENSION(KL1), INTENT(IN)  :: PTIME    ! time
INTEGER,            INTENT(OUT) :: KRESP    ! KRESP  : return-code if a problem appears
CHARACTER(LEN=100), INTENT(IN)  :: HCOMMENT ! Comment string

!*      0.2   Declarations of local variables
!
!
CHARACTER(LEN=5)          :: YMSG
INTEGER, DIMENSION(3,KL1) :: ITDATE
TYPE(TFIELDMETADATA)      :: TZFIELD
!-------------------------------------------------------------------------------
!
CALL PRINT_MSG(NVERB_DEBUG,'IO','WRITE_SURFT1_MNH',TRIM(TFILE_SURFEX%CNAME)//': writing '//TRIM(HREC))
!
IF( HREC=='DTCUR' .AND. CSTORAGE_TYPE/='SU' ) THEN
  CALL PRINT_MSG(NVERB_DEBUG,'IO','WRITE_SURFT1_MNH',TRIM(HREC)//' not written in file by externalized surface')
  RETURN
ELSE
  !
  ITDATE(1,:) = KYEAR  (:)
  ITDATE(2,:) = KMONTH (:)
  ITDATE(3,:) = KDAY   (:)
  !
  TZFIELD = TFIELDMETADATA(            &
    CMNHNAME   = TRIM(HREC)//'%TDATE', &
    CSTDNAME   = '',                   &
    CLONGNAME  = TRIM(HREC)//'%TDATE', &
    CUNITS     = '',                   &
    CDIR       = '--',                 &
    CCOMMENT   = TRIM(HCOMMENT),       &
    NGRID      = 0,                    &
    NTYPE      = TYPEINT,              &
    NDIMS      = 2,                    &
    LTIMEDEP   = .FALSE.               )
  !
  CALL IO_Field_write(TFILE_SURFEX,TZFIELD,ITDATE(:,:),KRESP)
  !
  IF (KRESP /=0) THEN
    WRITE ( YMSG, '( I5 )' ) KRESP
    CALL PRINT_MSG(NVERB_ERROR,'IO','WRITE_SURFT1_MNH','error when writing article '//TRIM(HREC)//' KRESP='//YMSG)
  END IF
  !
  TZFIELD = TFIELDMETADATA(            &
    CMNHNAME   = TRIM(HREC)//'%xtime', &
    CSTDNAME   = '',                   &
    CLONGNAME  = TRIM(HREC)//'%xtime', &
    CUNITS     = '',                   &
    CDIR       = '--',                 &
    CCOMMENT   = TRIM(HCOMMENT),       &
    NGRID      = 0,                    &
    NTYPE      = TYPEREAL,             &
    NDIMS      = 1,                    &
    LTIMEDEP   = .FALSE.               )
  !
  CALL IO_Field_write(TFILE_SURFEX,TZFIELD,PTIME(:),KRESP)
!
  IF (KRESP /=0) THEN
    WRITE ( YMSG, '( I5 )' ) KRESP
    CALL PRINT_MSG(NVERB_ERROR,'IO','WRITE_SURFT1_MNH','error when writing article '//TRIM(HREC)//' KRESP='//YMSG)
  END IF
!
END IF
!
END SUBROUTINE WRITE_SURFT1_MNH