writesurf_sbln.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_sbl_n (HSELECT, OSBL, SB, HPROGRAM, HWRITE, HSURF)
!     ####################################
!
!!****  *WRITE_FLAKE_n* - writes FLAKE fields
!!
!!    PURPOSE
!!    -------
!!
!!**  METHOD
!!    ------
!!
!!    EXTERNAL
!!    --------
!!
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------
!!
!!    REFERENCE
!!    ---------
!!
!!
!!    AUTHOR
!!    ------
!!      V. Masson   *Meteo France*
!!
!!    MODIFICATIONS
!!    -------------
!!      Original    01/2003 
!!      E. Martin   01/2012 avoid write of XUNDEF fields
!-------------------------------------------------------------------------------
!
!*       0.    DECLARATIONS
!              ------------
!
USE modd_canopy_n, ONLY : canopy_t
!
USE modi_write_surf
USE modi_end_io_surf_n
USE modi_init_io_surf_n
!
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) :: OSBL
!
TYPE(canopy_t), INTENT(INOUT) :: SB
!
 CHARACTER(LEN=6),  INTENT(IN)  :: HPROGRAM ! program calling
 CHARACTER(LEN=3),    INTENT(IN)  :: HWRITE    ! 'PREP' : does not write SBL XUNDEF fields
!                                             ! 'ALL' : all fields are written
 CHARACTER(LEN=6), INTENT(IN) :: HSURF
!
!*       0.2   Declarations of local variables
!              -------------------------------
!
INTEGER           :: IRESP          ! IRESP  : return-code if a problem appears
 CHARACTER(LEN=8) :: YBASE
 CHARACTER(LEN=12) :: YRECFM         ! Name of the article to be read
 CHARACTER(LEN=13) :: YFORMAT 
 CHARACTER(LEN=100):: YCOMMENT       ! Comment string
!
INTEGER :: JL  ! loop counter on layers
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!-------------------------------------------------------------------------------
!
!*       1.     Prognostic fields:
!               -----------------
!
!* flag to define if SBL is computed
!
IF (lhook) CALL dr_hook('WRITESURF_SBL_N',0,zhook_handle)
!
IF (hsurf=="TOWN  ") THEN
  yrecfm='TEB_CANOPY'
ELSEIF (hsurf=="WATER ") THEN
  yrecfm='WAT_SBL'
ELSEIF (hsurf=="NATURE") THEN
  yrecfm='ISBA_CANOPY'
ELSEIF (hsurf=="SEA   ") THEN
  yrecfm='SEA_SBL'
ENDIF
ycomment='flag to use SBL levels'
 CALL write_surf(hselect,hprogram,yrecfm,osbl,iresp,hcomment=ycomment)
!
IF (.NOT. osbl .AND. lhook) CALL dr_hook('WRITESURF_SBL_N',1,zhook_handle)
IF (.NOT. osbl) RETURN
!
IF (hsurf=="TOWN  ") THEN
  ybase = "TEB_CAN "
ELSEIF (hsurf=="WATER ") THEN
  ybase = "WAT_SBL "
ELSEIF (hsurf=="NATURE") THEN
  ybase = "ISBA_CAN"
ELSEIF (hsurf=="SEA   ") THEN
  ybase = "SEA_SBL "
ENDIF
!
IF (hsurf=="NATURE") THEN
  yformat='(A10,I2.2)'
ELSE
  yformat='(A9,I2.2) '
ENDIF
!
!* number of levels
!
yrecfm=trim(ybase)//'_LVL'
ycomment='number of SBL levels'
 CALL write_surf(hselect,hprogram,yrecfm,sb%NLVL,iresp,hcomment=ycomment)
!
!* altitudes
!
DO jl=1,sb%NLVL
  WRITE(yrecfm,yformat) trim(ybase)//'_Z',jl
  ycomment='altitudes of SBL levels (m)'
  CALL write_surf(hselect,hprogram,yrecfm,sb%XZ(:,jl),iresp,hcomment=ycomment)
END DO
!
IF (hwrite/='PRE') THEN
  !
  !* wind in SBL
  !
  DO jl=1,sb%NLVL
    WRITE(yrecfm,yformat) trim(ybase)//'_U',jl
    ycomment='wind at SBL levels (m/s)'
    CALL write_surf(hselect,hprogram,yrecfm,sb%XU(:,jl),iresp,hcomment=ycomment)
  END DO
  !
  !* temperature in SBL
  !
  DO jl=1,sb%NLVL
    WRITE(yrecfm,yformat) trim(ybase)//'_T',jl
    ycomment='temperature at SBL levels (K)'
    CALL write_surf(hselect,hprogram,yrecfm,sb%XT(:,jl),iresp,hcomment=ycomment)
  END DO
  !
  !* humidity in SBL
  !
  DO jl=1,sb%NLVL
    WRITE(yrecfm,yformat) trim(ybase)//'_Q',jl
    ycomment='humidity at SBL levels (kg/m3)'
    CALL write_surf(hselect,hprogram,yrecfm,sb%XQ(:,jl),iresp,hcomment=ycomment)
  END DO
  !
  !* Tke in SBL
  !
  DO jl=1,sb%NLVL
    WRITE(yrecfm,yformat) trim(ybase)//'_E',jl
    ycomment='Tke at SBL levels (m2/s2)'
    CALL write_surf(hselect,hprogram,yrecfm,sb%XTKE(:,jl),iresp,hcomment=ycomment)
  END DO
  !
  !* Monin-Obhukov length
  !
  IF (hsurf=="TOWN  ") THEN
    !
    DO jl=1,sb%NLVL
      WRITE(yrecfm,'(A10,I2.2)') trim(ybase)//'_MO',jl
      ycomment='Monin-Obukhov length (m)'
      CALL write_surf(hselect,hprogram,yrecfm,sb%XLMO(:,jl),iresp,hcomment=ycomment)
    END DO 
    !  
    !* mixing length
    !
    IF (ASSOCIATED(sb%XLM)) THEN
      DO jl=1,sb%NLVL
        WRITE(yrecfm,'(A10,I2.2)') trim(ybase)//'_LM',jl
        ycomment='mixing length (m)'
        CALL write_surf(hselect,hprogram,yrecfm,sb%XLM(:,jl),iresp,hcomment=ycomment)
     END DO
    END IF
    !
    !* dissipative length
    !
    IF (ASSOCIATED(sb%XLEPS)) THEN
      DO jl=1,sb%NLVL
        WRITE(yrecfm,'(A10,I2.2)') trim(ybase)//'_LE',jl
        ycomment='mixing length (m)'
        CALL write_surf(hselect,hprogram,yrecfm,sb%XLEPS(:,jl),iresp,hcomment=ycomment)
      END DO
    END IF 
    !   
  ELSE
    yrecfm=trim(ybase)//'_LMO     '
    CALL write_surf(hselect,hprogram,yrecfm,sb%XLMO(:,sb%NLVL),iresp,hcomment=ycomment)
  ENDIF
  !
  !* Air pressure in SBL
  !
  DO jl=1,sb%NLVL
    WRITE(yrecfm,yformat) trim(ybase)//'_P',jl
    ycomment='Pressure at SBL levels (Pa)'
    CALL write_surf(hselect,hprogram,yrecfm,sb%XP(:,jl),iresp,hcomment=ycomment)
  END DO
  !
ENDIF
!
IF (lhook) CALL dr_hook('WRITESURF_SBL_N',1,zhook_handle)
!
!
!-------------------------------------------------------------------------------
!
END SUBROUTINE writesurf_sbl_n