limit_netcdf.F90

Go to the documentation of this file.

MODULE limit
!
!*******************************************************************************
! Author : L. Fairhead, 27/01/94
!-------------------------------------------------------------------------------
! Purpose: Boundary conditions files building for new model using climatologies.
!          Both grids have to be regular.
!-------------------------------------------------------------------------------
! Note: This routine is designed to work for Earth
!-------------------------------------------------------------------------------
! Modification history:
!  * 23/03/1994: Z. X. Li
!  *    09/1999: L. Fairhead (netcdf reading in LMDZ.3.3)
!  *    07/2001: P. Le Van
!  *    11/2009: L. Guez     (ozone day & night climatos, see etat0_netcdf.F90)
!  *    12/2009: D. Cugnet   (f77->f90, calendars, files from coupled runs)
!-------------------------------------------------------------------------------

  USE ioipsl,             ONLY: flininfo, flinopen, flinget, flinclo,          &
   ioconf_calendar, ioget_calendar, lock_calendar, ioget_mon_len, ioget_year_len
  USE assert_eq_m,        ONLY: assert_eq
  USE conf_dat_m,         ONLY: conf_dat2d, conf_dat3d
  USE dimphy,             ONLY: klon, zmasq
  USE phys_state_var_mod, ONLY: pctsrf, rlon, rlat
  USE control_mod
  USE init_ssrf_m,        ONLY: start_init_subsurf

  CHARACTER(LEN=20), PARAMETER :: &
  fsst(4)=['amipbc_sst_1x1.nc   ','cpl_atm_sst.nc      ','histmth_sst.nc      '&
          ,'sstk.nc             ']
  CHARACTER(LEN=20), PARAMETER :: &
  fsic(4)=['amipbc_sic_1x1.nc   ','cpl_atm_sic.nc      ','histmth_sic.nc      '&
          ,'ci.nc               ']
  CHARACTER(LEN=10), PARAMETER :: &
  vsst(4)=['tosbcs    ','SISUTESW  ','tsol_oce  ','sstk      '], &
  vsic(4)=['sicbcs    ','SIICECOV  ','pourc_sic ','ci        ']
  CHARACTER(LEN=10), PARAMETER :: &
  frugo='Rugos.nc  ', falbe='Albedo.nc ', frelf='Relief.nc ',    &
   vrug='RUGOS     ',  valb='ALBEDO    ',  vrel='RELIEF    '

CONTAINS

!-------------------------------------------------------------------------------
!
SUBROUTINE limit_netcdf(masque, phis, extrap)
!
!-------------------------------------------------------------------------------
! Author : L. Fairhead, 27/01/94
!-------------------------------------------------------------------------------
! Purpose: Boundary conditions files building for new model using climatologies.
!          Both grids have to be regular.
!-------------------------------------------------------------------------------
! Note: This routine is designed to work for Earth
!-------------------------------------------------------------------------------
! Modification history:
!  * 23/03/1994: Z. X. Li
!  *    09/1999: L. Fairhead (netcdf reading in LMDZ.3.3)
!  *    07/2001: P. Le Van
!  *    11/2009: L. Guez     (ozone day & night climatos, see etat0_netcdf.F90)
!  *    12/2009: D. Cugnet   (f77->f90, calendars, files from coupled runs)
!-------------------------------------------------------------------------------
#ifndef CPP_1D
  USE indice_sol_mod
  USE netcdf,             ONLY: nf90_open,    nf90_create,  nf90_close,        &
                  nf90_def_dim, nf90_def_var, nf90_put_var, nf90_put_att,      &
                  nf90_noerr,   nf90_nowrite, nf90_double,  nf90_global,       &
                                  nf90_clobber, nf90_enddef,  nf90_unlimited, nf90_float
  USE inter_barxy_m,      ONLY: inter_barxy
  USE netcdf95,           ONLY: nf95_def_var, nf95_put_att, nf95_put_var
  IMPLICIT NONE
!-------------------------------------------------------------------------------
! Arguments:
  include "iniprint.h"
  include "dimensions.h"
  include "paramet.h"
  REAL, DIMENSION(iip1,jjp1), INTENT(INOUT) :: masque ! land mask
  REAL, DIMENSION(iip1,jjp1), INTENT(INOUT) :: phis   ! ground geopotential
  LOGICAL,                    INTENT(IN)    :: extrap ! SST extrapolation flag
!-------------------------------------------------------------------------------
! Local variables:
  include "logic.h"
  include "comgeom2.h"
  include "comconst.h"

!--- INPUT NETCDF FILES NAMES --------------------------------------------------
  CHARACTER(LEN=20) :: icefile, sstfile, dumstr, fnam
  CHARACTER(LEN=10) :: varname

!--- OUTPUT VARIABLES FOR NETCDF FILE ------------------------------------------
  REAL               :: fi_ice(klon), verif(klon)
  REAL, POINTER      :: phy_rug(:,:)=>null(), phy_ice(:,:)=>null()
  REAL, POINTER      :: phy_sst(:,:)=>null(), phy_alb(:,:)=>null()
  REAL, ALLOCATABLE  :: phy_bil(:,:), pctsrf_t(:,:,:)
  INTEGER            :: nbad

!--- VARIABLES FOR OUTPUT FILE WRITING -----------------------------------------
  INTEGER :: ierr, nid, ndim, ntim, k, dims(2), ix_sic, ix_sst
  INTEGER :: id_tim,  id_SST,  id_BILS, id_RUG, id_ALB
  INTEGER :: id_FOCE, id_FSIC, id_FTER, id_FLIC, varid_longitude, varid_latitude
  INTEGER :: NF90_FORMAT
  INTEGER :: ndays                   !--- Depending on the output calendar

!--- INITIALIZATIONS -----------------------------------------------------------
#ifdef NC_DOUBLE
  nf90_format=nf90_double
#else
  nf90_format=nf90_float
#endif
  CALL inigeom

