Context Navigation

source: codes/icosagcm/trunk/src/output/xios_mod.F90 @ 882

Last change on this file since 882 was 882, checked in by ymipsl, 5 years ago

Metric is now write in start.nc/restart.nc
Metric can be read at restart if read_metric=y.

YM

File size: 31.1 KB

Line
1	MODULE xios_mod
2
3	#ifdef CPP_USING_XIOS
4	USE xios
5	#endif
6	IMPLICIT NONE
7
8	PUBLIC
9	LOGICAL,SAVE :: using_xios
10
11	INTEGER,SAVE :: ncell_i
12	!$OMP THREADPRIVATE(ncell_i)
13	INTEGER,SAVE :: ncell_v
14	!$OMP THREADPRIVATE(ncell_v)
15	INTEGER,SAVE :: ncell_e
16	!$OMP THREADPRIVATE(ncell_e)
17
18	PRIVATE ncell_i,ncell_v,ncell_e
19
20	#ifdef CPP_USING_XIOS
21
22	CONTAINS
23
24	SUBROUTINE xios_init
25	USE getin_mod
26	USE xios
27	USE mpipara
28	IMPLICIT NONE
29	TYPE(xios_context) :: ctx_hdl
30
31	using_xios=.TRUE.
32	CALL xios_context_initialize("icosagcm",comm_icosa)
33	CALL xios_context_initialize("icosagcm_input",comm_icosa)
34	CALL xios_set_context
35
36	END SUBROUTINE xios_init
37
38	SUBROUTINE xios_init_write_field
39	USE genmod
40	USE mpipara
41	USE xios
42	USE grid_param
43	USE domain_mod
44	USE dimensions
45	USE spherical_geom_mod
46	USE geometry
47	USE mpi_mod
48	USE time_mod
49	USE metric, ONLY : vup,vdown, cell_glo
50	IMPLICIT NONE
51	TYPE(xios_context) :: ctx_hdl
52	TYPE(xios_duration) :: dtime
53	REAL(rstd) :: lev_value(llm)
54	REAL(rstd) :: lev_valuep1(llm+1)
55	REAL(rstd) :: nq_value(nqtot)
56	INTEGER :: ncell, ncell_tot, ncell_glo(0:mpi_size-1), displ
57	INTEGER :: ind, i,j,k,l,ij
58	REAL(rstd),ALLOCATABLE :: lon(:), lat(:), bounds_lon(:,:), bounds_lat(:,:)
59	INTEGER, ALLOCATABLE :: ind_glo(:)
60	TYPE(t_domain),POINTER :: d
61
62	CALL xios_set_context
63	!$OMP BARRIER
64	!$OMP MASTER
65	! CALL xios_context_initialize("icosagcm",comm_icosa)
66	! CALL xios_get_handle("icosagcm",ctx_hdl)
67	! CALL xios_set_current_context(ctx_hdl)
68	lev_value(:) = (/ (l,l=1,llm) /)
69	lev_valuep1(:) = (/ (l,l=1,llm+1) /)
70	nq_value(:) = (/ (l,l=1,nqtot) /)
71	CALL xios_set_axis_attr("lev",n_glo=llm ,value=lev_value) ;
72	CALL xios_set_axis_attr("levp1",n_glo=llm+1 ,value=lev_valuep1) ;
73	CALL xios_set_axis_attr("nq",n_glo=nqtot, value=nq_value) ;
74
75	ncell=0
76	DO ind=1,ndomain
77	d=>domain(ind)
78
79	DO j=d%jj_begin,d%jj_end
80	DO i=d%ii_begin,d%ii_end
81	IF (domain(ind)%own(i,j)) ncell=ncell+1
82	ENDDO
83	ENDDO
84	ENDDO
85	ncell_i=ncell
86
87	CALL MPI_ALLGATHER(ncell,1,MPI_INTEGER,ncell_glo,1,MPI_INTEGER,comm_icosa,ierr)
88
89	displ=0
90	DO i=1,mpi_rank
91	displ=displ+ncell_glo(i-1)
92	ENDDO
93
94	ncell_tot=sum(ncell_glo(:))
95
96	ALLOCATE(lon(ncell), lat(ncell), bounds_lon(0:5,ncell), bounds_lat(0:5,ncell), ind_glo(ncell))
97
98	ncell=0
99	DO ind=1,ndomain
100	d=>domain(ind)
101
102	DO j=d%jj_begin,d%jj_end
103	DO i=d%ii_begin,d%ii_end
104	IF (domain(ind)%own(i,j)) THEN
105	ncell=ncell+1
106	CALL xyz2lonlat(d%xyz(:,i,j),lon(ncell),lat(ncell))
107	lon(ncell)=lon(ncell)*180/Pi
108	lat(ncell)=lat(ncell)*180/Pi
109	DO k=0,5
110	CALL xyz2lonlat(d%vertex(:,k,i,j),bounds_lon(k,ncell), bounds_lat(k,ncell))
111	bounds_lat(k,ncell)=bounds_lat(k,ncell)*180/Pi
112	bounds_lon(k,ncell)=bounds_lon(k,ncell)*180/Pi
113	ENDDO
114	ind_glo(ncell)=domain(ind)%assign_cell_glo(i,j)-1
115	ENDIF
116	ENDDO
117	ENDDO
118	ENDDO
119
120	CALL xios_set_domaingroup_attr("i",ni_glo=ncell_tot, ibegin=displ, ni=ncell)
121	CALL xios_set_domaingroup_attr("i", data_dim=1, type='unstructured' , nvertex=6, i_index=ind_glo)
122	CALL xios_set_domaingroup_attr("i",lonvalue_1d=lon, latvalue_1d=lat, bounds_lon_1d=bounds_lon, bounds_lat_1d=bounds_lat)
123
124	DEALLOCATE(lon, lat, bounds_lon, bounds_lat,ind_glo)
125
126
127
128	ncell=0
129	DO ind=1,ndomain
130	d=>domain(ind)
131
132	DO j=d%jj_begin,d%jj_end
133	DO i=d%ii_begin,d%ii_end
134	DO k=0,5
135	IF (d%edge_assign_domain(k,i,j)==domloc_glo_ind(ind) .AND. d%edge_assign_i(k,i,j)==i .AND. d%edge_assign_j(k,i,j)==j &
136	.AND. d%edge_assign_pos(k,i,j)==k) THEN
137	ncell=ncell+1
138	ENDIF
139	ENDDO
140	ENDDO
141	ENDDO
142	ENDDO
143	ncell_e=ncell
144
145	CALL MPI_ALLGATHER(ncell_e,1,MPI_INTEGER,ncell_glo,1,MPI_INTEGER,comm_icosa,ierr)
146	displ=0
147	DO i=1,mpi_rank
148	displ=displ+ncell_glo(i-1)
149	ENDDO
150	ncell_tot=sum(ncell_glo(:))
151
152	ALLOCATE(lon(ncell), lat(ncell), bounds_lon(0:1,ncell), bounds_lat(0:1,ncell),ind_glo(ncell))
153
154
155	ncell=0
156	DO ind=1,ndomain
157	d=>domain(ind)
158	CALL swap_dimensions(ind)
159	CALL swap_geometry(ind)
160
161	DO j=d%jj_begin,d%jj_end
162	DO i=d%ii_begin,d%ii_end
163	DO k=0,5
164	IF (d%edge_assign_domain(k,i,j)==domloc_glo_ind(ind) .AND. d%edge_assign_i(k,i,j)==i .AND. d%edge_assign_j(k,i,j)==j &
165	.AND. d%edge_assign_pos(k,i,j)==k) THEN
166	ncell=ncell+1
167	ij=(j-1)*iim+i
168
169	lon(ncell)=lon_e(ij+u_pos(k+1))*180/Pi
170	lat(ncell)=lat_e(ij+u_pos(k+1))*180/Pi
171
172	CALL xyz2lonlat(d%vertex(:,MOD((k-1)+6,6),i,j),bounds_lon(0,ncell), bounds_lat(0,ncell))
173	CALL xyz2lonlat(d%vertex(:,k,i,j),bounds_lon(1,ncell), bounds_lat(1,ncell))
174	bounds_lon(:,ncell)=bounds_lon(:,ncell)*180/Pi
175	bounds_lat(:,ncell)=bounds_lat(:,ncell)*180/Pi
176	ind_glo(ncell)=cell_glo(d%assign_cell_glo(i,j))%edge(MOD(k+d%delta(i,j)+6,6))-1
177	ENDIF
178	ENDDO
179	ENDDO
180	ENDDO
181	ENDDO
182	CALL xios_set_domain_attr("u",ni_glo=ncell_tot, ibegin=displ, ni=ncell)
183	CALL xios_set_domain_attr("u", data_dim=1, type='unstructured' , nvertex=2, i_index=ind_glo)
184	CALL xios_set_domain_attr("u",lonvalue_1d=lon, latvalue_1d=lat, bounds_lon_1d=bounds_lon, bounds_lat_1d=bounds_lat)
185
186	DEALLOCATE(lon, lat, bounds_lon, bounds_lat,ind_glo)
187
188
189	ncell=0
190	DO ind=1,ndomain
191	d=>domain(ind)
192
193	DO j=d%jj_begin+1,d%jj_end
194	DO i=d%ii_begin,d%ii_end-1
195	ncell=ncell+1
196	ENDDO
197	ENDDO
198
199	DO j=d%jj_begin,d%jj_end-1
200	DO i=d%ii_begin+1,d%ii_end
201	ncell=ncell+1
202	ENDDO
203	ENDDO
204
205	ENDDO
206
207	ncell_v=ncell
208
209	CALL MPI_ALLGATHER(ncell,1,MPI_INTEGER,ncell_glo,1,MPI_INTEGER,comm_icosa,ierr)
210
211	displ=0
212	DO i=1,mpi_rank
213	displ=displ+ncell_glo(i-1)
214	ENDDO
215
216	ncell_tot=sum(ncell_glo(:))
217
218	ALLOCATE(lon(ncell), lat(ncell), bounds_lon(0:2,ncell), bounds_lat(0:2,ncell))
219
220	ncell=0
221	DO ind=1,ndomain
222	d=>domain(ind)
223
224	DO j=d%jj_begin+1,d%jj_end
225	DO i=d%ii_begin,d%ii_end-1
226	ncell=ncell+1
227	CALL xyz2lonlat(d%vertex(:,vdown,i,j),lon(ncell),lat(ncell))
228	lon(ncell)=lon(ncell)*180/Pi
229	lat(ncell)=lat(ncell)*180/Pi
230
231	CALL xyz2lonlat(d%xyz(:,i,j),bounds_lon(0,ncell), bounds_lat(0,ncell))
232	CALL xyz2lonlat(d%xyz(:,i,j-1),bounds_lon(1,ncell), bounds_lat(1,ncell))
233	CALL xyz2lonlat(d%xyz(:,i+1,j-1),bounds_lon(2,ncell), bounds_lat(2,ncell))
234
235	DO k=0,2
236	bounds_lat(k,ncell)=bounds_lat(k,ncell)*180/Pi
237	bounds_lon(k,ncell)=bounds_lon(k,ncell)*180/Pi
238	ENDDO
239	ENDDO
240	ENDDO
241
242	DO j=d%jj_begin,d%jj_end-1
243	DO i=d%ii_begin+1,d%ii_end
244	ncell=ncell+1
245	CALL xyz2lonlat(d%vertex(:,vup,i,j),lon(ncell),lat(ncell))
246	lon(ncell)=lon(ncell)*180/Pi
247	lat(ncell)=lat(ncell)*180/Pi
248	CALL xyz2lonlat(d%xyz(:,i,j),bounds_lon(0,ncell), bounds_lat(0,ncell))
249	CALL xyz2lonlat(d%xyz(:,i,j+1),bounds_lon(1,ncell), bounds_lat(1,ncell))
250	CALL xyz2lonlat(d%xyz(:,i-1,j+1),bounds_lon(2,ncell), bounds_lat(2,ncell))
251
252	DO k=0,2
253	bounds_lat(k,ncell)=bounds_lat(k,ncell)*180/Pi
254	bounds_lon(k,ncell)=bounds_lon(k,ncell)*180/Pi
255	ENDDO
256	ENDDO
257	ENDDO
258
259	ENDDO
260
261
262	CALL xios_set_domain_attr("v",ni_glo=ncell_tot, ibegin=displ, ni=ncell)
263	CALL xios_set_domain_attr("v", data_dim=1, type='unstructured' , nvertex=3)
264	CALL xios_set_domain_attr("v",lonvalue_1d=lon, latvalue_1d=lat, bounds_lon_1d=bounds_lon, bounds_lat_1d=bounds_lat)
265
266
267	dtime%second=dt
268	CALL xios_set_timestep(dtime)
269
270	CALL xios_set_fieldgroup_attr("standard_output", freq_op=itau_outxios_timestep, freq_offset=(itau_out-1)xios_timestep)
271
272	CALL xios_close_context_definition()
273	!$OMP END MASTER
274	!$OMP BARRIER
275
276	END SUBROUTINE xios_init_write_field
277
278
279	SUBROUTINE xios_init_write_field_input
280	USE genmod
281	USE mpipara
282	USE xios
283	USE grid_param
284	USE domain_mod
285	USE dimensions
286	USE spherical_geom_mod
287	USE geometry
288	USE mpi_mod
289	USE time_mod
290	USE metric, ONLY : vup,vdown, cell_glo
291	USE icosa,ONLY : getin
292	IMPLICIT NONE
293	TYPE(xios_context) :: ctx_hdl
294	TYPE(xios_duration) :: dtime
295	INTEGER :: ncell, ncell_tot, ncell_glo(0:mpi_size-1), displ
296	INTEGER :: ind, i,j,k,l,ij
297	REAL(rstd),ALLOCATABLE :: lon(:), lat(:), bounds_lon(:,:), bounds_lat(:,:)
298	INTEGER, ALLOCATABLE :: ind_glo(:)
299	TYPE(t_domain),POINTER :: d
300	CHARACTER(len=255) :: etat0_type
301	LOGICAL :: read_metric_
302
303	CALL xios_set_context_input
304	!$OMP BARRIER
305	!$OMP MASTER
306
307	ncell=0
308	DO ind=1,ndomain
309	d=>domain(ind)
310
311	DO j=d%jj_begin,d%jj_end
312	DO i=d%ii_begin,d%ii_end
313	IF (domain(ind)%own(i,j)) ncell=ncell+1
314	ENDDO
315	ENDDO
316	ENDDO
317	ncell_i=ncell
318
319	CALL MPI_ALLGATHER(ncell,1,MPI_INTEGER,ncell_glo,1,MPI_INTEGER,comm_icosa,ierr)
320
321	displ=0
322	DO i=1,mpi_rank
323	displ=displ+ncell_glo(i-1)
324	ENDDO
325
326	ncell_tot=sum(ncell_glo(:))
327
328	ALLOCATE(lon(ncell), lat(ncell), bounds_lon(0:5,ncell), bounds_lat(0:5,ncell), ind_glo(ncell))
329
330	ncell=0
331	DO ind=1,ndomain
332	d=>domain(ind)
333
334	DO j=d%jj_begin,d%jj_end
335	DO i=d%ii_begin,d%ii_end
336	IF (domain(ind)%own(i,j)) THEN
337	ncell=ncell+1
338	CALL xyz2lonlat(d%xyz(:,i,j),lon(ncell),lat(ncell))
339	lon(ncell)=lon(ncell)*180/Pi
340	lat(ncell)=lat(ncell)*180/Pi
341	DO k=0,5
342	CALL xyz2lonlat(d%vertex(:,k,i,j),bounds_lon(k,ncell), bounds_lat(k,ncell))
343	bounds_lat(k,ncell)=bounds_lat(k,ncell)*180/Pi
344	bounds_lon(k,ncell)=bounds_lon(k,ncell)*180/Pi
345	ENDDO
346	ind_glo(ncell)=domain(ind)%assign_cell_glo(i,j)-1
347	ENDIF
348	ENDDO
349	ENDDO
350	ENDDO
351
352	CALL xios_set_domain_attr("i",ni_glo=ncell_tot, ibegin=displ, ni=ncell)
353	CALL xios_set_domain_attr("i", data_dim=1, type='unstructured' , nvertex=6, i_index=ind_glo)
354	CALL xios_set_domain_attr("i",lonvalue_1d=lon, latvalue_1d=lat, bounds_lon_1d=bounds_lon, bounds_lat_1d=bounds_lat)
355
356	DEALLOCATE(lon, lat, bounds_lon, bounds_lat,ind_glo)
357
358	dtime%second=1
359	CALL xios_set_timestep(dtime)
360
361	CALL getin('etat0',etat0_type)
362	CALL getin('read_metric', read_metric_)
363
364	CALL xios_set_file_attr('start', enabled=.FALSE.)
365	IF (TRIM(etat0_type)=='start_file' .AND. read_metric_) THEN
366	CALL xios_set_file_attr('start', enabled=.TRUE.)
367	ENDIF
368
369
370	CALL xios_close_context_definition()
371	!$OMP END MASTER
372	!$OMP BARRIER
373
374	END SUBROUTINE xios_init_write_field_input
375
376	SUBROUTINE xios_write_field(name,field)
377	USE field_mod
378	IMPLICIT NONE
379	CHARACTER(LEN=*),INTENT(IN) :: name
380	TYPE(t_field), POINTER :: field(:)
381	CHARACTER(LEN=10) :: str_number
382	INTEGER :: iq
383
384	!$OMP BARRIER
385	!$OMP MASTER
386
387	IF (Field(1)%field_type==field_T) THEN
388	IF (field(1)%ndim==2) THEN
389	CALL xios_write_field_scalar(name,field,1,1)
390	ELSE IF (field(1)%ndim==3) THEN
391	CALL xios_write_field_scalar(name,field,size(field(1)%rval3d,2),1)
392	ELSE IF (field(1)%ndim==4) THEN
393	! DO iq=1,size(field(1)%rval4d,3)
394	! WRITE(str_number,'(i10)') iq
395	! CALL xios_write_field_scalar(name//TRIM(ADJUSTL(str_number)),field,size(field(1)%rval4d,2),iq)
396	CALL xios_write_field_scalar(name,field,size(field(1)%rval4d,2),size(field(1)%rval4d,3))
397	! ENDDO
398	ELSE
399	PRINT *, "xios_write_field : dimension > 4 are not supported for now"
400	ENDIF
401
402	ELSE IF (Field(1)%field_type==field_U) THEN
403	IF (field(1)%ndim==2) THEN
404	CALL xios_write_field_U(name,field,1,1)
405	ELSE IF (field(1)%ndim==3) THEN
406	CALL xios_write_field_U(name,field,size(field(1)%rval3d,2),1)
407	ELSE IF (field(1)%ndim==4) THEN
408	CALL xios_write_field_U(name,field,size(field(1)%rval4d,2),size(field(1)%rval4d,3))
409	ELSE
410	PRINT *, "xios_write_field : dimension > 4 are not supported for now"
411	ENDIF
412
413	ELSE IF (Field(1)%field_type==field_Z) THEN
414	IF (field(1)%ndim==2) THEN
415	CALL xios_write_field_vort(name,field,1)
416	ELSE IF (field(1)%ndim==3) THEN
417	CALL xios_write_field_vort(name,field,size(field(1)%rval3d,2))
418	ELSE IF (field(1)%ndim==4) THEN
419	DO iq=1,size(field(1)%rval4d,3)
420	WRITE(str_number,'(i10)') iq
421	CALL xios_write_field_vort(name//TRIM(ADJUSTL(str_number)),field,size(field(1)%rval4d,2),iq)
422	ENDDO
423	ELSE
424	PRINT *, "xios_write_field : dimension > 4 are not supported for now"
425	ENDIF
426	ENDIF
427	!$OMP END MASTER
428	!$OMP BARRIER
429
430	END SUBROUTINE xios_write_field
431
432	SUBROUTINE xios_read_field(name,field)
433	USE field_mod
434	IMPLICIT NONE
435	CHARACTER(LEN=*),INTENT(IN) :: name
436	TYPE(t_field), POINTER :: field(:)
437	CHARACTER(LEN=10) :: str_number
438	INTEGER :: iq
439
440	!$OMP BARRIER
441	!$OMP MASTER
442
443	IF (Field(1)%field_type==field_T) THEN
444	IF (field(1)%ndim==2) THEN
445	CALL xios_read_field_scalar(name,field,1,1)
446	ELSE IF (field(1)%ndim==3) THEN
447	CALL xios_read_field_scalar(name,field,size(field(1)%rval3d,2),1)
448	ELSE IF (field(1)%ndim==4) THEN
449	! DO iq=1,size(field(1)%rval4d,3)
450	! WRITE(str_number,'(i10)') iq
451	! CALL xios_read_field_scalar(name//TRIM(ADJUSTL(str_number)),field,size(field(1)%rval4d,2),iq)
452	! ENDDO
453	CALL xios_read_field_scalar(name,field,size(field(1)%rval4d,2),size(field(1)%rval4d,3))
454	ELSE
455	PRINT *, "xios_write_field : dimension > 4 are not supported for now"
456	ENDIF
457	ELSE IF (Field(1)%field_type==field_U) THEN
458	IF (field(1)%ndim==2) THEN
459	CALL xios_read_field_u(name,field,1,1)
460	ELSE IF (field(1)%ndim==3) THEN
461	CALL xios_read_field_u(name,field,size(field(1)%rval3d,2),1)
462	ELSE IF (field(1)%ndim==4) THEN
463	CALL xios_read_field_u(name,field,size(field(1)%rval4d,2),size(field(1)%rval4d,3))
464	ELSE
465	PRINT *, "xios_write_field : dimension > 4 are not supported for now"
466	ENDIF
467	ELSE IF (Field(1)%field_type==field_Z) THEN
468	IF (field(1)%ndim==2) THEN
469	CALL xios_read_field_vort(name,field,1)
470	ELSE IF (field(1)%ndim==3) THEN
471	CALL xios_read_field_vort(name,field,size(field(1)%rval3d,2))
472	ELSE IF (field(1)%ndim==4) THEN
473	DO iq=1,size(field(1)%rval4d,3)
474	WRITE(str_number,'(i10)') iq
475	CALL xios_read_field_vort(name//TRIM(ADJUSTL(str_number)),field,size(field(1)%rval4d,2),iq)
476	ENDDO
477	ELSE
478	PRINT *, "xios_write_field : dimension > 4 are not supported for now"
479	ENDIF
480	ENDIF
481	!$OMP END MASTER
482	!$OMP BARRIER
483
484	END SUBROUTINE xios_read_field
485
486
487
488	SUBROUTINE xios_write_field_scalar(name,field,nlev,nq)
489	USE genmod
490	USE mpipara
491	USE xios
492	USE grid_param
493	USE domain_mod
494	USE dimensions
495	USE spherical_geom_mod
496	USE geometry
497	USE mpi_mod
498	IMPLICIT NONE
499	CHARACTER(LEN=*),INTENT(IN) :: name
500	TYPE(t_field), POINTER :: field(:)
501	INTEGER,INTENT(IN) :: nlev
502	INTEGER,INTENT(IN) :: nq
503
504	REAL(rstd) :: field_tmp(ncell_i,nlev,nq)
505	TYPE(t_domain),POINTER :: d
506	INTEGER :: n,i,j,ij,ind
507
508	IF (field(1)%ndim==2) THEN
509	n=0
510	DO ind=1,ndomain
511
512	d=>domain(ind)
513
514	DO j=d%jj_begin,d%jj_end
515	DO i=d%ii_begin,d%ii_end
516	IF (d%own(i,j)) THEN
517	n=n+1
518	ij=d%iim*(j-1)+i
519	field_tmp(n,1,1)=field(ind)%rval2d(ij)
520	ENDIF
521	ENDDO
522	ENDDO
523	ENDDO
524	ELSE IF (field(1)%ndim==3) THEN
525	n=0
526	DO ind=1,ndomain
527	d=>domain(ind)
528
529	DO j=d%jj_begin,d%jj_end
530	DO i=d%ii_begin,d%ii_end
531	IF (d%own(i,j)) THEN
532	n=n+1
533	ij=d%iim*(j-1)+i
534	field_tmp(n,:,1)=field(ind)%rval3d(ij,:)
535	ENDIF
536	ENDDO
537	ENDDO
538	ENDDO
539	ELSE IF (field(1)%ndim==4) THEN
540	n=0
541	DO ind=1,ndomain
542	d=>domain(ind)
543
544	DO j=d%jj_begin,d%jj_end
545	DO i=d%ii_begin,d%ii_end
546	IF (d%own(i,j)) THEN
547	n=n+1
548	ij=d%iim*(j-1)+i
549	field_tmp(n,:,:)=field(ind)%rval4d(ij,:,:)
550	ENDIF
551	ENDDO
552	ENDDO
553	ENDDO
554	ENDIF
555
556	CALL xios_send_field(name,field_tmp)
557
558	END SUBROUTINE xios_write_field_scalar
559
560
561	SUBROUTINE xios_read_var(name,field)
562	USE prec
563	USE transfert_mod
564	CHARACTER(LEN=*),INTENT(IN) :: name
565	REAL(rstd), INTENT(OUT) :: field
566	!$OMP MASTER
567	CALL xios_recv_field(name,field)
568	!$OMP END MASTER
569	CALL bcast_omp(field)
570	END SUBROUTINE
571
572	SUBROUTINE xios_read_field_scalar(name,field,nlev,nq)
573	USE genmod
574	USE mpipara
575	USE xios
576	USE grid_param
577	USE domain_mod
578	USE dimensions
579	USE spherical_geom_mod
580	USE geometry
581	USE mpi_mod
582	IMPLICIT NONE
583	CHARACTER(LEN=*),INTENT(IN) :: name
584	TYPE(t_field), POINTER :: field(:)
585	INTEGER,INTENT(IN) :: nlev
586	INTEGER,INTENT(IN) :: nq
587
588	REAL(rstd) :: field_tmp(ncell_i,nlev,nq)
589	TYPE(t_domain),POINTER :: d
590	INTEGER :: n,i,j,ij,ind
591
592	CALL xios_recv_field(name,field_tmp)
593
594	IF (field(1)%ndim==2) THEN
595	n=0
596	DO ind=1,ndomain
597
598	d=>domain(ind)
599
600	DO j=d%jj_begin,d%jj_end
601	DO i=d%ii_begin,d%ii_end
602	IF (d%own(i,j)) THEN
603	n=n+1
604	ij=d%iim*(j-1)+i
605	field(ind)%rval2d(ij)=field_tmp(n,1,1)
606	ENDIF
607	ENDDO
608	ENDDO
609	ENDDO
610	ELSE IF (field(1)%ndim==3) THEN
611	n=0
612	DO ind=1,ndomain
613	d=>domain(ind)
614
615	DO j=d%jj_begin,d%jj_end
616	DO i=d%ii_begin,d%ii_end
617	IF (d%own(i,j)) THEN
618	n=n+1
619	ij=d%iim*(j-1)+i
620	field(ind)%rval3d(ij,:)=field_tmp(n,:,1)
621	ENDIF
622	ENDDO
623	ENDDO
624	ENDDO
625	ELSE IF (field(1)%ndim==4) THEN
626	n=0
627	DO ind=1,ndomain
628	d=>domain(ind)
629
630	DO j=d%jj_begin,d%jj_end
631	DO i=d%ii_begin,d%ii_end
632	IF (d%own(i,j)) THEN
633	n=n+1
634	ij=d%iim*(j-1)+i
635	field(ind)%rval4d(ij,:,:)=field_tmp(n,:,:)
636	ENDIF
637	ENDDO
638	ENDDO
639	ENDDO
640	ENDIF
641
642	END SUBROUTINE xios_read_field_scalar
643
644	SUBROUTINE xios_write_field_U(name,field,nlev,nq)
645	USE genmod
646	USE mpipara
647	USE xios
648	USE grid_param
649	USE domain_mod
650	USE dimensions
651	USE spherical_geom_mod
652	USE geometry
653	USE mpi_mod
654	IMPLICIT NONE
655	CHARACTER(LEN=*),INTENT(IN) :: name
656	TYPE(t_field), POINTER :: field(:)
657	INTEGER,INTENT(IN) :: nlev
658	INTEGER,INTENT(IN) :: nq
659
660	REAL(rstd) :: field_tmp(ncell_e,nlev,nq)
661	TYPE(t_domain),POINTER :: d
662	INTEGER :: n,i,j,k,ij,ind
663
664	IF (field(1)%ndim==2) THEN
665	n=0
666	DO ind=1,ndomain
667	d=>domain(ind)
668	CALL swap_dimensions(ind)
669	CALL swap_geometry(ind)
670
671	DO j=d%jj_begin,d%jj_end
672	DO i=d%ii_begin,d%ii_end
673	DO k=0,5
674	IF (d%edge_assign_domain(k,i,j)==domloc_glo_ind(ind) .AND. d%edge_assign_i(k,i,j)==i .AND. d%edge_assign_j(k,i,j)==j &
675	.AND. d%edge_assign_pos(k,i,j)==k) THEN
676	n=n+1
677	ij=iim*(j-1)+i
678	Field_tmp(n,1,1)=d%edge_assign_sign(k,i,j)*field(ind)%rval2d(ij+d%u_pos(k+1))
679	ENDIF
680	ENDDO
681	ENDDO
682	ENDDO
683	ENDDO
684
685	ELSE IF (field(1)%ndim==3) THEN
686
687	n=0
688	DO ind=1,ndomain
689	d=>domain(ind)
690	CALL swap_dimensions(ind)
691	CALL swap_geometry(ind)
692
693	DO j=d%jj_begin,d%jj_end
694	DO i=d%ii_begin,d%ii_end
695	DO k=0,5
696	IF (d%edge_assign_domain(k,i,j)==domloc_glo_ind(ind) .AND. d%edge_assign_i(k,i,j)==i .AND. d%edge_assign_j(k,i,j)==j &
697	.AND. d%edge_assign_pos(k,i,j)==k) THEN
698	n=n+1
699	ij=iim*(j-1)+i
700	Field_tmp(n,:,1)=d%edge_assign_sign(k,i,j)*field(ind)%rval3d(ij+d%u_pos(k+1),:)
701	ENDIF
702	ENDDO
703	ENDDO
704	ENDDO
705	ENDDO
706
707	ELSE IF (field(1)%ndim==4) THEN
708
709	n=0
710	DO ind=1,ndomain
711	d=>domain(ind)
712	CALL swap_dimensions(ind)
713	CALL swap_geometry(ind)
714
715	DO j=d%jj_begin,d%jj_end
716	DO i=d%ii_begin,d%ii_end
717	DO k=0,5
718	IF (d%edge_assign_domain(k,i,j)==domloc_glo_ind(ind) .AND. d%edge_assign_i(k,i,j)==i .AND. d%edge_assign_j(k,i,j)==j &
719	.AND. d%edge_assign_pos(k,i,j)==k) THEN
720	n=n+1
721	ij=iim*(j-1)+i
722	Field_tmp(n,:,:)=d%edge_assign_sign(k,i,j)*field(ind)%rval4d(ij+d%u_pos(k+1),:,:)
723	ENDIF
724	ENDDO
725	ENDDO
726	ENDDO
727	ENDDO
728
729	ENDIF
730
731	CALL xios_send_field(name,field_tmp)
732
733	END SUBROUTINE xios_write_field_u
734
735
736	SUBROUTINE xios_read_field_u(name,field,nlev,nq)
737	USE genmod
738	USE mpipara
739	USE xios
740	USE grid_param
741	USE domain_mod
742	USE dimensions
743	USE spherical_geom_mod
744	USE geometry
745	USE mpi_mod
746	IMPLICIT NONE
747	CHARACTER(LEN=*),INTENT(IN) :: name
748	TYPE(t_field), POINTER :: field(:)
749	INTEGER,INTENT(IN) :: nlev
750	INTEGER,INTENT(IN) :: nq
751
752	REAL(rstd) :: field_tmp(ncell_e,nlev,nq)
753	TYPE(t_domain),POINTER :: d
754	INTEGER :: n,i,j,k,ij,ind
755
756	CALL xios_recv_field(name,field_tmp)
757
758	IF (field(1)%ndim==2) THEN
759	n=0
760	DO ind=1,ndomain
761	d=>domain(ind)
762	CALL swap_dimensions(ind)
763	CALL swap_geometry(ind)
764
765	DO j=d%jj_begin,d%jj_end
766	DO i=d%ii_begin,d%ii_end
767	DO k=0,5
768	IF (d%edge_assign_domain(k,i,j)==domloc_glo_ind(ind) .AND. d%edge_assign_i(k,i,j)==i .AND. d%edge_assign_j(k,i,j)==j &
769	.AND. d%edge_assign_pos(k,i,j)==k) THEN
770	n=n+1
771	ij=iim*(j-1)+i
772	field(ind)%rval2d(ij+d%u_pos(k+1))=Field_tmp(n,1,1)*d%edge_assign_sign(k,i,j)
773	ENDIF
774	ENDDO
775	ENDDO
776	ENDDO
777	ENDDO
778
779	ELSE IF (field(1)%ndim==3) THEN
780
781	n=0
782	DO ind=1,ndomain
783	d=>domain(ind)
784	CALL swap_dimensions(ind)
785	CALL swap_geometry(ind)
786
787	DO j=d%jj_begin,d%jj_end
788	DO i=d%ii_begin,d%ii_end
789	DO k=0,5
790	IF (d%edge_assign_domain(k,i,j)==domloc_glo_ind(ind) .AND. d%edge_assign_i(k,i,j)==i .AND. d%edge_assign_j(k,i,j)==j &
791	.AND. d%edge_assign_pos(k,i,j)==k) THEN
792	n=n+1
793	ij=iim*(j-1)+i
794	field(ind)%rval3d(ij+d%u_pos(k+1),:)=Field_tmp(n,:,1)*d%edge_assign_sign(k,i,j)
795	ENDIF
796	ENDDO
797	ENDDO
798	ENDDO
799	ENDDO
800
801	ELSE IF (field(1)%ndim==4) THEN
802
803	n=0
804	DO ind=1,ndomain
805	d=>domain(ind)
806	CALL swap_dimensions(ind)
807	CALL swap_geometry(ind)
808
809	DO j=d%jj_begin,d%jj_end
810	DO i=d%ii_begin,d%ii_end
811	DO k=0,5
812	IF (d%edge_assign_domain(k,i,j)==domloc_glo_ind(ind) .AND. d%edge_assign_i(k,i,j)==i .AND. d%edge_assign_j(k,i,j)==j &
813	.AND. d%edge_assign_pos(k,i,j)==k) THEN
814	n=n+1
815	ij=iim*(j-1)+i
816	field(ind)%rval4d(ij+d%u_pos(k+1),:,:)=Field_tmp(n,:,:)*d%edge_assign_sign(k,i,j)
817	ENDIF
818	ENDDO
819	ENDDO
820	ENDDO
821	ENDDO
822
823	ENDIF
824
825
826	END SUBROUTINE xios_read_field_u
827
828
829
830
831	SUBROUTINE xios_write_field_vort(name,field,nlev,iq)
832	USE genmod
833	USE mpipara
834	USE xios
835	USE grid_param
836	USE domain_mod
837	USE dimensions
838	USE spherical_geom_mod
839	USE geometry
840	USE mpi_mod
841	IMPLICIT NONE
842	CHARACTER(LEN=*),INTENT(IN) :: name
843	TYPE(t_field), POINTER :: field(:)
844	INTEGER,INTENT(IN) :: nlev
845	INTEGER,INTENT(IN),OPTIONAL :: iq
846
847	REAL(rstd) :: field_tmp(ncell_v,nlev)
848	TYPE(t_domain),POINTER :: d
849	INTEGER :: n,i,j,ij,ind
850
851	IF (field(1)%ndim==2) THEN
852	n=0
853	DO ind=1,ndomain
854	d=>domain(ind)
855	CALL swap_dimensions(ind)
856
857	DO j=d%jj_begin+1,d%jj_end
858	DO i=d%ii_begin,d%ii_end-1
859	n=n+1
860	ij=iim*(j-1)+i
861	Field_tmp(n,1)=field(ind)%rval2d(ij+z_down)
862	ENDDO
863	ENDDO
864
865	DO j=d%jj_begin,d%jj_end-1
866	DO i=d%ii_begin+1,d%ii_end
867	n=n+1
868	ij=iim*(j-1)+i
869	Field_tmp(n,1)=field(ind)%rval2d(ij+z_up)
870	ENDDO
871	ENDDO
872
873	ENDDO
874
875	ELSE IF (field(1)%ndim==3) THEN
876	n=0
877	DO ind=1,ndomain
878	d=>domain(ind)
879	CALL swap_dimensions(ind)
880
881	DO j=d%jj_begin+1,d%jj_end
882	DO i=d%ii_begin,d%ii_end-1
883	n=n+1
884	ij=iim*(j-1)+i
885	Field_tmp(n,:)=field(ind)%rval3d(ij+z_down,:)
886	ENDDO
887	ENDDO
888
889	DO j=d%jj_begin,d%jj_end-1
890	DO i=d%ii_begin+1,d%ii_end
891	n=n+1
892	ij=iim*(j-1)+i
893	Field_tmp(n,:)=field(ind)%rval3d(ij+z_up,:)
894	ENDDO
895	ENDDO
896
897	ENDDO
898
899	ELSE IF (field(1)%ndim==4) THEN
900	n=0
901	DO ind=1,ndomain
902	d=>domain(ind)
903	CALL swap_dimensions(ind)
904
905	DO j=d%jj_begin+1,d%jj_end
906	DO i=d%ii_begin,d%ii_end-1
907	n=n+1
908	ij=iim*(j-1)+i
909	Field_tmp(n,:)=field(ind)%rval4d(ij+z_down,:,iq)
910	ENDDO
911	ENDDO
912
913	DO j=d%jj_begin,d%jj_end-1
914	DO i=d%ii_begin+1,d%ii_end
915	n=n+1
916	ij=iim*(j-1)+i
917	Field_tmp(n,:)=field(ind)%rval4d(ij+z_up,:,iq)
918	ENDDO
919	ENDDO
920
921	ENDDO
922
923	ENDIF
924
925	CALL xios_send_field(name,field_tmp)
926
927	END SUBROUTINE xios_write_field_vort
928
929	SUBROUTINE xios_read_field_vort(name,field,nlev,iq)
930	USE genmod
931	USE mpipara
932	USE xios
933	USE grid_param
934	USE domain_mod
935	USE dimensions
936	USE spherical_geom_mod
937	USE geometry
938	USE mpi_mod
939	IMPLICIT NONE
940	CHARACTER(LEN=*),INTENT(IN) :: name
941	TYPE(t_field), POINTER :: field(:)
942	INTEGER,INTENT(IN) :: nlev
943	INTEGER,INTENT(IN),OPTIONAL :: iq
944
945	REAL(rstd) :: field_tmp(ncell_v,nlev)
946	TYPE(t_domain),POINTER :: d
947	INTEGER :: n,i,j,ij,ind
948
949	CALL xios_recv_field(name,field_tmp)
950
951
952	IF (field(1)%ndim==2) THEN
953	n=0
954	DO ind=1,ndomain
955	d=>domain(ind)
956	CALL swap_dimensions(ind)
957
958	DO j=d%jj_begin+1,d%jj_end
959	DO i=d%ii_begin,d%ii_end-1
960	n=n+1
961	ij=iim*(j-1)+i
962	field(ind)%rval2d(ij+z_down)=Field_tmp(n,1)
963	ENDDO
964	ENDDO
965
966	DO j=d%jj_begin,d%jj_end-1
967	DO i=d%ii_begin+1,d%ii_end
968	n=n+1
969	ij=iim*(j-1)+i
970	Field_tmp(n,1)=field(ind)%rval2d(ij+z_up)
971	field(ind)%rval2d(ij+z_up)=Field_tmp(n,1)
972	ENDDO
973	ENDDO
974
975	ENDDO
976
977	ELSE IF (field(1)%ndim==3) THEN
978	n=0
979	DO ind=1,ndomain
980	d=>domain(ind)
981	CALL swap_dimensions(ind)
982
983	DO j=d%jj_begin+1,d%jj_end
984	DO i=d%ii_begin,d%ii_end-1
985	n=n+1
986	ij=iim*(j-1)+i
987	field(ind)%rval3d(ij+z_down,:)=Field_tmp(n,:)
988	ENDDO
989	ENDDO
990
991	DO j=d%jj_begin,d%jj_end-1
992	DO i=d%ii_begin+1,d%ii_end
993	n=n+1
994	ij=iim*(j-1)+i
995	field(ind)%rval3d(ij+z_up,:)=Field_tmp(n,:)
996	ENDDO
997	ENDDO
998
999	ENDDO
1000
1001	ELSE IF (field(1)%ndim==4) THEN
1002	n=0
1003	DO ind=1,ndomain
1004	d=>domain(ind)
1005	CALL swap_dimensions(ind)
1006
1007	DO j=d%jj_begin+1,d%jj_end
1008	DO i=d%ii_begin,d%ii_end-1
1009	n=n+1
1010	ij=iim*(j-1)+i
1011	field(ind)%rval4d(ij+z_down,:,iq)=Field_tmp(n,:)
1012	ENDDO
1013	ENDDO
1014
1015	DO j=d%jj_begin,d%jj_end-1
1016	DO i=d%ii_begin+1,d%ii_end
1017	n=n+1
1018	ij=iim*(j-1)+i
1019	field(ind)%rval4d(ij+z_up,:,iq)=Field_tmp(n,:)
1020	ENDDO
1021	ENDDO
1022
1023	ENDDO
1024
1025	ENDIF
1026
1027	END SUBROUTINE xios_read_field_vort
1028
1029
1030
1031
1032
1033	SUBROUTINE xios_write_field_finalize
1034	IMPLICIT NONE
1035
1036	!$OMP BARRIER
1037	!$OMP MASTER
1038	CALL xios_context_finalize
1039	!$OMP END MASTER
1040	!$OMP BARRIER
1041
1042	END SUBROUTINE xios_write_field_finalize
1043
1044	SUBROUTINE xios_set_context
1045	IMPLICIT NONE
1046	TYPE(xios_context) :: ctx_hdl
1047
1048	!$OMP MASTER
1049	CALL xios_get_handle("icosagcm",ctx_hdl)
1050	CALL xios_set_current_context(ctx_hdl)
1051	!$OMP END MASTER
1052
1053	END SUBROUTINE xios_set_context
1054
1055	SUBROUTINE xios_set_context_input
1056	IMPLICIT NONE
1057	TYPE(xios_context) :: ctx_hdl
1058
1059	!$OMP MASTER
1060	CALL xios_get_handle("icosagcm_input",ctx_hdl)
1061	CALL xios_set_current_context(ctx_hdl)
1062	!$OMP END MASTER
1063
1064	END SUBROUTINE xios_set_context_input
1065
1066
1067	#else
1068
1069
1070	INTERFACE xios_send_field
1071	MODULE PROCEDURE xios_send_field_scalar, xios_send_field_1d
1072	END INTERFACE xios_send_field
1073
1074	INTEGER,PARAMETER :: xios_timestep=1
1075
1076	CONTAINS
1077
1078
1079	SUBROUTINE xios_init
1080	IMPLICIT NONE
1081
1082	using_xios=.FALSE.
1083
1084	END SUBROUTINE xios_init
1085
1086	SUBROUTINE xios_send_field_scalar(name,field)
1087	IMPLICIT NONE
1088	CHARACTER(LEN=*),INTENT(IN) :: name
1089	REAL,INTENT(IN) :: field
1090	END SUBROUTINE xios_send_field_scalar
1091
1092	SUBROUTINE xios_send_field_1d(name,field)
1093	IMPLICIT NONE
1094	CHARACTER(LEN=*),INTENT(IN) :: name
1095	REAL,INTENT(IN) :: field(:)
1096	END SUBROUTINE xios_send_field_1d
1097
1098	SUBROUTINE xios_write_field(name,field)
1099	USE field_mod
1100	IMPLICIT NONE
1101	CHARACTER(LEN=*),INTENT(IN) :: name
1102	TYPE(t_field), POINTER :: field(:)
1103	END SUBROUTINE xios_write_field
1104
1105	SUBROUTINE xios_read_field(name,field)
1106	USE field_mod
1107	IMPLICIT NONE
1108	CHARACTER(LEN=*),INTENT(IN) :: name
1109	TYPE(t_field), POINTER :: field(:)
1110	END SUBROUTINE xios_read_field
1111
1112	SUBROUTINE xios_read_var(name,field)
1113	USE prec
1114	CHARACTER(LEN=*),INTENT(IN) :: name
1115	REAL(rstd), INTENT(OUT) :: field
1116	END SUBROUTINE
1117
1118	SUBROUTINE xios_update_calendar(step)
1119	IMPLICIT NONE
1120	INTEGER, INTENT(IN):: step
1121	END SUBROUTINE xios_update_calendar
1122
1123	SUBROUTINE xios_write_field_finalize
1124	END SUBROUTINE xios_write_field_finalize
1125
1126	SUBROUTINE xios_init_write_field
1127	END SUBROUTINE xios_init_write_field
1128
1129	SUBROUTINE xios_set_context
1130	END SUBROUTINE xios_set_context
1131
1132	SUBROUTINE xios_set_context_input
1133	END SUBROUTINE xios_set_context_input
1134
1135	SUBROUTINE xios_set_fieldgroup_attr(name,enabled,freq_op)
1136	CHARACTER(LEN=*) :: name
1137	LOGICAL,OPTIONAL :: enabled
1138	INTEGER,OPTIONAL :: freq_op
1139	END SUBROUTINE xios_set_fieldgroup_attr
1140
1141	SUBROUTINE xios_set_filegroup_attr(name,enabled)
1142	CHARACTER(LEN=*) :: name
1143	LOGICAL,OPTIONAL :: enabled
1144	END SUBROUTINE xios_set_filegroup_attr
1145
1146	SUBROUTINE xios_set_file_attr(id,name,mode,enabled, output_freq)
1147	CHARACTER(LEN=*) :: id
1148	CHARACTER(LEN=*),OPTIONAL :: name, mode
1149	LOGICAL,OPTIONAL :: enabled
1150	INTEGER,OPTIONAL :: output_freq
1151	END SUBROUTINE xios_set_file_attr
1152
1153	SUBROUTINE xios_get_axis_attr(name,n_glo,value)
1154	CHARACTER(LEN=*) :: name
1155	INTEGER,OPTIONAL :: n_glo
1156	REAL,OPTIONAL :: value(:)
1157	END SUBROUTINE xios_get_axis_attr
1158
1159	SUBROUTINE xios_set_axis_attr(id,n_glo,value)
1160	CHARACTER(LEN=*) :: id
1161	INTEGER,OPTIONAL :: n_glo
1162	REAL,OPTIONAL :: value(:)
1163	END SUBROUTINE xios_set_axis_attr
1164
1165	#endif
1166
1167	END MODULE xios_mod

Note: See TracBrowser for help on using the repository browser.

Download in other formats: