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

Last change on this file since 3336 was 3312, checked in by Laurent Fairhead, 7 years ago

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