!--- MASK, GROUND GEOPOT. & SUBSURFACES COMPUTATION (IN CASE ok_etat0==.FALSE.)
   IF(all(masque==-99999.)) THEN
    CALL start_init_orog0(rlonv,rlatu,phis,masque)
    CALL gr_dyn_fi(1,iip1,jjp1,klon,masque,zmasq)          !--- To physical grid
    ALLOCATE(rlon(klon),rlat(klon),pctsrf(klon,nbsrf))
    CALL start_init_subsurf(.false.)
  END IF

!--- Beware: anneeref (from gcm.def) is used to determine output time sampling
  ndays=ioget_year_len(anneeref)

!--- RUGOSITY TREATMENT --------------------------------------------------------
  CALL msg(1,'Traitement de la rugosite')
  CALL get_2dfield(frugo,vrug,'RUG',ndays,phy_rug,mask=masque(1:iim,:))

!--- OCEAN TREATMENT -----------------------------------------------------------
  CALL msg(1,'Traitement de la glace oceanique')

! Input SIC file selection
! Open file only to test if available
  DO ix_sic=1,SIZE(fsic)
     IF ( nf90_open(trim(fsic(ix_sic)),nf90_nowrite,nid)==nf90_noerr ) THEN
        icefile=fsic(ix_sic); varname=vsic(ix_sic); EXIT
     END IF
  END DO
  IF(ix_sic==SIZE(fsic)+1) THEN
     WRITE(lunout,*) 'ERROR! No sea-ice input file was found.'
     WRITE(lunout,*) 'One of following files must be available : '
     DO k=1,SIZE(fsic); WRITE(lunout,*) trim(fsic(k)); END DO
     CALL abort_physic('limit_netcdf','No sea-ice file was found',1)
  END IF
  CALL ncerr(nf90_close(nid),icefile)
  CALL msg(-1,'Fichier choisi pour la glace de mer:'//trim(icefile))

  CALL get_2dfield(icefile,varname, 'SIC',ndays,phy_ice)

  ALLOCATE(pctsrf_t(klon,nbsrf,ndays))
  DO k=1,ndays
     fi_ice=phy_ice(:,k)
     WHERE(fi_ice>=1.0  ) fi_ice=1.0
     WHERE(fi_ice<epsfra) fi_ice=0.0
     pctsrf_t(:,is_ter,k)=pctsrf(:,is_ter)       ! land soil
     pctsrf_t(:,is_lic,k)=pctsrf(:,is_lic)       ! land ice
     SELECT CASE(ix_sic)
        CASE(2)                                   ! SIC=pICE*(1-LIC-TER) (CPL)
        pctsrf_t(:,is_sic,k)=fi_ice(:)*(1.-pctsrf(:,is_lic)-pctsrf(:,is_ter))
        CASE(3)                                   ! SIC=pICE            (HIST)
        pctsrf_t(:,is_sic,k)=fi_ice(:)
        CASE DEFAULT                              ! SIC=pICE-LIC   (AMIP,ERAI)
        pctsrf_t(:,is_sic,k)=fi_ice-pctsrf_t(:,is_lic,k)
     END SELECT
     WHERE(pctsrf_t(:,is_sic,k)<=0) pctsrf_t(:,is_sic,k)=0.
     WHERE(1.0-zmasq<epsfra)
        pctsrf_t(:,is_sic,k)=0.0
        pctsrf_t(:,is_oce,k)=0.0
     ELSEWHERE
        WHERE(pctsrf_t(:,is_sic,k)>=1.0-zmasq)
           pctsrf_t(:,is_sic,k)=1.0-zmasq
           pctsrf_t(:,is_oce,k)=0.0
        ELSEWHERE
           pctsrf_t(:,is_oce,k)=1.0-zmasq-pctsrf_t(:,is_sic,k)
           WHERE(pctsrf_t(:,is_oce,k)<epsfra)
              pctsrf_t(:,is_oce,k)=0.0
              pctsrf_t(:,is_sic,k)=1.0-zmasq
           END WHERE
        END WHERE
     END WHERE
     nbad=count(pctsrf_t(:,is_oce,k)<0.0)
     IF(nbad>0) WRITE(lunout,*) 'pb sous maille pour nb points = ',nbad
     nbad=count(abs(sum(pctsrf_t(:,:,k),dim=2)-1.0)>epsfra)
     IF(nbad>0) WRITE(lunout,*) 'pb sous surface pour nb points = ',nbad
  END DO
  DEALLOCATE(phy_ice)

!--- SST TREATMENT -------------------------------------------------------------
  CALL msg(1,'Traitement de la sst')

! Input SST file selection
! Open file only to test if available
  DO ix_sst=1,SIZE(fsst)
     IF ( nf90_open(trim(fsst(ix_sst)),nf90_nowrite,nid)==nf90_noerr ) THEN
       sstfile=fsst(ix_sst); varname=vsst(ix_sst); EXIT
     END IF
  END DO
  IF(ix_sst==SIZE(fsst)+1) THEN
     WRITE(lunout,*) 'ERROR! No sst input file was found.'
     WRITE(lunout,*) 'One of following files must be available : '
     DO k=1,SIZE(fsst); WRITE(lunout,*) trim(fsst(k)); END DO
     CALL abort_physic('limit_netcdf','No sst file was found',1)
  END IF
  CALL ncerr(nf90_close(nid),sstfile)
  CALL msg(-1,'Fichier choisi pour la temperature de mer: '//trim(sstfile))

  CALL get_2dfield(sstfile,varname,'SST',ndays,phy_sst,flag=extrap)

!--- ALBEDO TREATMENT ----------------------------------------------------------
  CALL msg(1,'Traitement de l albedo')
  CALL get_2dfield(falbe,valb,'ALB',ndays,phy_alb)

!--- REFERENCE GROUND HEAT FLUX TREATMENT --------------------------------------
  ALLOCATE(phy_bil(klon,ndays)); phy_bil=0.0

!--- OUTPUT FILE WRITING -------------------------------------------------------
  CALL msg(5,'Ecriture du fichier limit : debut')
  fnam="limit.nc"

  !--- File creation
  CALL ncerr(nf90_create(fnam,nf90_clobber,nid),fnam)
  CALL ncerr(nf90_put_att(nid,nf90_global,"title","Fichier conditions aux limites"),fnam)

  !--- Dimensions creation
  CALL ncerr(nf90_def_dim(nid,"points_physiques",klon,ndim),fnam)
  CALL ncerr(nf90_def_dim(nid,"time",nf90_unlimited,ntim),fnam)

  dims=[ndim,ntim]

  !--- Variables creation
  CALL ncerr(nf90_def_var(nid,"TEMPS",nf90_format,[ntim],id_tim),fnam)
  CALL ncerr(nf90_def_var(nid,"FOCE", nf90_format,dims,id_foce),fnam)
  CALL ncerr(nf90_def_var(nid,"FSIC", nf90_format,dims,id_fsic),fnam)
  CALL ncerr(nf90_def_var(nid,"FTER", nf90_format,dims,id_fter),fnam)
  CALL ncerr(nf90_def_var(nid,"FLIC", nf90_format,dims,id_flic),fnam)
  CALL ncerr(nf90_def_var(nid,"SST",  nf90_format,dims,id_sst),fnam)
  CALL ncerr(nf90_def_var(nid,"BILS", nf90_format,dims,id_bils),fnam)
  CALL ncerr(nf90_def_var(nid,"ALB",  nf90_format,dims,id_alb),fnam)
  CALL ncerr(nf90_def_var(nid,"RUG",  nf90_format,dims,id_rug),fnam)
  call nf95_def_var(nid, "longitude", nf90_float, ndim, varid_longitude)
  call nf95_def_var(nid, "latitude",  nf90_float, ndim, varid_latitude)

  !--- Attributes creation
  CALL ncerr(nf90_put_att(nid,id_tim, "title","Jour dans l annee"),fnam)
  CALL ncerr(nf90_put_att(nid,id_foce,"title","Fraction ocean"),fnam)
  CALL ncerr(nf90_put_att(nid,id_fsic,"title","Fraction glace de mer"),fnam)
  CALL ncerr(nf90_put_att(nid,id_fter,"title","Fraction terre"),fnam)
  CALL ncerr(nf90_put_att(nid,id_flic,"title","Fraction land ice"),fnam)
  CALL ncerr(nf90_put_att(nid,id_sst ,"title","Temperature superficielle de la mer"),fnam)
  CALL ncerr(nf90_put_att(nid,id_bils,"title","Reference flux de chaleur au sol"),fnam)
  CALL ncerr(nf90_put_att(nid,id_alb, "title","Albedo a la surface"),fnam)
  CALL ncerr(nf90_put_att(nid,id_rug, "title","Rugosite"),fnam)

  call nf95_put_att(nid, varid_longitude, "standard_name", "longitude")
  call nf95_put_att(nid, varid_longitude, "units", "degrees_east")

  call nf95_put_att(nid, varid_latitude, "standard_name", "latitude")
  call nf95_put_att(nid, varid_latitude, "units", "degrees_north")

  CALL ncerr(nf90_enddef(nid),fnam)

  !--- Variables saving
  CALL ncerr(nf90_put_var(nid,id_tim,[(REAL(k),k=1,ndays)]),fnam)
  CALL ncerr(nf90_put_var(nid,id_foce,pctsrf_t(:,is_oce,:),[1,1],[klon,ndays]),fnam)
  CALL ncerr(nf90_put_var(nid,id_fsic,pctsrf_t(:,is_sic,:),[1,1],[klon,ndays]),fnam)
  CALL ncerr(nf90_put_var(nid,id_fter,pctsrf_t(:,is_ter,:),[1,1],[klon,ndays]),fnam)
  CALL ncerr(nf90_put_var(nid,id_flic,pctsrf_t(:,is_lic,:),[1,1],[klon,ndays]),fnam)
  CALL ncerr(nf90_put_var(nid,id_sst ,phy_sst(:,:),[1,1],[klon,ndays]),fnam)
  CALL ncerr(nf90_put_var(nid,id_bils,phy_bil(:,:),[1,1],[klon,ndays]),fnam)
  CALL ncerr(nf90_put_var(nid,id_alb ,phy_alb(:,:),[1,1],[klon,ndays]),fnam)
  CALL ncerr(nf90_put_var(nid,id_rug ,phy_rug(:,:),[1,1],[klon,ndays]),fnam)
  call nf95_put_var(nid, varid_longitude, rlon)
  call nf95_put_var(nid, varid_latitude, rlat)

  CALL ncerr(nf90_close(nid),fnam)

  CALL msg(6,'Ecriture du fichier limit : fin')

  DEALLOCATE(pctsrf_t,phy_sst,phy_bil,phy_alb,phy_rug)


!===============================================================================
!
  CONTAINS
!
!===============================================================================


!-------------------------------------------------------------------------------
!
SUBROUTINE get_2dfield(fnam, varname, mode, ndays, champo, flag, mask)
!
!-----------------------------------------------------------------------------
! Comments:
!   There are two assumptions concerning the NetCDF files, that are satisfied
!   with files that are conforming NC convention:
!     1) The last dimension of the variables used is the time record.
!     2) Dimensional variables have the same names as corresponding dimensions.
!-----------------------------------------------------------------------------
  USE netcdf, ONLY: nf90_open, nf90_inq_varid, nf90_inquire_variable, &
       nf90_close, nf90_inq_dimid, nf90_inquire_dimension, nf90_get_var, &
       nf90_get_att
  USE pchsp_95_m, only: pchsp_95
  USE pchfe_95_m, only: pchfe_95
  USE arth_m, only: arth
  USE indice_sol_mod

  IMPLICIT NONE
  include "dimensions.h"
  include "paramet.h"
  include "comgeom2.h"
!-----------------------------------------------------------------------------
! Arguments:
  CHARACTER(LEN=*),  INTENT(IN)     :: fnam     ! NetCDF file name
  CHARACTER(LEN=10), INTENT(IN)     :: varname  ! NetCDF variable name
  CHARACTER(LEN=3),  INTENT(IN)     :: mode     ! RUG, SIC, SST or ALB
  INTEGER,           INTENT(IN)     :: ndays    ! current year number of days
  REAL,    POINTER,  DIMENSION(:, :) :: champo  ! output field = f(t)
  LOGICAL, OPTIONAL, INTENT(IN)     :: flag     ! extrapol. (SST) old ice (SIC)
  REAL,    OPTIONAL, DIMENSION(iim, jjp1), INTENT(IN) :: mask
!------------------------------------------------------------------------------
! Local variables:
!--- NetCDF
  INTEGER           :: ncid, varid        ! NetCDF identifiers
  CHARACTER(LEN=30) :: dnam               ! dimension name
!--- dimensions
  INTEGER           :: dids(4)            ! NetCDF dimensions identifiers
  REAL, ALLOCATABLE :: dlon_ini(:)        ! initial longitudes vector
  REAL, ALLOCATABLE :: dlat_ini(:)        ! initial latitudes  vector
  REAL, POINTER     :: dlon(:), dlat(:)   ! reordered lon/lat  vectors
!--- fields
  INTEGER :: imdep, jmdep, lmdep          ! dimensions of 'champ'
  REAL, ALLOCATABLE :: champ(:,:)         ! wanted field on initial grid
  REAL, ALLOCATABLE :: yder(:), timeyear(:)
  REAL              :: champint(iim,jjp1) ! interpolated field
  REAL, ALLOCATABLE :: champtime(:,:,:)
  REAL, ALLOCATABLE :: champan(:,:,:)
!--- input files
  CHARACTER(LEN=20) :: cal_in             ! calendar
  CHARACTER(LEN=20) :: unit_sic           ! attribute unit in sea-ice file
  INTEGER           :: ndays_in           ! number of days
!--- misc
  INTEGER           :: i, j, k, l         ! loop counters
  REAL, ALLOCATABLE :: work(:,:)          ! used for extrapolation
  CHARACTER(LEN=25) :: title              ! for messages
  LOGICAL           :: extrp              ! flag for extrapolation
  REAL              :: chmin, chmax
  INTEGER ierr
  integer n_extrap ! number of extrapolated points
  logical skip

!------------------------------------------------------------------------------
!---Variables depending on keyword 'mode' -------------------------------------
  NULLIFY(champo)

  SELECT CASE(mode)
  CASE('RUG'); title='Rugosite'
  CASE('SIC'); title='Sea-ice'
  CASE('SST'); title='SST'
  CASE('ALB'); title='Albedo'
  END SELECT
  extrp=.false.; IF(PRESENT(flag).AND.mode=='SST') extrp=flag

