source: LMDZ6/trunk/libf/phylmd/iostart.f90 @ 5483

Last change on this file since 5483 was 5483, checked in by evignon, 10 hours ago

ajout de omp_threadprivate manquants
  • 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: 15.3 KB
Line 
1MODULE iostart
2
3PRIVATE
4    INTEGER,SAVE :: nid_start
5    INTEGER,SAVE :: nid_restart
6    INTEGER,SAVE :: idim1,idim2,idim3,idim4
7!$OMP THREADPRIVATE(nid_start,nid_restart,idim1,idim2,idim3,idim4)
8
9    INTEGER,PARAMETER :: length=100
10   
11    INTERFACE get_field
12      MODULE PROCEDURE Get_field_r1,Get_field_r2,Get_field_r3
13    END INTERFACE get_field
14   
15    INTERFACE get_var
16      MODULE PROCEDURE get_var_r0,Get_var_r1,Get_var_r2,Get_var_r3
17    END INTERFACE get_var
18
19    INTERFACE put_field
20      MODULE PROCEDURE put_field_r1,put_field_r2,put_field_r3
21    END INTERFACE put_field
22
23    INTERFACE put_var
24      MODULE PROCEDURE put_var_r0,put_var_r1,put_var_r2,put_var_r3
25    END INTERFACE put_var
26
27    PUBLIC get_field,get_var,put_field,put_var
28    PUBLIC Open_startphy,close_startphy,open_restartphy,close_restartphy, enddef_restartphy
29   
30CONTAINS
31
32  SUBROUTINE Open_startphy(filename)
33  USE netcdf
34  USE mod_phys_lmdz_para
35  IMPLICIT NONE
36    CHARACTER(LEN=*) :: filename
37    INTEGER          :: ierr
38
39    IF (is_mpi_root .AND. is_omp_root) THEN
40      ierr = NF90_OPEN (filename, NF90_NOWRITE,nid_start)
41      IF (ierr.NE.NF90_NOERR) THEN
42        write(6,*)' Pb d''ouverture du fichier '//filename
43        write(6,*)' ierr = ', ierr
44        CALL abort_physic("", "", 1)
45      ENDIF
46    ENDIF
47   
48  END SUBROUTINE Open_startphy
49
50  SUBROUTINE Close_startphy
51  USE netcdf
52  USE mod_phys_lmdz_para
53  IMPLICIT NONE
54    INTEGER          :: ierr
55
56    IF (is_mpi_root .AND. is_omp_root) THEN
57        ierr = NF90_CLOSE (nid_start)
58    ENDIF
59
60  END SUBROUTINE close_startphy
61
62
63  FUNCTION Inquire_Field(Field_name)
64  USE netcdf
65  USE mod_phys_lmdz_para
66  IMPLICIT NONE
67    CHARACTER(LEN=*) :: Field_name
68    LOGICAL :: inquire_field
69    INTEGER :: varid
70    INTEGER :: ierr
71   
72    IF (is_mpi_root .AND. is_omp_root) THEN
73      ierr=NF90_INQ_VARID(nid_start,Field_name,varid)
74      IF (ierr==NF90_NOERR) THEN
75        Inquire_field=.TRUE.
76      ELSE
77        Inquire_field=.FALSE.
78      ENDIF
79    ENDIF
80
81    CALL bcast(Inquire_field)
82
83  END FUNCTION Inquire_Field
84 
85 
86  SUBROUTINE Get_Field_r1(field_name,field,found)
87  IMPLICIT NONE
88    CHARACTER(LEN=*),INTENT(IN)    :: Field_name
89    REAL,INTENT(INOUT)               :: Field(:)
90    LOGICAL,INTENT(OUT),OPTIONAL   :: found
91
92    CALL Get_field_rgen(field_name,field,1,found)
93     
94  END SUBROUTINE Get_Field_r1
95 
96  SUBROUTINE Get_Field_r2(field_name,field,found)
97  IMPLICIT NONE
98    CHARACTER(LEN=*),INTENT(IN)    :: Field_name
99    REAL,INTENT(INOUT)               :: Field(:,:)
100    LOGICAL,INTENT(OUT),OPTIONAL   :: found
101
102    CALL Get_field_rgen(field_name,field,size(field,2),found)
103
104     
105  END SUBROUTINE Get_Field_r2
106 
107  SUBROUTINE Get_Field_r3(field_name,field,found)
108  IMPLICIT NONE
109    CHARACTER(LEN=*),INTENT(IN)    :: Field_name
110    REAL,INTENT(INOUT)               :: Field(:,:,:)
111    LOGICAL,INTENT(OUT),OPTIONAL   :: found
112
113    CALL Get_field_rgen(field_name,field,size(field,2)*size(field,3),found)
114     
115  END SUBROUTINE Get_Field_r3
116 
117  SUBROUTINE Get_field_rgen(field_name,field,field_size,found)
118  USE netcdf
119  USE dimphy
120  USE geometry_mod
121  USE mod_grid_phy_lmdz
122  USE mod_phys_lmdz_para
123  IMPLICIT NONE
124    CHARACTER(LEN=*) :: Field_name
125    INTEGER          :: field_size
126    REAL             :: field(klon,field_size)
127    LOGICAL,OPTIONAL :: found
128   
129    REAL,ALLOCATABLE    :: field_glo(:,:)
130    REAL,ALLOCATABLE    :: field_glo_tmp(:,:)
131    INTEGER,ALLOCATABLE :: ind_cell_glo_glo(:)
132    LOGICAL :: tmp_found
133    INTEGER :: varid
134    INTEGER :: ierr,i
135
136    IF (is_master) THEN
137      ALLOCATE(ind_cell_glo_glo(klon_glo))
138      ALLOCATE(field_glo(klon_glo,field_size))
139      ALLOCATE(field_glo_tmp(klon_glo,field_size))
140    ELSE
141      ALLOCATE(ind_cell_glo_glo(0))
142      ALLOCATE(field_glo(0,0))
143    ENDIF
144   
145    CALL gather(ind_cell_glo,ind_cell_glo_glo)
146   
147    IF (is_master) THEN
148 
149      ierr=NF90_INQ_VARID(nid_start,Field_name,varid)
150     
151      IF (ierr==NF90_NOERR) THEN
152        CALL body(field_glo_tmp)
153        tmp_found=.TRUE.
154      ELSE
155        tmp_found=.FALSE.
156      ENDIF
157   
158    ENDIF
159   
160    CALL bcast(tmp_found)
161
162    IF (tmp_found) THEN
163      IF (is_master) THEN 
164        DO i=1,klon_glo
165         field_glo(i,:)=field_glo_tmp(ind_cell_glo_glo(i),:)
166        ENDDO
167      ENDIF
168      CALL scatter(field_glo,field)
169    ENDIF
170   
171    IF (PRESENT(found)) THEN
172      found=tmp_found
173    ELSE
174      IF (.NOT. tmp_found) THEN
175        PRINT*, 'phyetat0: Le champ <'//field_name//'> est absent'
176        call abort_physic("", "", 1)
177      ENDIF
178    ENDIF
179 
180   
181    CONTAINS
182     
183     SUBROUTINE body(field_glo)
184       REAL :: field_glo(klon_glo*field_size)
185         ierr=NF90_GET_VAR(nid_start,varid,field_glo)
186         IF (ierr/=NF90_NOERR) THEN
187           ! La variable exist dans le fichier mais la lecture a echouee.
188           PRINT*, 'phyetat0: Lecture echouee pour <'//field_name//'>'
189
190           IF (field_name=='CLWCON' .OR. field_name=='RNEBCON' .OR. field_name=='RATQS') THEN
191              ! Essaye de lire le variable sur surface uniqument, comme fait avant
192              field_glo(:)=0.
193              ierr=NF90_GET_VAR(nid_start,varid,field_glo(1:klon_glo))
194              IF (ierr/=NF90_NOERR) THEN
195                 PRINT*, 'phyetat0: Lecture echouee aussi en 2D pour <'//field_name//'>'
196                 call abort_physic("", "", 1)
197              ELSE
198                 PRINT*, 'phyetat0: La variable <'//field_name//'> lu sur surface seulement'!, selon ancien format, le reste mis a zero'
199              END IF
200           ELSE
201              call abort_physic("", "", 1)
202           ENDIF
203         ENDIF
204
205     END SUBROUTINE body
206
207  END SUBROUTINE Get_field_rgen
208 
209
210  SUBROUTINE get_var_r0(var_name,var,found)
211  IMPLICIT NONE 
212    CHARACTER(LEN=*),INTENT(IN)  :: var_name
213    REAL,INTENT(INOUT)             :: var
214    LOGICAL,OPTIONAL,INTENT(OUT) :: found
215
216    REAL                         :: varout(1)
217   
218    CALL Get_var_rgen(var_name,varout,size(varout),found)
219    var=varout(1)
220 
221  END SUBROUTINE get_var_r0
222
223  SUBROUTINE get_var_r1(var_name,var,found)
224  IMPLICIT NONE 
225    CHARACTER(LEN=*),INTENT(IN)  :: var_name
226    REAL,INTENT(INOUT)             :: var(:)
227    LOGICAL,OPTIONAL,INTENT(OUT) :: found
228   
229    CALL Get_var_rgen(var_name,var,size(var),found)
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    CALL Get_var_rgen(var_name,var,size(var),found)
240 
241  END SUBROUTINE get_var_r2
242
243  SUBROUTINE get_var_r3(var_name,var,found)
244  IMPLICIT NONE 
245    CHARACTER(LEN=*),INTENT(IN)  :: var_name
246    REAL,INTENT(INOUT)             :: var(:,:,:)
247    LOGICAL,OPTIONAL,INTENT(OUT) :: found
248   
249    CALL Get_var_rgen(var_name,var,size(var),found)
250 
251  END SUBROUTINE get_var_r3
252
253  SUBROUTINE Get_var_rgen(var_name,var,var_size,found)
254  USE netcdf
255  USE dimphy
256  USE mod_grid_phy_lmdz
257  USE mod_phys_lmdz_para
258  IMPLICIT NONE
259    CHARACTER(LEN=*) :: var_name
260    INTEGER          :: var_size
261    REAL             :: var(var_size)
262    LOGICAL,OPTIONAL :: found
263   
264    LOGICAL :: tmp_found
265    INTEGER :: varid
266    INTEGER :: ierr
267   
268    IF (is_mpi_root .AND. is_omp_root) THEN
269 
270      ierr=NF90_INQ_VARID(nid_start,var_name,varid)
271     
272      IF (ierr==NF90_NOERR) THEN
273        ierr=NF90_GET_VAR(nid_start,varid,var)
274        IF (ierr/=NF90_NOERR) THEN
275          PRINT*, 'phyetat0: Lecture echouee pour <'//var_name//'>'
276          call abort_physic("", "", 1)
277        ENDIF
278        tmp_found=.TRUE.
279      ELSE
280        tmp_found=.FALSE.
281      ENDIF
282   
283    ENDIF
284   
285    CALL bcast(tmp_found)
286
287    IF (tmp_found) THEN
288      CALL bcast(var)
289    ENDIF
290   
291    IF (PRESENT(found)) THEN
292      found=tmp_found
293    ELSE
294      IF (.NOT. tmp_found) THEN
295        PRINT*, 'phyetat0: La variable champ <'//var_name//'> est absente'
296        call abort_physic("", "", 1)
297      ENDIF
298    ENDIF
299
300  END SUBROUTINE Get_var_rgen
301
302
303  SUBROUTINE open_restartphy(filename)
304  USE netcdf
305  USE mod_phys_lmdz_para, ONLY: is_master
306  USE mod_grid_phy_lmdz, ONLY: klon_glo
307  USE dimphy, ONLY: klev, klevp1
308  USE print_control_mod, ONLY: lunout
309  IMPLICIT NONE
310    CHARACTER(LEN=*),INTENT(IN) :: filename
311    INTEGER                     :: ierr
312   
313    IF (is_master) THEN
314      ierr = NF90_CREATE(filename, IOR(NF90_CLOBBER,NF90_64BIT_OFFSET), &
315                          nid_restart)
316      IF (ierr/=NF90_NOERR) THEN
317        write(lunout,*)'open_restartphy: problem creating file '//trim(filename)
318        write(lunout,*)trim(nf90_strerror(ierr))
319        CALL abort_physic("open_restartphy", trim(nf90_strerror(ierr)), 1)
320      ENDIF
321
322      ierr = NF90_PUT_ATT (nid_restart, NF90_GLOBAL, "title","Fichier redemmarage physique")
323
324      ierr = NF90_DEF_DIM (nid_restart, "index", length, idim1)
325      ierr = NF90_DEF_DIM (nid_restart, "points_physiques", klon_glo, idim2)
326      ierr = NF90_DEF_DIM (nid_restart, "horizon_vertical", klon_glo*klev, idim3)
327      ierr = NF90_DEF_DIM (nid_restart, "horizon_klevp1", klon_glo*klevp1, idim4)
328
329!      ierr = NF90_ENDDEF(nid_restart)
330    ENDIF
331
332  END SUBROUTINE open_restartphy
333 
334  SUBROUTINE enddef_restartphy
335  USE netcdf
336  USE mod_phys_lmdz_para
337  IMPLICIT NONE
338    INTEGER          :: ierr
339
340    IF (is_master) ierr = NF90_ENDDEF(nid_restart)
341 
342  END SUBROUTINE enddef_restartphy
343
344  SUBROUTINE close_restartphy
345  USE netcdf
346  USE mod_phys_lmdz_para
347  IMPLICIT NONE
348    INTEGER          :: ierr
349
350    IF (is_master) ierr = NF90_CLOSE (nid_restart)
351 
352  END SUBROUTINE close_restartphy
353
354 
355  SUBROUTINE put_field_r1(pass, field_name,title,field)
356  IMPLICIT NONE
357  INTEGER, INTENT(IN)            :: pass
358  CHARACTER(LEN=*),INTENT(IN)    :: field_name
359  CHARACTER(LEN=*),INTENT(IN)    :: title
360  REAL,INTENT(IN)                :: field(:)
361    CALL put_field_rgen(pass, field_name,title,field,1)
362 
363  END SUBROUTINE put_field_r1
364
365  SUBROUTINE put_field_r2(pass, field_name,title,field)
366  IMPLICIT NONE
367  INTEGER, INTENT(IN)            :: pass
368  CHARACTER(LEN=*),INTENT(IN)    :: field_name
369  CHARACTER(LEN=*),INTENT(IN)    :: title
370  REAL,INTENT(IN)                :: field(:,:)
371 
372    CALL put_field_rgen(pass, field_name,title,field,size(field,2))
373 
374  END SUBROUTINE put_field_r2
375
376  SUBROUTINE put_field_r3(pass, field_name,title,field)
377  IMPLICIT NONE
378  INTEGER, INTENT(IN)            :: pass
379  CHARACTER(LEN=*),INTENT(IN)    :: field_name
380  CHARACTER(LEN=*),INTENT(IN)    :: title
381  REAL,INTENT(IN)                :: field(:,:,:)
382 
383    CALL put_field_rgen(pass, field_name,title,field,size(field,2)*size(field,3))
384 
385  END SUBROUTINE put_field_r3
386 
387  SUBROUTINE put_field_rgen(pass, field_name,title,field,field_size)
388  USE netcdf
389  USE dimphy
390  USE geometry_mod
391  USE mod_grid_phy_lmdz
392  USE mod_phys_lmdz_para
393  USE lmdz_cppkeys_wrapper, ONLY: nf90_format
394  IMPLICIT NONE
395  INTEGER, INTENT(IN)            :: pass
396  CHARACTER(LEN=*),INTENT(IN)    :: field_name
397  CHARACTER(LEN=*),INTENT(IN)    :: title
398  INTEGER,INTENT(IN)             :: field_size
399  REAL,INTENT(IN)                :: field(klon,field_size)
400 
401!  REAL                           :: field_glo(klon_glo,field_size)
402!  REAL                           :: field_glo_tmp(klon_glo,field_size)
403  REAL ,ALLOCATABLE              :: field_glo(:,:)
404  REAL ,ALLOCATABLE              :: field_glo_tmp(:,:)
405  INTEGER,ALLOCATABLE            :: ind_cell_glo_glo(:)
406!  INTEGER                        :: ind_cell_glo_glo(klon_glo)
407  INTEGER                        :: ierr,i
408  INTEGER                        :: nvarid
409  INTEGER                        :: idim
410   
411! first pass : definition   
412  IF (pass==1) THEN
413   
414    IF (is_master) THEN
415
416      IF (field_size==1) THEN
417        idim=idim2
418      ELSE IF (field_size==klev) THEN
419        idim=idim3
420      ELSE IF (field_size==klevp1) THEN
421        idim=idim4
422      ELSE
423        PRINT *, "erreur phyredem : probleme de dimension"
424        CALL abort_physic("", "", 1)
425      ENDIF
426         
427!      ierr = NF90_REDEF (nid_restart)
428      ierr = NF90_DEF_VAR (nid_restart, field_name, nf90_format,(/ idim /),nvarid)
429      IF (LEN_TRIM(title) > 0) ierr = NF90_PUT_ATT (nid_restart,nvarid,"title", title)
430!      ierr = NF90_ENDDEF(nid_restart)
431     ENDIF
432
433! second pass : write     
434   ELSE IF (pass==2) THEN
435   
436     IF (is_master) THEN
437       ALLOCATE(ind_cell_glo_glo(klon_glo))
438       ALLOCATE(field_glo(klon_glo,field_size))
439       ALLOCATE(field_glo_tmp(klon_glo,field_size))
440     ELSE
441       ALLOCATE(ind_cell_glo_glo(0))
442       ALLOCATE(field_glo_tmp(0,0))
443     ENDIF
444     
445     CALL gather(ind_cell_glo,ind_cell_glo_glo)
446
447     CALL gather(field,field_glo_tmp)
448   
449     IF (is_master) THEN
450
451       DO i=1,klon_glo
452         field_glo(ind_cell_glo_glo(i),:)=field_glo_tmp(i,:)
453       ENDDO
454
455       ierr = NF90_INQ_VARID(nid_restart, field_name, nvarid)
456       ierr = NF90_PUT_VAR(nid_restart,nvarid,RESHAPE(field_glo,(/klon_glo*field_size/)))
457      ENDIF
458   ENDIF
459   
460 END SUBROUTINE put_field_rgen 
461 
462
463 SUBROUTINE put_var_r0(pass, var_name,title,var)
464   IMPLICIT NONE
465     INTEGER, INTENT(IN)            :: pass
466     CHARACTER(LEN=*),INTENT(IN) :: var_name
467     CHARACTER(LEN=*),INTENT(IN) :: title
468     REAL,INTENT(IN)             :: var
469     REAL                        :: varin(1)
470     
471     varin(1)=var
472     
473     CALL put_var_rgen(pass, var_name,title,varin,size(varin))
474
475  END SUBROUTINE put_var_r0
476
477
478   SUBROUTINE put_var_r1(pass, var_name,title,var)
479   IMPLICIT NONE
480     INTEGER, INTENT(IN)            :: pass
481     CHARACTER(LEN=*),INTENT(IN) :: var_name
482     CHARACTER(LEN=*),INTENT(IN) :: title
483     REAL,INTENT(IN)             :: var(:)
484     
485     CALL put_var_rgen(pass, var_name,title,var,size(var))
486
487  END SUBROUTINE put_var_r1
488 
489  SUBROUTINE put_var_r2(pass, var_name,title,var)
490   IMPLICIT NONE
491     INTEGER, INTENT(IN)            :: pass
492     CHARACTER(LEN=*),INTENT(IN) :: var_name
493     CHARACTER(LEN=*),INTENT(IN) :: title
494     REAL,INTENT(IN)             :: var(:,:)
495     
496     CALL put_var_rgen(pass, var_name,title,var,size(var))
497
498  END SUBROUTINE put_var_r2     
499 
500  SUBROUTINE put_var_r3(pass, var_name,title,var)
501   IMPLICIT NONE
502     INTEGER, INTENT(IN)            :: pass
503     CHARACTER(LEN=*),INTENT(IN) :: var_name
504     CHARACTER(LEN=*),INTENT(IN) :: title
505     REAL,INTENT(IN)             :: var(:,:,:)
506     
507     CALL put_var_rgen(pass, var_name,title,var,size(var))
508
509  END SUBROUTINE put_var_r3
510
511  SUBROUTINE put_var_rgen(pass, var_name,title,var,var_size)
512  USE netcdf
513  USE dimphy
514  USE mod_phys_lmdz_para
515  USE lmdz_cppkeys_wrapper, ONLY: nf90_format
516  IMPLICIT NONE
517    INTEGER, INTENT(IN)         :: pass
518    CHARACTER(LEN=*),INTENT(IN) :: var_name
519    CHARACTER(LEN=*),INTENT(IN) :: title
520    INTEGER,INTENT(IN)          :: var_size
521    REAL,INTENT(IN)             :: var(var_size)
522   
523    INTEGER :: ierr
524    INTEGER :: nvarid
525         
526    IF (is_master) THEN
527
528      IF (var_size/=length) THEN
529        PRINT *, "erreur phyredem : probleme de dimension"
530        call abort_physic("", "", 1)
531      ENDIF
532
533     ! first pass : definition   
534      IF (pass==1) THEN
535       
536!      ierr = NF90_REDEF (nid_restart)
537        ierr = NF90_DEF_VAR (nid_restart, var_name, nf90_format,(/ idim1 /),nvarid)
538        IF (LEN_TRIM(title)>0) ierr = NF90_PUT_ATT (nid_restart,nvarid,"title", title)
539!      ierr = NF90_ENDDEF(nid_restart)
540
541    ! second pass : write     
542      ELSE IF (pass==2) THEN
543        ierr = NF90_INQ_VARID(nid_restart, var_name, nvarid)
544        ierr = NF90_PUT_VAR(nid_restart,nvarid,var)
545      ENDIF
546    ENDIF
547   
548  END SUBROUTINE put_var_rgen     
549   
550END MODULE iostart
Note: See TracBrowser for help on using the repository browser.