Context Navigation

iophy.F90 @ 2344

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

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

Download in other formats:

Original Format