get_surf_varn.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 get_surf_var_n (FM, IM, SM, TM, WM, DGO, D, UG, U, USS,        &
                                 HPROGRAM, KI, KS,PSEA, PWATER, PNATURE, PTOWN, &
                                 PT2M, PQ2M, PQS, PZ0, PZ0H, PZ0EFF, PZ0_SEA,   &
                                 PZ0_WATER, PZ0_NATURE, PZ0_TOWN, PZ0H_SEA,     &
                                 PZ0H_WATER, PZ0H_NATURE, PZ0H_TOWN, PQS_SEA,   &
                                 PQS_WATER, PQS_NATURE, PQS_TOWN, PPSNG, PPSNV, &
                                 PZS, PSERIES, PTWSNOW, PSSO_STDEV, PLON, PLAT, &
                                 PBARE, PLAI_TREE, PH_TREE                    )  
!     #######################################################################
!
!!****  *GET_SURF_VAR_n* - gets some surface fields on atmospheric grid
!!
!!    PURPOSE
!!    -------
!!
!!    This program returns some surface variables neede by the atmosphere
!!
!!**  METHOD
!!    ------
!!
!!    Several functions are called in order to initialize surface variables
!!    needed by the atmospheric model. These functions fill the required arrays by
!!    the diagnosed values computed during the run. Since all arrays are optional,
!!    this program may be called with any of the arguments described above.
!!
!!    EXTERNAL
!!    --------
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------
!!
!!    REFERENCE
!!    ---------
!!
!!    AUTHOR
!!    ------
!!      P. Le Moigne   *Meteo France*
!!
!!    MODIFICATIONS
!!    -------------
!!      Original    02/2006
!       S. Riette   06/2010 PSSO_STDEV and PTWSNOW added
!       B. Decharme 09/2012 Argument added in GET_FLUX_n
!       B. Decharme 05/2013 Argument added in GET_FLUX_n for debug in ARP/AL/AR
!-------------------------------------------------------------------------------
!
!*       0.    DECLARATIONS
!              ------------
!
USE modd_surfex_n, ONLY : flake_model_t, isba_model_t, seaflux_model_t, &
                          teb_model_t, watflux_model_t
USE modd_diag_n, ONLY : diag_t, diag_options_t
USE modd_surf_atm_grid_n, ONLY : surf_atm_grid_t
USE modd_surf_atm_n, ONLY : surf_atm_t
USE modd_sso_n, ONLY : sso_t
!
USE modd_surf_par,     ONLY : xundef
USE modi_get_luout
USE modi_get_flux_n
USE modi_get_frac_n
USE modi_get_z0_n
USE modi_get_qs_n
USE modi_get_var_sea_n
USE modi_get_var_water_n
USE modi_get_var_nature_n
USE modi_get_var_town_n
USE modi_get_zs_n
USE modi_get_series_n
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
USE modi_abor1_sfx
USE modi_get_sso_stdev_n
USE modi_get_1d_mask
USE modi_get_coord_n
USE modi_get_veg_n
!
IMPLICIT NONE
!
!*       0.1   Declarations of arguments
!              -------------------------
!
TYPE(flake_model_t), INTENT(INOUT) :: FM
TYPE(isba_model_t), INTENT(INOUT) :: IM
TYPE(seaflux_model_t), INTENT(INOUT) :: SM
TYPE(teb_model_t), INTENT(INOUT) :: TM
TYPE(watflux_model_t), INTENT(INOUT) :: WM
!
TYPE(diag_options_t), INTENT(INOUT) :: DGO
TYPE(diag_t), INTENT(INOUT) :: D
TYPE(surf_atm_grid_t), INTENT(INOUT) :: UG
TYPE(surf_atm_t), INTENT(INOUT) :: U
TYPE(sso_t), INTENT(INOUT) :: USS
!
 CHARACTER(LEN=6),   INTENT(IN)            :: HPROGRAM    
INTEGER,            INTENT(IN)            :: KI         ! number of points
INTEGER,            INTENT(IN)            :: KS         ! number of points
!
REAL, DIMENSION(:), INTENT(OUT), OPTIONAL :: PSEA       ! sea fraction
REAL, DIMENSION(:), INTENT(OUT), OPTIONAL :: PWATER     ! water fraction
REAL, DIMENSION(:), INTENT(OUT), OPTIONAL :: PNATURE    ! nature fraction
REAL, DIMENSION(:), INTENT(OUT), OPTIONAL :: PTOWN      ! town fraction
!
REAL, DIMENSION(:), INTENT(OUT), OPTIONAL :: PT2M       ! Air temperature at 2 meters         (K)
REAL, DIMENSION(:), INTENT(OUT), OPTIONAL :: PQ2M       ! Air humidity at 2 meters            (kg/kg)
!
REAL, DIMENSION(:), INTENT(OUT), OPTIONAL :: PQS
REAL, DIMENSION(:), INTENT(OUT), OPTIONAL :: PZ0        ! surface roughness length            (m)
REAL, DIMENSION(:), INTENT(OUT), OPTIONAL :: PZ0H       ! surface roughness length for heat   (m)
REAL, DIMENSION(:), INTENT(OUT), OPTIONAL :: PZ0EFF     ! effective roughness length for heat (m)
!
REAL, DIMENSION(:), INTENT(OUT), OPTIONAL :: PZ0_SEA    ! surface roughness length over sea   (m)
REAL, DIMENSION(:), INTENT(OUT), OPTIONAL :: PZ0_WATER  ! surface roughness length over water (m)
REAL, DIMENSION(:), INTENT(OUT), OPTIONAL :: PZ0_NATURE ! surface roughness length over nature(m)
REAL, DIMENSION(:), INTENT(OUT), OPTIONAL :: PZ0_TOWN   ! surface roughness length over town  (m)
!
REAL, DIMENSION(:), INTENT(OUT), OPTIONAL :: PZ0H_SEA    ! surface roughness length for heat over sea   (m)
REAL, DIMENSION(:), INTENT(OUT), OPTIONAL :: PZ0H_WATER  ! surface roughness length for heat over water (m)
REAL, DIMENSION(:), INTENT(OUT), OPTIONAL :: PZ0H_NATURE ! surface roughness length for heat over nature(m)
REAL, DIMENSION(:), INTENT(OUT), OPTIONAL :: PZ0H_TOWN   ! surface roughness length for heat over town  (m)
!
REAL, DIMENSION(:), INTENT(OUT), OPTIONAL :: PQS_SEA    ! surface humidity over sea           (kg/kg)
REAL, DIMENSION(:), INTENT(OUT), OPTIONAL :: PQS_WATER  ! surface humidity over water         (kg/kg)
REAL, DIMENSION(:), INTENT(OUT), OPTIONAL :: PQS_NATURE ! surface humidity over nature        (kg/kg)
REAL, DIMENSION(:), INTENT(OUT), OPTIONAL :: PQS_TOWN   ! surface humidity over town          (kg/kg)
!
REAL, DIMENSION(:), INTENT(OUT), OPTIONAL :: PPSNG      ! snow fraction over ground           (-)        
REAL, DIMENSION(:), INTENT(OUT), OPTIONAL :: PPSNV      ! snow fraction over vegetation       (-)
!
REAL, DIMENSION(:), INTENT(OUT), OPTIONAL :: PZS        ! surface orography                   (m)    
!
REAL, DIMENSION(:,:), INTENT(OUT), OPTIONAL :: PSERIES  ! any surface field for which 
!                                                       ! mesoNH series are required
REAL, DIMENSION(:), INTENT(OUT), OPTIONAL :: PTWSNOW    ! Snow total reservoir
REAL, DIMENSION(:), INTENT(OUT), OPTIONAL :: PSSO_STDEV ! S.S.O. standard deviation           (m)
!
REAL, DIMENSION(:), INTENT(OUT), OPTIONAL :: PLON       ! longitude
REAL, DIMENSION(:), INTENT(OUT), OPTIONAL :: PLAT       ! latitude
!
REAL, DIMENSION(:), INTENT(OUT), OPTIONAL :: PBARE      ! bare soil fraction on grid mesh     (-)
REAL, DIMENSION(:), INTENT(OUT), OPTIONAL :: PLAI_TREE       ! Leaf Area Index    on grid mesh     (-)
REAL, DIMENSION(:), INTENT(OUT), OPTIONAL :: PH_TREE        ! Height of trees    on grid mesh     (-)
!
!-------------------------------------------------------------------------------
!
!
!*       0.2   Declarations of local variables
!              -------------------------------
!
REAL, DIMENSION(KI)    :: ZFIELD1, ZFIELD2, ZFIELD3, ZFIELD4, ZFIELD5, ZFIELD6
REAL, DIMENSION(KI)    :: ZFIELD7, ZFIELD8
REAL, DIMENSION(KI,KS) :: ZSERIES
INTEGER, DIMENSION(KI) :: IMASK
!
INTEGER :: KI_SEA    ! dimension of sea tile
INTEGER :: KI_WATER  ! dimension of water tile
INTEGER :: KI_NATURE ! dimension of nature tile
INTEGER :: KI_TOWN   ! dimension of town tile
!
INTEGER                            :: JI           ! loop index over tiles
INTEGER                            :: ILUOUT       ! unit number
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!
!-------------------------------------------------------------------------------
!
!*   0. Logical unit for writing out
!
IF (lhook) CALL dr_hook('GET_SURF_VAR_N',0,zhook_handle)
 CALL get_luout(hprogram,iluout)
