Context Navigation

iophy.F90 @ 2346

Last change on this file since 2346 was 2346, checked in by Ehouarn Millour, 9 years ago

Physics/dynamics separation:

remove all references to dimensions.h from physics. nbp_lon (==iim) , nbp_lat (==jjm+1) and nbp_lev (==llm) from mod_grid_phy_lmdz should be used instead.
added module regular_lonlat_mod in phy_common to store information about the global (lon-lat) grid cell boundaries and centers.

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: 43.6 KB

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

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

Download in other formats:

Original Format