!--- GETTING SOME DIMENSIONAL VARIABLES FROM FILE -----------------------------
  CALL msg(5,' Now reading file : '//trim(fnam))
  CALL ncerr(nf90_open(fnam, nf90_nowrite, ncid),fnam)
  CALL ncerr(nf90_inq_varid(ncid, trim(varname), varid),fnam)
  CALL ncerr(nf90_inquire_variable(ncid, varid, dimids=dids),fnam)

!--- Read unit for sea-ice variable only
  IF (mode=='SIC') THEN
    IF(nf90_get_att(ncid, varid, 'units', unit_sic)/=nf90_noerr) THEN
      CALL msg(5,'No unit in sea-ice file. Take percentage as default value')
      unit_sic='X'
    ELSE
      CALL msg(5,'Sea-ice cover has unit='//trim(unit_sic))
    END IF
  END IF

!--- Longitude
  CALL ncerr(nf90_inquire_dimension(ncid, dids(1), name=dnam, len=imdep),fnam)
  ALLOCATE(dlon_ini(imdep), dlon(imdep))
  CALL ncerr(nf90_inq_varid(ncid, dnam, varid), fnam)
  CALL ncerr(nf90_get_var(ncid, varid, dlon_ini), fnam)
  CALL msg(5,'variable '//trim(dnam)//' dimension ', imdep)

!--- Latitude
  CALL ncerr(nf90_inquire_dimension(ncid, dids(2), name=dnam, len=jmdep),fnam)
  ALLOCATE(dlat_ini(jmdep), dlat(jmdep))
  CALL ncerr(nf90_inq_varid(ncid, dnam, varid), fnam)
  CALL ncerr(nf90_get_var(ncid, varid, dlat_ini), fnam)
  CALL msg(5,'variable '//trim(dnam)//' dimension ', jmdep)

!--- Time (variable is not needed - it is rebuilt - but calendar is)
  CALL ncerr(nf90_inquire_dimension(ncid, dids(3), name=dnam, len=lmdep), fnam)
  ALLOCATE(timeyear(lmdep))
  CALL ncerr(nf90_inq_varid(ncid, dnam, varid), fnam)
  cal_in=' '
  IF(nf90_get_att(ncid, varid, 'calendar', cal_in)/=nf90_noerr) THEN
    SELECT CASE(mode)
      CASE('RUG', 'ALB'); cal_in='360d'
      CASE('SIC', 'SST'); cal_in='gregorian'
    END SELECT
  CALL msg(5,'WARNING: missing "calendar" attribute for "time" in '&
     &//trim(fnam)//'. Choosing default value.')
  END IF
  CALL msg(5,'var, calendar, dim: '//trim(dnam)//' '//trim(cal_in), lmdep)
  
!--- CONSTRUCTING THE INPUT TIME VECTOR FOR INTERPOLATION --------------------
  !--- Determining input file number of days, depending on calendar
  ndays_in=year_len(anneeref, cal_in)

!--- Time vector reconstruction (time vector from file is not trusted)
!--- If input records are not monthly, time sampling has to be constant !
  timeyear=mid_months(anneeref, cal_in, lmdep)
  IF (lmdep /= 12) WRITE(lunout,*) 'Note : les fichiers de ', trim(mode), &
       ' ne comportent pas 12, mais ', lmdep, ' enregistrements.'

!--- GETTING THE FIELD AND INTERPOLATING IT ----------------------------------
  ALLOCATE(champ(imdep, jmdep), champtime(iim, jjp1, lmdep))
  IF(extrp) ALLOCATE(work(imdep, jmdep))
  CALL msg(5,'')
  CALL msg(5,'LECTURE ET INTERPOLATION HORIZ. DE ', lmdep, ' CHAMPS.')
  CALL ncerr(nf90_inq_varid(ncid, varname, varid), fnam)
  DO l=1, lmdep
    CALL ncerr(nf90_get_var(ncid,varid,champ,[1,1,l],[imdep,jmdep,1]),fnam)
    CALL conf_dat2d(title, dlon_ini, dlat_ini, dlon, dlat, champ, .true.)
    IF(extrp) CALL extrapol(champ,imdep,jmdep,999999.,.true.,.true.,2,work)
    IF(l==1) THEN
      CALL msg(5,"----------------------------------------------------------")
      CALL msg(5,"$$$ Interpolation barycentrique pour "//trim(title)//" $$$")
      CALL msg(5,"----------------------------------------------------------")
    END IF
    IF(mode=='RUG') champ=log(champ)
    CALL inter_barxy(dlon,dlat(:jmdep-1),champ,rlonu(:iim),rlatv,champint)
    IF(mode=='RUG') THEN
      champint=exp(champint)
      WHERE(nint(mask)/=1) champint=0.001
    END IF
    champtime(:, :, l)=champint
  END DO
  CALL ncerr(nf90_close(ncid), fnam)

  DEALLOCATE(dlon_ini, dlat_ini, dlon, dlat, champ)
  IF(extrp) DEALLOCATE(work)

!--- TIME INTERPOLATION ------------------------------------------------------
  IF(prt_level>5) THEN
     WRITE(lunout, *)
     WRITE(lunout, *)'INTERPOLATION TEMPORELLE.'
     WRITE(lunout, *)' Vecteur temps en entree: ', timeyear
     WRITE(lunout, *)' Vecteur temps en sortie de 0 a ', ndays
  END IF

  ALLOCATE(yder(lmdep), champan(iip1, jjp1, ndays))
  skip = .false.
  n_extrap = 0
  DO j=1, jjp1
    DO i=1, iim
      yder = pchsp_95(timeyear, champtime(i, j, :), ibeg=2, iend=2, &
           vc_beg=0., vc_end=0.)
      CALL pchfe_95(timeyear, champtime(i, j, :), yder, skip, &
           arth(0., real(ndays_in) / ndays, ndays), champan(i, j, :), ierr)
      if (ierr < 0) stop 1
      n_extrap = n_extrap + ierr
    END DO
  END DO
  if (n_extrap /= 0) then
     WRITE(lunout,*) "get_2Dfield pchfe_95: n_extrap = ", n_extrap
  end if
  champan(iip1, :, :)=champan(1, :, :)
  DEALLOCATE(yder, champtime, timeyear)

!--- Checking the result
  DO j=1, jjp1
    CALL minmax(iip1, champan(1, j, 10), chmin, chmax)
    IF (prt_level>5) WRITE(lunout, *)' ',trim(title),' au temps 10 ', chmin, chmax, j
  END DO

!--- SPECIAL FILTER FOR SST: SST>271.38 --------------------------------------
  IF(mode=='SST') THEN
    CALL msg(5,'Filtrage de la SST: SST >= 271.38')
    WHERE(champan<271.38) champan=271.38
  END IF

!--- SPECIAL FILTER FOR SIC: 0.0<SIC<1.0 -------------------------------------
  IF(mode=='SIC') THEN
    CALL msg(5,'Filtrage de la SIC: 0.0 < Sea-ice < 1.0')

    IF (unit_sic=='1') THEN
       ! Nothing to be done for sea-ice field is already in fraction of 1
       ! This is the case for sea-ice in file cpl_atm_sic.nc
       CALL msg(5,'Sea-ice field already in fraction of 1')
    ELSE
       ! Convert sea ice from percentage to fraction of 1
       CALL msg(5,'Transformt sea-ice field from percentage to fraction of 1.')
       champan(:, :, :)=champan(:, :, :)/100.
    END IF

    champan(iip1, :, :)=champan(1, :, :)
    WHERE(champan>1.0) champan=1.0
    WHERE(champan<0.0) champan=0.0
 END IF

!--- DYNAMICAL TO PHYSICAL GRID ----------------------------------------------
  ALLOCATE(champo(klon, ndays))
  DO k=1, ndays
    CALL gr_dyn_fi(1, iip1, jjp1, klon, champan(1, 1, k), champo(1, k))
  END DO
  DEALLOCATE(champan)

END SUBROUTINE get_2dfield
!
!-------------------------------------------------------------------------------


!-------------------------------------------------------------------------------
!
SUBROUTINE start_init_orog0(lon_in,lat_in,phis,masque)
!
!-------------------------------------------------------------------------------
  IMPLICIT NONE
!===============================================================================
! Purpose:  Compute "phis" just like it would be in start_init_orog.
!===============================================================================
! Arguments:
  REAL,             INTENT(IN)    :: lon_in(:), lat_in(:)   ! dim (iml) (jml)
  REAL,             INTENT(INOUT) :: phis(:,:), masque(:,:) ! dim (iml,jml)
!-------------------------------------------------------------------------------
! Local variables:
  CHARACTER(LEN=256) :: modname="start_init_orog0"
  INTEGER            :: fid, llm_tmp,ttm_tmp, iml,jml, iml_rel,jml_rel, itau(1)
  REAL               :: lev(1), date, dt, deg2rad
  REAL, ALLOCATABLE  :: lon_rad(:), lon_ini(:), lon_rel(:,:), relief_hi(:,:)
  REAL, ALLOCATABLE  :: lat_rad(:), lat_ini(:), lat_rel(:,:)
!-------------------------------------------------------------------------------
  iml=assert_eq(SIZE(lon_in),SIZE(phis,1),SIZE(masque,1),trim(modname)//" iml")
  jml=assert_eq(SIZE(lat_in),SIZE(phis,2),SIZE(masque,2),trim(modname)//" jml")
  IF(iml/=iip1) CALL abort_gcm(trim(modname),'iml/=iip1',1)
  IF(jml/=jjp1) CALL abort_gcm(trim(modname),'jml/=jjp1',1)
  pi=2.0*asin(1.0); deg2rad=pi/180.0
  IF(any(phis/=-99999.)) RETURN                  !--- phis ALREADY KNOWN

!--- HIGH RESOLUTION OROGRAPHY
  CALL flininfo(frelf, iml_rel, jml_rel, llm_tmp, ttm_tmp, fid)

  ALLOCATE(lat_rel(iml_rel,jml_rel),lon_rel(iml_rel,jml_rel))
  CALL flinopen(frelf, .false., iml_rel, jml_rel, llm_tmp, lon_rel, lat_rel,   &
                lev, ttm_tmp, itau, date, dt, fid)
  ALLOCATE(relief_hi(iml_rel,jml_rel))
  CALL flinget(fid, vrel, iml_rel, jml_rel, llm_tmp, ttm_tmp, 1, 1, relief_hi)
  CALL flinclo(fid)

!--- IF ANGLES ARE IN DEGREES, THEY ARE CONVERTED INTO RADIANS
  ALLOCATE(lon_ini(iml_rel),lat_ini(jml_rel))
  lon_ini(:)=lon_rel(:,1); IF(maxval(lon_rel)>pi) lon_ini=lon_ini*deg2rad
  lat_ini(:)=lat_rel(1,:); IF(maxval(lat_rel)>pi) lat_ini=lat_ini*deg2rad

!--- FIELDS ARE PROCESSED TO BE ON STANDARD ANGULAR DOMAINS
  ALLOCATE(lon_rad(iml_rel),lat_rad(jml_rel))
  CALL conf_dat2d(vrel, lon_ini, lat_ini, lon_rad, lat_rad, relief_hi, .false.)
  DEALLOCATE(lon_ini,lat_ini)

!--- COMPUTING SURFACE GEOPOTENTIAL USING ROUTINE grid_noro0
  WRITE(lunout,*)
  WRITE(lunout,*)'*** Compute surface geopotential ***'

!--- CALL OROGRAPHY MODULE (REDUCED VERSION) TO COMPUTE FIELDS
  CALL grid_noro0(lon_rad, lat_rad, relief_hi, lon_in, lat_in, phis, masque)
  phis = phis * 9.81
  phis(iml,:) = phis(1,:)
  DEALLOCATE(relief_hi,lon_rad,lat_rad)

END SUBROUTINE start_init_orog0
!
!-------------------------------------------------------------------------------


!-------------------------------------------------------------------------------
!
SUBROUTINE grid_noro0(xd,yd,zd,x,y,zphi,mask)
!
!===============================================================================
! Purpose: Extracted from grid_noro to provide geopotential height for dynamics
!          without any call to physics subroutines.
!===============================================================================
  IMPLICIT NONE 
!-------------------------------------------------------------------------------
! Arguments:
  REAL, INTENT(IN)   :: xd(:), yd(:) !--- INPUT  COORDINATES     (imdp) (jmdp)
  REAL, INTENT(IN)   :: zd(:,:)      !--- INPUT  FIELD           (imdp,jmdp)
  REAL, INTENT(IN)   :: x(:), y(:)   !--- OUTPUT COORDINATES     (imar+1) (jmar)
  REAL, INTENT(OUT)  :: zphi(:,:)    !--- GEOPOTENTIAL           (imar+1,jmar)
  REAL, INTENT(INOUT):: mask(:,:)    !--- MASK                   (imar+1,jmar)
!-------------------------------------------------------------------------------
! Local variables:
  CHARACTER(LEN=256) :: modname="grid_noro0"
  REAL, ALLOCATABLE :: xusn(:), yusn(:)           ! dim (imdp+2*iext) (jmdp+2)
  REAL, ALLOCATABLE :: zusn(:,:)                  ! dim (imdp+2*iext,jmdp+2)
  REAL, ALLOCATABLE :: weight(:,:)                ! dim (imar+1,jmar)
  REAL, ALLOCATABLE :: mask_tmp(:,:), zmea(:,:)   ! dim (imar+1,jmar)
  REAL, ALLOCATABLE :: num_tot(:,:), num_lan(:,:) ! dim (imax,jmax)
  REAL, ALLOCATABLE :: a(:), b(:)                 ! dim (imax)
  REAL, ALLOCATABLE :: c(:), d(:)                 ! dim (jmax)
  LOGICAL :: masque_lu
  INTEGER :: i, ii, imdp, imar, iext
  INTEGER :: j, jj, jmdp, jmar, nn
  REAL    :: xpi, zlenx, weighx, xincr,  zbordnor, zmeanor, zweinor, zbordest
  REAL    :: rad, zleny, weighy, masque, zbordsud, zmeasud, zweisud, zbordoue
!-------------------------------------------------------------------------------
  imdp=assert_eq(SIZE(xd),SIZE(zd,1),trim(modname)//" imdp")
  jmdp=assert_eq(SIZE(yd),SIZE(zd,2),trim(modname)//" jmdp")
  imar=assert_eq(SIZE(x),SIZE(zphi,1),SIZE(mask,1),trim(modname)//" imar")-1
  jmar=assert_eq(SIZE(y),SIZE(zphi,2),SIZE(mask,2),trim(modname)//" jmar")
  IF(imar/=iim)   CALL abort_gcm(trim(modname),'imar/=iim'  ,1)
  IF(jmar/=jjm+1) CALL abort_gcm(trim(modname),'jmar/=jjm+1',1)
  iext=imdp/10
  xpi = acos(-1.)
  rad = 6371229.

!--- ARE WE USING A READ MASK ?
  masque_lu=any(mask/=-99999.); IF(.NOT.masque_lu) mask=0.0
  WRITE(lunout,*)'Masque lu: ',masque_lu

!--- EXTENSION OF THE INPUT DATABASE TO PROCEED COMPUTATIONS AT BOUNDARIES:
  ALLOCATE(xusn(imdp+2*iext))
  xusn(1     +iext:imdp  +iext)=xd(:)
  xusn(1          :       iext)=xd(1+imdp-iext:imdp)-2.*xpi
  xusn(1+imdp+iext:imdp+2*iext)=xd(1          :iext)+2.*xpi

  ALLOCATE(yusn(jmdp+2))
  yusn(1       )=yd(1)   +(yd(1)   -yd(2))
  yusn(2:jmdp+1)=yd(:)
  yusn(  jmdp+2)=yd(jmdp)+(yd(jmdp)-yd(jmdp-1))

  ALLOCATE(zusn(imdp+2*iext,jmdp+2))
  zusn(1       +iext:imdp  +iext,2:jmdp+1)=zd(:                   ,     :)
  zusn(1            :       iext,2:jmdp+1)=zd(imdp-iext+1:imdp    ,     :)
  zusn(1+imdp  +iext:imdp+2*iext,2:jmdp+1)=zd(1:iext              ,     :)
  zusn(1            :imdp/2+iext,       1)=zusn(1+imdp/2:imdp  +iext,     2)
  zusn(1+imdp/2+iext:imdp+2*iext,       1)=zusn(1       :imdp/2+iext,     2)
  zusn(1            :imdp/2+iext,  jmdp+2)=zusn(1+imdp/2:imdp  +iext,jmdp+1)
  zusn(1+imdp/2+iext:imdp+2*iext,  jmdp+2)=zusn(1       :imdp/2+iext,jmdp+1)

!--- COMPUTE LIMITS OF MODEL GRIDPOINT AREA (REGULAR GRID)
  ALLOCATE(a(imar+1),b(imar+1))
  b(1:imar)=(x(1:imar  )+ x(2:imar+1))/2.0
  b(imar+1)= x(  imar+1)+(x(  imar+1)-x(imar))/2.0
  a(1)=x(1)-(x(2)-x(1))/2.0
  a(2:imar+1)= b(1:imar)

  ALLOCATE(c(jmar),d(jmar))
  d(1:jmar-1)=(y(1:jmar-1)+ y(2:jmar))/2.0
  d(  jmar  )= y(  jmar  )+(y(  jmar)-y(jmar-1))/2.0
  c(1)=y(1)-(y(2)-y(1))/2.0
  c(2:jmar)=d(1:jmar-1)

!--- INITIALIZATIONS:
  ALLOCATE(weight(imar+1,jmar)); weight(:,:)= 0.0
  ALLOCATE(zmea(imar+1,jmar)); zmea(:,:)= 0.0

!--- SUMMATION OVER GRIDPOINT AREA
  zleny=xpi/REAL(jmdp)*rad
  xincr=xpi/REAL(jmdp)/2.
  ALLOCATE(num_tot(imar+1,jmar)); num_tot(:,:)=0.
  ALLOCATE(num_lan(imar+1,jmar)); num_lan(:,:)=0.
  DO ii = 1, imar+1
    DO jj = 1, jmar
      DO j = 2,jmdp+1 
        zlenx  =zleny  *cos(yusn(j))
        zbordnor=(xincr+c(jj)-yusn(j))*rad
        zbordsud=(xincr-d(jj)+yusn(j))*rad
        weighy=amax1(0.,amin1(zbordnor,zbordsud,zleny))
        IF(weighy/=0) THEN
          DO i = 2, imdp+2*iext-1
            zbordest=(xusn(i)-a(ii)+xincr)*rad*cos(yusn(j))
            zbordoue=(b(ii)+xincr-xusn(i))*rad*cos(yusn(j))
            weighx=amax1(0.,amin1(zbordest,zbordoue,zlenx))
            IF(weighx/=0)THEN
              num_tot(ii,jj)=num_tot(ii,jj)+1.0
              IF(zusn(i,j)>=1.)num_lan(ii,jj)=num_lan(ii,jj)+1.0
              weight(ii,jj)=weight(ii,jj)+weighx*weighy
              zmea(ii,jj)=zmea(ii,jj)+zusn(i,j)*weighx*weighy !--- MEAN
            END IF
          END DO
        END IF
      END DO
    END DO
  END DO

!--- COMPUTE PARAMETERS NEEDED BY LOTT & MILLER (1997) AND LOTT (1999) SSO SCHEME
  IF(.NOT.masque_lu) THEN
    WHERE(weight(:,1:jmar-1)/=0.0) mask=num_lan(:,:)/num_tot(:,:)
  END IF
  nn=count(weight(:,1:jmar-1)==0.0)
  IF(nn/=0) WRITE(lunout,*)'Problem with weight ; vanishing occurrences: ',nn
  WHERE(weight/=0.0) zmea(:,:)=zmea(:,:)/weight(:,:)

!--- MASK BASED ON GROUND MAXIMUM, 10% THRESHOLD (<10%: SURF PARAMS MEANINGLESS)
  ALLOCATE(mask_tmp(imar+1,jmar)); mask_tmp(:,:)=0.0
  WHERE(mask>=0.1) mask_tmp = 1.
  WHERE(weight(:,:)/=0.0)
    zphi(:,:)=mask_tmp(:,:)*zmea(:,:)
    zmea(:,:)=mask_tmp(:,:)*zmea(:,:)
  END WHERE
  WRITE(lunout,*)'  MEAN ORO:' ,maxval(zmea)

!--- Values at poles
  zphi(imar+1,:)=zphi(1,:)

  zweinor=sum(weight(1:imar,   1),dim=1)
  zweisud=sum(weight(1:imar,jmar),dim=1)
  zmeanor=sum(weight(1:imar,   1)*zmea(1:imar,   1),dim=1)
  zmeasud=sum(weight(1:imar,jmar)*zmea(1:imar,jmar),dim=1)
  zphi(:,1)=zmeanor/zweinor; zphi(:,jmar)=zmeasud/zweisud

END SUBROUTINE grid_noro0
!
!-------------------------------------------------------------------------------


!-------------------------------------------------------------------------------
!
FUNCTION year_len(y,cal_in)
!
!-------------------------------------------------------------------------------
  IMPLICIT NONE
!-------------------------------------------------------------------------------
! Arguments:
  INTEGER                       :: year_len
  INTEGER,           INTENT(IN) :: y
  CHARACTER(LEN=*),  INTENT(IN) :: cal_in
!-------------------------------------------------------------------------------
! Local variables:
  CHARACTER(LEN=20)             :: cal_out              ! calendar (for outputs)
!-------------------------------------------------------------------------------
!--- Getting the input calendar to reset at the end of the function
  CALL ioget_calendar(cal_out)

!--- Unlocking calendar and setting it to wanted one
  CALL lock_calendar(.false.); CALL ioconf_calendar(trim(cal_in))

!--- Getting the number of days in this year
  year_len=ioget_year_len(y)

!--- Back to original calendar
  CALL lock_calendar(.false.); CALL ioconf_calendar(trim(cal_out))

END FUNCTION year_len
!
!-------------------------------------------------------------------------------


!-------------------------------------------------------------------------------
!
FUNCTION mid_months(y,cal_in,nm)
!
!-------------------------------------------------------------------------------
  IMPLICIT NONE
!-------------------------------------------------------------------------------
! Arguments:
  INTEGER,                INTENT(IN) :: y               ! year
  CHARACTER(LEN=*),       INTENT(IN) :: cal_in          ! calendar
  INTEGER,                INTENT(IN) :: nm              ! months/year number
  REAL,    DIMENSION(nm)             :: mid_months      ! mid-month times
!-------------------------------------------------------------------------------
! Local variables:
  CHARACTER(LEN=99)                  :: mess            ! error message
  CHARACTER(LEN=20)                  :: cal_out         ! calendar (for outputs)
  INTEGER, DIMENSION(nm)             :: mnth            ! months lengths (days)
  INTEGER                            :: m               ! months counter
  INTEGER                            :: nd              ! number of days
!-------------------------------------------------------------------------------
  nd=year_len(y,cal_in)

  IF(nm==12) THEN

  !--- Getting the input calendar to reset at the end of the function
    CALL ioget_calendar(cal_out)

  !--- Unlocking calendar and setting it to wanted one
    CALL lock_calendar(.false.); CALL ioconf_calendar(trim(cal_in))

  !--- Getting the length of each month
    DO m=1,nm; mnth(m)=ioget_mon_len(y,m); END DO

  !--- Back to original calendar
    CALL lock_calendar(.false.); CALL ioconf_calendar(trim(cal_out))

  ELSE IF(modulo(nd,nm)/=0) THEN
    WRITE(mess,'(a,i3,a,i3,a)')'Unconsistent calendar: ',nd,' days/year, but ',&
      nm,' months/year. Months number should divide days number.'
    CALL abort_physic('mid_months',trim(mess),1)

  ELSE
    mnth=[(m,m=1,nm,nd/nm)]
  END IF

!--- Mid-months times
  mid_months(1)=0.5*REAL(mnth(1))
  DO k=2,nm
    mid_months(k)=mid_months(k-1)+0.5*REAL(mnth(k-1)+mnth(k))
  END DO

END FUNCTION mid_months
!
!-------------------------------------------------------------------------------



!-------------------------------------------------------------------------------
!
SUBROUTINE msg(lev,str1,i,str2)
!
!-------------------------------------------------------------------------------
! Arguments:
  INTEGER,                    INTENT(IN) :: lev
  CHARACTER(LEN=*),           INTENT(IN) :: str1
  INTEGER,          OPTIONAL, INTENT(IN) :: i
  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: str2
!-------------------------------------------------------------------------------
  IF(prt_level>lev) THEN
    IF(PRESENT(str2)) THEN
      WRITE(lunout,*) trim(str1), i, trim(str2)
    ELSE IF(PRESENT(i)) THEN
      WRITE(lunout,*) trim(str1), i
    ELSE
      WRITE(lunout,*) trim(str1)
    END IF
  END IF

END SUBROUTINE msg
!
!-------------------------------------------------------------------------------


!-------------------------------------------------------------------------------
!
SUBROUTINE ncerr(ncres,fnam)
!
!-------------------------------------------------------------------------------
! Purpose: NetCDF errors handling.
!-------------------------------------------------------------------------------
  USE netcdf, ONLY : nf90_noerr, nf90_strerror
  IMPLICIT NONE
!-------------------------------------------------------------------------------
! Arguments:
  INTEGER,          INTENT(IN) :: ncres
  CHARACTER(LEN=*), INTENT(IN) :: fnam
!-------------------------------------------------------------------------------
  IF(ncres/=nf90_noerr) THEN
    WRITE(lunout,*)'Problem with file '//trim(fnam)//' in routine limit_netcdf.'
    CALL abort_physic('limit_netcdf',nf90_strerror(ncres),1)
  END IF

END SUBROUTINE ncerr
!
!-------------------------------------------------------------------------------

#endif
! of #ifndef CPP_1D
END SUBROUTINE limit_netcdf

END MODULE limit
!
!*******************************************************************************