Context Navigation

iophy.F90 @ 2343

Last change on this file since 2343 was 2319, checked in by Laurent Fairhead, 9 years ago
Some initialisation missing
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.1 KB

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

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

Download in other formats:

Original Format