write_diag_pgd_isban.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_diag_pgd_isba_n (DTCO, HSELECT, U, CHI, NCHI, OSURF_DIAG_ALBEDO, &
                                        IO, S, K, NP, NPE, ISS, HPROGRAM)
!     #########################################
!
!!****  *WRITE_DIAG_PGD_ISBA_n* - writes the ISBA physiographic diagnostic fields
!!
!!    PURPOSE
!!    -------
!!
!!**  METHOD
!!    ------
!!
!!    EXTERNAL
!!    --------
!!
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------
!!
!!    REFERENCE
!!    ---------
!!
!!
!!    AUTHOR
!!    ------
!!      V. Masson   *Meteo France*
!!
!!    MODIFICATIONS
!!    -------------
!!      Original    01/2004 
!!      Modified    10/2004 by P. Le Moigne: add XZ0REL, XVEGTYPE_PATCH
!!      Modified    11/2005 by P. Le Moigne: limit length of VEGTYPE_PATCH field names
!!      Modified    11/2013 by B. Decharme : XPATCH now in writesurf_isban.F90
!!      Modified    10/2014 by P. Samuelsson: MEB variables
!!      Modified    06/2014 by B. Decharme : add XVEGTYPE
!-------------------------------------------------------------------------------
!
!*       0.    DECLARATIONS
!              ------------
!
USE modd_type_date_surf
!
USE modd_data_cover_n, ONLY : data_cover_t
USE modd_sso_n, ONLY : sso_t
USE modd_surf_atm_n, ONLY : surf_atm_t
USE modd_ch_isba_n, ONLY : ch_isba_t, ch_isba_np_t
USE modd_isba_options_n, ONLY : isba_options_t
USE modd_isba_n, ONLY : isba_s_t, isba_k_t, isba_np_t, isba_npe_t, isba_p_t, isba_pe_t
!
USE modd_surf_par,   ONLY : xundef, nundef
USE modd_agri,       ONLY : lagrip
!
!
USE modd_io_surf_fa, ONLY : lfanocompact, lprep
!
USE modi_init_io_surf_n
USE modi_write_surf
USE modi_end_io_surf_n
USE modi_write_field_1d_patch
USE modi_write_tfield_1d_patch
USE modi_unpack_same_rank
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
!*       0.1   Declarations of arguments
!              -------------------------
!
!
TYPE(data_cover_t), INTENT(INOUT) :: DTCO
 CHARACTER(LEN=*), DIMENSION(:), INTENT(IN) :: HSELECT
TYPE(surf_atm_t), INTENT(INOUT) :: U
TYPE(ch_isba_t), INTENT(INOUT) :: CHI
TYPE(ch_isba_np_t), INTENT(INOUT) :: NCHI
LOGICAL, INTENT(IN) :: OSURF_DIAG_ALBEDO
TYPE(isba_options_t), INTENT(INOUT) :: IO
TYPE(isba_s_t), INTENT(INOUT) :: S
TYPE(isba_k_t), INTENT(INOUT) :: K
TYPE(isba_np_t), INTENT(INOUT) :: NP
TYPE(isba_npe_t), INTENT(INOUT) :: NPE
TYPE(sso_t), INTENT(INOUT) :: ISS
!
 CHARACTER(LEN=6),  INTENT(IN)  :: HPROGRAM ! program calling
!
!*       0.2   Declarations of local variables
!              -------------------------------
!
TYPE(isba_p_t), POINTER :: PK
TYPE(isba_pe_t), POINTER :: PEK
!
REAL, DIMENSION(U%NSIZE_NATURE,IO%NPATCH) :: ZWORK
!
REAL, DIMENSION(:), ALLOCATABLE :: ZWORK1
REAL, DIMENSION(:,:), ALLOCATABLE :: ZWORK2
!
REAL, DIMENSION(U%NSIZE_NATURE,SIZE(NP%AL(1)%XDG,2)) :: ZDG   ! Work array
REAL, DIMENSION(U%NSIZE_NATURE) :: ZDG2
REAL, DIMENSION(U%NSIZE_NATURE) :: ZDTOT
!
INTEGER           :: IRESP          ! IRESP  : return-code if a problem appears
 CHARACTER(LEN=12) :: YRECFM         ! Name of the article to be read
 CHARACTER(LEN=100):: YCOMMENT       ! Comment string
 CHARACTER(LEN=2)  :: YLVLV, YPAS
 CHARACTER(LEN=4)  :: YLVL
 CHARACTER(LEN=2) :: YPAT
!
INTEGER         :: JI, JL, JP, ILAYER, ILU, IMASK
INTEGER           :: ISIZE_LMEB_PATCH   ! Number of patches where multi-energy balance should be applied
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!-------------------------------------------------------------------------------
!
!         Initialisation for IO
!
IF (lhook) CALL dr_hook('WRITE_DIAG_PGD_ISBA_N',0,zhook_handle)
!
ilu = u%NSIZE_NATURE
!
isize_lmeb_patch=count(io%LMEB_PATCH(:))
!
 CALL init_io_surf_n(dtco, u, hprogram,'NATURE','ISBA  ','WRITE','ISBA_VEG_EVOLUTION.OUT.nc')
!
!-------------------------------------------------------------------------------
!
!* Leaf Area Index
!
IF (io%CPHOTO=='NON' .OR. io%CPHOTO=='AST') THEN
  !
  yrecfm='LAI'
  ycomment='leaf area index (-)'
  !
  DO jp = 1,io%NPATCH
    CALL  write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,jp,&
                np%AL(jp)%NR_P,npe%AL(jp)%XLAI(:),ilu,s%XWORK_WR)
  ENDDO  
  !
ENDIF
!
!-------------------------------------------------------------------------------
!
!* Vegetation fraction
!
yrecfm='VEG'
ycomment='vegetation fraction (-)'
!
DO jp = 1,io%NPATCH
  CALL  write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,jp,&
              np%AL(jp)%NR_P,npe%AL(jp)%XVEG(:),ilu,s%XWORK_WR)
ENDDO  
!
!* Surface roughness length (without snow)
!
yrecfm='Z0VEG'
ycomment='surface roughness length (without snow) (m)'
!
DO jp = 1,io%NPATCH
  CALL  write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,jp,&
              np%AL(jp)%NR_P,npe%AL(jp)%XZ0(:),ilu,s%XWORK_WR)
ENDDO
!
IF (isize_lmeb_patch>0) THEN
  !
  yrecfm='GNDLITTER'
  ycomment='MEB: ground litter fraction (-)'
  !
DO jp = 1,io%NPATCH
  CALL  write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,jp,&
              np%AL(jp)%NR_P,npe%AL(jp)%XGNDLITTER(:),ilu,s%XWORK_WR)
ENDDO    
  !
  yrecfm='Z0LITTER'
  ycomment='MEB: ground litter roughness length (without snow) (m)'
  !
DO jp = 1,io%NPATCH
  CALL  write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,jp,&
              np%AL(jp)%NR_P,npe%AL(jp)%XZ0LITTER(:),ilu,s%XWORK_WR)
ENDDO    
  !
ENDIF
!
!-------------------------------------------------------------------------------
!
!* Soil depth for each patch
!
DO jl=1,SIZE(np%AL(1)%XDG,2)
  IF (jl<10) THEN
    WRITE(yrecfm,fmt='(A2,I1)') 'DG',jl
  ELSE
    WRITE(yrecfm,fmt='(A2,I2)') 'DG',jl          
  ENDIF
  ycomment='soil depth'//' (M)'
DO jp = 1,io%NPATCH
  CALL  write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,jp,&
              np%AL(jp)%NR_P,np%AL(jp)%XDG(:,jl),ilu,s%XWORK_WR)
ENDDO    
END DO
!
!* Averaged Soil depth
!
IF(io%NPATCH>1)THEN
!        
  zdg(:,:)=0.0
  DO jp=1,io%NPATCH
    pk => np%AL(jp)
    DO jl=1,SIZE(pk%XDG,2)
      DO ji=1, pk%NSIZE_P
        imask = pk%NR_P(ji)
        zdg(imask,jl) = zdg(imask,jl) + pk%XPATCH(ji)*pk%XDG(ji,jl)
      ENDDO
    ENDDO
  ENDDO
!
  DO jl=1,SIZE(np%AL(1)%XDG,2)
    WRITE(ylvl,'(I4)')jl
    yrecfm='DG'//adjustl(ylvl(:len_trim(ylvl)))
    yrecfm=yrecfm(:len_trim(yrecfm))//'_ISBA'
    ycomment='averaged soil depth layer '//adjustl(ylvl(:len_trim(ylvl)))//' (m)'   
    CALL write_surf(hselect,hprogram,yrecfm,zdg(:,jl),iresp,hcomment=ycomment)
  END DO
!        
ENDIF
!
!-------------------------------------------------------------------------------
!
IF(io%CISBA=='DIF')THEN
  !
  ALLOCATE(zwork2(ilu,io%NPATCH))
  !
  zdg2(:)=0.0
  zdtot(:)=0.0
  zwork2(:,:)=xundef
  DO jp=1,io%NPATCH
    pk => np%AL(jp)
     DO ji=1,pk%NSIZE_P
       imask = pk%NR_P(ji)
       zdg2(imask) = zdg2(imask) + pk%XPATCH(ji) * pk%XDG2(ji)
        jl = pk%NWG_LAYER(ji)
        IF(jl/=nundef)THEN
          zwork2(ji,jp) = pk%XDG(ji,jl)
          zdtot(imask) = zdtot(imask) + pk%XPATCH(ji) * pk%XDG(ji,jl)
        ENDIF
     ENDDO
  ENDDO
  !
  !* Root depth
  !
  yrecfm='DROOT_DIF'
  ycomment='Root depth in ISBA-DIF'
  DO jp = 1,io%NPATCH
    CALL  write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,jp,&
                np%AL(jp)%NR_P,np%AL(jp)%XDROOT(:),ilu,s%XWORK_WR)
  ENDDO    
  !
  yrecfm='DG2_DIF'
  ycomment='DG2 depth in ISBA-DIF'
  DO jp = 1,io%NPATCH
    CALL  write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,jp,&
              np%AL(jp)%NR_P,np%AL(jp)%XDG2(:),ilu,s%XWORK_WR)
  ENDDO    
  !  
  IF(io%NPATCH>1)THEN
    yrecfm='DG2_DIF_ISBA'
    ycomment='Averaged DG2 depth in ISBA-DIF'  
    CALL write_surf(hselect,hprogram,yrecfm,zdg2(:),iresp,hcomment=ycomment)          
  ENDIF  
  !
  !* Runoff depth
  !
  yrecfm='RUNOFFD'
  ycomment='Runoff deph in ISBA-DIF'
  DO jp = 1,io%NPATCH
    CALL  write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,jp,&
                np%AL(jp)%NR_P,np%AL(jp)%XRUNOFFD(:),ilu,s%XWORK_WR)
  ENDDO    
  !
  !* Total soil depth for mositure
  !
  yrecfm='DTOT_DIF'
  ycomment='Total soil depth for moisture in ISBA-DIF'
  DO jp = 1,io%NPATCH
    pk => np%AL(jp)
    CALL  write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,jp,&
                np%AL(jp)%NR_P,zwork2(1:pk%NSIZE_P,jp),ilu,s%XWORK_WR)
  ENDDO    
  DEALLOCATE(zwork2)
  !
  IF(io%NPATCH>1)THEN
    yrecfm='DTOTDF_ISBA'
    ycomment='Averaged Total soil depth for moisture in ISBA-DIF'   
    CALL write_surf(hselect,hprogram,yrecfm,zdtot(:),iresp,hcomment=ycomment)          
  ENDIF
  !
  !* Root fraction for each patch
  !
  ALLOCATE(zwork1(ilu))
  DO jp = 1,io%NPATCH
    pk => np%AL(jp)
    DO jl=1,SIZE(pk%XROOTFRAC,2)
      IF (jl<10) THEN
        WRITE(yrecfm,fmt='(A8,I1)') 'ROOTFRAC',jl
      ELSE
        WRITE(yrecfm,fmt='(A8,I2)') 'ROOTFRAC',jl          
      ENDIF  
      ycomment='root fraction by layer (-)'
      zwork1(:)=xundef
      DO ji=1,SIZE(pk%XDG,1)
        IF(jl<=pk%NWG_LAYER(ji).AND.pk%NWG_LAYER(ji)/=nundef) THEN
          zwork1(ji) = pk%XROOTFRAC(ji,jl)
        ENDIF
      ENDDO
      CALL  write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,jp,&
              np%AL(jp)%NR_P,zwork1(1:pk%NSIZE_P),ilu,s%XWORK_WR)
    ENDDO
  END DO
  DEALLOCATE(zwork1)
  !
  !* SOC fraction for each layer
  !
  IF(io%LSOC)THEN
    DO jl=1,SIZE(np%AL(1)%XDG,2)
     IF (jl<10) THEN
       WRITE(yrecfm,fmt='(A7,I1)') 'FRACSOC',jl
     ELSE
       WRITE(yrecfm,fmt='(A7,I2)') 'FRACSOC',jl          
     ENDIF  
     ycomment='SOC fraction by layer (-)'
     CALL write_surf(hselect,hprogram,yrecfm,s%XFRACSOC(:,jl),iresp,hcomment=ycomment)
    ENDDO
  ENDIF
!
ENDIF        
!
!-------------------------------------------------------------------------------
!
DO jl=1,SIZE(np%AL(1)%XDG,2)
  IF (jl<10) THEN
    WRITE(yrecfm,fmt='(A4,I1)') 'WSAT',jl
  ELSE
    WRITE(yrecfm,fmt='(A4,I2)') 'WSAT',jl          
  ENDIF  
  ycomment='soil porosity by layer (m3/m3)'  
  CALL write_surf(hselect, &
                  hprogram,yrecfm,k%XWSAT(:,jl),iresp,hcomment=ycomment)
ENDDO
!
DO jl=1,SIZE(np%AL(1)%XDG,2)
  IF (jl<10) THEN
    WRITE(yrecfm,fmt='(A3,I1)') 'WFC',jl
  ELSE
    WRITE(yrecfm,fmt='(A3,I2)') 'WFC',jl          
  ENDIF  
  ycomment='field capacity by layer (m3/m3)'
  CALL write_surf(hselect,hprogram,yrecfm,k%XWFC(:,jl),iresp,hcomment=ycomment)
ENDDO
!
DO jl=1,SIZE(np%AL(1)%XDG,2)
  IF (jl<10) THEN
    WRITE(yrecfm,fmt='(A5,I1)') 'WWILT',jl
  ELSE
    WRITE(yrecfm,fmt='(A5,I2)') 'WWILT',jl          
  ENDIF  
  ycomment='wilting point by layer (m3/m3)'
  CALL write_surf(hselect,hprogram,yrecfm,k%XWWILT(:,jl),iresp,hcomment=ycomment)
ENDDO     
!
!-------------------------------------------------------------------------------
! For Earth System Model
IF(lfanocompact.AND..NOT.lprep)THEN
  CALL end_io_surf_n(hprogram)
  IF (lhook) CALL dr_hook('WRITE_DIAG_PGD_ISBA_N',1,zhook_handle)
  RETURN
ENDIF
!
!-------------------------------------------------------------------------------
!
yrecfm='Z0REL'
ycomment='orography roughness length (M)'
!
 CALL write_surf(hselect,hprogram,yrecfm,iss%XZ0REL(:),iresp,hcomment=ycomment)
!
!-------------------------------------------------------------------------------
!
!* Runoff soil ice depth for each patch
!
IF(io%CHORT=='SGH'.AND.io%CISBA/='DIF')THEN
  yrecfm='DICE'
  ycomment='soil ice depth for runoff (m)'
  DO jp = 1,io%NPATCH
    CALL  write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,jp,&
                np%AL(jp)%NR_P,np%AL(jp)%XD_ICE(:),ilu,s%XWORK_WR)
  ENDDO    
ENDIF
!
!-------------------------------------------------------------------------------
!
!* Fraction of each vegetation type in the grid cell
!
DO jl=1,SIZE(s%XVEGTYPE_PATCH,2)
  WRITE(ypas,'(I2)') jl 
  ylvlv=adjustl(ypas(:len_trim(ypas)))
  WRITE(yrecfm,fmt='(A9)') 'VEGTYPE'//ylvlv
  ycomment='fraction of each vegetation type in the grid cell'//' (-)'
  CALL write_surf(hselect,hprogram,yrecfm,s%XVEGTYPE(:,jl),iresp,hcomment=ycomment)
END DO
!-------------------------------------------------------------------------------
!
!* Fraction of each vegetation type for each patch
!
IF(io%NPATCH>1.AND.SIZE(s%XVEGTYPE_PATCH,2)/=SIZE(s%XVEGTYPE_PATCH,3))THEN
!
  DO jl=1,SIZE(s%XVEGTYPE_PATCH,2)
    WRITE(ypas,'(I2)') jl 
    ylvlv=adjustl(ypas(:len_trim(ypas)))
    WRITE(yrecfm,fmt='(A9)') 'VEGTY_'//ylvlv
    ycomment='fraction of each vegetation type in each patch'//' (-)'
    DO jp = 1,io%NPATCH
      CALL  write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,jp,&
                  np%AL(jp)%NR_P,np%AL(jp)%XVEGTYPE_PATCH(:,jl),ilu,s%XWORK_WR)
    ENDDO      
  END DO
!
ENDIF
!
!-------------------------------------------------------------------------------
!
!* other surface parameters
!
yrecfm='RSMIN'
ycomment='minimum stomatal resistance (sm-1)'
DO jp = 1,io%NPATCH
  CALL  write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,jp,&
              np%AL(jp)%NR_P,npe%AL(jp)%XRSMIN(:),ilu,s%XWORK_WR)
ENDDO
!
yrecfm='GAMMA'
ycomment='coefficient for RSMIN calculation (-)'
DO jp = 1,io%NPATCH
  CALL  write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,jp,&
              np%AL(jp)%NR_P,npe%AL(jp)%XGAMMA(:),ilu,s%XWORK_WR)
ENDDO
!
yrecfm='CV'
ycomment='vegetation thermal inertia coefficient (-)'
DO jp = 1,io%NPATCH
  CALL  write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,jp,&
              np%AL(jp)%NR_P,npe%AL(jp)%XCV(:),ilu,s%XWORK_WR)
ENDDO
!
yrecfm='RGL'
ycomment='maximum solar radiation usable in photosynthesis (-)'
DO jp = 1,io%NPATCH
  CALL  write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,jp,&
              np%AL(jp)%NR_P,npe%AL(jp)%XRGL(:),ilu,s%XWORK_WR)
ENDDO
!
yrecfm='EMIS_ISBA'
ycomment='surface emissivity (-)'
DO jp = 1,io%NPATCH
  CALL  write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,jp,&
              np%AL(jp)%NR_P,npe%AL(jp)%XEMIS(:),ilu,s%XWORK_WR)
ENDDO
!
yrecfm='WRMAX_CF'
ycomment='coefficient for maximum water interception (-)'
DO jp = 1,io%NPATCH
  CALL  write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,jp,&
              np%AL(jp)%NR_P,npe%AL(jp)%XWRMAX_CF(:),ilu,s%XWORK_WR)
ENDDO
!
IF (isize_lmeb_patch>0) THEN
  !
  yrecfm='H_VEG'
  ycomment='MEB: height of vegetation (m)'
  DO jp = 1,io%NPATCH
    CALL  write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,jp,&
                np%AL(jp)%NR_P,npe%AL(jp)%XH_VEG(:),ilu,s%XWORK_WR)
  ENDDO
  !
ENDIF
!
!-------------------------------------------------------------------------------
!
IF (osurf_diag_albedo) THEN
!
!* Soil albedos
!
!
  yrecfm='ALBNIR_S'
  ycomment='soil near-infra-red albedo (-)'
  DO jp=1,io%NPATCH
    CALL unpack_same_rank(np%AL(jp)%NR_P, npe%AL(jp)%XALBNIR_SOIL, zwork(:,jp))
    WHERE (zwork(:,jp)/=xundef) zwork(:,1) = zwork(:,jp)
  ENDDO
  CALL write_surf(hselect,hprogram,yrecfm,zwork(:,1),iresp,hcomment=ycomment)
!
!-------------------------------------------------------------------------------
!
  yrecfm='ALBVIS_S'
  ycomment='soil visible albedo (-)'
  DO jp=1,io%NPATCH
    CALL unpack_same_rank(np%AL(jp)%NR_P, npe%AL(jp)%XALBVIS_SOIL, zwork(:,jp))
    WHERE (zwork(:,jp)/=xundef) zwork(:,1) = zwork(:,jp)
  ENDDO
  CALL write_surf(hselect,hprogram,yrecfm,zwork(:,1),iresp,hcomment=ycomment)  
!
!-------------------------------------------------------------------------------
!
  yrecfm='ALBUV_S'
  ycomment='soil UV albedo (-)'
  DO jp=1,io%NPATCH
    CALL unpack_same_rank(np%AL(jp)%NR_P, npe%AL(jp)%XALBUV_SOIL, zwork(:,jp))
    WHERE (zwork(:,jp)/=xundef) zwork(:,1) = zwork(:,jp)
  ENDDO
  CALL write_surf(hselect,hprogram,yrecfm,zwork(:,1),iresp,hcomment=ycomment)
!
!-------------------------------------------------------------------------------
!
!* albedos
!
  yrecfm='ALBNIR'
  ycomment='total near-infra-red albedo (-)'
  DO jp = 1,io%NPATCH
    CALL  write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,jp,&
                np%AL(jp)%NR_P,npe%AL(jp)%XALBNIR(:),ilu,s%XWORK_WR)
  ENDDO
!
!-------------------------------------------------------------------------------
!
  yrecfm='ALBVIS'
  ycomment='total visible albedo (-)'
  DO jp = 1,io%NPATCH
    CALL  write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,jp,&
                np%AL(jp)%NR_P,npe%AL(jp)%XALBVIS(:),ilu,s%XWORK_WR)
  ENDDO
!
!-------------------------------------------------------------------------------
!
  yrecfm='ALBUV'
  ycomment='total UV albedo (-)'
  DO jp = 1,io%NPATCH
    CALL  write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,jp,&
                np%AL(jp)%NR_P,npe%AL(jp)%XALBUV(:),ilu,s%XWORK_WR)
  ENDDO
!
END IF
!
!-------------------------------------------------------------------------------
!
!* chemical soil resistances
!
IF (chi%CCH_DRY_DEP=='WES89' .AND. chi%SVI%NBEQ>0) THEN
  yrecfm='SOILRC_SO2'
  ycomment='bare soil resistance for SO2 (?)'
  DO jp = 1,io%NPATCH
    CALL  write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,jp,&
                np%AL(jp)%NR_P,nchi%AL(jp)%XSOILRC_SO2(:),ilu,s%XWORK_WR)
  ENDDO  
  !
  yrecfm='SOILRC_O3'
  ycomment='bare soil resistance for O3 (?)'
  DO jp = 1,io%NPATCH
    CALL  write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,jp,&
                np%AL(jp)%NR_P,nchi%AL(jp)%XSOILRC_O3(:),ilu,s%XWORK_WR)
  ENDDO   
END IF
!
!-------------------------------------------------------------------------------
!
IF (lagrip .AND. (io%CPHOTO=='NIT' .OR. io%CPHOTO=='NCB') ) THEN
!
!* seeding and reaping
!
  yrecfm='TSEED'
  ycomment='date of seeding (-)'
  !
  DO jp = 1,io%NPATCH
    CALL  write_tfield_1d_patch(hselect,hprogram,yrecfm,ycomment,jp,&
                np%AL(jp)%NR_P,npe%AL(jp)%TSEED(:),ilu,s%TDATE_WR)
  ENDDO
!
  yrecfm='TREAP'
  ycomment='date of reaping (-)'
!
  DO jp = 1,io%NPATCH
    CALL  write_tfield_1d_patch(hselect,hprogram,yrecfm,ycomment,jp,&
                np%AL(jp)%NR_P,npe%AL(jp)%TREAP(:),ilu,s%TDATE_WR)
  ENDDO
!
!-------------------------------------------------------------------------------
!
!* irrigated fraction
!
  yrecfm='IRRIG'
  ycomment='flag for irrigation (irrigation if >0.) (-)'
!
  DO jp = 1,io%NPATCH
    CALL  write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,jp,&
                np%AL(jp)%NR_P,npe%AL(jp)%XIRRIG(:),ilu,s%XWORK_WR)
  ENDDO
!
!-------------------------------------------------------------------------------
!
!* water supply for irrigation
!
  yrecfm='WATSUP'
  ycomment='water supply during irrigation process (mm)'
!
  DO jp = 1,io%NPATCH
    CALL  write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,jp,&
                np%AL(jp)%NR_P,npe%AL(jp)%XWATSUP(:),ilu,s%XWORK_WR)
  ENDDO
!
ENDIF
!
!-------------------------------------------------------------------------------
!         End of IO
!
 CALL end_io_surf_n(hprogram)
IF (lhook) CALL dr_hook('WRITE_DIAG_PGD_ISBA_N',1,zhook_handle)
!
!
END SUBROUTINE write_diag_pgd_isba_n