My Project
 All Classes Files Functions Variables Macros
iostart.F90
Go to the documentation of this file.
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
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
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
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
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
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
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
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
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
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