source: codes/icosagcm/devel/src/output/xios_mod.F90

Last change on this file was 1026, checked in by dubos, 4 years ago

devel : towards conformity to F2008 standard
File size: 15.5 KB
Line 
1MODULE xios_mod
2 
3#ifdef CPP_USING_XIOS
4  USE xios
5#endif
6
7  USE prec, ONLY : rstd
8  USE field_mod, ONLY : t_field, field_T, field_U, field_Z
9  USE domain_mod, ONLY : t_domain, t_cellset, domain, ndomain, mesh_loc
10  USE grid_param, ONLY : grid_type, grid_unst, grid_ico
11  IMPLICIT NONE   
12  PRIVATE
13  SAVE
14
15  LOGICAL :: using_xios
16
17  INTEGER :: ncell_i, ncell_v, ncell_e
18!$OMP THREADPRIVATE(ncell_i, ncell_v, ncell_e)
19
20  PUBLIC :: using_xios, xios_init, &
21       xios_init_write_field, xios_init_write_field_input, &
22       xios_write_field_finalize, &
23       xios_write_field, xios_read_field
24
25#ifdef CPP_USING_XIOS
26
27  PUBLIC :: xios_timestep,    &
28       xios_set_file_attr, xios_set_fieldgroup_attr, &
29       xios_set_filegroup_attr, xios_get_axis_attr, &
30       xios_send_field, xios_read_var, &
31       xios_update_calendar, xios_set_context, xios_set_context_input, &
32       OPERATOR(+), OPERATOR(-), OPERATOR(*)
33 
34CONTAINS
35 
36 SUBROUTINE xios_init
37   USE mpipara, ONLY : comm_icosa
38   TYPE(xios_context) :: ctx_hdl
39
40   using_xios=.TRUE.
41   CALL xios_context_initialize("icosagcm",comm_icosa)
42   CALL xios_context_initialize("icosagcm_input",comm_icosa)
43   CALL xios_set_context
44
45 END SUBROUTINE xios_init
46
47 SUBROUTINE xios_init_write_field
48   USE disvert_mod, ONLY : presnivs
49   USE time_mod, ONLY : dt, itau_out
50   USE grid_param, ONLY : llm, nqtot
51   USE mpi_mod, ONLY : MPI_INTEGER
52
53   TYPE(xios_context) :: ctx_hdl
54   TYPE(xios_duration)      :: dtime
55   REAL(rstd) :: lev_value(llm)
56   REAL(rstd) :: lev_valuep1(llm+1)
57   REAL(rstd) :: nq_value(nqtot)
58   INTEGER :: l, ncell, ncell_tot, displ
59   REAL(rstd),ALLOCATABLE    :: lon(:), lat(:), bounds_lon(:,:), bounds_lat(:,:)
60   INTEGER, ALLOCATABLE      :: ind_glo(:)
61   TYPE(t_domain),POINTER :: d
62   
63   CALL xios_set_context
64   !$OMP BARRIER
65   !$OMP MASTER
66   !   CALL xios_context_initialize("icosagcm",comm_icosa)
67   !   CALL xios_get_handle("icosagcm",ctx_hdl)
68   !   CALL xios_set_current_context(ctx_hdl)
69   lev_value(:) = (/ (l,l=1,llm) /)     
70   lev_valuep1(:) = (/ (l,l=1,llm+1) /)     
71   nq_value(:) = (/ (l,l=1,nqtot) /)     
72   CALL xios_set_axis_attr("lev",n_glo=llm ,value=lev_value) ;
73   CALL xios_set_axis_attr("levp1",n_glo=llm+1 ,value=lev_valuep1) ;
74   CALL xios_set_axis_attr("nq",n_glo=nqtot, value=nq_value) ;
75   CALL xios_set_axis_attr("presnivs_mb",n_glo=llm, value=presnivs/100., unit="mb") ;
76
77   !------------------ primal cells ------------------
78   CALL collect_bounds(6, mesh_loc%primal_own)
79   ncell_i=ncell   
80   CALL xios_set_domaingroup_attr("i",ni_glo=ncell_tot, ibegin=displ, ni=ncell)
81   CALL xios_set_domaingroup_attr("i", data_dim=1, type='unstructured' , nvertex=6, i_index=ind_glo)
82   CALL xios_set_domaingroup_attr("i",lonvalue_1d=lon, latvalue_1d=lat, bounds_lon_1d=bounds_lon, bounds_lat_1d=bounds_lat)
83   DEALLOCATE(lon, lat, bounds_lon, bounds_lat,ind_glo) 
84   
85   !--------------------- dual cells ------------------
86   
87   CALL collect_bounds(3, mesh_loc%dual_own)
88   ncell_v=ncell
89   CALL xios_set_domain_attr("v",ni_glo=ncell_tot, ibegin=displ, ni=ncell)
90   CALL xios_set_domain_attr("v", data_dim=1, type='unstructured' , nvertex=3)
91   CALL xios_set_domain_attr("v",lonvalue_1d=lon, latvalue_1d=lat, bounds_lon_1d=bounds_lon, bounds_lat_1d=bounds_lat)
92   DEALLOCATE(lon, lat, bounds_lon, bounds_lat,ind_glo) 
93   
94   !---------------------- edges -----------------------
95   
96   CALL collect_bounds(2, mesh_loc%edge_own)
97   ncell_e=ncell
98   CALL xios_set_domain_attr("u",ni_glo=ncell_tot, ibegin=displ, ni=ncell)
99   CALL xios_set_domain_attr("u", data_dim=1, type='unstructured' , nvertex=2, i_index=ind_glo)
100   CALL xios_set_domain_attr("u",lonvalue_1d=lon, latvalue_1d=lat, bounds_lon_1d=bounds_lon, bounds_lat_1d=bounds_lat)
101   DEALLOCATE(lon, lat, bounds_lon, bounds_lat,ind_glo) 
102   
103   dtime%second=dt
104   CALL xios_set_timestep(dtime)
105   
106   CALL xios_set_fieldgroup_attr("standard_output", freq_op=itau_out*xios_timestep, freq_offset=(itau_out-1)*xios_timestep)
107   
108   CALL xios_close_context_definition()
109   !$OMP END MASTER
110   !$OMP BARRIER
111   
112 CONTAINS
113   
114   SUBROUTINE collect_bounds(nvert, cells)
115     USE mpipara, ONLY : comm_icosa, mpi_size, mpi_rank
116     INTEGER, INTENT(IN) :: nvert
117     TYPE(t_cellset)     :: cells(:)
118     INTEGER :: i, ind, n_beg, n_end, ierr, ncell_glo(0:mpi_size-1)
119     ncell = SUM(cells%ncell)
120     CALL MPI_ALLGATHER(ncell,1,MPI_INTEGER, &
121          ncell_glo,1, MPI_INTEGER, comm_icosa, ierr)
122     displ=0
123     DO i=1,mpi_rank
124        displ=displ+ncell_glo(i-1)
125     ENDDO
126     ncell_tot=sum(ncell_glo(:))
127     
128     ALLOCATE(lon(ncell), lat(ncell), ind_glo(ncell))
129     ALLOCATE(bounds_lon(nvert,ncell), bounds_lat(nvert,ncell))
130     
131     n_beg=0
132     DO ind=1,ndomain
133        n_end = n_beg + cells(ind)%ncell
134        ind_glo(n_beg+1:n_end) = cells(ind)%ind_glo(:)
135        lon(n_beg+1:n_end) = cells(ind)%lon(:)
136        lat(n_beg+1:n_end) = cells(ind)%lat(:)
137        bounds_lon(:,n_beg+1:n_end) = cells(ind)%bnds_lon(:,:)
138        bounds_lat(:,n_beg+1:n_end) = cells(ind)%bnds_lat(:,:)
139        n_beg = n_end
140     END DO
141   END SUBROUTINE collect_bounds
142   
143 END SUBROUTINE xios_init_write_field
144 
145 SUBROUTINE xios_init_write_field_input
146   USE disvert_mod,        ONLY : presnivs
147   USE time_mod,           ONLY : dt, itau_out
148   USE grid_param,         ONLY : llm, nqtot
149   USE mpi_mod,            ONLY : MPI_INTEGER
150   USE icosa,              ONLY : getin
151   USE mpipara,            ONLY : comm_icosa, mpi_rank, mpi_size
152   USE spherical_geom_mod, ONLY : xyz2lonlat
153   USE genmod
154 !USE genmod
155 !USE mpipara
156 !USE xios
157 !USE grid_param
158 !USE domain_mod
159 !USE dimensions
160 !USE spherical_geom_mod
161 !USE geometry
162 !USE mpi_mod
163 !USE time_mod
164 !USE metric, ONLY : vup,vdown, cell_glo
165 !USE icosa,ONLY  : getin
166 !IMPLICIT NONE
167  TYPE(xios_context) :: ctx_hdl
168  TYPE(xios_duration)      :: dtime
169  INTEGER :: ncell, ncell_tot, ncell_glo(0:mpi_size-1), displ
170  INTEGER :: ind, i,j,k,l,ij, ierr
171  REAL(rstd),ALLOCATABLE    :: lon(:), lat(:), bounds_lon(:,:), bounds_lat(:,:)
172  INTEGER, ALLOCATABLE      :: ind_glo(:)
173  TYPE(t_domain),POINTER :: d
174  CHARACTER(len=255) :: etat0_type
175  LOGICAL :: read_metric_
176
177   CALL xios_set_context_input
178!$OMP BARRIER
179!$OMP MASTER
180   
181   ncell=0
182   DO ind=1,ndomain
183     d=>domain(ind)
184       
185     DO j=d%jj_begin,d%jj_end
186       DO i=d%ii_begin,d%ii_end
187         IF (domain(ind)%own(i,j)) ncell=ncell+1
188       ENDDO
189     ENDDO
190   ENDDO     
191   ncell_i=ncell
192   
193   CALL MPI_ALLGATHER(ncell,1,MPI_INTEGER,ncell_glo,1,MPI_INTEGER,comm_icosa,ierr)
194
195   displ=0
196   DO i=1,mpi_rank
197     displ=displ+ncell_glo(i-1)
198   ENDDO
199
200   ncell_tot=sum(ncell_glo(:))
201   
202   ALLOCATE(lon(ncell), lat(ncell), bounds_lon(0:5,ncell), bounds_lat(0:5,ncell), ind_glo(ncell)) 
203   
204   ncell=0
205   DO ind=1,ndomain
206     d=>domain(ind)
207       
208     DO j=d%jj_begin,d%jj_end
209       DO i=d%ii_begin,d%ii_end
210         IF (domain(ind)%own(i,j)) THEN
211           ncell=ncell+1
212           CALL xyz2lonlat(d%xyz(:,i,j),lon(ncell),lat(ncell))
213           lon(ncell)=lon(ncell)*180/Pi
214           lat(ncell)=lat(ncell)*180/Pi
215           DO k=0,5
216             CALL xyz2lonlat(d%vertex(:,k,i,j),bounds_lon(k,ncell), bounds_lat(k,ncell))
217             bounds_lat(k,ncell)=bounds_lat(k,ncell)*180/Pi
218             bounds_lon(k,ncell)=bounds_lon(k,ncell)*180/Pi
219           ENDDO
220           ind_glo(ncell)=domain(ind)%assign_cell_glo(i,j)-1 
221         ENDIF
222       ENDDO
223     ENDDO
224   ENDDO         
225
226   CALL xios_set_domain_attr("i",ni_glo=ncell_tot, ibegin=displ, ni=ncell)
227   CALL xios_set_domain_attr("i", data_dim=1, type='unstructured' , nvertex=6, i_index=ind_glo)
228   CALL xios_set_domain_attr("i",lonvalue_1d=lon, latvalue_1d=lat, bounds_lon_1d=bounds_lon, bounds_lat_1d=bounds_lat)
229   
230   DEALLOCATE(lon, lat, bounds_lon, bounds_lat,ind_glo) 
231
232   dtime%second=1
233   CALL xios_set_timestep(dtime)
234!$OMP END MASTER
235
236   CALL getin('etat0',etat0_type)
237   CALL getin('read_metric', read_metric_) 
238
239!$OMP MASTER
240 
241   CALL xios_set_file_attr('start', enabled=.FALSE.)
242   IF (TRIM(etat0_type)=='start_file' .AND. read_metric_) THEN
243     CALL xios_set_file_attr('start', enabled=.TRUE.)
244   ENDIF
245     
246
247   CALL xios_close_context_definition()
248!$OMP END MASTER
249!$OMP BARRIER
250   
251 END SUBROUTINE xios_init_write_field_input 
252
253
254
255 SUBROUTINE xios_write_field(name,field)
256   CHARACTER(LEN=*),INTENT(IN) :: name
257   TYPE(t_field), POINTER :: field(:)
258   TYPE(t_cellset), POINTER :: cells(:)
259   INTEGER :: ncells
260
261!$OMP BARRIER
262!$OMP MASTER
263
264   SELECT CASE(field(1)%field_type)
265   CASE(field_T)
266      cells => mesh_loc%primal_own
267      ncells = ncell_i
268   CASE(field_U)
269      cells => mesh_loc%edge_own
270      ncells = ncell_e
271   CASE(field_Z)
272      cells => mesh_loc%dual_own
273      ncells = ncell_v
274   END SELECT
275
276   IF (field(1)%ndim>4) THEN
277      PRINT *, "xios_write_field : dimension > 4 are not supported for now"
278   ELSE
279      CALL xios_write_field_gen(name, field, cells, & 
280           ncells, field(1)%dim3, field(1)%dim4)
281   END IF
282   
283!$OMP END MASTER
284!$OMP BARRIER
285     
286 END SUBROUTINE xios_write_field
287
288
289
290 SUBROUTINE xios_read_field(name,field)
291   CHARACTER(LEN=*),INTENT(IN) :: name
292   TYPE(t_field), POINTER :: field(:)
293   TYPE(t_cellset), POINTER :: cells(:)
294   INTEGER :: ncells
295
296!$OMP BARRIER
297!$OMP MASTER
298
299   SELECT CASE(field(1)%field_type)
300   CASE(field_T)
301      cells => mesh_loc%primal_own
302      ncells = ncell_i
303   CASE(field_U)
304      cells => mesh_loc%edge_own
305      ncells = ncell_e
306   CASE(field_Z)
307      cells => mesh_loc%dual_own
308      ncells = ncell_v
309   END SELECT
310
311   IF (field(1)%ndim>4) THEN
312      PRINT *, "xios_read_field : dimension > 4 are not supported for now"
313   ELSE
314      CALL xios_read_field_hex(name, field, cells, & 
315           ncells, field(1)%dim3, field(1)%dim4)
316   END IF
317   
318!$OMP END MASTER
319!$OMP BARRIER
320     
321 END SUBROUTINE xios_read_field
322
323 SUBROUTINE xios_write_field_gen(name, field, cells, ncell_tot, nlev, nq)
324   CHARACTER(LEN=*),INTENT(IN) :: name
325   TYPE(t_field) :: field(:)
326   TYPE(t_cellset), TARGET :: cells(:)
327   INTEGER,INTENT(IN) :: ncell_tot, nlev, nq
328   REAL(rstd) :: field_tmp(ncell_tot, nlev, nq)
329   TYPE(t_cellset), POINTER :: cellset
330   INTEGER :: ind, n_beg, n, ij, sgn
331   LOGICAL :: signed
332
333   IF(ALLOCATED(cells(1)%sgn)) THEN
334      signed=.TRUE.
335   ELSE
336      signed=.FALSE.
337      sgn=1
338   END IF
339
340   n_beg=0
341   DO ind=1,ndomain
342      cellset => cells(ind)
343      DO n=1, cellset%ncell
344         ij = cellset%ij(n)
345         IF(signed) sgn = cellset%sgn(n)
346         SELECT CASE(grid_type)
347         CASE(grid_ico)
348            SELECT CASE(field(1)%ndim)
349            CASE(2)
350               field_tmp(n_beg+n,1,1) = sgn*field(ind)%rval2d(ij)
351            CASE(3)
352               field_tmp(n_beg+n,:,1) = sgn*field(ind)%rval3d(ij,:)
353            CASE(4)
354               field_tmp(n_beg+n,:,:) = sgn*field(ind)%rval4d(ij,:,:)
355            END SELECT
356         CASE(grid_unst)
357            SELECT CASE(field(1)%ndim)
358            CASE(2)
359               field_tmp(n_beg+n,1,1) = sgn*field(ind)%rval2d(ij)
360            CASE(3)
361               field_tmp(n_beg+n,:,1) = sgn*field(ind)%rval3d(:,ij)
362            CASE(4)
363               field_tmp(n_beg+n,:,:) = sgn*field(ind)%rval4d(:,ij,:)
364            END SELECT
365         END SELECT
366      END DO
367      n_beg = n_beg + cellset%ncell
368   END DO
369   CALL xios_send_field(name,field_tmp) 
370   
371 END SUBROUTINE xios_write_field_gen
372
373SUBROUTINE xios_read_field_hex(name, field, cells, ncell_tot, nlev, nq)
374   CHARACTER(LEN=*),INTENT(IN) :: name
375   TYPE(t_field), POINTER :: field(:)
376   TYPE(t_cellset), TARGET :: cells(:)
377   INTEGER,INTENT(IN) :: ncell_tot, nlev, nq
378
379   REAL(rstd) :: field_tmp(ncell_tot,nlev,nq)
380   TYPE(t_cellset), POINTER :: cellset
381   INTEGER :: ind, n_beg, n, ij, sgn
382   LOGICAL :: signed
383
384   CALL xios_recv_field(name,field_tmp)
385
386   IF(ALLOCATED(cells(1)%sgn)) THEN
387      signed=.TRUE.
388   ELSE
389      signed=.FALSE.
390      sgn=1
391   END IF
392
393
394   n_beg=0
395   DO ind=1,ndomain
396      cellset => cells(ind)
397      DO n=1, cellset%ncell
398         ij = cellset%ij(n)
399         IF(signed) sgn = cellset%sgn(n)
400         SELECT CASE(field(1)%ndim)
401         CASE(2)
402            field(ind)%rval2d(ij) = sgn*field_tmp(n_beg+n,1,1) 
403         CASE(3)
404            field(ind)%rval3d(ij,:) = sgn*field_tmp(n_beg+n,:,1)
405         CASE(4)
406            field(ind)%rval4d(ij,:,:) = sgn*field_tmp(n_beg+n,:,:)
407         END SELECT
408      END DO
409      n_beg = n_beg + cellset%ncell
410   END DO
411 END SUBROUTINE xios_read_field_hex
412
413 SUBROUTINE xios_read_var(name,field)
414   USE prec
415   USE transfert_mod
416   CHARACTER(LEN=*),INTENT(IN) :: name
417   REAL(rstd), INTENT(OUT) :: field
418   !$OMP MASTER
419   CALL xios_recv_field(name,field)
420   !$OMP END MASTER
421   CALL bcast_omp(field)
422 END SUBROUTINE
423 
424 SUBROUTINE xios_write_field_finalize
425!$OMP BARRIER
426!$OMP MASTER
427   CALL xios_context_finalize
428!$OMP END MASTER
429!$OMP BARRIER
430 END SUBROUTINE xios_write_field_finalize
431
432 SUBROUTINE xios_set_context
433  TYPE(xios_context) :: ctx_hdl
434
435!$OMP MASTER
436   CALL xios_get_handle("icosagcm",ctx_hdl)
437   CALL xios_set_current_context(ctx_hdl)
438!$OMP END MASTER
439
440  END SUBROUTINE xios_set_context
441
442 SUBROUTINE xios_set_context_input
443 IMPLICIT NONE   
444  TYPE(xios_context) :: ctx_hdl
445
446!$OMP MASTER
447   CALL xios_get_handle("icosagcm_input",ctx_hdl)
448   CALL xios_set_current_context(ctx_hdl)
449!$OMP END MASTER
450
451  END SUBROUTINE xios_set_context_input
452
453#else
454 
455
456INTERFACE xios_send_field
457  MODULE PROCEDURE xios_send_field_scalar, xios_send_field_1d
458END INTERFACE  xios_send_field
459
460INTEGER,PARAMETER :: xios_timestep=1
461
462CONTAINS 
463 
464 
465  SUBROUTINE xios_init
466    using_xios=.FALSE.   
467  END SUBROUTINE xios_init
468 
469  SUBROUTINE xios_send_field_scalar(name,field)
470    CHARACTER(LEN=*),INTENT(IN) :: name
471    REAL,INTENT(IN) :: field
472  END SUBROUTINE xios_send_field_scalar 
473
474  SUBROUTINE xios_send_field_1d(name,field)
475    CHARACTER(LEN=*),INTENT(IN) :: name
476    REAL,INTENT(IN) :: field(:)
477  END SUBROUTINE xios_send_field_1d 
478 
479  SUBROUTINE xios_write_field(name,field)
480  USE field_mod
481   CHARACTER(LEN=*),INTENT(IN) :: name
482   TYPE(t_field), POINTER :: field(:)
483  END SUBROUTINE xios_write_field
484
485  SUBROUTINE xios_read_field(name,field)
486  USE field_mod
487   CHARACTER(LEN=*),INTENT(IN) :: name
488   TYPE(t_field), POINTER :: field(:)
489  END SUBROUTINE xios_read_field
490
491 SUBROUTINE xios_read_var(name,field)
492   USE prec
493   CHARACTER(LEN=*),INTENT(IN) :: name
494   REAL(rstd), INTENT(OUT) :: field
495 END SUBROUTINE
496 
497  SUBROUTINE xios_update_calendar(step)
498   INTEGER, INTENT(IN):: step 
499  END SUBROUTINE xios_update_calendar
500
501  SUBROUTINE xios_write_field_finalize
502  END SUBROUTINE xios_write_field_finalize
503 
504  SUBROUTINE xios_init_write_field_input
505  END SUBROUTINE
506
507  SUBROUTINE xios_init_write_field
508  END SUBROUTINE xios_init_write_field 
509 
510  SUBROUTINE xios_set_context
511  END SUBROUTINE xios_set_context
512 
513  SUBROUTINE xios_set_fieldgroup_attr(name,enabled,freq_op)
514    CHARACTER(LEN=*) :: name
515    LOGICAL,OPTIONAL          :: enabled
516    INTEGER,OPTIONAL          :: freq_op
517  END SUBROUTINE xios_set_fieldgroup_attr
518
519  SUBROUTINE xios_set_filegroup_attr(name,enabled)
520    CHARACTER(LEN=*) :: name
521    LOGICAL,OPTIONAL          :: enabled
522  END SUBROUTINE xios_set_filegroup_attr
523
524  SUBROUTINE xios_set_file_attr(id,name,mode,enabled, output_freq)
525    CHARACTER(LEN=*) :: id
526    CHARACTER(LEN=*),OPTIONAL :: name, mode
527    LOGICAL,OPTIONAL          :: enabled
528    INTEGER,OPTIONAL          :: output_freq
529  END SUBROUTINE xios_set_file_attr
530
531  SUBROUTINE xios_get_axis_attr(name,n_glo,value)
532    CHARACTER(LEN=*) :: name
533    INTEGER,OPTIONAL          :: n_glo
534    REAL,OPTIONAL             :: value(:)
535  END SUBROUTINE xios_get_axis_attr
536
537  SUBROUTINE xios_set_axis_attr(id,n_glo,value)
538    CHARACTER(LEN=*) :: id
539    INTEGER,OPTIONAL          :: n_glo
540    REAL,OPTIONAL             :: value(:)
541  END SUBROUTINE xios_set_axis_attr
542
543#endif 
544
545END MODULE xios_mod
Note: See TracBrowser for help on using the repository browser.