Context Navigation

iostart.F90 @ 2913

Last change on this file since 2913 was 2913, checked in by romain.vande, 2 years ago
Mars PCM: Adapt start2archive.F to the subslope parametrisation. Small correction for some dimensions of variables. RV
File size: 36.7 KB

Line
1	MODULE iostart
2
3	IMPLICIT NONE
4	PRIVATE
5	INTEGER,SAVE :: nid_start ! NetCDF file identifier for startfi.nc file
6	INTEGER,SAVE :: nid_restart ! NetCDF file identifier for restartfi.nc file
7
8	! restartfi.nc file dimension identifiers: (see open_restartphy())
9	INTEGER,SAVE :: idim1 ! "index" dimension
10	INTEGER,SAVE :: idim2 ! "physical_points" dimension
11	INTEGER,SAVE :: idim3 ! "subsurface_layers" dimension
12	INTEGER,SAVE :: idim4 ! "nlayer_plus_1" dimension
13	INTEGER,SAVE :: idim5 ! "number_of_advected_fields" dimension
14	INTEGER,SAVE :: idim6 ! "nlayer" dimension
15	INTEGER,SAVE :: idim7 ! "Time" dimension
16	INTEGER,SAVE :: idim8 ! "nslope" dimension
17	INTEGER,SAVE :: idim9 ! "nslope_plus_1" dimension
18	INTEGER,SAVE :: timeindex ! current time index (for time-dependent fields)
19	INTEGER,PARAMETER :: length=100 ! size of tab_cntrl array
20
21	INTERFACE get_field
22	MODULE PROCEDURE Get_field_r1,Get_field_r2,Get_field_r3
23	END INTERFACE get_field
24
25	INTERFACE get_var
26	MODULE PROCEDURE get_var_r0,Get_var_r1,Get_var_r2,Get_var_r3
27	END INTERFACE get_var
28
29	INTERFACE put_field
30	MODULE PROCEDURE put_field_r1,put_field_r2,put_field_r3
31	END INTERFACE put_field
32
33	INTERFACE put_var
34	MODULE PROCEDURE put_var_r0,put_var_r1,put_var_r2,put_var_r3
35	END INTERFACE put_var
36
37	PUBLIC nid_start, length
38	PUBLIC get_field,get_var,put_field,put_var
39	PUBLIC inquire_dimension, inquire_dimension_length
40	PUBLIC inquire_field, inquire_field_ndims
41	PUBLIC open_startphy,close_startphy,open_restartphy,close_restartphy
42
43	CONTAINS
44
45	SUBROUTINE open_startphy(filename)
46	USE netcdf, only: NF90_OPEN, NF90_NOERR, NF90_NOWRITE, nf90_strerror
47	USE mod_phys_lmdz_para, only: is_master, bcast
48	IMPLICIT NONE
49	CHARACTER(LEN=*) :: filename
50	INTEGER :: ierr
51
52	IF (is_master) THEN
53	ierr = NF90_OPEN (filename, NF90_NOWRITE, nid_start)
54	IF (ierr.NE.NF90_NOERR) THEN
55	write(,)'open_startphy: problem opening file '//trim(filename)
56	write(,)trim(nf90_strerror(ierr))
57	CALL abort_physic("open_startphy","Cannot open file",1)
58	ENDIF
59	ENDIF
60
61	CALL bcast(nid_start) ! tell all procs about nid_start
62
63	END SUBROUTINE open_startphy
64
65	SUBROUTINE close_startphy
66	USE netcdf, only: NF90_CLOSE
67	USE mod_phys_lmdz_para, only: is_master
68	IMPLICIT NONE
69	INTEGER :: ierr
70
71	IF (is_master) THEN
72	ierr = NF90_CLOSE (nid_start)
73	ENDIF
74
75	END SUBROUTINE close_startphy
76
77
78	FUNCTION inquire_field(Field_name)
79	! check if a given field is present in the input file
80	USE netcdf, only: NF90_INQ_VARID, NF90_NOERR
81	USE mod_phys_lmdz_para, only: is_master, bcast
82	IMPLICIT NONE
83	CHARACTER(LEN=*),INTENT(IN) :: Field_name
84	LOGICAL :: inquire_field
85	INTEGER :: varid
86	INTEGER :: ierr
87
88	IF (is_master) THEN
89	ierr=NF90_INQ_VARID(nid_start,Field_name,varid)
90	IF (ierr==NF90_NOERR) THEN
91	Inquire_field=.TRUE.
92	ELSE
93	Inquire_field=.FALSE.
94	ENDIF
95	ENDIF
96
97	CALL bcast(inquire_field)
98
99	END FUNCTION inquire_field
100
101
102	FUNCTION inquire_field_ndims(Field_name)
103	! give the number of dimensions of "Field_name" stored in the input file
104	USE netcdf, only: nf90_inq_varid, nf90_inquire_variable, &
105	NF90_NOERR, nf90_strerror
106	USE mod_phys_lmdz_para, only: is_master, bcast
107	IMPLICIT NONE
108	CHARACTER(LEN=*),INTENT(IN) :: Field_name
109	INTEGER :: inquire_field_ndims
110	INTEGER :: varid
111	INTEGER :: ierr
112
113	IF (is_master) THEN
114	ierr=nf90_inq_varid(nid_start,Field_name,varid)
115	ierr=nf90_inquire_variable(nid_start,varid,&
116	ndims=inquire_field_ndims)
117	IF (ierr.NE.NF90_NOERR) THEN
118	write(,)'inquire_field_ndims: problem obtaining ndims of '&
119	//trim(field_name)
120	write(,)trim(nf90_strerror(ierr))
121	CALL abort_physic("inquire_field_ndims","Failed to get ndims",1)
122	ENDIF
123	ENDIF
124
125	CALL bcast(inquire_field_ndims)
126
127	END FUNCTION inquire_field_ndims
128
129
130	FUNCTION inquire_dimension(Field_name)
131	! check if a given dimension is present in the input file
132	USE netcdf, only: nf90_inq_dimid, NF90_NOERR
133	USE mod_phys_lmdz_para, only: is_master, bcast
134	IMPLICIT NONE
135	CHARACTER(LEN=*),INTENT(IN) :: Field_name
136	LOGICAL :: inquire_dimension
137	INTEGER :: varid
138	INTEGER :: ierr
139
140	IF (is_master) THEN
141	ierr=NF90_INQ_DIMID(nid_start,Field_name,varid)
142	IF (ierr==NF90_NOERR) THEN
143	Inquire_dimension=.TRUE.
144	ELSE
145	Inquire_dimension=.FALSE.
146	ENDIF
147	ENDIF
148
149	CALL bcast(inquire_dimension)
150
151	END FUNCTION inquire_dimension
152
153	FUNCTION inquire_dimension_length(Field_name)
154	! give the length of the "Field_name" dimension stored in the input file
155	USE netcdf, only: nf90_inquire_dimension, nf90_inq_dimid, &
156	NF90_NOERR, nf90_strerror
157	USE mod_phys_lmdz_para, only: is_master, bcast
158	IMPLICIT NONE
159	CHARACTER(LEN=*),INTENT(IN) :: Field_name
160	INTEGER :: inquire_dimension_length
161	INTEGER :: varid
162	INTEGER :: ierr
163
164	IF (is_master) THEN
165	ierr=nf90_inq_dimid(nid_start,Field_name,varid)
166	ierr=nf90_inquire_dimension(nid_start,varid,&
167	len=inquire_dimension_length)
168	IF (ierr.NE.NF90_NOERR) THEN
169	write(,)'inquire_field_length: problem obtaining length of '&
170	//trim(field_name)
171	write(,)trim(nf90_strerror(ierr))
172	CALL abort_physic("inquire_field_ndims","Failed to get length",1)
173	ENDIF
174	ENDIF
175
176	CALL bcast(inquire_dimension_length)
177
178	END FUNCTION inquire_dimension_length
179
180
181
182	SUBROUTINE Get_Field_r1(field_name,field,found,timeindex)
183	! For a surface field
184	use mod_grid_phy_lmdz, only: klon_glo ! number of atmospheric columns (full grid)
185	IMPLICIT NONE
186	CHARACTER(LEN=*),INTENT(IN) :: Field_name
187	REAL,INTENT(INOUT) :: Field(:)
188	LOGICAL,INTENT(OUT),OPTIONAL :: found
189	INTEGER,INTENT(IN),OPTIONAL :: timeindex ! time index of sought data
190
191	integer :: edges(4), corners(4)
192
193	edges(1)=klon_glo
194	edges(2:4)=1
195	corners(1:4)=1
196	if (PRESENT(timeindex)) then
197	corners(2)=timeindex
198	endif
199
200	IF (PRESENT(found)) THEN
201	CALL Get_field_rgen(field_name,field,1,corners,edges,found)
202	ELSE
203	CALL Get_field_rgen(field_name,field,1,corners,edges)
204	ENDIF
205
206	END SUBROUTINE Get_Field_r1
207
208	SUBROUTINE Get_Field_r2(field_name,field,found,timeindex)
209	! For a "3D" horizontal-vertical field
210	use mod_grid_phy_lmdz, only: klon_glo ! number of atmospheric columns (full grid)
211	IMPLICIT NONE
212	CHARACTER(LEN=*),INTENT(IN) :: Field_name
213	REAL,INTENT(INOUT) :: Field(:,:)
214	LOGICAL,INTENT(OUT),OPTIONAL :: found
215	INTEGER,INTENT(IN),OPTIONAL :: timeindex ! time index of sought data
216
217	integer :: edges(4), corners(4)
218
219	edges(1)=klon_glo
220	edges(2)=size(field,2)
221	edges(3:4)=1
222	corners(1:4)=1
223	if (PRESENT(timeindex)) then
224	corners(3)=timeindex
225	endif
226
227	IF (PRESENT(found)) THEN
228	CALL Get_field_rgen(field_name,field,size(field,2),&
229	corners,edges,found)
230	ELSE
231	CALL Get_field_rgen(field_name,field,size(field,2),&
232	corners,edges)
233	ENDIF
234
235
236	END SUBROUTINE Get_Field_r2
237
238	SUBROUTINE Get_Field_r3(field_name,field,found,timeindex)
239	! for a "4D" field surf/alt/??
240	use mod_grid_phy_lmdz, only: klon_glo ! number of atmospheric columns (full grid)
241	IMPLICIT NONE
242	CHARACTER(LEN=*),INTENT(IN) :: Field_name
243	REAL,INTENT(INOUT) :: Field(:,:,:)
244	LOGICAL,INTENT(OUT),OPTIONAL :: found
245	INTEGER,INTENT(IN),OPTIONAL :: timeindex ! time index of sought data
246
247	integer :: edges(4), corners(4)
248
249	edges(1)=klon_glo
250	edges(2)=size(field,2)
251	edges(3)=size(field,3)
252	edges(4)=1
253	corners(1:4)=1
254	if (PRESENT(timeindex)) then
255	corners(4)=timeindex
256	endif
257
258	IF (PRESENT(found)) THEN
259	CALL Get_field_rgen(field_name,field,size(field,2)*size(field,3),&
260	corners,edges,found)
261	ELSE
262	CALL Get_field_rgen(field_name,field,size(field,2)*size(field,3),&
263	corners,edges)
264	ENDIF
265
266	END SUBROUTINE Get_Field_r3
267
268	SUBROUTINE Get_field_rgen(field_name,field,field_size, &
269	corners,edges,found)
270	USE netcdf
271	USE dimphy
272	USE mod_grid_phy_lmdz
273	USE mod_phys_lmdz_para
274	IMPLICIT NONE
275	CHARACTER(LEN=*) :: Field_name
276	INTEGER :: field_size
277	REAL :: field(klon,field_size)
278	INTEGER,INTENT(IN) :: corners(4)
279	INTEGER,INTENT(IN) :: edges(4)
280	LOGICAL,OPTIONAL :: found
281
282	REAL :: field_glo(klon_glo,field_size)
283	LOGICAL :: tmp_found
284	INTEGER :: varid
285	INTEGER :: ierr
286
287	IF (is_master) THEN
288
289	ierr=NF90_INQ_VARID(nid_start,Field_name,varid)
290
291	IF (ierr==NF90_NOERR) THEN
292	CALL body(field_glo)
293	tmp_found=.TRUE.
294	ELSE
295	tmp_found=.FALSE.
296	ENDIF
297
298	ENDIF
299
300	CALL bcast(tmp_found)
301
302	IF (tmp_found) THEN
303	CALL scatter(field_glo,field)
304	ENDIF
305
306	IF (PRESENT(found)) THEN
307	found=tmp_found
308	ELSE
309	IF (.NOT. tmp_found) THEN
310	PRINT*, 'get_field_rgen: Field <'//field_name//'> not found'
311	CALL abort_physic("get_field_rgen","Failed to get field",1)
312	ENDIF
313	ENDIF
314
315
316	CONTAINS
317
318	SUBROUTINE body(field_glo)
319	REAL :: field_glo(klon_glo*field_size)
320	ierr=NF90_GET_VAR(nid_start,varid,field_glo,corners,edges)
321	IF (ierr/=NF90_NOERR) THEN
322	! La variable exist dans le fichier mais la lecture a echouee.
323	PRINT*, 'get_field_rgen: Failed reading <'//field_name//'>'
324
325	! IF (field_name=='CLWCON' .OR. field_name=='RNEBCON' .OR. field_name=='RATQS') THEN
326	! ! Essaye de lire le variable sur surface uniqument, comme fait avant
327	! field_glo(:)=0.
328	! ierr=NF90_GET_VAR(nid_start,varid,field_glo(1:klon_glo))
329	! IF (ierr/=NF90_NOERR) THEN
330	! PRINT*, 'phyetat0: Lecture echouee aussi en 2D pour <'//field_name//'>'
331	! CALL abort
332	! ELSE
333	! PRINT*, 'phyetat0: La variable <'//field_name//'> lu sur surface seulement'!, selon ancien format, le reste mis a zero'
334	! END IF
335	! ELSE
336	CALL abort_physic("get_field_rgen","Failed to read field",1)
337	! ENDIF
338	ENDIF
339
340	END SUBROUTINE body
341
342	END SUBROUTINE Get_field_rgen
343
344
345	SUBROUTINE get_var_r0(var_name,var,found)
346	! Get a scalar from input file
347	IMPLICIT NONE
348	CHARACTER(LEN=*),INTENT(IN) :: var_name
349	REAL,INTENT(INOUT) :: var
350	LOGICAL,OPTIONAL,INTENT(OUT) :: found
351
352	REAL :: varout(1)
353
354	IF (PRESENT(found)) THEN
355	CALL Get_var_rgen(var_name,varout,size(varout),found)
356	ELSE
357	CALL Get_var_rgen(var_name,varout,size(varout))
358	ENDIF
359	var=varout(1)
360
361	END SUBROUTINE get_var_r0
362
363	SUBROUTINE get_var_r1(var_name,var,found)
364	! Get a vector from input file
365	IMPLICIT NONE
366	CHARACTER(LEN=*),INTENT(IN) :: var_name
367	REAL,INTENT(INOUT) :: var(:)
368	LOGICAL,OPTIONAL,INTENT(OUT) :: found
369
370	IF (PRESENT(found)) THEN
371	CALL Get_var_rgen(var_name,var,size(var),found)
372	ELSE
373	CALL Get_var_rgen(var_name,var,size(var))
374	ENDIF
375
376	END SUBROUTINE get_var_r1
377
378	SUBROUTINE get_var_r2(var_name,var,found)
379	! Get a 2D field from input file
380	IMPLICIT NONE
381	CHARACTER(LEN=*),INTENT(IN) :: var_name
382	REAL,INTENT(OUT) :: var(:,:)
383	LOGICAL,OPTIONAL,INTENT(OUT) :: found
384
385	IF (PRESENT(found)) THEN
386	CALL Get_var_rgen(var_name,var,size(var),found)
387	ELSE
388	CALL Get_var_rgen(var_name,var,size(var))
389	ENDIF
390
391	END SUBROUTINE get_var_r2
392
393	SUBROUTINE get_var_r3(var_name,var,found)
394	! Get a 3D field frominput file
395	IMPLICIT NONE
396	CHARACTER(LEN=*),INTENT(IN) :: var_name
397	REAL,INTENT(INOUT) :: var(:,:,:)
398	LOGICAL,OPTIONAL,INTENT(OUT) :: found
399
400	IF (PRESENT(found)) THEN
401	CALL Get_var_rgen(var_name,var,size(var),found)
402	ELSE
403	CALL Get_var_rgen(var_name,var,size(var))
404	ENDIF
405
406	END SUBROUTINE get_var_r3
407
408	SUBROUTINE Get_var_rgen(var_name,var,var_size,found)
409	USE netcdf
410	USE dimphy
411	USE mod_grid_phy_lmdz
412	USE mod_phys_lmdz_para
413	IMPLICIT NONE
414	CHARACTER(LEN=*) :: var_name
415	INTEGER :: var_size
416	REAL :: var(var_size)
417	LOGICAL,OPTIONAL :: found
418
419	LOGICAL :: tmp_found
420	INTEGER :: varid
421	INTEGER :: ierr
422
423	IF (is_mpi_root .AND. is_omp_root) THEN
424
425	ierr=NF90_INQ_VARID(nid_start,var_name,varid)
426
427	IF (ierr==NF90_NOERR) THEN
428	ierr=NF90_GET_VAR(nid_start,varid,var)
429	IF (ierr/=NF90_NOERR) THEN
430	PRINT*, 'phyetat0: Failed loading <'//trim(var_name)//'>'
431	CALL abort_physic("get_var_rgen","Failed to read variable",1)
432	ENDIF
433	tmp_found=.TRUE.
434	ELSE
435	tmp_found=.FALSE.
436	ENDIF
437
438	ENDIF
439
440	CALL bcast(tmp_found)
441
442	IF (tmp_found) THEN
443	CALL bcast(var)
444	ENDIF
445
446	IF (PRESENT(found)) THEN
447	found=tmp_found
448	ELSE
449	IF (.NOT. tmp_found) THEN
450	PRINT*, 'phyetat0: Variable <'//trim(var_name)//'> not found'
451	CALL abort_physic("get_var_rgen","Failed to read variable",1)
452	ENDIF
453	ENDIF
454
455	END SUBROUTINE Get_var_rgen
456
457	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
458
459	SUBROUTINE open_restartphy(filename)
460	USE netcdf, only: NF90_CREATE, NF90_CLOBBER, NF90_64BIT_OFFSET, &
461	NF90_NOERR, nf90_strerror, &
462	NF90_PUT_ATT, NF90_GLOBAL, NF90_DEF_DIM, &
463	NF90_UNLIMITED, NF90_ENDDEF, &
464	NF90_WRITE, NF90_OPEN
465	USE mod_phys_lmdz_para, only: is_master
466	USE mod_grid_phy_lmdz, only: klon_glo
467	USE dimphy, only: klev, klevp1
468	USE tracer_mod, only: nqmx
469	USE comsoil_h, only: nsoilmx
470	USE comslope_mod, only: nslope
471	IMPLICIT NONE
472	CHARACTER(LEN=*),INTENT(IN) :: filename
473	INTEGER :: ierr
474	LOGICAL,SAVE :: already_created=.false.
475
476	IF (is_master) THEN
477	if (.not.already_created) then
478	! At the very first call, create the file
479	ierr=NF90_CREATE(filename,IOR(NF90_CLOBBER,NF90_64BIT_OFFSET), &
480	nid_restart)
481	IF (ierr/=NF90_NOERR) THEN
482	write(,)'open_restartphy: problem creating file '//trim(filename)
483	write(,)trim(nf90_strerror(ierr))
484	CALL abort_physic("open_restartphy","Failed creating file",1)
485	ENDIF
486	already_created=.true.
487	else
488	! Just open the file
489	ierr=NF90_OPEN(filename,NF90_WRITE,nid_restart)
490	IF (ierr/=NF90_NOERR) THEN
491	write(,)'open_restartphy: problem opening file '//trim(filename)
492	write(,)trim(nf90_strerror(ierr))
493	CALL abort_physic("open_restartphy","Failed opening file",1)
494	ENDIF
495	return
496	endif ! of if (.not.already_created)
497
498	ierr=NF90_PUT_ATT(nid_restart,NF90_GLOBAL,"title",&
499	"Physics start file")
500	IF (ierr/=NF90_NOERR) THEN
501	write(,)'open_restartphy: problem writing title '
502	write(,)trim(nf90_strerror(ierr))
503	ENDIF
504
505	ierr=NF90_DEF_DIM(nid_restart,"index",length,idim1)
506	IF (ierr/=NF90_NOERR) THEN
507	write(,)'open_restartphy: problem defining index dimension '
508	write(,)trim(nf90_strerror(ierr))
509	CALL abort_physic("open_restartphy","Failed defining index",1)
510	ENDIF
511
512	ierr=NF90_DEF_DIM(nid_restart,"physical_points",klon_glo,idim2)
513	IF (ierr/=NF90_NOERR) THEN
514	write(,)'open_restartphy: problem defining physical_points dimension '
515	write(,)trim(nf90_strerror(ierr))
516	CALL abort_physic("open_restartphy","Failed defining physical_points",1)
517	ENDIF
518
519	ierr=NF90_DEF_DIM(nid_restart,"subsurface_layers",nsoilmx,idim3)
520	IF (ierr/=NF90_NOERR) THEN
521	write(,)'open_restartphy: problem defining subsurface_layers dimension '
522	write(,)trim(nf90_strerror(ierr))
523	CALL abort_physic("open_restartphy","Failed defining subsurface_layers",1)
524	ENDIF
525
526	ierr=NF90_DEF_DIM(nid_restart,"nlayer_plus_1",klevp1,idim4)
527	IF (ierr/=NF90_NOERR) THEN
528	write(,)'open_restartphy: problem defining nlayer_plus_1 dimension '
529	write(,)trim(nf90_strerror(ierr))
530	CALL abort_physic("open_restartphy","Failed defining nlayer_plus_1",1)
531	ENDIF
532
533	if (nqmx.ne.0) then
534	ierr=NF90_DEF_DIM(nid_restart,"number_of_advected_fields",nqmx,idim5)
535	else
536	! pretend nqmx=1 because 0 size implies unlimited dimension for NetCDF
537	ierr=NF90_DEF_DIM(nid_restart,"number_of_advected_fields",1,idim5)
538	endif
539	IF (ierr/=NF90_NOERR) THEN
540	write(,)'open_restartphy: problem defining number_of_advected_fields dimension '
541	write(,)trim(nf90_strerror(ierr))
542	CALL abort_physic("open_restartphy","Failed defining number_of_advected_fields",1)
543	ENDIF
544
545	ierr=NF90_DEF_DIM(nid_restart,"nlayer",klev,idim6)
546	IF (ierr/=NF90_NOERR) THEN
547	write(,)'open_restartphy: problem defining nlayer dimension '
548	write(,)trim(nf90_strerror(ierr))
549	CALL abort_physic("open_restartphy","Failed defining nlayer",1)
550	ENDIF
551
552	ierr=NF90_DEF_DIM(nid_restart,"Time",NF90_UNLIMITED,idim7)
553	IF (ierr/=NF90_NOERR) THEN
554	write(,)'open_restartphy: problem defining Time dimension '
555	write(,)trim(nf90_strerror(ierr))
556	CALL abort_physic("open_restartphy","Failed defining Time",1)
557	ENDIF
558
559	ierr=NF90_DEF_DIM(nid_restart,"nslope",nslope,idim8)
560	IF (ierr/=NF90_NOERR) THEN
561	write(,)'phyredem: problem defining nslope dimension'
562	write(,)trim(nf90_strerror(ierr))
563	CALL ABORT
564	ENDIF
565
566	ierr=NF90_DEF_DIM(nid_restart,"inter_slope",nslope+1,idim9)
567	IF (ierr/=NF90_NOERR) THEN
568	write(,)'phyredem: problem defining inter slope dimension'
569	write(,)trim(nf90_strerror(ierr))
570	CALL ABORT
571	ENDIF
572
573	ierr=NF90_ENDDEF(nid_restart)
574	IF (ierr/=NF90_NOERR) THEN
575	write(,)'open_restartphy: problem ending definition mode '
576	write(,)trim(nf90_strerror(ierr))
577	CALL abort_physic("open_restartphy","Failed ending definition mode",1)
578	ENDIF
579	ENDIF
580
581	END SUBROUTINE open_restartphy
582
583	SUBROUTINE close_restartphy
584	USE netcdf, only: NF90_CLOSE
585	USE mod_phys_lmdz_para, only: is_master
586	IMPLICIT NONE
587	INTEGER :: ierr
588
589	IF (is_master) THEN
590	ierr = NF90_CLOSE (nid_restart)
591	ENDIF
592
593	END SUBROUTINE close_restartphy
594
595	SUBROUTINE put_field_r1(field_name,title,field,time)
596	! For a surface field
597	IMPLICIT NONE
598	CHARACTER(LEN=*),INTENT(IN) :: field_name
599	CHARACTER(LEN=*),INTENT(IN) :: title
600	REAL,INTENT(IN) :: field(:)
601	REAL,OPTIONAL,INTENT(IN) :: time
602
603	IF (present(time)) THEN
604	! if timeindex is present, it is a time-dependent variable
605	CALL put_field_rgen(field_name,title,field,1,time)
606	ELSE
607	CALL put_field_rgen(field_name,title,field,1)
608	ENDIF
609
610	END SUBROUTINE put_field_r1
611
612	SUBROUTINE put_field_r2(field_name,title,field,time)
613	! For a "3D" horizontal-vertical field
614	IMPLICIT NONE
615	CHARACTER(LEN=*),INTENT(IN) :: field_name
616	CHARACTER(LEN=*),INTENT(IN) :: title
617	REAL,INTENT(IN) :: field(:,:)
618	REAL,OPTIONAL,INTENT(IN) :: time
619
620	IF (present(time)) THEN
621	! if timeindex is present, it is a time-dependent variable
622	CALL put_field_rgen(field_name,title,field,size(field,2),time)
623	ELSE
624	CALL put_field_rgen(field_name,title,field,size(field,2))
625	ENDIF
626
627	END SUBROUTINE put_field_r2
628
629	SUBROUTINE put_field_r3(field_name,title,field,time)
630	! For a "4D" field surf/alt/??
631	IMPLICIT NONE
632	CHARACTER(LEN=*),INTENT(IN) :: field_name
633	CHARACTER(LEN=*),INTENT(IN) :: title
634	REAL,INTENT(IN) :: field(:,:,:)
635	REAL,OPTIONAL,INTENT(IN) :: time
636
637	IF (present(time)) THEN
638	! if timeindex is present, it is a time-dependent variable
639	CALL put_field_rgen(field_name,title,field,size(field,2)*size(field,3),&
640	time)
641	ELSE
642	CALL put_field_rgen(field_name,title,field,size(field,2)*size(field,3))
643	ENDIF
644
645	END SUBROUTINE put_field_r3
646
647	SUBROUTINE put_field_rgen(field_name,title,field,field_size,time)
648	USE netcdf
649	USE dimphy
650	USE comsoil_h, only: nsoilmx
651	USE comslope_mod, ONLY: nslope
652	USE mod_grid_phy_lmdz
653	USE mod_phys_lmdz_para
654	IMPLICIT NONE
655	CHARACTER(LEN=*),INTENT(IN) :: field_name
656	CHARACTER(LEN=*),INTENT(IN) :: title
657	INTEGER,INTENT(IN) :: field_size
658	REAL,INTENT(IN) :: field(klon,field_size)
659	REAL,OPTIONAL,INTENT(IN) :: time
660
661	REAL :: field_glo(klon_glo,field_size)
662	REAL :: field_glo_reshape(klon_glo,nsoilmx,nslope,timeindex)
663	INTEGER :: ierr
664	INTEGER :: nvarid
665	INTEGER :: idim
666
667	CALL gather(field,field_glo)
668
669	IF (is_master) THEN
670
671	IF (field_size==1) THEN
672	! input is a 1D "surface field" array
673	if (.not.present(time)) then ! for a time-independent field
674	ierr=NF90_REDEF(nid_restart)
675	#ifdef NC_DOUBLE
676	ierr=NF90_DEF_VAR(nid_restart,field_name,NF90_DOUBLE,&
677	(/idim2/),nvarid)
678	#else
679	ierr=NF90_DEF_VAR(nid_restart,field_name,NF90_FLOAT,&
680	(/idim2/),nvarid)
681	#endif
682	if (ierr.ne.NF90_NOERR) then
683	write(,)"put_field_rgen error: failed to define "//trim(field_name)
684	write(,)trim(nf90_strerror(ierr))
685	endif
686	IF (LEN_TRIM(title) > 0) ierr=NF90_PUT_ATT(nid_restart,nvarid,"title",title)
687	ierr=NF90_ENDDEF(nid_restart)
688	ierr=NF90_PUT_VAR(nid_restart,nvarid,field_glo)
689	else
690	! check if the variable has already been defined:
691	ierr=NF90_INQ_VARID(nid_restart,field_name,nvarid)
692	if (ierr/=NF90_NOERR) then ! variable not found, define it
693	ierr=NF90_REDEF(nid_restart)
694	#ifdef NC_DOUBLE
695	if(field_name.eq. "tauscaling" .or. field_name.eq. "totcloudfrac" .or. field_name.eq. "wstar" ) then
696	ierr=NF90_DEF_VAR(nid_restart,field_name,NF90_DOUBLE,&
697	(/idim2,idim7/),nvarid)
698	else
699	ierr=NF90_DEF_VAR(nid_restart,field_name,NF90_DOUBLE,&
700	(/idim2,idim8,idim7/),nvarid)
701	endif
702	#else
703	if(field_name.eq. "tauscaling" .or. field_name.eq. "totcloudfrac" .or. field_name.eq. "wstar" ) then
704	ierr=NF90_DEF_VAR(nid_restart,field_name,NF90_FLOAT,&
705	(/idim2,idim7/),nvarid)
706	else
707	ierr=NF90_DEF_VAR(nid_restart,field_name,NF90_DOUBLE,&
708	(/idim2,idim8,idim7/),nvarid)
709	endif
710	#endif
711	if (ierr.ne.NF90_NOERR) then
712	write(,)"put_field_rgen error: failed to define "//trim(field_name)
713	write(,)trim(nf90_strerror(ierr))
714	endif
715	IF (LEN_TRIM(title) > 0) ierr=NF90_PUT_ATT(nid_restart,nvarid,"title",title)
716	ierr=NF90_ENDDEF(nid_restart)
717	endif
718	! Write the variable
719	ierr=NF90_PUT_VAR(nid_restart,nvarid,field_glo,&
720	start=(/1,timeindex/))
721	endif ! of if (.not.present(timeindex))
722
723	ELSE IF (field_size==klev) THEN
724	! input is a 2D "atmospheric field" array
725	if (.not.present(time)) then ! for a time-independent field
726	ierr=NF90_REDEF(nid_restart)
727	#ifdef NC_DOUBLE
728	ierr=NF90_DEF_VAR(nid_restart,field_name,NF90_DOUBLE,&
729	(/idim2,idim6/),nvarid)
730	#else
731	ierr=NF90_DEF_VAR(nid_restart,field_name,NF90_FLOAT,&
732	(/idim2,idim6/),nvarid)
733	#endif
734	if (ierr.ne.NF90_NOERR) then
735	write(,)"put_field_rgen error: failed to define "//trim(field_name)
736	write(,)trim(nf90_strerror(ierr))
737	endif
738	IF (LEN_TRIM(title) > 0) ierr=NF90_PUT_ATT(nid_restart,nvarid,"title",title)
739	ierr=NF90_ENDDEF(nid_restart)
740	ierr=NF90_PUT_VAR(nid_restart,nvarid,field_glo)
741	else
742	! check if the variable has already been defined:
743	ierr=NF90_INQ_VARID(nid_restart,field_name,nvarid)
744	if (ierr/=NF90_NOERR) then ! variable not found, define it
745	ierr=NF90_REDEF(nid_restart)
746	#ifdef NC_DOUBLE
747	ierr=NF90_DEF_VAR(nid_restart,field_name,NF90_DOUBLE,&
748	(/idim2,idim6,idim7/),nvarid)
749	#else
750	ierr=NF90_DEF_VAR(nid_restart,field_name,NF90_FLOAT,&
751	(/idim2,idim6,idim7/),nvarid)
752	#endif
753	if (ierr.ne.NF90_NOERR) then
754	write(,)"put_field_rgen error: failed to define "//trim(field_name)
755	write(,)trim(nf90_strerror(ierr))
756	endif
757	IF (LEN_TRIM(title) > 0) ierr=NF90_PUT_ATT(nid_restart,nvarid,"title",title)
758	ierr=NF90_ENDDEF(nid_restart)
759	endif
760	! Write the variable
761	ierr=NF90_PUT_VAR(nid_restart,nvarid,field_glo,&
762	start=(/1,1,timeindex/))
763	endif ! of if (.not.present(time))
764
765	ELSE IF (field_size==klevp1) THEN
766	! input is a 2D "interlayer atmospheric field" array
767	if (.not.present(time)) then ! for a time-independent field
768	ierr=NF90_REDEF(nid_restart)
769	#ifdef NC_DOUBLE
770	ierr=NF90_DEF_VAR(nid_restart,field_name,NF90_DOUBLE,&
771	(/idim2,idim4/),nvarid)
772	#else
773	ierr=NF90_DEF_VAR(nid_restart,field_name,NF90_FLOAT,&
774	(/idim2,idim4/),nvarid)
775	#endif
776	if (ierr.ne.NF90_NOERR) then
777	write(,)"put_field_rgen error: failed to define "//trim(field_name)
778	write(,)trim(nf90_strerror(ierr))
779	endif
780	IF (LEN_TRIM(title) > 0) ierr=NF90_PUT_ATT(nid_restart,nvarid,"title",title)
781	ierr = NF90_ENDDEF(nid_restart)
782	ierr = NF90_PUT_VAR(nid_restart,nvarid,field_glo)
783	else
784	! check if the variable has already been defined:
785	ierr=NF90_INQ_VARID(nid_restart,field_name,nvarid)
786	if (ierr/=NF90_NOERR) then ! variable not found, define it
787	ierr=NF90_REDEF(nid_restart)
788	#ifdef NC_DOUBLE
789	ierr=NF90_DEF_VAR(nid_restart,field_name,NF90_DOUBLE,&
790	(/idim2,idim4,idim7/),nvarid)
791	#else
792	ierr=NF90_DEF_VAR(nid_restart,field_name,NF90_FLOAT,&
793	(/idim2,idim4,idim7/),nvarid)
794	#endif
795	if (ierr.ne.NF90_NOERR) then
796	write(,)"put_field_rgen error: failed to define "//trim(field_name)
797	write(,)trim(nf90_strerror(ierr))
798	endif
799	IF (LEN_TRIM(title) > 0) ierr=NF90_PUT_ATT(nid_restart,nvarid,"title",title)
800	ierr=NF90_ENDDEF(nid_restart)
801	endif
802	! Write the variable
803	ierr=NF90_PUT_VAR(nid_restart,nvarid,field_glo,&
804	start=(/1,1,timeindex/))
805	endif ! of if (.not.present(timeindex))
806
807	ELSE IF (field_size==nsoilmx .or. field_size==nsoilmx*nslope) THEN
808	! input is a 2D "subsurface field" array
809	if (.not.present(time)) then ! for a time-independent field
810	ierr = NF90_REDEF(nid_restart)
811	#ifdef NC_DOUBLE
812	ierr=NF90_DEF_VAR(nid_restart,field_name,NF90_DOUBLE,&
813	(/idim2,idim3/),nvarid)
814	#else
815	ierr=NF90_DEF_VAR(nid_restart,field_name,NF90_FLOAT,&
816	(/idim2,idim3/),nvarid)
817	#endif
818	if (ierr.ne.NF90_NOERR) then
819	write(,)"put_field_rgen error: failed to define "//trim(field_name)
820	write(,)trim(nf90_strerror(ierr))
821	endif
822	IF (LEN_TRIM(title) > 0) ierr=NF90_PUT_ATT(nid_restart,nvarid,"title",title)
823	ierr = NF90_ENDDEF(nid_restart)
824	ierr = NF90_PUT_VAR(nid_restart,nvarid,field_glo)
825	else
826	! check if the variable has already been defined:
827	ierr=NF90_INQ_VARID(nid_restart,field_name,nvarid)
828	if (ierr/=NF90_NOERR) then ! variable not found, define it
829	ierr=NF90_REDEF(nid_restart)
830	#ifdef NC_DOUBLE
831	if(field_name.eq. "tsoil") then
832	ierr=NF90_DEF_VAR(nid_restart,field_name,NF90_DOUBLE,&
833	(/idim2,idim3,idim8,idim7/),nvarid)
834	else
835	ierr=NF90_DEF_VAR(nid_restart,field_name,NF90_DOUBLE,&
836	(/idim2,idim3,idim7/),nvarid)
837	endif
838	#else
839	if(field_name.eq. "tsoil") then
840	ierr=NF90_DEF_VAR(nid_restart,field_name,NF90_FLOAT,&
841	(/idim2,idim3,idim8,idim7/),nvarid)
842	else
843	ierr=NF90_DEF_VAR(nid_restart,field_name,NF90_FLOAT,&
844	(/idim2,idim3,idim7/),nvarid)
845	endif
846	#endif
847	if (ierr.ne.NF90_NOERR) then
848	write(,)"put_field_rgen error: failed to define "//trim(field_name)
849	write(,)trim(nf90_strerror(ierr))
850	endif
851	IF (LEN_TRIM(title) > 0) ierr=NF90_PUT_ATT(nid_restart,nvarid,"title",title)
852	ierr=NF90_ENDDEF(nid_restart)
853	endif
854	! Write the variable
855	if(field_name.eq. "tsoil") then
856
857	field_glo_reshape=RESHAPE(field_glo, (/klon_glo, nsoilmx, nslope, timeindex/))
858
859	ierr=NF90_PUT_VAR(nid_restart,nvarid,field_glo_reshape,&
860	start=(/1,1,1,timeindex/))
861	else
862	ierr=NF90_PUT_VAR(nid_restart,nvarid,field_glo,&
863	start=(/1,1,timeindex/))
864	endif
865	endif ! of if (.not.present(time))
866
867	ELSE IF (field_size==nslope) THEN
868	! input is a 2D "subsurface field" array
869	if (.not.present(time)) then ! for a time-independent field
870	ierr = NF90_REDEF(nid_restart)
871	#ifdef NC_DOUBLE
872	ierr=NF90_DEF_VAR(nid_restart,field_name,NF90_DOUBLE,&
873	(/idim2,idim8/),nvarid)
874	#else
875	ierr=NF90_DEF_VAR(nid_restart,field_name,NF90_FLOAT,&
876	(/idim2,idim8/),nvarid)
877	#endif
878	if (ierr.ne.NF90_NOERR) then
879	write(,)"put_field_rgen error: failed to define"//trim(field_name)
880	write(,)trim(nf90_strerror(ierr))
881	endif
882	IF (LEN_TRIM(title) > 0) ierr=NF90_PUT_ATT(nid_restart,nvarid,"title",title)
883	ierr = NF90_ENDDEF(nid_restart)
884	ierr = NF90_PUT_VAR(nid_restart,nvarid,field_glo)
885	else
886	! check if the variable has already been defined:
887	ierr=NF90_INQ_VARID(nid_restart,field_name,nvarid)
888	if (ierr/=NF90_NOERR) then ! variable not found, define it
889	ierr=NF90_REDEF(nid_restart)
890	#ifdef NC_DOUBLE
891	ierr=NF90_DEF_VAR(nid_restart,field_name,NF90_DOUBLE,&
892	(/idim2,idim8,idim7/),nvarid)
893	#else
894	ierr=NF90_DEF_VAR(nid_restart,field_name,NF90_FLOAT,&
895	(/idim2,idim8,idim7/),nvarid)
896	#endif
897	if (ierr.ne.NF90_NOERR) then
898	write(,)"put_field_rgen error: failed to define"//trim(field_name)
899	write(,)trim(nf90_strerror(ierr))
900	endif
901	IF (LEN_TRIM(title) > 0) ierr=NF90_PUT_ATT(nid_restart,nvarid,"title",title)
902	ierr=NF90_ENDDEF(nid_restart)
903	endif
904	! Write the variable
905	ierr=NF90_PUT_VAR(nid_restart,nvarid,field_glo,&
906	start=(/1,1,timeindex/))
907
908	endif ! of if (.not.present(time))
909
910	ELSE
911	PRINT *, "Error phyredem(put_field_rgen) : wrong dimension for ",trim(field_name)
912	write(,) " field_size =",field_size
913	CALL abort_physic("put_field_rgen","wrong field dimension",1)
914	ENDIF
915
916	! Check the writting of field to file went OK
917	if (ierr.ne.NF90_NOERR) then
918	write(,) " Error phyredem(put_field_rgen) : failed writing ",trim(field_name)
919	write(,)trim(nf90_strerror(ierr))
920	CALL abort_physic("put_field_rgen","Failed writing field",1)
921	endif
922
923	ENDIF ! of IF (is_master)
924
925	END SUBROUTINE put_field_rgen
926
927	SUBROUTINE put_var_r0(var_name,title,var)
928	! Put a scalar in file
929	IMPLICIT NONE
930	CHARACTER(LEN=*),INTENT(IN) :: var_name
931	CHARACTER(LEN=*),INTENT(IN) :: title
932	REAL,INTENT(IN) :: var
933	REAL :: varin(1)
934
935	varin(1)=var
936
937	CALL put_var_rgen(var_name,title,varin,size(varin))
938
939	END SUBROUTINE put_var_r0
940
941
942	SUBROUTINE put_var_r1(var_name,title,var)
943	! Put a vector in file
944	IMPLICIT NONE
945	CHARACTER(LEN=*),INTENT(IN) :: var_name
946	CHARACTER(LEN=*),INTENT(IN) :: title
947	REAL,INTENT(IN) :: var(:)
948
949	CALL put_var_rgen(var_name,title,var,size(var))
950
951	END SUBROUTINE put_var_r1
952
953	SUBROUTINE put_var_r2(var_name,title,var)
954	! Put a 2D field in file
955	IMPLICIT NONE
956	CHARACTER(LEN=*),INTENT(IN) :: var_name
957	CHARACTER(LEN=*),INTENT(IN) :: title
958	REAL,INTENT(IN) :: var(:,:)
959
960	CALL put_var_rgen(var_name,title,var,size(var))
961
962	END SUBROUTINE put_var_r2
963
964	SUBROUTINE put_var_r3(var_name,title,var)
965	! Put a 3D field in file
966	IMPLICIT NONE
967	CHARACTER(LEN=*),INTENT(IN) :: var_name
968	CHARACTER(LEN=*),INTENT(IN) :: title
969	REAL,INTENT(IN) :: var(:,:,:)
970
971	CALL put_var_rgen(var_name,title,var,size(var))
972
973	END SUBROUTINE put_var_r3
974
975	SUBROUTINE put_var_rgen(var_name,title,var,var_size)
976	USE netcdf, only: NF90_REDEF, NF90_DEF_VAR, NF90_ENDDEF, NF90_PUT_VAR, &
977	NF90_FLOAT, NF90_DOUBLE, &
978	NF90_PUT_ATT, NF90_NOERR, nf90_strerror, &
979	nf90_inq_dimid, nf90_inquire_dimension, NF90_INQ_VARID
980	USE comsoil_h, only: nsoilmx
981	USE comslope_mod, only: nslope
982	USE mod_phys_lmdz_para, only: is_master
983	IMPLICIT NONE
984	CHARACTER(LEN=*),INTENT(IN) :: var_name
985	CHARACTER(LEN=*),INTENT(IN) :: title
986	INTEGER,INTENT(IN) :: var_size
987	REAL,INTENT(IN) :: var(var_size)
988
989	INTEGER :: ierr
990	INTEGER :: nvarid
991	INTEGER :: idim1d
992	logical,save :: firsttime=.true.
993
994	IF (is_master) THEN
995
996	IF (var_name=="Time") THEN
997	! Very specific case of "Time" variable
998	if (firsttime) then
999	! Create the "Time variable"
1000	ierr=NF90_REDEF(nid_restart)
1001	#ifdef NC_DOUBLE
1002	ierr=NF90_DEF_VAR(nid_restart,var_name,NF90_DOUBLE,&
1003	(/idim7/),nvarid)
1004	#else
1005	ierr=NF90_DEF_VAR(nid_restart,var_name,NF90_FLOAT,&
1006	(/idim7/),nvarid)
1007	#endif
1008	IF (LEN_TRIM(title) > 0) ierr=NF90_PUT_ATT(nid_restart,nvarid,"title",title)
1009	ierr=NF90_ENDDEF(nid_restart)
1010
1011	firsttime=.false.
1012	endif
1013	! Append "time" value
1014	! get current length of "Time" dimension
1015	ierr=nf90_inq_dimid(nid_restart,var_name,idim1d)
1016	ierr=nf90_inquire_dimension(nid_restart,idim1d,len=timeindex)
1017	timeindex=timeindex+1
1018	ierr=NF90_INQ_VARID(nid_restart,var_name,nvarid)
1019	ierr=NF90_PUT_VAR(nid_restart,nvarid,var,&
1020	start=(/timeindex/))
1021	IF (ierr/=NF90_NOERR) THEN
1022	write(,)'put_var_rgen: problem writing Time'
1023	write(,)trim(nf90_strerror(ierr))
1024	CALL abort_physic("get_var_rgen","Failed to write Time",1)
1025	ENDIF
1026	return ! nothing left to do
1027	ELSEIF (var_size==length) THEN
1028	! We know it is a "controle" kind of 1D array
1029	idim1d=idim1
1030	ELSEIF (var_size==nsoilmx) THEN
1031	! We know it is an "mlayer" kind of 1D array
1032	idim1d=idim3
1033	ELSEIF (var_size==nslope+1) THEN
1034	! We know it is an "inter slope" kind of 1D array
1035	idim1d=idim9
1036	ELSE
1037	PRINT *, "put_var_rgen error : wrong dimension"
1038	write(,) " var_size =",var_size
1039	CALL abort_physic("get_var_rgen","Wrong variable dimension",1)
1040
1041	ENDIF ! of IF (var_size==length) THEN
1042
1043	! Swich to NetCDF define mode
1044	ierr=NF90_REDEF (nid_restart)
1045	! Define the variable
1046	#ifdef NC_DOUBLE
1047	ierr=NF90_DEF_VAR(nid_restart,var_name,NF90_DOUBLE,(/idim1d/),nvarid)
1048	#else
1049	ierr=NF90_DEF_VAR(nid_restart,var_name,NF90_FLOAT,(/idim1d/),nvarid)
1050	#endif
1051	! Add a "title" attribute
1052	IF (LEN_TRIM(title)>0) ierr=NF90_PUT_ATT(nid_restart,nvarid,"title",title)
1053	! Swich out of define mode
1054	ierr=NF90_ENDDEF(nid_restart)
1055	! Write variable to file
1056	ierr=NF90_PUT_VAR(nid_restart,nvarid,var)
1057	IF (ierr/=NF90_NOERR) THEN
1058	write(,)'put_var_rgen: problem writing '//trim(var_name)
1059	write(,)trim(nf90_strerror(ierr))
1060	CALL abort_physic("get_var_rgen","Failed writing variable",1)
1061	ENDIF
1062	ENDIF ! of IF (is_master)
1063
1064	END SUBROUTINE put_var_rgen
1065
1066	END MODULE iostart

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

Download in other formats:

Original Format