write_tfield_1d_patch.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.
SUBROUTINE write_tfield_1d_patch(HSELECT,HPROGRAM,HRECFM,HCOMMENT,KP,KMASK,TFIELD_IN,KSIZE,TPDATE_WR)
!
USE modd_type_date_surf
!
USE modd_write_surf_atm, ONLY : lsplit_patch
!
USE modd_surf_par, ONLY : xundef, nundef
!
USE modi_unpack_same_rank
USE modi_write_surf
!
IMPLICIT NONE
!
 CHARACTER(LEN=*), DIMENSION(:), INTENT(IN) :: HSELECT
 CHARACTER(LEN=*), INTENT(IN) :: HPROGRAM
 CHARACTER(LEN=*), INTENT(IN) :: HRECFM
 CHARACTER(LEN=*), INTENT(IN) :: HCOMMENT
INTEGER, INTENT(IN) :: KP
INTEGER, DIMENSION(:), INTENT(IN) :: KMASK
TYPE(date_time), DIMENSION(:), INTENT(IN) :: TFIELD_IN
TYPE(date_time), DIMENSION(:,:), INTENT(INOUT) :: TPDATE_WR
INTEGER, INTENT(IN) :: KSIZE
!
INTEGER, DIMENSION(SIZE(TFIELD_IN)) :: ZINT1
INTEGER, DIMENSION(KSIZE) :: ZINT2
REAL, DIMENSION(SIZE(TFIELD_IN)) :: ZINT1R
REAL, DIMENSION(KSIZE) :: ZINT2R
TYPE(date_time), DIMENSION(KSIZE) :: TZWORK
!
 CHARACTER(LEN=12) :: YRECFM
 CHARACTER(LEN=2) :: YPAT
INTEGER :: IRESP
!
yrecfm=adjustl(hrecfm(:len_trim(hrecfm)))
IF (lsplit_patch) THEN
  IF (kp/=0) THEN
    WRITE(ypat,'(I2)') kp
    yrecfm=adjustl(hrecfm(:len_trim(hrecfm)))//'P'//adjustl(ypat(:len_trim(ypat)))
  ENDIF
ENDIF
!
zint1 = tfield_in(:)%TDATE%YEAR
 CALL unpack_same_rank(kmask,zint1,zint2,nundef)
tzwork(:)%TDATE%YEAR = zint2
zint1 = tfield_in(:)%TDATE%MONTH 
 CALL unpack_same_rank(kmask,zint1,zint2,nundef)
tzwork(:)%TDATE%MONTH = zint2 
zint1 = tfield_in(:)%TDATE%DAY
 CALL unpack_same_rank(kmask,zint1,zint2,nundef)
tzwork(:)%TDATE%DAY = zint2 
zint1r = tfield_in(:)%TIME
 CALL unpack_same_rank(kmask,zint1r,zint2r,xundef)
tzwork(:)%TIME = zint2r
!
IF (lsplit_patch) THEN
  CALL write_surf(hselect,hprogram,yrecfm,tzwork,iresp,hcomment=hcomment)
ELSE
  IF (kp/=0) THEN
    tpdate_wr(:,kp)%TDATE%YEAR  = tzwork(:)%TDATE%YEAR
    tpdate_wr(:,kp)%TDATE%MONTH = tzwork(:)%TDATE%MONTH
    tpdate_wr(:,kp)%TDATE%DAY   = tzwork(:)%TDATE%DAY
    tpdate_wr(:,kp)%TIME        = tzwork(:)%TIME
    IF ( kp==SIZE(tpdate_wr,2) ) THEN
      CALL write_surf(hselect,hprogram,yrecfm,tpdate_wr,iresp,hcomment=hcomment)
   ENDIF
  ELSE
    CALL write_surf(hselect,hprogram,yrecfm,tzwork,iresp,hcomment=hcomment)
  ENDIF
ENDIF
!
END SUBROUTINE write_tfield_1d_patch