Context Navigation

iostart.F90

Last change on this file was 3331, checked in by acozic, 7 years ago
Add modification for isotopes
Property svn:executable set to ``*
File size: 13.6 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 mod_grid_phy_lmdz
132	USE mod_phys_lmdz_para
133	IMPLICIT NONE
134	CHARACTER(LEN=*) :: Field_name
135	INTEGER :: field_size
136	REAL :: field(klon,field_size)
137	LOGICAL,OPTIONAL :: found
138
139	REAL :: field_glo(klon_glo,field_size)
140	LOGICAL :: tmp_found
141	INTEGER :: varid
142	INTEGER :: ierr
143
144	IF (is_mpi_root .AND. is_omp_root) THEN
145
146	ierr=NF90_INQ_VARID(nid_start,Field_name,varid)
147
148	IF (ierr==NF90_NOERR) THEN
149	CALL body(field_glo)
150	tmp_found=.TRUE.
151	ELSE
152	tmp_found=.FALSE.
153	ENDIF
154
155	ENDIF
156
157	CALL bcast(tmp_found)
158
159	IF (tmp_found) THEN
160	CALL scatter(field_glo,field)
161	ENDIF
162
163	IF (PRESENT(found)) THEN
164	found=tmp_found
165	ELSE
166	IF (.NOT. tmp_found) THEN
167	PRINT*, 'phyetat0: Le champ <'//field_name//'> est absent'
168	call abort_physic("", "", 1)
169	ENDIF
170	ENDIF
171
172
173	CONTAINS
174
175	SUBROUTINE body(field_glo)
176	REAL :: field_glo(klon_glo*field_size)
177	ierr=NF90_GET_VAR(nid_start,varid,field_glo)
178	IF (ierr/=NF90_NOERR) THEN
179	! La variable exist dans le fichier mais la lecture a echouee.
180	PRINT*, 'phyetat0: Lecture echouee pour <'//field_name//'>'
181
182	IF (field_name=='CLWCON' .OR. field_name=='RNEBCON' .OR. field_name=='RATQS') THEN
183	! Essaye de lire le variable sur surface uniqument, comme fait avant
184	field_glo(:)=0.
185	ierr=NF90_GET_VAR(nid_start,varid,field_glo(1:klon_glo))
186	IF (ierr/=NF90_NOERR) THEN
187	PRINT*, 'phyetat0: Lecture echouee aussi en 2D pour <'//field_name//'>'
188	call abort_physic("", "", 1)
189	ELSE
190	PRINT*, 'phyetat0: La variable <'//field_name//'> lu sur surface seulement'!, selon ancien format, le reste mis a zero'
191	END IF
192	ELSE
193	call abort_physic("", "", 1)
194	ENDIF
195	ENDIF
196
197	END SUBROUTINE body
198
199	END SUBROUTINE Get_field_rgen
200
201
202	SUBROUTINE get_var_r0(var_name,var,found)
203	IMPLICIT NONE
204	CHARACTER(LEN=*),INTENT(IN) :: var_name
205	REAL,INTENT(INOUT) :: var
206	LOGICAL,OPTIONAL,INTENT(OUT) :: found
207
208	REAL :: varout(1)
209
210	IF (PRESENT(found)) THEN
211	CALL Get_var_rgen(var_name,varout,size(varout),found)
212	ELSE
213	CALL Get_var_rgen(var_name,varout,size(varout))
214	ENDIF
215	var=varout(1)
216
217	END SUBROUTINE get_var_r0
218
219	SUBROUTINE get_var_r1(var_name,var,found)
220	IMPLICIT NONE
221	CHARACTER(LEN=*),INTENT(IN) :: var_name
222	REAL,INTENT(INOUT) :: var(:)
223	LOGICAL,OPTIONAL,INTENT(OUT) :: found
224
225	IF (PRESENT(found)) THEN
226	CALL Get_var_rgen(var_name,var,size(var),found)
227	ELSE
228	CALL Get_var_rgen(var_name,var,size(var))
229	ENDIF
230
231	END SUBROUTINE get_var_r1
232
233	SUBROUTINE get_var_r2(var_name,var,found)
234	IMPLICIT NONE
235	CHARACTER(LEN=*),INTENT(IN) :: var_name
236	REAL,INTENT(OUT) :: var(:,:)
237	LOGICAL,OPTIONAL,INTENT(OUT) :: found
238
239	IF (PRESENT(found)) THEN
240	CALL Get_var_rgen(var_name,var,size(var),found)
241	ELSE
242	CALL Get_var_rgen(var_name,var,size(var))
243	ENDIF
244
245	END SUBROUTINE get_var_r2
246
247	SUBROUTINE get_var_r3(var_name,var,found)
248	IMPLICIT NONE
249	CHARACTER(LEN=*),INTENT(IN) :: var_name
250	REAL,INTENT(INOUT) :: var(:,:,:)
251	LOGICAL,OPTIONAL,INTENT(OUT) :: found
252
253	IF (PRESENT(found)) THEN
254	CALL Get_var_rgen(var_name,var,size(var),found)
255	ELSE
256	CALL Get_var_rgen(var_name,var,size(var))
257	ENDIF
258
259	END SUBROUTINE get_var_r3
260
261	SUBROUTINE Get_var_rgen(var_name,var,var_size,found)
262	USE netcdf
263	USE dimphy
264	USE mod_grid_phy_lmdz
265	USE mod_phys_lmdz_para
266	IMPLICIT NONE
267	CHARACTER(LEN=*) :: var_name
268	INTEGER :: var_size
269	REAL :: var(var_size)
270	LOGICAL,OPTIONAL :: found
271
272	LOGICAL :: tmp_found
273	INTEGER :: varid
274	INTEGER :: ierr
275
276	IF (is_mpi_root .AND. is_omp_root) THEN
277
278	ierr=NF90_INQ_VARID(nid_start,var_name,varid)
279
280	IF (ierr==NF90_NOERR) THEN
281	ierr=NF90_GET_VAR(nid_start,varid,var)
282	IF (ierr/=NF90_NOERR) THEN
283	PRINT*, 'phyetat0: Lecture echouee pour <'//var_name//'>'
284	call abort_physic("", "", 1)
285	ENDIF
286	tmp_found=.TRUE.
287	ELSE
288	tmp_found=.FALSE.
289	ENDIF
290
291	ENDIF
292
293	CALL bcast(tmp_found)
294
295	IF (tmp_found) THEN
296	CALL bcast(var)
297	ENDIF
298
299	IF (PRESENT(found)) THEN
300	found=tmp_found
301	ELSE
302	IF (.NOT. tmp_found) THEN
303	PRINT*, 'phyetat0: La variable champ <'//var_name//'> est absente'
304	call abort_physic("", "", 1)
305	ENDIF
306	ENDIF
307
308	END SUBROUTINE Get_var_rgen
309
310
311	SUBROUTINE open_restartphy(filename)
312	USE netcdf
313	USE mod_phys_lmdz_para
314	USE mod_grid_phy_lmdz
315	USE dimphy
316	IMPLICIT NONE
317	CHARACTER(LEN=*),INTENT(IN) :: filename
318	INTEGER :: ierr
319
320	IF (is_mpi_root .AND. is_omp_root) THEN
321	ierr = NF90_CREATE(filename, NF90_CLOBBER, nid_restart)
322	IF (ierr/=NF90_NOERR) THEN
323	write(6,*)' Pb d''ouverture du fichier '//filename
324	write(6,*)' ierr = ', ierr
325	CALL abort_physic("", "", 1)
326	ENDIF
327
328	ierr = NF90_PUT_ATT (nid_restart, NF90_GLOBAL, "title","Fichier redemmarage physique")
329
330	ierr = NF90_DEF_DIM (nid_restart, "index", length, idim1)
331	ierr = NF90_DEF_DIM (nid_restart, "points_physiques", klon_glo, idim2)
332	ierr = NF90_DEF_DIM (nid_restart, "horizon_vertical", klon_glo*klev, idim3)
333	ierr = NF90_DEF_DIM (nid_restart, "horizon_klevp1", klon_glo*klevp1, idim4)
334
335	ierr = NF90_ENDDEF(nid_restart)
336	ENDIF
337
338	END SUBROUTINE open_restartphy
339
340	SUBROUTINE close_restartphy
341	USE netcdf
342	USE mod_phys_lmdz_para
343	IMPLICIT NONE
344	INTEGER :: ierr
345
346	IF (is_mpi_root .AND. is_omp_root) THEN
347	ierr = NF90_CLOSE (nid_restart)
348	ENDIF
349
350	END SUBROUTINE close_restartphy
351
352
353	SUBROUTINE put_field_r1(field_name,title,field)
354	IMPLICIT NONE
355	CHARACTER(LEN=*),INTENT(IN) :: field_name
356	CHARACTER(LEN=*),INTENT(IN) :: title
357	REAL,INTENT(IN) :: field(:)
358
359	CALL put_field_rgen(field_name,title,field,1)
360
361	END SUBROUTINE put_field_r1
362
363	SUBROUTINE put_field_r2(field_name,title,field)
364	IMPLICIT NONE
365	CHARACTER(LEN=*),INTENT(IN) :: field_name
366	CHARACTER(LEN=*),INTENT(IN) :: title
367	REAL,INTENT(IN) :: field(:,:)
368
369	CALL put_field_rgen(field_name,title,field,size(field,2))
370
371	END SUBROUTINE put_field_r2
372
373	SUBROUTINE put_field_r3(field_name,title,field)
374	IMPLICIT NONE
375	CHARACTER(LEN=*),INTENT(IN) :: field_name
376	CHARACTER(LEN=*),INTENT(IN) :: title
377	REAL,INTENT(IN) :: field(:,:,:)
378
379	CALL put_field_rgen(field_name,title,field,size(field,2)*size(field,3))
380
381	END SUBROUTINE put_field_r3
382
383	SUBROUTINE put_field_rgen(field_name,title,field,field_size)
384	USE netcdf
385	USE dimphy
386	USE mod_grid_phy_lmdz
387	USE mod_phys_lmdz_para
388	IMPLICIT NONE
389	CHARACTER(LEN=*),INTENT(IN) :: field_name
390	CHARACTER(LEN=*),INTENT(IN) :: title
391	INTEGER,INTENT(IN) :: field_size
392	REAL,INTENT(IN) :: field(klon,field_size)
393
394	REAL :: field_glo(klon_glo,field_size)
395	INTEGER :: ierr
396	INTEGER :: nvarid
397	INTEGER :: idim
398
399
400	CALL gather(field,field_glo)
401
402	IF (is_mpi_root .AND. is_omp_root) THEN
403
404	IF (field_size==1) THEN
405	idim=idim2
406	ELSE IF (field_size==klev) THEN
407	idim=idim3
408	ELSE IF (field_size==klevp1) THEN
409	idim=idim4
410	ELSE
411	PRINT *, "erreur phyredem : probleme de dimension"
412	CALL abort_physic("", "", 1)
413	ENDIF
414
415	ierr = NF90_REDEF (nid_restart)
416	#ifdef NC_DOUBLE
417	ierr = NF90_DEF_VAR (nid_restart, field_name, NF90_DOUBLE,(/ idim /),nvarid)
418	#else
419	ierr = NF90_DEF_VAR (nid_restart, field_name, NF90_FLOAT,(/ idim /),nvarid)
420	#endif
421	IF (LEN_TRIM(title) > 0) ierr = NF90_PUT_ATT (nid_restart,nvarid,"title", title)
422	ierr = NF90_ENDDEF(nid_restart)
423	ierr = NF90_PUT_VAR(nid_restart,nvarid,RESHAPE(field_glo,(/klon_glo*field_size/)))
424	ENDIF
425
426	END SUBROUTINE put_field_rgen
427
428	SUBROUTINE put_var_r0(var_name,title,var)
429	IMPLICIT NONE
430	CHARACTER(LEN=*),INTENT(IN) :: var_name
431	CHARACTER(LEN=*),INTENT(IN) :: title
432	REAL,INTENT(IN) :: var
433	REAL :: varin(1)
434
435	varin(1)=var
436
437	CALL put_var_rgen(var_name,title,varin,size(varin))
438
439	END SUBROUTINE put_var_r0
440
441
442	SUBROUTINE put_var_r1(var_name,title,var)
443	IMPLICIT NONE
444	CHARACTER(LEN=*),INTENT(IN) :: var_name
445	CHARACTER(LEN=*),INTENT(IN) :: title
446	REAL,INTENT(IN) :: var(:)
447
448	CALL put_var_rgen(var_name,title,var,size(var))
449
450	END SUBROUTINE put_var_r1
451
452	SUBROUTINE put_var_r2(var_name,title,var)
453	IMPLICIT NONE
454	CHARACTER(LEN=*),INTENT(IN) :: var_name
455	CHARACTER(LEN=*),INTENT(IN) :: title
456	REAL,INTENT(IN) :: var(:,:)
457
458	CALL put_var_rgen(var_name,title,var,size(var))
459
460	END SUBROUTINE put_var_r2
461
462	SUBROUTINE put_var_r3(var_name,title,var)
463	IMPLICIT NONE
464	CHARACTER(LEN=*),INTENT(IN) :: var_name
465	CHARACTER(LEN=*),INTENT(IN) :: title
466	REAL,INTENT(IN) :: var(:,:,:)
467
468	CALL put_var_rgen(var_name,title,var,size(var))
469
470	END SUBROUTINE put_var_r3
471
472	SUBROUTINE put_var_rgen(var_name,title,var,var_size)
473	USE netcdf
474	USE dimphy
475	USE mod_phys_lmdz_para
476	IMPLICIT NONE
477	CHARACTER(LEN=*),INTENT(IN) :: var_name
478	CHARACTER(LEN=*),INTENT(IN) :: title
479	INTEGER,INTENT(IN) :: var_size
480	REAL,INTENT(IN) :: var(var_size)
481
482	INTEGER :: ierr
483	INTEGER :: nvarid
484
485	IF (is_mpi_root .AND. is_omp_root) THEN
486
487	IF (var_size/=length) THEN
488	PRINT *, "erreur phyredem : probleme de dimension"
489	call abort_physic("", "", 1)
490	ENDIF
491
492	ierr = NF90_REDEF (nid_restart)
493
494	#ifdef NC_DOUBLE
495	ierr = NF90_DEF_VAR (nid_restart, var_name, NF90_DOUBLE,(/ idim1 /),nvarid)
496	#else
497	ierr = NF90_DEF_VAR (nid_restart, var_name, NF90_FLOAT,(/ idim1 /),nvarid)
498	#endif
499	IF (LEN_TRIM(title)>0) ierr = NF90_PUT_ATT (nid_restart,nvarid,"title", title)
500	ierr = NF90_ENDDEF(nid_restart)
501
502	ierr = NF90_PUT_VAR(nid_restart,nvarid,var)
503
504	ENDIF
505
506	END SUBROUTINE put_var_rgen
507
508	END MODULE iostart

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

Download in other formats:

Original Format