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 (OSNOWDIMNC, HSELECT, HPROGRAM, HSURFTYPE, &
                                    HPREFIX, KI, KMASK_P, KPATCH, TPSNOW, &
                                    PWSN_WR, PRHO_WR, PHEA_WR, PAGE_WR, PSG1_WR, &
                                    PSG2_WR, PHIS_WR, PALB_WR)
!     ##########################################################
!
!!****  *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_surf_par,   ONLY : xundef
USE modd_type_snow
USE modd_prep_snow, ONLY : lsnow_frac_tot
!
USE modd_write_surf_atm, ONLY : lsplit_patch
!
USE modi_write_field_2d_patch
USE modi_write_field_1d_patch
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
!
LOGICAL, INTENT(IN) :: OSNOWDIMNC
!
 CHARACTER(LEN=*), DIMENSION(:), INTENT(IN) :: HSELECT 
!
 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
INTEGER,            INTENT(IN)    :: KI      ! horizontal size of snow var.
INTEGER, DIMENSION(:), INTENT(IN) :: KMASK_P
INTEGER,            INTENT(IN) :: KPATCH    ! number of tiles                                             
TYPE(surf_snow),    INTENT(IN) :: TPSNOW     ! snow characteristics
REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PWSN_WR
REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRHO_WR
REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PHEA_WR
REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PAGE_WR
REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSG1_WR
REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PSG2_WR
REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PHIS_WR
REAL, DIMENSION(:,:), INTENT(INOUT) :: PALB_WR
!
!*       0.2   declarations of local variables
!
 CHARACTER (LEN=100) :: YFMT           ! format for writing
 CHARACTER(LEN=12)   :: YRECFM         ! Name of the article to be read
 CHARACTER(LEN=100)  :: YCOMMENT       ! Comment string
 CHARACTER(LEN=4)    :: YNLAYER        ! String depending on the number of layer : less
                                       !than 10 or more    
 CHARACTER(LEN=3) :: YPAT
!
INTEGER             :: ISURFTYPE_LEN, IPAT_LEN, IFACT
INTEGER             :: IRESP          ! IRESP  : return-code if a problem appears
INTEGER             :: JL, JP         ! loop counter
!
LOGICAL             :: GSNOW          ! T --> snow exists somewhere                                  
!
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!-------------------------------------------------------------------------------
IF (lhook) CALL dr_hook('WRITESURF_GR_SNOW',0,zhook_handle)
!
!*       1.    Initialisation
!              --------------
!
isurftype_len = len_trim(hsurftype)
!
jp = max(1,kpatch)
!
IF (kpatch<=1) THEN
  !
  !*       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(hselect,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(hselect,hprogram,yrecfm,tpsnow%NLAYER,iresp,hcomment=ycomment)
  !
  !
  !*       4.    Tests to find if there is snow
  !              ------------------------------
  !
ENDIF
!
IF (kpatch>0.AND.lsplit_patch) THEN
  WRITE(ypat,'(I2)') kpatch
  ypat = "P"//adjustl(ypat)
  ipat_len = len_trim(adjustl(ypat))
ELSE
  ypat = " "
  ipat_len=1
ENDIF
!

IF (tpsnow%NLAYER>0) THEN
  CALL detect_field(hprogram,tpsnow%WSNOW(:,1:1),gsnow)
ELSE
  gsnow = .false.
END IF
!
WRITE(yfmt,'(A5,I1,A2,I1,A1)') '(A3,A',isurftype_len,',A',ipat_len,')'
WRITE(yrecfm,yfmt) 'SN_',adjustl(hsurftype(:len_trim(hsurftype))),adjustl(ypat(:len_trim(ypat)))
yrecfm=adjustl(hprefix//yrecfm)
ycomment    = '(LOGICAL)'
 CALL write_surf(hselect,hprogram,yrecfm,gsnow,iresp,hcomment=ycomment)
!
!*       5.    Additional key
!              ---------------
!
IF (kpatch==1) THEN
  ycomment    = '(LOGICAL)'
  CALL write_surf(hselect,hprogram,'LSNOW_FRAC_T',lsnow_frac_tot,iresp,hcomment=ycomment)
ENDIF
!
IF ( osnowdimnc .AND. hprogram=='OFFLIN' ) THEN
  !
  IF (tpsnow%SCHEME=='1-L' .OR. tpsnow%SCHEME=='D95' .OR. tpsnow%SCHEME=='EBA' .OR. &
      tpsnow%SCHEME=='3-L' .OR. tpsnow%SCHEME=='CRO') THEN
    !
    WRITE(yfmt,'(A5,I1,A1)') '(A4,A',isurftype_len,')'
    WRITE(yrecfm,yfmt) 'WSN_',hsurftype
    yrecfm=adjustl(hprefix//yrecfm)
    WRITE(yfmt,'(A5,I1,A4)') '(A9,A',isurftype_len,',A8)'    
    WRITE(ycomment,yfmt) 'X_Y_WSNOW',hsurftype,' (kg/m2)'
    CALL  write_field_2d_patch(hselect,hprogram,yrecfm,ycomment,kpatch,kmask_p,tpsnow%WSNOW(:,:),&
            ki,'snow_layer',pwsn_wr)
    !
    WRITE(yfmt,'(A5,I1,A1)') '(A4,A',isurftype_len,')'
    WRITE(yrecfm,yfmt) 'RSN_',hsurftype
    yrecfm=adjustl(hprefix//yrecfm)  
    WRITE(yfmt,'(A5,I1,A4)') '(A9,A',isurftype_len,',A8)'
    WRITE(ycomment,yfmt) 'X_Y_RSNOW',hsurftype,' (kg/m2)'
    CALL  write_field_2d_patch(hselect,hprogram,yrecfm,ycomment,kpatch,kmask_p,tpsnow%RHO(:,:),&
            ki,'snow_layer',prho_wr)
    !
  ENDIF
  !
  IF (tpsnow%SCHEME=='3-L' .OR. tpsnow%SCHEME=='CRO') THEN
    !
    WRITE(yfmt,'(A5,I1,A1)') '(A4,A',isurftype_len,')'
    WRITE(yrecfm,yfmt) 'HSN_',hsurftype
    yrecfm=adjustl(hprefix//yrecfm) 
    WRITE(yfmt,'(A5,I1,A4)') '(A9,A',isurftype_len,',A8)'
    WRITE(ycomment,yfmt) 'X_Y_HSNOW',hsurftype,' (kg/m2)'
    CALL  write_field_2d_patch(hselect,hprogram,yrecfm,ycomment,kpatch,kmask_p,tpsnow%HEAT(:,:),&
            ki,'snow_layer',phea_wr)
    !
    WRITE(yfmt,'(A5,I1,A1)') '(A4,A',isurftype_len,')'
    WRITE(yrecfm,yfmt) 'ASN_',hsurftype
    yrecfm=adjustl(hprefix//yrecfm) 
    WRITE(yfmt,'(A5,I1,A4)') '(A8,A',isurftype_len,',A8)'
    WRITE(ycomment,yfmt) 'X_Y_SAGE',hsurftype,' (kg/m2)'
    CALL  write_field_2d_patch(hselect,hprogram,yrecfm,ycomment,kpatch,kmask_p,tpsnow%AGE(:,:),&
            ki,'snow_layer',page_wr)
    !
  ENDIF
  !
  IF (tpsnow%SCHEME=='CRO') THEN
    !
    WRITE(yfmt,'(A5,I1,A1)') '(A4,A',isurftype_len,')'
    WRITE(yrecfm,yfmt) 'SG1_',hsurftype
    yrecfm=adjustl(hprefix//yrecfm)  
    WRITE(yfmt,'(A5,I1,A4)') '(A7,A',isurftype_len,',A8)'
    WRITE(ycomment,yfmt) 'X_Y_SG1',hsurftype,' (kg/m2)'
    CALL  write_field_2d_patch(hselect,hprogram,yrecfm,ycomment,kpatch,kmask_p,tpsnow%GRAN1(:,:),&
            ki,'snow_layer',psg1_wr)
    !  
    WRITE(yfmt,'(A5,I1,A1)') '(A4,A',isurftype_len,')'
    WRITE(yrecfm,yfmt) 'SG2_',hsurftype
    yrecfm=adjustl(hprefix//yrecfm)  
    WRITE(yfmt,'(A5,I1,A4)') '(A7,A',isurftype_len,',A8)'  
    WRITE(ycomment,yfmt) 'X_Y_SG2',hsurftype,' (kg/m2)'
    CALL  write_field_2d_patch(hselect,hprogram,yrecfm,ycomment,kpatch,kmask_p,tpsnow%GRAN2(:,:),&
            ki,'snow_layer',psg2_wr)
    !  
    WRITE(yfmt,'(A5,I1,A1)') '(A4,A',isurftype_len,')'
    WRITE(yrecfm,yfmt) 'SHI_',hsurftype
    yrecfm=adjustl(hprefix//yrecfm)  
    WRITE(yfmt,'(A5,I1,A4)') '(A8,A',isurftype_len,',A8)'  
    WRITE(ycomment,yfmt) 'X_Y_HIST',hsurftype,' (kg/m2)'
    CALL  write_field_2d_patch(hselect,hprogram,yrecfm,ycomment,kpatch,kmask_p,tpsnow%HIST(:,:),&
            ki,'snow_layer',phis_wr)
    !
  ENDIF
  !
  IF (tpsnow%SCHEME=='1-L') THEN
    !
    WRITE(yfmt,'(A5,I1,A1)')     '(A4,A',isurftype_len,')'
    WRITE(yrecfm,yfmt) 'TSN_',hsurftype
    yrecfm=adjustl(hprefix//yrecfm)
    WRITE(yfmt,'(A6,I1,A4)')     '(A10,A',isurftype_len,',A8)'
    WRITE(ycomment,yfmt) 'X_Y_TSNOW',hsurftype,' (K)'
    CALL  write_field_2d_patch(hselect,hprogram,yrecfm,ycomment,kpatch,kmask_p,tpsnow%T(:,:),ki,'snow_layer')
    !
  END IF
  !
ELSE
  !
  DO jl = 1,tpsnow%NLAYER
    !
    ynlayer='I1.1'
    IF (jl>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,jl
      yrecfm=adjustl(hprefix//yrecfm)
      WRITE(yfmt,'(A6,I1,A9)') '(A10,A',isurftype_len,','//ynlayer//',A8))'
      WRITE(ycomment,yfmt) 'X_Y_WSNOW_',hsurftype,jl,' (kg/m2)'
      CALL  write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,kpatch,kmask_p,tpsnow%WSNOW(:,jl),&
              ki,pwsn_wr(:,jl,:))
      !
      !*       7.    Snow density
      !              ------------
      !
      WRITE(yfmt,'(A5,I1,A6)') '(A4,A',isurftype_len,','//ynlayer//')'
      WRITE(yrecfm,yfmt) 'RSN_',hsurftype,jl
      yrecfm=adjustl(hprefix//yrecfm)
      WRITE(yfmt,'(A6,I1,A9)') '(A10,A',isurftype_len,','//ynlayer//',A8))'
      WRITE(ycomment,yfmt) 'X_Y_RSNOW_',hsurftype,jl,' (kg/m3)'
      CALL  write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,kpatch,kmask_p,tpsnow%RHO(:,jl),&
              ki,prho_wr(:,jl,:))
      !
    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,jl
      yrecfm=adjustl(hprefix//yrecfm)
      WRITE(yfmt,'(A6,I1,A9)')     '(A10,A',isurftype_len,','//ynlayer//',A8))'
      WRITE(ycomment,yfmt) 'X_Y_HSNOW_',hsurftype,jl,' (J/m3)'
      CALL  write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,kpatch,kmask_p,tpsnow%HEAT(:,jl),&
              ki,phea_wr(:,jl,:))
      !
      !*       10.    Age parameter
      !              ---------------
      !
      WRITE(yfmt,'(A5,I1,A6)')     '(A4,A',isurftype_len,','//ynlayer//')'
      WRITE(yrecfm,yfmt) 'SAG_',hsurftype,jl
      yrecfm=adjustl(hprefix//yrecfm)
      WRITE(yfmt,'(A6,I1,A9)')     '(A9,A',isurftype_len,','//ynlayer//',A8))'
      WRITE(ycomment,yfmt) 'X_Y_SAGE_',hsurftype,jl,' (-)'
      CALL  write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,kpatch,kmask_p,tpsnow%AGE(:,jl),&
              ki,page_wr(:,jl,:))
      !
    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,jl
      yrecfm=adjustl(hprefix//yrecfm)
      WRITE(yfmt,'(A6,I1,A9)')     '(A11,A',isurftype_len,','//ynlayer//',A8))'
      WRITE(ycomment,yfmt) 'X_Y_SGRAN1_',hsurftype,jl,' (-)'
      CALL  write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,kpatch,kmask_p,tpsnow%GRAN1(:,jl),&
              ki,psg1_wr(:,jl,:))
      !
      !*       11.    Snow Gran2
      !              ----------
      !
      WRITE(yfmt,'(A5,I1,A6)')     '(A4,A',isurftype_len,','//ynlayer//')'
      WRITE(yrecfm,yfmt) 'SG2_',hsurftype,jl
      yrecfm=adjustl(hprefix//yrecfm)
      WRITE(yfmt,'(A6,I1,A9)')     '(A11,A',isurftype_len,','//ynlayer//',A8))'
      WRITE(ycomment,yfmt) 'X_Y_SGRAN2_',hsurftype,jl,' (-)'
      CALL  write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,kpatch,kmask_p,tpsnow%GRAN2(:,jl),&
              ki,psg2_wr(:,jl,:))
      !
      !*       13.   Historical parameter
      !              -------------------
      !
      WRITE(yfmt,'(A5,I1,A6)')     '(A4,A',isurftype_len,','//ynlayer//')'
      WRITE(yrecfm,yfmt) 'SHI_',hsurftype,jl
      yrecfm=adjustl(hprefix//yrecfm)
      WRITE(yfmt,'(A6,I1,A9)')     '(A10,A',isurftype_len,','//ynlayer//',A8))'
      WRITE(ycomment,yfmt) 'X_Y_SHIST_',hsurftype,jl,' (-)'
      CALL  write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,kpatch,kmask_p,tpsnow%HIST(:,jl),&
              ki,phis_wr(:,jl,:))
      !
    ENDIF
    !
    !*       8.    Snow temperature
    !              ----------------
    !
    IF (tpsnow%SCHEME=='1-L') THEN
      !
      WRITE(yfmt,'(A5,I1,A6)')     '(A4,A',isurftype_len,','//ynlayer//')'
      WRITE(yrecfm,yfmt) 'TSN_',hsurftype,jl
      yrecfm=adjustl(hprefix//yrecfm)
      WRITE(yfmt,'(A6,I1,A9)')     '(A10,A',isurftype_len,','//ynlayer//',A8))'
      WRITE(ycomment,yfmt) 'X_Y_TSNOW_',hsurftype,jl,' (K)'
      CALL  write_field_1d_patch(hselect,hprogram,yrecfm,ycomment,kpatch,kmask_p,tpsnow%T(:,jl),ki)
      !
    END IF
    !
  ENDDO
  !
ENDIF
!
!
!*       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_field_1d_patch(hselect,hprogram,yrecfm,ycomment,kpatch,kmask_p,tpsnow%ALB(:),&
          ki,palb_wr)
  !
END IF
!
IF (lhook) CALL dr_hook('WRITESURF_GR_SNOW',1,zhook_handle)
!
END SUBROUTINE writesurf_gr_snow