src/SURFEX/writesurf_flake_sbln.F90

   1 !SURFEX_LIC Copyright 1994-2014 Meteo-France
   2 !SURFEX_LIC This is part of the SURFEX software governed by the CeCILL-C  licence
   3 !SURFEX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
   4 !SURFEX_LIC for details. version 1.
   5 !     #########
   6       SUBROUTINE WRITESURF_FLAKE_SBL_n(HPROGRAM,HWRITE)
   7 !     ####################################
   8 !
   9 !!****  *WRITE_FLAKE_n* - writes FLAKE fields
  10 !!
  11 !!    PURPOSE
  12 !!    -------
  13 !!
  14 !!**  METHOD
  15 !!    ------
  16 !!
  17 !!    EXTERNAL
  18 !!    --------
  19 !!
  20 !!
  21 !!    IMPLICIT ARGUMENTS
  22 !!    ------------------
  23 !!
  24 !!    REFERENCE
  25 !!    ---------
  26 !!
  27 !!
  28 !!    AUTHOR
  29 !!    ------
  30 !!      V. Masson   *Meteo France*
  31 !!
  32 !!    MODIFICATIONS
  33 !!    -------------
  34 !!      Original    01/2003
  35 !!      E. Martin   01/2012 avoid write of XUNDEF fields
  36 !-------------------------------------------------------------------------------
  37 !
  38 !*       0.    DECLARATIONS
  39 !              ------------
  40 !
  41 !
  42 !
  43 USE MODD_FLAKE_n,       ONLY : LSBL
  44 USE MODD_FLAKE_SBL_n,   ONLY : NLVL, XZ, XU, XT, XQ, XTKE, XLMO, XP
  45 !
  46 USE MODI_WRITE_SURF
  47 !
  48 !
  49 USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
  50 USE PARKIND1  ,ONLY : JPRB
  51 !
  52 IMPLICIT NONE
  53 !
  54 !*       0.1   Declarations of arguments
  55 !              -------------------------
  56 !
  57  CHARACTER(LEN=6),  INTENT(IN)  :: HPROGRAM ! program calling
  58  CHARACTER(LEN=3),    INTENT(IN)  :: HWRITE    ! 'PREP' : does not write SBL XUNDEF fields
  59 !                                             ! 'ALL' : all fields are written
  60 !*       0.2   Declarations of local variables
  61 !              -------------------------------
  62 !
  63 INTEGER           :: IRESP          ! IRESP  : return-code if a problem appears
  64  CHARACTER(LEN=12) :: YRECFM         ! Name of the article to be read
  65  CHARACTER(LEN=100):: YCOMMENT       ! Comment string
  66 !
  67 INTEGER :: JLAYER  ! loop counter on layers
  68 REAL(KIND=JPRB) :: ZHOOK_HANDLE
  69 !-------------------------------------------------------------------------------
  70 !
  71 !*       1.     Prognostic fields:
  72 !               -----------------
  73 !
  74 !* flag to define if SBL is computed
  75 !
  76 IF (LHOOK) CALL DR_HOOK('WRITESURF_FLAKE_SBL_N',0,ZHOOK_HANDLE)
  77 YRECFM='WAT_SBL'
  78 YCOMMENT='flag to use SBL levels'
  79  CALL WRITE_SURF(HPROGRAM,YRECFM,LSBL,IRESP,HCOMMENT=YCOMMENT)
  80 !
  81 IF (.NOT. LSBL .AND. LHOOK) CALL DR_HOOK('WRITESURF_FLAKE_SBL_N',1,ZHOOK_HANDLE)
  82 IF (.NOT. LSBL) RETURN
  83 !
  84 !* number of levels
  85 !
  86 YRECFM='WAT_SBL_LVL'
  87 YCOMMENT='number of SBL levels'
  88  CALL WRITE_SURF(HPROGRAM,YRECFM,NLVL,IRESP,HCOMMENT=YCOMMENT)
  89 !
  90 !* altitudes
  91 !
  92 DO JLAYER=1,NLVL
  93   WRITE(YRECFM,'(A9,I2.2,A1)') 'WAT_SBL_Z',JLAYER,' '
  94   YCOMMENT='altitudes of SBL levels (m)'
  95   CALL WRITE_SURF(HPROGRAM,YRECFM,XZ(:,JLAYER),IRESP,HCOMMENT=YCOMMENT)
  96 END DO
  97 !
  98 IF (HWRITE/='PRE') THEN
  99   !
 100   !* wind in SBL
 101   !
 102   DO JLAYER=1,NLVL
 103     WRITE(YRECFM,'(A9,I2.2,A1)') 'WAT_SBL_U',JLAYER,' '
 104     YCOMMENT='wind at SBL levels (m/s)'
 105     CALL WRITE_SURF(HPROGRAM,YRECFM,XU(:,JLAYER),IRESP,HCOMMENT=YCOMMENT)
 106   END DO
 107   !
 108   !* temperature in SBL
 109   !
 110   DO JLAYER=1,NLVL
 111     WRITE(YRECFM,'(A9,I2.2,A1)') 'WAT_SBL_T',JLAYER,' '
 112     YCOMMENT='temperature at SBL levels (K)'
 113     CALL WRITE_SURF(HPROGRAM,YRECFM,XT(:,JLAYER),IRESP,HCOMMENT=YCOMMENT)
 114   END DO
 115   !
 116   !* humidity in SBL
 117   !
 118   DO JLAYER=1,NLVL
 119     WRITE(YRECFM,'(A9,I2.2,A1)') 'WAT_SBL_Q',JLAYER,' '
 120     YCOMMENT='humidity at SBL levels (kg/m3)'
 121     CALL WRITE_SURF(HPROGRAM,YRECFM,XQ(:,JLAYER),IRESP,HCOMMENT=YCOMMENT)
 122   END DO
 123   !
 124   !* Tke in SBL
 125   !
 126   DO JLAYER=1,NLVL
 127     WRITE(YRECFM,'(A9,I2.2,A1)') 'WAT_SBL_E',JLAYER,' '
 128     YCOMMENT='Tke at SBL levels (m2/s2)'
 129     CALL WRITE_SURF(HPROGRAM,YRECFM,XTKE(:,JLAYER),IRESP,HCOMMENT=YCOMMENT)
 130   END DO
 131   !
 132   !* Monin-Obhukov length
 133   !
 134   YRECFM='WAT_SBL_LMO     '
 135   CALL WRITE_SURF(HPROGRAM,YRECFM,XLMO(:),IRESP,HCOMMENT=YCOMMENT)
 136   !
 137   !* Air pressure in SBL
 138   !
 139   DO JLAYER=1,NLVL
 140     WRITE(YRECFM,'(A9,I2.2,A1)') 'WAT_SBL_P',JLAYER,' '
 141     YCOMMENT='Pressure at SBL levels (Pa)'
 142     CALL WRITE_SURF(HPROGRAM,YRECFM,XP(:,JLAYER),IRESP,HCOMMENT=YCOMMENT)
 143   END DO
 144   !
 145 ENDIF
 146 !
 147 IF (LHOOK) CALL DR_HOOK('WRITESURF_FLAKE_SBL_N',1,ZHOOK_HANDLE)
 148 !
 149 !
 150 !-------------------------------------------------------------------------------
 151 !
 152 END SUBROUTINE WRITESURF_FLAKE_SBL_n