Context Navigation

iostart.F90 @ 5028

Last change on this file since 5028 was 3411, checked in by Laurent Fairhead, 6 years ago
Undoing merge with trunk (r3356) to properly register Yann's latest modifications
Property copyright set to Name of program: LMDZ Creation date: 1984 Version: LMDZ5 License: CeCILL version 2 Holder: Laboratoire de m\'et\'eorologie dynamique, CNRS, UMR 8539 See the license file in the root directory Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 14.3 KB

Line
1	MODULE iostart
2
3	PRIVATE
4	INTEGER,SAVE :: nid_start
5	INTEGER,SAVE :: nid_restart
6
7	INTEGER,SAVE :: idim1,idim2,idim3,idim4
8	INTEGER,PARAMETER :: length=100
9
10	INTERFACE get_field
11	MODULE PROCEDURE Get_field_r1,Get_field_r2,Get_field_r3
12	END INTERFACE get_field
13
14	INTERFACE get_var
15	MODULE PROCEDURE get_var_r0,Get_var_r1,Get_var_r2,Get_var_r3
16	END INTERFACE get_var
17
18	INTERFACE put_field
19	MODULE PROCEDURE put_field_r1,put_field_r2,put_field_r3
20	END INTERFACE put_field
21
22	INTERFACE put_var
23	MODULE PROCEDURE put_var_r0,put_var_r1,put_var_r2,put_var_r3
24	END INTERFACE put_var
25
26	PUBLIC get_field,get_var,put_field,put_var
27	PUBLIC Open_startphy,close_startphy,open_restartphy,close_restartphy
28
29	CONTAINS
30
31	SUBROUTINE Open_startphy(filename)
32	USE netcdf
33	USE mod_phys_lmdz_para
34	IMPLICIT NONE
35	CHARACTER(LEN=*) :: filename
36	INTEGER :: ierr
37
38	IF (is_mpi_root .AND. is_omp_root) THEN
39	ierr = NF90_OPEN (filename, NF90_NOWRITE,nid_start)
40	IF (ierr.NE.NF90_NOERR) THEN
41	write(6,*)' Pb d''ouverture du fichier '//filename
42	write(6,*)' ierr = ', ierr
43	CALL abort_physic("", "", 1)
44	ENDIF
45	ENDIF
46
47	END SUBROUTINE Open_startphy
48
49	SUBROUTINE Close_startphy
50	USE netcdf
51	USE mod_phys_lmdz_para
52	IMPLICIT NONE
53	INTEGER :: ierr
54
55	IF (is_mpi_root .AND. is_omp_root) THEN
56	ierr = NF90_CLOSE (nid_start)
57	ENDIF
58
59	END SUBROUTINE close_startphy
60
61
62	FUNCTION Inquire_Field(Field_name)
63	USE netcdf
64	USE mod_phys_lmdz_para
65	IMPLICIT NONE
66	CHARACTER(LEN=*) :: Field_name
67	LOGICAL :: inquire_field
68	INTEGER :: varid
69	INTEGER :: ierr
70
71	IF (is_mpi_root .AND. is_omp_root) THEN
72	ierr=NF90_INQ_VARID(nid_start,Field_name,varid)
73	IF (ierr==NF90_NOERR) THEN
74	Inquire_field=.TRUE.
75	ELSE
76	Inquire_field=.FALSE.
77	ENDIF
78	ENDIF
79
80	CALL bcast(Inquire_field)
81
82	END FUNCTION Inquire_Field
83
84
85	SUBROUTINE Get_Field_r1(field_name,field,found)
86	IMPLICIT NONE
87	CHARACTER(LEN=*),INTENT(IN) :: Field_name
88	REAL,INTENT(INOUT) :: Field(:)
89	LOGICAL,INTENT(OUT),OPTIONAL :: found
90
91	IF (PRESENT(found)) THEN
92	CALL Get_field_rgen(field_name,field,1,found)
93	ELSE
94	CALL Get_field_rgen(field_name,field,1)
95	ENDIF
96
97	END SUBROUTINE Get_Field_r1
98
99	SUBROUTINE Get_Field_r2(field_name,field,found)
100	IMPLICIT NONE
101	CHARACTER(LEN=*),INTENT(IN) :: Field_name
102	REAL,INTENT(INOUT) :: Field(:,:)
103	LOGICAL,INTENT(OUT),OPTIONAL :: found
104
105	IF (PRESENT(found)) THEN
106	CALL Get_field_rgen(field_name,field,size(field,2),found)
107	ELSE
108	CALL Get_field_rgen(field_name,field,size(field,2))
109	ENDIF
110
111
112	END SUBROUTINE Get_Field_r2
113
114	SUBROUTINE Get_Field_r3(field_name,field,found)
115	IMPLICIT NONE
116	CHARACTER(LEN=*),INTENT(IN) :: Field_name
117	REAL,INTENT(INOUT) :: Field(:,:,:)
118	LOGICAL,INTENT(OUT),OPTIONAL :: found
119
120	IF (PRESENT(found)) THEN
121	CALL Get_field_rgen(field_name,field,size(field,2)*size(field,3),found)
122	ELSE
123	CALL Get_field_rgen(field_name,field,size(field,2)*size(field,3))
124	ENDIF
125
126	END SUBROUTINE Get_Field_r3
127
128	SUBROUTINE Get_field_rgen(field_name,field,field_size,found)
129	USE netcdf
130	USE dimphy
131	USE geometry_mod
132	USE mod_grid_phy_lmdz
133	USE mod_phys_lmdz_para
134	IMPLICIT NONE
135	CHARACTER(LEN=*) :: Field_name
136	INTEGER :: field_size
137	REAL :: field(klon,field_size)
138	LOGICAL,OPTIONAL :: found
139
140	REAL :: field_glo(klon_glo,field_size)
141	REAL :: field_glo_tmp(klon_glo,field_size)
142	INTEGER :: ind_cell_glo_glo(klon_glo)
143	LOGICAL :: tmp_found
144	INTEGER :: varid
145	INTEGER :: ierr,i
146
147	! IF (is_master) ALLOCATE(ind_cell_glo_glo(1:klon_glo))
148	CALL gather(ind_cell_glo,ind_cell_glo_glo)
149
150	IF (is_master) THEN
151
152	ierr=NF90_INQ_VARID(nid_start,Field_name,varid)
153
154	IF (ierr==NF90_NOERR) THEN
155	CALL body(field_glo_tmp)
156	tmp_found=.TRUE.
157	ELSE
158	tmp_found=.FALSE.
159	ENDIF
160
161	ENDIF
162
163	CALL bcast(tmp_found)
164
165	IF (tmp_found) THEN
166	IF (is_master) THEN
167	DO i=1,klon_glo
168	field_glo(i,:)=field_glo_tmp(ind_cell_glo_glo(i),:)
169	ENDDO
170	ENDIF
171	CALL scatter(field_glo,field)
172	ENDIF
173
174	IF (PRESENT(found)) THEN
175	found=tmp_found
176	ELSE
177	IF (.NOT. tmp_found) THEN
178	PRINT*, 'phyetat0: Le champ <'//field_name//'> est absent'
179	call abort_physic("", "", 1)
180	ENDIF
181	ENDIF
182
183
184	CONTAINS
185
186	SUBROUTINE body(field_glo)
187	REAL :: field_glo(klon_glo*field_size)
188	ierr=NF90_GET_VAR(nid_start,varid,field_glo)
189	IF (ierr/=NF90_NOERR) THEN
190	! La variable exist dans le fichier mais la lecture a echouee.
191	PRINT*, 'phyetat0: Lecture echouee pour <'//field_name//'>'
192
193	IF (field_name=='CLWCON' .OR. field_name=='RNEBCON' .OR. field_name=='RATQS') THEN
194	! Essaye de lire le variable sur surface uniqument, comme fait avant
195	field_glo(:)=0.
196	ierr=NF90_GET_VAR(nid_start,varid,field_glo(1:klon_glo))
197	IF (ierr/=NF90_NOERR) THEN
198	PRINT*, 'phyetat0: Lecture echouee aussi en 2D pour <'//field_name//'>'
199	call abort_physic("", "", 1)
200	ELSE
201	PRINT*, 'phyetat0: La variable <'//field_name//'> lu sur surface seulement'!, selon ancien format, le reste mis a zero'
202	END IF
203	ELSE
204	call abort_physic("", "", 1)
205	ENDIF
206	ENDIF
207
208	END SUBROUTINE body
209
210	END SUBROUTINE Get_field_rgen
211
212
213	SUBROUTINE get_var_r0(var_name,var,found)
214	IMPLICIT NONE
215	CHARACTER(LEN=*),INTENT(IN) :: var_name
216	REAL,INTENT(INOUT) :: var
217	LOGICAL,OPTIONAL,INTENT(OUT) :: found
218
219	REAL :: varout(1)
220
221	IF (PRESENT(found)) THEN
222	CALL Get_var_rgen(var_name,varout,size(varout),found)
223	ELSE
224	CALL Get_var_rgen(var_name,varout,size(varout))
225	ENDIF
226	var=varout(1)
227
228	END SUBROUTINE get_var_r0
229
230	SUBROUTINE get_var_r1(var_name,var,found)
231	IMPLICIT NONE
232	CHARACTER(LEN=*),INTENT(IN) :: var_name
233	REAL,INTENT(INOUT) :: var(:)
234	LOGICAL,OPTIONAL,INTENT(OUT) :: found
235
236	IF (PRESENT(found)) THEN
237	CALL Get_var_rgen(var_name,var,size(var),found)
238	ELSE
239	CALL Get_var_rgen(var_name,var,size(var))
240	ENDIF
241
242	END SUBROUTINE get_var_r1
243
244	SUBROUTINE get_var_r2(var_name,var,found)
245	IMPLICIT NONE
246	CHARACTER(LEN=*),INTENT(IN) :: var_name
247	REAL,INTENT(OUT) :: var(:,:)
248	LOGICAL,OPTIONAL,INTENT(OUT) :: found
249
250	IF (PRESENT(found)) THEN
251	CALL Get_var_rgen(var_name,var,size(var),found)
252	ELSE
253	CALL Get_var_rgen(var_name,var,size(var))
254	ENDIF
255
256	END SUBROUTINE get_var_r2
257
258	SUBROUTINE get_var_r3(var_name,var,found)
259	IMPLICIT NONE
260	CHARACTER(LEN=*),INTENT(IN) :: var_name
261	REAL,INTENT(INOUT) :: var(:,:,:)
262	LOGICAL,OPTIONAL,INTENT(OUT) :: found
263
264	IF (PRESENT(found)) THEN
265	CALL Get_var_rgen(var_name,var,size(var),found)
266	ELSE
267	CALL Get_var_rgen(var_name,var,size(var))
268	ENDIF
269
270	END SUBROUTINE get_var_r3
271
272	SUBROUTINE Get_var_rgen(var_name,var,var_size,found)
273	USE netcdf
274	USE dimphy
275	USE mod_grid_phy_lmdz
276	USE mod_phys_lmdz_para
277	IMPLICIT NONE
278	CHARACTER(LEN=*) :: var_name
279	INTEGER :: var_size
280	REAL :: var(var_size)
281	LOGICAL,OPTIONAL :: found
282
283	LOGICAL :: tmp_found
284	INTEGER :: varid
285	INTEGER :: ierr
286
287	IF (is_mpi_root .AND. is_omp_root) THEN
288
289	ierr=NF90_INQ_VARID(nid_start,var_name,varid)
290
291	IF (ierr==NF90_NOERR) THEN
292	ierr=NF90_GET_VAR(nid_start,varid,var)
293	IF (ierr/=NF90_NOERR) THEN
294	PRINT*, 'phyetat0: Lecture echouee pour <'//var_name//'>'
295	call abort_physic("", "", 1)
296	ENDIF
297	tmp_found=.TRUE.
298	ELSE
299	tmp_found=.FALSE.
300	ENDIF
301
302	ENDIF
303
304	CALL bcast(tmp_found)
305
306	IF (tmp_found) THEN
307	CALL bcast(var)
308	ENDIF
309
310	IF (PRESENT(found)) THEN
311	found=tmp_found
312	ELSE
313	IF (.NOT. tmp_found) THEN
314	PRINT*, 'phyetat0: La variable champ <'//var_name//'> est absente'
315	call abort_physic("", "", 1)
316	ENDIF
317	ENDIF
318
319	END SUBROUTINE Get_var_rgen
320
321
322	SUBROUTINE open_restartphy(filename)
323	USE netcdf
324	USE mod_phys_lmdz_para
325	USE mod_grid_phy_lmdz
326	USE dimphy
327	IMPLICIT NONE
328	CHARACTER(LEN=*),INTENT(IN) :: filename
329	INTEGER :: ierr
330
331	IF (is_mpi_root .AND. is_omp_root) THEN
332	ierr = NF90_CREATE(filename, NF90_CLOBBER, nid_restart)
333	IF (ierr/=NF90_NOERR) THEN
334	write(6,*)' Pb d''ouverture du fichier '//filename
335	write(6,*)' ierr = ', ierr
336	CALL abort_physic("", "", 1)
337	ENDIF
338
339	ierr = NF90_PUT_ATT (nid_restart, NF90_GLOBAL, "title","Fichier redemmarage physique")
340
341	ierr = NF90_DEF_DIM (nid_restart, "index", length, idim1)
342	ierr = NF90_DEF_DIM (nid_restart, "points_physiques", klon_glo, idim2)
343	ierr = NF90_DEF_DIM (nid_restart, "horizon_vertical", klon_glo*klev, idim3)
344	ierr = NF90_DEF_DIM (nid_restart, "horizon_klevp1", klon_glo*klevp1, idim4)
345
346	ierr = NF90_ENDDEF(nid_restart)
347	ENDIF
348
349	END SUBROUTINE open_restartphy
350
351	SUBROUTINE close_restartphy
352	USE netcdf
353	USE mod_phys_lmdz_para
354	IMPLICIT NONE
355	INTEGER :: ierr
356
357	IF (is_mpi_root .AND. is_omp_root) THEN
358	ierr = NF90_CLOSE (nid_restart)
359	ENDIF
360
361	END SUBROUTINE close_restartphy
362
363
364	SUBROUTINE put_field_r1(field_name,title,field)
365	IMPLICIT NONE
366	CHARACTER(LEN=*),INTENT(IN) :: field_name
367	CHARACTER(LEN=*),INTENT(IN) :: title
368	REAL,INTENT(IN) :: field(:)
369
370	CALL put_field_rgen(field_name,title,field,1)
371
372	END SUBROUTINE put_field_r1
373
374	SUBROUTINE put_field_r2(field_name,title,field)
375	IMPLICIT NONE
376	CHARACTER(LEN=*),INTENT(IN) :: field_name
377	CHARACTER(LEN=*),INTENT(IN) :: title
378	REAL,INTENT(IN) :: field(:,:)
379
380	CALL put_field_rgen(field_name,title,field,size(field,2))
381
382	END SUBROUTINE put_field_r2
383
384	SUBROUTINE put_field_r3(field_name,title,field)
385	IMPLICIT NONE
386	CHARACTER(LEN=*),INTENT(IN) :: field_name
387	CHARACTER(LEN=*),INTENT(IN) :: title
388	REAL,INTENT(IN) :: field(:,:,:)
389
390	CALL put_field_rgen(field_name,title,field,size(field,2)*size(field,3))
391
392	END SUBROUTINE put_field_r3
393
394	SUBROUTINE put_field_rgen(field_name,title,field,field_size)
395	USE netcdf
396	USE dimphy
397	USE geometry_mod
398	USE mod_grid_phy_lmdz
399	USE mod_phys_lmdz_para
400	IMPLICIT NONE
401	CHARACTER(LEN=*),INTENT(IN) :: field_name
402	CHARACTER(LEN=*),INTENT(IN) :: title
403	INTEGER,INTENT(IN) :: field_size
404	REAL,INTENT(IN) :: field(klon,field_size)
405
406	REAL :: field_glo(klon_glo,field_size)
407	REAL :: field_glo_tmp(klon_glo,field_size)
408	! INTEGER,ALLOCATABLE :: ind_cell_glo_glo(:)
409	INTEGER :: ind_cell_glo_glo(klon_glo)
410	INTEGER :: ierr,i
411	INTEGER :: nvarid
412	INTEGER :: idim
413
414
415	! IF (is_master) ALLOCATE(ind_cell_glo_glo(klon_glo))
416	CALL gather(ind_cell_glo,ind_cell_glo_glo)
417
418	CALL gather(field,field_glo_tmp)
419
420	IF (is_master) THEN
421
422	DO i=1,klon_glo
423	field_glo(ind_cell_glo_glo(i),:)=field_glo_tmp(i,:)
424	ENDDO
425
426
427	IF (field_size==1) THEN
428	idim=idim2
429	ELSE IF (field_size==klev) THEN
430	idim=idim3
431	ELSE IF (field_size==klevp1) THEN
432	idim=idim4
433	ELSE
434	PRINT *, "erreur phyredem : probleme de dimension"
435	CALL abort_physic("", "", 1)
436	ENDIF
437
438	ierr = NF90_REDEF (nid_restart)
439	#ifdef NC_DOUBLE
440	ierr = NF90_DEF_VAR (nid_restart, field_name, NF90_DOUBLE,(/ idim /),nvarid)
441	#else
442	ierr = NF90_DEF_VAR (nid_restart, field_name, NF90_FLOAT,(/ idim /),nvarid)
443	#endif
444	IF (LEN_TRIM(title) > 0) ierr = NF90_PUT_ATT (nid_restart,nvarid,"title", title)
445	ierr = NF90_ENDDEF(nid_restart)
446	ierr = NF90_PUT_VAR(nid_restart,nvarid,RESHAPE(field_glo,(/klon_glo*field_size/)))
447	ENDIF
448
449	END SUBROUTINE put_field_rgen
450
451	SUBROUTINE put_var_r0(var_name,title,var)
452	IMPLICIT NONE
453	CHARACTER(LEN=*),INTENT(IN) :: var_name
454	CHARACTER(LEN=*),INTENT(IN) :: title
455	REAL,INTENT(IN) :: var
456	REAL :: varin(1)
457
458	varin(1)=var
459
460	CALL put_var_rgen(var_name,title,varin,size(varin))
461
462	END SUBROUTINE put_var_r0
463
464
465	SUBROUTINE put_var_r1(var_name,title,var)
466	IMPLICIT NONE
467	CHARACTER(LEN=*),INTENT(IN) :: var_name
468	CHARACTER(LEN=*),INTENT(IN) :: title
469	REAL,INTENT(IN) :: var(:)
470
471	CALL put_var_rgen(var_name,title,var,size(var))
472
473	END SUBROUTINE put_var_r1
474
475	SUBROUTINE put_var_r2(var_name,title,var)
476	IMPLICIT NONE
477	CHARACTER(LEN=*),INTENT(IN) :: var_name
478	CHARACTER(LEN=*),INTENT(IN) :: title
479	REAL,INTENT(IN) :: var(:,:)
480
481	CALL put_var_rgen(var_name,title,var,size(var))
482
483	END SUBROUTINE put_var_r2
484
485	SUBROUTINE put_var_r3(var_name,title,var)
486	IMPLICIT NONE
487	CHARACTER(LEN=*),INTENT(IN) :: var_name
488	CHARACTER(LEN=*),INTENT(IN) :: title
489	REAL,INTENT(IN) :: var(:,:,:)
490
491	CALL put_var_rgen(var_name,title,var,size(var))
492
493	END SUBROUTINE put_var_r3
494
495	SUBROUTINE put_var_rgen(var_name,title,var,var_size)
496	USE netcdf
497	USE dimphy
498	USE mod_phys_lmdz_para
499	IMPLICIT NONE
500	CHARACTER(LEN=*),INTENT(IN) :: var_name
501	CHARACTER(LEN=*),INTENT(IN) :: title
502	INTEGER,INTENT(IN) :: var_size
503	REAL,INTENT(IN) :: var(var_size)
504
505	INTEGER :: ierr
506	INTEGER :: nvarid
507
508	IF (is_mpi_root .AND. is_omp_root) THEN
509
510	IF (var_size/=length) THEN
511	PRINT *, "erreur phyredem : probleme de dimension"
512	call abort_physic("", "", 1)
513	ENDIF
514
515	ierr = NF90_REDEF (nid_restart)
516
517	#ifdef NC_DOUBLE
518	ierr = NF90_DEF_VAR (nid_restart, var_name, NF90_DOUBLE,(/ idim1 /),nvarid)
519	#else
520	ierr = NF90_DEF_VAR (nid_restart, var_name, NF90_FLOAT,(/ idim1 /),nvarid)
521	#endif
522	IF (LEN_TRIM(title)>0) ierr = NF90_PUT_ATT (nid_restart,nvarid,"title", title)
523	ierr = NF90_ENDDEF(nid_restart)
524
525	ierr = NF90_PUT_VAR(nid_restart,nvarid,var)
526
527	ENDIF
528
529	END SUBROUTINE put_var_rgen
530
531	END MODULE iostart

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

Download in other formats:

Original Format