Context Navigation

iophy.F90 @ 3184

Last change on this file since 3184 was 3107, checked in by oboucher, 7 years ago
Minor changes related to previous commit
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: 48.4 KB

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

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

Download in other formats:

Original Format