prep_flake_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_flake_extern (&
                              hprogram,hsurf,hfile,hfiletype,hfilepgd,hfilepgdtype,kluout,pfield)
!     #################################################################################
!
!
!
!
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 modi_abor1_sfx
USE modi_get_luout
!
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=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
!
!*      0.2    declarations of local variables
!
!
REAL, DIMENSION(:), ALLOCATABLE :: zmask
!
 CHARACTER(LEN=12) :: yrecfm         ! Name of the article to be read
INTEGER           :: iresp          ! reading return code
INTEGER           :: iluout
!
INTEGER           :: iversion       ! total 1D dimensio
INTEGER           :: ini            ! total 1D dimension
 CHARACTER(LEN=6)  :: ywater         ! lake scheme
INTEGER           :: idim_water     ! number of water points
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_FLAKE_EXTERN',0,zhook_handle)
!
 CALL open_aux_io_surf(&
                       hfilepgd,hfilepgdtype,'FULL  ')
!
 CALL read_surf(&
                hfilepgdtype,'WATER',ywater,iresp)
!
!-------------------------------------------------------------------------------------
!
!*      2.     Reading of grid
!              ---------------
!
 CALL prep_grid_extern(&
                       hfilepgdtype,kluout,cingrid_type,cinterp_type,ini)
!
 CALL read_surf(&
                hfilepgdtype,'DIM_WATER',idim_water,iresp)
!
yrecfm='VERSION'
 CALL read_surf(hfilepgdtype,yrecfm,iversion,iresp)
!
ALLOCATE(zmask(ini))
IF (iversion>=7) THEN
  yrecfm='FRAC_WATER'
  CALL read_surf(hfilepgdtype,yrecfm,zmask,iresp,hdir='A')       
ELSE
  zmask(:) = 1.
ENDIF
!
IF (idim_water==0) THEN
  CALL get_luout(hprogram,iluout)
  WRITE(iluout,*) ' '
  WRITE(iluout,*) 'No inland water data available in input file ',hfile
  WRITE(iluout,*) 'Please change your input file '
  WRITE(iluout,*) '             or '
  WRITE(iluout,*) 'specify inland water temperature XTS_WATER_UNIF'
  CALL abor1_sfx('PREP_FLAKE_EXTERN: No inland water data available in input file')
END IF
!
!---------------------------------------------------------------------------------------
SELECT CASE(hsurf)
!---------------------------------------------------------------------------------------
!
!*     3.      Orography
!              ---------
!
  CASE('ZS     ')
    ALLOCATE(pfield(ini,1))
    yrecfm='ZS'
    CALL read_surf(&
                hfilepgdtype,yrecfm,pfield(:,1),iresp,hdir='A')
    CALL close_aux_io_surf(hfilepgd,hfilepgdtype)
!
!*      4.  Sea surface temperature
!           -----------------------
!
  CASE('TS     ')
    ALLOCATE(pfield(ini,1))
    yrecfm='TS_WATER'
    CALL close_aux_io_surf(hfilepgd,hfilepgdtype)
    CALL open_aux_io_surf(&
                       hfile,hfiletype,'WATER ')
    CALL read_surf(&
                hfiletype,yrecfm,pfield(:,1),iresp,hdir='A')
    CALL close_aux_io_surf(hfile,hfiletype)
    WHERE (zmask(:)==0.) pfield(:,1) = xundef
!
END SELECT
!
!*      5.  FLake variables
!           -----------------------
!
IF (hsurf/='ZS    ' .AND. hsurf/='TS    ') THEN

  CALL close_aux_io_surf(hfilepgd,hfilepgdtype)

  IF (ywater=='FLAKE ') THEN

    CALL open_aux_io_surf(&
                       hfile,hfiletype,'WATER ')

    SELECT CASE(hsurf)

    CASE('T_SNOW ')
      ALLOCATE(pfield(ini,1))
      yrecfm='T_SNOW  '  
      CALL read_surf(&
                hfiletype,yrecfm,pfield(:,1),iresp,hdir='A')
!
    CASE('T_ICE  ')
      ALLOCATE(pfield(ini,1))
      yrecfm='T_ICE   '  
      CALL read_surf(&
                hfiletype,yrecfm,pfield(:,1),iresp,hdir='A')
!
    CASE('T_MNW  ')
      ALLOCATE(pfield(ini,1))
      yrecfm='T_MNW   '  
      CALL read_surf(&
                hfiletype,yrecfm,pfield(:,1),iresp,hdir='A')
!
    CASE('T_BOT  ')
      ALLOCATE(pfield(ini,1))
      yrecfm='T_BOT   '  
      CALL read_surf(&
                hfiletype,yrecfm,pfield(:,1),iresp,hdir='A')
!
    CASE('T_B1   ')
      ALLOCATE(pfield(ini,1))
      yrecfm='T_B1    '  
      CALL read_surf(&
                hfiletype,yrecfm,pfield(:,1),iresp,hdir='A')
!
    CASE('H_SNOW ')
      ALLOCATE(pfield(ini,1))
      yrecfm='H_SNOW  '  
      CALL read_surf(&
                hfiletype,yrecfm,pfield(:,1),iresp,hdir='A')
!
    CASE('H_ICE  ')
      ALLOCATE(pfield(ini,1))
      yrecfm='H_ICE   '  
      CALL read_surf(&
                hfiletype,yrecfm,pfield(:,1),iresp,hdir='A')
!
    CASE('H_ML   ')
      ALLOCATE(pfield(ini,1))
      yrecfm='H_ML    '  
      CALL read_surf(&
                hfiletype,yrecfm,pfield(:,1),iresp,hdir='A')
!
    CASE('H_B1   ')
      ALLOCATE(pfield(ini,1))
      yrecfm='H_B1    '  
      CALL read_surf(&
                hfiletype,yrecfm,pfield(:,1),iresp,hdir='A')
!
!---------------------------------------------------------------------------------------
    END SELECT

    WHERE (zmask(:)==0.) pfield(:,1) = xundef
    CALL close_aux_io_surf(hfile,hfiletype)

  ELSE
!* no Flake field in the input file
    ALLOCATE(pfield(ini,1))
    pfield = xundef
  END IF
END IF
!-------------------------------------------------------------------------------------
!
DEALLOCATE(zmask)
!
!*      6.     End of IO
!              ---------
!
IF (lhook) CALL dr_hook('PREP_FLAKE_EXTERN',1,zhook_handle)
!
!---------------------------------------------------------------------------------------
!
END SUBROUTINE prep_flake_extern