prep_isba_buffer.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 prep_isba_buffer (IG, U, &
                             hprogram,hsurf,kluout,pfield)
!     #################################################################################
!
!!****  *PREP_ISBA_BUFFER* - initializes ISBA fields from operational BUFFER
!!
!!    PURPOSE
!!    -------
!
!!**  METHOD
!!    ------
!!
!!    REFERENCE
!!    ---------
!!      
!!
!!    AUTHOR
!!    ------
!!     S. Malardel 
!!
!!    MODIFICATIONS
!!    -------------
!!      Original    03/2005
!!------------------------------------------------------------------
!

!
!
USE modd_isba_grid_n, ONLY : isba_grid_t
USE modd_surf_atm_n, ONLY : surf_atm_t
!
USE mode_read_buffer
!
USE modd_type_date_surf
!
USE modi_prep_buffer_grid
USE modi_interp_grid_nat
!
USE modd_prep,           ONLY : cinterp_type
USE modd_prep_isba,      ONLY : xgrid_soil, xwr_def
USE modd_surf_par,       ONLY : xundef
USE modd_grid_buffer,    ONLY : nni
USE modn_prep_isba,      ONLY : lextrap_tg,lextrap_wg,lextrap_wgi
#ifdef SFX_ARO
USE modi_oi_hor_extrapol_surf
#endif
USE modi_pack_same_rank
USE modi_unpack_same_rank
USE modi_abor1_sfx
!
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
!*      0.1    declarations of arguments
!
!
TYPE(isba_grid_t), INTENT(INOUT) :: ig
TYPE(surf_atm_t), INTENT(INOUT) :: u
!
 CHARACTER(LEN=6),   INTENT(IN)  :: hprogram  ! program calling surf. schemes
 CHARACTER(LEN=7),   INTENT(IN)  :: hsurf     ! type of field
INTEGER,            INTENT(IN)  :: kluout    ! logical unit of output listing
REAL,DIMENSION(:,:,:), POINTER    :: pfield    ! field to interpolate horizontally
!
!*      0.2    declarations of local variables
!
TYPE (date_time)                :: tztime_buf    ! current date and time
 CHARACTER(LEN=6)                 :: yinmodel       ! model from which buffer originates
REAL, DIMENSION(:,:), POINTER   :: zfield         ! field read
REAL, DIMENSION(:),   POINTER   :: zfield1d       ! field read
REAL, DIMENSION(:,:), POINTER   :: zd             ! depth of field in the soil
REAL,DIMENSION(:),POINTER        :: zlsm
REAL,DIMENSION(:),POINTER        :: zalt
REAL,ALLOCATABLE,DIMENSION(:)    :: zfield_ep
REAL,ALLOCATABLE,DIMENSION(:)    :: zfield_ep_in
REAL,ALLOCATABLE,DIMENSION(:)    :: zlsm_nature
REAL,ALLOCATABLE,DIMENSION(:)    :: zalt_nature
LOGICAL,ALLOCATABLE,DIMENSION(:) :: ointerp
INTEGER                          :: ilayer,ii
REAL(KIND=JPRB) :: zhook_handle
!
!-------------------------------------------------------------------------------------
!
!*      1.     Reading of grid
!              ---------------
!
IF (lhook) CALL dr_hook('PREP_ISBA_BUFFER',0,zhook_handle)
 CALL prep_buffer_grid(kluout,yinmodel,tztime_buf)

!
!*      2.     Reading of field
!              ----------------
!
!*      3.     Transformation into physical quantity to be interpolated
!              --------------------------------------------------------
!
SELECT CASE(hsurf)
!
!*      3.1    Profile of temperature in the soil
!
  CASE('TG    ')
     !* reading of the profile and its depth definition
     SELECT CASE(yinmodel)
     CASE('ALADIN')
        CALL read_buffer_tg(kluout,yinmodel,zfield,zd)
        IF ( lextrap_tg ) THEN
          IF ( SIZE(u%NR_NATURE) /= u%NSIZE_NATURE ) THEN
            CALL abor1_sfx('ABORT: PREP_ISBA_BUFFER - DIFFERENT SIZES')
          ELSE
            ! Allocate working arrays
            ALLOCATE(zfield_ep(u%NSIZE_NATURE))
            ALLOCATE(zfield_ep_in(u%NSIZE_NATURE))
            ALLOCATE(ointerp(u%NSIZE_NATURE))
            ALLOCATE(zlsm_nature(u%NSIZE_NATURE))
            ALLOCATE(zalt_nature(u%NSIZE_NATURE))

            ! Read LSM and ZS
            CALL read_buffer_land_mask(kluout,yinmodel,zlsm)
            CALL read_buffer_zs(kluout,yinmodel,zalt)

            ! Pack nature points to reduce dimension to nsize_nature
            CALL pack_same_rank(u%NR_NATURE,zlsm,zlsm_nature)
            CALL pack_same_rank(u%NR_NATURE,zalt,zalt_nature)

            ! Do extrapolations in all layers
            DO ilayer=1,SIZE(zfield,2)
              WRITE(kluout,*) 'Extrapolating TG from nearest land point in points where LSM < 0.5. LAYER:',ilayer

              ! Pack nature points to reduce dimension
              CALL pack_same_rank(u%NR_NATURE,zfield(:,ilayer),zfield_ep(:))
              ! Set values to be extrapolated
              ointerp=.false.
              DO ii=1,u%NSIZE_NATURE
                IF ( zlsm_nature(ii) < 0.5 ) THEN
                  ointerp(ii)   = .true.
                  zfield_ep(ii) = xundef
                ENDIF
              ENDDO

              zfield_ep_in(:) = zfield_ep(:)
