Context Navigation

← Previous Revision
Next Revision →
Blame
Revision Log

xios_mod.F90

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

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

Context Navigation

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

Download in other formats: