Context Navigation

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

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

Add functionnality to input/output field of type U (value on the edges)
Management of start/restart files by XIOS

YM

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

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

Download in other formats: