Context Navigation

iophy.F90 @ 4188

Last change on this file since 4188 was 3003, checked in by Laurent Fairhead, 7 years ago
Modifications to the code and xml files to output Ap and B, the coefficients of the hybrid coordinates as requested by the CMIP6 DataRequest? LF (with guidance from A. Caubel and S. Senesi)
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: 47.8 KB

Line
1	!
2	! $Id: iophy.F90 3003 2017-10-03 14:45:26Z 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, 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 dryaod_dry=true if at least one of the concerned variables are defined
667	IF (var%name=='dryod550aer') THEN
668	IF ( var%flag(iff)<=lev_files(iff) ) dryaod_diag=.TRUE.
669	ENDIF
670	!
671	DO naero = 1, naero_tot-1
672	IF (var%name=='dryod550_'//name_aero_tau(naero)) THEN
673	IF ( var%flag(iff)<=lev_files(iff) ) dryaod_diag=.TRUE.
674	ENDIF
675	ENDDO
676	! Set ok_4xCO2atm=true if at least one of the concerned variables are
677	! defined
678	IF (var%name=='rsut4co2'.OR.var%name=='rlut4co2'.OR.var%name=='rsutcs4co2' &
679	.OR. var%name=='rlutcs4co2'.OR.var%name=='rsu4co2'.OR.var%name=='rsucs4co2' &
680	.OR.var%name=='rsu4co2'.OR.var%name=='rsucs4co2'.OR.var%name=='rsd4co2'.OR. &
681	var%name=='rsdcs4co2'.OR.var%name=='rlu4co2'.OR.var%name=='rlucs4co2'.OR.&
682	var%name=='rld4co2'.OR.var%name=='rldcs4co2') THEN
683	IF ( var%flag(iff)<=lev_files(iff) ) ok_4xCO2atm=.TRUE.
684	ENDIF
685	END SUBROUTINE histdef2d
686
687	SUBROUTINE histdef3d (iff,var)
688
689	USE ioipsl, ONLY: histdef
690	USE dimphy, ONLY: klev
691	USE mod_phys_lmdz_para, ONLY: jj_nb
692	USE phys_output_var_mod, ONLY: ctrl_out, type_ecri_files, zoutm, zdtime_moy, &
693	clef_stations, phys_out_filenames, lev_files, &
694	nid_files, nhorim, swaero_diag, dryaod_diag, levmin, &
695	levmax, nvertm
696	USE print_control_mod, ONLY: prt_level,lunout
697	USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat
698	#ifdef CPP_XIOS
699	USE wxios, ONLY: wxios_add_field_to_file
700	#endif
701	IMPLICIT NONE
702
703	INCLUDE "clesphys.h"
704
705	INTEGER :: iff
706	TYPE(ctrl_out) :: var
707
708	REAL zstophym
709	CHARACTER(LEN=20) :: typeecrit
710
711	! ug On récupère le type écrit de la structure:
712	! Assez moche, à refaire si meilleure méthode...
713	IF (INDEX(var%type_ecrit(iff), "once") > 0) THEN
714	typeecrit = 'once'
715	ELSE IF(INDEX(var%type_ecrit(iff), "t_min") > 0) THEN
716	typeecrit = 't_min(X)'
717	ELSE IF(INDEX(var%type_ecrit(iff), "t_max") > 0) THEN
718	typeecrit = 't_max(X)'
719	ELSE IF(INDEX(var%type_ecrit(iff), "inst") > 0) THEN
720	typeecrit = 'inst(X)'
721	ELSE
722	typeecrit = type_ecri_files(iff)
723	ENDIF
724
725
726	! Appel a la lecture des noms et niveau d'ecriture des variables dans output.def
727	CALL conf_physoutputs(var%name,var%flag)
728
729	IF (typeecrit=='inst(X)'.OR.typeecrit=='once') THEN
730	zstophym=zoutm(iff)
731	ELSE
732	zstophym=zdtime_moy
733	ENDIF
734
735	IF(.NOT.clef_stations(iff)) THEN
736
737	#ifdef CPP_XIOS
738	IF (.not. ok_all_xml) THEN
739	IF ( var%flag(iff)<=lev_files(iff) ) THEN
740	CALL wxios_add_field_to_file(var%name, 3, iff, phys_out_filenames(iff), &
741	var%description, var%unit, var%flag(iff), typeecrit)
742	IF (prt_level >= 10) THEN
743	WRITE(lunout,*) 'histdef3d: call wxios_add_field_to_file var%name iff: ', &
744	trim(var%name),iff
745	ENDIF
746	ENDIF
747	ENDIF
748	#endif
749	#ifndef CPP_IOIPSL_NO_OUTPUT
750
751	IF ( var%flag(iff)<=lev_files(iff) ) THEN
752	CALL histdef (nid_files(iff), var%name, var%description, var%unit, &
753	nbp_lon, jj_nb, nhorim(iff), klev, levmin(iff), &
754	levmax(iff)-levmin(iff)+1, nvertm(iff), 32, typeecrit, &
755	zstophym, zoutm(iff))
756	ENDIF
757	ELSE
758	IF ( var%flag(iff)<=lev_files(iff)) THEN
759	CALL histdef (nid_files(iff), var%name, var%description, var%unit, &
760	npstn,1,nhorim(iff), klev, levmin(iff), &
761	levmax(iff)-levmin(iff)+1, nvertm(iff), 32, &
762	typeecrit, zstophym,zoutm(iff))
763	ENDIF
764	#endif
765	ENDIF
766	END SUBROUTINE histdef3d
767
768	SUBROUTINE conf_physoutputs(nam_var,flag_var)
769	!!! Lecture des noms et niveau de sortie des variables dans output.def
770	! en utilisant les routines getin de IOIPSL
771	USE ioipsl, ONLY: getin
772	USE phys_output_var_mod, ONLY: nfiles
773	USE print_control_mod, ONLY: prt_level,lunout
774	IMPLICIT NONE
775
776	CHARACTER(LEN=20) :: nam_var
777	INTEGER, DIMENSION(nfiles) :: flag_var
778
779	IF(prt_level>10) WRITE(lunout,*)'Avant getin: nam_var flag_var ',nam_var,flag_var(:)
780	CALL getin('flag_'//nam_var,flag_var)
781	CALL getin('name_'//nam_var,nam_var)
782	IF(prt_level>10) WRITE(lunout,*)'Apres getin: nam_var flag_var ',nam_var,flag_var(:)
783
784	END SUBROUTINE conf_physoutputs
785
786
787	SUBROUTINE histwrite2d_phy_old(nid,lpoint,name,itau,field)
788	USE dimphy, ONLY: klon
789	USE mod_phys_lmdz_para, ONLY: Gather_omp, grid1Dto2D_mpi, &
790	is_sequential, klon_mpi_begin, klon_mpi_end, &
791	jj_nb, klon_mpi
792	USE ioipsl, ONLY: histwrite
793	USE print_control_mod, ONLY: prt_level,lunout
794	USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat
795	IMPLICIT NONE
796
797	INTEGER,INTENT(IN) :: nid
798	LOGICAL,INTENT(IN) :: lpoint
799	CHARACTER(), INTENT(IN) :: name
800	INTEGER, INTENT(IN) :: itau
801	REAL,DIMENSION(:),INTENT(IN) :: field
802	REAL,DIMENSION(klon_mpi) :: buffer_omp
803	INTEGER, allocatable, DIMENSION(:) :: index2d
804	REAL :: Field2d(nbp_lon,jj_nb)
805
806	INTEGER :: ip
807	REAL,ALLOCATABLE,DIMENSION(:) :: fieldok
808
809	IF (size(field)/=klon) CALL abort_physic('iophy::histwrite2d','Field first DIMENSION not equal to klon',1)
810
811	CALL Gather_omp(field,buffer_omp)
812	!$OMP MASTER
813	CALL grid1Dto2D_mpi(buffer_omp,Field2d)
814	if(.NOT.lpoint) THEN
815	ALLOCATE(index2d(nbp_lon*jj_nb))
816	ALLOCATE(fieldok(nbp_lon*jj_nb))
817	IF (prt_level >= 10) write(lunout,*)'Sending ',name,' to IOIPSL'
818	CALL histwrite(nid,name,itau,Field2d,nbp_lon*jj_nb,index2d)
819	IF (prt_level >= 10) write(lunout,*)'Finished sending ',name,' to IOIPSL'
820	ELSE
821	ALLOCATE(fieldok(npstn))
822	ALLOCATE(index2d(npstn))
823
824	IF (is_sequential) THEN
825	! klon_mpi_begin=1
826	! klon_mpi_end=klon
827	DO ip=1, npstn
828	fieldok(ip)=buffer_omp(nptabij(ip))
829	ENDDO
830	ELSE
831	DO ip=1, npstn
832	! print*,'histwrite2d is_sequential npstn ip name nptabij',npstn,ip,name,nptabij(ip)
833	IF(nptabij(ip).GE.klon_mpi_begin.AND. &
834	nptabij(ip).LE.klon_mpi_end) THEN
835	fieldok(ip)=buffer_omp(nptabij(ip)-klon_mpi_begin+1)
836	ENDIF
837	ENDDO
838	ENDIF
839	IF (prt_level >= 10) write(lunout,*)'Sending ',name,' to IOIPSL'
840	CALL histwrite(nid,name,itau,fieldok,npstn,index2d)
841	IF (prt_level >= 10) write(lunout,*)'Finished sending ',name,' to IOIPSL'
842	!
843	ENDIF
844	DEALLOCATE(index2d)
845	DEALLOCATE(fieldok)
846	!$OMP END MASTER
847
848
849	END SUBROUTINE histwrite2d_phy_old
850
851	SUBROUTINE histwrite3d_phy_old(nid,lpoint,name,itau,field)
852	USE dimphy, ONLY: klon
853	USE mod_phys_lmdz_para, ONLY: Gather_omp, grid1Dto2D_mpi, &
854	is_sequential, klon_mpi_begin, klon_mpi_end, &
855	jj_nb, klon_mpi
856	USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat
857	USE ioipsl, ONLY: histwrite
858	USE print_control_mod, ONLY: prt_level,lunout
859	IMPLICIT NONE
860
861	INTEGER,INTENT(IN) :: nid
862	LOGICAL,INTENT(IN) :: lpoint
863	CHARACTER(), INTENT(IN) :: name
864	INTEGER, INTENT(IN) :: itau
865	REAL,DIMENSION(:,:),INTENT(IN) :: field ! --> field(klon,:)
866	REAL,DIMENSION(klon_mpi,size(field,2)) :: buffer_omp
867	REAL :: Field3d(nbp_lon,jj_nb,size(field,2))
868	INTEGER :: ip, n, nlev
869	INTEGER, ALLOCATABLE, DIMENSION(:) :: index3d
870	REAL,allocatable, DIMENSION(:,:) :: fieldok
871
872
873	IF (size(field,1)/=klon) CALL abort_physic('iophy::histwrite3d','Field first DIMENSION not equal to klon',1)
874	nlev=size(field,2)
875
876	CALL Gather_omp(field,buffer_omp)
877	!$OMP MASTER
878	CALL grid1Dto2D_mpi(buffer_omp,field3d)
879	IF (.NOT.lpoint) THEN
880	ALLOCATE(index3d(nbp_lonjj_nbnlev))
881	ALLOCATE(fieldok(nbp_lon*jj_nb,nlev))
882	IF (prt_level >= 10) write(lunout,*)'Sending ',name,' to IOIPSL'
883	CALL histwrite(nid,name,itau,Field3d,nbp_lonjj_nbnlev,index3d)
884	IF (prt_level >= 10) write(lunout,*)'Finished sending ',name,' to IOIPSL'
885	ELSE
886	nlev=size(field,2)
887	ALLOCATE(index3d(npstn*nlev))
888	ALLOCATE(fieldok(npstn,nlev))
889
890	IF (is_sequential) THEN
891	! klon_mpi_begin=1
892	! klon_mpi_end=klon
893	DO n=1, nlev
894	DO ip=1, npstn
895	fieldok(ip,n)=buffer_omp(nptabij(ip),n)
896	ENDDO
897	ENDDO
898	ELSE
899	DO n=1, nlev
900	DO ip=1, npstn
901	IF(nptabij(ip).GE.klon_mpi_begin.AND. &
902	nptabij(ip).LE.klon_mpi_end) THEN
903	fieldok(ip,n)=buffer_omp(nptabij(ip)-klon_mpi_begin+1,n)
904	ENDIF
905	ENDDO
906	ENDDO
907	ENDIF
908	IF (prt_level >= 10) write(lunout,*)'Sending ',name,' to IOIPSL'
909	CALL histwrite(nid,name,itau,fieldok,npstn*nlev,index3d)
910	IF (prt_level >= 10) write(lunout,*)'Finished sending ',name,' to IOIPSL'
911	ENDIF
912	DEALLOCATE(index3d)
913	DEALLOCATE(fieldok)
914	!$OMP END MASTER
915
916	END SUBROUTINE histwrite3d_phy_old
917
918
919
920
921	! ug NOUVELLE VERSION DES WRITE AVEC LA BOUCLE DO RENTREE
922	SUBROUTINE histwrite2d_phy(var,field, STD_iff)
923	USE dimphy, ONLY: klon, klev
924	USE mod_phys_lmdz_para, ONLY: gather_omp, grid1dto2d_mpi, &
925	jj_nb, klon_mpi, klon_mpi_begin, &
926	klon_mpi_end, is_sequential
927	USE ioipsl, ONLY: histwrite
928	USE phys_output_var_mod, ONLY: ctrl_out, clef_files, lev_files, &
929	nfiles, vars_defined, clef_stations, &
930	nid_files
931	USE print_control_mod, ONLY: prt_level,lunout
932	USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat
933	#ifdef CPP_XIOS
934	USE xios, ONLY: xios_send_field
935	#endif
936
937
938	IMPLICIT NONE
939	include 'clesphys.h'
940
941	TYPE(ctrl_out), INTENT(IN) :: var
942	REAL, DIMENSION(:), INTENT(IN) :: field
943	INTEGER, INTENT(IN), OPTIONAL :: STD_iff ! ug RUSTINE POUR LES STD LEVS.....
944
945	INTEGER :: iff, iff_beg, iff_end
946	LOGICAL, SAVE :: firstx
947	!$OMP THREADPRIVATE(firstx)
948
949	REAL,DIMENSION(klon_mpi) :: buffer_omp
950	INTEGER, allocatable, DIMENSION(:) :: index2d
951	REAL :: Field2d(nbp_lon,jj_nb)
952
953	INTEGER :: ip
954	REAL, ALLOCATABLE, DIMENSION(:) :: fieldok
955
956	IF (prt_level >= 10) THEN
957	WRITE(lunout,*)'Begin histwrite2d_phy for ',trim(var%name)
958	ENDIF
959	! ug RUSTINE POUR LES STD LEVS.....
960	IF (PRESENT(STD_iff)) THEN
961	iff_beg = STD_iff
962	iff_end = STD_iff
963	ELSE
964	iff_beg = 1
965	iff_end = nfiles
966	ENDIF
967
968	! On regarde si on est dans la phase de définition ou d'écriture:
969	IF (.NOT.vars_defined) THEN
970	!$OMP MASTER
971	!Si phase de définition.... on définit
972	IF (.not. ok_all_xml) THEN
973	IF (prt_level >= 10) THEN
974	WRITE (lunout,*)"histwrite2d_phy: .not.vars_defined ; time to define ", trim(var%name)
975	ENDIF
976	DO iff=iff_beg, iff_end
977	IF (clef_files(iff)) THEN
978	CALL histdef2d(iff, var)
979	ENDIF
980	ENDDO
981	ENDIF
982	!$OMP END MASTER
983	ELSE
984
985	!Et sinon on.... écrit
986	IF (SIZE(field)/=klon .AND. SIZE(field)/=klev) CALL abort_physic('iophy::histwrite2d_phy','Field first DIMENSION not equal to klon/klev',1)
987	IF (prt_level >= 10) THEn
988	WRITE (lunout,*)"histwrite2d_phy: .not.vars_defined ; time to gather and write ", trim(var%name)
989	ENDIF
990
991
992	IF (SIZE(field) == klon) then
993	CALL Gather_omp(field,buffer_omp)
994	ELSE
995	buffer_omp(:)=0.
996	ENDIF
997	!$OMP MASTER
998	CALL grid1Dto2D_mpi(buffer_omp,Field2d)
999
1000	! La boucle sur les fichiers:
1001	firstx=.true.
1002
1003	IF (ok_all_xml) THEN
1004	#ifdef CPP_XIOS
1005	IF (prt_level >= 10) THEN
1006	write(lunout,*)'Dans iophy histwrite2D,var%name ', trim(var%name)
1007	ENDIF
1008	IF (SIZE(field) == klon) then
1009	CALL xios_send_field(var%name, Field2d)
1010	ELSE
1011	CALL xios_send_field(var%name, field)
1012	ENDIF
1013	IF (prt_level >= 10) THEN
1014	WRITE (lunout,*)'Dans iophy histwrite2D,var%name apres xios_send ', trim(var%name)
1015	ENDIF
1016	#else
1017	CALL abort_physic ('iophy','cannot have ok_all_xml = .T. without CPP_XIOS defined' ,1)
1018	#endif
1019	ELSE
1020	DO iff=iff_beg, iff_end
1021	IF (var%flag(iff) <= lev_files(iff) .AND. clef_files(iff)) THEN
1022
1023	#ifdef CPP_XIOS
1024	IF (firstx) THEN
1025	IF (prt_level >= 10) THEN
1026	WRITE (lunout,*)'Dans iophy histwrite2D,iff,var%name ', iff,trim(var%name)
1027	WRITE (lunout,*)"histwrite2d_phy:.NOT.clef_stations(iff)and iff==iff_beg, call xios_send_field"
1028	ENDIF
1029	IF (SIZE(field) == klon) then
1030	CALL xios_send_field(var%name, Field2d)
1031	ELSE
1032	CALL xios_send_field(var%name, field)
1033	ENDIF
1034	firstx=.false.
1035	ENDIF
1036	#endif
1037
1038	IF (.NOT.clef_stations(iff)) THEN
1039	ALLOCATE(index2d(nbp_lon*jj_nb))
1040	ALLOCATE(fieldok(nbp_lon*jj_nb))
1041	#ifndef CPP_IOIPSL_NO_OUTPUT
1042	CALL histwrite(nid_files(iff),var%name,itau_iophy,Field2d,nbp_lon*jj_nb,index2d)
1043	#endif
1044	!#ifdef CPP_XIOS
1045	! IF (iff == iff_beg) THEN
1046	! if (prt_level >= 10) then
1047	! write(lunout,*)"histwrite2d_phy: .NOT.clef_stations(iff) and iff==iff_beg, call xios_send_field"
1048	! endif
1049	! CALL xios_send_field(var%name, Field2d)
1050	! ENDIF
1051	!#endif
1052	ELSE
1053	ALLOCATE(fieldok(npstn))
1054	ALLOCATE(index2d(npstn))
1055
1056	IF (is_sequential) THEN
1057	DO ip=1, npstn
1058	fieldok(ip)=buffer_omp(nptabij(ip))
1059	ENDDO
1060	ELSE
1061	DO ip=1, npstn
1062	write(lunout,*)'histwrite2d_phy is_sequential npstn ip namenptabij',npstn,ip,var%name,nptabij(ip)
1063	IF(nptabij(ip).GE.klon_mpi_begin.AND. &
1064	nptabij(ip).LE.klon_mpi_end) THEN
1065	fieldok(ip)=buffer_omp(nptabij(ip)-klon_mpi_begin+1)
1066	ENDIF
1067	ENDDO
1068	ENDIF ! of IF (is_sequential)
1069	#ifndef CPP_IOIPSL_NO_OUTPUT
1070	IF (prt_level >= 10) THEn
1071	write(lunout,*)"histwrite2d_phy: clef_stations(iff) and iff==iff_beg, call wxios_write_2D"
1072	ENDIF
1073	CALL histwrite(nid_files(iff),var%name,itau_iophy,fieldok,npstn,index2d)
1074	#endif
1075	ENDIF ! of IF(.NOT.clef_stations(iff))
1076
1077	DEALLOCATE(index2d)
1078	DEALLOCATE(fieldok)
1079	ENDIF !levfiles
1080	ENDDO ! of DO iff=iff_beg, iff_end
1081	ENDIF
1082	!$OMP END MASTER
1083	ENDIF ! vars_defined
1084	IF (prt_level >= 10) WRITE(lunout,*)'End histwrite2d_phy ',trim(var%name)
1085	END SUBROUTINE histwrite2d_phy
1086
1087
1088	! ug NOUVELLE VERSION DES WRITE AVEC LA BOUCLE DO RENTREE
1089	SUBROUTINE histwrite3d_phy(var, field, STD_iff)
1090	USE dimphy, ONLY: klon, klev
1091	USE mod_phys_lmdz_para, ONLY: gather_omp, grid1dto2d_mpi, &
1092	jj_nb, klon_mpi, klon_mpi_begin, &
1093	klon_mpi_end, is_sequential
1094	USE ioipsl, ONLY: histwrite
1095	USE phys_output_var_mod, ONLY: ctrl_out, clef_files, lev_files, &
1096	nfiles, vars_defined, clef_stations, &
1097	nid_files
1098	USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat
1099	#ifdef CPP_XIOS
1100	USE xios, ONLY: xios_send_field
1101	#endif
1102	USE print_control_mod, ONLY: prt_level,lunout
1103
1104	IMPLICIT NONE
1105	include 'clesphys.h'
1106
1107	TYPE(ctrl_out), INTENT(IN) :: var
1108	REAL, DIMENSION(:,:), INTENT(IN) :: field ! --> field(klon,:)
1109	INTEGER, INTENT(IN), OPTIONAL :: STD_iff ! ug RUSTINE POUR LES STD LEVS.....
1110
1111	INTEGER :: iff, iff_beg, iff_end
1112	LOGICAL, SAVE :: firstx
1113	!$OMP THREADPRIVATE(firstx)
1114	REAL,DIMENSION(klon_mpi,SIZE(field,2)) :: buffer_omp
1115	REAL :: Field3d(nbp_lon,jj_nb,SIZE(field,2))
1116	INTEGER :: ip, n, nlev, nlevx
1117	INTEGER, ALLOCATABLE, DIMENSION(:) :: index3d
1118	REAL,ALLOCATABLE, DIMENSION(:,:) :: fieldok
1119
1120	IF (prt_level >= 10) write(lunout,*)'Begin histrwrite3d ',var%name
1121
1122	! ug RUSTINE POUR LES STD LEVS.....
1123	IF (PRESENT(STD_iff)) THEN
1124	iff_beg = STD_iff
1125	iff_end = STD_iff
1126	ELSE
1127	iff_beg = 1
1128	iff_end = nfiles
1129	ENDIF
1130
1131	! On regarde si on est dans la phase de définition ou d'écriture:
1132	IF(.NOT.vars_defined) THEN
1133	!Si phase de définition.... on définit
1134	!$OMP MASTER
1135	DO iff=iff_beg, iff_end
1136	IF (clef_files(iff)) THEN
1137	CALL histdef3d(iff, var)
1138	ENDIF
1139	ENDDO
1140	!$OMP END MASTER
1141	ELSE
1142	!Et sinon on.... écrit
1143
1144	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)
1145
1146	nlev=SIZE(field,2)
1147	IF (nlev.EQ.klev+1) THEN
1148	nlevx=klev
1149	ELSE
1150	nlevx=nlev
1151	ENDIF
1152
1153	IF (SIZE(field,1) == klon) then
1154	CALL Gather_omp(field,buffer_omp)
1155	ELSE
1156	buffer_omp(:,:)=0.
1157	ENDIF
1158	!$OMP MASTER
1159	CALL grid1Dto2D_mpi(buffer_omp,field3d)
1160
1161
1162	! BOUCLE SUR LES FICHIERS
1163	firstx=.true.
1164
1165	IF (ok_all_xml) THEN
1166	#ifdef CPP_XIOS
1167	IF (prt_level >= 10) THEN
1168	write(lunout,*)'Dans iophy histwrite3D,var%name ',&
1169	trim(var%name)
1170	ENDIF
1171	IF (SIZE(field,1) == klon) then
1172	CALL xios_send_field(var%name, Field3d(:,:,1:nlevx))
1173	ELSE
1174	CALL xios_send_field(var%name, field)
1175	ENDIF
1176	#else
1177	CALL abort_physic ('iophy','cannot have ok_all_xml = .T. without CPP_XIOS defined' ,1)
1178	#endif
1179	ELSE
1180
1181
1182	DO iff=iff_beg, iff_end
1183	IF (var%flag(iff) <= lev_files(iff) .AND. clef_files(iff)) THEN
1184	#ifdef CPP_XIOS
1185	IF (firstx) THEN
1186	IF (prt_level >= 10) THEn
1187	WRITE (lunout,*)'Dans iophy, histwrite3D iff nlev klev firstx', &
1188	iff,nlev,klev, firstx
1189	WRITE (lunout,*)'histwrite3d_phy: call xios_send_field for ', &
1190	trim(var%name), ' with iim jjm nlevx = ', &
1191	nbp_lon,jj_nb,nlevx
1192	ENDIF
1193	IF (SIZE(field,1) == klon) then
1194	CALL xios_send_field(var%name, Field3d(:,:,1:nlevx))
1195	ELSE
1196	CALL xios_send_field(var%name, field)
1197	ENDIF
1198	firstx=.false.
1199	ENDIF
1200	#endif
1201	IF (.NOT.clef_stations(iff)) THEN
1202	ALLOCATE(index3d(nbp_lonjj_nbnlev))
1203	ALLOCATE(fieldok(nbp_lon*jj_nb,nlev))
1204
1205	#ifndef CPP_IOIPSL_NO_OUTPUT
1206	CALL histwrite(nid_files(iff),var%name,itau_iophy,Field3d,nbp_lonjj_nbnlev,index3d)
1207	#endif
1208
1209	!#ifdef CPP_XIOS
1210	! IF (iff == 1) THEN
1211	! CALL xios_send_field(var%name, Field3d(:,:,1:klev))
1212	! ENDIF
1213	!#endif
1214	!
1215	ELSE
1216	nlev=size(field,2)
1217	ALLOCATE(index3d(npstn*nlev))
1218	ALLOCATE(fieldok(npstn,nlev))
1219
1220	IF (is_sequential) THEN
1221	DO n=1, nlev
1222	DO ip=1, npstn
1223	fieldok(ip,n)=buffer_omp(nptabij(ip),n)
1224	ENDDO
1225	ENDDO
1226	ELSE
1227	DO n=1, nlev
1228	DO ip=1, npstn
1229	IF(nptabij(ip).GE.klon_mpi_begin.AND. &
1230	nptabij(ip).LE.klon_mpi_end) THEN
1231	fieldok(ip,n)=buffer_omp(nptabij(ip)-klon_mpi_begin+1,n)
1232	ENDIF
1233	ENDDO
1234	ENDDO
1235	ENDIF
1236	#ifndef CPP_IOIPSL_NO_OUTPUT
1237	CALL histwrite(nid_files(iff),var%name,itau_iophy,fieldok,npstn*nlev,index3d)
1238	#endif
1239	ENDIF
1240	DEALLOCATE(index3d)
1241	DEALLOCATE(fieldok)
1242	ENDIF
1243	ENDDO
1244	ENDIF
1245	!$OMP END MASTER
1246	ENDIF ! vars_defined
1247	IF (prt_level >= 10) write(lunout,*)'End histrwrite3d ',var%name
1248	END SUBROUTINE histwrite3d_phy
1249
1250
1251	! VERSION DES HISTWRITE DEDIEES AU TOUT-XIOS-XML DEJA UTILISEE DANS PHYDEV
1252	#ifdef CPP_XIOS
1253	SUBROUTINE histwrite2d_xios(field_name,field)
1254	USE dimphy, ONLY: klon, klev
1255	USE mod_phys_lmdz_para, ONLY: gather_omp, grid1Dto2D_mpi, &
1256	is_sequential, klon_mpi_begin, klon_mpi_end, &
1257	jj_nb, klon_mpi
1258	USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat
1259	USE xios, ONLY: xios_send_field
1260	USE print_control_mod, ONLY: prt_level,lunout
1261
1262	IMPLICIT NONE
1263
1264	CHARACTER(LEN=*), INTENT(IN) :: field_name
1265	REAL, DIMENSION(:), INTENT(IN) :: field
1266
1267	REAL,DIMENSION(klon_mpi) :: buffer_omp
1268	INTEGER, allocatable, DIMENSION(:) :: index2d
1269	REAL :: Field2d(nbp_lon,jj_nb)
1270
1271	INTEGER :: ip
1272	REAL, ALLOCATABLE, DIMENSION(:) :: fieldok
1273
1274	IF (prt_level >= 10) WRITE(lunout,*)'Begin histrwrite2d_xios ',field_name
1275
1276	!Et sinon on.... écrit
1277	IF (SIZE(field)/=klon .AND. SIZE(field)/=klev) CALL abort_physic('iophy::histwrite2d_xios','Field first DIMENSION not equal to klon/klev',1)
1278
1279	IF (SIZE(field) == klev) then
1280	!$OMP MASTER
1281	CALL xios_send_field(field_name,field)
1282	!$OMP END MASTER
1283	ELSE
1284	CALL Gather_omp(field,buffer_omp)
1285	!$OMP MASTER
1286	CALL grid1Dto2D_mpi(buffer_omp,Field2d)
1287
1288	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1289	!ATTENTION, STATIONS PAS GEREES !
1290	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1291	!IF(.NOT.clef_stations(iff)) THEN
1292	IF (.TRUE.) THEN
1293	ALLOCATE(index2d(nbp_lon*jj_nb))
1294	ALLOCATE(fieldok(nbp_lon*jj_nb))
1295
1296
1297	CALL xios_send_field(field_name, Field2d)
1298
1299	ELSE
1300	ALLOCATE(fieldok(npstn))
1301	ALLOCATE(index2d(npstn))
1302
1303	IF (is_sequential) THEN
1304	DO ip=1, npstn
1305	fieldok(ip)=buffer_omp(nptabij(ip))
1306	ENDDO
1307	ELSE
1308	DO ip=1, npstn
1309	PRINT*,'histwrite2d_xios is_sequential npstn ip namenptabij',npstn,ip,field_name,nptabij(ip)
1310	IF(nptabij(ip).GE.klon_mpi_begin.AND. &
1311	nptabij(ip).LE.klon_mpi_end) THEN
1312	fieldok(ip)=buffer_omp(nptabij(ip)-klon_mpi_begin+1)
1313	ENDIF
1314	ENDDO
1315	ENDIF
1316
1317	ENDIF
1318
1319	DEALLOCATE(index2d)
1320	DEALLOCATE(fieldok)
1321	!$OMP END MASTER
1322	ENDIF
1323
1324	IF (prt_level >= 10) WRITE(lunout,*)'End histrwrite2d_xios ',field_name
1325	END SUBROUTINE histwrite2d_xios
1326
1327
1328	! ug NOUVELLE VERSION DES WRITE AVEC LA BOUCLE DO RENTREE
1329	SUBROUTINE histwrite3d_xios(field_name, field)
1330	USE dimphy, ONLY: klon, klev
1331	USE mod_phys_lmdz_para, ONLY: gather_omp, grid1Dto2D_mpi, &
1332	is_sequential, klon_mpi_begin, klon_mpi_end, &
1333	jj_nb, klon_mpi
1334	USE xios, ONLY: xios_send_field
1335	USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat
1336	USE print_control_mod, ONLY: prt_level,lunout
1337
1338	IMPLICIT NONE
1339
1340	CHARACTER(LEN=*), INTENT(IN) :: field_name
1341	REAL, DIMENSION(:,:), INTENT(IN) :: field ! --> field(klon,:)
1342
1343	REAL,DIMENSION(klon_mpi,SIZE(field,2)) :: buffer_omp
1344	REAL :: Field3d(nbp_lon,jj_nb,SIZE(field,2))
1345	INTEGER :: ip, n, nlev
1346	INTEGER, ALLOCATABLE, DIMENSION(:) :: index3d
1347	REAL,ALLOCATABLE, DIMENSION(:,:) :: fieldok
1348
1349	IF (prt_level >= 10) write(lunout,*)'Begin histrwrite3d_xios ',field_name
1350
1351	!Et on.... écrit
1352	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)
1353
1354	IF (SIZE(field,1) == klev) then
1355	!$OMP MASTER
1356	CALL xios_send_field(field_name,field)
1357	!$OMP END MASTER
1358	ELSE
1359	nlev=SIZE(field,2)
1360
1361
1362	CALL Gather_omp(field,buffer_omp)
1363	!$OMP MASTER
1364	CALL grid1Dto2D_mpi(buffer_omp,field3d)
1365
1366	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1367	!ATTENTION, STATIONS PAS GEREES !
1368	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1369	!IF (.NOT.clef_stations(iff)) THEN
1370	IF(.TRUE.)THEN
1371	ALLOCATE(index3d(nbp_lonjj_nbnlev))
1372	ALLOCATE(fieldok(nbp_lon*jj_nb,nlev))
1373	CALL xios_send_field(field_name, Field3d(:,:,1:nlev))
1374
1375	ELSE
1376	nlev=size(field,2)
1377	ALLOCATE(index3d(npstn*nlev))
1378	ALLOCATE(fieldok(npstn,nlev))
1379
1380	IF (is_sequential) THEN
1381	DO n=1, nlev
1382	DO ip=1, npstn
1383	fieldok(ip,n)=buffer_omp(nptabij(ip),n)
1384	ENDDO
1385	ENDDO
1386	ELSE
1387	DO n=1, nlev
1388	DO ip=1, npstn
1389	IF(nptabij(ip).GE.klon_mpi_begin.AND. &
1390	nptabij(ip).LE.klon_mpi_end) THEN
1391	fieldok(ip,n)=buffer_omp(nptabij(ip)-klon_mpi_begin+1,n)
1392	ENDIF
1393	ENDDO
1394	ENDDO
1395	ENDIF
1396	ENDIF
1397	DEALLOCATE(index3d)
1398	DEALLOCATE(fieldok)
1399	!$OMP END MASTER
1400	ENDIF
1401
1402	IF (prt_level >= 10) write(lunout,*)'End histrwrite3d_xios ',field_name
1403	END SUBROUTINE histwrite3d_xios
1404
1405	#ifdef CPP_XIOS
1406	SUBROUTINE histwrite0d_xios(field_name, field)
1407	USE xios, ONLY: xios_send_field
1408	IMPLICIT NONE
1409
1410	CHARACTER(LEN=*), INTENT(IN) :: field_name
1411	REAL, INTENT(IN) :: field ! --> scalar
1412
1413	!$OMP MASTER
1414	CALL xios_send_field(field_name, field)
1415	!$OMP END MASTER
1416
1417	END SUBROUTINE histwrite0d_xios
1418	#endif
1419
1420	#endif
1421	end module iophy

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

Download in other formats:

Original Format