Context Navigation

iophy.F90 @ 2429

Last change on this file since 2429 was 2429, checked in by Laurent Fairhead, 8 years ago
Correction on the calculation of the surface of the grid at the poles (problem was introduced in r2222). Due to the different distribution of OMP tasks in the dynamics and the physics, had to introduce 2 new logical variables, is_pole_north_phy and is_pole_south_phy, and so decided to rename the old is_north_pole/is_south_pole to is_north_pole_dyn/is_south_pole_dyn to stay coherent and, hopefully, clear things up a bit. LF
Property copyright set to Name of program: LMDZ Creation date: 1984 Version: LMDZ5 License: CeCILL version 2 Holder: Laboratoire de m\'et\'eorologie dynamique, CNRS, UMR 8539 See the license file in the root directory Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 43.6 KB

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

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

Download in other formats:

Original Format