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 (HSELECT, OSNOWDIMNC, CHI, NDST, &
                                   IO, S, NP, NPE, KI, 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_surfex_mpi, ONLY : nrank
!
USE modn_prep_surf_atm, ONLY : lwrite_extern
USE modd_write_surf_atm,  ONLY : lsplit_patch
!
USE modd_ch_isba_n, ONLY : ch_isba_t
USE modd_dst_n, ONLY : dst_np_t
!
USE modd_isba_options_n, ONLY : isba_options_t
USE modd_isba_n, ONLY : isba_np_t, isba_npe_t, isba_s_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_field_1d_patch
USE modi_write_surf
USE modi_writesurf_gr_snow
USE modi_allocate_gr_snow
USE modi_dealloc_gr_snow
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
!*       0.1   Declarations of arguments
!              -------------------------
!
 CHARACTER(LEN=*), DIMENSION(:), INTENT(IN) :: HSELECT 
LOGICAL, INTENT(IN) :: OSNOWDIMNC  
!
TYPE(ch_isba_t), INTENT(INOUT) :: CHI
TYPE(dst_np_t), INTENT(INOUT) :: NDST
!
TYPE(isba_options_t), INTENT(INOUT) :: IO
TYPE(isba_s_t), INTENT(INOUT) :: S
TYPE(isba_np_t), INTENT(INOUT) :: NP
TYPE(isba_npe_t), INTENT(INOUT) :: NPE
INTEGER, INTENT(IN) :: KI
!
 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
  CHARACTER(LEN=2) :: YPAT
!
INTEGER :: JJ, JL, JP, JNB, JNL, JNS, JNLV  ! 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(io%LTEMP_ARP)THEN
  iwork=io%NTEMPLAYER_ARP
ELSEIF(io%CISBA=='DIF')THEN
  iwork=io%NGROUND_LAYER
ELSE
  iwork=2 !Only 2 temperature layer in ISBA-FR
ENDIF
!
DO jl=1,iwork
  WRITE(ylvl,'(I4)') jl
  yrecfm='TG'//adjustl(ylvl(:len_trim(ylvl)))
  yform='(A6,I1.1,A4)'
  IF (jl >= 10)  yform='(A6,I2.2,A4)'
  WRITE(ycomment,fmt=yform) 'X_Y_TG',jl,' (K)'
  DO jp = 1,io%NPATCH
    CALL write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,jp,&
                np%AL(jp)%NR_P,npe%AL(jp)%XTG(:,jl),ki,s%XWORK_WR)
  ENDDO
END DO
!
!* soil liquid water contents
!
DO jl=1,io%NGROUND_LAYER
  WRITE(ylvl,'(I4)') jl     
  yrecfm='WG'//adjustl(ylvl(:len_trim(ylvl)))
  yform='(A6,I1.1,A8)'
  IF (jl >= 10)  yform='(A6,I2.2,A8)'
  WRITE(ycomment,fmt=yform) 'X_Y_WG',jl,' (m3/m3)'
  DO jp = 1,io%NPATCH
    CALL write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,jp,&
                np%AL(jp)%NR_P,npe%AL(jp)%XWG(:,jl),ki,s%XWORK_WR)  
  ENDDO
END DO
!
!* soil ice water contents
!
IF(io%CISBA=='DIF')THEN
  iwork=io%NGROUND_LAYER
ELSE
  iwork=2 !Only 2 soil ice layer in ISBA-FR
ENDIF
!
DO jl=1,iwork
  WRITE(ylvl,'(I4)') jl     
  yrecfm='WGI'//adjustl(ylvl(:len_trim(ylvl)))
  yform='(A7,I1.1,A8)'
  IF (jl >= 10)  yform='(A7,I2.2,A8)'
  WRITE(ycomment,yform) 'X_Y_WGI',jl,' (m3/m3)'
  DO jp = 1,io%NPATCH
    CALL write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,jp,&
                np%AL(jp)%NR_P,npe%AL(jp)%XWGI(:,jl),ki,s%XWORK_WR)  
  ENDDO
END DO
!
!* water intercepted on leaves
!
yrecfm='WR'
ycomment='X_Y_WR (kg/m2)'
DO jp = 1,io%NPATCH
  CALL write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,jp,&
                np%AL(jp)%NR_P,npe%AL(jp)%XWR(:),ki,s%XWORK_WR)    
ENDDO
!
!* Glacier ice storage
!
yrecfm = 'GLACIER'
ycomment='LGLACIER key for external prep'   
 CALL write_surf(hselect,hprogram,yrecfm,io%LGLACIER,iresp,hcomment=ycomment)
!
IF(io%LGLACIER)THEN
  yrecfm='ICE_STO'
  ycomment='X_Y_ICE_STO (kg/m2)'
  DO jp = 1,io%NPATCH
    CALL write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,jp,&
                np%AL(jp)%NR_P,npe%AL(jp)%XICE_STO(:),ki,s%XWORK_WR)   
  ENDDO
ENDIF
!
!* Leaf Area Index
!
IF (io%CPHOTO/='NON' .AND. io%CPHOTO/='AST') THEN
  !
  yrecfm='LAI'
  !
  ycomment='X_Y_LAI (m2/m2)'
  DO jp = 1,io%NPATCH
    CALL write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,jp,&
                np%AL(jp)%NR_P,npe%AL(jp)%XLAI(:),ki,s%XWORK_WR)    
  ENDDO
  !
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='RD_NS'//adjustl(yvar(:len_trim(yvar)))
      DO jp = 1,io%NPATCH
        CALL write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,jp,&
                     np%AL(jp)%NR_P,np%AL(jp)%XRED_NOISE(:,jvar),ki,s%XWORK_WR)       
      ENDDO
    ENDIF
  ENDDO
ENDIF
!
!* snow mantel
!
DO jp = 1,io%NPATCH
  CALL writesurf_gr_snow(osnowdimnc, hselect, hprogram, 'VEG', '     ', ki, &
           np%AL(jp)%NR_P, jp, npe%AL(jp)%TSNOW, s%XWSN_WR, s%XRHO_WR, &
           s%XHEA_WR, s%XAGE_WR, s%XSG1_WR, s%XSG2_WR, s%XHIS_WR, s%XALB_WR)
ENDDO
!
!* key and/or field usefull to make an external prep
!
IF(io%CISBA=='DIF')THEN
!
  yrecfm = 'SOC'
  ycomment='SOC key for external prep'
  CALL write_surf(hselect,hprogram,yrecfm,io%LSOC,iresp,hcomment=ycomment)
!
ELSE
!
  yrecfm = 'TEMPARP'
  ycomment='LTEMP_ARP key for external prep'
  CALL write_surf(hselect,hprogram,yrecfm,io%LTEMP_ARP,iresp,hcomment=ycomment)
!
  IF(io%LTEMP_ARP)THEN
    yrecfm = 'NTEMPLARP'
    ycomment='NTEMPLAYER_ARP for external prep'
    CALL write_surf(hselect,hprogram,yrecfm,io%NTEMPLAYER_ARP,iresp,hcomment=ycomment)
  ENDIF
!
ENDIF
!
!-------------------------------------------------------------------------------
!
!*       3.  MEB Prognostic or Semi-prognostic variables
!            -------------------------------------------
!
!
isize_lmeb_patch=count(io%LMEB_PATCH(:))
!
IF (isize_lmeb_patch>0) THEN
!
!* water intercepted on canopy vegetation leaves
!
  yrecfm='WRL'
  ycomment='X_Y_WRL (kg/m2)'
  DO jp = 1,io%NPATCH
    CALL write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,jp,&
                  np%AL(jp)%NR_P,npe%AL(jp)%XWRL(:),ki,s%XWORK_WR)    
  ENDDO
!
!* ice on litter
!
  yrecfm='WRLI'
  ycomment='X_Y_WRLI (kg/m2)'
  DO jp = 1,io%NPATCH
    CALL write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,jp,&
                  np%AL(jp)%NR_P,npe%AL(jp)%XWRLI(:),ki,s%XWORK_WR)    
  ENDDO
!
!* snow intercepted on canopy vegetation leaves
!
  yrecfm='WRVN'
  ycomment='X_Y_WRVN (kg/m2)'
  DO jp = 1,io%NPATCH
    CALL write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,jp,&
                  np%AL(jp)%NR_P,npe%AL(jp)%XWRVN(:),ki,s%XWORK_WR)    
  ENDDO

!
!* canopy vegetation temperature
!
  yrecfm='TV'
  ycomment='X_Y_TV (K)'
  DO jp = 1,io%NPATCH
    CALL write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,jp,&
                  np%AL(jp)%NR_P,npe%AL(jp)%XTV(:),ki,s%XWORK_WR)    
  ENDDO
!
!* litter temperature
!
  yrecfm='TL'
  ycomment='X_Y_TL (K)'
  DO jp = 1,io%NPATCH
    CALL write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,jp,&
                  np%AL(jp)%NR_P,npe%AL(jp)%XTL(:),ki,s%XWORK_WR)    
  ENDDO
!
!* vegetation canopy air temperature
!
  yrecfm='TC'
  ycomment='X_Y_TC (K)'
  DO jp = 1,io%NPATCH
    CALL write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,jp,&
                  np%AL(jp)%NR_P,npe%AL(jp)%XTC(:),ki,s%XWORK_WR)    
  ENDDO
!
!* vegetation canopy air specific humidity
!
  yrecfm='QC'
  ycomment='X_Y_QC (kg/kg)'
  DO jp = 1,io%NPATCH
    CALL write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,jp,&
                  np%AL(jp)%NR_P,npe%AL(jp)%XQC(:),ki,s%XWORK_WR)    
  ENDDO
!
ENDIF
!
!-------------------------------------------------------------------------------
!
!*       4.  Semi-prognostic variables
!            -------------------------
!
!
!* Fraction for each patch
!
yrecfm='PATCH'
ycomment='fraction for 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)%XPATCH(:),ki,s%XWORK_WR)    
ENDDO
!
!* patch averaged radiative temperature (K)
!
yrecfm='TSRAD_NAT'
ycomment='X_TSRAD_NAT (K)'
 CALL write_surf(hselect,hprogram,yrecfm,s%XTSRAD_NAT(:),iresp,hcomment=ycomment)
!
!* aerodynamical resistance
!
yrecfm='RESA'
ycomment='X_Y_RESA (s/m)'
DO jp = 1,io%NPATCH
  CALL write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,jp,&
                  np%AL(jp)%NR_P,npe%AL(jp)%XRESA(:),ki,s%XWORK_WR)    
ENDDO
!
!* Land use variables
!
IF(oland_use .OR. lwrite_extern)THEN
!
  DO jl=1,io%NGROUND_LAYER
    WRITE(ylvl,'(I4)') jl
    yform='(A6,I1.1,A8)'
    IF (jl >= 10)  yform='(A6,I2.2,A8)'
    IF (oland_use) THEN
      yrecfm='OLD_DG'//adjustl(ylvl(:len_trim(ylvl)))
      WRITE(ycomment,fmt=yform) 'X_Y_OLD_DG',jl,' (m)'
    ELSE
      yrecfm='DG'//adjustl(ylvl(:len_trim(ylvl)))
      WRITE(ycomment,fmt=yform) 'X_Y_DG',jl,' (m)'
    ENDIF
    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),ki,s%XWORK_WR)    
    ENDDO
  END DO
!
ENDIF
!
!* ISBA-AGS variables
!
IF (io%CPHOTO/='NON') THEN
  yrecfm='AN'
  ycomment='X_Y_AN (kgCO2/kgair m/s)'
  DO jp = 1,io%NPATCH
    CALL write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,jp,&
                    np%AL(jp)%NR_P,npe%AL(jp)%XAN(:),ki,s%XWORK_WR)    
  ENDDO
!
  yrecfm='ANDAY'
  ycomment='X_Y_ANDAY (kgCO2/m2/day)'
  DO jp = 1,io%NPATCH
    CALL write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,jp,&
                    np%AL(jp)%NR_P,npe%AL(jp)%XANDAY(:),ki,s%XWORK_WR)    
  ENDDO  
!
  yrecfm='ANFM'
  ycomment='X_Y_ANFM (kgCO2/kgair m/s)'
  DO jp = 1,io%NPATCH
    CALL write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,jp,&
                    np%AL(jp)%NR_P,npe%AL(jp)%XANFM(:),ki,s%XWORK_WR)    
  ENDDO    
!
  yrecfm='LE_AGS'
  ycomment='X_Y_LE_AGS (W/m2)'
  DO jp = 1,io%NPATCH
    CALL write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,jp,&
                    np%AL(jp)%NR_P,npe%AL(jp)%XLE(:),ki,s%XWORK_WR)    
  ENDDO    
END IF
!
!
IF (io%CPHOTO=='NIT' .OR. io%CPHOTO=='NCB') THEN
  !
  DO jnb=1,io%NNBIOMASS
    WRITE(ylvl,'(I1)') jnb
    yrecfm='BIOMA'//adjustl(ylvl(:len_trim(ylvl)))
    yform='(A11,I1.1,A10)'
    WRITE(ycomment,fmt=yform) 'X_Y_BIOMASS',jnb,' (kgDM/m2)'
    DO jp = 1,io%NPATCH
      CALL write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,jp,&
                      np%AL(jp)%NR_P,npe%AL(jp)%XBIOMASS(:,jnb),ki,s%XWORK_WR)    
    ENDDO      
  END DO
  !
  !
  DO jnb=2,io%NNBIOMASS
    WRITE(ylvl,'(I1)') jnb
    yrecfm='RESPI'//adjustl(ylvl(:len_trim(ylvl)))
    yform='(A16,I1.1,A10)'
    WRITE(ycomment,fmt=yform) 'X_Y_RESP_BIOMASS',jnb,' (kg/m2/s)'
    DO jp = 1,io%NPATCH
      CALL write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,jp,&
                      np%AL(jp)%NR_P,npe%AL(jp)%XRESP_BIOMASS(:,jnb),ki,s%XWORK_WR)    
    ENDDO      
  END DO
  !
END IF
!
!* Soil carbon
!
yrecfm = 'RESPSL'
ycomment=yrecfm
 CALL write_surf(hselect,hprogram,yrecfm,io%CRESPSL,iresp,hcomment=ycomment)
!
yrecfm='NLITTER'
ycomment=yrecfm
 CALL write_surf(hselect,hprogram,yrecfm,io%NNLITTER,iresp,hcomment=ycomment)
!
yrecfm='NLITTLEVS'
ycomment=yrecfm
 CALL write_surf(hselect,hprogram,yrecfm,io%NNLITTLEVS,iresp,hcomment=ycomment)
!
yrecfm='NSOILCARB'
ycomment=yrecfm
 CALL write_surf(hselect,hprogram,yrecfm,io%NNSOILCARB,iresp,hcomment=ycomment)
!
IF(io%LSPINUPCARBS.OR.io%LSPINUPCARBW)THEN
  yrecfm='NBYEARSOLD'
  ycomment='yrs'
  CALL write_surf(hselect,hprogram,yrecfm,io%NNBYEARSOLD,iresp,hcomment=ycomment)
ENDIF
!
IF (io%CRESPSL=='CNT') THEN
  !
  DO jnl=1,io%NNLITTER
    DO jnlv=1,io%NNLITTLEVS
      WRITE(ylvl,'(I1,A1,I1)') jnl,'_',jnlv
      yrecfm='LITTER'//adjustl(ylvl(:len_trim(ylvl)))
      yform='(A10,I1.1,A1,I1.1,A8)'
      WRITE(ycomment,fmt=yform) 'X_Y_LITTER',jnl,' ',jnlv,' (gC/m2)'
      DO jp = 1,io%NPATCH
        CALL write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,jp,&
                        np%AL(jp)%NR_P,npe%AL(jp)%XLITTER(:,jnl,jnlv),ki,s%XWORK_WR)    
      ENDDO        
    END DO
  END DO

  DO jns=1,io%NNSOILCARB
    WRITE(ylvl,'(I4)') jns
    yrecfm='SOILCARB'//adjustl(ylvl(:len_trim(ylvl)))
    yform='(A8,I1.1,A8)'
    WRITE(ycomment,fmt=yform) 'X_Y_SOILCARB',jns,' (gC/m2)'
    DO jp = 1,io%NPATCH
      CALL write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,jp,&
                      np%AL(jp)%NR_P,npe%AL(jp)%XSOILCARB(:,jns),ki,s%XWORK_WR)    
    ENDDO     
  END DO
!
  DO jnlv=1,io%NNLITTLEVS
    WRITE(ylvl,'(I4)') jnlv
    yrecfm='LIGN_STR'//adjustl(ylvl(:len_trim(ylvl)))
    yform='(A12,I1.1,A8)'
    WRITE(ycomment,fmt=yform) 'X_Y_LIGNIN_STRUC',jnlv,' (-)'
    DO jp = 1,io%NPATCH
      CALL write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,jp,&
                      np%AL(jp)%NR_P,npe%AL(jp)%XLIGNIN_STRUC(:,jnlv),ki,s%XWORK_WR)    
    ENDDO       
  END DO
!
ENDIF
!
!
IF (chi%SVI%NDSTEQ > 0)THEN
  DO jsv = 1,ndstmde ! for all dust modes
    WRITE(yrecfm,'(A6,I3.3)')'F_DSTM',jsv
    ycomment='X_Y_'//yrecfm//' (kg/m2)'
    DO jp = 1,io%NPATCH
      CALL write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,jp,&
                      np%AL(jp)%NR_P,ndst%AL(jp)%XSFDSTM(:,jsv),ki,s%XWORK_WR)    
    ENDDO     
  END DO
ENDIF
!
!-------------------------------------------------------------------------------

!*       5.  Time
!            ----
!
yrecfm='DTCUR'
ycomment='s'
 CALL write_surf(hselect,hprogram,yrecfm,s%TTIME,iresp,hcomment=ycomment)
!
IF (lhook) CALL dr_hook('WRITESURF_ISBA_N',1,zhook_handle)
!
!-------------------------------------------------------------------------------
!
END SUBROUTINE writesurf_isba_n