Context Navigation

limit_netcdf.F90 @ 1476

Last change on this file since 1476 was 1476, checked in by jghattas, 14 years ago

Bug correction for ce0l in dyn3dpar :

added missing MPI_FINALIZE
removed STOP before end of program

Property svn:eol-style set to native
Property svn:keywords set to Author Date Id Revision

File size: 25.5 KB

Rev	Line
[1000]	1	!
[1279]	2	! $Id: limit_netcdf.F90 1476 2011-01-25 11:12:55Z jghattas $
[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
[1000]	269
	270
[1319]	271	!===============================================================================
	272	!
	273	CONTAINS
	274	!
	275	!===============================================================================
[1000]	276
	277
[1319]	278	!-------------------------------------------------------------------------------
	279	!
[1328]	280	SUBROUTINE get_2Dfield(fnam, mode, ibar, ndays, champo, flag, mask, lCPL)
[1319]	281	!
	282	!-------------------------------------------------------------------------------
	283	! Comments:
	284	! There are two assumptions concerning the NetCDF files, that are satisfied
	285	! with files that are conforming NC convention:
	286	! 1) The last dimension of the variables used is the time record.
	287	! 2) Dimensional variables have the same names as corresponding dimensions.
	288	!-------------------------------------------------------------------------------
	289	USE netcdf, ONLY : NF90_OPEN, NF90_INQ_VARID, NF90_INQUIRE_VARIABLE, &
	290	NF90_CLOSE, NF90_INQ_DIMID, NF90_INQUIRE_DIMENSION, &
	291	NF90_GET_VAR, NF90_GET_ATT
	292	USE dimphy, ONLY : klon
	293	USE phys_state_var_mod, ONLY : pctsrf
	294	IMPLICIT NONE
	295	#include "dimensions.h"
	296	#include "paramet.h"
	297	#include "comgeom2.h"
	298	#include "control.h"
	299	#include "indicesol.h"
	300	#include "iniprint.h"
	301	!-------------------------------------------------------------------------------
	302	! Arguments:
	303	CHARACTER(LEN=*), INTENT(IN) :: fnam ! NetCDF file name
	304	CHARACTER(LEN=3), INTENT(IN) :: mode ! RUG, SIC, SST or ALB
	305	LOGICAL, INTENT(IN) :: ibar ! interp on pressure levels
	306	INTEGER, INTENT(IN) :: ndays ! current year number of days
	307	REAL, POINTER, DIMENSION(:,:) :: champo ! output field = f(t)
[1328]	308	LOGICAL, OPTIONAL, INTENT(IN) :: flag ! extrapol. (SST) old ice (SIC)
[1319]	309	REAL, OPTIONAL, DIMENSION(iim,jjp1), INTENT(IN) :: mask
[1328]	310	LOGICAL, OPTIONAL, INTENT(IN) :: lCPL ! Coupled model flag (for ICE)
[1319]	311	!-------------------------------------------------------------------------------
	312	! Local variables:
	313	!--- NetCDF
	314	INTEGER :: ierr, ncid, varid ! NetCDF identifiers
	315	CHARACTER(LEN=30) :: dnam ! dimension name
	316	CHARACTER(LEN=80) :: varname ! NetCDF variable name
	317	!--- dimensions
	318	INTEGER, DIMENSION(4) :: dids ! NetCDF dimensions identifiers
	319	REAL, ALLOCATABLE, DIMENSION(:) :: dlon_ini ! initial longitudes vector
	320	REAL, ALLOCATABLE, DIMENSION(:) :: dlat_ini ! initial latitudes vector
	321	REAL, POINTER, DIMENSION(:) :: dlon, dlat ! reordered lon/lat vectors
	322	!--- fields
	323	INTEGER :: imdep, jmdep, lmdep ! dimensions of 'champ'
[1323]	324	REAL, ALLOCATABLE, DIMENSION(:,:) :: champ ! wanted field on initial grid
[1319]	325	REAL, ALLOCATABLE, DIMENSION(:) :: yder, timeyear
	326	REAL, DIMENSION(iim,jjp1) :: champint ! interpolated field
	327	REAL, ALLOCATABLE, DIMENSION(:,:,:) :: champtime
	328	REAL, ALLOCATABLE, DIMENSION(:,:,:) :: champan
	329	REAL :: time, by
	330	!--- input files
	331	CHARACTER(LEN=20) :: cal_in ! calendar
	332	INTEGER :: ndays_in ! number of days
	333	!--- misc
	334	INTEGER :: i, j, k, l ! loop counters
	335	REAL, ALLOCATABLE, DIMENSION(:,:) :: work ! used for extrapolation
	336	CHARACTER(LEN=25) :: title ! for messages
	337	LOGICAL :: extrp ! flag for extrapolation
	338	REAL :: chmin, chmax
	339	!-------------------------------------------------------------------------------
	340	!---Variables depending on keyword 'mode' --------------------------------------
	341	NULLIFY(champo)
	342	SELECT CASE(mode)
	343	CASE('RUG'); varname='RUGOS'; title='Rugosite'
	344	CASE('SIC'); varname='sicbcs'; title='Sea-ice'
	345	CASE('SST'); varname='tosbcs'; title='SST'
	346	CASE('ALB'); varname='ALBEDO'; title='Albedo'
	347	END SELECT
[1000]	348
[1402]	349	extrp=.FALSE.
	350	IF ( PRESENT(flag) ) THEN
	351	IF ( flag .AND. mode=='SST' ) extrp=.TRUE.
	352	END IF
	353
[1319]	354	!--- GETTING SOME DIMENSIONAL VARIABLES FROM FILE ------------------------------
	355	ierr=NF90_OPEN(fnam,NF90_NOWRITE,ncid); CALL ncerr(ierr,fnam)
	356	ierr=NF90_INQ_VARID(ncid,varname,varid); CALL ncerr(ierr,fnam)
	357	ierr=NF90_INQUIRE_VARIABLE(ncid,varid,dimids=dids); CALL ncerr(ierr,fnam)
[1000]	358
[1319]	359	!--- Longitude
	360	ierr=NF90_INQUIRE_DIMENSION(ncid,dids(1),name=dnam,len=imdep)
	361	CALL ncerr(ierr,fnam); ALLOCATE(dlon_ini(imdep),dlon(imdep))
	362	ierr=NF90_INQ_VARID(ncid,dnam,varid); CALL ncerr(ierr,fnam)
	363	ierr=NF90_GET_VAR(ncid,varid,dlon_ini); CALL ncerr(ierr,fnam)
	364	WRITE(lunout,*) 'variable ', dnam, 'dimension ', imdep
[1000]	365
[1319]	366	!--- Latitude
	367	ierr=NF90_INQUIRE_DIMENSION(ncid,dids(2),name=dnam,len=jmdep)
	368	CALL ncerr(ierr,fnam); ALLOCATE(dlat_ini(jmdep),dlat(jmdep))
	369	ierr=NF90_INQ_VARID(ncid,dnam,varid); CALL ncerr(ierr,fnam)
	370	ierr=NF90_GET_VAR(ncid,varid,dlat_ini); CALL ncerr(ierr,fnam)
	371	WRITE(lunout,*) 'variable ', dnam, 'dimension ', jmdep
[1000]	372
[1319]	373	!--- Time (variable is not needed - it is rebuilt - but calendar is)
	374	ierr=NF90_INQUIRE_DIMENSION(ncid,dids(3),name=dnam,len=lmdep)
	375	CALL ncerr(ierr,fnam); ALLOCATE(timeyear(lmdep))
	376	ierr=NF90_INQ_VARID(ncid,dnam,varid); CALL ncerr(ierr,fnam)
	377	cal_in=' '
	378	ierr=NF90_GET_ATT(ncid,varid,'calendar',cal_in)
	379	IF(ierr/=NF90_NOERR) THEN
	380	SELECT CASE(mode)
	381	CASE('RUG','ALB'); cal_in='360d'
	382	CASE('SIC','SST'); cal_in='gregorian'
	383	END SELECT
	384	WRITE(lunout,*)'ATTENTION: variable ''time'' sans attribut ''calendrier'' d&
	385	&ans '//TRIM(fnam)//'. On choisit la valeur par defaut.'
	386	END IF
	387	WRITE(lunout,*) 'variable ', dnam, 'dimension ', lmdep, 'calendrier ', cal_in
