writesurf_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 writesurf_isba_n (DGU, U, &
                                    chi, dst, i, &
                                   hprogram,oland_use)
!     #####################################
!
!!****  *WRITESURF_ISBA_n* - writes ISBA prognostic fields
!!                        
!!
!!    PURPOSE
!!    -------
!!
!!**  METHOD
!!    ------
!!
!!    EXTERNAL
!!    --------
!!
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------
!!
!!    REFERENCE
!!    ---------
!!
!!
!!    AUTHOR
!!    ------
!!      V. Masson   *Meteo France*
!!
!!    MODIFICATIONS
!!    -------------
!!      Original    01/2003 
!!      P. LeMoigne 12/2004 : correct dimensionning if more than 10 layers in
!!                            the soil (diffusion version)
!!      B. Decharme  2008    : Floodplains
!!      B. Decharme  01/2009 : Optional Arpege deep soil temperature write
!!      A.L. Gibelin   03/09 : modifications for CENTURY model 
!!      A.L. Gibelin 04/2009 : BIOMASS and RESP_BIOMASS arrays 
!!      A.L. Gibelin 06/2009 : Soil carbon variables for CNT option
!!      B. Decharme  07/2011 : land_use semi-prognostic variables
!!      B. Decharme  09/2012 : suppress NWG_LAYER (parallelization problems)
!!      B. Decharme  09/2012 : write some key for prep_read_external
!!      B. Decharme  04/2013 : Only 2 temperature layer in ISBA-FR
!!      P. Samuelsson 10/2014: MEB
!!
!-------------------------------------------------------------------------------
!
!*       0.    DECLARATIONS
!              ------------
!
!
!
!
USE modd_diag_surf_atm_n, ONLY : diag_surf_atm_t
USE modd_surf_atm_n, ONLY : surf_atm_t
!
USE modd_ch_isba_n, ONLY : ch_isba_t
USE modd_dst_n, ONLY : dst_t
USE modd_isba_n, ONLY : isba_t
!
USE modd_surf_par, ONLY : nundef
!
!
USE modd_assim, ONLY : lassim, cassim, cassim_isba, nie, nens, &
                       xaddtimecorr, lens_gen, nvar
!
USE modd_dst_surf
!
USE modi_write_surf
USE modi_writesurf_gr_snow
!
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
!*       0.1   Declarations of arguments
!              -------------------------
!
!
!
TYPE(diag_surf_atm_t), INTENT(INOUT) :: dgu
TYPE(surf_atm_t), INTENT(INOUT) :: u
!
TYPE(ch_isba_t), INTENT(INOUT) :: chi
TYPE(dst_t), INTENT(INOUT) :: dst
TYPE(isba_t), INTENT(INOUT) :: i
!
 CHARACTER(LEN=6),  INTENT(IN)  :: hprogram ! program calling
LOGICAL,           INTENT(IN)  :: oland_use !
!
!*       0.2   Declarations of local variables
!              -------------------------------
!
INTEGER           :: iresp          ! IRESP  : return-code if a problem appears
 CHARACTER(LEN=12) :: yrecfm         ! Name of the article to be read
 CHARACTER(LEN=4 ) :: ylvl
 CHARACTER(LEN=3 ) :: yvar
 CHARACTER(LEN=100):: ycomment       ! Comment string
 CHARACTER(LEN=25) :: yform          ! Writing format
!
INTEGER :: jj, jlayer, jp, jnbiomass, jnlitter, jnsoilcarb, jnlittlevs  ! loop counter on levels
INTEGER :: iwork   ! Work integer
INTEGER :: jsv
INTEGER :: isize_lmeb_patch
INTEGER :: jvar
!
REAL(KIND=JPRB) :: zhook_handle
!
!------------------------------------------------------------------------------
!
!*       2.     Prognostic fields:
!               -----------------
!
IF (lhook) CALL dr_hook('WRITESURF_ISBA_N',0,zhook_handle)
!* soil temperatures
!
IF(i%LTEMP_ARP)THEN
  iwork=i%NTEMPLAYER_ARP
