Context Navigation

ts2IPCC.F90 @ 555

Last change on this file since 555 was 555, checked in by lmdzadmin, 20 years ago
Rajout du traitement de variables 3D LF
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 14.1 KB

Line
1	!
2	! $Header$
3	!
4	PROGRAM ts2IPCC
5
6	!
7	! Filtre permettant de transformer les fichiers de serie temporelle a une
8	! variable de l'IPSL en fichiers acceptables par le PCMDI/IPCC.
9	!
10	! Utilisation de la bibliothèque CMOR du PCMDI
11	!
12	! L. Fairhead 2004/08
13	!
14	! Ce programme est appelé avec un argument, le nom du fichier à traiter
15	! Il nécessite aussi un fichier config.def contenant diverses informations
16	! (voir plus bas) et l'accès à un tableau faisant la correspondance entre
17	! les noms de variables du modèle et les noms imposés par l'IPCC
18	! Pour l'instant on ne traite que les fichiers contenant la serie
19	! temporelle d'une seule variable
20
21	use cmor_users_functions
22	use netcdf
23
24	implicit none
25
26	#include "netcdf.inc"
27
28	CHARACTER (len=256) :: orig_file ! nom du fichier à traiter
29	character (len=512) :: line_read
30	CHARACTER (len=128) :: inpath, contact, hist_gen,repert,instit
31	CHARACTER (len=128) :: hist_var,expt_id,source,comment,refs
32	CHARACTER (len=20) :: action
33	character (len=20) :: first_part
34	character (len=1004) :: second_part
35	CHARACTER (len=20), DIMENSION(100) :: ipsl_name, ipsl_units
36	CHARACTER (len=20), DIMENSION(100) :: ipcc_name, ipcc_table
37	CHARACTER (len=80) :: varname, units, namedim
38
39	INTEGER :: orig_file_id, nvars, ndims
40	INTEGER :: verbos, exit_ctl, realis, indice,index_table
41	INTEGER :: iargc, iostat, ierr
42	INTEGER :: i,idim
43	INTEGER, ALLOCATABLE, DIMENSION(:) :: dimids,axis_ids,lendim
44	INTEGER :: latid, lonid, vertid, timeid
45	INTEGER :: varid, cmorvarid
46	INTEGER :: ilat, ilon, ivert, itime
47	INTEGER :: lunout ! device de sortie
48
49	logical :: found = .false.
50
51	REAL, ALLOCATABLE, DIMENSION(:) :: lon, lat, vert, time
52	REAL, ALLOCATABLE, DIMENSION(:) :: lon_bounds, lat_bounds
53	REAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: donnees
54	DOUBLE PRECISION, DIMENSION(1) :: rdate
55	real :: missing_value
56
57	external iargc
58
59	!
60	! quelques initialisations
61	lunout = 6
62	varname = 'xxxxxxxx'
63
64	!
65	! On vérifie que l'appel au programme a bien un argument:
66	CALL getarg(1, orig_file)
67	IF (iargc() == 0 .OR. orig_file == '-h') then
68	WRITE(lunout,*)' '
69	WRITE(lunout,*)' Utilisation de ce programme: '
70	WRITE(lunout,*)' ./ts2IPCC nom_de_fichier [variable]'
71	WRITE(lunout,*)' ou nom_de_fichier est le nom du fichier a traiter'
72	WRITE(lunout,*)' et variable la variable a traiter [optionel]'
73	WRITE(lunout,*)' '
74	WRITE(lunout,*)' ./ts2IPCC -h sort ce message'
75	WRITE(lunout,*)' '
76	stop
77	ENDIF
78	if (iargc() == 2) then
79	CALL getarg(2, varname)
80	endif
81
82	!
83	! Lecture du fichier de configuration
84	OPEN (20, IOSTAT=iostat, file='config.def',form='formatted')
85	IF (iostat /= 0) then
86	WRITE(lunout,*)'Erreur ouverture du fichier config.def'
87	stop
88	endif
89
90	do while (iostat == 0)
91	READ(20,'(A)',iostat=iostat)line_read
92	line_read = trim(line_read)
93	IF (INDEX(line_read, '#') /= 1) THEN
94	first_part = trim(line_read(1:INDEX(line_read, '=')-1))
95	second_part = trim(line_read(INDEX(line_read, '=')+1:))
96	selectcase(first_part)
97	case('inpath')
98	inpath = trim(second_part)
99	case('file_action')
100	action = trim(second_part)
101	case('verbosity')
102	READ(second_part,'(i)') verbos
103	case('exit_control')
104	READ(second_part,'(i)') exit_ctl
105	case('repertoire')
106	repert = trim(second_part)
107	case('experiment_ID')
108	expt_id = trim(second_part)
109	case('institut')
110	instit = trim(second_part)
111	case('source')
112	source = trim(second_part)
113	case('realisation')
114	READ(second_part,'(i)') realis
115	case('hist_gen')
116	hist_gen = trim(second_part)
117	case('comment')
118	comment = trim(second_part)
119	case('refs')
120	refs = trim(second_part)
121	case('hist_var')
122	hist_var = trim(second_part)
123	case('contact')
124	contact = trim(second_part)
125	end select
126	endif
127	enddo
128	if (iostat > 0) then
129	WRITE(lunout,*)'Probleme de lecture du fichier config.def, iostat = ',iostat
130	stop
131	endif
132	close(20)
133
134	!
135	! Lecture du tableau de correspondance nom IPSL <=> nom IPCC
136	OPEN (20, IOSTAT=iostat, file='table.def',form='formatted')
137	IF (iostat /= 0) then
138	WRITE(lunout,*)'Erreur ouverture du fichier table.def'
139	stop
140	endif
141	indice = 0
142	do while (iostat == 0)
143	READ(20,'(A)',iostat=iostat)line_read
144	line_read = trim(line_read)
145	IF (INDEX(line_read, '#') /= 1) THEN
146	indice = indice + 1
147	ipsl_name(indice) = trim(line_read(1:INDEX(line_read, '\|')-1))
148	line_read = trim(line_read(INDEX(line_read, '\|')+1:))
149	ipsl_units(indice) = trim(line_read(1:INDEX(line_read, '\|')-1))
150	line_read = trim(line_read(INDEX(line_read, '\|')+1:))
151	ipcc_name(indice) = trim(line_read(1:INDEX(line_read, '\|')-1))
152	ipcc_table(indice) = trim(line_read(INDEX(line_read, '\|')+1:))
153	endif
154	enddo
155	indice = indice - 1
156	close(20)
157	! DO i = 1, indice
158	! WRITE(lunout,*)ipsl_name(i),ipsl_units(i),ipcc_name(i),ipcc_table(i)
159	! enddo
160
161	!
162	! Ouverture du fichier a traiter
163	ierr = nf_open(orig_file, NF_NOWRITE, orig_file_id)
164	IF (ierr /= NF_NOERR) then
165	WRITE(lunout,*)NF_STRERROR(ierr)
166	stop
167	endif
168	!
169	! trouver la variable a traiter, c'est une variable a 3 ou 4 dimensions
170	ierr = nf_inq_nvars(orig_file_id, nvars)
171	IF (ierr /= NF_NOERR) then
172	WRITE(lunout,*)NF_STRERROR(ierr)
173	stop
174	endif
175
176	i = 0
177	if (varname == 'xxxxxxxx') then
178	DO while (.not.found)
179	i = i + 1
180	if (i > nvars) then
181	WRITE(lunout,*)' pas de variable 3d ou 4d trouvee'
182	stop
183	endif
184	ierr = nf_inq_varname(orig_file_id, i, varname)
185	IF (ierr /= NF_NOERR) then
186	WRITE(lunout,*)NF_STRERROR(ierr)
187	stop
188	endif
189	ierr = nf_inq_varndims(orig_file_id, i, ndims)
190	IF (ierr /= NF_NOERR) then
191	WRITE(lunout,*)NF_STRERROR(ierr)
192	stop
193	endif
194	if (ndims > 2) found = .true.
195	enddo
196	else
197	ierr = nf_inq_varid(orig_file_id, varname, varid)
198	IF (ierr /= NF_NOERR) then
199	WRITE(lunout,*)NF_STRERROR(ierr)
200	stop
201	endif
202	endif
203
204	!
205	! recherche de la correspondance nom IPSL <=> nom IPCC
206	found = .false.
207	i = 0
208	do while (.not. found)
209	i = i + 1
210	if (i > indice) then
211	WRITE(lunout,*)'La variable ',trim(varname),' n''est pas dans le tableau de correspondance table.def'
212	stop
213	endif
214	IF (varname == ipsl_name(i)) THEN
215	index_table = i
216	found = .true.
217	endif
218	enddo
219
220	WRITE(lunout,*)' found variable = ', trim(varname)
221	WRITE(lunout,*)' ipcc_name = ', trim(ipcc_name(index_table))
222
223
224	!
225	! Initialisation CMOR
226	ierr = cmor_setup(inpath=inpath, netcdf_file_action=action,set_verbosity=verbos,&
227	& exit_control=exit_ctl)
228	IF (ierr /= 0) then
229	WRITE(lunout,*)'Probleme dans cmor_setup, ierr = ', ierr
230	endif
231
232	!
233	! Initialisation dataset
234	ierr = cmor_dataset(outpath=repert, &
235	& experiment_id=expt_id, &
236	& institution=instit, &
237	& source=source, &
238	& calendar='360_day', &
239	& realization=realis, &
240	& contact=contact, &
241	& history=hist_gen, &
242	& comment=comment, &
243	& references=refs)
244	IF (ierr /= 0) then
245	WRITE(lunout,*)'Probleme dans cmor_dataset, ierr = ', ierr
246	endif
247
248	!
249	! Definition des axes
250
251	ierr = nf90_inq_varid(orig_file_id,TRIM(varname), varid)
252	if (ierr /= 0) call handle_err(ierr)
253	ierr = nf90_Inquire_Variable(orig_file_id, varid, ndims = ndims)
254	if (ierr /= 0) call handle_err(ierr)
255	allocate (dimids(ndims))
256	allocate (axis_ids(ndims))
257	allocate (lendim(ndims))
258	ierr = nf90_Inquire_Variable(orig_file_id, varid, dimids = dimids)
259	if (ierr /= 0) call handle_err(ierr)
260
261	do idim = 1, ndims
262	ierr = nf90_Inquire_Dimension(orig_file_id, dimids(idim), &
263	name = namedim, len = lendim(idim))
264	if (ierr /= 0) call handle_err(ierr)
265	units=' '
266	selectcase(trim(namedim))
267	case('lat')
268	! lecture de la latitude:
269	allocate(lat(lendim(idim)))
270	ierr = nf_inq_varid(orig_file_id, namedim, latid)
271	if (ierr /= 0) call handle_err(ierr)
272	ierr = nf_get_var_real(orig_file_id, latid, lat)
273	if (ierr /= 0) call handle_err(ierr)
274	ierr = nf_get_att_text(orig_file_id, latid, 'units', units)
275	if (ierr /= 0) call handle_err(ierr)
276	allocate(lat_bounds(lendim(idim)+1))
277	DO i = 2, lendim(idim)
278	lat_bounds(i) = lat(i-1) - (lat(i-1) - lat(i))/2
279	enddo
280	lat_bounds(1) = lat(1)
281	lat_bounds(lendim(idim)+1) = lat(lendim(idim))
282	! definition de la latitude
283	axis_ids(idim) = cmor_axis( &
284	table=trim(ipcc_table(index_table)), &
285	table_entry='latitude', &
286	units=units, &
287	length=lendim(idim), &
288	coord_vals=lat, &
289	cell_bounds=lat_bounds)
290	!
291	!
292	case('lon')
293	! lecture de la longitude:
294	allocate(lon(lendim(idim)))
295	ierr = nf_inq_varid(orig_file_id, namedim, lonid)
296	if (ierr /= 0) call handle_err(ierr)
297	ierr = nf_get_var_real(orig_file_id, lonid, lon)
298	if (ierr /= 0) call handle_err(ierr)
299	ierr = nf_get_att_text(orig_file_id, lonid, 'units', units)
300	if (ierr /= 0) call handle_err(ierr)
301	ALLOCATE(lon_bounds(lendim(idim)+1))
302	DO i = 2, lendim(idim)
303	lon_bounds(i) = lon(i-1) - (lon(i-1) - lon(i))/2
304	enddo
305	lon_bounds(1) = lon(1) - (lon_bounds(3) -lon_bounds(2))/2.
306	lon_bounds(lendim(idim)+1) = lon(lendim(idim)) + (lon_bounds(lendim(idim))-lon_bounds(lendim(idim)-1))/2.
307
308	! definition de la longitude
309	axis_ids(idim) = cmor_axis( &
310	table=trim(ipcc_table(index_table)), &
311	table_entry='longitude', &
312	units=units, &
313	length=lendim(idim), &
314	coord_vals=lon, &
315	cell_bounds=lon_bounds)
316	!
317	!
318	case('presnivs')
319	! lecture de la verticale:
320	allocate(vert(lendim(idim)))
321	ierr = nf_inq_varid(orig_file_id, namedim, vertid)
322	if (ierr /= 0) call handle_err(ierr)
323	ierr = nf_get_var_real(orig_file_id, vertid, vert)
324	if (ierr /= 0) call handle_err(ierr)
325	ierr = nf_get_att_text(orig_file_id, vertid, 'units', units)
326	if (ierr /= 0) call handle_err(ierr)
327	!
328	! definition de la verticale
329	if (units == 'mb') units='Pa'
330	axis_ids(idim) = cmor_axis( &
331	table=trim(ipcc_table(index_table)), &
332	table_entry='pressure', &
333	units=units, &
334	length=lendim(idim), &
335	coord_vals=vert)
336	!
337	!
338	case('time_counter')
339	! definition du temps
340	if (idim /= ndims) then
341	write(lunout,*)'la dimension temps doit etre la derniere dimension'
342	stop
343	endif
344	allocate(time(lendim(idim)))
345	ierr = nf_inq_varid(orig_file_id,namedim,timeid)
346	if (ierr /=0) call handle_err(ierr)
347	ierr = nf_get_var_real(orig_file_id, timeid, time)
348	if (ierr /=0) call handle_err(ierr)
349	ierr = nf_get_att_text(orig_file_id,timeid, 'units', units)
350	if (ierr /=0) call handle_err(ierr)
351	axis_ids(idim) = cmor_axis( &
352	table=trim(ipcc_table(index_table)), &
353	table_entry='time', &
354	units=units, &
355	length=lendim(idim), &
356	interval='30 minutes')
357	itime= lendim(idim)
358	case default
359	write(lunout,*)'Dimension: ', trim(namedim),' non reconnue'
360	stop
361	endselect
362	enddo
363
364	!
365	! Definition de la variable a ecrire
366	units=' '
367	ierr = nf_inq_varid(orig_file_id,TRIM(varname), varid)
368	if (ierr /= 0) call handle_err(ierr)
369	ierr = nf_get_att_text(orig_file_id, varid, 'units', units)
370	if (ierr /= 0) call handle_err(ierr)
371	ierr = nf_get_att_real(orig_file_id, varid, 'missing_value', missing_value)
372	if (ierr /= 0) call handle_err(ierr)
373	cmorvarid = cmor_variable( &
374	table=trim(ipcc_table(index_table)), &
375	table_entry=trim(ipcc_name(index_table)), &
376	units=units, &
377	axis_ids= axis_ids, &
378	missing_value=real(missing_value), &
379	original_name=varname)
380	!
381	! Lecture de la variable
382	if (ndims == 3) then
383	ALLOCATE (donnees(lendim(1), lendim(2), 1, lendim(3) ))
384	else if (ndims ==4) then
385	allocate (donnees(lendim(1), lendim(2), lendim(3), lendim(4) ))
386	endif
387	ierr = nf_get_var_real(orig_file_id, varid, donnees)
388	!
389	! Ecriture de la variable
390
391	DO i = 1, itime
392	rdate(1) = dble(time(i))
393	ierr = cmor_write( &
394	var_id = cmorvarid, &
395	DATA = REAL(donnees(:,:,:,i)), &
396	ntimes_passed = 1, &
397	time_vals = rdate)
398	enddo
399	!
400	! Fin CMOR
401	ierr = cmor_close()
402	IF (ierr /= 0) then
403	WRITE(lunout,*)'Probleme dans cmor_close, ierr = ', ierr
404	endif
405
406	!
407	! fermeture fichier originel
408	ierr = nf_close(orig_file_id)
409	IF (ierr /= NF_NOERR) then
410	WRITE(lunout,*)NF_STRERROR(ierr)
411	stop
412	endif
413
414	contains
415
416	subroutine handle_err(status)
417	use netcdf
418
419	implicit none
420	integer, intent(in) :: status
421
422	write(lunout,*)nf90_strerror(status)
423	stop
424
425	end subroutine handle_err
426
427	END PROGRAM ts2IPCC
428

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

Download in other formats:

Original Format