!
!*   1. Fraction of each tile
!
IF (PRESENT(psea) .OR. PRESENT(pwater) .OR. PRESENT(pnature) .OR. PRESENT(ptown)) THEN
   !
   CALL get_frac_n(u, hprogram, ki, zfield1, zfield2, zfield3, zfield4)
   !
   IF (PRESENT(psea)   ) psea    = zfield1
   IF (PRESENT(pwater) ) pwater  = zfield2
   IF (PRESENT(pnature)) pnature = zfield3
   IF (PRESENT(ptown)  ) ptown   = zfield4
   !
END IF
!
!-------------------------------------------------------------------------------
!
!*   2. Parameters at 2 meters
!
IF ( PRESENT(pt2m) .OR. PRESENT(pq2m) ) THEN
   !
   CALL get_flux_n(dgo, d, hprogram, ki, &
                   zfield1, zfield1, zfield1, zfield1, zfield1, zfield2, &
                   zfield3, zfield4, zfield4, zfield4, zfield4, zfield4, &
                   zfield4, zfield4, zfield4                             )
   !
   IF (PRESENT(pt2m)   ) pt2m    = zfield2
   IF (PRESENT(pq2m)   ) pq2m    = zfield3
   !
END IF
!
!-------------------------------------------------------------------------------
!
!*   3. Roughness lengths
!
IF ( PRESENT(pz0) .OR. PRESENT(pz0h) ) THEN
   !
   CALL get_z0_n(dgo, d, hprogram, ki, zfield1, zfield2)
   !
   IF (PRESENT(pz0)    ) pz0    = zfield1
   IF (PRESENT(pz0h)   ) pz0h   = zfield2
   !
END IF
!
!-------------------------------------------------------------------------------
!
!*   3. Specific humidity
!
IF ( PRESENT(pqs) ) THEN
   !
   CALL get_qs_n(dgo, d, hprogram, ki, pqs)
   !
END IF
!
!-------------------------------------------------------------------------------
!
!*   4. Surface humidity for each tile (qs is not aggregated)
!
IF ( PRESENT(pqs_sea) .OR. PRESENT(pz0_sea) .OR. PRESENT(pz0h_sea) ) THEN
   !
   ! Get parameters over sea tile
   !
   IF ( .NOT.PRESENT(psea) ) THEN
      !
      CALL abor1_sfx('GET_SURF_VARN: ARGUMENT PSEA MISSING')
      !
   ENDIF
   !
   ki_sea  = count(psea(:) > 0.0)
   !
   imask(:)=0
   CALL get_1d_mask(ki_sea, ki, psea, imask(1:ki_sea))
   !
   CALL get_var_sea_n(sm%SD%O, sm%SD%D, &
                      hprogram, ki_sea, zfield1(1:ki_sea), zfield2(1:ki_sea), zfield3(1:ki_sea))
   !
   IF(PRESENT(pqs_sea))THEN
      pqs_sea(:) = xundef
      DO ji = 1, ki_sea
         pqs_sea(imask(ji))  = zfield1(ji)
      END DO
   ENDIF
   !   
   IF(PRESENT(pz0_sea))THEN
      pz0_sea(:) = xundef
      DO ji = 1, ki_sea
         pz0_sea(imask(ji))  = zfield2(ji)
      END DO
   ENDIF
   !
   IF(PRESENT(pz0h_sea))THEN
      pz0h_sea(:) = xundef
      DO ji = 1, ki_sea
         pz0h_sea(imask(ji)) = zfield3(ji)
      END DO
   ENDIF
   !
ENDIF
   !
   !-------------------------------------------------------------------------------
   !
