Context Navigation

iophy.F90 @ 3405

Last change on this file since 3405 was 3356, checked in by Laurent Fairhead, 6 years ago
First attempt at merging with trunk
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: 51.2 KB

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

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

Download in other formats:

Original Format