Context Navigation

iostart.F90 @ 5209

Last change on this file since 5209 was 5084, checked in by Laurent Fairhead, 4 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