Context Navigation

iophy.F90 @ 2201

Last change on this file since 2201 was 2137, checked in by idelkadi, 10 years ago
Implementation de XIOS pour les sorties du simulateur COSP
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: 42.9 KB

Line
1	!
2	! $Id: iophy.F90 2137 2014-10-29 19:47:46Z crio $
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	#ifdef CPP_IOIPSL
49	USE ioipsl, only: flio_dom_set
50	#endif
51	#ifdef CPP_XIOS
52	use wxios, only: wxios_domain_param
53	#endif
54	IMPLICIT NONE
55	INCLUDE 'dimensions.h'
56	include 'iniprint.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	#ifdef CPP_XIOS
566	use wxios, only: wxios_add_field_to_file
567	#endif
568	IMPLICIT NONE
569
570	INCLUDE "dimensions.h"
571	INCLUDE "temps.h"
572	INCLUDE "clesphys.h"
573	INCLUDE "iniprint.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	#ifdef CPP_XIOS
653	use wxios, only: wxios_add_field_to_file
654	#endif
655	IMPLICIT NONE
656
657	INCLUDE "dimensions.h"
658	INCLUDE "temps.h"
659	INCLUDE "clesphys.h"
660	INCLUDE "iniprint.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	IMPLICIT NONE
731
732	include 'iniprint.h'
733
734	CHARACTER(LEN=20) :: nam_var
735	INTEGER, DIMENSION(nfiles) :: flag_var
736
737	IF(prt_level>10) WRITE(lunout,*)'Avant getin: nam_var flag_var ',nam_var,flag_var(:)
738	CALL getin('flag_'//nam_var,flag_var)
739	CALL getin('name_'//nam_var,nam_var)
740	IF(prt_level>10) WRITE(lunout,*)'Apres getin: nam_var flag_var ',nam_var,flag_var(:)
741
742	END SUBROUTINE conf_physoutputs
743
744
745
746	SUBROUTINE histwrite2d_phy_old(nid,lpoint,name,itau,field)
747	USE dimphy, only: klon
748	USE mod_phys_lmdz_para, only: Gather_omp, grid1Dto2D_mpi, &
749	is_sequential, klon_mpi_begin, klon_mpi_end, &
750	jj_nb, klon_mpi
751	USE ioipsl, only: histwrite
752	IMPLICIT NONE
753	include 'dimensions.h'
754	include 'iniprint.h'
755
756	integer,INTENT(IN) :: nid
757	logical,INTENT(IN) :: lpoint
758	character(), INTENT(IN) :: name
759	integer, INTENT(IN) :: itau
760	REAL,DIMENSION(:),INTENT(IN) :: field
761	REAL,DIMENSION(klon_mpi) :: buffer_omp
762	INTEGER, allocatable, DIMENSION(:) :: index2d
763	REAL :: Field2d(iim,jj_nb)
764
765	integer :: ip
766	REAL,allocatable,DIMENSION(:) :: fieldok
767
768
769	IF (size(field)/=klon) CALL abort_gcm('iophy::histwrite2d','Field first DIMENSION not equal to klon',1)
770
771	CALL Gather_omp(field,buffer_omp)
772	!$OMP MASTER
773	CALL grid1Dto2D_mpi(buffer_omp,Field2d)
774	if(.NOT.lpoint) THEN
775	ALLOCATE(index2d(iim*jj_nb))
776	ALLOCATE(fieldok(iim*jj_nb))
777	IF (prt_level >= 10) write(lunout,*)'Sending ',name,' to IOIPSL'
778	CALL histwrite(nid,name,itau,Field2d,iim*jj_nb,index2d)
779	IF (prt_level >= 10) write(lunout,*)'Finished sending ',name,' to IOIPSL'
780	else
781	ALLOCATE(fieldok(npstn))
782	ALLOCATE(index2d(npstn))
783
784	if(is_sequential) then
785	! klon_mpi_begin=1
786	! klon_mpi_end=klon
787	DO ip=1, npstn
788	fieldok(ip)=buffer_omp(nptabij(ip))
789	ENDDO
790	else
791	DO ip=1, npstn
792	! print*,'histwrite2d is_sequential npstn ip name nptabij',npstn,ip,name,nptabij(ip)
793	IF(nptabij(ip).GE.klon_mpi_begin.AND. &
794	nptabij(ip).LE.klon_mpi_end) THEN
795	fieldok(ip)=buffer_omp(nptabij(ip)-klon_mpi_begin+1)
796	ENDIF
797	ENDDO
798	endif
799	IF (prt_level >= 10) write(lunout,*)'Sending ',name,' to IOIPSL'
800	CALL histwrite(nid,name,itau,fieldok,npstn,index2d)
801	IF (prt_level >= 10) write(lunout,*)'Finished sending ',name,' to IOIPSL'
802	!
803	endif
804	deallocate(index2d)
805	deallocate(fieldok)
806	!$OMP END MASTER
807
808
809	end SUBROUTINE histwrite2d_phy_old
810
811	SUBROUTINE histwrite3d_phy_old(nid,lpoint,name,itau,field)
812	USE dimphy, only: klon
813	USE mod_phys_lmdz_para, only: Gather_omp, grid1Dto2D_mpi, &
814	is_sequential, klon_mpi_begin, klon_mpi_end, &
815	jj_nb, klon_mpi
816	use ioipsl, only: histwrite
817	IMPLICIT NONE
818	include 'dimensions.h'
819	include 'iniprint.h'
820
821	integer,INTENT(IN) :: nid
822	logical,INTENT(IN) :: lpoint
823	character(), INTENT(IN) :: name
824	integer, INTENT(IN) :: itau
825	REAL,DIMENSION(:,:),INTENT(IN) :: field ! --> field(klon,:)
826	REAL,DIMENSION(klon_mpi,size(field,2)) :: buffer_omp
827	REAL :: Field3d(iim,jj_nb,size(field,2))
828	INTEGER :: ip, n, nlev
829	INTEGER, ALLOCATABLE, DIMENSION(:) :: index3d
830	REAL,allocatable, DIMENSION(:,:) :: fieldok
831
832
833	IF (size(field,1)/=klon) CALL abort_gcm('iophy::histwrite3d','Field first DIMENSION not equal to klon',1)
834	nlev=size(field,2)
835
836	CALL Gather_omp(field,buffer_omp)
837	!$OMP MASTER
838	CALL grid1Dto2D_mpi(buffer_omp,field3d)
839	if(.NOT.lpoint) THEN
840	ALLOCATE(index3d(iimjj_nbnlev))
841	ALLOCATE(fieldok(iim*jj_nb,nlev))
842	IF (prt_level >= 10) write(lunout,*)'Sending ',name,' to IOIPSL'
843	CALL histwrite(nid,name,itau,Field3d,iimjj_nbnlev,index3d)
844	IF (prt_level >= 10) write(lunout,*)'Finished sending ',name,' to IOIPSL'
845	else
846	nlev=size(field,2)
847	ALLOCATE(index3d(npstn*nlev))
848	ALLOCATE(fieldok(npstn,nlev))
849
850	if(is_sequential) then
851	! klon_mpi_begin=1
852	! klon_mpi_end=klon
853	DO n=1, nlev
854	DO ip=1, npstn
855	fieldok(ip,n)=buffer_omp(nptabij(ip),n)
856	ENDDO
857	ENDDO
858	else
859	DO n=1, nlev
860	DO ip=1, npstn
861	IF(nptabij(ip).GE.klon_mpi_begin.AND. &
862	nptabij(ip).LE.klon_mpi_end) THEN
863	fieldok(ip,n)=buffer_omp(nptabij(ip)-klon_mpi_begin+1,n)
864	ENDIF
865	ENDDO
866	ENDDO
867	endif
868	IF (prt_level >= 10) write(lunout,*)'Sending ',name,' to IOIPSL'
869	CALL histwrite(nid,name,itau,fieldok,npstn*nlev,index3d)
870	IF (prt_level >= 10) write(lunout,*)'Finished sending ',name,' to IOIPSL'
871	endif
872	deallocate(index3d)
873	deallocate(fieldok)
874	!$OMP END MASTER
875
876	end SUBROUTINE histwrite3d_phy_old
877
878
879
880
881	! ug NOUVELLE VERSION DES WRITE AVEC LA BOUCLE DO RENTREE
882	SUBROUTINE histwrite2d_phy(var,field, STD_iff)
883	USE dimphy, only: klon
884	USE mod_phys_lmdz_para, only: gather_omp, grid1dto2d_mpi, &
885	jj_nb, klon_mpi, klon_mpi_begin, &
886	klon_mpi_end, is_sequential
887	USE ioipsl, only: histwrite
888	use phys_output_var_mod, only: ctrl_out, clef_files, lev_files, &
889	nfiles, vars_defined, clef_stations, &
890	nid_files
891	#ifdef CPP_XIOS
892	USE xios, only: xios_send_field
893	#endif
894
895
896	IMPLICIT NONE
897	INCLUDE 'dimensions.h'
898	INCLUDE 'iniprint.h'
899	include 'clesphys.h'
900
901	TYPE(ctrl_out), INTENT(IN) :: var
902	REAL, DIMENSION(:), INTENT(IN) :: field
903	INTEGER, INTENT(IN), OPTIONAL :: STD_iff ! ug RUSTINE POUR LES STD LEVS.....
904
905	INTEGER :: iff, iff_beg, iff_end
906	LOGICAL, SAVE :: firstx
907	!$OMP THREADPRIVATE(firstx)
908
909	REAL,DIMENSION(klon_mpi) :: buffer_omp
910	INTEGER, allocatable, DIMENSION(:) :: index2d
911	REAL :: Field2d(iim,jj_nb)
912
913	INTEGER :: ip
914	REAL, ALLOCATABLE, DIMENSION(:) :: fieldok
915
916	IF (prt_level >= 10) THEN
917	WRITE(lunout,*)'Begin histwrite2d_phy for ',trim(var%name)
918	ENDIF
919	! ug RUSTINE POUR LES STD LEVS.....
920	IF (PRESENT(STD_iff)) THEN
921	iff_beg = STD_iff
922	iff_end = STD_iff
923	ELSE
924	iff_beg = 1
925	iff_end = nfiles
926	END IF
927
928	! On regarde si on est dans la phase de définition ou d'écriture:
929	IF(.NOT.vars_defined) THEN
930	!$OMP MASTER
931	!Si phase de définition.... on définit
932	IF (.not. ok_all_xml) THEN
933	if (prt_level >= 10) then
934	write(lunout,*)"histwrite2d_phy: .not.vars_defined ; time to define ", &
935	trim(var%name)
936	endif
937	DO iff=iff_beg, iff_end
938	IF (clef_files(iff)) THEN
939	CALL histdef2d(iff, var)
940	ENDIF
941	ENDDO
942	ENDIF
943	!$OMP END MASTER
944	ELSE
945
946	!Et sinon on.... écrit
947	IF (SIZE(field)/=klon) CALL abort_gcm('iophy::histwrite2d_phy','Field first DIMENSION not equal to klon',1)
948
949	if (prt_level >= 10) then
950	write(lunout,*)"histwrite2d_phy: .not.vars_defined ; time to gather and write ", &
951	trim(var%name)
952	endif
953
954	CALL Gather_omp(field,buffer_omp)
955	!$OMP MASTER
956	CALL grid1Dto2D_mpi(buffer_omp,Field2d)
957
958	! La boucle sur les fichiers:
959	firstx=.true.
960
961	IF (ok_all_xml) THEN
962	#ifdef CPP_XIOS
963	if (prt_level >= 10) then
964	write(lunout,*)'Dans iophy histwrite2D,var%name ',&
965	trim(var%name)
966	endif
967	CALL xios_send_field(var%name, Field2d)
968	if (prt_level >= 10) then
969	write(lunout,*)'Dans iophy histwrite2D,var%name apres xios_send ',&
970	trim(var%name)
971	endif
972	#else
973	CALL abort_gcm ('iophy','cannot have ok_all_xml = .T. without CPP_XIOS defined' ,1)
974	#endif
975	ELSE
976	DO iff=iff_beg, iff_end
977	IF (var%flag(iff) <= lev_files(iff) .AND. clef_files(iff)) THEN
978
979	#ifdef CPP_XIOS
980	IF (firstx) THEN
981	if (prt_level >= 10) then
982	write(lunout,*)'Dans iophy histwrite2D,iff,var%name ',&
983	iff,trim(var%name)
984	write(lunout,*)"histwrite2d_phy:.NOT.clef_stations(iff)and iff==iff_beg, call xios_send_field"
985	endif
986	CALL xios_send_field(var%name, Field2d)
987	firstx=.false.
988	ENDIF
989	#endif
990
991	IF(.NOT.clef_stations(iff)) THEN
992	ALLOCATE(index2d(iim*jj_nb))
993	ALLOCATE(fieldok(iim*jj_nb))
994	#ifndef CPP_IOIPSL_NO_OUTPUT
995	CALL histwrite(nid_files(iff),var%name,itau_iophy,Field2d,iim*jj_nb,index2d)
996	#endif
997	!#ifdef CPP_XIOS
998	! IF (iff == iff_beg) THEN
999	! if (prt_level >= 10) then
1000	! write(lunout,*)"histwrite2d_phy: .NOT.clef_stations(iff) and iff==iff_beg, call xios_send_field"
1001	! endif
1002	! CALL xios_send_field(var%name, Field2d)
1003	! ENDIF
1004	!#endif
1005	ELSE
1006	ALLOCATE(fieldok(npstn))
1007	ALLOCATE(index2d(npstn))
1008
1009	IF (is_sequential) THEN
1010	DO ip=1, npstn
1011	fieldok(ip)=buffer_omp(nptabij(ip))
1012	ENDDO
1013	ELSE
1014	DO ip=1, npstn
1015	write(lunout,*)'histwrite2d_phy is_sequential npstn ip namenptabij',npstn,ip,var%name,nptabij(ip)
1016	IF(nptabij(ip).GE.klon_mpi_begin.AND. &
1017	nptabij(ip).LE.klon_mpi_end) THEN
1018	fieldok(ip)=buffer_omp(nptabij(ip)-klon_mpi_begin+1)
1019	ENDIF
1020	ENDDO
1021	ENDIF ! of IF (is_sequential)
1022	#ifndef CPP_IOIPSL_NO_OUTPUT
1023	if (prt_level >= 10) then
1024	write(lunout,*)"histwrite2d_phy: clef_stations(iff) and iff==iff_beg, call wxios_write_2D"
1025	endif
1026	CALL histwrite(nid_files(iff),var%name,itau_iophy,fieldok,npstn,index2d)
1027	#endif
1028	ENDIF ! of IF(.NOT.clef_stations(iff))
1029
1030	deallocate(index2d)
1031	deallocate(fieldok)
1032	ENDIF !levfiles
1033	ENDDO ! of DO iff=iff_beg, iff_end
1034	ENDIF
1035	!$OMP END MASTER
1036	ENDIF ! vars_defined
1037	IF (prt_level >= 10) WRITE(lunout,*)'End histwrite2d_phy ',trim(var%name)
1038	END SUBROUTINE histwrite2d_phy
1039
1040
1041	! ug NOUVELLE VERSION DES WRITE AVEC LA BOUCLE DO RENTREE
1042	SUBROUTINE histwrite3d_phy(var, field, STD_iff)
1043	USE dimphy, only: klon, klev
1044	USE mod_phys_lmdz_para, only: gather_omp, grid1dto2d_mpi, &
1045	jj_nb, klon_mpi, klon_mpi_begin, &
1046	klon_mpi_end, is_sequential
1047	USE ioipsl, only: histwrite
1048	use phys_output_var_mod, only: ctrl_out, clef_files, lev_files, &
1049	nfiles, vars_defined, clef_stations, &
1050	nid_files
1051	#ifdef CPP_XIOS
1052	USE xios, only: xios_send_field
1053	#endif
1054
1055
1056	IMPLICIT NONE
1057	INCLUDE 'dimensions.h'
1058	INCLUDE 'iniprint.h'
1059	include 'clesphys.h'
1060
1061	TYPE(ctrl_out), INTENT(IN) :: var
1062	REAL, DIMENSION(:,:), INTENT(IN) :: field ! --> field(klon,:)
1063	INTEGER, INTENT(IN), OPTIONAL :: STD_iff ! ug RUSTINE POUR LES STD LEVS.....
1064
1065	INTEGER :: iff, iff_beg, iff_end
1066	LOGICAL, SAVE :: firstx
1067	!$OMP THREADPRIVATE(firstx)
1068	REAL,DIMENSION(klon_mpi,SIZE(field,2)) :: buffer_omp
1069	REAL :: Field3d(iim,jj_nb,SIZE(field,2))
1070	INTEGER :: ip, n, nlev, nlevx
1071	INTEGER, ALLOCATABLE, DIMENSION(:) :: index3d
1072	REAL,ALLOCATABLE, DIMENSION(:,:) :: fieldok
1073
1074	IF (prt_level >= 10) write(lunout,*)'Begin histrwrite3d ',var%name
1075
1076	! ug RUSTINE POUR LES STD LEVS.....
1077	IF (PRESENT(STD_iff)) THEN
1078	iff_beg = STD_iff
1079	iff_end = STD_iff
1080	ELSE
1081	iff_beg = 1
1082	iff_end = nfiles
1083	END IF
1084
1085	! On regarde si on est dans la phase de définition ou d'écriture:
1086	IF(.NOT.vars_defined) THEN
1087	!Si phase de définition.... on définit
1088	!$OMP MASTER
1089	DO iff=iff_beg, iff_end
1090	IF (clef_files(iff)) THEN
1091	CALL histdef3d(iff, var)
1092	ENDIF
1093	ENDDO
1094	!$OMP END MASTER
1095	ELSE
1096	!Et sinon on.... écrit
1097	IF (SIZE(field,1)/=klon) CALL abort_gcm('iophy::histwrite3d','Field first DIMENSION not equal to klon',1)
1098	nlev=SIZE(field,2)
1099	if (nlev.eq.klev+1) then
1100	nlevx=klev
1101	else
1102	nlevx=nlev
1103	endif
1104
1105	CALL Gather_omp(field,buffer_omp)
1106	!$OMP MASTER
1107	CALL grid1Dto2D_mpi(buffer_omp,field3d)
1108
1109
1110	! BOUCLE SUR LES FICHIERS
1111	firstx=.true.
1112
1113	IF (ok_all_xml) THEN
1114	#ifdef CPP_XIOS
1115	if (prt_level >= 10) then
1116	write(lunout,*)'Dans iophy histwrite3D,var%name ',&
1117	trim(var%name)
1118	endif
1119	CALL xios_send_field(var%name, Field3d(:,:,1:nlevx))
1120	#else
1121	CALL abort_gcm ('iophy','cannot have ok_all_xml = .T. without CPP_XIOS defined' ,1)
1122	#endif
1123	ELSE
1124
1125
1126	DO iff=iff_beg, iff_end
1127	IF (var%flag(iff) <= lev_files(iff) .AND. clef_files(iff)) THEN
1128	#ifdef CPP_XIOS
1129	IF (firstx) THEN
1130	if (prt_level >= 10) then
1131	write(lunout,*)'Dans iophy, histwrite3D iff nlev klev firstx', &
1132	iff,nlev,klev, firstx
1133	write(lunout,*)'histwrite3d_phy: call xios_send_field for ', &
1134	trim(var%name), ' with iim jjm nlevx = ', &
1135	iim,jj_nb,nlevx
1136	endif
1137	CALL xios_send_field(var%name, Field3d(:,:,1:nlevx))
1138	firstx=.false.
1139	ENDIF
1140	#endif
1141	IF (.NOT.clef_stations(iff)) THEN
1142	ALLOCATE(index3d(iimjj_nbnlev))
1143	ALLOCATE(fieldok(iim*jj_nb,nlev))
1144
1145	#ifndef CPP_IOIPSL_NO_OUTPUT
1146	CALL histwrite(nid_files(iff),var%name,itau_iophy,Field3d,iimjj_nbnlev,index3d)
1147	#endif
1148
1149	!#ifdef CPP_XIOS
1150	! IF (iff == 1) THEN
1151	! CALL xios_send_field(var%name, Field3d(:,:,1:klev))
1152	! ENDIF
1153	!#endif
1154	!
1155	ELSE
1156	nlev=size(field,2)
1157	ALLOCATE(index3d(npstn*nlev))
1158	ALLOCATE(fieldok(npstn,nlev))
1159
1160	IF (is_sequential) THEN
1161	DO n=1, nlev
1162	DO ip=1, npstn
1163	fieldok(ip,n)=buffer_omp(nptabij(ip),n)
1164	ENDDO
1165	ENDDO
1166	ELSE
1167	DO n=1, nlev
1168	DO ip=1, npstn
1169	IF(nptabij(ip).GE.klon_mpi_begin.AND. &
1170	nptabij(ip).LE.klon_mpi_end) THEN
1171	fieldok(ip,n)=buffer_omp(nptabij(ip)-klon_mpi_begin+1,n)
1172	ENDIF
1173	ENDDO
1174	ENDDO
1175	ENDIF
1176	#ifndef CPP_IOIPSL_NO_OUTPUT
1177	CALL histwrite(nid_files(iff),var%name,itau_iophy,fieldok,npstn*nlev,index3d)
1178	#endif
1179	ENDIF
1180	deallocate(index3d)
1181	deallocate(fieldok)
1182	ENDIF
1183	ENDDO
1184	ENDIF
1185	!$OMP END MASTER
1186	ENDIF ! vars_defined
1187	IF (prt_level >= 10) write(lunout,*)'End histrwrite3d ',var%name
1188	END SUBROUTINE histwrite3d_phy
1189
1190
1191	! VERSION DES HISTWRITE DEDIEES AU TOUT-XIOS-XML DEJA UTILISEE DANS PHYDEV
1192	#ifdef CPP_XIOS
1193	SUBROUTINE histwrite2d_xios(field_name,field)
1194	USE dimphy, only: klon
1195	USE mod_phys_lmdz_para, only: gather_omp, grid1Dto2D_mpi, &
1196	is_sequential, klon_mpi_begin, klon_mpi_end, &
1197	jj_nb, klon_mpi
1198	USE xios, only: xios_send_field
1199
1200
1201	IMPLICIT NONE
1202	INCLUDE 'dimensions.h'
1203	INCLUDE 'iniprint.h'
1204
1205	CHARACTER(LEN=*), INTENT(IN) :: field_name
1206	REAL, DIMENSION(:), INTENT(IN) :: field
1207
1208	REAL,DIMENSION(klon_mpi) :: buffer_omp
1209	INTEGER, allocatable, DIMENSION(:) :: index2d
1210	REAL :: Field2d(iim,jj_nb)
1211
1212	INTEGER :: ip
1213	REAL, ALLOCATABLE, DIMENSION(:) :: fieldok
1214
1215	IF (prt_level >= 10) WRITE(lunout,*)'Begin histrwrite2d_xios ',field_name
1216
1217	!Et sinon on.... écrit
1218	IF (SIZE(field)/=klon) CALL abort_gcm('iophy::histwrite2d_xios','Field first DIMENSION not equal to klon',1)
1219
1220	CALL Gather_omp(field,buffer_omp)
1221	!$OMP MASTER
1222	CALL grid1Dto2D_mpi(buffer_omp,Field2d)
1223
1224	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1225	!ATTENTION, STATIONS PAS GEREES !
1226	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1227	!IF(.NOT.clef_stations(iff)) THEN
1228	IF (.TRUE.) THEN
1229	ALLOCATE(index2d(iim*jj_nb))
1230	ALLOCATE(fieldok(iim*jj_nb))
1231
1232
1233	CALL xios_send_field(field_name, Field2d)
1234
1235	ELSE
1236	ALLOCATE(fieldok(npstn))
1237	ALLOCATE(index2d(npstn))
1238
1239	IF (is_sequential) THEN
1240	DO ip=1, npstn
1241	fieldok(ip)=buffer_omp(nptabij(ip))
1242	ENDDO
1243	ELSE
1244	DO ip=1, npstn
1245	PRINT*,'histwrite2d_xios is_sequential npstn ip namenptabij',npstn,ip,field_name,nptabij(ip)
1246	IF(nptabij(ip).GE.klon_mpi_begin.AND. &
1247	nptabij(ip).LE.klon_mpi_end) THEN
1248	fieldok(ip)=buffer_omp(nptabij(ip)-klon_mpi_begin+1)
1249	ENDIF
1250	ENDDO
1251	ENDIF
1252
1253	ENDIF
1254
1255	deallocate(index2d)
1256	deallocate(fieldok)
1257	!$OMP END MASTER
1258
1259	IF (prt_level >= 10) WRITE(lunout,*)'End histrwrite2d_xios ',field_name
1260	END SUBROUTINE histwrite2d_xios
1261
1262
1263	! ug NOUVELLE VERSION DES WRITE AVEC LA BOUCLE DO RENTREE
1264	SUBROUTINE histwrite3d_xios(field_name, field)
1265	USE dimphy, only: klon, klev
1266	USE mod_phys_lmdz_para, only: gather_omp, grid1Dto2D_mpi, &
1267	is_sequential, klon_mpi_begin, klon_mpi_end, &
1268	jj_nb, klon_mpi
1269	USE xios, only: xios_send_field
1270
1271
1272	IMPLICIT NONE
1273	INCLUDE 'dimensions.h'
1274	INCLUDE 'iniprint.h'
1275
1276	CHARACTER(LEN=*), INTENT(IN) :: field_name
1277	REAL, DIMENSION(:,:), INTENT(IN) :: field ! --> field(klon,:)
1278
1279	REAL,DIMENSION(klon_mpi,SIZE(field,2)) :: buffer_omp
1280	REAL :: Field3d(iim,jj_nb,SIZE(field,2))
1281	INTEGER :: ip, n, nlev
1282	INTEGER, ALLOCATABLE, DIMENSION(:) :: index3d
1283	REAL,ALLOCATABLE, DIMENSION(:,:) :: fieldok
1284
1285	IF (prt_level >= 10) write(lunout,*)'Begin histrwrite3d_xios ',field_name
1286
1287	!Et on.... écrit
1288	IF (SIZE(field,1)/=klon) CALL abort_gcm('iophy::histwrite3d','Field first DIMENSION not equal to klon',1)
1289	nlev=SIZE(field,2)
1290
1291
1292	CALL Gather_omp(field,buffer_omp)
1293	!$OMP MASTER
1294	CALL grid1Dto2D_mpi(buffer_omp,field3d)
1295
1296	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1297	!ATTENTION, STATIONS PAS GEREES !
1298	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1299	!IF (.NOT.clef_stations(iff)) THEN
1300	IF(.TRUE.)THEN
1301	ALLOCATE(index3d(iimjj_nbnlev))
1302	ALLOCATE(fieldok(iim*jj_nb,nlev))
1303	CALL xios_send_field(field_name, Field3d(:,:,1:nlev))
1304
1305	ELSE
1306	nlev=size(field,2)
1307	ALLOCATE(index3d(npstn*nlev))
1308	ALLOCATE(fieldok(npstn,nlev))
1309
1310	IF (is_sequential) THEN
1311	DO n=1, nlev
1312	DO ip=1, npstn
1313	fieldok(ip,n)=buffer_omp(nptabij(ip),n)
1314	ENDDO
1315	ENDDO
1316	ELSE
1317	DO n=1, nlev
1318	DO ip=1, npstn
1319	IF(nptabij(ip).GE.klon_mpi_begin.AND. &
1320	nptabij(ip).LE.klon_mpi_end) THEN
1321	fieldok(ip,n)=buffer_omp(nptabij(ip)-klon_mpi_begin+1,n)
1322	ENDIF
1323	ENDDO
1324	ENDDO
1325	ENDIF
1326	ENDIF
1327	deallocate(index3d)
1328	deallocate(fieldok)
1329	!$OMP END MASTER
1330
1331	IF (prt_level >= 10) write(lunout,*)'End histrwrite3d_xios ',field_name
1332	END SUBROUTINE histwrite3d_xios
1333	#endif
1334	end module iophy

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

Download in other formats:

Original Format