Context Navigation

limit_netcdf.F90 @ 1425

Last change on this file since 1425 was 1402, checked in by jghattas, 14 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

Rev	Line
[1000]	1	!
[1279]	2	! $Id: limit_netcdf.F90 1402 2010-06-22 09:34:56Z lguez $
[1319]	3	!-------------------------------------------------------------------------------
[1000]	4	!
[1319]	5	SUBROUTINE 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	!-------------------------------------------------------------------------------
[1279]	22	#ifdef CPP_EARTH
[1319]	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
[1323]	30	USE inter_barxy_m, only: inter_barxy
[1319]	31	#endif
	32	IMPLICIT NONE
	33	!-------------------------------------------------------------------------------
	34	! Arguments:
[1000]	35	#include "dimensions.h"
	36	#include "paramet.h"
[1319]	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:
[1000]	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
[1319]	54	!--- For fractionary sub-cell use (old coding used soil index: 0,1,2,3) --------
	55	LOGICAL, PARAMETER :: fracterre=.TRUE.
[1000]	56
[1319]	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 '
[1000]	67
[1319]	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
[1000]	75
[1319]	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
[1328]	83	INTEGER :: ndays !--- Depending on the output calendar
[1000]	84
[1319]	85	!--- INITIALIZATIONS -----------------------------------------------------------
	86	#ifdef NC_DOUBLE
	87	NF90_FORMAT=NF90_DOUBLE
	88	#else
	89	NF90_FORMAT=NF90_FLOAT
	90	#endif
[1000]	91
[1319]	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
[1000]	101
[1319]	102	!--- Beware: anneeref (from gcm.def) is used to determine output time sampling
	103	ndays=ioget_year_len(anneeref)
[1000]	104
[1319]	105	!--- RUGOSITY TREATMENT --------------------------------------------------------
	106	WRITE(lunout,*) 'Traitement de la rugosite'
	107	CALL get_2Dfield(frugo,'RUG',interbar,ndays,phy_rug,mask=masque(1:iim,:))
[1000]	108
[1319]	109	!--- OCEAN TREATMENT -----------------------------------------------------------
	110	PRINT*, 'Traitement de la glace oceanique' ; icefile=''; lCPL=.FALSE.
[1000]	111
[1319]	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)
[1000]	125
[1328]	126	CALL get_2Dfield(icefile,'SIC',interbar,ndays,phy_ice,flag=oldice,lCPL=lCPL)
[1000]	127
[1319]	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
[1328]	136	IF(lCPL) THEN ! SIC=pICE*(1-LIC-TER)
[1319]	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)
[1000]	189
[1319]	190	!--- SST TREATMENT -------------------------------------------------------------
	191	WRITE(lunout,*) 'Traitement de la sst' ; sstfile=''; lCPL=.FALSE.
[1000]	192
[1319]	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)
[1000]	206
[1319]	207	CALL get_2Dfield(trim(sstfile),'SST',interbar,ndays,phy_sst,flag=extrap)
[1000]	208
[1319]	209	!--- ALBEDO TREATMENT ----------------------------------------------------------
	210	WRITE(lunout,*) 'Traitement de l albedo'
	211	CALL get_2Dfield(falbe,'ALB',interbar,ndays,phy_alb)
[1000]	212
[1319]	213	!--- REFERENCE GROUND HEAT FLUX TREATMENT --------------------------------------
	214	ALLOCATE(phy_bil(klon,ndays)); phy_bil=0.0
[1000]	215
[1319]	216	!--- OUTPUT FILE WRITING -------------------------------------------------------
	217	WRITE(lunout,*) 'Ecriture du fichier limit'
[1000]	218
[1319]	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")
[1000]	222
[1319]	223	!--- Dimensions creation
	224	ierr=NF90_DEF_DIM(nid,"points_physiques",klon,ndim)
	225	ierr=NF90_DEF_DIM(nid,"time",NF90_UNLIMITED,ntim)
[1000]	226
[1319]	227	dims=(/ndim,ntim/)
[1000]	228
[1319]	229	!--- Variables creation
[1328]	230	ierr=NF90_DEF_VAR(nid,"TEMPS",NF90_FORMAT,(/ntim/),id_tim)
[1319]	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)
[1000]	239
[1319]	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")
[1000]	250
[1319]	251	ierr=NF90_ENDDEF(nid)
	252
	253	!--- Variables saving
[1328]	254	ierr=NF90_PUT_VAR(nid,id_tim,(/(REAL(k),k=1,ndays)/))
[1319]	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)
[1000]	267	#endif
[1319]	268	! of #ifdef CPP_EARTH
	269	STOP
[1000]	270
	271
[1319]	272	!===============================================================================
	273	!
	274	CONTAINS
	275	!
	276	!===============================================================================
[1000]	277
	278
[1319]	279	!-------------------------------------------------------------------------------
	280	!
[1328]	281	SUBROUTINE get_2Dfield(fnam, mode, ibar, ndays, champo, flag, mask, lCPL)
[1319]	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)
[1328]	309	LOGICAL, OPTIONAL, INTENT(IN) :: flag ! extrapol. (SST) old ice (SIC)
[1319]	310	REAL, OPTIONAL, DIMENSION(iim,jjp1), INTENT(IN) :: mask
[1328]	311	LOGICAL, OPTIONAL, INTENT(IN) :: lCPL ! Coupled model flag (for ICE)
[1319]	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'
[1323]	325	REAL, ALLOCATABLE, DIMENSION(:,:) :: champ ! wanted field on initial grid
[1319]	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
[1000]	349
[1402]	350	extrp=.FALSE.
	351	IF ( PRESENT(flag) ) THEN
	352	IF ( flag .AND. mode=='SST' ) extrp=.TRUE.
	353	END IF
	354
[1319]	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)
[1000]	359
[1319]	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
[1000]	366
[1319]	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
[1000]	373
[1319]	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
[1000]	389
[1319]	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)
[1000]	393
[1319]	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) &
[1328]	398	//' ne comportent pas 12, mais ',lmdep,' enregistrements.'
[1000]	399
[1319]	400	!--- GETTING THE FIELD AND INTERPOLATING IT ------------------------------------
[1323]	401	ALLOCATE(champ(imdep,jmdep),champtime(iim,jjp1,lmdep))
[1319]	402	IF(extrp) ALLOCATE(work(imdep,jmdep))
[1000]	403
[1319]	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)
[1000]	411
[1319]	412	IF(extrp) CALL extrapol(champ,imdep,jmdep,999999.,.TRUE.,.TRUE.,2,work)
[1000]	413
[1319]	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)
[1323]	424	CALL inter_barxy(dlon, dlat(:jmdep-1), champ, rlonu(:iim), &
	425	rlatv, champint)
[1319]	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)
[1323]	432	CASE('RUG'); CALL rugosite(imdep, jmdep, dlon, dlat, champ, &
[1319]	433	iim, jjp1, rlonv, rlatu, champint, mask)
[1323]	434	CASE('SIC'); CALL sea_ice (imdep, jmdep, dlon, dlat, champ, &
[1319]	435	iim, jjp1, rlonv, rlatu, champint)
[1323]	436	CASE('SST','ALB'); CALL grille_m(imdep, jmdep, dlon, dlat, champ, &
[1319]	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)
[1000]	443
[1319]	444	DEALLOCATE(dlon_ini,dlat_ini,dlon,dlat,champ)
	445	IF(extrp) DEALLOCATE(work)
[1000]	446
[1319]	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)
[1000]	465
[1319]	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
[1000]	471
[1319]	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
[1000]	477
[1319]	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'
[1328]	481	IF(.NOT.lCPL) champan(:,:,:)=champan(:,:,:)/100.
[1319]	482	champan(iip1,:,:)=champan(1,:,:)
	483	WHERE(champan>1.0) champan=1.0
	484	WHERE(champan<0.0) champan=0.0
	485	END IF
[1000]	486
[1319]	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)
[1328]	493
[1319]	494	END SUBROUTINE get_2Dfield
	495	!
	496	!-------------------------------------------------------------------------------
[1000]	497
	498
	499
[1319]	500	!-------------------------------------------------------------------------------
	501	!
	502	FUNCTION 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)
[1000]	518
[1319]	519	!--- Unlocking calendar and setting it to wanted one
	520	CALL lock_calendar(.FALSE.); CALL ioconf_calendar(TRIM(cal_in))
[1000]	521
[1319]	522	!--- Getting the number of days in this year
	523	year_len=ioget_year_len(y)
[1000]	524
[1319]	525	!--- Back to original calendar
	526	CALL lock_calendar(.FALSE.); CALL ioconf_calendar(TRIM(cal_out))
[1000]	527
[1319]	528	END FUNCTION year_len
	529	!
	530	!-------------------------------------------------------------------------------
[1000]	531
	532
[1319]	533	!-------------------------------------------------------------------------------
	534	!
	535	FUNCTION 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)
[1000]	555
[1319]	556	IF(nm==12) THEN
[1000]	557
[1319]	558	!--- Getting the input calendar to reset at the end of the function
	559	CALL ioget_calendar(cal_out)
[1000]	560
[1319]	561	!--- Unlocking calendar and setting it to wanted one
	562	CALL lock_calendar(.FALSE.); CALL ioconf_calendar(TRIM(cal_in))
[1000]	563
[1319]	564	!--- Getting the length of each month
	565	DO m=1,nm; mnth(m)=ioget_mon_len(y,m); END DO
[1000]	566
[1319]	567	!--- Back to original calendar
	568	CALL lock_calendar(.FALSE.); CALL ioconf_calendar(TRIM(cal_out))
[1000]	569
[1319]	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)
[1000]	574
[1319]	575	ELSE
	576	mnth=(/(m,m=1,nm,nd/nm)/)
	577	END IF
[1000]	578
[1319]	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
[1000]	584
[1319]	585	END FUNCTION mid_months
	586	!
	587	!-------------------------------------------------------------------------------
[1000]	588
	589
[1319]	590	!-------------------------------------------------------------------------------
	591	!
	592	SUBROUTINE 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
[1000]	609
[1319]	610	END SUBROUTINE ncerr
	611	!
	612	!-------------------------------------------------------------------------------
	613
	614
	615	END SUBROUTINE limit_netcdf

Note: See TracBrowser for help on using the repository browser.

Download in other formats:

Original Format