source: LMDZ6/trunk/libf/phylmd/iostart.F90 @ 5040

Last change on this file since 5040 was 3508, checked in by Ehouarn Millour, 5 years ago

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