Context Navigation

iostart.F90 @ 5123

Last change on this file since 5123 was 5116, checked in by abarral, 5 months ago
rename modules properly lmdz_* move ismin, ismax, minmax into new lmdz_libmath.f90 (lint) uppercase fortran keywords
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.7 KB

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

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

Download in other formats:

Original Format