IF ( PRESENT(pqs_water) .OR. PRESENT(pz0_water) .OR. PRESENT(pz0h_water) ) THEN
   !
   ! Get parameters over water tile
   !
   IF ( .NOT.PRESENT(pwater) ) THEN
      CALL abor1_sfx('GET_SURF_VARN: ARGUMENT PWATER MISSING')
   ENDIF
   !
   ki_water  = count(pwater(:) > 0.0)
   !
   imask(:)=0
   CALL get_1d_mask(ki_water, ki, pwater, imask(1:ki_water))
   !
   CALL get_var_water_n(fm%DFO, fm%DF, wm%DWO, wm%DW, &
                        hprogram, ki_water, u%CWATER, zfield1(1:ki_water), &
                        zfield2(1:ki_water), zfield3(1:ki_water))
   !
   IF(PRESENT(pqs_water))THEN
      pqs_water(:) = xundef
      DO ji = 1, ki_water
         pqs_water(imask(ji))  = zfield1(ji)
      END DO
   ENDIF
   !   
   IF(PRESENT(pz0_water))THEN
      pz0_water(:) = xundef
      DO ji = 1, ki_water
         pz0_water(imask(ji))  = zfield2(ji)
      END DO
   ENDIF
   !
   IF(PRESENT(pz0h_water))THEN
      pz0h_water(:) = xundef
      DO ji = 1, ki_water
         pz0h_water(imask(ji)) = zfield3(ji)
      END DO
   ENDIF
   !
ENDIF
   !
   !-------------------------------------------------------------------------------
   !
IF ( PRESENT(pqs_nature) .OR. PRESENT(ppsng) .OR. PRESENT(ppsnv) .OR.  PRESENT(pz0eff).OR. &
     PRESENT(ptwsnow) .OR. PRESENT(pbare) .OR. PRESENT(plai_tree) .OR. PRESENT(ph_tree) ) THEN
   !
   ! Get parameters over nature tile
   !
   !
   IF ( .NOT.PRESENT(pnature) ) THEN
      !
      CALL abor1_sfx('GET_SURF_VARN: ARGUMENT PNATURE MISSING')
      !
   ENDIF
   !   
   ki_nature = count(pnature(:) > 0.0)
   !
   imask(:)=0
   CALL get_1d_mask(ki_nature, ki, pnature, imask(1:ki_nature))
   !
   IF (ki_nature>0) THEN
     CALL get_var_nature_n(im%S, im%ID%O, im%ID%D, im%ID%DM, hprogram, ki_nature, &
                           zfield1(1:ki_nature), zfield2(1:ki_nature), zfield3(1:ki_nature), &
                           zfield4(1:ki_nature), zfield5(1:ki_nature), zfield6(1:ki_nature), &
                           zfield7(1:ki_nature), zfield8(1:ki_nature))
   ENDIF
   !
   IF(PRESENT(pqs_nature))THEN
     pqs_nature    (:) = xundef
     DO ji = 1, ki_nature
       pqs_nature(imask(ji))  = zfield1(ji)
     END DO
   ENDIF
   !   
   IF(PRESENT(pz0_nature))THEN
     pz0_nature    (:) = xundef
     DO ji = 1, ki_nature
       pz0_nature(imask(ji))  = zfield5(ji)
     END DO
   ENDIF
   !
   IF(PRESENT(pz0h_nature))THEN
     pz0h_nature   (:) = xundef
     DO ji = 1, ki_nature
       pz0h_nature(imask(ji)) = zfield6(ji)
     END DO
   ENDIF
   !  
   IF (PRESENT(ppsng)) THEN
     ppsng      (:) = xundef
     DO ji = 1, ki_nature
       ppsng(imask(ji)) = zfield2(ji)
     END DO
   ENDIF
   !
   IF (PRESENT(ppsnv)) THEN
     ppsnv      (:) = xundef
     DO ji = 1, ki_nature
       ppsnv(imask(ji)) = zfield3(ji)
     END DO
   ENDIF
   !
   IF ( PRESENT(pz0eff) ) THEN
     pz0eff     (:) = xundef
     DO ji = 1, ki_nature
       pz0eff(imask(ji)) = zfield4(ji)
     END DO
   ENDIF
   !
   IF(PRESENT(ptwsnow)) THEN
     ptwsnow    (:) = xundef
     DO ji = 1, ki_nature
       ptwsnow(imask(ji)) = zfield7(ji)
     ENDDO
   ENDIF
   !
   !* bare soil fraction
   !
   IF(PRESENT(pbare)) THEN
     pbare    (:) = xundef
     DO ji = 1, ki_nature
       pbare(imask(ji)) = zfield8(ji)
     ENDDO
     pbare(:) = pbare(:) * u%XNATURE(:) ! averages bare soil fraction on whole grid mesh
   ENDIF
   !
   !*   LAI and height of trees
   !
   IF (PRESENT(plai_tree) .OR. PRESENT(ph_tree) ) THEN
     !
     CALL get_veg_n(hprogram, ki_nature, u, im%O, im%S, im%NP, im%NPE, zfield1(1:ki_nature), zfield2(1:ki_nature))
     !
     IF (PRESENT(plai_tree)) THEN
       plai_tree(:) = xundef
       DO ji = 1, ki_nature
         plai_tree(imask(ji)) = zfield1(ji)
       ENDDO
       plai_tree(:) = plai_tree(:) * u%XNATURE(:) ! averages tree LAI on whole grid mesh
     END IF
     !
     IF (PRESENT(ph_tree)) THEN
       ph_tree(:) = 0.
       DO ji = 1, ki_nature
         ph_tree(imask(ji)) = zfield2(ji)
       ENDDO
     END IF
     !
   END IF   
   !   
