Context Navigation

source: codes/icosagcm/trunk/src/xios_mod.F90 @ 492

Last change on this file since 492 was 492, checked in by ymipsl, 8 years ago

Some bugs fixed in XIOS...
=> Some modifciation in restart and read fonctionnalities.

YM

File size: 27.7 KB

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

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

Download in other formats: