Context Navigation

iophy.F90 @ 4933

Last change on this file since 4933 was 2669, checked in by Laurent Fairhead, 8 years ago
Merged trunk changes r2640:2664 into testing branch
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: 44.4 KB

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

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

Download in other formats:

Original Format