ENDIF
   !
   !-------------------------------------------------------------------------------
   !
IF ( PRESENT(pqs_town) .OR. PRESENT(pz0_town) .OR. PRESENT(pz0h_town) ) THEN
   !
   ! Get parameters over town tile
   !
   IF ( .NOT.PRESENT(ptown) ) THEN
      !
      CALL abor1_sfx('GET_SURF_VARN: ARGUMENT PTOWN MISSING')
      !
   ENDIF
   !
   ki_town   = count(ptown(:) > 0.0)
   !
   imask(:)=0
   CALL get_1d_mask(ki_town, ki, ptown, imask(1:ki_town))
   !
   CALL get_var_town_n(tm%TD%O, tm%TD%D, hprogram, ki_town, &
                       zfield1(1:ki_town), zfield2(1:ki_town), zfield3(1:ki_town))
   !
   IF(PRESENT(pqs_town))THEN
      pqs_town(:) = xundef
      DO ji = 1, ki_town
         pqs_town(imask(ji))  = zfield1(ji)
      END DO
   ENDIF
   !   
   IF(PRESENT(pz0_town))THEN
      pz0_town(:) = xundef
      DO ji = 1, ki_town
         pz0_town(imask(ji))  = zfield2(ji)
      END DO
   ENDIF
   !
   IF(PRESENT(pz0h_town))THEN
      pz0h_town(:) = xundef
      DO ji = 1, ki_town
         pz0h_town(imask(ji)) = zfield3(ji)
      END DO
   ENDIF
   !
END IF
!
!*   5. Orography
!
IF (PRESENT(pzs)) THEN
   !
   CALL get_zs_n(u, hprogram, ki, zfield1)
   !
   pzs = zfield1 
   !
END IF
!
!*   6. Series
!
IF (PRESENT(pseries)) THEN
   !
   IF ( .NOT.PRESENT(pwater) ) THEN
      CALL abor1_sfx('GET_SURF_VARN: ARGUMENT PWATER REQUIRED FOR WATER SERIES')
   ENDIF        
   !
   IF ( count(pwater(:) > 0.0) > 0.0 ) THEN
     !   
     CALL get_series_n(fm%F, hprogram, ki, ks, zseries)
     !
     pseries = zseries
     !
   ELSE
     pseries = xundef
   ENDIF
   !
END IF
!
!*   7. Subgrid orography standard deviation
!
IF (PRESENT(psso_stdev)) THEN
   !
   CALL get_sso_stdev_n(uss, 'ASCII ', ki, zfield1)
   !
   psso_stdev = zfield1
   !
END IF
!
!*   8. Longitude et Latitude
!
IF (PRESENT(plon).OR.PRESENT(plat)) THEN
   !
   CALL get_coord_n(ug, hprogram, ki, zfield1, zfield2)
   !
   IF (PRESENT(plon)   ) plon    = zfield1
   IF (PRESENT(plat)   ) plat    = zfield2
   !
END IF
!
IF (lhook) CALL dr_hook('GET_SURF_VAR_N',1,zhook_handle)
!==============================================================================
!
END SUBROUTINE get_surf_var_n