Context Navigation

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

Last change on this file since 803 was 707, checked in by ymipsl, 6 years ago

OpenMP fix for function xios_read_var.
Only master thread must call XIOS and the result is broadcasted to other threads.

YM

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

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

Download in other formats: