Context Navigation

iophy.F90 @ 3335

Last change on this file since 3335 was 3266, checked in by oboucher, 7 years ago
Added a broadcast of flags that are changed back to T in histdef2d and histdef3d Improved the indenting throughout
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: 50.1 KB

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

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

Download in other formats:

Original Format