Context Navigation

iophy.F90 @ 1198

Last change on this file since 1198 was 892, checked in by slebonnois, 12 years ago
SL: Important commit ! Adaptation of Venus physics to parallel computation / template for arch on the LMD servers using ifort / documentation for 1D column physics and for parallel computations
File size: 12.6 KB

Line
1	!
2	! $Header$
3	!
4	module iophy
5
6	! abd REAL,private,allocatable,dimension(:),save :: io_lat
7	! abd REAL,private,allocatable,dimension(:),save :: io_lon
8	REAL,allocatable,dimension(:),save :: io_lat
9	REAL,allocatable,dimension(:),save :: io_lon
10	INTEGER, save :: phys_domain_id
11	INTEGER, save :: npstn
12	INTEGER, allocatable, dimension(:), save :: nptabij
13
14	INTERFACE histwrite_phy
15	MODULE PROCEDURE histwrite2d_phy,histwrite3d_phy
16	END INTERFACE
17
18	INTERFACE histbeg_phy_all
19	MODULE PROCEDURE histbeg_phy,histbeg_phy_points
20	END INTERFACE
21
22
23	contains
24
25	subroutine init_iophy_new(rlat,rlon)
26	USE dimphy
27	USE mod_phys_lmdz_para
28	USE mod_grid_phy_lmdz
29	USE ioipsl
30	implicit none
31	include 'dimensions.h'
32	real,dimension(klon),intent(in) :: rlon
33	real,dimension(klon),intent(in) :: rlat
34
35	REAL,dimension(klon_glo) :: rlat_glo
36	REAL,dimension(klon_glo) :: rlon_glo
37
38	INTEGER,DIMENSION(2) :: ddid
39	INTEGER,DIMENSION(2) :: dsg
40	INTEGER,DIMENSION(2) :: dsl
41	INTEGER,DIMENSION(2) :: dpf
42	INTEGER,DIMENSION(2) :: dpl
43	INTEGER,DIMENSION(2) :: dhs
44	INTEGER,DIMENSION(2) :: dhe
45	INTEGER :: i
46
47	CALL gather(rlat,rlat_glo)
48	CALL bcast(rlat_glo)
49	CALL gather(rlon,rlon_glo)
50	CALL bcast(rlon_glo)
51
52	!$OMP MASTER
53	ALLOCATE(io_lat(jjm+1-1/(iim*jjm)))
54	io_lat(1)=rlat_glo(1)
55	io_lat(jjm+1-1/(iim*jjm))=rlat_glo(klon_glo)
56	IF ((iim*jjm) > 1) then
57	DO i=2,jjm
58	io_lat(i)=rlat_glo(2+(i-2)*iim)
59	ENDDO
60	ENDIF
61
62	ALLOCATE(io_lon(iim))
63	io_lon(:)=rlon_glo(2-1/(iimjjm):iim+1-1/(iimjjm))
64
65	! POUR VENUS, LA CARTE EST A L ENVERS !!
66	io_lat = -1.*io_lat
67	io_lon = -1.*io_lon
68
69	ddid=(/ 1,2 /)
70	dsg=(/ iim, jjm+1-1/(iim*jjm) /)
71	dsl=(/ iim, jj_nb /)
72	dpf=(/ 1,jj_begin /)
73	dpl=(/ iim, jj_end /)
74	dhs=(/ ii_begin-1,0 /)
75	if (mpi_rank==mpi_size-1) then
76	dhe=(/0,0/)
77	else
78	dhe=(/ iim-ii_end,0 /)
79	endif
80
81	call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
82	'APPLE',phys_domain_id)
83
84	!$OMP END MASTER
85
86	end subroutine init_iophy_new
87
88	subroutine init_iophy(lat,lon)
89	USE dimphy
90	USE mod_phys_lmdz_para
91	use ioipsl
92	implicit none
93	include 'dimensions.h'
94	real,dimension(iim),intent(in) :: lon
95	real,dimension(jjm+1-1/(iim*jjm)),intent(in) :: lat
96
97	INTEGER,DIMENSION(2) :: ddid
98	INTEGER,DIMENSION(2) :: dsg
99	INTEGER,DIMENSION(2) :: dsl
100	INTEGER,DIMENSION(2) :: dpf
101	INTEGER,DIMENSION(2) :: dpl
102	INTEGER,DIMENSION(2) :: dhs
103	INTEGER,DIMENSION(2) :: dhe
104
105	!$OMP MASTER
106	allocate(io_lat(jjm+1-1/(iim*jjm)))
107	io_lat(:)=lat(:)
108	allocate(io_lon(iim))
109	io_lon(:)=lon(:)
110
111	ddid=(/ 1,2 /)
112	dsg=(/ iim, jjm+1-1/(iim*jjm) /)
113	dsl=(/ iim, jj_nb /)
114	dpf=(/ 1,jj_begin /)
115	dpl=(/ iim, jj_end /)
116	dhs=(/ ii_begin-1,0 /)
117	if (mpi_rank==mpi_size-1) then
118	dhe=(/0,0/)
119	else
120	dhe=(/ iim-ii_end,0 /)
121	endif
122
123	call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
124	'APPLE',phys_domain_id)
125
126	!$OMP END MASTER
127
128	end subroutine init_iophy
129
130	subroutine histbeg_phy(name,itau0,zjulian,dtime,nhori,nid_day)
131	USE dimphy
132	USE mod_phys_lmdz_para
133	use ioipsl
134	use write_field
135	implicit none
136	include 'dimensions.h'
137
138	character(), intent(IN) :: name
139	integer, intent(in) :: itau0
140	real,intent(in) :: zjulian
141	real,intent(in) :: dtime
142	integer,intent(out) :: nhori
143	integer,intent(out) :: nid_day
144
145	!$OMP MASTER
146	if (is_sequential) then
147	call histbeg(name,iim,io_lon, jj_nb,io_lat(jj_begin:jj_end), &
148	1,iim,1,jj_nb,itau0, zjulian, dtime, nhori, nid_day)
149	else
150	call histbeg(name,iim,io_lon, jj_nb,io_lat(jj_begin:jj_end), &
151	1,iim,1,jj_nb,itau0, zjulian, dtime, nhori, nid_day,phys_domain_id)
152	endif
153	!$OMP END MASTER
154
155	end subroutine histbeg_phy
156
157	subroutine histbeg_phy_points(rlon,rlat,pim,tabij,ipt,jpt, &
158	plon,plat,plon_bounds,plat_bounds, &
159	nname,itau0,zjulian,dtime,nnhori,nnid_day)
160	USE dimphy
161	USE mod_phys_lmdz_para
162	USE mod_grid_phy_lmdz
163	use ioipsl
164	use write_field
165	implicit none
166	include 'dimensions.h'
167
168	real,dimension(klon),intent(in) :: rlon
169	real,dimension(klon),intent(in) :: rlat
170	integer, intent(in) :: itau0
171	real,intent(in) :: zjulian
172	real,intent(in) :: dtime
173	integer, intent(in) :: pim
174	integer, intent(out) :: nnhori
175	character(len=20), intent(in) :: nname
176	INTEGER, intent(out) :: nnid_day
177	integer :: i
178	REAL,dimension(klon_glo) :: rlat_glo
179	REAL,dimension(klon_glo) :: rlon_glo
180	INTEGER, DIMENSION(pim), intent(in) :: tabij
181	REAL,dimension(pim), intent(in) :: plat, plon
182	INTEGER,dimension(pim), intent(in) :: ipt, jpt
183	REAL,dimension(pim,2), intent(out) :: plat_bounds, plon_bounds
184
185	INTEGER, SAVE :: tabprocbeg, tabprocend
186	!$OMP THREADPRIVATE(tabprocbeg, tabprocend)
187	INTEGER :: ip
188	INTEGER, PARAMETER :: nip=1
189	INTEGER :: npproc
190	REAL, allocatable, dimension(:) :: npplat, npplon
191	REAL, allocatable, dimension(:,:) :: npplat_bounds, npplon_bounds
192	INTEGER, PARAMETER :: jjmp1=jjm+1-1/jjm
193	REAL, dimension(iim,jjmp1) :: zx_lon, zx_lat
194
195	CALL gather(rlat,rlat_glo)
196	CALL bcast(rlat_glo)
197	CALL gather(rlon,rlon_glo)
198	CALL bcast(rlon_glo)
199
200	!$OMP MASTER
201	DO i=1,pim
202
203	! print*,'CFMIP_iophy i tabij lon lat',i,tabij(i),plon(i),plat(i)
204
205	plon_bounds(i,1)=rlon_glo(tabij(i)-1)
206	plon_bounds(i,2)=rlon_glo(tabij(i)+1)
207	if(plon_bounds(i,2).LE.0..AND.plon_bounds(i,1).GE.0.) THEN
208	if(rlon_glo(tabij(i)).GE.0.) THEN
209	plon_bounds(i,2)=-1*plon_bounds(i,2)
210	endif
211	endif
212	if(plon_bounds(i,2).GE.0..AND.plon_bounds(i,1).LE.0.) THEN
213	if(rlon_glo(tabij(i)).LE.0.) THEN
214	plon_bounds(i,2)=-1*plon_bounds(i,2)
215	endif
216	endif
217	!
218	IF ( tabij(i).LE.iim) THEN
219	plat_bounds(i,1)=rlat_glo(tabij(i))
220	ELSE
221	plat_bounds(i,1)=rlat_glo(tabij(i)-iim)
222	ENDIF
223	plat_bounds(i,2)=rlat_glo(tabij(i)+iim)
224	!
225	! print*,'CFMIP_iophy point i lon lon_bds',i,plon_bounds(i,1),rlon_glo(tabij(i)),plon_bounds(i,2)
226	! print*,'CFMIP_iophy point i lat lat_bds',i,plat_bounds(i,1),rlat_glo(tabij(i)),plat_bounds(i,2)
227	!
228	ENDDO
229	if (is_sequential) then
230
231	npstn=pim
232	IF(.NOT. ALLOCATED(nptabij)) THEN
233	ALLOCATE(nptabij(pim))
234	ENDIF
235	DO i=1,pim
236	nptabij(i)=tabij(i)
237	ENDDO
238
239	CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon_glo,zx_lon)
240	if ((iim*jjm).gt.1) then
241	DO i = 1, iim
242	zx_lon(i,1) = rlon_glo(i+1)
243	zx_lon(i,jjmp1) = rlon_glo(i+1)
244	ENDDO
245	endif
246	CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat_glo,zx_lat)
247
248	DO i=1,pim
249	! print*,'CFMIP_iophy i tabij lon lat',i,tabij(i),plon(i),plat(i)
250
251	plon_bounds(i,1)=zx_lon(ipt(i)-1,jpt(i))
252	plon_bounds(i,2)=zx_lon(ipt(i)+1,jpt(i))
253
254	if (ipt(i).EQ.1) then
255	plon_bounds(i,1)=zx_lon(iim,jpt(i))
256	plon_bounds(i,2)=360.+zx_lon(ipt(i)+1,jpt(i))
257	endif
258
259	if (ipt(i).EQ.iim) then
260	plon_bounds(i,2)=360.+zx_lon(1,jpt(i))
261	endif
262
263	plat_bounds(i,1)=zx_lat(ipt(i),jpt(i)-1)
264	plat_bounds(i,2)=zx_lat(ipt(i),jpt(i)+1)
265
266	if (jpt(i).EQ.1) then
267	plat_bounds(i,1)=zx_lat(ipt(i),1)+0.001
268	plat_bounds(i,2)=zx_lat(ipt(i),1)-0.001
269	endif
270
271	if (jpt(i).EQ.jjmp1) then
272	plat_bounds(i,1)=zx_lat(ipt(i),jjmp1)+0.001
273	plat_bounds(i,2)=zx_lat(ipt(i),jjmp1)-0.001
274	endif
275	!
276	! print*,'CFMIP_iophy point i lon lon_bds',i,plon_bounds(i,1),rlon(tabij(i)),plon_bounds(i,2)
277	! print*,'CFMIP_iophy point i lat lat_bds',i,plat_bounds(i,1),rlat(tabij(i)),plat_bounds(i,2)
278	!
279	ENDDO
280	! print*,'iophy is_sequential nname, nnhori, nnid_day=',trim(nname),nnhori,nnid_day
281	call histbeg(nname,pim,plon,plon_bounds, &
282	plat,plat_bounds, &
283	itau0, zjulian, dtime, nnhori, nnid_day)
284	else
285	npproc=0
286	DO ip=1, pim
287	tabprocbeg=klon_mpi_begin
288	tabprocend=klon_mpi_end
289	IF(tabij(ip).GE.tabprocbeg.AND.tabij(ip).LE.tabprocend) THEN
290	npproc=npproc+1
291	npstn=npproc
292	ENDIF
293	ENDDO
294	! print*,'CFMIP_iophy mpi_rank npstn',mpi_rank,npstn
295	IF(.NOT. ALLOCATED(nptabij)) THEN
296	ALLOCATE(nptabij(npstn))
297	ALLOCATE(npplon(npstn), npplat(npstn))
298	ALLOCATE(npplon_bounds(npstn,2), npplat_bounds(npstn,2))
299	ENDIF
300	npproc=0
301	DO ip=1, pim
302	IF(tabij(ip).GE.tabprocbeg.AND.tabij(ip).LE.tabprocend) THEN
303	npproc=npproc+1
304	nptabij(npproc)=tabij(ip)
305	! print*,'mpi_rank npproc ip plon plat tabij=',mpi_rank,npproc,ip, &
306	! plon(ip),plat(ip),tabij(ip)
307	npplon(npproc)=plon(ip)
308	npplat(npproc)=plat(ip)
309	npplon_bounds(npproc,1)=plon_bounds(ip,1)
310	npplon_bounds(npproc,2)=plon_bounds(ip,2)
311	npplat_bounds(npproc,1)=plat_bounds(ip,1)
312	npplat_bounds(npproc,2)=plat_bounds(ip,2)
313	!!!
314	!!! print qui sert a reordonner les points stations selon l'ordre CFMIP
315	!!! ne pas enlever
316	print*,'iophy_mpi rank ip lon lat',mpi_rank,ip,plon(ip),plat(ip)
317	!!!
318	ENDIF
319	ENDDO
320	call histbeg(nname,npstn,npplon,npplon_bounds, &
321	npplat,npplat_bounds, &
322	itau0,zjulian,dtime,nnhori,nnid_day,phys_domain_id)
323	endif
324	!$OMP END MASTER
325
326	end subroutine histbeg_phy_points
327
328	subroutine histwrite2d_phy(nid,lpoint,name,itau,field)
329	USE dimphy
330	USE mod_phys_lmdz_para
331	USE ioipsl
332	implicit none
333	include 'dimensions.h'
334
335	integer,intent(in) :: nid
336	logical,intent(in) :: lpoint
337	character(), intent(IN) :: name
338	integer, intent(in) :: itau
339	real,dimension(:),intent(in) :: field
340	REAL,dimension(klon_mpi) :: buffer_omp
341	INTEGER, allocatable, dimension(:) :: index2d
342	REAL :: Field2d(iim,jj_nb)
343
344	integer :: ip
345	real,allocatable,dimension(:) :: fieldok
346
347	IF (size(field)/=klon) CALL abort_gcm('iophy::histwrite2d','Field first dimension not equal to klon',1)
348
349	CALL Gather_omp(field,buffer_omp)
350	!$OMP MASTER
351	CALL grid1Dto2D_mpi(buffer_omp,Field2d)
352	if(.NOT.lpoint) THEN
353	ALLOCATE(index2d(iim*jj_nb))
354	ALLOCATE(fieldok(iim*jj_nb))
355	CALL histwrite(nid,name,itau,Field2d,iim*jj_nb,index2d)
356	else
357	ALLOCATE(fieldok(npstn))
358	ALLOCATE(index2d(npstn))
359
360	if(is_sequential) then
361	! klon_mpi_begin=1
362	! klon_mpi_end=klon
363	DO ip=1, npstn
364	fieldok(ip)=buffer_omp(nptabij(ip))
365	ENDDO
366	else
367	DO ip=1, npstn
368	! print*,'histwrite2d is_sequential npstn ip name nptabij',npstn,ip,name,nptabij(ip)
369	IF(nptabij(ip).GE.klon_mpi_begin.AND. &
370	nptabij(ip).LE.klon_mpi_end) THEN
371	fieldok(ip)=buffer_omp(nptabij(ip)-klon_mpi_begin+1)
372	ENDIF
373	ENDDO
374	endif
375	CALL histwrite(nid,name,itau,fieldok,npstn,index2d)
376	!
377	endif
378	deallocate(index2d)
379	deallocate(fieldok)
380	!$OMP END MASTER
381	end subroutine histwrite2d_phy
382
383	subroutine histwrite3d_phy(nid,lpoint,name,itau,field)
384	USE dimphy
385	USE mod_phys_lmdz_para
386
387	use ioipsl
388	implicit none
389	include 'dimensions.h'
390
391	integer,intent(in) :: nid
392	logical,intent(in) :: lpoint
393	character(), intent(IN) :: name
394	integer, intent(in) :: itau
395	real,dimension(:,:),intent(in) :: field ! --> field(klon,:)
396	REAL,dimension(klon_mpi,size(field,2)) :: buffer_omp
397	REAL :: Field3d(iim,jj_nb,size(field,2))
398	INTEGER :: ip, n, nlev
399	INTEGER, ALLOCATABLE, dimension(:) :: index3d
400	real,allocatable, dimension(:,:) :: fieldok
401
402	IF (size(field,1)/=klon) CALL abort_gcm('iophy::histwrite3d','Field first dimension not equal to klon',1)
403	nlev=size(field,2)
404
405	! print*,'hist3d_phy mpi_rank npstn=',mpi_rank,npstn
406
407	! DO ip=1, npstn
408	! print*,'hist3d_phy mpi_rank nptabij',mpi_rank,nptabij(ip)
409	! ENDDO
410
411	CALL Gather_omp(field,buffer_omp)
412	!$OMP MASTER
413	CALL grid1Dto2D_mpi(buffer_omp,field3d)
414	if(.NOT.lpoint) THEN
415	ALLOCATE(index3d(iimjj_nbnlev))
416	ALLOCATE(fieldok(iim*jj_nb,nlev))
417	CALL histwrite(nid,name,itau,Field3d,iimjj_nbnlev,index3d)
418	else
419	nlev=size(field,2)
420	ALLOCATE(index3d(npstn*nlev))
421	ALLOCATE(fieldok(npstn,nlev))
422
423	if(is_sequential) then
424	! klon_mpi_begin=1
425	! klon_mpi_end=klon
426	DO n=1, nlev
427	DO ip=1, npstn
428	fieldok(ip,n)=buffer_omp(nptabij(ip),n)
429	ENDDO
430	ENDDO
431	else
432	DO n=1, nlev
433	DO ip=1, npstn
434	IF(nptabij(ip).GE.klon_mpi_begin.AND. &
435	nptabij(ip).LE.klon_mpi_end) THEN
436	fieldok(ip,n)=buffer_omp(nptabij(ip)-klon_mpi_begin+1,n)
437	ENDIF
438	ENDDO
439	ENDDO
440	endif
441	CALL histwrite(nid,name,itau,fieldok,npstn*nlev,index3d)
442	endif
443	deallocate(index3d)
444	deallocate(fieldok)
445	!$OMP END MASTER
446	end subroutine histwrite3d_phy
447
448	end module iophy

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

Download in other formats:

Original Format