Context Navigation

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

Last change on this file since 521 was 505, checked in by dubos, 7 years ago
Allow compilation without XIOS
File size: 28.0 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	CHARACTER(LEN=*),INTENT(IN) :: name
466	REAL(rstd), INTENT(OUT) :: field
467	CALL xios_recv_field(name,field)
468	END SUBROUTINE
469
470	SUBROUTINE xios_read_field_scalar(name,field,nlev,nq)
471	USE genmod
472	USE mpipara
473	USE xios
474	USE grid_param
475	USE domain_mod
476	USE dimensions
477	USE spherical_geom_mod
478	USE geometry
479	USE mpi_mod
480	IMPLICIT NONE
481	CHARACTER(LEN=*),INTENT(IN) :: name
482	TYPE(t_field), POINTER :: field(:)
483	INTEGER,INTENT(IN) :: nlev
484	INTEGER,INTENT(IN) :: nq
485
486	REAL(rstd) :: field_tmp(ncell_i,nlev,nq)
487	TYPE(t_domain),POINTER :: d
488	INTEGER :: n,i,j,ij,ind
489
490	CALL xios_recv_field(name,field_tmp)
491
492	IF (field(1)%ndim==2) THEN
493	n=0
494	DO ind=1,ndomain
495
496	d=>domain(ind)
497
498	DO j=d%jj_begin,d%jj_end
499	DO i=d%ii_begin,d%ii_end
500	IF (d%own(i,j)) THEN
501	n=n+1
502	ij=d%iim*(j-1)+i
503	field(ind)%rval2d(ij)=field_tmp(n,1,1)
504	ENDIF
505	ENDDO
506	ENDDO
507	ENDDO
508	ELSE IF (field(1)%ndim==3) THEN
509	n=0
510	DO ind=1,ndomain
511	d=>domain(ind)
512
513	DO j=d%jj_begin,d%jj_end
514	DO i=d%ii_begin,d%ii_end
515	IF (d%own(i,j)) THEN
516	n=n+1
517	ij=d%iim*(j-1)+i
518	field(ind)%rval3d(ij,:)=field_tmp(n,:,1)
519	ENDIF
520	ENDDO
521	ENDDO
522	ENDDO
523	ELSE IF (field(1)%ndim==4) THEN
524	n=0
525	DO ind=1,ndomain
526	d=>domain(ind)
527
528	DO j=d%jj_begin,d%jj_end
529	DO i=d%ii_begin,d%ii_end
530	IF (d%own(i,j)) THEN
531	n=n+1
532	ij=d%iim*(j-1)+i
533	field(ind)%rval4d(ij,:,:)=field_tmp(n,:,:)
534	ENDIF
535	ENDDO
536	ENDDO
537	ENDDO
538	ENDIF
539
540	END SUBROUTINE xios_read_field_scalar
541
542	SUBROUTINE xios_write_field_U(name,field,nlev,nq)
543	USE genmod
544	USE mpipara
545	USE xios
546	USE grid_param
547	USE domain_mod
548	USE dimensions
549	USE spherical_geom_mod
550	USE geometry
551	USE mpi_mod
552	IMPLICIT NONE
553	CHARACTER(LEN=*),INTENT(IN) :: name
554	TYPE(t_field), POINTER :: field(:)
555	INTEGER,INTENT(IN) :: nlev
556	INTEGER,INTENT(IN) :: nq
557
558	REAL(rstd) :: field_tmp(ncell_e,nlev,nq)
559	TYPE(t_domain),POINTER :: d
560	INTEGER :: n,i,j,k,ij,ind
561
562	IF (field(1)%ndim==2) THEN
563	n=0
564	DO ind=1,ndomain
565	d=>domain(ind)
566	CALL swap_dimensions(ind)
567	CALL swap_geometry(ind)
568
569	DO j=d%jj_begin,d%jj_end
570	DO i=d%ii_begin,d%ii_end
571	DO k=0,5
572	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 &
573	.AND. d%edge_assign_pos(k,i,j)==k) THEN
574	n=n+1
575	ij=iim*(j-1)+i
576	Field_tmp(n,1,1)=d%edge_assign_sign(k,i,j)*field(ind)%rval2d(ij+d%u_pos(k+1))
577	ENDIF
578	ENDDO
579	ENDDO
580	ENDDO
581	ENDDO
582
583	ELSE IF (field(1)%ndim==3) THEN
584
585	n=0
586	DO ind=1,ndomain
587	d=>domain(ind)
588	CALL swap_dimensions(ind)
589	CALL swap_geometry(ind)
590
591	DO j=d%jj_begin,d%jj_end
592	DO i=d%ii_begin,d%ii_end
593	DO k=0,5
594	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 &
595	.AND. d%edge_assign_pos(k,i,j)==k) THEN
596	n=n+1
597	ij=iim*(j-1)+i
598	Field_tmp(n,:,1)=d%edge_assign_sign(k,i,j)*field(ind)%rval3d(ij+d%u_pos(k+1),:)
599	ENDIF
600	ENDDO
601	ENDDO
602	ENDDO
603	ENDDO
604
605	ELSE IF (field(1)%ndim==4) THEN
606
607	n=0
608	DO ind=1,ndomain
609	d=>domain(ind)
610	CALL swap_dimensions(ind)
611	CALL swap_geometry(ind)
612
613	DO j=d%jj_begin,d%jj_end
614	DO i=d%ii_begin,d%ii_end
615	DO k=0,5
616	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 &
617	.AND. d%edge_assign_pos(k,i,j)==k) THEN
618	n=n+1
619	ij=iim*(j-1)+i
620	Field_tmp(n,:,:)=d%edge_assign_sign(k,i,j)*field(ind)%rval4d(ij+d%u_pos(k+1),:,:)
621	ENDIF
622	ENDDO
623	ENDDO
624	ENDDO
625	ENDDO
626
627	ENDIF
628
629	CALL xios_send_field(name,field_tmp)
630
631	END SUBROUTINE xios_write_field_u
632
633
634	SUBROUTINE xios_read_field_u(name,field,nlev,nq)
635	USE genmod
636	USE mpipara
637	USE xios
638	USE grid_param
639	USE domain_mod
640	USE dimensions
641	USE spherical_geom_mod
642	USE geometry
643	USE mpi_mod
644	IMPLICIT NONE
645	CHARACTER(LEN=*),INTENT(IN) :: name
646	TYPE(t_field), POINTER :: field(:)
647	INTEGER,INTENT(IN) :: nlev
648	INTEGER,INTENT(IN) :: nq
649
650	REAL(rstd) :: field_tmp(ncell_e,nlev,nq)
651	TYPE(t_domain),POINTER :: d
652	INTEGER :: n,i,j,k,ij,ind
653
654	CALL xios_recv_field(name,field_tmp)
655
656	IF (field(1)%ndim==2) THEN
657	n=0
658	DO ind=1,ndomain
659	d=>domain(ind)
660	CALL swap_dimensions(ind)
661	CALL swap_geometry(ind)
662
663	DO j=d%jj_begin,d%jj_end
664	DO i=d%ii_begin,d%ii_end
665	DO k=0,5
666	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 &
667	.AND. d%edge_assign_pos(k,i,j)==k) THEN
668	n=n+1
669	ij=iim*(j-1)+i
670	field(ind)%rval2d(ij+d%u_pos(k+1))=Field_tmp(n,1,1)*d%edge_assign_sign(k,i,j)
671	ENDIF
672	ENDDO
673	ENDDO
674	ENDDO
675	ENDDO
676
677	ELSE IF (field(1)%ndim==3) THEN
678
679	n=0
680	DO ind=1,ndomain
681	d=>domain(ind)
682	CALL swap_dimensions(ind)
683	CALL swap_geometry(ind)
684
685	DO j=d%jj_begin,d%jj_end
686	DO i=d%ii_begin,d%ii_end
687	DO k=0,5
688	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 &
689	.AND. d%edge_assign_pos(k,i,j)==k) THEN
690	n=n+1
691	ij=iim*(j-1)+i
692	field(ind)%rval3d(ij+d%u_pos(k+1),:)=Field_tmp(n,:,1)*d%edge_assign_sign(k,i,j)
693	ENDIF
694	ENDDO
695	ENDDO
696	ENDDO
697	ENDDO
698
699	ELSE IF (field(1)%ndim==4) THEN
700
701	n=0
702	DO ind=1,ndomain
703	d=>domain(ind)
704	CALL swap_dimensions(ind)
705	CALL swap_geometry(ind)
706
707	DO j=d%jj_begin,d%jj_end
708	DO i=d%ii_begin,d%ii_end
709	DO k=0,5
710	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 &
711	.AND. d%edge_assign_pos(k,i,j)==k) THEN
712	n=n+1
713	ij=iim*(j-1)+i
714	field(ind)%rval4d(ij+d%u_pos(k+1),:,:)=Field_tmp(n,:,:)*d%edge_assign_sign(k,i,j)
715	ENDIF
716	ENDDO
717	ENDDO
718	ENDDO
719	ENDDO
720
721	ENDIF
722
723
724	END SUBROUTINE xios_read_field_u
725
726
727
728
729	SUBROUTINE xios_write_field_vort(name,field,nlev,iq)
730	USE genmod
731	USE mpipara
732	USE xios
733	USE grid_param
734	USE domain_mod
735	USE dimensions
736	USE spherical_geom_mod
737	USE geometry
738	USE mpi_mod
739	IMPLICIT NONE
740	CHARACTER(LEN=*),INTENT(IN) :: name
741	TYPE(t_field), POINTER :: field(:)
742	INTEGER,INTENT(IN) :: nlev
743	INTEGER,INTENT(IN),OPTIONAL :: iq
744
745	REAL(rstd) :: field_tmp(ncell_v,nlev)
746	TYPE(t_domain),POINTER :: d
747	INTEGER :: n,i,j,ij,ind
748
749	IF (field(1)%ndim==2) THEN
750	n=0
751	DO ind=1,ndomain
752	d=>domain(ind)
753	CALL swap_dimensions(ind)
754
755	DO j=d%jj_begin+1,d%jj_end
756	DO i=d%ii_begin,d%ii_end-1
757	n=n+1
758	ij=iim*(j-1)+i
759	Field_tmp(n,1)=field(ind)%rval2d(ij+z_down)
760	ENDDO
761	ENDDO
762
763	DO j=d%jj_begin,d%jj_end-1
764	DO i=d%ii_begin+1,d%ii_end
765	n=n+1
766	ij=iim*(j-1)+i
767	Field_tmp(n,1)=field(ind)%rval2d(ij+z_up)
768	ENDDO
769	ENDDO
770
771	ENDDO
772
773	ELSE IF (field(1)%ndim==3) THEN
774	n=0
775	DO ind=1,ndomain
776	d=>domain(ind)
777	CALL swap_dimensions(ind)
778
779	DO j=d%jj_begin+1,d%jj_end
780	DO i=d%ii_begin,d%ii_end-1
781	n=n+1
782	ij=iim*(j-1)+i
783	Field_tmp(n,:)=field(ind)%rval3d(ij+z_down,:)
784	ENDDO
785	ENDDO
786
787	DO j=d%jj_begin,d%jj_end-1
788	DO i=d%ii_begin+1,d%ii_end
789	n=n+1
790	ij=iim*(j-1)+i
791	Field_tmp(n,:)=field(ind)%rval3d(ij+z_up,:)
792	ENDDO
793	ENDDO
794
795	ENDDO
796
797	ELSE IF (field(1)%ndim==4) THEN
798	n=0
799	DO ind=1,ndomain
800	d=>domain(ind)
801	CALL swap_dimensions(ind)
802
803	DO j=d%jj_begin+1,d%jj_end
804	DO i=d%ii_begin,d%ii_end-1
805	n=n+1
806	ij=iim*(j-1)+i
807	Field_tmp(n,:)=field(ind)%rval4d(ij+z_down,:,iq)
808	ENDDO
809	ENDDO
810
811	DO j=d%jj_begin,d%jj_end-1
812	DO i=d%ii_begin+1,d%ii_end
813	n=n+1
814	ij=iim*(j-1)+i
815	Field_tmp(n,:)=field(ind)%rval4d(ij+z_up,:,iq)
816	ENDDO
817	ENDDO
818
819	ENDDO
820
821	ENDIF
822
823	CALL xios_send_field(name,field_tmp)
824
825	END SUBROUTINE xios_write_field_vort
826
827	SUBROUTINE xios_read_field_vort(name,field,nlev,iq)
828	USE genmod
829	USE mpipara
830	USE xios
831	USE grid_param
832	USE domain_mod
833	USE dimensions
834	USE spherical_geom_mod
835	USE geometry
836	USE mpi_mod
837	IMPLICIT NONE
838	CHARACTER(LEN=*),INTENT(IN) :: name
839	TYPE(t_field), POINTER :: field(:)
840	INTEGER,INTENT(IN) :: nlev
841	INTEGER,INTENT(IN),OPTIONAL :: iq
842
843	REAL(rstd) :: field_tmp(ncell_v,nlev)
844	TYPE(t_domain),POINTER :: d
845	INTEGER :: n,i,j,ij,ind
846
847	CALL xios_recv_field(name,field_tmp)
848
849
850	IF (field(1)%ndim==2) THEN
851	n=0
852	DO ind=1,ndomain
853	d=>domain(ind)
854	CALL swap_dimensions(ind)
855
856	DO j=d%jj_begin+1,d%jj_end
857	DO i=d%ii_begin,d%ii_end-1
858	n=n+1
859	ij=iim*(j-1)+i
860	field(ind)%rval2d(ij+z_down)=Field_tmp(n,1)
861	ENDDO
862	ENDDO
863
864	DO j=d%jj_begin,d%jj_end-1
865	DO i=d%ii_begin+1,d%ii_end
866	n=n+1
867	ij=iim*(j-1)+i
868	Field_tmp(n,1)=field(ind)%rval2d(ij+z_up)
869	field(ind)%rval2d(ij+z_up)=Field_tmp(n,1)
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(ind)%rval3d(ij+z_down,:)=Field_tmp(n,:)
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(ind)%rval3d(ij+z_up,:)=Field_tmp(n,:)
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(ind)%rval4d(ij+z_down,:,iq)=Field_tmp(n,:)
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(ind)%rval4d(ij+z_up,:,iq)=Field_tmp(n,:)
918	ENDDO
919	ENDDO
920
921	ENDDO
922
923	ENDIF
924
925	END SUBROUTINE xios_read_field_vort
926
927
928
929
930
931	SUBROUTINE xios_write_field_finalize
932	IMPLICIT NONE
933
934	!$OMP BARRIER
935	!$OMP MASTER
936	CALL xios_context_finalize
937	!$OMP END MASTER
938	!$OMP BARRIER
939
940	END SUBROUTINE xios_write_field_finalize
941
942	SUBROUTINE xios_set_context
943	IMPLICIT NONE
944	TYPE(xios_context) :: ctx_hdl
945
946	!$OMP MASTER
947	CALL xios_get_handle("icosagcm",ctx_hdl)
948	CALL xios_set_current_context(ctx_hdl)
949	!$OMP END MASTER
950
951	END SUBROUTINE xios_set_context
952
953
954	#else
955
956
957	INTERFACE xios_send_field
958	MODULE PROCEDURE xios_send_field_scalar, xios_send_field_1d
959	END INTERFACE xios_send_field
960
961	INTEGER,PARAMETER :: xios_timestep=1
962
963	CONTAINS
964
965
966	SUBROUTINE xios_init
967	IMPLICIT NONE
968
969	using_xios=.FALSE.
970
971	END SUBROUTINE xios_init
972
973	SUBROUTINE xios_send_field_scalar(name,field)
974	IMPLICIT NONE
975	CHARACTER(LEN=*),INTENT(IN) :: name
976	REAL,INTENT(IN) :: field
977	END SUBROUTINE xios_send_field_scalar
978
979	SUBROUTINE xios_send_field_1d(name,field)
980	IMPLICIT NONE
981	CHARACTER(LEN=*),INTENT(IN) :: name
982	REAL,INTENT(IN) :: field(:)
983	END SUBROUTINE xios_send_field_1d
984
985	SUBROUTINE xios_write_field(name,field)
986	USE field_mod
987	IMPLICIT NONE
988	CHARACTER(LEN=*),INTENT(IN) :: name
989	TYPE(t_field), POINTER :: field(:)
990	END SUBROUTINE xios_write_field
991
992	SUBROUTINE xios_read_field(name,field)
993	USE field_mod
994	IMPLICIT NONE
995	CHARACTER(LEN=*),INTENT(IN) :: name
996	TYPE(t_field), POINTER :: field(:)
997	END SUBROUTINE xios_read_field
998
999	SUBROUTINE xios_read_var(name,field)
1000	USE prec
1001	CHARACTER(LEN=*),INTENT(IN) :: name
1002	REAL(rstd), INTENT(OUT) :: field
1003	END SUBROUTINE
1004
1005	SUBROUTINE xios_update_calendar(step)
1006	IMPLICIT NONE
1007	INTEGER, INTENT(IN):: step
1008	END SUBROUTINE xios_update_calendar
1009
1010	SUBROUTINE xios_write_field_finalize
1011	END SUBROUTINE xios_write_field_finalize
1012
1013	SUBROUTINE xios_init_write_field
1014	END SUBROUTINE xios_init_write_field
1015
1016	SUBROUTINE xios_set_context
1017	END SUBROUTINE xios_set_context
1018
1019	SUBROUTINE xios_set_fieldgroup_attr(name,enabled,freq_op)
1020	CHARACTER(LEN=*) :: name
1021	LOGICAL,OPTIONAL :: enabled
1022	INTEGER,OPTIONAL :: freq_op
1023	END SUBROUTINE xios_set_fieldgroup_attr
1024
1025	SUBROUTINE xios_set_filegroup_attr(name,enabled)
1026	CHARACTER(LEN=*) :: name
1027	LOGICAL,OPTIONAL :: enabled
1028	END SUBROUTINE xios_set_filegroup_attr
1029
1030	SUBROUTINE xios_set_file_attr(id,name,enabled, output_freq)
1031	CHARACTER(LEN=*) :: id
1032	CHARACTER(LEN=*),OPTIONAL :: name
1033	LOGICAL,OPTIONAL :: enabled
1034	INTEGER,OPTIONAL :: output_freq
1035	END SUBROUTINE xios_set_file_attr
1036
1037	SUBROUTINE xios_get_axis_attr(name,n_glo,value)
1038	CHARACTER(LEN=*) :: name
1039	INTEGER,OPTIONAL :: n_glo
1040	REAL,OPTIONAL :: value(:)
1041	END SUBROUTINE xios_get_axis_attr
1042
1043	SUBROUTINE xios_set_axis_attr(id,n_glo,value)
1044	CHARACTER(LEN=*) :: id
1045	INTEGER,OPTIONAL :: n_glo
1046	REAL,OPTIONAL :: value(:)
1047	END SUBROUTINE xios_set_axis_attr
1048
1049	#endif
1050
1051	END MODULE xios_mod

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

Download in other formats: