Context Navigation

iophy.F90 @ 3238

Last change on this file since 3238 was 3238, checked in by Laurent Fairhead, 6 years ago
Adding some debugging information
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: 49.7 KB

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

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

Download in other formats:

Original Format