prep_isba_cc_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_cc_extern (&
                                hprogram,hsurf,hfile,hfiletype,hfilepgd,hfilepgdtype,kluout,pfield,oprep_ags)
!     #################################################################################
!
!!****  *PREP_ISBA_CC_EXTERN* - initializes ISBA-CC fields from external isba field
!!
!!    PURPOSE
!!    -------
!
!!**  METHOD
!!    ------
!!
!!    REFERENCE
!!    ---------
!!      
!!
!!    AUTHOR
!!    ------
!!     V. Masson 
!!
!!    MODIFICATIONS
!!    -------------
!!      Original    01/2004
!!      B. Decharme  04/2014, external init with FA files
!!------------------------------------------------------------------
!
!
!
!
USE mode_read_extern
!
USE modd_type_date_surf
!
USE modi_prep_grid_extern
USE modi_read_surf
USE modi_open_aux_io_surf
USE modi_close_aux_io_surf
!
USE modd_prep,           ONLY : cingrid_type, cinterp_type
USE modd_surf_par,       ONLY : xundef
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
!*      0.1    declarations of arguments
!
!
!
 CHARACTER(LEN=6),   INTENT(IN)  :: hprogram  ! program calling surf. schemes
 CHARACTER(LEN=8),   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,            INTENT(INOUT):: oprep_ags
!
!*      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
 CHARACTER(LEN=3)  :: yphoto
 CHARACTER(LEN=3)  :: yrespsl
 CHARACTER(LEN=4)  :: ylvl
!
INTEGER           :: jnbiomass             ! loop counter
INTEGER           :: jnlitter              ! loop counter
INTEGER           :: jnlittlevs            ! loop counter
INTEGER           :: jnsoilcarb            ! loop counter
INTEGER           :: iversion     ! surface version
INTEGER           :: iwork,inbiomass,inlitter, &
                     inlittlevs,insoilcarb
!
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_CC_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)
!
 CALL close_aux_io_surf(hfilepgd,hfilepgdtype)
!
!---------------------------------------------------------------------------------------
!
!*      3.     Transformation into physical quantity to be interpolated
!              --------------------------------------------------------
!
 CALL open_aux_io_surf(&
                      hfilepgd,hfilepgdtype,'NATURE')
yrecfm='PHOTO'
 CALL read_surf(&
               hfilepgdtype,yrecfm,yphoto,iresp)  
yrecfm='PATCH_NUMBER'
 CALL read_surf(&
               hfilepgdtype,yrecfm,ipatch,iresp)
 CALL close_aux_io_surf(hfilepgd,hfilepgdtype)
!
IF(iversion<8.OR.(yphoto/='NIT'.AND.yphoto/='NCB'))THEN
  oprep_ags = .false.
  IF (lhook) CALL dr_hook('PREP_ISBA_CC_EXTERN',1,zhook_handle)
  RETURN
ENDIF
!       
SELECT CASE(hsurf)
!
  CASE('BIOMASS')
     CALL open_aux_io_surf(&
                      hfilepgd,hfilepgdtype,'NATURE')
     yrecfm='NBIOMASS'
     CALL read_surf(&
               hfilepgdtype,yrecfm,inbiomass,iresp)
     CALL close_aux_io_surf(hfilepgd,hfilepgdtype)
     IF (yphoto=='NIT' .OR. yphoto=='NCB') THEN
       ALLOCATE(pfield(ini,inbiomass,ipatch))
       pfield(:,:,:) = xundef
       CALL open_aux_io_surf(&
                      hfile,hfiletype,'NATURE')
       DO jnbiomass=1,inbiomass
          WRITE(ylvl,'(I1)') jnbiomass
          yrecfm='BIOMA'//adjustl(ylvl(:len_trim(ylvl)))
          CALL read_surf(&
               hfiletype,yrecfm,pfield(:,jnbiomass,:),iresp,hdir='A')
       ENDDO
       CALL close_aux_io_surf(hfile,hfiletype)
     ELSE
       oprep_ags = .false.
     ENDIF
