writesurf_gr_snow.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_gr_snow (DGU, U, &
                                    hprogram,hsurftype,hprefix,tpsnow  )
!     ##########################################################
!
!!****  *WRITESURF_GR_SNOW* - routine to write snow surface fields
!!
!!    PURPOSE
!!    -------
!       Writes snow surface fields
!
!!**  METHOD
!!    ------
!!    
!!    
!!
!!    EXTERNAL
!!    --------
!!
!!       
!!    IMPLICIT ARGUMENTS
!!    ------------------ 
!!
!!    REFERENCE
!!    ---------
!!
!!      
!!
!!    AUTHOR
!!    ------
!!      V. Masson       * Meteo France *
!!
!!    MODIFICATIONS
!!    -------------
!!      Original      02/2003
!!     A. Bogatchev 09/2005 EBA snow option
!-----------------------------------------------------------------------------
!
!*       0.    DECLARATIONS
!
!
!
USE modd_diag_surf_atm_n, ONLY : diag_surf_atm_t
USE modd_surf_atm_n, ONLY : surf_atm_t
!
USE modd_surf_par,   ONLY : xundef
USE modd_type_snow
USE modd_prep_snow, ONLY : lsnow_frac_tot
!
USE modi_detect_field
USE modi_write_surf
!
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
!
 CHARACTER (LEN=6),  INTENT(IN) :: hprogram   ! program
 CHARACTER (LEN=*),  INTENT(IN) :: hsurftype  ! generic name used for
                                             ! snow characteristics
                                             ! storage in file
 CHARACTER (LEN=3),  INTENT(IN) :: hprefix    ! generic name of prefix for
                                             ! patch identification
TYPE(surf_snow),    INTENT(IN) :: tpsnow     ! snow characteristics
!
!*       0.2   declarations of local variables
!
INTEGER             :: isurftype_len
!
 CHARACTER (LEN=100) :: yfmt           ! format for writing
 CHARACTER(LEN=12)   :: yrecfm         ! Name of the article to be read
 CHARACTER(LEN=100)  :: ycomment       ! Comment string
INTEGER             :: iresp          ! IRESP  : return-code if a problem appears
!
LOGICAL             :: gsnow          ! T --> snow exists somewhere
!
INTEGER             :: jlayer         ! loop counter
 CHARACTER(LEN=4)    :: ynlayer        ! String depending on the number of layer : less
                                      !than 10 or more                              
