source: LMDZ6/branches/Amaury_dev/libf/phylmd/iostart.F90 @ 5111

Last change on this file since 5111 was 5111, checked in by abarral, 2 months ago

Put abort_physic into a module
Remove -g option from makelmdz_fcm, since that option is linked to a header file that isn't included anywhere.
(lint) light lint on traversed files
  • 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.7 KB
Line 
1MODULE iostart
2  USE lmdz_abort_physic, ONLY: abort_physic
3 
4PRIVATE
5    INTEGER,SAVE :: nid_start
6    INTEGER,SAVE :: nid_restart
7   
8    INTEGER,SAVE :: idim1,idim2,idim3,idim4
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, ONLY: nf90_nowrite, nf90_noerr,nf90_open
34  USE lmdz_phys_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/=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, ONLY: nf90_close
52  USE lmdz_phys_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, ONLY: nf90_noerr,nf90_inq_varid
65  USE lmdz_phys_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, ONLY: nf90_inq_varid,nf90_noerr,nf90_get_var
119  USE dimphy
120  USE geometry_mod
121  USE lmdz_grid_phy
122  USE lmdz_phys_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, ONLY: nf90_noerr,nf90_get_var,nf90_inq_varid
255  USE dimphy
256  USE lmdz_grid_phy
257  USE lmdz_phys_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, ONLY: nf90_create,nf90_clobber,nf90_64bit_offset,nf90_noerr,nf90_strerror,&
305          nf90_global,nf90_put_att,nf90_def_dim
306  USE lmdz_phys_para, ONLY: is_master
307  USE lmdz_grid_phy, ONLY: klon_glo
308  USE dimphy, ONLY: klev, klevp1
309  USE print_control_mod, ONLY: lunout
310  IMPLICIT NONE
311    CHARACTER(LEN=*),INTENT(IN) :: filename
312    INTEGER                     :: ierr
313   
314    IF (is_master) THEN
315      ierr = nf90_create(filename, IOR(nf90_clobber,nf90_64bit_offset), &
316                          nid_restart)
317      IF (ierr/=nf90_noerr) THEN
318        write(lunout,*)'open_restartphy: problem creating file '//trim(filename)
319        write(lunout,*)trim(nf90_strerror(ierr))
320        CALL abort_physic("open_restartphy", trim(nf90_strerror(ierr)), 1)
321      ENDIF
322
323      ierr = nf90_put_att (nid_restart, nf90_global, "title","Fichier redemmarage physique")
324
325      ierr = nf90_def_dim (nid_restart, "index", length, idim1)
326      ierr = nf90_def_dim (nid_restart, "points_physiques", klon_glo, idim2)
327      ierr = nf90_def_dim (nid_restart, "horizon_vertical", klon_glo*klev, idim3)
328      ierr = nf90_def_dim (nid_restart, "horizon_klevp1", klon_glo*klevp1, idim4)
329
330!      ierr = nf90_enddef(nid_restart)
331    ENDIF
332
333  END SUBROUTINE open_restartphy
334 
335  SUBROUTINE enddef_restartphy
336  USE netcdf, ONLY: nf90_enddef
337  USE lmdz_phys_para
338  IMPLICIT NONE
339    INTEGER          :: ierr
340
341    IF (is_master) ierr = nf90_enddef(nid_restart)
342 
343  END SUBROUTINE enddef_restartphy
344
345  SUBROUTINE close_restartphy
346  USE netcdf, ONLY: nf90_close
347  USE lmdz_phys_para
348  IMPLICIT NONE
349    INTEGER          :: ierr
350
351    IF (is_master) ierr = nf90_close (nid_restart)
352 
353  END SUBROUTINE close_restartphy
354
355 
356  SUBROUTINE put_field_r1(pass, field_name,title,field)
357  IMPLICIT NONE
358  INTEGER, INTENT(IN)            :: pass
359  CHARACTER(LEN=*),INTENT(IN)    :: field_name
360  CHARACTER(LEN=*),INTENT(IN)    :: title
361  REAL,INTENT(IN)                :: field(:)
362    CALL put_field_rgen(pass, field_name,title,field,1)
363 
364  END SUBROUTINE put_field_r1
365
366  SUBROUTINE put_field_r2(pass, field_name,title,field)
367  IMPLICIT NONE
368  INTEGER, INTENT(IN)            :: pass
369  CHARACTER(LEN=*),INTENT(IN)    :: field_name
370  CHARACTER(LEN=*),INTENT(IN)    :: title
371  REAL,INTENT(IN)                :: field(:,:)
372 
373    CALL put_field_rgen(pass, field_name,title,field,size(field,2))
374 
375  END SUBROUTINE put_field_r2
376
377  SUBROUTINE put_field_r3(pass, field_name,title,field)
378  IMPLICIT NONE
379  INTEGER, INTENT(IN)            :: pass
380  CHARACTER(LEN=*),INTENT(IN)    :: field_name
381  CHARACTER(LEN=*),INTENT(IN)    :: title
382  REAL,INTENT(IN)                :: field(:,:,:)
383 
384    CALL put_field_rgen(pass, field_name,title,field,size(field,2)*size(field,3))
385 
386  END SUBROUTINE put_field_r3
387 
388  SUBROUTINE put_field_rgen(pass, field_name,title,field,field_size)
389  USE netcdf, ONLY: nf90_def_var,nf90_put_att,nf90_inq_varid,nf90_put_var
390  USE lmdz_cppkeys_wrapper, ONLY: nf90_format
391  USE dimphy
392  USE geometry_mod
393  USE lmdz_grid_phy
394  USE lmdz_phys_para
395  IMPLICIT NONE
396  INTEGER, INTENT(IN)            :: pass
397  CHARACTER(LEN=*),INTENT(IN)    :: field_name
398  CHARACTER(LEN=*),INTENT(IN)    :: title
399  INTEGER,INTENT(IN)             :: field_size
400  REAL,INTENT(IN)                :: field(klon,field_size)
401 
402!  REAL                           :: field_glo(klon_glo,field_size)
403!  REAL                           :: field_glo_tmp(klon_glo,field_size)
404  REAL ,ALLOCATABLE              :: field_glo(:,:)
405  REAL ,ALLOCATABLE              :: field_glo_tmp(:,:)
406  INTEGER,ALLOCATABLE            :: ind_cell_glo_glo(:)
407!  INTEGER                        :: ind_cell_glo_glo(klon_glo)
408  INTEGER                        :: ierr,i
409  INTEGER                        :: nvarid
410  INTEGER                        :: idim
411   
412! first pass : definition   
413  IF (pass==1) THEN
414   
415    IF (is_master) THEN
416
417      IF (field_size==1) THEN
418        idim=idim2
419      ELSE IF (field_size==klev) THEN
420        idim=idim3
421      ELSE IF (field_size==klevp1) THEN
422        idim=idim4
423      ELSE
424        PRINT *, "erreur phyredem : probleme de dimension"
425        CALL abort_physic("", "", 1)
426      ENDIF
427         
428!      ierr = nf90_redef (nid_restart)
429      ierr = nf90_def_var (nid_restart, field_name, nf90_format,(/ idim /),nvarid)
430      IF (LEN_TRIM(title) > 0) ierr = nf90_put_att (nid_restart,nvarid,"title", title)
431!      ierr = nf90_enddef(nid_restart)
432     ENDIF
433
434! second pass : write     
435   ELSE IF (pass==2) THEN
436   
437     IF (is_master) THEN
438       ALLOCATE(ind_cell_glo_glo(klon_glo))
439       ALLOCATE(field_glo(klon_glo,field_size))
440       ALLOCATE(field_glo_tmp(klon_glo,field_size))
441     ELSE
442       ALLOCATE(ind_cell_glo_glo(0))
443       ALLOCATE(field_glo_tmp(0,0))
444     ENDIF
445     
446     CALL gather(ind_cell_glo,ind_cell_glo_glo)
447
448     CALL gather(field,field_glo_tmp)
449   
450     IF (is_master) THEN
451
452       DO i=1,klon_glo
453         field_glo(ind_cell_glo_glo(i),:)=field_glo_tmp(i,:)
454       ENDDO
455
456       ierr = nf90_inq_varid(nid_restart, field_name, nvarid)
457       ierr = nf90_put_var(nid_restart,nvarid,RESHAPE(field_glo,(/klon_glo*field_size/)))
458      ENDIF
459   ENDIF
460   
461 END SUBROUTINE put_field_rgen 
462 
463
464 SUBROUTINE put_var_r0(pass, var_name,title,var)
465   IMPLICIT NONE
466     INTEGER, INTENT(IN)            :: pass
467     CHARACTER(LEN=*),INTENT(IN) :: var_name
468     CHARACTER(LEN=*),INTENT(IN) :: title
469     REAL,INTENT(IN)             :: var
470     REAL                        :: varin(1)
471     
472     varin(1)=var
473     
474     CALL put_var_rgen(pass, var_name,title,varin,size(varin))
475
476  END SUBROUTINE put_var_r0
477
478
479   SUBROUTINE put_var_r1(pass, var_name,title,var)
480   IMPLICIT NONE
481     INTEGER, INTENT(IN)            :: pass
482     CHARACTER(LEN=*),INTENT(IN) :: var_name
483     CHARACTER(LEN=*),INTENT(IN) :: title
484     REAL,INTENT(IN)             :: var(:)
485     
486     CALL put_var_rgen(pass, var_name,title,var,size(var))
487
488  END SUBROUTINE put_var_r1
489 
490  SUBROUTINE put_var_r2(pass, var_name,title,var)
491   IMPLICIT NONE
492     INTEGER, INTENT(IN)            :: pass
493     CHARACTER(LEN=*),INTENT(IN) :: var_name
494     CHARACTER(LEN=*),INTENT(IN) :: title
495     REAL,INTENT(IN)             :: var(:,:)
496     
497     CALL put_var_rgen(pass, var_name,title,var,size(var))
498
499  END SUBROUTINE put_var_r2     
500 
501  SUBROUTINE put_var_r3(pass, var_name,title,var)
502   IMPLICIT NONE
503     INTEGER, INTENT(IN)            :: pass
504     CHARACTER(LEN=*),INTENT(IN) :: var_name
505     CHARACTER(LEN=*),INTENT(IN) :: title
506     REAL,INTENT(IN)             :: var(:,:,:)
507     
508     CALL put_var_rgen(pass, var_name,title,var,size(var))
509
510  END SUBROUTINE put_var_r3
511
512  SUBROUTINE put_var_rgen(pass, var_name,title,var,var_size)
513  USE netcdf, ONLY: nf90_def_var,nf90_put_var,nf90_inq_varid,nf90_put_att
514  USE lmdz_cppkeys_wrapper, ONLY: nf90_format
515  USE dimphy
516  USE lmdz_phys_para
517  IMPLICIT NONE
518    INTEGER, INTENT(IN)         :: pass
519    CHARACTER(LEN=*),INTENT(IN) :: var_name
520    CHARACTER(LEN=*),INTENT(IN) :: title
521    INTEGER,INTENT(IN)          :: var_size
522    REAL,INTENT(IN)             :: var(var_size)
523   
524    INTEGER :: ierr
525    INTEGER :: nvarid
526         
527    IF (is_master) THEN
528
529      IF (var_size/=length) THEN
530        PRINT *, "erreur phyredem : probleme de dimension"
531        CALL abort_physic("", "", 1)
532      ENDIF
533
534     ! first pass : definition   
535      IF (pass==1) THEN
536       
537!      ierr = nf90_redef (nid_restart)
538
539        ierr = nf90_def_var (nid_restart, var_name, nf90_format,(/ idim1 /),nvarid)
540        IF (LEN_TRIM(title)>0) ierr = nf90_put_att (nid_restart,nvarid,"title", title)
541!      ierr = nf90_enddef(nid_restart)
542
543    ! second pass : write     
544      ELSE IF (pass==2) THEN
545        ierr = nf90_inq_varid(nid_restart, var_name, nvarid)
546        ierr = nf90_put_var(nid_restart,nvarid,var)
547      ENDIF
548    ENDIF
549   
550  END SUBROUTINE put_var_rgen     
551   
552END MODULE iostart
Note: See TracBrowser for help on using the repository browser.