!
  CASE('LITTER')
     CALL open_aux_io_surf(&
                      hfile,hfiletype,'NATURE')
     yrecfm='RESPSL'
     CALL read_surf(&
               hfiletype,yrecfm,yrespsl,iresp)
     IF(yrespsl=='CNT')THEN
       yrecfm='NLITTER'
       CALL read_surf(&
               hfiletype,yrecfm,inlitter,iresp)
       yrecfm='NLITTLEVS'
       CALL read_surf(&
               hfiletype,yrecfm,inlittlevs,iresp)
       ALLOCATE(pfield(ini,inlitter*inlittlevs,ipatch))
       pfield(:,:,:) = xundef
       iwork=0
       DO jnlitter=1,inlitter
          DO jnlittlevs=1,inlittlevs
             iwork=iwork+1
             WRITE(ylvl,'(I1,A1,I1)') jnlitter,'_',jnlittlevs
             yrecfm='LITTER'//adjustl(ylvl(:len_trim(ylvl)))
             CALL read_surf(&
               hfiletype,yrecfm,pfield(:,iwork,:),iresp,hdir='A')
          ENDDO
       ENDDO
     ELSE
       oprep_ags = .false.
     ENDIF    
     CALL close_aux_io_surf(hfile,hfiletype)
!
  CASE('SOILCARB')
     CALL open_aux_io_surf(&
                      hfile,hfiletype,'NATURE')
     yrecfm='RESPSL'
     CALL read_surf(&
               hfiletype,yrecfm,yrespsl,iresp)
     IF(yrespsl=='CNT')THEN
       yrecfm='NSOILCARB'
       CALL read_surf(&
               hfiletype,yrecfm,insoilcarb,iresp)
       ALLOCATE(pfield(ini,insoilcarb,ipatch))
       pfield(:,:,:) = xundef
       DO jnsoilcarb=1,insoilcarb
          WRITE(ylvl,'(I4)') jnsoilcarb
          yrecfm='SOILCARB'//adjustl(ylvl(:len_trim(ylvl)))
          CALL read_surf(&
               hfiletype,yrecfm,pfield(:,jnsoilcarb,:),iresp,hdir='A')
       ENDDO
     ELSE
       oprep_ags = .false.
     ENDIF    
     CALL close_aux_io_surf(hfile,hfiletype)
!     
  CASE('LIGNIN')
     CALL open_aux_io_surf(&
                      hfile,hfiletype,'NATURE')
     yrecfm='RESPSL'
     CALL read_surf(&
               hfiletype,yrecfm,yrespsl,iresp)
     IF(yrespsl=='CNT')THEN
       yrecfm='NLITTLEVS'
       CALL read_surf(&
               hfiletype,yrecfm,inlittlevs,iresp)
       ALLOCATE(pfield(ini,inlittlevs,ipatch))
       pfield(:,:,:) = xundef
       DO jnlittlevs=1,inlittlevs
          WRITE(ylvl,'(I4)') jnlittlevs
          yrecfm='LIGNIN_STR'//adjustl(ylvl(:len_trim(ylvl)))
          CALL read_surf(&
               hfiletype,yrecfm,pfield(:,jnlittlevs,:),iresp,hdir='A')
       ENDDO
     ELSE
       oprep_ags = .false.
     ENDIF    
     CALL close_aux_io_surf(hfile,hfiletype)
!
END SELECT
!
!
!---------------------------------------------------------------------------
!
!*      6.     End of IO
!              ---------
!
IF (lhook) CALL dr_hook('PREP_ISBA_CC_EXTERN',1,zhook_handle)
!
!---------------------------------------------------------------------------
!---------------------------------------------------------------------------
END SUBROUTINE prep_isba_cc_extern