[1000]	388
[1319]	389	!--- CONSTRUCTING THE INPUT TIME VECTOR FOR INTERPOLATION ----------------------
	390	!--- Determining input file number of days, depending on calendar
	391	ndays_in=year_len(anneeref,cal_in)
[1000]	392
[1319]	393	!--- Time vector reconstruction (time vector from file is not trusted)
	394	!--- If input records are not monthly, time sampling has to be constant !
	395	timeyear=mid_months(anneeref,cal_in,lmdep)
	396	IF(lmdep/=12) WRITE(lunout,'(a,i3,a)')'Note: les fichiers de '//TRIM(mode) &
[1328]	397	//' ne comportent pas 12, mais ',lmdep,' enregistrements.'
[1000]	398
[1319]	399	!--- GETTING THE FIELD AND INTERPOLATING IT ------------------------------------
[1323]	400	ALLOCATE(champ(imdep,jmdep),champtime(iim,jjp1,lmdep))
[1319]	401	IF(extrp) ALLOCATE(work(imdep,jmdep))
[1000]	402
[1319]	403	WRITE(lunout,*)
	404	WRITE(lunout,'(a,i3,a)')'LECTURE ET INTERPOLATION HORIZ. DE ',lmdep,' CHAMPS.'
	405	ierr=NF90_INQ_VARID(ncid,varname,varid); CALL ncerr(ierr,fnam)
	406	DO l=1,lmdep
	407	ierr=NF90_GET_VAR(ncid,varid,champ,(/1,1,l/),(/imdep,jmdep,1/))
	408	CALL ncerr(ierr,fnam)
	409	CALL conf_dat2d(title,imdep,jmdep,dlon_ini,dlat_ini,dlon,dlat,champ,ibar)
[1000]	410
[1319]	411	IF(extrp) CALL extrapol(champ,imdep,jmdep,999999.,.TRUE.,.TRUE.,2,work)
[1000]	412
[1319]	413	IF(ibar.AND..NOT.(mode=='SIC'.AND.flag)) THEN
	414	IF(l==1) THEN
	415	WRITE(lunout,*) &
	416	'-------------------------------------------------------------------------'
	417	WRITE(lunout,*) &
	418	'$$$ Utilisation de l''interpolation barycentrique pour '//TRIM(title)//' $$$'
	419	WRITE(lunout,*) &
	420	'-------------------------------------------------------------------------'
	421	END IF
	422	IF(mode=='RUG') champ=LOG(champ)
[1323]	423	CALL inter_barxy(dlon, dlat(:jmdep-1), champ, rlonu(:iim), &
	424	rlatv, champint)
[1319]	425	IF(mode=='RUG') THEN
	426	champint=EXP(champint)
	427	WHERE(NINT(mask)/=1) champint=0.001
	428	END IF
	429	ELSE
	430	SELECT CASE(mode)
[1323]	431	CASE('RUG'); CALL rugosite(imdep, jmdep, dlon, dlat, champ, &
[1319]	432	iim, jjp1, rlonv, rlatu, champint, mask)
[1323]	433	CASE('SIC'); CALL sea_ice (imdep, jmdep, dlon, dlat, champ, &
[1319]	434	iim, jjp1, rlonv, rlatu, champint)
[1323]	435	CASE('SST','ALB'); CALL grille_m(imdep, jmdep, dlon, dlat, champ, &
[1319]	436	iim, jjp1, rlonv, rlatu, champint)
	437	END SELECT
	438	END IF
	439	champtime(:,:,l)=champint
	440	END DO
	441	ierr=NF90_CLOSE(ncid); CALL ncerr(ierr,fnam)
[1000]	442
[1319]	443	DEALLOCATE(dlon_ini,dlat_ini,dlon,dlat,champ)
	444	IF(extrp) DEALLOCATE(work)
[1000]	445
[1319]	446	!--- TIME INTERPOLATION --------------------------------------------------------
	447	WRITE(lunout,*)
	448	WRITE(lunout,*)'INTERPOLATION TEMPORELLE.'
	449	WRITE(lunout,"(2x,' Vecteur temps en entree: ',10f6.1)") timeyear
	450	WRITE(lunout,"(2x,' Vecteur temps en sortie de 0 a ',i3)") ndays
	451	ALLOCATE(yder(lmdep),champan(iip1,jjp1,ndays))
	452	DO j=1,jjp1
	453	DO i=1,iim
	454	CALL spline(timeyear,champtime(i,j,:),lmdep,1.e30,1.e30,yder)
	455	DO k=1,ndays
	456	time=FLOAT((k-1)*ndays_in)/FLOAT(ndays)
	457	CALL splint(timeyear,champtime(i,j,:),yder,lmdep,time,by)
	458	champan(i,j,k) = by
	459	END DO
	460	END DO
	461	END DO
	462	champan(iip1,:,:)=champan(1,:,:)
	463	DEALLOCATE(yder,champtime,timeyear)
[1000]	464
[1319]	465	!--- Checking the result
	466	DO j=1,jjp1
	467	CALL minmax(iip1,champan(1,j,10),chmin,chmax)
	468	WRITE(lunout,*)' '//TRIM(title)//' au temps 10 ',chmin,chmax,j
	469	END DO
[1000]	470
[1319]	471	!--- SPECIAL FILTER FOR SST: SST>271.38 ----------------------------------------
	472	IF(mode=='SST') THEN
	473	WRITE(lunout,*) 'Filtrage de la SST: SST >= 271.38'
	474	WHERE(champan<271.38) champan=271.38
	475	END IF
[1000]	476
[1319]	477	!--- SPECIAL FILTER FOR SIC: 0.0<SIC<1.0 ---------------------------------------
	478	IF(mode=='SIC') THEN
	479	WRITE(lunout,*) 'Filtrage de la SIC: 0.0 < Sea-ice < 1.0'
[1328]	480	IF(.NOT.lCPL) champan(:,:,:)=champan(:,:,:)/100.
[1319]	481	champan(iip1,:,:)=champan(1,:,:)
	482	WHERE(champan>1.0) champan=1.0
	483	WHERE(champan<0.0) champan=0.0
	484	END IF
[1000]	485
[1319]	486	!--- DYNAMICAL TO PHYSICAL GRID ------------------------------------------------
	487	ALLOCATE(champo(klon,ndays))
	488	DO k=1,ndays
	489	CALL gr_dyn_fi(1,iip1,jjp1,klon,champan(1,1,k),champo(1,k))
	490	END DO
	491	DEALLOCATE(champan)
[1328]	492
[1319]	493	END SUBROUTINE get_2Dfield
	494	!
	495	!-------------------------------------------------------------------------------
[1000]	496
	497
	498
[1319]	499	!-------------------------------------------------------------------------------
	500	!
	501	FUNCTION year_len(y,cal_in)
	502	!
	503	!-------------------------------------------------------------------------------
	504	USE ioipsl, ONLY : ioget_calendar,ioconf_calendar,lock_calendar,ioget_year_len
	505	IMPLICIT NONE
	506	!-------------------------------------------------------------------------------
	507	! Arguments:
	508	INTEGER :: year_len
	509	INTEGER, INTENT(IN) :: y
	510	CHARACTER(LEN=*), INTENT(IN) :: cal_in
	511	!-------------------------------------------------------------------------------
	512	! Local variables:
	513	CHARACTER(LEN=20) :: cal_out ! calendar (for outputs)
	514	!-------------------------------------------------------------------------------
	515	!--- Getting the input calendar to reset at the end of the function
	516	CALL ioget_calendar(cal_out)
[1000]	517
[1319]	518	!--- Unlocking calendar and setting it to wanted one
	519	CALL lock_calendar(.FALSE.); CALL ioconf_calendar(TRIM(cal_in))
[1000]	520
[1319]	521	!--- Getting the number of days in this year
	522	year_len=ioget_year_len(y)
[1000]	523
[1319]	524	!--- Back to original calendar
	525	CALL lock_calendar(.FALSE.); CALL ioconf_calendar(TRIM(cal_out))
[1000]	526
[1319]	527	END FUNCTION year_len
	528	!
	529	!-------------------------------------------------------------------------------
