prep_isba_extern.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_extern (DTCO, I, U, &
                             hprogram,hsurf,hfile,hfiletype,hfilepgd,hfilepgdtype,kluout,pfield,okey)
!     #################################################################################
!
!!****  *PREP_ISBA_EXTERN* - initializes ISBA fields from operational GRIB
!!
!!    PURPOSE
!!    -------
!
!!**  METHOD
!!    ------
!!
!!    REFERENCE
!!    ---------
!!      
!!
!!    AUTHOR
!!    ------
!!     V. Masson 
!!
!!    MODIFICATIONS
!!    -------------
!!      Original    01/2004
!!      B. Decharme  04/2014, external init with FA files
!!------------------------------------------------------------------
!
!
!
!
!
!
USE modd_data_cover_n, ONLY : data_cover_t
USE modd_isba_n, ONLY : isba_t
USE modd_surf_atm_n, ONLY : surf_atm_t
!
USE modd_prep,           ONLY : cingrid_type, cinterp_type
USE modd_prep_isba,      ONLY : xgrid_soil, xwr_def
USE modd_surf_par,       ONLY : xundef
!
USE mode_read_extern
!
USE modd_type_date_surf
!
USE modi_prep_grid_extern
USE modi_read_surf
USE modi_interp_grid_nat
USE modi_open_aux_io_surf
USE modi_close_aux_io_surf
!
USE modi_abor1_sfx
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
!*      0.1    declarations of arguments
!
!
TYPE(data_cover_t), INTENT(INOUT) :: dtco
TYPE(isba_t), INTENT(INOUT) :: i
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
 CHARACTER(LEN=28),  INTENT(IN)  :: hfile     ! name of file
 CHARACTER(LEN=6),   INTENT(IN)  :: hfiletype ! type of input file
 CHARACTER(LEN=28),  INTENT(IN)  :: hfilepgd     ! name of file
 CHARACTER(LEN=6),   INTENT(IN)  :: hfilepgdtype ! type of input file
INTEGER,            INTENT(IN)   :: kluout    ! logical unit of output listing
REAL,DIMENSION(:,:,:), POINTER   :: pfield    ! field to interpolate horizontally (on final soil grid)
LOGICAL, OPTIONAL,  INTENT(INOUT):: okey
!
!*      0.2    declarations of local variables
!
 CHARACTER(LEN=12) :: yrecfm         ! Name of the article to be read
INTEGER           :: iresp          ! reading return code
INTEGER           :: ini            ! total 1D dimension
INTEGER           :: ipatch         ! number of patch
LOGICAL           :: gglacier
 CHARACTER(LEN=3)  :: yphoto
!
REAL, DIMENSION(:,:,:), POINTER     :: zfield         ! field read on initial MNH vertical soil grid, all patches
REAL, DIMENSION(:,:),   POINTER     :: zfield1        ! field read on initial MNH vertical soil grid, one patch
REAL, DIMENSION(:,:,:), POINTER     :: zd             ! layer thicknesses
REAL, DIMENSION(:,:),   POINTER     :: zd1            ! layer thicknesses, one patch
REAL, DIMENSION(:,:), ALLOCATABLE   :: zout           !
REAL, DIMENSION(:), ALLOCATABLE     :: zmask
INTEGER                             :: jpatch, jl       ! loop counter for patch
INTEGER :: iversion
REAL(KIND=JPRB) :: zhook_handle
!
!------------------------------------------------------------------------------
!
!*      1.     Preparation of IO for reading in the file
!              -----------------------------------------
!
!* Note that all points are read, even those without physical meaning.
!  These points will not be used during the horizontal interpolation step.
!  Their value must be defined as XUNDEF.
!
IF (lhook) CALL dr_hook('PREP_ISBA_EXTERN',0,zhook_handle)
!
!------------------------------------------------------------------------------
!
!*      2.     Reading of grid
!              ---------------
!
 CALL open_aux_io_surf(&
                       hfilepgd,hfilepgdtype,'FULL  ')
!
 CALL prep_grid_extern(&
                       hfilepgdtype,kluout,cingrid_type,cinterp_type,ini)
!
yrecfm='VERSION'
 CALL read_surf(hfilepgdtype,yrecfm,iversion,iresp)
!
ALLOCATE(zmask(ini))
IF (iversion>=7) THEN 
  yrecfm='FRAC_NATURE'
  CALL read_surf(hfilepgdtype,yrecfm,zmask,iresp,hdir='A')
ELSE
  zmask(:) = 1.
ENDIF
!
!---------------------------------------------------------------------------------------
!
!*      3.     Transformation into physical quantity to be interpolated
!              --------------------------------------------------------
!
SELECT CASE(hsurf)
!
!*     3.      Orography
!              ---------
!
  CASE('ZS     ')
    ALLOCATE(pfield(ini,1,1))
    pfield(:,:,:) = xundef
    yrecfm='ZS'
    CALL read_surf(&
                   hfilepgdtype,yrecfm,pfield(:,1,1),iresp,hdir='A')
    CALL close_aux_io_surf(hfilepgd,hfilepgdtype)
!
!--------------------------------------------------------------------------
!
!
!*      3.1    Profile of temperature, water or ice in the soil
!
  CASE('TG    ','WG    ','WGI   ')
     CALL close_aux_io_surf(hfilepgd,hfilepgdtype)
!* reading of the profile and its depth definition
     CALL read_extern_isba(u, &
                           dtco, i, &
                           hfile,hfiletype,hfilepgd,hfilepgdtype,&
                           kluout,ini,hsurf,hsurf,zfield,zd,okey)
! 
     ALLOCATE(zfield1(SIZE(zfield,1),SIZE(zfield,2)))
     ALLOCATE(zd1(SIZE(zfield,1),SIZE(zfield,2)))
     ALLOCATE(zout(SIZE(zfield,1),SIZE(xgrid_soil)))
     ALLOCATE(pfield(SIZE(zfield,1),SIZE(xgrid_soil),SIZE(zfield,3)))
     pfield(:,:,:) = xundef
!
     DO jpatch=1,SIZE(zfield,3)
        zfield1(:,:)=zfield(:,:,jpatch)
        zd1(:,:)=zd(:,:,jpatch)
        CALL interp_grid_nat(zd1,zfield1,xgrid_soil,zout)
        pfield(:,:,jpatch)=zout(:,:)
     END DO
     !
     DO jpatch=1,SIZE(pfield,3)
       DO jl=1,SIZE(pfield,2)
         WHERE (zmask(:)==0.) pfield(:,jl,jpatch) = xundef
       ENDDO
     ENDDO
     !
     DEALLOCATE(zfield)
     DEALLOCATE(zout)
     DEALLOCATE(zfield1)
     DEALLOCATE(zd)
!
!--------------------------------------------------------------------------
!
!*      3.4    Water content intercepted on leaves, LAI
!
  CASE('WR     ')
     CALL close_aux_io_surf(hfilepgd,hfilepgdtype)     
     !* number of tiles
     CALL open_aux_io_surf(&
                       hfilepgd,hfilepgdtype,'NATURE')
     yrecfm='PATCH_NUMBER'
     CALL read_surf(&
                   hfilepgdtype,yrecfm,ipatch,iresp)
     CALL close_aux_io_surf(hfilepgd,hfilepgdtype)
     ALLOCATE(pfield(ini,1,ipatch))
     pfield(:,:,:) = xundef
     yrecfm = 'WR'
     CALL open_aux_io_surf(&
                       hfile,hfiletype,'NATURE')
     CALL read_surf(&
                   hfiletype,yrecfm,pfield(:,1,:),iresp,hdir='A')
     CALL close_aux_io_surf(hfile,hfiletype)
     DO jpatch=1,SIZE(pfield,3)
       WHERE (zmask(:)==0.) pfield(:,1,jpatch) = xundef
     ENDDO     
!
  CASE('LAI    ')
     CALL close_aux_io_surf(hfilepgd,hfilepgdtype)
     !* number of tiles
     CALL open_aux_io_surf(&
                       hfilepgd,hfilepgdtype,'NATURE')
     yrecfm='PATCH_NUMBER'
     CALL read_surf(&
                   hfilepgdtype,yrecfm,ipatch,iresp)
     yrecfm='PHOTO'
     CALL read_surf(&
                   hfilepgdtype,yrecfm,yphoto,iresp)     
     CALL close_aux_io_surf(hfilepgd,hfilepgdtype)
     ALLOCATE(pfield(ini,1,ipatch))
     pfield(:,:,:) = xundef     
     IF (yphoto=='LAI' .OR. yphoto=='LST' .OR. yphoto=='NIT' .OR. yphoto=='NCB') THEN
       CALL open_aux_io_surf(&
                       hfile,hfiletype,'NATURE')
       yrecfm = 'LAI'
       CALL read_surf(&
                   hfiletype,yrecfm,pfield(:,1,:),iresp,hdir='A')
       CALL close_aux_io_surf(hfile,hfiletype)
       DO jpatch=1,SIZE(pfield,3)
         WHERE (zmask(:)==0.) pfield(:,1,jpatch) = xundef
       ENDDO       
     ENDIF
!
  CASE('ICE_STO')
     CALL close_aux_io_surf(hfilepgd,hfilepgdtype)     
      !* number of tiles
     CALL open_aux_io_surf(&
                       hfilepgd,hfilepgdtype,'NATURE')
     yrecfm='PATCH_NUMBER'
     CALL read_surf(&
                   hfilepgdtype,yrecfm,ipatch,iresp)
     CALL close_aux_io_surf(hfilepgd,hfilepgdtype)
     CALL open_aux_io_surf(&
                       hfile,hfiletype,'NATURE')
     yrecfm='GLACIER'
     CALL read_surf(&
                   hfiletype,yrecfm,gglacier,iresp)
     ALLOCATE(pfield(ini,1,ipatch))
     pfield(:,:,:) = 0.0     
     IF(gglacier)THEN
       yrecfm = 'ICE_STO'
       CALL read_surf(&
                   hfiletype,yrecfm,pfield(:,1,:),iresp,hdir='A')
     ENDIF
     CALL close_aux_io_surf(hfile,hfiletype)
     DO jpatch=1,SIZE(pfield,3)
       WHERE (zmask(:)==0.) pfield(:,1,jpatch) = xundef
     ENDDO     
!
  CASE default
    CALL abor1_sfx('PREP_ISBA_EXTERN: '//trim(hsurf)//" initialization not implemented !")
!
END SELECT
!
DEALLOCATE(zmask)
!
!---------------------------------------------------------------------------
!
!*      6.     End of IO
!              ---------
!
IF (lhook) CALL dr_hook('PREP_ISBA_EXTERN',1,zhook_handle)
!
!---------------------------------------------------------------------------
!---------------------------------------------------------------------------
END SUBROUTINE prep_isba_extern