!
REAL(KIND=JPRB) :: zhook_handle
!-------------------------------------------------------------------------------
IF (lhook) CALL dr_hook('WRITESURF_GR_SNOW',0,zhook_handle)
!
!*       1.    Initialisation
!              --------------
!
isurftype_len = len_trim(hsurftype)
!
!
!*       2.    Type of snow scheme
!              -------------------
!
WRITE(yfmt,'(A5,I1,A4)') '(A3,A',isurftype_len,',A4)'
WRITE(yrecfm,yfmt) 'SN_',hsurftype,'_TYP'
yrecfm=adjustl(hprefix//yrecfm)
ycomment=' '
 CALL write_surf(dgu, u, &
                 hprogram,yrecfm,tpsnow%SCHEME,iresp,hcomment=ycomment)
!
!
!*       3.    Number of layers
!              ----------------
!
WRITE(yfmt,'(A5,I1,A4)') '(A3,A',isurftype_len,',A2)'
WRITE(yrecfm,yfmt) 'SN_',hsurftype,'_N'
yrecfm=adjustl(hprefix//yrecfm)
ycomment    = '(INTEGER)'
 CALL write_surf(dgu, u, &
                 hprogram,yrecfm,tpsnow%NLAYER,iresp,hcomment=ycomment)
!
!
!*       4.    Tests to find if there is snow
!              ------------------------------
!
IF (tpsnow%NLAYER>0) THEN
  CALL detect_field(hprogram,tpsnow%WSNOW(:,1,:),gsnow)
ELSE
  gsnow = .false.
END IF
!
WRITE(yfmt,'(A5,I1,A1)') '(A3,A',isurftype_len,')'
WRITE(yrecfm,yfmt) 'SN_',hsurftype
yrecfm=adjustl(hprefix//yrecfm)
ycomment    = '(LOGICAL)'
 CALL write_surf(dgu, u, &
                 hprogram,yrecfm,gsnow,iresp,hcomment=ycomment)
!
!
IF (.NOT. gsnow) THEN
  IF (lhook) CALL dr_hook('WRITESURF_GR_SNOW',1,zhook_handle)
  RETURN
END IF
!
!
!*       5.    Additional key
!              ---------------
!
ycomment    = '(LOGICAL)'
 CALL write_surf(dgu, u, &
                 hprogram,'LSNOW_FRAC_T',lsnow_frac_tot,iresp,hcomment=ycomment)
!
!
DO jlayer = 1,tpsnow%NLAYER
  !
  ynlayer='I1.1'
  IF (jlayer>9) ynlayer='I2.2'
  !
  IF (tpsnow%SCHEME=='1-L' .OR. tpsnow%SCHEME=='D95' .OR. tpsnow%SCHEME=='EBA' .OR. &
      tpsnow%SCHEME=='3-L' .OR. tpsnow%SCHEME=='CRO') THEN
    !
    !*       6.    Snow reservoir
    !              --------------
    !
    WRITE(yfmt,'(A5,I1,A6)') '(A4,A',isurftype_len,','//ynlayer//')'
    WRITE(yrecfm,yfmt) 'WSN_',hsurftype,jlayer
    yrecfm=adjustl(hprefix//yrecfm)
    WRITE(yfmt,'(A6,I1,A9)') '(A10,A',isurftype_len,','//ynlayer//',A8))'
    WRITE(ycomment,yfmt) 'X_Y_WSNOW_',hsurftype,jlayer,' (kg/m2)'
    CALL write_surf(dgu, u, &
                 hprogram,yrecfm,tpsnow%WSNOW(:,jlayer,:),iresp,hcomment=ycomment)
    !
    !*       7.    Snow density
    !              ------------
    !
    WRITE(yfmt,'(A5,I1,A6)') '(A4,A',isurftype_len,','//ynlayer//')'
    WRITE(yrecfm,yfmt) 'RSN_',hsurftype,jlayer
    yrecfm=adjustl(hprefix//yrecfm)
    WRITE(yfmt,'(A6,I1,A9)') '(A10,A',isurftype_len,','//ynlayer//',A8))'
    WRITE(ycomment,yfmt) 'X_Y_RSNOW_',hsurftype,jlayer,' (kg/m3)'
    CALL write_surf(dgu, u, &
                 hprogram,yrecfm,tpsnow%RHO(:,jlayer,:),iresp,hcomment=ycomment)
    !
  END IF
  !
  !*       8.    Snow temperature
  !              ----------------
  !
  IF (tpsnow%SCHEME=='1-L') THEN
    !
    WRITE(yfmt,'(A5,I1,A6)')     '(A4,A',isurftype_len,','//ynlayer//')'
    WRITE(yrecfm,yfmt) 'TSN_',hsurftype,jlayer
    yrecfm=adjustl(hprefix//yrecfm)
    WRITE(yfmt,'(A6,I1,A9)')     '(A10,A',isurftype_len,','//ynlayer//',A8))'
    WRITE(ycomment,yfmt) 'X_Y_TSNOW_',hsurftype,jlayer,' (K)'
    CALL write_surf(dgu, u, &
                 hprogram,yrecfm,tpsnow%T(:,jlayer,:),iresp,hcomment=ycomment)
    !
  END IF
  !
  IF (tpsnow%SCHEME=='3-L' .OR. tpsnow%SCHEME=='CRO') THEN
    !
    !*       9.    Heat content
    !              ------------         
    !
    WRITE(yfmt,'(A5,I1,A6)')     '(A4,A',isurftype_len,','//ynlayer//')'
    WRITE(yrecfm,yfmt) 'HSN_',hsurftype,jlayer
    yrecfm=adjustl(hprefix//yrecfm)
    WRITE(yfmt,'(A6,I1,A9)')     '(A10,A',isurftype_len,','//ynlayer//',A8))'
    WRITE(ycomment,yfmt) 'X_Y_HSNOW_',hsurftype,jlayer,' (J/m3)'
    CALL write_surf(dgu, u, &
                 hprogram,yrecfm,tpsnow%HEAT(:,jlayer,:),iresp,hcomment=ycomment)
    !
    !*       10.    Age parameter
    !              ---------------
    !
    WRITE(yfmt,'(A5,I1,A6)')     '(A4,A',isurftype_len,','//ynlayer//')'
    WRITE(yrecfm,yfmt) 'SAG_',hsurftype,jlayer
    yrecfm=adjustl(hprefix//yrecfm)
    WRITE(yfmt,'(A6,I1,A9)')     '(A9,A',isurftype_len,','//ynlayer//',A8))'
    WRITE(ycomment,yfmt) 'X_Y_SAGE_',hsurftype,jlayer,' (-)'
    CALL write_surf(dgu, u, &
                 hprogram,yrecfm,tpsnow%AGE(:,jlayer,:),iresp,hcomment=ycomment)
    !
  END IF
  !
  IF (tpsnow%SCHEME=='CRO') THEN
    !
    !*       11.    Snow Gran1
    !              ----------
    !
    WRITE(yfmt,'(A5,I1,A6)')     '(A4,A',isurftype_len,','//ynlayer//')'
    WRITE(yrecfm,yfmt) 'SG1_',hsurftype,jlayer
    yrecfm=adjustl(hprefix//yrecfm)
    WRITE(yfmt,'(A6,I1,A9)')     '(A11,A',isurftype_len,','//ynlayer//',A8))'
    WRITE(ycomment,yfmt) 'X_Y_SGRAN1_',hsurftype,jlayer,' (-)'
    CALL write_surf(dgu, u, &
                 hprogram,yrecfm,tpsnow%GRAN1(:,jlayer,:),iresp,hcomment=ycomment)
    !
    !*       12.    Snow Gran2
    !              ------------
    !
    WRITE(yfmt,'(A5,I1,A6)')     '(A4,A',isurftype_len,','//ynlayer//')'
    WRITE(yrecfm,yfmt) 'SG2_',hsurftype,jlayer
    yrecfm=adjustl(hprefix//yrecfm)
    WRITE(yfmt,'(A6,I1,A9)')     '(A11,A',isurftype_len,','//ynlayer//',A8))'
    WRITE(ycomment,yfmt) 'X_Y_SGRAN2_',hsurftype,jlayer,' (-)'
    CALL write_surf(dgu, u, &
                 hprogram,yrecfm,tpsnow%GRAN2(:,jlayer,:),iresp,hcomment=ycomment)
    !
    !*       13.   Historical parameter
    !              -------------------
    !
    WRITE(yfmt,'(A5,I1,A6)')     '(A4,A',isurftype_len,','//ynlayer//')'
    WRITE(yrecfm,yfmt) 'SHI_',hsurftype,jlayer
    yrecfm=adjustl(hprefix//yrecfm)
    WRITE(yfmt,'(A6,I1,A9)')     '(A10,A',isurftype_len,','//ynlayer//',A8))'
    WRITE(ycomment,yfmt) 'X_Y_SHIST_',hsurftype,jlayer,' (-)'
    CALL write_surf(dgu, u, &
                 hprogram,yrecfm,tpsnow%HIST(:,jlayer,:),iresp,hcomment=ycomment)
    !
  END IF
  !
END DO
!
!
!*       14.    Albedo
!              ------
!
IF (tpsnow%SCHEME=='D95' .OR. tpsnow%SCHEME=='EBA' .OR. tpsnow%SCHEME=='1-L' .OR. &
    tpsnow%SCHEME=='3-L' .OR. tpsnow%SCHEME=='CRO') THEN
  !
  WRITE(yfmt,'(A5,I1,A1)')     '(A4,A',isurftype_len,')'
  WRITE(yrecfm,yfmt) 'ASN_',hsurftype
  yrecfm=adjustl(hprefix//yrecfm)
  WRITE(yfmt,'(A6,I1,A5)')     '(A10,A',isurftype_len,',A10)'
  WRITE(ycomment,yfmt) 'X_Y_ASNOW_',hsurftype,' (no unit)'
  CALL write_surf(dgu, u, &
                 hprogram,yrecfm,tpsnow%ALB(:,:),iresp,hcomment=ycomment)
  !
END IF
!
IF (lhook) CALL dr_hook('WRITESURF_GR_SNOW',1,zhook_handle)
!
END SUBROUTINE writesurf_gr_snow