Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

iophy_F90_modifje20140505 @ 5434

Last change on this file since 5434 was 2175, checked in by jescribano, 10 years ago
SPLA code included for first time
File size: 41.4 KB

Line
1	!
2	! $Id: iophy.F90 2002 2014-04-04 12:39:54Z emillour $
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	INTEGER, SAVE :: itau_iophy
14
15	!$OMP THREADPRIVATE(itau_iophy)
16
17	#ifdef CPP_XIOS
18	INTERFACE histwrite_phy
19	MODULE PROCEDURE histwrite2d_phy,histwrite3d_phy,histwrite2d_phy_old,histwrite3d_phy_old,histwrite2d_xios,histwrite3d_xios
20	END INTERFACE
21	#else
22	INTERFACE histwrite_phy
23	MODULE PROCEDURE histwrite2d_phy,histwrite3d_phy,histwrite2d_phy_old,histwrite3d_phy_old
24	END INTERFACE
25	#endif
26
27	INTERFACE histbeg_phy_all
28	MODULE PROCEDURE histbeg_phy,histbeg_phyxios,histbeg_phy_points
29	END INTERFACE
30
31
32	CONTAINS
33
34	! ug Routine pour définir itau_iophy depuis phys_output_write_mod:
35	SUBROUTINE set_itau_iophy(ito)
36	IMPLICIT NONE
37	INTEGER, INTENT(IN) :: ito
38	itau_iophy = ito
39	END SUBROUTINE
40
41	SUBROUTINE init_iophy_new(rlat,rlon)
42	USE dimphy, only: klon
43	USE mod_phys_lmdz_para, only: gather, bcast, &
44	jj_nb, jj_begin, jj_end, ii_begin, ii_end, &
45	mpi_size, mpi_rank, klon_mpi, &
46	is_sequential, is_south_pole
47	USE mod_grid_phy_lmdz, only: nbp_lon, nbp_lat, klon_glo
48	#ifdef CPP_IOIPSL
49	USE ioipsl, only: flio_dom_set
50	#endif
51	#ifdef CPP_XIOS
52	use wxios, only: wxios_domain_param
53	#endif
54	IMPLICIT NONE
55	INCLUDE 'dimensions.h'
56	include 'iniprint.h'
57	REAL,DIMENSION(klon),INTENT(IN) :: rlon
58	REAL,DIMENSION(klon),INTENT(IN) :: rlat
59
60	REAL,DIMENSION(klon_glo) :: rlat_glo
61	REAL,DIMENSION(klon_glo) :: rlon_glo
62
63	INTEGER,DIMENSION(2) :: ddid
64	INTEGER,DIMENSION(2) :: dsg
65	INTEGER,DIMENSION(2) :: dsl
66	INTEGER,DIMENSION(2) :: dpf
67	INTEGER,DIMENSION(2) :: dpl
68	INTEGER,DIMENSION(2) :: dhs
69	INTEGER,DIMENSION(2) :: dhe
70	INTEGER :: i
71	INTEGER :: data_ibegin, data_iend
72
73	CALL gather(rlat,rlat_glo)
74	CALL bcast(rlat_glo)
75	CALL gather(rlon,rlon_glo)
76	CALL bcast(rlon_glo)
77
78	!$OMP MASTER
79	ALLOCATE(io_lat(jjm+1-1/(iim*jjm)))
80	io_lat(1)=rlat_glo(1)
81	io_lat(jjm+1-1/(iim*jjm))=rlat_glo(klon_glo)
82	IF ((iim*jjm) > 1) then
83	DO i=2,jjm
84	io_lat(i)=rlat_glo(2+(i-2)*iim)
85	ENDDO
86	ENDIF
87
88	ALLOCATE(io_lon(iim))
89	io_lon(:)=rlon_glo(2-1/(iimjjm):iim+1-1/(iimjjm))
90	!! (I) dtnb : total number of domains
91	!! (I) dnb : domain number
92	!! (I) did(:) : distributed dimensions identifiers
93	!! (up to 5 dimensions are supported)
94	!! (I) dsg(:) : total number of points for each dimension
95	!! (I) dsl(:) : local number of points for each dimension
96	!! (I) dpf(:) : position of first local point for each dimension
97	!! (I) dpl(:) : position of last local point for each dimension
98	!! (I) dhs(:) : start halo size for each dimension
99	!! (I) dhe(:) : end halo size for each dimension
100	!! (C) cdnm : Model domain definition name.
101	!! The names actually supported are :
102	!! "BOX", "APPLE", "ORANGE".
103	!! These names are case insensitive.
104
105	ddid=(/ 1,2 /)
106	dsg=(/ iim, jjm+1-1/(iim*jjm) /)
107	dsl=(/ iim, jj_nb /)
108	dpf=(/ 1,jj_begin /)
109	dpl=(/ iim, jj_end /)
110	dhs=(/ ii_begin-1,0 /)
111	IF (mpi_rank==mpi_size-1) THEN
112	dhe=(/0,0/)
113	ELSE
114	dhe=(/ iim-ii_end,0 /)
115	ENDIF
116
117	#ifndef CPP_NO_IOIPSL
118	CALL flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
119	'APPLE',phys_domain_id)
120	#endif
121	#ifdef CPP_XIOS
122	! Set values for the mask:
123	IF (mpi_rank == 0) THEN
124	data_ibegin = 0
125	ELSE
126	data_ibegin = ii_begin - 1
127	END IF
128
129	IF (mpi_rank == mpi_size-1) THEN
130	data_iend = nbp_lon
131	ELSE
132	data_iend = ii_end + 1
133	END IF
134
135	if (prt_level>=10) then
136	write(lunout,*) "init_iophy_new: mpirank=",mpi_rank," iibegin=",ii_begin , " ii_end=",ii_end," jjbegin=",jj_begin," jj_nb=",jj_nb," jj_end=",jj_end
137	write(lunout,*) "init_iophy_new: mpirank=",mpi_rank," nbp_lon=",nbp_lon," nbp_lat=",nbp_lat
138	write(lunout,*) "init_iophy_new: mpirank=",mpi_rank," data_ibegin=",data_ibegin," data_iend=",data_iend
139	write(lunout,*) "init_iophy_new: mpirank=",mpi_rank," data_ibegin=",data_ibegin," data_iend=",data_iend
140	write(lunout,*) "init_iophy_new: mpirank=",mpi_rank," is_south_pole=",is_south_pole
141	endif
142
143	! Initialize the XIOS domain coreesponding to this process:
144	CALL wxios_domain_param("dom_glo", is_sequential, nbp_lon, jj_nb, nbp_lon, nbp_lat, &
145	1, nbp_lon, ii_begin, ii_end, jj_begin, jj_end, &
146	klon_mpi+2*(nbp_lon-1), data_ibegin, data_iend, &
147	io_lat, io_lon,is_south_pole,mpi_rank)
148	#endif
149	!$OMP END MASTER
150
151	END SUBROUTINE init_iophy_new
152
153	SUBROUTINE init_iophy(lat,lon)
154	USE mod_phys_lmdz_para, only: jj_begin, jj_end, ii_begin, ii_end, jj_nb, &
155	mpi_size, mpi_rank
156	USE ioipsl, only: flio_dom_set
157	IMPLICIT NONE
158	INCLUDE 'dimensions.h'
159	REAL,DIMENSION(iim),INTENT(IN) :: lon
160	REAL,DIMENSION(jjm+1-1/(iim*jjm)),INTENT(IN) :: lat
161
162	INTEGER,DIMENSION(2) :: ddid
163	INTEGER,DIMENSION(2) :: dsg
164	INTEGER,DIMENSION(2) :: dsl
165	INTEGER,DIMENSION(2) :: dpf
166	INTEGER,DIMENSION(2) :: dpl
167	INTEGER,DIMENSION(2) :: dhs
168	INTEGER,DIMENSION(2) :: dhe
169
170	!$OMP MASTER
171	allocate(io_lat(jjm+1-1/(iim*jjm)))
172	io_lat(:)=lat(:)
173	allocate(io_lon(iim))
174	io_lon(:)=lon(:)
175
176	ddid=(/ 1,2 /)
177	dsg=(/ iim, jjm+1-1/(iim*jjm) /)
178	dsl=(/ iim, jj_nb /)
179	dpf=(/ 1,jj_begin /)
180	dpl=(/ iim, jj_end /)
181	dhs=(/ ii_begin-1,0 /)
182	if (mpi_rank==mpi_size-1) then
183	dhe=(/0,0/)
184	else
185	dhe=(/ iim-ii_end,0 /)
186	endif
187
188	#ifndef CPP_NO_IOIPSL
189	call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
190	'APPLE',phys_domain_id)
191	#endif
192	!$OMP END MASTER
193
194	end SUBROUTINE init_iophy
195
196	SUBROUTINE histbeg_phyxios(name,itau0,zjulian,dtime,ffreq,lev,nhori,nid_day)
197	! USE dimphy
198	USE mod_phys_lmdz_para, only: is_sequential, is_using_mpi, is_mpi_root, &
199	jj_begin, jj_end, jj_nb
200	use ioipsl, only: histbeg
201	#ifdef CPP_XIOS
202	use wxios, only: wxios_add_file
203	#endif
204	IMPLICIT NONE
205	include 'dimensions.h'
206
207	character(), INTENT(IN) :: name
208	integer, INTENT(IN) :: itau0
209	REAL,INTENT(IN) :: zjulian
210	REAL,INTENT(IN) :: dtime
211	character(LEN=*), INTENT(IN) :: ffreq
212	INTEGER,INTENT(IN) :: lev
213	integer,intent(out) :: nhori
214	integer,intent(out) :: nid_day
215
216	!$OMP MASTER
217	if (is_sequential) then
218	call histbeg(name,iim,io_lon, jj_nb,io_lat(jj_begin:jj_end), &
219	1,iim,1,jj_nb,itau0, zjulian, dtime, nhori, nid_day)
220	else
221	call histbeg(name,iim,io_lon, jj_nb,io_lat(jj_begin:jj_end), &
222	1,iim,1,jj_nb,itau0, zjulian, dtime, nhori, nid_day,phys_domain_id)
223	endif
224
225	#ifdef CPP_XIOS
226	! ug OMP en chantier...
227	IF((.NOT. is_using_mpi) .OR. is_mpi_root) THEN
228	! ug Création du fichier
229	CALL wxios_add_file(name, ffreq, lev)
230	END IF
231	#endif
232	!$OMP END MASTER
233
234	END SUBROUTINE histbeg_phyxios
235
236	SUBROUTINE histbeg_phy(name,itau0,zjulian,dtime,nhori,nid_day)
237
238	USE mod_phys_lmdz_para, only: jj_begin, jj_end, jj_nb, is_sequential
239	use ioipsl, only: histbeg
240
241	IMPLICIT NONE
242	include 'dimensions.h'
243
244	character(), INTENT(IN) :: name
245	integer, INTENT(IN) :: itau0
246	REAL,INTENT(IN) :: zjulian
247	REAL,INTENT(IN) :: dtime
248	integer,intent(out) :: nhori
249	integer,intent(out) :: nid_day
250
251	!$OMP MASTER
252	#ifndef CPP_NO_IOIPSL
253	if (is_sequential) then
254	call histbeg(name,iim,io_lon, jj_nb,io_lat(jj_begin:jj_end), &
255	1,iim,1,jj_nb,itau0, zjulian, dtime, nhori, nid_day)
256	else
257	call histbeg(name,iim,io_lon, jj_nb,io_lat(jj_begin:jj_end), &
258	1,iim,1,jj_nb,itau0, zjulian, dtime, nhori, nid_day,phys_domain_id)
259	endif
260	#endif
261	!$OMP END MASTER
262
263	END SUBROUTINE histbeg_phy
264
265
266	SUBROUTINE histbeg_phy_points(rlon,rlat,pim,tabij,ipt,jpt, &
267	plon,plat,plon_bounds,plat_bounds, &
268	nname,itau0,zjulian,dtime,nnhori,nnid_day)
269	USE dimphy, only: klon
270	USE mod_phys_lmdz_para, only: gather, bcast, &
271	is_sequential, klon_mpi_begin, klon_mpi_end, &
272	mpi_rank
273	USE mod_grid_phy_lmdz, only: klon_glo
274	use ioipsl, only: histbeg
275
276	IMPLICIT NONE
277	include 'dimensions.h'
278
279	REAL,DIMENSION(klon),INTENT(IN) :: rlon
280	REAL,DIMENSION(klon),INTENT(IN) :: rlat
281	integer, INTENT(IN) :: itau0
282	REAL,INTENT(IN) :: zjulian
283	REAL,INTENT(IN) :: dtime
284	integer, INTENT(IN) :: pim
285	integer, intent(out) :: nnhori
286	character(len=20), INTENT(IN) :: nname
287	INTEGER, intent(out) :: nnid_day
288	integer :: i
289	REAL,DIMENSION(klon_glo) :: rlat_glo
290	REAL,DIMENSION(klon_glo) :: rlon_glo
291	INTEGER, DIMENSION(pim), INTENT(IN) :: tabij
292	REAL,DIMENSION(pim), INTENT(IN) :: plat, plon
293	INTEGER,DIMENSION(pim), INTENT(IN) :: ipt, jpt
294	REAL,DIMENSION(pim,2), intent(out) :: plat_bounds, plon_bounds
295
296	INTEGER, SAVE :: tabprocbeg, tabprocend
297	!$OMP THREADPRIVATE(tabprocbeg, tabprocend)
298	INTEGER :: ip
299	INTEGER, PARAMETER :: nip=1
300	INTEGER :: npproc
301	REAL, allocatable, DIMENSION(:) :: npplat, npplon
302	REAL, allocatable, DIMENSION(:,:) :: npplat_bounds, npplon_bounds
303	INTEGER, PARAMETER :: jjmp1=jjm+1-1/jjm
304	REAL, DIMENSION(iim,jjmp1) :: zx_lon, zx_lat
305
306	CALL gather(rlat,rlat_glo)
307	CALL bcast(rlat_glo)
308	CALL gather(rlon,rlon_glo)
309	CALL bcast(rlon_glo)
310
311	!$OMP MASTER
312	DO i=1,pim
313
314	! print*,'CFMIP_iophy i tabij lon lat',i,tabij(i),plon(i),plat(i)
315
316	plon_bounds(i,1)=rlon_glo(tabij(i)-1)
317	plon_bounds(i,2)=rlon_glo(tabij(i)+1)
318	if(plon_bounds(i,2).LE.0..AND.plon_bounds(i,1).GE.0.) THEN
319	if(rlon_glo(tabij(i)).GE.0.) THEN
320	plon_bounds(i,2)=-1*plon_bounds(i,2)
321	endif
322	endif
323	if(plon_bounds(i,2).GE.0..AND.plon_bounds(i,1).LE.0.) THEN
324	if(rlon_glo(tabij(i)).LE.0.) THEN
325	plon_bounds(i,2)=-1*plon_bounds(i,2)
326	endif
327	endif
328	!
329	IF ( tabij(i).LE.iim) THEN
330	plat_bounds(i,1)=rlat_glo(tabij(i))
331	ELSE
332	plat_bounds(i,1)=rlat_glo(tabij(i)-iim)
333	ENDIF
334	plat_bounds(i,2)=rlat_glo(tabij(i)+iim)
335	!
336	! print*,'CFMIP_iophy point i lon lon_bds',i,plon_bounds(i,1),rlon_glo(tabij(i)),plon_bounds(i,2)
337	! print*,'CFMIP_iophy point i lat lat_bds',i,plat_bounds(i,1),rlat_glo(tabij(i)),plat_bounds(i,2)
338	!
339	ENDDO
340	if (is_sequential) then
341
342	npstn=pim
343	IF(.NOT. ALLOCATED(nptabij)) THEN
344	ALLOCATE(nptabij(pim))
345	ENDIF
346	DO i=1,pim
347	nptabij(i)=tabij(i)
348	ENDDO
349
350	CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon_glo,zx_lon)
351	if ((iim*jjm).gt.1) then
352	DO i = 1, iim
353	zx_lon(i,1) = rlon_glo(i+1)
354	zx_lon(i,jjmp1) = rlon_glo(i+1)
355	ENDDO
356	endif
357	CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat_glo,zx_lat)
358
359	DO i=1,pim
360	! print*,'CFMIP_iophy i tabij lon lat',i,tabij(i),plon(i),plat(i)
361
362	plon_bounds(i,1)=zx_lon(ipt(i)-1,jpt(i))
363	plon_bounds(i,2)=zx_lon(ipt(i)+1,jpt(i))
364
365	if (ipt(i).EQ.1) then
366	plon_bounds(i,1)=zx_lon(iim,jpt(i))
367	plon_bounds(i,2)=360.+zx_lon(ipt(i)+1,jpt(i))
368	endif
369
370	if (ipt(i).EQ.iim) then
371	plon_bounds(i,2)=360.+zx_lon(1,jpt(i))
372	endif
373
374	plat_bounds(i,1)=zx_lat(ipt(i),jpt(i)-1)
375	plat_bounds(i,2)=zx_lat(ipt(i),jpt(i)+1)
376
377	if (jpt(i).EQ.1) then
378	plat_bounds(i,1)=zx_lat(ipt(i),1)+0.001
379	plat_bounds(i,2)=zx_lat(ipt(i),1)-0.001
380	endif
381
382	if (jpt(i).EQ.jjmp1) then
383	plat_bounds(i,1)=zx_lat(ipt(i),jjmp1)+0.001
384	plat_bounds(i,2)=zx_lat(ipt(i),jjmp1)-0.001
385	endif
386	!
387	! print*,'CFMIP_iophy point i lon lon_bds',i,plon_bounds(i,1),rlon(tabij(i)),plon_bounds(i,2)
388	! print*,'CFMIP_iophy point i lat lat_bds',i,plat_bounds(i,1),rlat(tabij(i)),plat_bounds(i,2)
389	!
390	ENDDO
391
392	#ifndef CPP_NO_IOIPSL
393	call histbeg(nname,pim,plon,plon_bounds, &
394	plat,plat_bounds, &
395	itau0, zjulian, dtime, nnhori, nnid_day)
396	#endif
397	else
398	npproc=0
399	DO ip=1, pim
400	tabprocbeg=klon_mpi_begin
401	tabprocend=klon_mpi_end
402	IF(tabij(ip).GE.tabprocbeg.AND.tabij(ip).LE.tabprocend) THEN
403	npproc=npproc+1
404	npstn=npproc
405	ENDIF
406	ENDDO
407	! print*,'CFMIP_iophy mpi_rank npstn',mpi_rank,npstn
408	IF(.NOT. ALLOCATED(nptabij)) THEN
409	ALLOCATE(nptabij(npstn))
410	ALLOCATE(npplon(npstn), npplat(npstn))
411	ALLOCATE(npplon_bounds(npstn,2), npplat_bounds(npstn,2))
412	ENDIF
413	npproc=0
414	DO ip=1, pim
415	IF(tabij(ip).GE.tabprocbeg.AND.tabij(ip).LE.tabprocend) THEN
416	npproc=npproc+1
417	nptabij(npproc)=tabij(ip)
418	! print*,'mpi_rank npproc ip plon plat tabij=',mpi_rank,npproc,ip, &
419	! plon(ip),plat(ip),tabij(ip)
420	npplon(npproc)=plon(ip)
421	npplat(npproc)=plat(ip)
422	npplon_bounds(npproc,1)=plon_bounds(ip,1)
423	npplon_bounds(npproc,2)=plon_bounds(ip,2)
424	npplat_bounds(npproc,1)=plat_bounds(ip,1)
425	npplat_bounds(npproc,2)=plat_bounds(ip,2)
426	!!!
427	!!! print qui sert a reordonner les points stations selon l'ordre CFMIP
428	!!! ne pas enlever
429	print*,'iophy_mpi rank ip lon lat',mpi_rank,ip,plon(ip),plat(ip)
430	!!!
431	ENDIF
432	ENDDO
433	#ifndef CPP_NO_IOIPSL
434	call histbeg(nname,npstn,npplon,npplon_bounds, &
435	npplat,npplat_bounds, &
436	itau0,zjulian,dtime,nnhori,nnid_day,phys_domain_id)
437	#endif
438	endif
439	!$OMP END MASTER
440
441	end SUBROUTINE histbeg_phy_points
442
443
444	SUBROUTINE histdef2d_old (iff,lpoint,flag_var,nomvar,titrevar,unitvar)
445
446	USE ioipsl, only: histdef
447	USE mod_phys_lmdz_para, only: jj_nb
448	use phys_output_var_mod, only: type_ecri, zoutm, zdtime_moy, lev_files, &
449	nid_files, nhorim, swaero_diag, nfiles
450	IMPLICIT NONE
451
452	INCLUDE "dimensions.h"
453	INCLUDE "temps.h"
454	INCLUDE "clesphys.h"
455
456	INTEGER :: iff
457	LOGICAL :: lpoint
458	INTEGER, DIMENSION(nfiles) :: flag_var
459	CHARACTER(LEN=20) :: nomvar
460	CHARACTER(LEN=*) :: titrevar
461	CHARACTER(LEN=*) :: unitvar
462
463	REAL zstophym
464
465	IF (type_ecri(iff)=='inst(X)'.OR.type_ecri(iff)=='once') THEN
466	zstophym=zoutm(iff)
467	ELSE
468	zstophym=zdtime_moy
469	ENDIF
470
471	! Appel a la lecture des noms et niveau d'ecriture des variables dans output.def
472	CALL conf_physoutputs(nomvar,flag_var)
473
474	IF(.NOT.lpoint) THEN
475	IF ( flag_var(iff)<=lev_files(iff) ) THEN
476	CALL histdef (nid_files(iff),nomvar,titrevar,unitvar, &
477	iim,jj_nb,nhorim(iff), 1,1,1, -99, 32, &
478	type_ecri(iff), zstophym,zoutm(iff))
479	ENDIF
480	ELSE
481	IF ( flag_var(iff)<=lev_files(iff) ) THEN
482	CALL histdef (nid_files(iff),nomvar,titrevar,unitvar, &
483	npstn,1,nhorim(iff), 1,1,1, -99, 32, &
484	type_ecri(iff), zstophym,zoutm(iff))
485	ENDIF
486	ENDIF
487
488	! Set swaero_diag=true if at least one of the concerned variables are defined
489	IF (nomvar=='topswad' .OR. nomvar=='topswai' .OR. nomvar=='solswad' .OR. nomvar=='solswai' ) THEN
490	IF ( flag_var(iff)<=lev_files(iff) ) THEN
491	swaero_diag=.TRUE.
492	END IF
493	END IF
494	END SUBROUTINE histdef2d_old
495
496
497
498	SUBROUTINE histdef3d_old (iff,lpoint,flag_var,nomvar,titrevar,unitvar)
499
500	USE ioipsl, only: histdef
501	USE dimphy, only: klev
502	USE mod_phys_lmdz_para, only: jj_nb
503	use phys_output_var_mod, only: type_ecri, zoutm, lev_files, nid_files, &
504	nhorim, zdtime_moy, levmin, levmax, &
505	nvertm, nfiles
506	IMPLICIT NONE
507
508	INCLUDE "dimensions.h"
509	INCLUDE "temps.h"
510	! INCLUDE "indicesol.h"
511	INCLUDE "clesphys.h"
512
513	INTEGER :: iff
514	LOGICAL :: lpoint
515	INTEGER, DIMENSION(nfiles) :: flag_var
516	CHARACTER(LEN=20) :: nomvar
517	CHARACTER(LEN=*) :: titrevar
518	CHARACTER(LEN=*) :: unitvar
519
520	REAL zstophym
521
522	! Appel a la lecture des noms et niveau d'ecriture des variables dans output.def
523	CALL conf_physoutputs(nomvar,flag_var)
524
525	IF (type_ecri(iff)=='inst(X)'.OR.type_ecri(iff)=='once') THEN
526	zstophym=zoutm(iff)
527	ELSE
528	zstophym=zdtime_moy
529	ENDIF
530
531	IF(.NOT.lpoint) THEN
532	IF ( flag_var(iff)<=lev_files(iff) ) THEN
533	CALL histdef (nid_files(iff), nomvar, titrevar, unitvar, &
534	iim, jj_nb, nhorim(iff), klev, levmin(iff), &
535	levmax(iff)-levmin(iff)+1, nvertm(iff), 32, type_ecri(iff), &
536	zstophym, zoutm(iff))
537	ENDIF
538	ELSE
539	IF ( flag_var(iff)<=lev_files(iff) ) THEN
540	CALL histdef (nid_files(iff), nomvar, titrevar, unitvar, &
541	npstn,1,nhorim(iff), klev, levmin(iff), &
542	levmax(iff)-levmin(iff)+1, nvertm(iff), 32, &
543	type_ecri(iff), zstophym,zoutm(iff))
544	ENDIF
545	ENDIF
546	END SUBROUTINE histdef3d_old
547
548
549
550
551
552
553
554
555	SUBROUTINE histdef2d (iff,var)
556
557	USE ioipsl, only: histdef
558	USE mod_phys_lmdz_para, only: jj_nb
559	use phys_output_var_mod, only: ctrl_out, type_ecri_files, zoutm, zdtime_moy, &
560	clef_stations, phys_out_filenames, lev_files, &
561	nid_files, nhorim, swaero_diag
562	#ifdef CPP_XIOS
563	use wxios, only: wxios_add_field_to_file
564	#endif
565	IMPLICIT NONE
566
567	INCLUDE "dimensions.h"
568	INCLUDE "temps.h"
569	INCLUDE "clesphys.h"
570	INCLUDE "iniprint.h"
571
572	INTEGER :: iff
573	TYPE(ctrl_out) :: var
574
575	REAL zstophym
576	CHARACTER(LEN=20) :: typeecrit
577
578
579	! ug On récupère le type écrit de la structure:
580	! Assez moche, à refaire si meilleure méthode...
581	IF (INDEX(var%type_ecrit(iff), "once") > 0) THEN
582	typeecrit = 'once'
583	ELSE IF(INDEX(var%type_ecrit(iff), "t_min") > 0) THEN
584	typeecrit = 't_min(X)'
585	ELSE IF(INDEX(var%type_ecrit(iff), "t_max") > 0) THEN
586	typeecrit = 't_max(X)'
587	ELSE IF(INDEX(var%type_ecrit(iff), "inst") > 0) THEN
588	typeecrit = 'inst(X)'
589	ELSE
590	typeecrit = type_ecri_files(iff)
591	ENDIF
592
593	IF (typeecrit=='inst(X)'.OR.typeecrit=='once') THEN
594	zstophym=zoutm(iff)
595	ELSE
596	zstophym=zdtime_moy
597	ENDIF
598
599	! Appel a la lecture des noms et niveau d'ecriture des variables dans output.def
600	CALL conf_physoutputs(var%name, var%flag)
601
602	IF(.NOT.clef_stations(iff)) THEN
603
604	#ifdef CPP_XIOS
605	IF ( var%flag(iff)<=lev_files(iff) ) THEN
606	CALL wxios_add_field_to_file(var%name, 2, iff, phys_out_filenames(iff), &
607	var%description, var%unit, var%flag(iff), typeecrit)
608	IF (prt_level >= 10) THEN
609	WRITE(lunout,*) 'histdef2d: call wxios_add_field_to_file var%name iff: ', &
610	trim(var%name),iff
611	ENDIF
612	ENDIF
613	#endif
614	#ifndef CPP_NO_IOIPSL
615
616	IF ( var%flag(iff)<=lev_files(iff) ) THEN
617	CALL histdef (nid_files(iff), var%name, var%description, var%unit, &
618	iim,jj_nb,nhorim(iff), 1,1,1, -99, 32, &
619	typeecrit, zstophym,zoutm(iff))
620	ENDIF
621	ELSE
622	IF ( var%flag(iff)<=lev_files(iff)) THEN
623	CALL histdef (nid_files(iff), var%name, var%description, var%unit, &
624	npstn,1,nhorim(iff), 1,1,1, -99, 32, &
625	typeecrit, zstophym,zoutm(iff))
626	ENDIF
627	#endif
628	ENDIF
629
630	! Set swaero_diag=true if at least one of the concerned variables are defined
631	IF (var%name=='topswad' .OR. var%name=='topswai' .OR. var%name=='solswad' .OR. var%name=='solswai' ) THEN
632	IF ( var%flag(iff)<=lev_files(iff) ) THEN
633	swaero_diag=.TRUE.
634	END IF
635	END IF
636	END SUBROUTINE histdef2d
637
638	SUBROUTINE histdef3d (iff,var)
639
640	USE ioipsl, only: histdef
641	USE dimphy, only: klev
642	USE mod_phys_lmdz_para, only: jj_nb
643	use phys_output_var_mod, only: ctrl_out, type_ecri_files, zoutm, zdtime_moy, &
644	clef_stations, phys_out_filenames, lev_files, &
645	nid_files, nhorim, swaero_diag, levmin, &
646	levmax, nvertm
647	#ifdef CPP_XIOS
648	use wxios, only: wxios_add_field_to_file
649	#endif
650	IMPLICIT NONE
651
652	INCLUDE "dimensions.h"
653	INCLUDE "temps.h"
654	INCLUDE "clesphys.h"
655	INCLUDE "iniprint.h"
656
657	INTEGER :: iff
658	TYPE(ctrl_out) :: var
659
660	REAL zstophym
661	CHARACTER(LEN=20) :: typeecrit
662
663	! ug On récupère le type écrit de la structure:
664	! Assez moche, à refaire si meilleure méthode...
665	IF (INDEX(var%type_ecrit(iff), "once") > 0) THEN
666	typeecrit = 'once'
667	ELSE IF(INDEX(var%type_ecrit(iff), "t_min") > 0) THEN
668	typeecrit = 't_min(X)'
669	ELSE IF(INDEX(var%type_ecrit(iff), "t_max") > 0) THEN
670	typeecrit = 't_max(X)'
671	ELSE IF(INDEX(var%type_ecrit(iff), "inst") > 0) THEN
672	typeecrit = 'inst(X)'
673	ELSE
674	typeecrit = type_ecri_files(iff)
675	ENDIF
676
677
678	! Appel a la lecture des noms et niveau d'ecriture des variables dans output.def
679	CALL conf_physoutputs(var%name,var%flag)
680
681	IF (typeecrit=='inst(X)'.OR.typeecrit=='once') THEN
682	zstophym=zoutm(iff)
683	ELSE
684	zstophym=zdtime_moy
685	ENDIF
686
687	IF(.NOT.clef_stations(iff)) THEN
688
689	#ifdef CPP_XIOS
690	IF ( var%flag(iff)<=lev_files(iff) ) THEN
691	CALL wxios_add_field_to_file(var%name, 3, iff, phys_out_filenames(iff), &
692	var%description, var%unit, var%flag(iff), typeecrit)
693	IF (prt_level >= 10) THEN
694	WRITE(lunout,*) 'histdef3d: call wxios_add_field_to_file var%name iff: ', &
695	trim(var%name),iff
696	ENDIF
697	ENDIF
698	#endif
699	#ifndef CPP_NO_IOIPSL
700
701	IF ( var%flag(iff)<=lev_files(iff) ) THEN
702	CALL histdef (nid_files(iff), var%name, var%description, var%unit, &
703	iim, jj_nb, nhorim(iff), klev, levmin(iff), &
704	levmax(iff)-levmin(iff)+1, nvertm(iff), 32, typeecrit, &
705	zstophym, zoutm(iff))
706	ENDIF
707	ELSE
708	IF ( var%flag(iff)<=lev_files(iff)) THEN
709	CALL histdef (nid_files(iff), var%name, var%description, var%unit, &
710	npstn,1,nhorim(iff), klev, levmin(iff), &
711	levmax(iff)-levmin(iff)+1, nvertm(iff), 32, &
712	typeecrit, zstophym,zoutm(iff))
713	ENDIF
714	#endif
715	ENDIF
716	END SUBROUTINE histdef3d
717
718	SUBROUTINE conf_physoutputs(nam_var,flag_var)
719	!!! Lecture des noms et niveau de sortie des variables dans output.def
720	! en utilisant les routines getin de IOIPSL
721	use ioipsl, only: getin
722	use phys_output_var_mod, only: nfiles
723	IMPLICIT NONE
724
725	include 'iniprint.h'
726
727	CHARACTER(LEN=20) :: nam_var
728	INTEGER, DIMENSION(nfiles) :: flag_var
729
730	IF(prt_level>10) WRITE(lunout,*)'Avant getin: nam_var flag_var ',nam_var,flag_var(:)
731	CALL getin('flag_'//nam_var,flag_var)
732	CALL getin('name_'//nam_var,nam_var)
733	IF(prt_level>10) WRITE(lunout,*)'Apres getin: nam_var flag_var ',nam_var,flag_var(:)
734
735	END SUBROUTINE conf_physoutputs
736
737
738
739	SUBROUTINE histwrite2d_phy_old(nid,lpoint,name,itau,field)
740	USE dimphy, only: klon
741	USE mod_phys_lmdz_para, only: Gather_omp, grid1Dto2D_mpi, &
742	is_sequential, klon_mpi_begin, klon_mpi_end, &
743	jj_nb, klon_mpi
744	USE ioipsl, only: histwrite
745	IMPLICIT NONE
746	include 'dimensions.h'
747	include 'iniprint.h'
748
749	integer,INTENT(IN) :: nid
750	logical,INTENT(IN) :: lpoint
751	character(), INTENT(IN) :: name
752	integer, INTENT(IN) :: itau
753	REAL,DIMENSION(:),INTENT(IN) :: field
754	REAL,DIMENSION(klon_mpi) :: buffer_omp
755	INTEGER, allocatable, DIMENSION(:) :: index2d
756	REAL :: Field2d(iim,jj_nb)
757
758	integer :: ip
759	REAL,allocatable,DIMENSION(:) :: fieldok
760
761
762	IF (size(field)/=klon) CALL abort_gcm('iophy::histwrite2d','Field first DIMENSION not equal to klon',1)
763
764	CALL Gather_omp(field,buffer_omp)
765	!$OMP MASTER
766	CALL grid1Dto2D_mpi(buffer_omp,Field2d)
767	if(.NOT.lpoint) THEN
768	ALLOCATE(index2d(iim*jj_nb))
769	ALLOCATE(fieldok(iim*jj_nb))
770	IF (prt_level >= 10) write(lunout,*)'Sending ',name,' to IOIPSL'
771	CALL histwrite(nid,name,itau,Field2d,iim*jj_nb,index2d)
772	IF (prt_level >= 10) write(lunout,*)'Finished sending ',name,' to IOIPSL'
773	else
774	ALLOCATE(fieldok(npstn))
775	ALLOCATE(index2d(npstn))
776
777	if(is_sequential) then
778	! klon_mpi_begin=1
779	! klon_mpi_end=klon
780	DO ip=1, npstn
781	fieldok(ip)=buffer_omp(nptabij(ip))
782	ENDDO
783	else
784	DO ip=1, npstn
785	! print*,'histwrite2d is_sequential npstn ip name nptabij',npstn,ip,name,nptabij(ip)
786	IF(nptabij(ip).GE.klon_mpi_begin.AND. &
787	nptabij(ip).LE.klon_mpi_end) THEN
788	fieldok(ip)=buffer_omp(nptabij(ip)-klon_mpi_begin+1)
789	ENDIF
790	ENDDO
791	endif
792	IF (prt_level >= 10) write(lunout,*)'Sending ',name,' to IOIPSL'
793	CALL histwrite(nid,name,itau,fieldok,npstn,index2d)
794	IF (prt_level >= 10) write(lunout,*)'Finished sending ',name,' to IOIPSL'
795	!
796	endif
797	deallocate(index2d)
798	deallocate(fieldok)
799	!$OMP END MASTER
800
801
802	end SUBROUTINE histwrite2d_phy_old
803
804	SUBROUTINE histwrite3d_phy_old(nid,lpoint,name,itau,field)
805	USE dimphy, only: klon
806	USE mod_phys_lmdz_para, only: Gather_omp, grid1Dto2D_mpi, &
807	is_sequential, klon_mpi_begin, klon_mpi_end, &
808	jj_nb, klon_mpi
809	use ioipsl, only: histwrite
810	IMPLICIT NONE
811	include 'dimensions.h'
812	include 'iniprint.h'
813
814	integer,INTENT(IN) :: nid
815	logical,INTENT(IN) :: lpoint
816	character(), INTENT(IN) :: name
817	integer, INTENT(IN) :: itau
818	REAL,DIMENSION(:,:),INTENT(IN) :: field ! --> field(klon,:)
819	REAL,DIMENSION(klon_mpi,size(field,2)) :: buffer_omp
820	REAL :: Field3d(iim,jj_nb,size(field,2))
821	INTEGER :: ip, n, nlev
822	INTEGER, ALLOCATABLE, DIMENSION(:) :: index3d
823	REAL,allocatable, DIMENSION(:,:) :: fieldok
824
825
826	IF (size(field,1)/=klon) CALL abort_gcm('iophy::histwrite3d','Field first DIMENSION not equal to klon',1)
827	nlev=size(field,2)
828
829	CALL Gather_omp(field,buffer_omp)
830	!$OMP MASTER
831	CALL grid1Dto2D_mpi(buffer_omp,field3d)
832	if(.NOT.lpoint) THEN
833	ALLOCATE(index3d(iimjj_nbnlev))
834	ALLOCATE(fieldok(iim*jj_nb,nlev))
835	IF (prt_level >= 10) write(lunout,*)'Sending ',name,' to IOIPSL'
836	CALL histwrite(nid,name,itau,Field3d,iimjj_nbnlev,index3d)
837	IF (prt_level >= 10) write(lunout,*)'Finished sending ',name,' to IOIPSL'
838	else
839	nlev=size(field,2)
840	ALLOCATE(index3d(npstn*nlev))
841	ALLOCATE(fieldok(npstn,nlev))
842
843	if(is_sequential) then
844	! klon_mpi_begin=1
845	! klon_mpi_end=klon
846	DO n=1, nlev
847	DO ip=1, npstn
848	fieldok(ip,n)=buffer_omp(nptabij(ip),n)
849	ENDDO
850	ENDDO
851	else
852	DO n=1, nlev
853	DO ip=1, npstn
854	IF(nptabij(ip).GE.klon_mpi_begin.AND. &
855	nptabij(ip).LE.klon_mpi_end) THEN
856	fieldok(ip,n)=buffer_omp(nptabij(ip)-klon_mpi_begin+1,n)
857	ENDIF
858	ENDDO
859	ENDDO
860	endif
861	IF (prt_level >= 10) write(lunout,*)'Sending ',name,' to IOIPSL'
862	CALL histwrite(nid,name,itau,fieldok,npstn*nlev,index3d)
863	IF (prt_level >= 10) write(lunout,*)'Finished sending ',name,' to IOIPSL'
864	endif
865	deallocate(index3d)
866	deallocate(fieldok)
867	!$OMP END MASTER
868
869	end SUBROUTINE histwrite3d_phy_old
870
871
872
873
874	! ug NOUVELLE VERSION DES WRITE AVEC LA BOUCLE DO RENTREE
875	SUBROUTINE histwrite2d_phy(var,field, STD_iff)
876	USE dimphy, only: klon
877	USE mod_phys_lmdz_para, only: gather_omp, grid1dto2d_mpi, &
878	jj_nb, klon_mpi, klon_mpi_begin, &
879	klon_mpi_end, is_sequential
880	USE ioipsl, only: histwrite
881	use phys_output_var_mod, only: ctrl_out, clef_files, lev_files, &
882	nfiles, vars_defined, clef_stations, &
883	nid_files
884	#ifdef CPP_XIOS
885	USE xios, only: xios_send_field
886	#endif
887
888
889	IMPLICIT NONE
890	INCLUDE 'dimensions.h'
891	INCLUDE 'iniprint.h'
892
893	TYPE(ctrl_out), INTENT(IN) :: var
894	REAL, DIMENSION(:), INTENT(IN) :: field
895	INTEGER, INTENT(IN), OPTIONAL :: STD_iff ! ug RUSTINE POUR LES STD LEVS.....
896
897	INTEGER :: iff, iff_beg, iff_end
898	LOGICAL, SAVE :: firstx
899	!$OMP THREADPRIVATE(firstx)
900
901	REAL,DIMENSION(klon_mpi) :: buffer_omp
902	INTEGER, allocatable, DIMENSION(:) :: index2d
903	REAL :: Field2d(iim,jj_nb)
904
905	INTEGER :: ip
906	REAL, ALLOCATABLE, DIMENSION(:) :: fieldok
907
908	IF (prt_level >= 10) THEN
909	WRITE(lunout,*)'Begin histwrite2d_phy for ',trim(var%name)
910	ENDIF
911	! ug RUSTINE POUR LES STD LEVS.....
912	IF (PRESENT(STD_iff)) THEN
913	iff_beg = STD_iff
914	iff_end = STD_iff
915	ELSE
916	iff_beg = 1
917	iff_end = nfiles
918	END IF
919
920	! On regarde si on est dans la phase de définition ou d'écriture:
921	IF(.NOT.vars_defined) THEN
922	!$OMP MASTER
923	!Si phase de définition.... on définit
924	DO iff=iff_beg, iff_end
925	IF (clef_files(iff)) THEN
926	CALL histdef2d(iff, var)
927	ENDIF
928	ENDDO
929	!$OMP END MASTER
930	ELSE
931
932	!Et sinon on.... écrit
933	IF (SIZE(field)/=klon) CALL abort_gcm('iophy::histwrite2d_phy','Field first DIMENSION not equal to klon',1)
934
935	if (prt_level >= 10) then
936	write(lunout,*)"histwrite2d_phy: .not.vars_defined ; time to gather and write ", &
937	trim(var%name)
938	endif
939
940	CALL Gather_omp(field,buffer_omp)
941	!$OMP MASTER
942	CALL grid1Dto2D_mpi(buffer_omp,Field2d)
943
944	! La boucle sur les fichiers:
945	firstx=.true.
946	DO iff=iff_beg, iff_end
947	IF (var%flag(iff) <= lev_files(iff) .AND. clef_files(iff)) THEN
948
949	#ifdef CPP_XIOS
950	IF (firstx) THEN
951	if (prt_level >= 10) then
952	write(lunout,*)'Dans iophy histwrite2D,iff,var%name ',&
953	iff,trim(var%name)
954	write(lunout,*)"histwrite2d_phy:.NOT.clef_stations(iff)and iff==iff_beg, call xios_send_field"
955	endif
956	CALL xios_send_field(var%name, Field2d)
957	firstx=.false.
958	ENDIF
959	#endif
960
961	IF(.NOT.clef_stations(iff)) THEN
962	ALLOCATE(index2d(iim*jj_nb))
963	ALLOCATE(fieldok(iim*jj_nb))
964	#ifndef CPP_NO_IOIPSL
965	CALL histwrite(nid_files(iff),var%name,itau_iophy,Field2d,iim*jj_nb,index2d)
966	#endif
967	!#ifdef CPP_XIOS
968	! IF (iff == iff_beg) THEN
969	! if (prt_level >= 10) then
970	! write(lunout,*)"histwrite2d_phy: .NOT.clef_stations(iff) and iff==iff_beg, call xios_send_field"
971	! endif
972	! CALL xios_send_field(var%name, Field2d)
973	! ENDIF
974	!#endif
975	ELSE
976	ALLOCATE(fieldok(npstn))
977	ALLOCATE(index2d(npstn))
978
979	IF (is_sequential) THEN
980	DO ip=1, npstn
981	fieldok(ip)=buffer_omp(nptabij(ip))
982	ENDDO
983	ELSE
984	DO ip=1, npstn
985	write(lunout,*)'histwrite2d_phy is_sequential npstn ip namenptabij',npstn,ip,var%name,nptabij(ip)
986	IF(nptabij(ip).GE.klon_mpi_begin.AND. &
987	nptabij(ip).LE.klon_mpi_end) THEN
988	fieldok(ip)=buffer_omp(nptabij(ip)-klon_mpi_begin+1)
989	ENDIF
990	ENDDO
991	ENDIF ! of IF (is_sequential)
992	#ifndef CPP_NO_IOIPSL
993	if (prt_level >= 10) then
994	write(lunout,*)"histwrite2d_phy: clef_stations(iff) and iff==iff_beg, call wxios_write_2D"
995	endif
996	CALL histwrite(nid_files(iff),var%name,itau_iophy,fieldok,npstn,index2d)
997	#endif
998	ENDIF ! of IF(.NOT.clef_stations(iff))
999
1000	deallocate(index2d)
1001	deallocate(fieldok)
1002	ENDIF !levfiles
1003	ENDDO ! of DO iff=iff_beg, iff_end
1004	!$OMP END MASTER
1005	ENDIF ! vars_defined
1006	IF (prt_level >= 10) WRITE(lunout,*)'End histwrite2d_phy ',trim(var%name)
1007	END SUBROUTINE histwrite2d_phy
1008
1009
1010	! ug NOUVELLE VERSION DES WRITE AVEC LA BOUCLE DO RENTREE
1011	SUBROUTINE histwrite3d_phy(var, field, STD_iff)
1012	USE dimphy, only: klon, klev
1013	USE mod_phys_lmdz_para, only: gather_omp, grid1dto2d_mpi, &
1014	jj_nb, klon_mpi, klon_mpi_begin, &
1015	klon_mpi_end, is_sequential
1016	USE ioipsl, only: histwrite
1017	use phys_output_var_mod, only: ctrl_out, clef_files, lev_files, &
1018	nfiles, vars_defined, clef_stations, &
1019	nid_files
1020	#ifdef CPP_XIOS
1021	USE xios, only: xios_send_field
1022	#endif
1023
1024
1025	IMPLICIT NONE
1026	INCLUDE 'dimensions.h'
1027	INCLUDE 'iniprint.h'
1028
1029	TYPE(ctrl_out), INTENT(IN) :: var
1030	REAL, DIMENSION(:,:), INTENT(IN) :: field ! --> field(klon,:)
1031	INTEGER, INTENT(IN), OPTIONAL :: STD_iff ! ug RUSTINE POUR LES STD LEVS.....
1032
1033	INTEGER :: iff, iff_beg, iff_end
1034	LOGICAL, SAVE :: firstx
1035	!$OMP THREADPRIVATE(firstx)
1036	REAL,DIMENSION(klon_mpi,SIZE(field,2)) :: buffer_omp
1037	REAL :: Field3d(iim,jj_nb,SIZE(field,2))
1038	INTEGER :: ip, n, nlev, nlevx
1039	INTEGER, ALLOCATABLE, DIMENSION(:) :: index3d
1040	REAL,ALLOCATABLE, DIMENSION(:,:) :: fieldok
1041
1042	IF (prt_level >= 10) write(lunout,*)'Begin histrwrite3d ',var%name
1043
1044	! ug RUSTINE POUR LES STD LEVS.....
1045	IF (PRESENT(STD_iff)) THEN
1046	iff_beg = STD_iff
1047	iff_end = STD_iff
1048	ELSE
1049	iff_beg = 1
1050	iff_end = nfiles
1051	END IF
1052
1053	! On regarde si on est dans la phase de définition ou d'écriture:
1054	IF(.NOT.vars_defined) THEN
1055	!Si phase de définition.... on définit
1056	!$OMP MASTER
1057	DO iff=iff_beg, iff_end
1058	IF (clef_files(iff)) THEN
1059	CALL histdef3d(iff, var)
1060	ENDIF
1061	ENDDO
1062	!$OMP END MASTER
1063	ELSE
1064	!Et sinon on.... écrit
1065	!JE IF (SIZE(field,1)/=klon) CALL abort_gcm('iophy::histwrite3d','Field first DIMENSION not equal to klon',1)
1066	nlev=SIZE(field,2)
1067	if (nlev.eq.klev+1) then
1068	nlevx=klev
1069	else
1070	nlevx=nlev
1071	endif
1072
1073	CALL Gather_omp(field,buffer_omp)
1074	!$OMP MASTER
1075	CALL grid1Dto2D_mpi(buffer_omp,field3d)
1076
1077
1078	! BOUCLE SUR LES FICHIERS
1079	firstx=.true.
1080	DO iff=iff_beg, iff_end
1081	IF (var%flag(iff) <= lev_files(iff) .AND. clef_files(iff)) THEN
1082	#ifdef CPP_XIOS
1083	IF (firstx) THEN
1084	if (prt_level >= 10) then
1085	write(lunout,*)'Dans iophy, histwrite3D iff nlev klev firstx', &
1086	iff,nlev,klev, firstx
1087	write(lunout,*)'histwrite3d_phy: call xios_send_field for ', &
1088	trim(var%name), ' with iim jjm nlevx = ', &
1089	iim,jj_nb,nlevx
1090	endif
1091	CALL xios_send_field(var%name, Field3d(:,:,1:nlevx))
1092	firstx=.false.
1093	ENDIF
1094	#endif
1095	IF (.NOT.clef_stations(iff)) THEN
1096	ALLOCATE(index3d(iimjj_nbnlev))
1097	ALLOCATE(fieldok(iim*jj_nb,nlev))
1098
1099	#ifndef CPP_NO_IOIPSL
1100	CALL histwrite(nid_files(iff),var%name,itau_iophy,Field3d,iimjj_nbnlev,index3d)
1101	#endif
1102
1103	!#ifdef CPP_XIOS
1104	! IF (iff == 1) THEN
1105	! CALL xios_send_field(var%name, Field3d(:,:,1:klev))
1106	! ENDIF
1107	!#endif
1108	!
1109	ELSE
1110	nlev=size(field,2)
1111	ALLOCATE(index3d(npstn*nlev))
1112	ALLOCATE(fieldok(npstn,nlev))
1113
1114	IF (is_sequential) THEN
1115	DO n=1, nlev
1116	DO ip=1, npstn
1117	fieldok(ip,n)=buffer_omp(nptabij(ip),n)
1118	ENDDO
1119	ENDDO
1120	ELSE
1121	DO n=1, nlev
1122	DO ip=1, npstn
1123	IF(nptabij(ip).GE.klon_mpi_begin.AND. &
1124	nptabij(ip).LE.klon_mpi_end) THEN
1125	fieldok(ip,n)=buffer_omp(nptabij(ip)-klon_mpi_begin+1,n)
1126	ENDIF
1127	ENDDO
1128	ENDDO
1129	ENDIF
1130	#ifndef CPP_NO_IOIPSL
1131	CALL histwrite(nid_files(iff),var%name,itau_iophy,fieldok,npstn*nlev,index3d)
1132	#endif
1133	ENDIF
1134	deallocate(index3d)
1135	deallocate(fieldok)
1136	ENDIF
1137	ENDDO
1138	!$OMP END MASTER
1139	ENDIF ! vars_defined
1140	IF (prt_level >= 10) write(lunout,*)'End histrwrite3d ',var%name
1141	END SUBROUTINE histwrite3d_phy
1142
1143
1144	! VERSION DES HISTWRITE DEDIEES AU TOUT-XIOS-XML DEJA UTILISEE DANS PHYDEV
1145	#ifdef CPP_XIOS
1146	SUBROUTINE histwrite2d_xios(field_name,field)
1147	USE dimphy, only: klon
1148	USE mod_phys_lmdz_para, only: gather_omp, grid1Dto2D_mpi, &
1149	is_sequential, klon_mpi_begin, klon_mpi_end, &
1150	jj_nb, klon_mpi
1151	USE xios, only: xios_send_field
1152
1153
1154	IMPLICIT NONE
1155	INCLUDE 'dimensions.h'
1156	INCLUDE 'iniprint.h'
1157
1158	CHARACTER(LEN=*), INTENT(IN) :: field_name
1159	REAL, DIMENSION(:), INTENT(IN) :: field
1160
1161	REAL,DIMENSION(klon_mpi) :: buffer_omp
1162	INTEGER, allocatable, DIMENSION(:) :: index2d
1163	REAL :: Field2d(iim,jj_nb)
1164
1165	INTEGER :: ip
1166	REAL, ALLOCATABLE, DIMENSION(:) :: fieldok
1167
1168	IF (prt_level >= 10) WRITE(lunout,*)'Begin histrwrite2d_xios ',field_name
1169
1170	!Et sinon on.... écrit
1171	IF (SIZE(field)/=klon) CALL abort_gcm('iophy::histwrite2d_xios','Field first DIMENSION not equal to klon',1)
1172
1173	CALL Gather_omp(field,buffer_omp)
1174	!$OMP MASTER
1175	CALL grid1Dto2D_mpi(buffer_omp,Field2d)
1176
1177	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1178	!ATTENTION, STATIONS PAS GEREES !
1179	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1180	!IF(.NOT.clef_stations(iff)) THEN
1181	IF (.TRUE.) THEN
1182	ALLOCATE(index2d(iim*jj_nb))
1183	ALLOCATE(fieldok(iim*jj_nb))
1184
1185
1186	CALL xios_send_field(field_name, Field2d)
1187
1188	ELSE
1189	ALLOCATE(fieldok(npstn))
1190	ALLOCATE(index2d(npstn))
1191
1192	IF (is_sequential) THEN
1193	DO ip=1, npstn
1194	fieldok(ip)=buffer_omp(nptabij(ip))
1195	ENDDO
1196	ELSE
1197	DO ip=1, npstn
1198	PRINT*,'histwrite2d_xios is_sequential npstn ip namenptabij',npstn,ip,field_name,nptabij(ip)
1199	IF(nptabij(ip).GE.klon_mpi_begin.AND. &
1200	nptabij(ip).LE.klon_mpi_end) THEN
1201	fieldok(ip)=buffer_omp(nptabij(ip)-klon_mpi_begin+1)
1202	ENDIF
1203	ENDDO
1204	ENDIF
1205
1206	ENDIF
1207
1208	deallocate(index2d)
1209	deallocate(fieldok)
1210	!$OMP END MASTER
1211
1212	IF (prt_level >= 10) WRITE(lunout,*)'End histrwrite2d_xios ',field_name
1213	END SUBROUTINE histwrite2d_xios
1214
1215
1216	! ug NOUVELLE VERSION DES WRITE AVEC LA BOUCLE DO RENTREE
1217	SUBROUTINE histwrite3d_xios(field_name, field)
1218	USE dimphy, only: klon, klev
1219	USE mod_phys_lmdz_para, only: gather_omp, grid1Dto2D_mpi, &
1220	is_sequential, klon_mpi_begin, klon_mpi_end, &
1221	jj_nb, klon_mpi
1222	USE xios, only: xios_send_field
1223
1224
1225	IMPLICIT NONE
1226	INCLUDE 'dimensions.h'
1227	INCLUDE 'iniprint.h'
1228
1229	CHARACTER(LEN=*), INTENT(IN) :: field_name
1230	REAL, DIMENSION(:,:), INTENT(IN) :: field ! --> field(klon,:)
1231
1232	REAL,DIMENSION(klon_mpi,SIZE(field,2)) :: buffer_omp
1233	REAL :: Field3d(iim,jj_nb,SIZE(field,2))
1234	INTEGER :: ip, n, nlev
1235	INTEGER, ALLOCATABLE, DIMENSION(:) :: index3d
1236	REAL,ALLOCATABLE, DIMENSION(:,:) :: fieldok
1237
1238	IF (prt_level >= 10) write(lunout,*)'Begin histrwrite3d_xios ',field_name
1239
1240	!Et on.... écrit
1241	IF (SIZE(field,1)/=klon) CALL abort_gcm('iophy::histwrite3d','Field first DIMENSION not equal to klon',1)
1242	nlev=SIZE(field,2)
1243
1244
1245	CALL Gather_omp(field,buffer_omp)
1246	!$OMP MASTER
1247	CALL grid1Dto2D_mpi(buffer_omp,field3d)
1248
1249	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1250	!ATTENTION, STATIONS PAS GEREES !
1251	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1252	!IF (.NOT.clef_stations(iff)) THEN
1253	IF(.TRUE.)THEN
1254	ALLOCATE(index3d(iimjj_nbnlev))
1255	ALLOCATE(fieldok(iim*jj_nb,nlev))
1256	CALL xios_send_field(field_name, Field3d(:,:,1:nlev))
1257
1258	ELSE
1259	nlev=size(field,2)
1260	ALLOCATE(index3d(npstn*nlev))
1261	ALLOCATE(fieldok(npstn,nlev))
1262
1263	IF (is_sequential) THEN
1264	DO n=1, nlev
1265	DO ip=1, npstn
1266	fieldok(ip,n)=buffer_omp(nptabij(ip),n)
1267	ENDDO
1268	ENDDO
1269	ELSE
1270	DO n=1, nlev
1271	DO ip=1, npstn
1272	IF(nptabij(ip).GE.klon_mpi_begin.AND. &
1273	nptabij(ip).LE.klon_mpi_end) THEN
1274	fieldok(ip,n)=buffer_omp(nptabij(ip)-klon_mpi_begin+1,n)
1275	ENDIF
1276	ENDDO
1277	ENDDO
1278	ENDIF
1279	ENDIF
1280	deallocate(index3d)
1281	deallocate(fieldok)
1282	!$OMP END MASTER
1283
1284	IF (prt_level >= 10) write(lunout,*)'End histrwrite3d_xios ',field_name
1285	END SUBROUTINE histwrite3d_xios
1286	#endif
1287	end module iophy

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

Download in other formats:

Original Format