ELSEIF(i%CISBA=='DIF')THEN
  iwork=i%NGROUND_LAYER
ELSE
  iwork=2 !Only 2 temperature layer in ISBA-FR
ENDIF
!
DO jlayer=1,iwork
  WRITE(ylvl,'(I4)') jlayer
  yrecfm='TG'//adjustl(ylvl(:len_trim(ylvl)))
  yform='(A6,I1.1,A4)'
  IF (jlayer >= 10)  yform='(A6,I2.2,A4)'
  WRITE(ycomment,fmt=yform) 'X_Y_TG',jlayer,' (K)'
  CALL write_surf(dgu, u, &
                  hprogram,yrecfm,i%XTG(:,jlayer,:),iresp,hcomment=ycomment)
END DO
!
!* soil liquid water contents
!
DO jlayer=1,i%NGROUND_LAYER
   WRITE(ylvl,'(I4)') jlayer     
   yrecfm='WG'//adjustl(ylvl(:len_trim(ylvl)))
   yform='(A6,I1.1,A8)'
   IF (jlayer >= 10)  yform='(A6,I2.2,A8)'
   WRITE(ycomment,fmt=yform) 'X_Y_WG',jlayer,' (m3/m3)'
   CALL write_surf(dgu, u, &
                  hprogram,yrecfm,i%XWG(:,jlayer,:),iresp,hcomment=ycomment)
END DO
!
!* soil ice water contents
!
IF(i%CISBA=='DIF')THEN
  iwork=i%NGROUND_LAYER
ELSE
  iwork=2 !Only 2 soil ice layer in ISBA-FR
ENDIF
!
DO jlayer=1,iwork
   WRITE(ylvl,'(I4)') jlayer     
   yrecfm='WGI'//adjustl(ylvl(:len_trim(ylvl)))
   yform='(A7,I1.1,A8)'
   IF (jlayer >= 10)  yform='(A7,I2.2,A8)'
   WRITE(ycomment,yform) 'X_Y_WGI',jlayer,' (m3/m3)'
   CALL write_surf(dgu, u, &
                  hprogram,yrecfm,i%XWGI(:,jlayer,:),iresp,hcomment=ycomment)  
END DO
!
!* water intercepted on leaves
!
yrecfm='WR'
ycomment='X_Y_WR (kg/m2)'
 CALL write_surf(dgu, u, &
                  hprogram,yrecfm,i%XWR(:,:),iresp,hcomment=ycomment)
!
!* Glacier ice storage
!
yrecfm = 'GLACIER'
ycomment='LGLACIER key for external prep'
 CALL write_surf(dgu, u, &
                  hprogram,yrecfm,i%LGLACIER,iresp,hcomment=ycomment)
!
IF(i%LGLACIER)THEN
  yrecfm='ICE_STO'
  ycomment='X_Y_ICE_STO (kg/m2)'
  CALL write_surf(dgu, u, &
                  hprogram,yrecfm,i%XICE_STO(:,:),iresp,hcomment=ycomment)
ENDIF
!
!* Leaf Area Index
!
IF (i%CPHOTO/='NON' .AND. i%CPHOTO/='AGS' .AND. i%CPHOTO/='AST') THEN
  !
  yrecfm='LAI'
  !
  ycomment='X_Y_LAI (m2/m2)'
  CALL write_surf(dgu, u, &
                  hprogram,yrecfm,i%XLAI(:,:),iresp,hcomment=ycomment)
  !
END IF
!
IF ( trim(cassim_isba)=="ENKF" .AND. (lassim .OR. nie/=0) ) THEN
  DO jvar = 1,nvar
    IF ( xaddtimecorr(jvar)>0. ) THEN
      WRITE(yvar,'(I3)') jvar
      ycomment = 'Red_Noise_Enkf'
      yrecfm='RED_NOISE'//adjustl(yvar(:len_trim(yvar)))
      CALL write_surf(dgu, u, &
                      hprogram,yrecfm,i%XRED_NOISE(:,:,jvar),iresp,hcomment=ycomment)
    ENDIF
  ENDDO
ENDIF
!
!* snow mantel
!
 CALL writesurf_gr_snow(dgu, u, &
                        hprogram,'VEG','     ',i%TSNOW)
!
!
!* key and/or field usefull to make an external prep
!
IF(i%CISBA=='DIF')THEN
!
  yrecfm = 'SOC'
  ycomment='SOC key for external prep'
  CALL write_surf(dgu, u, &
                  hprogram,yrecfm,i%LSOC,iresp,hcomment=ycomment)
!
ELSE
!
  yrecfm = 'TEMPARP'
  ycomment='LTEMP_ARP key for external prep'
  CALL write_surf(dgu, u, &
                  hprogram,yrecfm,i%LTEMP_ARP,iresp,hcomment=ycomment)
!
  IF(i%LTEMP_ARP)THEN
    yrecfm = 'NTEMPLARP'
    ycomment='NTEMPLAYER_ARP for external prep'
    CALL write_surf(dgu, u, &
                  hprogram,yrecfm,i%NTEMPLAYER_ARP,iresp,hcomment=ycomment)
  ENDIF
!
ENDIF
!
!-------------------------------------------------------------------------------
!
!*       3.  MEB Prognostic or Semi-prognostic variables
!            -------------------------------------------
!
!
isize_lmeb_patch=count(i%LMEB_PATCH(:))
!
IF (isize_lmeb_patch>0) THEN
!
!* water intercepted on canopy vegetation leaves
!
  yrecfm='WRL'
  ycomment='X_Y_WRL (kg/m2)'
  CALL write_surf(dgu, u, &
                 hprogram,yrecfm,i%XWRL(:,:),iresp,hcomment=ycomment)
!
!* ice on litter
!
  yrecfm='WRLI'
  ycomment='X_Y_WRLI (kg/m2)'
  CALL write_surf(dgu, u, &
                hprogram,yrecfm,i%XWRLI(:,:),iresp,hcomment=ycomment)
!
!* snow intercepted on canopy vegetation leaves
!
  yrecfm='WRVN'
  ycomment='X_Y_WRVN (kg/m2)'
  CALL write_surf(dgu, u, &
                  hprogram,yrecfm,i%XWRVN(:,:),iresp,hcomment=ycomment)
!
!* canopy vegetation temperature
!
  yrecfm='TV'
  ycomment='X_Y_TV (K)'
  CALL write_surf(dgu, u, &
                  hprogram,yrecfm,i%XTV(:,:),iresp,hcomment=ycomment)
!
!* litter temperature
!
  yrecfm='TL'
  ycomment='X_Y_TL (K)'
  CALL write_surf(dgu, u, &
                hprogram,yrecfm,i%XTL(:,:),iresp,hcomment=ycomment)
!
!* vegetation canopy air temperature
!
  yrecfm='TC'
  ycomment='X_Y_TC (K)'
  CALL write_surf(dgu, u, &
                  hprogram,yrecfm,i%XTC(:,:),iresp,hcomment=ycomment)
!
!* vegetation canopy air specific humidity
!
  yrecfm='QC'
  ycomment='X_Y_QC (kg/kg)'
  CALL write_surf(dgu, u, &
                  hprogram,yrecfm,i%XQC(:,:),iresp,hcomment=ycomment)
!
ENDIF
!
!-------------------------------------------------------------------------------
!
!*       4.  Semi-prognostic variables
!            -------------------------
!
!
!* Fraction for each patch
!
yrecfm='PATCH'
ycomment='fraction for each patch (-)'
 CALL write_surf(dgu, u, &
                  hprogram,yrecfm,i%XPATCH(:,:),iresp,hcomment=ycomment)
!
!* patch averaged radiative temperature (K)
!
yrecfm='TSRAD_NAT'
ycomment='X_TSRAD_NAT (K)'
 CALL write_surf(dgu, u, &
                  hprogram,yrecfm,i%XTSRAD_NAT(:),iresp,hcomment=ycomment)
!
!* aerodynamical resistance
!
yrecfm='RESA'
ycomment='X_Y_RESA (s/m)'
 CALL write_surf(dgu, u, &
                  hprogram,yrecfm,i%XRESA(:,:),iresp,hcomment=ycomment)
!
!* Land use variables
!
IF(oland_use)THEN
!
  DO jlayer=1,i%NGROUND_LAYER
    WRITE(ylvl,'(I4)') jlayer
    yrecfm='OLD_DG'//adjustl(ylvl(:len_trim(ylvl)))
    yform='(A6,I1.1,A8)'
    IF (jlayer >= 10)  yform='(A6,I2.2,A8)'
    WRITE(ycomment,fmt=yform) 'X_Y_OLD_DG',jlayer,' (m)'
    CALL write_surf(dgu, u, &
                  hprogram,yrecfm,i%XDG(:,jlayer,:),iresp,hcomment=ycomment)
  END DO
!
ENDIF
!
!* ISBA-AGS variables
!
IF (i%CPHOTO/='NON') THEN
  yrecfm='AN'
  ycomment='X_Y_AN (kgCO2/kgair m/s)'
  CALL write_surf(dgu, u, &
                  hprogram,yrecfm,i%XAN(:,:),iresp,hcomment=ycomment)
!
  yrecfm='ANDAY'
  ycomment='X_Y_ANDAY (kgCO2/m2/day)'
  CALL write_surf(dgu, u, &
                  hprogram,yrecfm,i%XANDAY(:,:),iresp,hcomment=ycomment)
!
  yrecfm='ANFM'
  ycomment='X_Y_ANFM (kgCO2/kgair m/s)'
  CALL write_surf(dgu, u, &
                  hprogram,yrecfm,i%XANFM(:,:),iresp,hcomment=ycomment)
!
  yrecfm='LE_AGS'
  ycomment='X_Y_LE_AGS (W/m2)'
  CALL write_surf(dgu, u, &
                  hprogram,yrecfm,i%XLE(:,:),iresp,hcomment=ycomment)
END IF
!
!
IF (i%CPHOTO=='NIT' .OR. i%CPHOTO=='NCB') THEN
  !
  DO jnbiomass=1,i%NNBIOMASS
    WRITE(ylvl,'(I1)') jnbiomass
    yrecfm='BIOMA'//adjustl(ylvl(:len_trim(ylvl)))
    yform='(A11,I1.1,A10)'
    WRITE(ycomment,fmt=yform) 'X_Y_BIOMASS',jnbiomass,' (kgDM/m2)'
    CALL write_surf(dgu, u, &
                  hprogram,yrecfm,i%XBIOMASS(:,jnbiomass,:),iresp,hcomment=ycomment)
  END DO
  !
  !
  DO jnbiomass=2,i%NNBIOMASS
    WRITE(ylvl,'(I1)') jnbiomass
    yrecfm='RESPI'//adjustl(ylvl(:len_trim(ylvl)))
    yform='(A16,I1.1,A10)'
    WRITE(ycomment,fmt=yform) 'X_Y_RESP_BIOMASS',jnbiomass,' (kg/m2/s)'
    CALL write_surf(dgu, u, &
                  hprogram,yrecfm,i%XRESP_BIOMASS(:,jnbiomass,:),iresp,hcomment=ycomment)
  END DO
  !
END IF
!
!* Soil carbon
!
yrecfm = 'RESPSL'
ycomment=yrecfm
 CALL write_surf(dgu, u, &
                  hprogram,yrecfm,i%CRESPSL,iresp,hcomment=ycomment)
!
yrecfm='NLITTER'
ycomment=yrecfm
 CALL write_surf(dgu, u, &
                  hprogram,yrecfm,i%NNLITTER,iresp,hcomment=ycomment)
!
yrecfm='NLITTLEVS'
ycomment=yrecfm
 CALL write_surf(dgu, u, &
                  hprogram,yrecfm,i%NNLITTLEVS,iresp,hcomment=ycomment)
!
yrecfm='NSOILCARB'
ycomment=yrecfm
 CALL write_surf(dgu, u, &
                  hprogram,yrecfm,i%NNSOILCARB,iresp,hcomment=ycomment)
!
IF(i%LSPINUPCARBS.OR.i%LSPINUPCARBW)THEN
  yrecfm='NBYEARSOLD'
  ycomment='yrs'
  CALL write_surf(dgu, u, &
                  hprogram,yrecfm,i%NNBYEARSOLD,iresp,hcomment=ycomment)
ENDIF
!
IF (i%CRESPSL=='CNT') THEN
  !
  DO jnlitter=1,i%NNLITTER
    DO jnlittlevs=1,i%NNLITTLEVS
      WRITE(ylvl,'(I1,A1,I1)') jnlitter,'_',jnlittlevs
      yrecfm='LITTER'//adjustl(ylvl(:len_trim(ylvl)))
      yform='(A10,I1.1,A1,I1.1,A8)'
      WRITE(ycomment,fmt=yform) 'X_Y_LITTER',jnlitter,' ',jnlittlevs,' (gC/m2)'
      CALL write_surf(dgu, u, &
                  hprogram,yrecfm,i%XLITTER(:,jnlitter,jnlittlevs,:),iresp,hcomment=ycomment)
    END DO
  END DO

  DO jnsoilcarb=1,i%NNSOILCARB
    WRITE(ylvl,'(I4)') jnsoilcarb
    yrecfm='SOILCARB'//adjustl(ylvl(:len_trim(ylvl)))
    yform='(A8,I1.1,A8)'
    WRITE(ycomment,fmt=yform) 'X_Y_SOILCARB',jnsoilcarb,' (gC/m2)'
    CALL write_surf(dgu, u, &
                  hprogram,yrecfm,i%XSOILCARB(:,jnsoilcarb,:),iresp,hcomment=ycomment)
  END DO
!
  DO jnlittlevs=1,i%NNLITTLEVS
    WRITE(ylvl,'(I4)') jnlittlevs
    yrecfm='LIGNIN_STR'//adjustl(ylvl(:len_trim(ylvl)))
    yform='(A12,I1.1,A8)'
    WRITE(ycomment,fmt=yform) 'X_Y_LIGNIN_STRUC',jnlittlevs,' (-)'
    CALL write_surf(dgu, u, &
                  hprogram,yrecfm,i%XLIGNIN_STRUC(:,jnlittlevs,:),iresp,hcomment=ycomment)
  END DO
!
ENDIF
!
!
IF (chi%SVI%NDSTEQ > 0)THEN
  DO jsv = 1,ndstmde ! for all dust modes
    WRITE(yrecfm,'(A8,I3.3)')'FLX_DSTM',jsv
    ycomment='X_Y_'//yrecfm//' (kg/m2)'
    CALL write_surf(dgu, u, &
                  hprogram,yrecfm,dst%XSFDSTM(:,jsv,:),iresp,hcomment=ycomment)
  END DO
ENDIF
!
!-------------------------------------------------------------------------------
!
!*       5.  Time
!            ----
!
yrecfm='DTCUR'
ycomment='s'
 CALL write_surf(dgu, u, &
                  hprogram,yrecfm,i%TTIME,iresp,hcomment=ycomment)
IF (lhook) CALL dr_hook('WRITESURF_ISBA_N',1,zhook_handle)
!
!-------------------------------------------------------------------------------
!
END SUBROUTINE writesurf_isba_n