source: dynamico_lmdz/aquaplanet/LMDZ5/libf/phylmd/iostart.F90 @ 3814

Last change on this file since 3814 was 3814, checked in by ymipsl, 10 years ago

remove all dynamic dependency in LMDZ physics except for the include "dimensions.h"

YM
File size: 13.6 KB
Line 
1MODULE iostart
2
3PRIVATE
4    INTEGER,SAVE :: nid_start
5    INTEGER,SAVE :: nid_restart
6   
7    INTEGER,SAVE :: idim1,idim2,idim3,idim4
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_physic("", "", 1)
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_physic("", "", 1)
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_physic("", "", 1)
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_physic("", "", 1)
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_physic("", "", 1)
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_physic("", "", 1)
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  IMPLICIT NONE
317    CHARACTER(LEN=*),INTENT(IN) :: filename
318    INTEGER                     :: ierr
319   
320    IF (is_mpi_root .AND. is_omp_root) THEN
321      ierr = NF90_CREATE(filename, NF90_CLOBBER, nid_restart)
322      IF (ierr/=NF90_NOERR) THEN
323        write(6,*)' Pb d''ouverture du fichier '//filename
324        write(6,*)' ierr = ', ierr
325        CALL abort_physic("", "", 1)
326      ENDIF
327
328      ierr = NF90_PUT_ATT (nid_restart, NF90_GLOBAL, "title","Fichier redemmarage physique")
329
330      ierr = NF90_DEF_DIM (nid_restart, "index", length, idim1)
331      ierr = NF90_DEF_DIM (nid_restart, "points_physiques", klon_glo, idim2)
332      ierr = NF90_DEF_DIM (nid_restart, "horizon_vertical", klon_glo*klev, idim3)
333      ierr = NF90_DEF_DIM (nid_restart, "horizon_klevp1", klon_glo*klevp1, idim4)
334
335      ierr = NF90_ENDDEF(nid_restart)
336    ENDIF
337
338  END SUBROUTINE open_restartphy
339 
340  SUBROUTINE close_restartphy
341  USE netcdf
342  USE mod_phys_lmdz_para
343  IMPLICIT NONE
344    INTEGER          :: ierr
345
346    IF (is_mpi_root .AND. is_omp_root) THEN
347      ierr = NF90_CLOSE (nid_restart)
348    ENDIF
349 
350  END SUBROUTINE close_restartphy
351
352 
353  SUBROUTINE put_field_r1(field_name,title,field)
354  IMPLICIT NONE
355  CHARACTER(LEN=*),INTENT(IN)    :: field_name
356  CHARACTER(LEN=*),INTENT(IN)    :: title
357  REAL,INTENT(IN)                :: field(:)
358 
359    CALL put_field_rgen(field_name,title,field,1)
360 
361  END SUBROUTINE put_field_r1
362
363  SUBROUTINE put_field_r2(field_name,title,field)
364  IMPLICIT NONE
365  CHARACTER(LEN=*),INTENT(IN)    :: field_name
366  CHARACTER(LEN=*),INTENT(IN)    :: title
367  REAL,INTENT(IN)                :: field(:,:)
368 
369    CALL put_field_rgen(field_name,title,field,size(field,2))
370 
371  END SUBROUTINE put_field_r2
372
373  SUBROUTINE put_field_r3(field_name,title,field)
374  IMPLICIT NONE
375  CHARACTER(LEN=*),INTENT(IN)    :: field_name
376  CHARACTER(LEN=*),INTENT(IN)    :: title
377  REAL,INTENT(IN)                :: field(:,:,:)
378 
379    CALL put_field_rgen(field_name,title,field,size(field,2)*size(field,3))
380 
381  END SUBROUTINE put_field_r3
382 
383  SUBROUTINE put_field_rgen(field_name,title,field,field_size)
384  USE netcdf
385  USE dimphy
386  USE mod_grid_phy_lmdz
387  USE mod_phys_lmdz_para
388  IMPLICIT NONE
389  CHARACTER(LEN=*),INTENT(IN)    :: field_name
390  CHARACTER(LEN=*),INTENT(IN)    :: title
391  INTEGER,INTENT(IN)             :: field_size
392  REAL,INTENT(IN)                :: field(klon,field_size)
393 
394  REAL                           :: field_glo(klon_glo,field_size)
395  INTEGER                        :: ierr
396  INTEGER                        :: nvarid
397  INTEGER                        :: idim
398   
399   
400    CALL gather(field,field_glo)
401   
402    IF (is_mpi_root .AND. is_omp_root) THEN
403
404      IF (field_size==1) THEN
405        idim=idim2
406      ELSE IF (field_size==klev) THEN
407        idim=idim3
408      ELSE IF (field_size==klevp1) THEN
409        idim=idim4
410      ELSE
411        PRINT *, "erreur phyredem : probleme de dimension"
412        CALL abort_physic("", "", 1)
413      ENDIF
414         
415      ierr = NF90_REDEF (nid_restart)
416#ifdef NC_DOUBLE
417      ierr = NF90_DEF_VAR (nid_restart, field_name, NF90_DOUBLE,(/ idim /),nvarid)
418#else
419      ierr = NF90_DEF_VAR (nid_restart, field_name, NF90_FLOAT,(/ idim /),nvarid)
420#endif
421      IF (LEN_TRIM(title) > 0) ierr = NF90_PUT_ATT (nid_restart,nvarid,"title", title)
422      ierr = NF90_ENDDEF(nid_restart)
423      ierr = NF90_PUT_VAR(nid_restart,nvarid,RESHAPE(field_glo,(/klon_glo*field_size/)))
424    ENDIF
425   
426   END SUBROUTINE put_field_rgen 
427 
428   SUBROUTINE put_var_r0(var_name,title,var)
429   IMPLICIT NONE
430     CHARACTER(LEN=*),INTENT(IN) :: var_name
431     CHARACTER(LEN=*),INTENT(IN) :: title
432     REAL,INTENT(IN)             :: var
433     REAL                        :: varin(1)
434     
435     varin(1)=var
436     
437     CALL put_var_rgen(var_name,title,varin,size(varin))
438
439  END SUBROUTINE put_var_r0
440
441
442   SUBROUTINE put_var_r1(var_name,title,var)
443   IMPLICIT NONE
444     CHARACTER(LEN=*),INTENT(IN) :: var_name
445     CHARACTER(LEN=*),INTENT(IN) :: title
446     REAL,INTENT(IN)             :: var(:)
447     
448     CALL put_var_rgen(var_name,title,var,size(var))
449
450  END SUBROUTINE put_var_r1
451 
452  SUBROUTINE put_var_r2(var_name,title,var)
453   IMPLICIT NONE
454     CHARACTER(LEN=*),INTENT(IN) :: var_name
455     CHARACTER(LEN=*),INTENT(IN) :: title
456     REAL,INTENT(IN)             :: var(:,:)
457     
458     CALL put_var_rgen(var_name,title,var,size(var))
459
460  END SUBROUTINE put_var_r2     
461 
462  SUBROUTINE put_var_r3(var_name,title,var)
463   IMPLICIT NONE
464     CHARACTER(LEN=*),INTENT(IN) :: var_name
465     CHARACTER(LEN=*),INTENT(IN) :: title
466     REAL,INTENT(IN)             :: var(:,:,:)
467     
468     CALL put_var_rgen(var_name,title,var,size(var))
469
470  END SUBROUTINE put_var_r3
471
472  SUBROUTINE put_var_rgen(var_name,title,var,var_size)
473  USE netcdf
474  USE dimphy
475  USE mod_phys_lmdz_para
476  IMPLICIT NONE
477     CHARACTER(LEN=*),INTENT(IN) :: var_name
478     CHARACTER(LEN=*),INTENT(IN) :: title
479     INTEGER,INTENT(IN)          :: var_size
480     REAL,INTENT(IN)             :: var(var_size)
481     
482     INTEGER :: ierr
483     INTEGER :: nvarid
484         
485    IF (is_mpi_root .AND. is_omp_root) THEN
486
487      IF (var_size/=length) THEN
488        PRINT *, "erreur phyredem : probleme de dimension"
489        call abort_physic("", "", 1)
490      ENDIF
491     
492      ierr = NF90_REDEF (nid_restart)
493
494#ifdef NC_DOUBLE
495      ierr = NF90_DEF_VAR (nid_restart, var_name, NF90_DOUBLE,(/ idim1 /),nvarid)
496#else
497      ierr = NF90_DEF_VAR (nid_restart, var_name, NF90_FLOAT,(/ idim1 /),nvarid)
498#endif
499      IF (LEN_TRIM(title)>0) ierr = NF90_PUT_ATT (nid_restart,nvarid,"title", title)
500      ierr = NF90_ENDDEF(nid_restart)
501     
502      ierr = NF90_PUT_VAR(nid_restart,nvarid,var)
503
504    ENDIF
505   
506  END SUBROUTINE put_var_rgen     
507   
508END MODULE iostart
Note: See TracBrowser for help on using the repository browser.