#ifdef SFX_ARO
              CALL oi_hor_extrapol_surf(u%NSIZE_NATURE,ig%XLAT,ig%XLON,zfield_ep_in(:), &
                                        ig%XLAT,ig%XLON,zfield_ep(:),ointerp,pzs=zalt,ndim2=10)
#endif

              ! Unpack to full rank
              CALL unpack_same_rank(u%NR_NATURE,zfield_ep(:),zfield(:,ilayer))
            ENDDO
            DEALLOCATE(zfield_ep)
            DEALLOCATE(zfield_ep_in)
            DEALLOCATE(zlsm_nature)
            DEALLOCATE(zalt_nature)
            DEALLOCATE(ointerp)
          ENDIF
        ENDIF 
     END SELECT
     
     CALL soil_profile_buffer

  CASE('WG    ')
     !* reading of the profile and its depth definition
     SELECT CASE(yinmodel)
     CASE('ARPEGE','ALADIN','MOCAGE')
        CALL read_buffer_wg(kluout,yinmodel,zfield,zd)
        IF ( lextrap_wg ) THEN
          IF ( SIZE(u%NR_NATURE) /= u%NSIZE_NATURE ) THEN
            CALL abor1_sfx('ABORT: PREP_ISBA_BUFFER - DIFFERENT SIZES')
          ELSE
            ! Allocate working arrays
            ALLOCATE(zfield_ep(u%NSIZE_NATURE))
            ALLOCATE(zfield_ep_in(u%NSIZE_NATURE))
            ALLOCATE(ointerp(u%NSIZE_NATURE))
            ALLOCATE(zlsm_nature(u%NSIZE_NATURE))

            ! Read LSM
            CALL read_buffer_land_mask(kluout,yinmodel,zlsm)

            ! Pack nature points to reduce dimension to nsize_nature
            CALL pack_same_rank(u%NR_NATURE,zlsm,zlsm_nature)
   
            ! Do extrapolations in all layers
            DO ilayer=1,SIZE(zfield,2)
              WRITE(kluout,*) 'Extrapolating WG from nearest land point in points where LSM < 0.5. LAYER:',ilayer

              ! Pack nature points to reduce dimension
              CALL pack_same_rank(u%NR_NATURE,zfield(:,ilayer),zfield_ep(:))
              ! Set values to be extrapolated
              ointerp=.false.
              
              DO ii=1,u%NSIZE_NATURE
                IF ( zlsm_nature(ii) < 0.5 ) THEN
                  ointerp(ii)   = .true.
                  zfield_ep(ii) = xundef
                ENDIF
              ENDDO

              zfield_ep_in(:) = zfield_ep
#ifdef SFX_ARO
              CALL oi_hor_extrapol_surf(u%NSIZE_NATURE,ig%XLAT,ig%XLON,zfield_ep_in(:), &
                                        ig%XLAT,ig%XLON,zfield_ep(:),ointerp,ndim2=10)
#endif

              ! Unpack to full rank
              CALL unpack_same_rank(u%NR_NATURE,zfield_ep(:),zfield(:,ilayer))
            ENDDO
            DEALLOCATE(zfield_ep)
            DEALLOCATE(zfield_ep_in)
            DEALLOCATE(zlsm_nature)
            DEALLOCATE(ointerp)
          ENDIF
        ENDIF

     END SELECT
     CALL soil_profile_buffer


!*      3.3    Profile of soil ice content

  CASE('WGI   ')    
     !* reading of the profile and its depth definition
     SELECT CASE(yinmodel)
       CASE('ALADIN')
         CALL read_buffer_wgi(kluout,yinmodel,zfield,zd)
         IF ( lextrap_wgi ) THEN

          IF ( SIZE(u%NR_NATURE) /= u%NSIZE_NATURE ) THEN
            CALL abor1_sfx('ABORT: PREP_ISBA_BUFFER - DIFFERENT SIZES')
          ELSE

            ! Allocate working arrays
            ALLOCATE(zfield_ep(u%NSIZE_NATURE))
            ALLOCATE(zfield_ep_in(u%NSIZE_NATURE))
            ALLOCATE(ointerp(u%NSIZE_NATURE))
            ALLOCATE(zlsm_nature(u%NSIZE_NATURE))

            ! Read LSM
            CALL read_buffer_land_mask(kluout,yinmodel,zlsm)

            ! Pack nature points to reduce dimension to nsize_nature
            CALL pack_same_rank(u%NR_NATURE,zlsm,zlsm_nature)

            ! Do extrapolations in all layers
            DO ilayer=1,SIZE(zfield,2)
              WRITE(kluout,*) 'Extrapolating WGI from nearest land point in points where LSM < 0.5. LAYER:',ilayer
        
              ! Pack nature points to reduce dimension
              CALL pack_same_rank(u%NR_NATURE,zfield(:,ilayer),zfield_ep(:))
              ! Set values to be extrapolated
              ointerp=.false.
              DO ii=1,u%NSIZE_NATURE
                IF ( zlsm_nature(ii) < 0.5 ) THEN
                  ointerp(ii)  = .true.
                  zfield_ep(ii) = xundef
                ENDIF
              ENDDO
          
              zfield_ep_in(:) = zfield_ep
#ifdef SFX_ARO
              CALL oi_hor_extrapol_surf(u%NSIZE_NATURE,ig%XLAT,ig%XLON,zfield_ep_in(:), &
                                        ig%XLAT,ig%XLON,zfield_ep(:),ointerp,ndim2=10)
#endif

              ! Unpack to full rank
              CALL unpack_same_rank(u%NR_NATURE,zfield_ep(:),zfield(:,ilayer))
            ENDDO
            DEALLOCATE(zfield_ep)
            DEALLOCATE(zfield_ep_in)
            DEALLOCATE(zlsm_nature)
            DEALLOCATE(ointerp)
          ENDIF
        ENDIF

     END SELECT
     CALL soil_profile_buffer
!
!*      3.4    Water content intercepted on leaves, LAI
!
  CASE('WR     ')
     ALLOCATE(pfield(nni,1,1))
     pfield(:,:,:) = xwr_def
!
  CASE('LAI    ')
     ALLOCATE(pfield(nni,1,1))
     pfield(:,:,:) = xundef
!
!
!*      3.5    Other fields
!
  CASE('ZS     ')
     CALL read_buffer_zs(kluout,yinmodel,zfield1d)
     ALLOCATE(pfield(SIZE(zfield1d,1),1,1))
     pfield(:,1,1)=zfield1d(:)
     DEALLOCATE(zfield1d)
!
  CASE('ICE_STO')
     ALLOCATE(pfield(nni,1,1))
     pfield(:,:,:) = 0.0
!
  CASE default
    CALL abor1_sfx('PREP_ISBA_BUFFER: '//trim(hsurf)//" initialization not implemented !")     
!
END SELECT
!
!*      4.     Interpolation method
!              --------------------
!
 cinterp_type='BUFFER'
!
!
!-------------------------------------------------------------------------------------
!-------------------------------------------------------------------------------------
!
IF (lhook) CALL dr_hook('PREP_ISBA_BUFFER',1,zhook_handle)
 CONTAINS
!
!-------------------------------------------------------------------------------------
!-------------------------------------------------------------------------------------
SUBROUTINE soil_profile_buffer
!-------------------------------------------------------------------------------------
!
REAL, DIMENSION(:,:), ALLOCATABLE :: zout   ! work array
REAL(KIND=JPRB) :: zhook_handle
!
!-------------------------------------------------------------------------------------
!
     !
     !* interpolation on fine vertical grid
     IF (lhook) CALL dr_hook('SOIL_PROFILE_BUFFER',0,zhook_handle)
     ALLOCATE(zout(SIZE(zfield,1),SIZE(xgrid_soil)))
     CALL interp_grid_nat(zd,zfield,xgrid_soil,zout)
     !
     !* extends definition to all vegtypes.
     ALLOCATE(pfield(SIZE(zfield,1),SIZE(xgrid_soil),1))
     pfield(:,:,1)=zout(:,:)
     !* end
     DEALLOCATE(zout)
     DEALLOCATE(zfield)
     DEALLOCATE(zd)
IF (lhook) CALL dr_hook('SOIL_PROFILE_BUFFER',1,zhook_handle)

END SUBROUTINE soil_profile_buffer
!
!-------------------------------------------------------------------------------------
END SUBROUTINE prep_isba_buffer