Context Navigation

iostart.F90 @ 5207

Last change on this file since 5207 was 5084, checked in by Laurent Fairhead, 12 months ago
Reverting to r4065. Updating fortran standard broke too much stuff. Will do it by smaller chunks AB, LF
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: 15.4 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, enddef_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	CALL Get_field_rgen(field_name,field,1,found)
92
93	END SUBROUTINE Get_Field_r1
94
95	SUBROUTINE Get_Field_r2(field_name,field,found)
96	IMPLICIT NONE
97	CHARACTER(LEN=*),INTENT(IN) :: Field_name
98	REAL,INTENT(INOUT) :: Field(:,:)
99	LOGICAL,INTENT(OUT),OPTIONAL :: found
100
101	CALL Get_field_rgen(field_name,field,size(field,2),found)
102
103
104	END SUBROUTINE Get_Field_r2
105
106	SUBROUTINE Get_Field_r3(field_name,field,found)
107	IMPLICIT NONE
108	CHARACTER(LEN=*),INTENT(IN) :: Field_name
109	REAL,INTENT(INOUT) :: Field(:,:,:)
110	LOGICAL,INTENT(OUT),OPTIONAL :: found
111
112	CALL Get_field_rgen(field_name,field,size(field,2)*size(field,3),found)
113
114	END SUBROUTINE Get_Field_r3
115
116	SUBROUTINE Get_field_rgen(field_name,field,field_size,found)
117	USE netcdf
118	USE dimphy
119	USE geometry_mod
120	USE mod_grid_phy_lmdz
121	USE mod_phys_lmdz_para
122	IMPLICIT NONE
123	CHARACTER(LEN=*) :: Field_name
124	INTEGER :: field_size
125	REAL :: field(klon,field_size)
126	LOGICAL,OPTIONAL :: found
127
128	REAL,ALLOCATABLE :: field_glo(:,:)
129	REAL,ALLOCATABLE :: field_glo_tmp(:,:)
130	INTEGER,ALLOCATABLE :: ind_cell_glo_glo(:)
131	LOGICAL :: tmp_found
132	INTEGER :: varid
133	INTEGER :: ierr,i
134
135	IF (is_master) THEN
136	ALLOCATE(ind_cell_glo_glo(klon_glo))
137	ALLOCATE(field_glo(klon_glo,field_size))
138	ALLOCATE(field_glo_tmp(klon_glo,field_size))
139	ELSE
140	ALLOCATE(ind_cell_glo_glo(0))
141	ALLOCATE(field_glo(0,0))
142	ENDIF
143
144	CALL gather(ind_cell_glo,ind_cell_glo_glo)
145
146	IF (is_master) THEN
147
148	ierr=NF90_INQ_VARID(nid_start,Field_name,varid)
149
150	IF (ierr==NF90_NOERR) THEN
151	CALL body(field_glo_tmp)
152	tmp_found=.TRUE.
153	ELSE
154	tmp_found=.FALSE.
155	ENDIF
156
157	ENDIF
158
159	CALL bcast(tmp_found)
160
161	IF (tmp_found) THEN
162	IF (is_master) THEN
163	DO i=1,klon_glo
164	field_glo(i,:)=field_glo_tmp(ind_cell_glo_glo(i),:)
165	ENDDO
166	ENDIF
167	CALL scatter(field_glo,field)
168	ENDIF
169
170	IF (PRESENT(found)) THEN
171	found=tmp_found
172	ELSE
173	IF (.NOT. tmp_found) THEN
174	PRINT*, 'phyetat0: Le champ <'//field_name//'> est absent'
175	call abort_physic("", "", 1)
176	ENDIF
177	ENDIF
178
179
180	CONTAINS
181
182	SUBROUTINE body(field_glo)
183	REAL :: field_glo(klon_glo*field_size)
184	ierr=NF90_GET_VAR(nid_start,varid,field_glo)
185	IF (ierr/=NF90_NOERR) THEN
186	! La variable exist dans le fichier mais la lecture a echouee.
187	PRINT*, 'phyetat0: Lecture echouee pour <'//field_name//'>'
188
189	IF (field_name=='CLWCON' .OR. field_name=='RNEBCON' .OR. field_name=='RATQS') THEN
190	! Essaye de lire le variable sur surface uniqument, comme fait avant
191	field_glo(:)=0.
192	ierr=NF90_GET_VAR(nid_start,varid,field_glo(1:klon_glo))
193	IF (ierr/=NF90_NOERR) THEN
194	PRINT*, 'phyetat0: Lecture echouee aussi en 2D pour <'//field_name//'>'
195	call abort_physic("", "", 1)
196	ELSE
197	PRINT*, 'phyetat0: La variable <'//field_name//'> lu sur surface seulement'!, selon ancien format, le reste mis a zero'
198	END IF
199	ELSE
200	call abort_physic("", "", 1)
201	ENDIF
202	ENDIF
203
204	END SUBROUTINE body
205
206	END SUBROUTINE Get_field_rgen
207
208
209	SUBROUTINE get_var_r0(var_name,var,found)
210	IMPLICIT NONE
211	CHARACTER(LEN=*),INTENT(IN) :: var_name
212	REAL,INTENT(INOUT) :: var
213	LOGICAL,OPTIONAL,INTENT(OUT) :: found
214
215	REAL :: varout(1)
216
217	CALL Get_var_rgen(var_name,varout,size(varout),found)
218	var=varout(1)
219
220	END SUBROUTINE get_var_r0
221
222	SUBROUTINE get_var_r1(var_name,var,found)
223	IMPLICIT NONE
224	CHARACTER(LEN=*),INTENT(IN) :: var_name
225	REAL,INTENT(INOUT) :: var(:)
226	LOGICAL,OPTIONAL,INTENT(OUT) :: found
227
228	CALL Get_var_rgen(var_name,var,size(var),found)
229
230	END SUBROUTINE get_var_r1
231
232	SUBROUTINE get_var_r2(var_name,var,found)
233	IMPLICIT NONE
234	CHARACTER(LEN=*),INTENT(IN) :: var_name
235	REAL,INTENT(OUT) :: var(:,:)
236	LOGICAL,OPTIONAL,INTENT(OUT) :: found
237
238	CALL Get_var_rgen(var_name,var,size(var),found)
239
240	END SUBROUTINE get_var_r2
241
242	SUBROUTINE get_var_r3(var_name,var,found)
243	IMPLICIT NONE
244	CHARACTER(LEN=*),INTENT(IN) :: var_name
245	REAL,INTENT(INOUT) :: var(:,:,:)
246	LOGICAL,OPTIONAL,INTENT(OUT) :: found
247
248	CALL Get_var_rgen(var_name,var,size(var),found)
249
250	END SUBROUTINE get_var_r3
251
252	SUBROUTINE Get_var_rgen(var_name,var,var_size,found)
253	USE netcdf
254	USE dimphy
255	USE mod_grid_phy_lmdz
256	USE mod_phys_lmdz_para
257	IMPLICIT NONE
258	CHARACTER(LEN=*) :: var_name
259	INTEGER :: var_size
260	REAL :: var(var_size)
261	LOGICAL,OPTIONAL :: found
262
263	LOGICAL :: tmp_found
264	INTEGER :: varid
265	INTEGER :: ierr
266
267	IF (is_mpi_root .AND. is_omp_root) THEN
268
269	ierr=NF90_INQ_VARID(nid_start,var_name,varid)
270
271	IF (ierr==NF90_NOERR) THEN
272	ierr=NF90_GET_VAR(nid_start,varid,var)
273	IF (ierr/=NF90_NOERR) THEN
274	PRINT*, 'phyetat0: Lecture echouee pour <'//var_name//'>'
275	call abort_physic("", "", 1)
276	ENDIF
277	tmp_found=.TRUE.
278	ELSE
279	tmp_found=.FALSE.
280	ENDIF
281
282	ENDIF
283
284	CALL bcast(tmp_found)
285
286	IF (tmp_found) THEN
287	CALL bcast(var)
288	ENDIF
289
290	IF (PRESENT(found)) THEN
291	found=tmp_found
292	ELSE
293	IF (.NOT. tmp_found) THEN
294	PRINT*, 'phyetat0: La variable champ <'//var_name//'> est absente'
295	call abort_physic("", "", 1)
296	ENDIF
297	ENDIF
298
299	END SUBROUTINE Get_var_rgen
300
301
302	SUBROUTINE open_restartphy(filename)
303	USE netcdf
304	USE mod_phys_lmdz_para, ONLY: is_master
305	USE mod_grid_phy_lmdz, ONLY: klon_glo
306	USE dimphy, ONLY: klev, klevp1
307	USE print_control_mod, ONLY: lunout
308	IMPLICIT NONE
309	CHARACTER(LEN=*),INTENT(IN) :: filename
310	INTEGER :: ierr
311
312	IF (is_master) THEN
313	ierr = NF90_CREATE(filename, IOR(NF90_CLOBBER,NF90_64BIT_OFFSET), &
314	nid_restart)
315	IF (ierr/=NF90_NOERR) THEN
316	write(lunout,*)'open_restartphy: problem creating file '//trim(filename)
317	write(lunout,*)trim(nf90_strerror(ierr))
318	CALL abort_physic("open_restartphy", trim(nf90_strerror(ierr)), 1)
319	ENDIF
320
321	ierr = NF90_PUT_ATT (nid_restart, NF90_GLOBAL, "title","Fichier redemmarage physique")
322
323	ierr = NF90_DEF_DIM (nid_restart, "index", length, idim1)
324	ierr = NF90_DEF_DIM (nid_restart, "points_physiques", klon_glo, idim2)
325	ierr = NF90_DEF_DIM (nid_restart, "horizon_vertical", klon_glo*klev, idim3)
326	ierr = NF90_DEF_DIM (nid_restart, "horizon_klevp1", klon_glo*klevp1, idim4)
327
328	! ierr = NF90_ENDDEF(nid_restart)
329	ENDIF
330
331	END SUBROUTINE open_restartphy
332
333	SUBROUTINE enddef_restartphy
334	USE netcdf
335	USE mod_phys_lmdz_para
336	IMPLICIT NONE
337	INTEGER :: ierr
338
339	IF (is_master) ierr = NF90_ENDDEF(nid_restart)
340
341	END SUBROUTINE enddef_restartphy
342
343	SUBROUTINE close_restartphy
344	USE netcdf
345	USE mod_phys_lmdz_para
346	IMPLICIT NONE
347	INTEGER :: ierr
348
349	IF (is_master) ierr = NF90_CLOSE (nid_restart)
350
351	END SUBROUTINE close_restartphy
352
353
354	SUBROUTINE put_field_r1(pass, field_name,title,field)
355	IMPLICIT NONE
356	INTEGER, INTENT(IN) :: pass
357	CHARACTER(LEN=*),INTENT(IN) :: field_name
358	CHARACTER(LEN=*),INTENT(IN) :: title
359	REAL,INTENT(IN) :: field(:)
360	CALL put_field_rgen(pass, field_name,title,field,1)
361
362	END SUBROUTINE put_field_r1
363
364	SUBROUTINE put_field_r2(pass, field_name,title,field)
365	IMPLICIT NONE
366	INTEGER, INTENT(IN) :: pass
367	CHARACTER(LEN=*),INTENT(IN) :: field_name
368	CHARACTER(LEN=*),INTENT(IN) :: title
369	REAL,INTENT(IN) :: field(:,:)
370
371	CALL put_field_rgen(pass, field_name,title,field,size(field,2))
372
373	END SUBROUTINE put_field_r2
374
375	SUBROUTINE put_field_r3(pass, field_name,title,field)
376	IMPLICIT NONE
377	INTEGER, INTENT(IN) :: pass
378	CHARACTER(LEN=*),INTENT(IN) :: field_name
379	CHARACTER(LEN=*),INTENT(IN) :: title
380	REAL,INTENT(IN) :: field(:,:,:)
381
382	CALL put_field_rgen(pass, field_name,title,field,size(field,2)*size(field,3))
383
384	END SUBROUTINE put_field_r3
385
386	SUBROUTINE put_field_rgen(pass, field_name,title,field,field_size)
387	USE netcdf
388	USE dimphy
389	USE geometry_mod
390	USE mod_grid_phy_lmdz
391	USE mod_phys_lmdz_para
392	IMPLICIT NONE
393	INTEGER, INTENT(IN) :: pass
394	CHARACTER(LEN=*),INTENT(IN) :: field_name
395	CHARACTER(LEN=*),INTENT(IN) :: title
396	INTEGER,INTENT(IN) :: field_size
397	REAL,INTENT(IN) :: field(klon,field_size)
398
399	! REAL :: field_glo(klon_glo,field_size)
400	! REAL :: field_glo_tmp(klon_glo,field_size)
401	REAL ,ALLOCATABLE :: field_glo(:,:)
402	REAL ,ALLOCATABLE :: field_glo_tmp(:,:)
403	INTEGER,ALLOCATABLE :: ind_cell_glo_glo(:)
404	! INTEGER :: ind_cell_glo_glo(klon_glo)
405	INTEGER :: ierr,i
406	INTEGER :: nvarid
407	INTEGER :: idim
408
409	! first pass : definition
410	IF (pass==1) THEN
411
412	IF (is_master) THEN
413
414	IF (field_size==1) THEN
415	idim=idim2
416	ELSE IF (field_size==klev) THEN
417	idim=idim3
418	ELSE IF (field_size==klevp1) THEN
419	idim=idim4
420	ELSE
421	PRINT *, "erreur phyredem : probleme de dimension"
422	CALL abort_physic("", "", 1)
423	ENDIF
424
425	! ierr = NF90_REDEF (nid_restart)
426	#ifdef NC_DOUBLE
427	ierr = NF90_DEF_VAR (nid_restart, field_name, NF90_DOUBLE,(/ idim /),nvarid)
428	#else
429	ierr = NF90_DEF_VAR (nid_restart, field_name, NF90_FLOAT,(/ idim /),nvarid)
430	#endif
431	IF (LEN_TRIM(title) > 0) ierr = NF90_PUT_ATT (nid_restart,nvarid,"title", title)
432	! ierr = NF90_ENDDEF(nid_restart)
433	ENDIF
434
435	! second pass : write
436	ELSE IF (pass==2) THEN
437
438	IF (is_master) THEN
439	ALLOCATE(ind_cell_glo_glo(klon_glo))
440	ALLOCATE(field_glo(klon_glo,field_size))
441	ALLOCATE(field_glo_tmp(klon_glo,field_size))
442	ELSE
443	ALLOCATE(ind_cell_glo_glo(0))
444	ALLOCATE(field_glo_tmp(0,0))
445	ENDIF
446
447	CALL gather(ind_cell_glo,ind_cell_glo_glo)
448
449	CALL gather(field,field_glo_tmp)
450
451	IF (is_master) THEN
452
453	DO i=1,klon_glo
454	field_glo(ind_cell_glo_glo(i),:)=field_glo_tmp(i,:)
455	ENDDO
456
457	ierr = NF90_INQ_VARID(nid_restart, field_name, nvarid)
458	ierr = NF90_PUT_VAR(nid_restart,nvarid,RESHAPE(field_glo,(/klon_glo*field_size/)))
459	ENDIF
460	ENDIF
461
462	END SUBROUTINE put_field_rgen
463
464
465	SUBROUTINE put_var_r0(pass, var_name,title,var)
466	IMPLICIT NONE
467	INTEGER, INTENT(IN) :: pass
468	CHARACTER(LEN=*),INTENT(IN) :: var_name
469	CHARACTER(LEN=*),INTENT(IN) :: title
470	REAL,INTENT(IN) :: var
471	REAL :: varin(1)
472
473	varin(1)=var
474
475	CALL put_var_rgen(pass, var_name,title,varin,size(varin))
476
477	END SUBROUTINE put_var_r0
478
479
480	SUBROUTINE put_var_r1(pass, var_name,title,var)
481	IMPLICIT NONE
482	INTEGER, INTENT(IN) :: pass
483	CHARACTER(LEN=*),INTENT(IN) :: var_name
484	CHARACTER(LEN=*),INTENT(IN) :: title
485	REAL,INTENT(IN) :: var(:)
486
487	CALL put_var_rgen(pass, var_name,title,var,size(var))
488
489	END SUBROUTINE put_var_r1
490
491	SUBROUTINE put_var_r2(pass, var_name,title,var)
492	IMPLICIT NONE
493	INTEGER, INTENT(IN) :: pass
494	CHARACTER(LEN=*),INTENT(IN) :: var_name
495	CHARACTER(LEN=*),INTENT(IN) :: title
496	REAL,INTENT(IN) :: var(:,:)
497
498	CALL put_var_rgen(pass, var_name,title,var,size(var))
499
500	END SUBROUTINE put_var_r2
501
502	SUBROUTINE put_var_r3(pass, var_name,title,var)
503	IMPLICIT NONE
504	INTEGER, INTENT(IN) :: pass
505	CHARACTER(LEN=*),INTENT(IN) :: var_name
506	CHARACTER(LEN=*),INTENT(IN) :: title
507	REAL,INTENT(IN) :: var(:,:,:)
508
509	CALL put_var_rgen(pass, var_name,title,var,size(var))
510
511	END SUBROUTINE put_var_r3
512
513	SUBROUTINE put_var_rgen(pass, var_name,title,var,var_size)
514	USE netcdf
515	USE dimphy
516	USE mod_phys_lmdz_para
517	IMPLICIT NONE
518	INTEGER, INTENT(IN) :: pass
519	CHARACTER(LEN=*),INTENT(IN) :: var_name
520	CHARACTER(LEN=*),INTENT(IN) :: title
521	INTEGER,INTENT(IN) :: var_size
522	REAL,INTENT(IN) :: var(var_size)
523
524	INTEGER :: ierr
525	INTEGER :: nvarid
526
527	IF (is_master) THEN
528
529	IF (var_size/=length) THEN
530	PRINT *, "erreur phyredem : probleme de dimension"
531	call abort_physic("", "", 1)
532	ENDIF
533
534	! first pass : definition
535	IF (pass==1) THEN
536
537	! ierr = NF90_REDEF (nid_restart)
538
539	#ifdef NC_DOUBLE
540	ierr = NF90_DEF_VAR (nid_restart, var_name, NF90_DOUBLE,(/ idim1 /),nvarid)
541	#else
542	ierr = NF90_DEF_VAR (nid_restart, var_name, NF90_FLOAT,(/ idim1 /),nvarid)
543	#endif
544	IF (LEN_TRIM(title)>0) ierr = NF90_PUT_ATT (nid_restart,nvarid,"title", title)
545	! ierr = NF90_ENDDEF(nid_restart)
546
547	! second pass : write
548	ELSE IF (pass==2) THEN
549	ierr = NF90_INQ_VARID(nid_restart, var_name, nvarid)
550	ierr = NF90_PUT_VAR(nid_restart,nvarid,var)
551	ENDIF
552	ENDIF
553
554	END SUBROUTINE put_var_rgen
555
556	END MODULE iostart

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

Download in other formats:

Original Format