Context Navigation

source: codes/icosagcm/devel/src/output/xios_mod.F90 @ 879

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

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

Download in other formats: