source: LMDZ6/branches/DYNAMICO-conv/libf/phylmd/iostart.F90 @ 3405

Last change on this file since 3405 was 3356, checked in by Laurent Fairhead, 6 years ago

First attempt at merging with trunk
  • 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    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    :: field_glo(klon_glo,field_size)
129    REAL    :: field_glo_tmp(klon_glo,field_size)
130    INTEGER :: ind_cell_glo_glo(klon_glo)
131    LOGICAL :: tmp_found
132    INTEGER :: varid
133    INTEGER :: ierr,i
134
135!    IF (is_master) ALLOCATE(ind_cell_glo_glo(1:klon_glo))
136    CALL gather(ind_cell_glo,ind_cell_glo_glo)
137   
138    IF (is_master) THEN
139 
140      ierr=NF90_INQ_VARID(nid_start,Field_name,varid)
141     
142      IF (ierr==NF90_NOERR) THEN
143        CALL body(field_glo_tmp)
144        tmp_found=.TRUE.
145      ELSE
146        tmp_found=.FALSE.
147      ENDIF
148   
149    ENDIF
150   
151    CALL bcast(tmp_found)
152
153    IF (tmp_found) THEN
154      IF (is_master) THEN 
155        DO i=1,klon_glo
156         field_glo(i,:)=field_glo_tmp(ind_cell_glo_glo(i),:)
157        ENDDO
158      ENDIF
159      CALL scatter(field_glo,field)
160    ENDIF
161   
162    IF (PRESENT(found)) THEN
163      found=tmp_found
164    ELSE
165      IF (.NOT. tmp_found) THEN
166        PRINT*, 'phyetat0: Le champ <'//field_name//'> est absent'
167        call abort_physic("", "", 1)
168      ENDIF
169    ENDIF
170 
171   
172    CONTAINS
173     
174     SUBROUTINE body(field_glo)
175       REAL :: field_glo(klon_glo*field_size)
176         ierr=NF90_GET_VAR(nid_start,varid,field_glo)
177         IF (ierr/=NF90_NOERR) THEN
178           ! La variable exist dans le fichier mais la lecture a echouee.
179           PRINT*, 'phyetat0: Lecture echouee pour <'//field_name//'>'
180
181           IF (field_name=='CLWCON' .OR. field_name=='RNEBCON' .OR. field_name=='RATQS') THEN
182              ! Essaye de lire le variable sur surface uniqument, comme fait avant
183              field_glo(:)=0.
184              ierr=NF90_GET_VAR(nid_start,varid,field_glo(1:klon_glo))
185              IF (ierr/=NF90_NOERR) THEN
186                 PRINT*, 'phyetat0: Lecture echouee aussi en 2D pour <'//field_name//'>'
187                 call abort_physic("", "", 1)
188              ELSE
189                 PRINT*, 'phyetat0: La variable <'//field_name//'> lu sur surface seulement'!, selon ancien format, le reste mis a zero'
190              END IF
191           ELSE
192              call abort_physic("", "", 1)
193           ENDIF
194         ENDIF
195
196     END SUBROUTINE body
197
198  END SUBROUTINE Get_field_rgen
199 
200
201  SUBROUTINE get_var_r0(var_name,var,found)
202  IMPLICIT NONE 
203    CHARACTER(LEN=*),INTENT(IN)  :: var_name
204    REAL,INTENT(INOUT)             :: var
205    LOGICAL,OPTIONAL,INTENT(OUT) :: found
206
207    REAL                         :: varout(1)
208   
209    CALL Get_var_rgen(var_name,varout,size(varout),found)
210    var=varout(1)
211 
212  END SUBROUTINE get_var_r0
213
214  SUBROUTINE get_var_r1(var_name,var,found)
215  IMPLICIT NONE 
216    CHARACTER(LEN=*),INTENT(IN)  :: var_name
217    REAL,INTENT(INOUT)             :: var(:)
218    LOGICAL,OPTIONAL,INTENT(OUT) :: found
219   
220    CALL Get_var_rgen(var_name,var,size(var),found)
221 
222  END SUBROUTINE get_var_r1
223
224  SUBROUTINE get_var_r2(var_name,var,found)
225  IMPLICIT NONE 
226    CHARACTER(LEN=*),INTENT(IN)  :: var_name
227    REAL,INTENT(OUT)             :: var(:,:)
228    LOGICAL,OPTIONAL,INTENT(OUT) :: found
229   
230    CALL Get_var_rgen(var_name,var,size(var),found)
231 
232  END SUBROUTINE get_var_r2
233
234  SUBROUTINE get_var_r3(var_name,var,found)
235  IMPLICIT NONE 
236    CHARACTER(LEN=*),INTENT(IN)  :: var_name
237    REAL,INTENT(INOUT)             :: var(:,:,:)
238    LOGICAL,OPTIONAL,INTENT(OUT) :: found
239   
240    CALL Get_var_rgen(var_name,var,size(var),found)
241 
242  END SUBROUTINE get_var_r3
243
244  SUBROUTINE Get_var_rgen(var_name,var,var_size,found)
245  USE netcdf
246  USE dimphy
247  USE mod_grid_phy_lmdz
248  USE mod_phys_lmdz_para
249  IMPLICIT NONE
250    CHARACTER(LEN=*) :: var_name
251    INTEGER          :: var_size
252    REAL             :: var(var_size)
253    LOGICAL,OPTIONAL :: found
254   
255    LOGICAL :: tmp_found
256    INTEGER :: varid
257    INTEGER :: ierr
258   
259    IF (is_mpi_root .AND. is_omp_root) THEN
260 
261      ierr=NF90_INQ_VARID(nid_start,var_name,varid)
262     
263      IF (ierr==NF90_NOERR) THEN
264        ierr=NF90_GET_VAR(nid_start,varid,var)
265        IF (ierr/=NF90_NOERR) THEN
266          PRINT*, 'phyetat0: Lecture echouee pour <'//var_name//'>'
267          call abort_physic("", "", 1)
268        ENDIF
269        tmp_found=.TRUE.
270      ELSE
271        tmp_found=.FALSE.
272      ENDIF
273   
274    ENDIF
275   
276    CALL bcast(tmp_found)
277
278    IF (tmp_found) THEN
279      CALL bcast(var)
280    ENDIF
281   
282    IF (PRESENT(found)) THEN
283      found=tmp_found
284    ELSE
285      IF (.NOT. tmp_found) THEN
286        PRINT*, 'phyetat0: La variable champ <'//var_name//'> est absente'
287        call abort_physic("", "", 1)
288      ENDIF
289    ENDIF
290
291  END SUBROUTINE Get_var_rgen
292
293
294  SUBROUTINE open_restartphy(filename)
295  USE netcdf
296  USE mod_phys_lmdz_para
297  USE mod_grid_phy_lmdz
298  USE dimphy
299  IMPLICIT NONE
300    CHARACTER(LEN=*),INTENT(IN) :: filename
301    INTEGER                     :: ierr
302   
303    IF (is_mpi_root .AND. is_omp_root) THEN
304      ierr = NF90_CREATE(filename, NF90_CLOBBER, nid_restart)
305      IF (ierr/=NF90_NOERR) THEN
306        write(6,*)' Pb d''ouverture du fichier '//filename
307        write(6,*)' ierr = ', ierr
308        CALL abort_physic("", "", 1)
309      ENDIF
310
311      ierr = NF90_PUT_ATT (nid_restart, NF90_GLOBAL, "title","Fichier redemmarage physique")
312
313      ierr = NF90_DEF_DIM (nid_restart, "index", length, idim1)
314      ierr = NF90_DEF_DIM (nid_restart, "points_physiques", klon_glo, idim2)
315      ierr = NF90_DEF_DIM (nid_restart, "horizon_vertical", klon_glo*klev, idim3)
316      ierr = NF90_DEF_DIM (nid_restart, "horizon_klevp1", klon_glo*klevp1, idim4)
317
318      ierr = NF90_ENDDEF(nid_restart)
319    ENDIF
320
321  END SUBROUTINE open_restartphy
322 
323  SUBROUTINE close_restartphy
324  USE netcdf
325  USE mod_phys_lmdz_para
326  IMPLICIT NONE
327    INTEGER          :: ierr
328
329    IF (is_mpi_root .AND. is_omp_root) THEN
330      ierr = NF90_CLOSE (nid_restart)
331    ENDIF
332 
333  END SUBROUTINE close_restartphy
334
335 
336  SUBROUTINE put_field_r1(field_name,title,field)
337  IMPLICIT NONE
338  CHARACTER(LEN=*),INTENT(IN)    :: field_name
339  CHARACTER(LEN=*),INTENT(IN)    :: title
340  REAL,INTENT(IN)                :: field(:)
341 
342    CALL put_field_rgen(field_name,title,field,1)
343 
344  END SUBROUTINE put_field_r1
345
346  SUBROUTINE put_field_r2(field_name,title,field)
347  IMPLICIT NONE
348  CHARACTER(LEN=*),INTENT(IN)    :: field_name
349  CHARACTER(LEN=*),INTENT(IN)    :: title
350  REAL,INTENT(IN)                :: field(:,:)
351 
352    CALL put_field_rgen(field_name,title,field,size(field,2))
353 
354  END SUBROUTINE put_field_r2
355
356  SUBROUTINE put_field_r3(field_name,title,field)
357  IMPLICIT NONE
358  CHARACTER(LEN=*),INTENT(IN)    :: field_name
359  CHARACTER(LEN=*),INTENT(IN)    :: title
360  REAL,INTENT(IN)                :: field(:,:,:)
361 
362    CALL put_field_rgen(field_name,title,field,size(field,2)*size(field,3))
363 
364  END SUBROUTINE put_field_r3
365 
366  SUBROUTINE put_field_rgen(field_name,title,field,field_size)
367  USE netcdf
368  USE dimphy
369  USE geometry_mod
370  USE mod_grid_phy_lmdz
371  USE mod_phys_lmdz_para
372  IMPLICIT NONE
373  CHARACTER(LEN=*),INTENT(IN)    :: field_name
374  CHARACTER(LEN=*),INTENT(IN)    :: title
375  INTEGER,INTENT(IN)             :: field_size
376  REAL,INTENT(IN)                :: field(klon,field_size)
377 
378  REAL                           :: field_glo(klon_glo,field_size)
379  REAL                           :: field_glo_tmp(klon_glo,field_size)
380!  INTEGER,ALLOCATABLE            :: ind_cell_glo_glo(:)
381  INTEGER                        :: ind_cell_glo_glo(klon_glo)
382  INTEGER                        :: ierr,i
383  INTEGER                        :: nvarid
384  INTEGER                        :: idim
385   
386   
387!    IF (is_master) ALLOCATE(ind_cell_glo_glo(klon_glo))
388    CALL gather(ind_cell_glo,ind_cell_glo_glo)
389
390    CALL gather(field,field_glo_tmp)
391   
392    IF (is_master) THEN
393
394      DO i=1,klon_glo
395       field_glo(ind_cell_glo_glo(i),:)=field_glo_tmp(i,:)
396      ENDDO
397
398
399      IF (field_size==1) THEN
400        idim=idim2
401      ELSE IF (field_size==klev) THEN
402        idim=idim3
403      ELSE IF (field_size==klevp1) THEN
404        idim=idim4
405      ELSE
406        PRINT *, "erreur phyredem : probleme de dimension"
407        CALL abort_physic("", "", 1)
408      ENDIF
409         
410      ierr = NF90_REDEF (nid_restart)
411#ifdef NC_DOUBLE
412      ierr = NF90_DEF_VAR (nid_restart, field_name, NF90_DOUBLE,(/ idim /),nvarid)
413#else
414      ierr = NF90_DEF_VAR (nid_restart, field_name, NF90_FLOAT,(/ idim /),nvarid)
415#endif
416      IF (LEN_TRIM(title) > 0) ierr = NF90_PUT_ATT (nid_restart,nvarid,"title", title)
417      ierr = NF90_ENDDEF(nid_restart)
418      ierr = NF90_PUT_VAR(nid_restart,nvarid,RESHAPE(field_glo,(/klon_glo*field_size/)))
419    ENDIF
420   
421   END SUBROUTINE put_field_rgen 
422 
423   SUBROUTINE put_var_r0(var_name,title,var)
424   IMPLICIT NONE
425     CHARACTER(LEN=*),INTENT(IN) :: var_name
426     CHARACTER(LEN=*),INTENT(IN) :: title
427     REAL,INTENT(IN)             :: var
428     REAL                        :: varin(1)
429     
430     varin(1)=var
431     
432     CALL put_var_rgen(var_name,title,varin,size(varin))
433
434  END SUBROUTINE put_var_r0
435
436
437   SUBROUTINE put_var_r1(var_name,title,var)
438   IMPLICIT NONE
439     CHARACTER(LEN=*),INTENT(IN) :: var_name
440     CHARACTER(LEN=*),INTENT(IN) :: title
441     REAL,INTENT(IN)             :: var(:)
442     
443     CALL put_var_rgen(var_name,title,var,size(var))
444
445  END SUBROUTINE put_var_r1
446 
447  SUBROUTINE put_var_r2(var_name,title,var)
448   IMPLICIT NONE
449     CHARACTER(LEN=*),INTENT(IN) :: var_name
450     CHARACTER(LEN=*),INTENT(IN) :: title
451     REAL,INTENT(IN)             :: var(:,:)
452     
453     CALL put_var_rgen(var_name,title,var,size(var))
454
455  END SUBROUTINE put_var_r2     
456 
457  SUBROUTINE put_var_r3(var_name,title,var)
458   IMPLICIT NONE
459     CHARACTER(LEN=*),INTENT(IN) :: var_name
460     CHARACTER(LEN=*),INTENT(IN) :: title
461     REAL,INTENT(IN)             :: var(:,:,:)
462     
463     CALL put_var_rgen(var_name,title,var,size(var))
464
465  END SUBROUTINE put_var_r3
466
467  SUBROUTINE put_var_rgen(var_name,title,var,var_size)
468  USE netcdf
469  USE dimphy
470  USE mod_phys_lmdz_para
471  IMPLICIT NONE
472     CHARACTER(LEN=*),INTENT(IN) :: var_name
473     CHARACTER(LEN=*),INTENT(IN) :: title
474     INTEGER,INTENT(IN)          :: var_size
475     REAL,INTENT(IN)             :: var(var_size)
476     
477     INTEGER :: ierr
478     INTEGER :: nvarid
479         
480    IF (is_mpi_root .AND. is_omp_root) THEN
481
482      IF (var_size/=length) THEN
483        PRINT *, "erreur phyredem : probleme de dimension"
484        call abort_physic("", "", 1)
485      ENDIF
486     
487      ierr = NF90_REDEF (nid_restart)
488
489#ifdef NC_DOUBLE
490      ierr = NF90_DEF_VAR (nid_restart, var_name, NF90_DOUBLE,(/ idim1 /),nvarid)
491#else
492      ierr = NF90_DEF_VAR (nid_restart, var_name, NF90_FLOAT,(/ idim1 /),nvarid)
493#endif
494      IF (LEN_TRIM(title)>0) ierr = NF90_PUT_ATT (nid_restart,nvarid,"title", title)
495      ierr = NF90_ENDDEF(nid_restart)
496     
497      ierr = NF90_PUT_VAR(nid_restart,nvarid,var)
498
499    ENDIF
500   
501  END SUBROUTINE put_var_rgen     
502   
503END MODULE iostart
Note: See TracBrowser for help on using the repository browser.