Context Navigation

iophy.F90 @ 5360

Last change on this file since 5360 was 3631, checked in by acozic, 5 years ago
uncomment test on prt_level - comment add by mystake on last commit
Property copyright set to Name of program: LMDZ Creation date: 1984 Version: LMDZ5 License: CeCILL version 2 Holder: Laboratoire de m\'et\'eorologie dynamique, CNRS, UMR 8539 See the license file in the root directory Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 45.5 KB

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

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

Download in other formats:

Original Format