source: trunk/LMDZ.UNIVERSAL/libf/phygeneric/iostart.F90 @ 1133

Last change on this file since 1133 was 907, checked in by emillour, 12 years ago

Generic/common/universal models:

  • Added possibility to write restartfi.nc files in parallel (MPI)
  • Added arch files suitable for Ada (IDRIS supercomputer)
  • Some further cleanup is clearly required to merge generic/universal models
  • LMDZ.UNIVERSAL/libf/phygeneric/dimphy.F90 to be uptaded in following commit (can't both remove a symbolic link and create a file with the same name in a single commit with svn).

EM
File size: 16.2 KB
Line 
1MODULE iostart
2
3PRIVATE
4    INTEGER,SAVE :: nid_start
5    INTEGER,SAVE :: nid_restart
6   
7    INTEGER,SAVE :: idim1,idim2,idim3,idim4,idim5,idim6
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
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  USE infotrac, only: nqtot
317  IMPLICIT NONE
318    CHARACTER(LEN=*),INTENT(IN) :: filename
319    INTEGER                     :: ierr
320   
321    IF (is_mpi_root .AND. is_omp_root) THEN
322      ierr = NF90_CREATE(filename, NF90_CLOBBER, nid_restart)
323      IF (ierr/=NF90_NOERR) THEN
324        write(6,*)' Pb d''ouverture du fichier '//filename
325        write(6,*)' ierr = ', ierr
326        CALL ABORT
327      ENDIF
328
329      ierr = NF90_PUT_ATT (nid_restart, NF90_GLOBAL, "title","Physics start file")
330
331      ierr = NF90_DEF_DIM (nid_restart, "index", length, idim1)
332      ierr = NF90_DEF_DIM (nid_restart, "physical_points", klon_glo, idim2)
333      ierr = NF90_DEF_DIM (nid_restart, "subsurface_layers", nsoil, idim3)
334      ierr = NF90_DEF_DIM (nid_restart, "nlayer_plus_1",klevp1, idim4)
335      ierr = NF90_DEF_DIM (nid_restart, "number_of_advected_fields",nqtot, idim5)
336      ierr = NF90_DEF_DIM (nid_restart, "nlayer",klev, idim6)
337
338      ierr = NF90_ENDDEF(nid_restart)
339    ENDIF
340
341  END SUBROUTINE open_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_mpi_root .AND. is_omp_root) THEN
350      ierr = NF90_CLOSE (nid_restart)
351    ENDIF
352 
353  END SUBROUTINE close_restartphy
354
355 
356  SUBROUTINE put_field_r1(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,1)
363 
364  END SUBROUTINE put_field_r1
365
366  SUBROUTINE put_field_r2(field_name,title,field)
367  IMPLICIT NONE
368  CHARACTER(LEN=*),INTENT(IN)    :: field_name
369  CHARACTER(LEN=*),INTENT(IN)    :: title
370  REAL,INTENT(IN)                :: field(:,:)
371 
372    CALL put_field_rgen(field_name,title,field,size(field,2))
373 
374  END SUBROUTINE put_field_r2
375
376  SUBROUTINE put_field_r3(field_name,title,field)
377  IMPLICIT NONE
378  CHARACTER(LEN=*),INTENT(IN)    :: field_name
379  CHARACTER(LEN=*),INTENT(IN)    :: title
380  REAL,INTENT(IN)                :: field(:,:,:)
381 
382    CALL put_field_rgen(field_name,title,field,size(field,2)*size(field,3))
383 
384  END SUBROUTINE put_field_r3
385 
386  SUBROUTINE put_field_rgen(field_name,title,field,field_size)
387  USE netcdf
388  USE dimphy
389  USE mod_grid_phy_lmdz
390  USE mod_phys_lmdz_para
391  IMPLICIT NONE
392  CHARACTER(LEN=*),INTENT(IN)    :: field_name
393  CHARACTER(LEN=*),INTENT(IN)    :: title
394  INTEGER,INTENT(IN)             :: field_size
395  REAL,INTENT(IN)                :: field(klon,field_size)
396 
397  REAL                           :: field_glo(klon_glo,field_size)
398  INTEGER                        :: ierr
399  INTEGER                        :: nvarid
400  INTEGER                        :: idim
401   
402   
403    CALL gather(field,field_glo)
404   
405    IF (is_mpi_root .AND. is_omp_root) THEN
406
407      IF (field_size==1) THEN
408        ! input is a 1D "surface field" array
409!        idim=idim2
410        ierr = NF90_REDEF (nid_restart)
411#ifdef NC_DOUBLE
412        ierr = NF90_DEF_VAR (nid_restart, field_name, NF90_DOUBLE,(/ idim2 /),nvarid)
413#else
414        ierr = NF90_DEF_VAR (nid_restart, field_name, NF90_FLOAT,(/ idim2 /),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,field_glo)
419
420      ELSE IF (field_size==klev) THEN
421        ! input is a 2D "atmospheric field" array
422        !idim=idim3
423        ierr = NF90_REDEF (nid_restart)
424#ifdef NC_DOUBLE
425        ierr = NF90_DEF_VAR (nid_restart, field_name, NF90_DOUBLE,(/ idim2 , idim6 /),nvarid)
426#else
427        ierr = NF90_DEF_VAR (nid_restart, field_name, NF90_FLOAT,(/ idim2 , idim6 /),nvarid)
428#endif
429        IF (LEN_TRIM(title) > 0) ierr = NF90_PUT_ATT (nid_restart,nvarid,"title", title)
430        ierr = NF90_ENDDEF(nid_restart)
431        ierr = NF90_PUT_VAR(nid_restart,nvarid,field_glo)
432
433      ELSE IF (field_size==klevp1) THEN
434        ! input is a 2D "interlayer atmospheric field" array
435        !idim=idim4
436        ierr = NF90_REDEF (nid_restart)
437#ifdef NC_DOUBLE
438        ierr = NF90_DEF_VAR (nid_restart, field_name, NF90_DOUBLE,(/ idim2 , idim4 /),nvarid)
439#else
440        ierr = NF90_DEF_VAR (nid_restart, field_name, NF90_FLOAT,(/ idim2 , idim4 /),nvarid)
441#endif
442        IF (LEN_TRIM(title) > 0) ierr = NF90_PUT_ATT (nid_restart,nvarid,"title", title)
443        ierr = NF90_ENDDEF(nid_restart)
444        ierr = NF90_PUT_VAR(nid_restart,nvarid,field_glo)
445
446      ELSE IF (field_size==nsoil) THEN
447        ! input is a 2D "subsurface field" array
448        ierr = NF90_REDEF (nid_restart)
449#ifdef NC_DOUBLE
450        ierr = NF90_DEF_VAR (nid_restart, field_name, NF90_DOUBLE,(/ idim2 , idim3 /),nvarid)
451#else
452        ierr = NF90_DEF_VAR (nid_restart, field_name, NF90_FLOAT,(/ idim2 , idim3 /),nvarid)
453#endif
454        IF (LEN_TRIM(title) > 0) ierr = NF90_PUT_ATT (nid_restart,nvarid,"title", title)
455        ierr = NF90_ENDDEF(nid_restart)
456        ierr = NF90_PUT_VAR(nid_restart,nvarid,field_glo)
457
458      ELSE
459        PRINT *, "Error phyredem(put_field_rgen) : wrong dimension for ",trim(field_name)
460        write(*,*) "  field_size =",field_size
461        CALL ABORT
462      ENDIF
463
464      ! Check the writting of field to file went OK
465      if (ierr.ne.NF90_NOERR) then
466        write(*,*) " Error phyredem(put_field_rgen) : failed writing ",trim(field_name)
467        call abort
468      endif
469
470!      ierr = NF90_REDEF (nid_restart)
471!#ifdef NC_DOUBLE
472!      ierr = NF90_DEF_VAR (nid_restart, field_name, NF90_DOUBLE,(/ idim /),nvarid)
473!#else
474!      ierr = NF90_DEF_VAR (nid_restart, field_name, NF90_FLOAT,(/ idim /),nvarid)
475!#endif
476!      IF (LEN_TRIM(title) > 0) ierr = NF90_PUT_ATT (nid_restart,nvarid,"title", title)
477!      ierr = NF90_ENDDEF(nid_restart)
478!      ierr = NF90_PUT_VAR(nid_restart,nvarid,RESHAPE(field_glo,(/klon_glo*field_size/)))
479
480    ENDIF ! of IF (is_mpi_root .AND. is_omp_root)
481   
482   END SUBROUTINE put_field_rgen 
483 
484   SUBROUTINE put_var_r0(var_name,title,var)
485   IMPLICIT NONE
486     CHARACTER(LEN=*),INTENT(IN) :: var_name
487     CHARACTER(LEN=*),INTENT(IN) :: title
488     REAL,INTENT(IN)             :: var
489     REAL                        :: varin(1)
490     
491     varin(1)=var
492     
493     CALL put_var_rgen(var_name,title,varin,size(varin))
494
495  END SUBROUTINE put_var_r0
496
497
498   SUBROUTINE put_var_r1(var_name,title,var)
499   IMPLICIT NONE
500     CHARACTER(LEN=*),INTENT(IN) :: var_name
501     CHARACTER(LEN=*),INTENT(IN) :: title
502     REAL,INTENT(IN)             :: var(:)
503     
504     CALL put_var_rgen(var_name,title,var,size(var))
505
506  END SUBROUTINE put_var_r1
507 
508  SUBROUTINE put_var_r2(var_name,title,var)
509   IMPLICIT NONE
510     CHARACTER(LEN=*),INTENT(IN) :: var_name
511     CHARACTER(LEN=*),INTENT(IN) :: title
512     REAL,INTENT(IN)             :: var(:,:)
513     
514     CALL put_var_rgen(var_name,title,var,size(var))
515
516  END SUBROUTINE put_var_r2     
517 
518  SUBROUTINE put_var_r3(var_name,title,var)
519   IMPLICIT NONE
520     CHARACTER(LEN=*),INTENT(IN) :: var_name
521     CHARACTER(LEN=*),INTENT(IN) :: title
522     REAL,INTENT(IN)             :: var(:,:,:)
523     
524     CALL put_var_rgen(var_name,title,var,size(var))
525
526  END SUBROUTINE put_var_r3
527
528  SUBROUTINE put_var_rgen(var_name,title,var,var_size)
529  USE netcdf
530  USE dimphy
531  USE mod_phys_lmdz_para
532  IMPLICIT NONE
533     CHARACTER(LEN=*),INTENT(IN) :: var_name
534     CHARACTER(LEN=*),INTENT(IN) :: title
535     INTEGER,INTENT(IN)          :: var_size
536     REAL,INTENT(IN)             :: var(var_size)
537     
538     INTEGER :: ierr
539     INTEGER :: nvarid
540     INTEGER :: idim1d
541         
542    IF (is_mpi_root .AND. is_omp_root) THEN
543
544      IF (var_size==length) THEN
545        ! We know it is a "controle" kind of 1D array
546        idim1d=idim1
547      ELSEIF (var_size==nsoil) THEN
548        ! We know it is an  "mlayer" kind of 1D array
549        idim1d=idim3
550      ELSE
551        PRINT *, "Error phyredem(put_var_rgen) : wrong dimension"
552        write(*,*) "  var_size =",var_size
553        CALL abort
554
555      ENDIF ! of IF (var_size==length) THEN
556
557      ierr = NF90_REDEF (nid_restart)
558
559#ifdef NC_DOUBLE
560      ierr = NF90_DEF_VAR (nid_restart, var_name, NF90_DOUBLE,(/ idim1d /),nvarid)
561#else
562      ierr = NF90_DEF_VAR (nid_restart, var_name, NF90_FLOAT,(/ idim1d /),nvarid)
563#endif
564      IF (LEN_TRIM(title)>0) ierr = NF90_PUT_ATT (nid_restart,nvarid,"title", title)
565      ierr = NF90_ENDDEF(nid_restart)
566     
567      ierr = NF90_PUT_VAR(nid_restart,nvarid,var)
568
569    ENDIF ! of IF (is_mpi_root .AND. is_omp_root)
570   
571  END SUBROUTINE put_var_rgen     
572   
573END MODULE iostart
Note: See TracBrowser for help on using the repository browser.