source: LMDZ5/branches/testing/libf/phylmd/iostart.F90 @ 3069

Last change on this file since 3069 was 2408, checked in by Laurent Fairhead, 9 years ago

Merged trunk changes r2298:2396 into testing branch
  • 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: 13.6 KB
Line 
1MODULE iostart
2
3PRIVATE
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   
29CONTAINS
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   
508END MODULE iostart
Note: See TracBrowser for help on using the repository browser.