source: LMDZ4/branches/LMDZ4_AR5/libf/dyn3d/limit_netcdf.F90 @ 5425

Last change on this file since 5425 was 1402, checked in by jghattas, 15 years ago

Bug fix : Added a test if optional argument is present before use.


Correction de bug : ajout du test de presence d'un argument optionel avant son utilisation.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 25.6 KB
Line 
1!
2! $Id: limit_netcdf.F90 1402 2010-06-22 09:34:56Z jyg $
3!-------------------------------------------------------------------------------
4!
5SUBROUTINE limit_netcdf(interbar, extrap, oldice, masque)
6!
7!-------------------------------------------------------------------------------
8! Author : L. Fairhead, 27/01/94
9!-------------------------------------------------------------------------------
10! Purpose: Boundary conditions files building for new model using climatologies.
11!          Both grids have to be regular.
12!-------------------------------------------------------------------------------
13! Note: This routine is designed to work for Earth
14!-------------------------------------------------------------------------------
15! Modification history:
16!  * 23/03/1994: Z. X. Li
17!  *    09/1999: L. Fairhead (netcdf reading in LMDZ.3.3)
18!  *    07/2001: P. Le Van
19!  *    11/2009: L. Guez     (ozone day & night climatos, see etat0_netcdf.F90)
20!  *    12/2009: D. Cugnet   (f77->f90, calendars, files from coupled runs)
21!-------------------------------------------------------------------------------
22#ifdef CPP_EARTH
23  USE dimphy
24  USE ioipsl,             ONLY : ioget_year_len
25  USE phys_state_var_mod, ONLY : pctsrf
26  USE netcdf,             ONLY : NF90_OPEN,    NF90_CREATE,  NF90_CLOSE,       &
27                   NF90_DEF_DIM, NF90_DEF_VAR, NF90_PUT_VAR, NF90_PUT_ATT,     &
28                   NF90_NOERR,   NF90_NOWRITE, NF90_DOUBLE,  NF90_GLOBAL,      &
29                   NF90_CLOBBER, NF90_ENDDEF,  NF90_UNLIMITED
30  USE inter_barxy_m, only: inter_barxy
31#endif
32  IMPLICIT NONE
33!-------------------------------------------------------------------------------
34! Arguments:
35#include "dimensions.h"
36#include "paramet.h"
37#include "iniprint.h"
38  LOGICAL,                    INTENT(IN) :: interbar ! barycentric interpolation
39  LOGICAL,                    INTENT(IN) :: extrap   ! SST extrapolation flag
40  LOGICAL,                    INTENT(IN) :: oldice   ! old way ice computation
41  REAL, DIMENSION(iip1,jjp1), INTENT(IN) :: masque   ! land mask
42#ifndef CPP_EARTH
43  WRITE(lunout,*)'limit_netcdf: Earth-specific routine, needs Earth physics'
44#else
45!-------------------------------------------------------------------------------
46! Local variables:
47#include "control.h"
48#include "logic.h"
49#include "comvert.h"
50#include "comgeom2.h"
51#include "comconst.h"
52#include "indicesol.h"
53
54!--- For fractionary sub-cell use (old coding used soil index: 0,1,2,3) --------
55  LOGICAL, PARAMETER :: fracterre=.TRUE.
56
57!--- INPUT NETCDF FILES NAMES --------------------------------------------------
58  CHARACTER(LEN=25) :: icefile, sstfile, dumstr
59  CHARACTER(LEN=25), PARAMETER :: famipsst='amipbc_sst_1x1.nc        ',        &
60                                  famipsic='amipbc_sic_1x1.nc        ',        &
61                                  fclimsst='amipbc_sst_1x1_clim.nc   ',        &
62                                  fclimsic='amipbc_sic_1x1_clim.nc   ',        &
63                                  fcpldsst='cpl_atm_sst.nc           ',        &
64                                  fcpldsic='cpl_atm_sic.nc           ',        &
65                                  frugo   ='Rugos.nc                 ',        &
66                                  falbe   ='Albedo.nc                '
67
68!--- OUTPUT VARIABLES FOR NETCDF FILE ------------------------------------------
69  REAL,   DIMENSION(klon)                :: fi_ice, verif
70  REAL,   DIMENSION(:,:),   POINTER      :: phy_rug=>NULL(), phy_ice=>NULL()
71  REAL,   DIMENSION(:,:),   POINTER      :: phy_sst=>NULL(), phy_alb=>NULL()
72  REAL,   DIMENSION(:,:),   ALLOCATABLE  :: phy_bil
73  REAL,   DIMENSION(:,:,:), ALLOCATABLE  :: pctsrf_t
74  INTEGER                                :: nbad
75
76!--- VARIABLES FOR OUTPUT FILE WRITING -----------------------------------------
77  INTEGER :: ierr, nid, ndim, ntim, k
78  INTEGER, DIMENSION(2) :: dims
79  INTEGER :: id_tim,  id_SST,  id_BILS, id_RUG, id_ALB
80  INTEGER :: id_FOCE, id_FSIC, id_FTER, id_FLIC
81  INTEGER :: NF90_FORMAT
82  LOGICAL :: lCPL                    !--- T: IPCC-IPSL cpl model output files
83  INTEGER :: ndays                   !--- Depending on the output calendar
84
85!--- INITIALIZATIONS -----------------------------------------------------------
86#ifdef NC_DOUBLE
87  NF90_FORMAT=NF90_DOUBLE
88#else
89  NF90_FORMAT=NF90_FLOAT
90#endif
91
92  pi    = 4.*ATAN(1.)
93  rad   = 6371229.
94  daysec= 86400.
95  omeg  = 2.*pi/daysec
96  g     = 9.8
97  kappa = 0.2857143
98  cpp   = 1004.70885
99  dtvr  = daysec/FLOAT(day_step)
100  CALL inigeom
101
102!--- Beware: anneeref (from gcm.def) is used to determine output time sampling
103  ndays=ioget_year_len(anneeref)
104
105!--- RUGOSITY TREATMENT --------------------------------------------------------
106  WRITE(lunout,*) 'Traitement de la rugosite'
107  CALL get_2Dfield(frugo,'RUG',interbar,ndays,phy_rug,mask=masque(1:iim,:))
108
109!--- OCEAN TREATMENT -----------------------------------------------------------
110  PRINT*, 'Traitement de la glace oceanique' ; icefile=''; lCPL=.FALSE.
111
112! Input SIC file selection
113  icefile='fake'
114  IF(NF90_OPEN(famipsic,NF90_NOWRITE,nid)==NF90_NOERR) icefile=TRIM(famipsic)
115  IF(NF90_OPEN(fclimsic,NF90_NOWRITE,nid)==NF90_NOERR) icefile=TRIM(fclimsic)
116  IF(NF90_OPEN(fcpldsic,NF90_NOWRITE,nid)==NF90_NOERR) icefile=TRIM(fcpldsic)
117  SELECT CASE(icefile)
118    CASE(famipsic); dumstr='Amip.'
119    CASE(fclimsic); dumstr='Amip climatologique.'
120    CASE(fcpldsic); dumstr='de sortie du modele couplé IPSL/IPCC.';lCPL=.TRUE.
121    CASE('fake');   CALL abort_gcm('limit_netcdf','Fichier SIC non reconnu.',1)
122  END SELECT
123  ierr=NF90_CLOSE(nid)
124  WRITE(lunout,*)'Pour la glace de mer a ete choisi un fichier '//TRIM(dumstr)
125
126  CALL get_2Dfield(icefile,'SIC',interbar,ndays,phy_ice,flag=oldice,lCPL=lCPL)
127
128  ALLOCATE(pctsrf_t(klon,nbsrf,ndays))
129  DO k=1,ndays
130    fi_ice=phy_ice(:,k)
131    WHERE(fi_ice>=1.0  ) fi_ice=1.0
132    WHERE(fi_ice<EPSFRA) fi_ice=0.0
133    IF(fracterre) THEN
134      pctsrf_t(:,is_ter,k)=pctsrf(:,is_ter)       ! land soil
135      pctsrf_t(:,is_lic,k)=pctsrf(:,is_lic)       ! land ice
136      IF(lCPL) THEN                               ! SIC=pICE*(1-LIC-TER)
137        pctsrf_t(:,is_sic,k)=fi_ice*(1-pctsrf(:,is_lic)-pctsrf(:,is_ter))
138      ELSE                                        ! SIC=pICE-LIC
139        pctsrf_t(:,is_sic,k)=fi_ice-pctsrf_t(:,is_lic,k)
140      END IF
141      WHERE(pctsrf_t(:,is_sic,k)<=0) pctsrf_t(:,is_sic,k)=0.
142      WHERE(1.0-zmasq<EPSFRA)
143        pctsrf_t(:,is_sic,k)=0.0
144        pctsrf_t(:,is_oce,k)=0.0
145      ELSEWHERE
146        WHERE(pctsrf_t(:,is_sic,k)>=1.0-zmasq)
147          pctsrf_t(:,is_sic,k)=1.0-zmasq
148          pctsrf_t(:,is_oce,k)=0.0
149        ELSEWHERE
150          pctsrf_t(:,is_oce,k)=1.0-zmasq-pctsrf_t(:,is_sic,k)
151          WHERE(pctsrf_t(:,is_oce,k)<EPSFRA)
152            pctsrf_t(:,is_oce,k)=0.0
153            pctsrf_t(:,is_sic,k)=1.0-zmasq
154          END WHERE
155        END WHERE
156      END WHERE
157      nbad=COUNT(pctsrf_t(:,is_oce,k)<0.0)
158      IF(nbad>0) WRITE(lunout,*) 'pb sous maille pour nb point = ',nbad
159      nbad=COUNT(abs(sum(pctsrf_t(:,:,k),dim=2)-1.0)>EPSFRA)
160      IF(nbad>0) WRITE(lunout,*) 'pb sous surface pour nb points = ',nbad
161    ELSE
162      pctsrf_t(:,is_ter,k)=pctsrf(:,is_ter)
163      WHERE(NINT(pctsrf(:,is_ter))==1)
164        pctsrf_t(:,is_sic,k)=0.
165        pctsrf_t(:,is_oce,k)=0.                 
166        WHERE(fi_ice>=1.e-5)
167          pctsrf_t(:,is_lic,k)=fi_ice
168          pctsrf_t(:,is_ter,k)=pctsrf_t(:,is_ter,k)-pctsrf_t(:,is_lic,k)
169        ELSEWHERE
170          pctsrf_t(:,is_lic,k)=0.0
171        END WHERE
172      ELSEWHERE
173        pctsrf_t(:,is_lic,k) = 0.0
174        WHERE(fi_ice>=1.e-5)
175          pctsrf_t(:,is_ter,k)=0.0
176          pctsrf_t(:,is_sic,k)=fi_ice
177          pctsrf_t(:,is_oce,k)=1.0-pctsrf_t(:,is_sic,k)
178        ELSEWHERE
179          pctsrf_t(:,is_sic,k)=0.0
180          pctsrf_t(:,is_oce,k)=1.0
181        END WHERE
182      END WHERE
183      verif=sum(pctsrf_t(:,:,k),dim=2)
184      nbad=COUNT(verif<1.0-1.e-5.OR.verif>1.0+1.e-5)
185      IF(nbad>0) WRITE(lunout,*) 'pb sous maille pour nb point = ',nbad
186    END IF
187  END DO
188  DEALLOCATE(phy_ice)
189
190!--- SST TREATMENT -------------------------------------------------------------
191  WRITE(lunout,*) 'Traitement de la sst' ; sstfile=''; lCPL=.FALSE.
192
193! Input SST file selection
194  sstfile='fake'
195  IF(NF90_OPEN(famipsst,NF90_NOWRITE,nid)==NF90_NOERR) sstfile=TRIM(famipsst)
196  IF(NF90_OPEN(fclimsst,NF90_NOWRITE,nid)==NF90_NOERR) sstfile=TRIM(fclimsst)
197  IF(NF90_OPEN(fcpldsst,NF90_NOWRITE,nid)==NF90_NOERR) sstfile=TRIM(fcpldsst)
198  SELECT CASE(icefile)
199    CASE(famipsic); dumstr='Amip.'
200    CASE(fclimsic); dumstr='Amip climatologique.'
201    CASE(fcpldsic); dumstr='de sortie du modele couplé IPSL/IPCC.';lCPL=.TRUE.
202    CASE('fake');   CALL abort_gcm('limit_netcdf','Fichier SST non reconnu',1)
203  END SELECT
204  ierr=NF90_CLOSE(nid)
205  WRITE(lunout,*)'Pour la temperature de mer a ete choisi un fichier '//TRIM(dumstr)
206
207  CALL get_2Dfield(trim(sstfile),'SST',interbar,ndays,phy_sst,flag=extrap)
208
209!--- ALBEDO TREATMENT ----------------------------------------------------------
210  WRITE(lunout,*) 'Traitement de l albedo'
211  CALL get_2Dfield(falbe,'ALB',interbar,ndays,phy_alb)
212
213!--- REFERENCE GROUND HEAT FLUX TREATMENT --------------------------------------
214  ALLOCATE(phy_bil(klon,ndays)); phy_bil=0.0
215
216!--- OUTPUT FILE WRITING -------------------------------------------------------
217  WRITE(lunout,*) 'Ecriture du fichier limit'
218
219  !--- File creation
220  ierr=NF90_CREATE("limit.nc",NF90_CLOBBER,nid)
221  ierr=NF90_PUT_ATT(nid,NF90_GLOBAL,"title","Fichier conditions aux limites")
222
223  !--- Dimensions creation
224  ierr=NF90_DEF_DIM(nid,"points_physiques",klon,ndim)
225  ierr=NF90_DEF_DIM(nid,"time",NF90_UNLIMITED,ntim)
226
227  dims=(/ndim,ntim/)
228
229  !--- Variables creation
230  ierr=NF90_DEF_VAR(nid,"TEMPS",NF90_FORMAT,(/ntim/),id_tim)
231  ierr=NF90_DEF_VAR(nid,"FOCE", NF90_FORMAT,dims,id_FOCE)
232  ierr=NF90_DEF_VAR(nid,"FSIC", NF90_FORMAT,dims,id_FSIC)
233  ierr=NF90_DEF_VAR(nid,"FTER", NF90_FORMAT,dims,id_FTER)
234  ierr=NF90_DEF_VAR(nid,"FLIC", NF90_FORMAT,dims,id_FLIC)
235  ierr=NF90_DEF_VAR(nid,"SST",  NF90_FORMAT,dims,id_SST)
236  ierr=NF90_DEF_VAR(nid,"BILS", NF90_FORMAT,dims,id_BILS)
237  ierr=NF90_DEF_VAR(nid,"ALB",  NF90_FORMAT,dims,id_ALB)
238  ierr=NF90_DEF_VAR(nid,"RUG",  NF90_FORMAT,dims,id_RUG)
239
240  !--- Attributes creation
241  ierr=NF90_PUT_ATT(nid,id_tim, "title","Jour dans l annee")
242  ierr=NF90_PUT_ATT(nid,id_FOCE,"title","Fraction ocean")
243  ierr=NF90_PUT_ATT(nid,id_FSIC,"title","Fraction glace de mer")
244  ierr=NF90_PUT_ATT(nid,id_FTER,"title","Fraction terre")
245  ierr=NF90_PUT_ATT(nid,id_FLIC,"title","Fraction land ice")
246  ierr=NF90_PUT_ATT(nid,id_SST ,"title","Temperature superficielle de la mer")
247  ierr=NF90_PUT_ATT(nid,id_BILS,"title","Reference flux de chaleur au sol")
248  ierr=NF90_PUT_ATT(nid,id_ALB, "title","Albedo a la surface")
249  ierr=NF90_PUT_ATT(nid,id_RUG, "title","Rugosite")
250
251  ierr=NF90_ENDDEF(nid)
252
253  !--- Variables saving
254  ierr=NF90_PUT_VAR(nid,id_tim,(/(REAL(k),k=1,ndays)/))
255  ierr=NF90_PUT_VAR(nid,id_FOCE,pctsrf_t(:,is_oce,:),(/1,1/),(/klon,ndays/))
256  ierr=NF90_PUT_VAR(nid,id_FSIC,pctsrf_t(:,is_sic,:),(/1,1/),(/klon,ndays/))
257  ierr=NF90_PUT_VAR(nid,id_FTER,pctsrf_t(:,is_ter,:),(/1,1/),(/klon,ndays/))
258  ierr=NF90_PUT_VAR(nid,id_FLIC,pctsrf_t(:,is_lic,:),(/1,1/),(/klon,ndays/))
259  ierr=NF90_PUT_VAR(nid,id_SST ,phy_sst(:,:),(/1,1/),(/klon,ndays/))
260  ierr=NF90_PUT_VAR(nid,id_BILS,phy_bil(:,:),(/1,1/),(/klon,ndays/))
261  ierr=NF90_PUT_VAR(nid,id_ALB ,phy_alb(:,:),(/1,1/),(/klon,ndays/))
262  ierr=NF90_PUT_VAR(nid,id_RUG ,phy_rug(:,:),(/1,1/),(/klon,ndays/))
263
264  ierr=NF90_CLOSE(nid)
265
266  DEALLOCATE(pctsrf_t,phy_sst,phy_bil,phy_alb,phy_rug)
267#endif
268! of #ifdef CPP_EARTH
269  STOP
270
271
272!===============================================================================
273!
274  CONTAINS
275!
276!===============================================================================
277
278
279!-------------------------------------------------------------------------------
280!
281SUBROUTINE get_2Dfield(fnam, mode, ibar, ndays, champo, flag, mask, lCPL)
282!
283!-------------------------------------------------------------------------------
284! Comments:
285!   There are two assumptions concerning the NetCDF files, that are satisfied
286!   with files that are conforming NC convention:
287!     1) The last dimension of the variables used is the time record.
288!     2) Dimensional variables have the same names as corresponding dimensions.
289!-------------------------------------------------------------------------------
290  USE netcdf, ONLY : NF90_OPEN,    NF90_INQ_VARID, NF90_INQUIRE_VARIABLE,      &
291                     NF90_CLOSE,   NF90_INQ_DIMID, NF90_INQUIRE_DIMENSION,     &
292                     NF90_GET_VAR, NF90_GET_ATT
293  USE dimphy, ONLY : klon
294  USE phys_state_var_mod, ONLY : pctsrf
295  IMPLICIT NONE
296#include "dimensions.h"
297#include "paramet.h"
298#include "comgeom2.h"
299#include "control.h"
300#include "indicesol.h"
301#include "iniprint.h"
302!-------------------------------------------------------------------------------
303! Arguments:
304  CHARACTER(LEN=*),  INTENT(IN)     :: fnam     ! NetCDF file name
305  CHARACTER(LEN=3),  INTENT(IN)     :: mode     ! RUG, SIC, SST or ALB
306  LOGICAL,           INTENT(IN)     :: ibar     ! interp on pressure levels
307  INTEGER,           INTENT(IN)     :: ndays    ! current year number of days
308  REAL,    POINTER,  DIMENSION(:,:) :: champo   ! output field = f(t)
309  LOGICAL, OPTIONAL, INTENT(IN)     :: flag     ! extrapol. (SST)  old ice (SIC)
310  REAL,    OPTIONAL, DIMENSION(iim,jjp1), INTENT(IN) :: mask
311  LOGICAL, OPTIONAL, INTENT(IN)     :: lCPL     ! Coupled model flag (for ICE)
312!-------------------------------------------------------------------------------
313! Local variables:
314!--- NetCDF
315  INTEGER :: ierr, ncid, varid                  ! NetCDF identifiers
316  CHARACTER(LEN=30)               :: dnam       ! dimension name
317  CHARACTER(LEN=80)               :: varname    ! NetCDF variable name
318!--- dimensions
319  INTEGER,           DIMENSION(4) :: dids       ! NetCDF dimensions identifiers
320  REAL, ALLOCATABLE, DIMENSION(:) :: dlon_ini   ! initial longitudes vector
321  REAL, ALLOCATABLE, DIMENSION(:) :: dlat_ini   ! initial latitudes  vector
322  REAL, POINTER,     DIMENSION(:) :: dlon, dlat ! reordered lon/lat  vectors
323!--- fields
324  INTEGER :: imdep, jmdep, lmdep                ! dimensions of 'champ'
325  REAL, ALLOCATABLE, DIMENSION(:,:) :: champ      ! wanted field on initial grid
326  REAL, ALLOCATABLE, DIMENSION(:) :: yder, timeyear
327  REAL,              DIMENSION(iim,jjp1) :: champint   ! interpolated field
328  REAL, ALLOCATABLE, DIMENSION(:,:,:)    :: champtime
329  REAL, ALLOCATABLE, DIMENSION(:,:,:)    :: champan
330  REAL                              :: time, by
331!--- input files
332  CHARACTER(LEN=20)                 :: cal_in   ! calendar
333  INTEGER                           :: ndays_in ! number of days
334!--- misc
335  INTEGER :: i, j, k, l                         ! loop counters
336  REAL, ALLOCATABLE, DIMENSION(:,:) :: work     ! used for extrapolation
337  CHARACTER(LEN=25)                 :: title    ! for messages
338  LOGICAL                           :: extrp    ! flag for extrapolation
339  REAL                              :: chmin, chmax
340!-------------------------------------------------------------------------------
341!---Variables depending on keyword 'mode' --------------------------------------
342  NULLIFY(champo)
343  SELECT CASE(mode)
344    CASE('RUG'); varname='RUGOS';  title='Rugosite'
345    CASE('SIC'); varname='sicbcs'; title='Sea-ice'
346    CASE('SST'); varname='tosbcs'; title='SST'
347    CASE('ALB'); varname='ALBEDO'; title='Albedo'
348  END SELECT
349
350  extrp=.FALSE.
351  IF ( PRESENT(flag) ) THEN
352     IF ( flag .AND. mode=='SST' ) extrp=.TRUE.
353  END IF
354
355!--- GETTING SOME DIMENSIONAL VARIABLES FROM FILE ------------------------------
356  ierr=NF90_OPEN(fnam,NF90_NOWRITE,ncid);                  CALL ncerr(ierr,fnam)
357  ierr=NF90_INQ_VARID(ncid,varname,varid);                 CALL ncerr(ierr,fnam)
358  ierr=NF90_INQUIRE_VARIABLE(ncid,varid,dimids=dids);      CALL ncerr(ierr,fnam)
359
360!--- Longitude
361  ierr=NF90_INQUIRE_DIMENSION(ncid,dids(1),name=dnam,len=imdep)
362  CALL ncerr(ierr,fnam); ALLOCATE(dlon_ini(imdep),dlon(imdep))
363  ierr=NF90_INQ_VARID(ncid,dnam,varid);                    CALL ncerr(ierr,fnam)
364  ierr=NF90_GET_VAR(ncid,varid,dlon_ini);                  CALL ncerr(ierr,fnam)
365  WRITE(lunout,*) 'variable ', dnam, 'dimension ', imdep
366
367!--- Latitude
368  ierr=NF90_INQUIRE_DIMENSION(ncid,dids(2),name=dnam,len=jmdep)
369  CALL ncerr(ierr,fnam); ALLOCATE(dlat_ini(jmdep),dlat(jmdep))
370  ierr=NF90_INQ_VARID(ncid,dnam,varid);                    CALL ncerr(ierr,fnam)
371  ierr=NF90_GET_VAR(ncid,varid,dlat_ini);                  CALL ncerr(ierr,fnam)
372  WRITE(lunout,*) 'variable ', dnam, 'dimension ', jmdep
373
374!--- Time (variable is not needed - it is rebuilt - but calendar is)
375  ierr=NF90_INQUIRE_DIMENSION(ncid,dids(3),name=dnam,len=lmdep)
376  CALL ncerr(ierr,fnam); ALLOCATE(timeyear(lmdep))
377  ierr=NF90_INQ_VARID(ncid,dnam,varid);                    CALL ncerr(ierr,fnam)
378  cal_in=' '
379  ierr=NF90_GET_ATT(ncid,varid,'calendar',cal_in)
380  IF(ierr/=NF90_NOERR) THEN
381    SELECT CASE(mode)
382      CASE('RUG','ALB'); cal_in='360d'
383      CASE('SIC','SST'); cal_in='gregorian'
384    END SELECT
385    WRITE(lunout,*)'ATTENTION: variable ''time'' sans attribut ''calendrier'' d&
386     &ans '//TRIM(fnam)//'. On choisit la valeur par defaut.'
387  END IF
388  WRITE(lunout,*) 'variable ', dnam, 'dimension ', lmdep, 'calendrier ', cal_in
389
390!--- CONSTRUCTING THE INPUT TIME VECTOR FOR INTERPOLATION ----------------------
391  !--- Determining input file number of days, depending on calendar
392  ndays_in=year_len(anneeref,cal_in)
393
394!--- Time vector reconstruction (time vector from file is not trusted)
395!--- If input records are not monthly, time sampling has to be constant !
396  timeyear=mid_months(anneeref,cal_in,lmdep)
397  IF(lmdep/=12) WRITE(lunout,'(a,i3,a)')'Note: les fichiers de '//TRIM(mode)   &
398    //' ne comportent pas 12, mais ',lmdep,' enregistrements.'
399
400!--- GETTING THE FIELD AND INTERPOLATING IT ------------------------------------
401  ALLOCATE(champ(imdep,jmdep),champtime(iim,jjp1,lmdep))
402  IF(extrp) ALLOCATE(work(imdep,jmdep))
403
404  WRITE(lunout,*)
405  WRITE(lunout,'(a,i3,a)')'LECTURE ET INTERPOLATION HORIZ. DE ',lmdep,' CHAMPS.'
406  ierr=NF90_INQ_VARID(ncid,varname,varid);                 CALL ncerr(ierr,fnam)
407  DO l=1,lmdep
408    ierr=NF90_GET_VAR(ncid,varid,champ,(/1,1,l/),(/imdep,jmdep,1/))
409    CALL ncerr(ierr,fnam)
410    CALL conf_dat2d(title,imdep,jmdep,dlon_ini,dlat_ini,dlon,dlat,champ,ibar)
411
412    IF(extrp) CALL extrapol(champ,imdep,jmdep,999999.,.TRUE.,.TRUE.,2,work)
413
414    IF(ibar.AND..NOT.(mode=='SIC'.AND.flag)) THEN
415      IF(l==1) THEN
416        WRITE(lunout,*)                                                        &
417  '-------------------------------------------------------------------------'
418        WRITE(lunout,*)                                                        &
419  '$$$ Utilisation de l''interpolation barycentrique pour '//TRIM(title)//' $$$'
420        WRITE(lunout,*)                                                        &
421  '-------------------------------------------------------------------------'
422      END IF
423      IF(mode=='RUG') champ=LOG(champ)
424      CALL inter_barxy(dlon, dlat(:jmdep-1), champ, rlonu(:iim),     &
425                         rlatv, champint)
426      IF(mode=='RUG') THEN
427        champint=EXP(champint)
428        WHERE(NINT(mask)/=1) champint=0.001
429      END IF
430    ELSE
431      SELECT CASE(mode)
432        CASE('RUG');       CALL rugosite(imdep, jmdep, dlon, dlat, champ,    &
433                                    iim, jjp1, rlonv, rlatu, champint, mask)
434        CASE('SIC');       CALL sea_ice (imdep, jmdep, dlon, dlat, champ,    &
435                                    iim, jjp1, rlonv, rlatu, champint)
436        CASE('SST','ALB'); CALL grille_m(imdep, jmdep, dlon, dlat, champ,    &
437                                    iim, jjp1, rlonv, rlatu, champint)
438      END SELECT
439    END IF
440    champtime(:,:,l)=champint
441  END DO
442  ierr=NF90_CLOSE(ncid);                                   CALL ncerr(ierr,fnam)
443
444  DEALLOCATE(dlon_ini,dlat_ini,dlon,dlat,champ)
445  IF(extrp) DEALLOCATE(work)
446
447!--- TIME INTERPOLATION --------------------------------------------------------
448  WRITE(lunout,*)
449  WRITE(lunout,*)'INTERPOLATION TEMPORELLE.'
450  WRITE(lunout,"(2x,' Vecteur temps en entree: ',10f6.1)") timeyear
451  WRITE(lunout,"(2x,' Vecteur temps en sortie de 0 a ',i3)") ndays
452  ALLOCATE(yder(lmdep),champan(iip1,jjp1,ndays))
453  DO j=1,jjp1
454    DO i=1,iim
455      CALL spline(timeyear,champtime(i,j,:),lmdep,1.e30,1.e30,yder)
456      DO k=1,ndays
457        time=FLOAT((k-1)*ndays_in)/FLOAT(ndays)
458        CALL splint(timeyear,champtime(i,j,:),yder,lmdep,time,by)
459        champan(i,j,k) = by
460      END DO
461    END DO
462  END DO
463  champan(iip1,:,:)=champan(1,:,:)
464  DEALLOCATE(yder,champtime,timeyear)
465
466!--- Checking the result
467  DO j=1,jjp1
468    CALL minmax(iip1,champan(1,j,10),chmin,chmax)
469    WRITE(lunout,*)' '//TRIM(title)//' au temps 10 ',chmin,chmax,j
470  END DO
471
472!--- SPECIAL FILTER FOR SST: SST>271.38 ----------------------------------------
473  IF(mode=='SST') THEN
474    WRITE(lunout,*) 'Filtrage de la SST: SST >= 271.38'
475    WHERE(champan<271.38) champan=271.38
476  END IF
477
478!--- SPECIAL FILTER FOR SIC: 0.0<SIC<1.0 ---------------------------------------
479  IF(mode=='SIC') THEN
480    WRITE(lunout,*) 'Filtrage de la SIC: 0.0 < Sea-ice < 1.0'
481    IF(.NOT.lCPL) champan(:,:,:)=champan(:,:,:)/100.
482    champan(iip1,:,:)=champan(1,:,:)
483    WHERE(champan>1.0) champan=1.0
484    WHERE(champan<0.0) champan=0.0
485  END IF
486
487!--- DYNAMICAL TO PHYSICAL GRID ------------------------------------------------
488  ALLOCATE(champo(klon,ndays))
489  DO k=1,ndays
490    CALL gr_dyn_fi(1,iip1,jjp1,klon,champan(1,1,k),champo(1,k))
491  END DO
492  DEALLOCATE(champan)
493
494END SUBROUTINE get_2Dfield
495!
496!-------------------------------------------------------------------------------
497
498
499
500!-------------------------------------------------------------------------------
501!
502FUNCTION year_len(y,cal_in)
503!
504!-------------------------------------------------------------------------------
505  USE ioipsl, ONLY : ioget_calendar,ioconf_calendar,lock_calendar,ioget_year_len
506  IMPLICIT NONE
507!-------------------------------------------------------------------------------
508! Arguments:
509  INTEGER                       :: year_len
510  INTEGER,           INTENT(IN) :: y
511  CHARACTER(LEN=*),  INTENT(IN) :: cal_in
512!-------------------------------------------------------------------------------
513! Local variables:
514  CHARACTER(LEN=20)             :: cal_out              ! calendar (for outputs)
515!-------------------------------------------------------------------------------
516!--- Getting the input calendar to reset at the end of the function
517  CALL ioget_calendar(cal_out)
518
519!--- Unlocking calendar and setting it to wanted one
520  CALL lock_calendar(.FALSE.); CALL ioconf_calendar(TRIM(cal_in))
521
522!--- Getting the number of days in this year
523  year_len=ioget_year_len(y)
524
525!--- Back to original calendar
526  CALL lock_calendar(.FALSE.); CALL ioconf_calendar(TRIM(cal_out))
527
528END FUNCTION year_len
529!
530!-------------------------------------------------------------------------------
531
532
533!-------------------------------------------------------------------------------
534!
535FUNCTION mid_months(y,cal_in,nm)
536!
537!-------------------------------------------------------------------------------
538  USE ioipsl, ONLY : ioget_calendar,ioconf_calendar,lock_calendar,ioget_mon_len
539  IMPLICIT NONE
540!-------------------------------------------------------------------------------
541! Arguments:
542  INTEGER,                INTENT(IN) :: y               ! year
543  CHARACTER(LEN=*),       INTENT(IN) :: cal_in          ! calendar
544  INTEGER,                INTENT(IN) :: nm              ! months/year number
545  REAL,    DIMENSION(nm)             :: mid_months      ! mid-month times
546!-------------------------------------------------------------------------------
547! Local variables:
548  CHARACTER(LEN=99)                  :: mess            ! error message
549  CHARACTER(LEN=20)                  :: cal_out         ! calendar (for outputs)
550  INTEGER, DIMENSION(nm)             :: mnth            ! months lengths (days)
551  INTEGER                            :: m               ! months counter
552  INTEGER                            :: nd              ! number of days
553!-------------------------------------------------------------------------------
554  nd=year_len(y,cal_in)
555
556  IF(nm==12) THEN
557
558  !--- Getting the input calendar to reset at the end of the function
559    CALL ioget_calendar(cal_out)
560
561  !--- Unlocking calendar and setting it to wanted one
562    CALL lock_calendar(.FALSE.); CALL ioconf_calendar(TRIM(cal_in))
563
564  !--- Getting the length of each month
565    DO m=1,nm; mnth(m)=ioget_mon_len(y,m); END DO
566
567  !--- Back to original calendar
568    CALL lock_calendar(.FALSE.); CALL ioconf_calendar(TRIM(cal_out))
569
570  ELSE IF(MODULO(nd,nm)/=0) THEN
571    WRITE(mess,'(a,i3,a,i3,a)')'Unconsistent calendar: ',nd,' days/year, but ',&
572      nm,' months/year. Months number should divide days number.'
573    CALL abort_gcm('mid_months',TRIM(mess),1)
574
575  ELSE
576    mnth=(/(m,m=1,nm,nd/nm)/)
577  END IF
578
579!--- Mid-months times
580  mid_months(1)=0.5*FLOAT(mnth(1))
581  DO k=2,nm
582    mid_months(k)=mid_months(k-1)+0.5*FLOAT(mnth(k-1)+mnth(k))
583  END DO
584
585END FUNCTION mid_months
586!
587!-------------------------------------------------------------------------------
588
589
590!-------------------------------------------------------------------------------
591!
592SUBROUTINE ncerr(ncres,fnam)
593!
594!-------------------------------------------------------------------------------
595! Purpose: NetCDF errors handling.
596!-------------------------------------------------------------------------------
597  USE netcdf, ONLY : NF90_NOERR, NF90_STRERROR
598  IMPLICIT NONE
599!-------------------------------------------------------------------------------
600! Arguments:
601  INTEGER,          INTENT(IN) :: ncres
602  CHARACTER(LEN=*), INTENT(IN) :: fnam
603!-------------------------------------------------------------------------------
604#include "iniprint.h"
605  IF(ncres/=NF90_NOERR) THEN
606    WRITE(lunout,*)'Problem with file '//TRIM(fnam)//' in routine limit_netcdf.'
607    CALL abort_gcm('limit_netcdf',NF90_STRERROR(ncres),1)
608  END IF
609
610END SUBROUTINE ncerr
611!
612!-------------------------------------------------------------------------------
613
614
615END SUBROUTINE limit_netcdf
Note: See TracBrowser for help on using the repository browser.