Context Navigation

iophy.F90 @ 5425

Last change on this file since 5425 was 2002, checked in by Ehouarn Millour, 11 years ago
Further cleanup concerning XIOS (mainly about axes being defined as axes and not as groups of axes). EM
Property copyright set to Name of program: LMDZ Creation date: 1984 Version: LMDZ5 License: CeCILL version 2 Holder: Laboratoire de m\'et\'eorologie dynamique, CNRS, UMR 8539 See the license file in the root directory Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 41.4 KB

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

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

Download in other formats:

Original Format