write_field_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_field_1d_patch(HSELECT,HPROGRAM,HRECFM,HCOMMENT,KP,KMASK,PFIELD_IN,KSIZE,PWORK_WR)
!
USE modd_write_surf_atm, ONLY : lsplit_patch
!
USE modd_surf_par, ONLY : xundef
!
USE modi_unpack_same_rank
USE modi_write_surf
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
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
REAL, DIMENSION(:), INTENT(IN) :: PFIELD_IN
INTEGER, INTENT(IN) :: KSIZE
REAL, DIMENSION(:,:), OPTIONAL, INTENT(INOUT) :: PWORK_WR
!
REAL, DIMENSION(KSIZE,1) :: ZWORK
 CHARACTER(LEN=12) :: YRECFM
 CHARACTER(LEN=2) :: YPAT
INTEGER :: IRESP
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!
IF (lhook) CALL dr_hook('WRITE_FIELD_1D_PATCH',0,zhook_handle)
!
yrecfm=adjustl(hrecfm(:len_trim(hrecfm)))
 CALL unpack_same_rank(kmask,pfield_in,zwork(:,1),xundef)
!
IF (lsplit_patch) THEN
  !
  IF (kp/=0) THEN
    WRITE(ypat,'(I2)') kp
    yrecfm=adjustl(yrecfm(:len_trim(yrecfm)))//'P'//adjustl(ypat(:len_trim(ypat)))
  ENDIF
  CALL write_surf(hselect,hprogram,yrecfm,zwork(:,1),iresp,hcomment=hcomment)
  !
ELSE
  !
  IF (kp/=0) THEN
    pwork_wr(:,kp) = zwork(:,1)
    IF ( kp==SIZE(pwork_wr,2) ) THEN
      CALL write_surf(hselect,hprogram,yrecfm,pwork_wr,iresp,hcomment=hcomment)
   ENDIF
  ELSE
    CALL write_surf(hselect,hprogram,yrecfm,zwork(:,:),iresp,hcomment=hcomment)
  ENDIF
  !
ENDIF
!
IF (lhook) CALL dr_hook('WRITE_FIELD_1D_PATCH',1,zhook_handle)
!
END SUBROUTINE write_field_1d_patch