[1000]	530
	531
[1319]	532	!-------------------------------------------------------------------------------
	533	!
	534	FUNCTION mid_months(y,cal_in,nm)
	535	!
	536	!-------------------------------------------------------------------------------
	537	USE ioipsl, ONLY : ioget_calendar,ioconf_calendar,lock_calendar,ioget_mon_len
	538	IMPLICIT NONE
	539	!-------------------------------------------------------------------------------
	540	! Arguments:
	541	INTEGER, INTENT(IN) :: y ! year
	542	CHARACTER(LEN=*), INTENT(IN) :: cal_in ! calendar
	543	INTEGER, INTENT(IN) :: nm ! months/year number
	544	REAL, DIMENSION(nm) :: mid_months ! mid-month times
	545	!-------------------------------------------------------------------------------
	546	! Local variables:
	547	CHARACTER(LEN=99) :: mess ! error message
	548	CHARACTER(LEN=20) :: cal_out ! calendar (for outputs)
	549	INTEGER, DIMENSION(nm) :: mnth ! months lengths (days)
	550	INTEGER :: m ! months counter
	551	INTEGER :: nd ! number of days
	552	!-------------------------------------------------------------------------------
	553	nd=year_len(y,cal_in)
[1000]	554
[1319]	555	IF(nm==12) THEN
[1000]	556
[1319]	557	!--- Getting the input calendar to reset at the end of the function
	558	CALL ioget_calendar(cal_out)
[1000]	559
[1319]	560	!--- Unlocking calendar and setting it to wanted one
	561	CALL lock_calendar(.FALSE.); CALL ioconf_calendar(TRIM(cal_in))
[1000]	562
[1319]	563	!--- Getting the length of each month
	564	DO m=1,nm; mnth(m)=ioget_mon_len(y,m); END DO
[1000]	565
[1319]	566	!--- Back to original calendar
	567	CALL lock_calendar(.FALSE.); CALL ioconf_calendar(TRIM(cal_out))
[1000]	568
[1319]	569	ELSE IF(MODULO(nd,nm)/=0) THEN
	570	WRITE(mess,'(a,i3,a,i3,a)')'Unconsistent calendar: ',nd,' days/year, but ',&
	571	nm,' months/year. Months number should divide days number.'
	572	CALL abort_gcm('mid_months',TRIM(mess),1)
[1000]	573
[1319]	574	ELSE
	575	mnth=(/(m,m=1,nm,nd/nm)/)
	576	END IF
[1000]	577
[1319]	578	!--- Mid-months times
	579	mid_months(1)=0.5*FLOAT(mnth(1))
	580	DO k=2,nm
	581	mid_months(k)=mid_months(k-1)+0.5*FLOAT(mnth(k-1)+mnth(k))
	582	END DO
[1000]	583
[1319]	584	END FUNCTION mid_months
	585	!
	586	!-------------------------------------------------------------------------------
[1000]	587
	588
[1319]	589	!-------------------------------------------------------------------------------
	590	!
	591	SUBROUTINE ncerr(ncres,fnam)
	592	!
	593	!-------------------------------------------------------------------------------
	594	! Purpose: NetCDF errors handling.
	595	!-------------------------------------------------------------------------------
	596	USE netcdf, ONLY : NF90_NOERR, NF90_STRERROR
	597	IMPLICIT NONE
	598	!-------------------------------------------------------------------------------
	599	! Arguments:
	600	INTEGER, INTENT(IN) :: ncres
	601	CHARACTER(LEN=*), INTENT(IN) :: fnam
	602	!-------------------------------------------------------------------------------
	603	#include "iniprint.h"
	604	IF(ncres/=NF90_NOERR) THEN
	605	WRITE(lunout,*)'Problem with file '//TRIM(fnam)//' in routine limit_netcdf.'
	606	CALL abort_gcm('limit_netcdf',NF90_STRERROR(ncres),1)
	607	END IF
[1000]	608
[1319]	609	END SUBROUTINE ncerr
	610	!
	611	!-------------------------------------------------------------------------------
	612
	613
	614	END SUBROUTINE limit_netcdf

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

Download in other formats:

Original Format