Context Navigation

iophy.F90 @ 1828

Last change on this file since 1828 was 1828, checked in by idelkadi, 11 years ago
Gestion des fichiers de sorties sur les niveaux de pression NMC (hist*NMC.nc) via le meme mecanisme utilise pour les fichiers histoires (phys_output_mod, ...) Ces sorties sont ainsi controles par les memes flags : phys_out_filekeys, phys_out_filenames, phys_out_filetimesteps, phys_out_filelevels, ... (exemple dans config.def : phys_out_filenames=histmth histday histhf histins histLES histstn histmthNMC histdayNMC histhfNMC)
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 29.4 KB

Line
1	!
2	! $Header$
3	!
4	MODULE iophy
5
6	USE phys_output_var_mod
7
8	#ifdef CPP_XIOS
9	USE wxios
10	#endif
11
12	! abd REAL,private,allocatable,DIMENSION(:),save :: io_lat
13	! abd REAL,private,allocatable,DIMENSION(:),save :: io_lon
14	REAL,ALLOCATABLE,DIMENSION(:),SAVE :: io_lat
15	REAL,ALLOCATABLE,DIMENSION(:),SAVE :: io_lon
16	INTEGER, SAVE :: phys_domain_id
17	INTEGER, SAVE :: npstn
18	INTEGER, ALLOCATABLE, DIMENSION(:), SAVE :: nptabij
19	INTEGER, SAVE :: itau_iophy
20
21	!$OMP THREADPRIVATE(itau_iophy)
22
23	INTERFACE histwrite_phy
24	MODULE PROCEDURE histwrite2d_phy,histwrite3d_phy,histwrite2d_phy_old,histwrite3d_phy_old
25	END INTERFACE
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
43	USE mod_phys_lmdz_para
44	USE mod_grid_phy_lmdz
45	USE ioipsl
46
47	IMPLICIT NONE
48	INCLUDE 'dimensions.h'
49	REAL,DIMENSION(klon),INTENT(IN) :: rlon
50	REAL,DIMENSION(klon),INTENT(IN) :: rlat
51
52	REAL,DIMENSION(klon_glo) :: rlat_glo
53	REAL,DIMENSION(klon_glo) :: rlon_glo
54
55	INTEGER,DIMENSION(2) :: ddid
56	INTEGER,DIMENSION(2) :: dsg
57	INTEGER,DIMENSION(2) :: dsl
58	INTEGER,DIMENSION(2) :: dpf
59	INTEGER,DIMENSION(2) :: dpl
60	INTEGER,DIMENSION(2) :: dhs
61	INTEGER,DIMENSION(2) :: dhe
62	INTEGER :: i
63
64	CALL gather(rlat,rlat_glo)
65	CALL bcast(rlat_glo)
66	CALL gather(rlon,rlon_glo)
67	CALL bcast(rlon_glo)
68
69	!$OMP MASTER
70	ALLOCATE(io_lat(jjm+1-1/(iim*jjm)))
71	io_lat(1)=rlat_glo(1)
72	io_lat(jjm+1-1/(iim*jjm))=rlat_glo(klon_glo)
73	IF ((iim*jjm) > 1) then
74	DO i=2,jjm
75	io_lat(i)=rlat_glo(2+(i-2)*iim)
76	ENDDO
77	ENDIF
78
79	ALLOCATE(io_lon(iim))
80	io_lon(:)=rlon_glo(2-1/(iimjjm):iim+1-1/(iimjjm))
81
82	ddid=(/ 1,2 /)
83	dsg=(/ iim, jjm+1-1/(iim*jjm) /)
84	dsl=(/ iim, jj_nb /)
85	dpf=(/ 1,jj_begin /)
86	dpl=(/ iim, jj_end /)
87	dhs=(/ ii_begin-1,0 /)
88	IF (mpi_rank==mpi_size-1) THEN
89	dhe=(/0,0/)
90	ELSE
91	dhe=(/ iim-ii_end,0 /)
92	ENDIF
93
94	CALL flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
95	'APPLE',phys_domain_id)
96	#ifdef CPP_XIOS
97	!On initialise le domaine xios, maintenant que tout est connu:
98	CALL wxios_domain_param("dom_glo", is_sequential, iim, jjm+1, io_lat, io_lon)
99	#endif
100	!$OMP END MASTER
101
102	END SUBROUTINE init_iophy_new
103
104	SUBROUTINE init_iophy(lat,lon)
105	USE dimphy
106	USE mod_phys_lmdz_para
107	USE ioipsl
108	IMPLICIT NONE
109	INCLUDE 'dimensions.h'
110	REAL,DIMENSION(iim),INTENT(IN) :: lon
111	REAL,DIMENSION(jjm+1-1/(iim*jjm)),INTENT(IN) :: lat
112
113	INTEGER,DIMENSION(2) :: ddid
114	INTEGER,DIMENSION(2) :: dsg
115	INTEGER,DIMENSION(2) :: dsl
116	INTEGER,DIMENSION(2) :: dpf
117	INTEGER,DIMENSION(2) :: dpl
118	INTEGER,DIMENSION(2) :: dhs
119	INTEGER,DIMENSION(2) :: dhe
120
121	!$OMP MASTER
122	allocate(io_lat(jjm+1-1/(iim*jjm)))
123	io_lat(:)=lat(:)
124	allocate(io_lon(iim))
125	io_lon(:)=lon(:)
126
127	ddid=(/ 1,2 /)
128	dsg=(/ iim, jjm+1-1/(iim*jjm) /)
129	dsl=(/ iim, jj_nb /)
130	dpf=(/ 1,jj_begin /)
131	dpl=(/ iim, jj_end /)
132	dhs=(/ ii_begin-1,0 /)
133	if (mpi_rank==mpi_size-1) then
134	dhe=(/0,0/)
135	else
136	dhe=(/ iim-ii_end,0 /)
137	endif
138
139	call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
140	'APPLE',phys_domain_id)
141
142	!$OMP END MASTER
143
144	end SUBROUTINE init_iophy
145
146	SUBROUTINE histbeg_phyxios(name,itau0,zjulian,dtime,ffreq,lev,nhori,nid_day)
147	USE dimphy
148	USE mod_phys_lmdz_para
149	use ioipsl
150	use write_field
151	IMPLICIT NONE
152	include 'dimensions.h'
153
154	character(), INTENT(IN) :: name
155	integer, INTENT(IN) :: itau0
156	REAL,INTENT(IN) :: zjulian
157	REAL,INTENT(IN) :: dtime
158	character(LEN=*), INTENT(IN) :: ffreq
159	INTEGER,INTENT(IN) :: lev
160	integer,intent(out) :: nhori
161	integer,intent(out) :: nid_day
162
163	!$OMP MASTER
164	if (is_sequential) then
165	call histbeg(name,iim,io_lon, jj_nb,io_lat(jj_begin:jj_end), &
166	1,iim,1,jj_nb,itau0, zjulian, dtime, nhori, nid_day)
167	else
168	call histbeg(name,iim,io_lon, jj_nb,io_lat(jj_begin:jj_end), &
169	1,iim,1,jj_nb,itau0, zjulian, dtime, nhori, nid_day,phys_domain_id)
170	endif
171
172	#ifdef CPP_XIOS
173	! ug OMP en chantier...
174	IF((.NOT. is_using_mpi) .OR. is_mpi_root) THEN
175	! ug Création du fichier
176	CALL wxios_add_file(name, ffreq, lev)
177	END IF
178	#endif
179	!$OMP END MASTER
180
181	END SUBROUTINE histbeg_phyxios
182
183	SUBROUTINE histbeg_phy(name,itau0,zjulian,dtime,nhori,nid_day)
184	USE dimphy
185	USE mod_phys_lmdz_para
186	use ioipsl
187	use write_field
188	IMPLICIT NONE
189	include 'dimensions.h'
190
191	character(), INTENT(IN) :: name
192	integer, INTENT(IN) :: itau0
193	REAL,INTENT(IN) :: zjulian
194	REAL,INTENT(IN) :: dtime
195	integer,intent(out) :: nhori
196	integer,intent(out) :: nid_day
197
198	!$OMP MASTER
199	if (is_sequential) then
200	call histbeg(name,iim,io_lon, jj_nb,io_lat(jj_begin:jj_end), &
201	1,iim,1,jj_nb,itau0, zjulian, dtime, nhori, nid_day)
202	else
203	call histbeg(name,iim,io_lon, jj_nb,io_lat(jj_begin:jj_end), &
204	1,iim,1,jj_nb,itau0, zjulian, dtime, nhori, nid_day,phys_domain_id)
205	endif
206
207	!$OMP END MASTER
208
209	END SUBROUTINE histbeg_phy
210
211
212	SUBROUTINE histbeg_phy_points(rlon,rlat,pim,tabij,ipt,jpt, &
213	plon,plat,plon_bounds,plat_bounds, &
214	nname,itau0,zjulian,dtime,nnhori,nnid_day)
215	USE dimphy
216	USE mod_phys_lmdz_para
217	USE mod_grid_phy_lmdz
218	use ioipsl
219	use write_field
220	IMPLICIT NONE
221	include 'dimensions.h'
222
223	REAL,DIMENSION(klon),INTENT(IN) :: rlon
224	REAL,DIMENSION(klon),INTENT(IN) :: rlat
225	integer, INTENT(IN) :: itau0
226	REAL,INTENT(IN) :: zjulian
227	REAL,INTENT(IN) :: dtime
228	integer, INTENT(IN) :: pim
229	integer, intent(out) :: nnhori
230	character(len=20), INTENT(IN) :: nname
231	INTEGER, intent(out) :: nnid_day
232	integer :: i
233	REAL,DIMENSION(klon_glo) :: rlat_glo
234	REAL,DIMENSION(klon_glo) :: rlon_glo
235	INTEGER, DIMENSION(pim), INTENT(IN) :: tabij
236	REAL,DIMENSION(pim), INTENT(IN) :: plat, plon
237	INTEGER,DIMENSION(pim), INTENT(IN) :: ipt, jpt
238	REAL,DIMENSION(pim,2), intent(out) :: plat_bounds, plon_bounds
239
240	INTEGER, SAVE :: tabprocbeg, tabprocend
241	!$OMP THREADPRIVATE(tabprocbeg, tabprocend)
242	INTEGER :: ip
243	INTEGER, PARAMETER :: nip=1
244	INTEGER :: npproc
245	REAL, allocatable, DIMENSION(:) :: npplat, npplon
246	REAL, allocatable, DIMENSION(:,:) :: npplat_bounds, npplon_bounds
247	INTEGER, PARAMETER :: jjmp1=jjm+1-1/jjm
248	REAL, DIMENSION(iim,jjmp1) :: zx_lon, zx_lat
249
250	CALL gather(rlat,rlat_glo)
251	CALL bcast(rlat_glo)
252	CALL gather(rlon,rlon_glo)
253	CALL bcast(rlon_glo)
254
255	!$OMP MASTER
256	DO i=1,pim
257
258	! print*,'CFMIP_iophy i tabij lon lat',i,tabij(i),plon(i),plat(i)
259
260	plon_bounds(i,1)=rlon_glo(tabij(i)-1)
261	plon_bounds(i,2)=rlon_glo(tabij(i)+1)
262	if(plon_bounds(i,2).LE.0..AND.plon_bounds(i,1).GE.0.) THEN
263	if(rlon_glo(tabij(i)).GE.0.) THEN
264	plon_bounds(i,2)=-1*plon_bounds(i,2)
265	endif
266	endif
267	if(plon_bounds(i,2).GE.0..AND.plon_bounds(i,1).LE.0.) THEN
268	if(rlon_glo(tabij(i)).LE.0.) THEN
269	plon_bounds(i,2)=-1*plon_bounds(i,2)
270	endif
271	endif
272	!
273	IF ( tabij(i).LE.iim) THEN
274	plat_bounds(i,1)=rlat_glo(tabij(i))
275	ELSE
276	plat_bounds(i,1)=rlat_glo(tabij(i)-iim)
277	ENDIF
278	plat_bounds(i,2)=rlat_glo(tabij(i)+iim)
279	!
280	! print*,'CFMIP_iophy point i lon lon_bds',i,plon_bounds(i,1),rlon_glo(tabij(i)),plon_bounds(i,2)
281	! print*,'CFMIP_iophy point i lat lat_bds',i,plat_bounds(i,1),rlat_glo(tabij(i)),plat_bounds(i,2)
282	!
283	ENDDO
284	if (is_sequential) then
285
286	npstn=pim
287	IF(.NOT. ALLOCATED(nptabij)) THEN
288	ALLOCATE(nptabij(pim))
289	ENDIF
290	DO i=1,pim
291	nptabij(i)=tabij(i)
292	ENDDO
293
294	CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon_glo,zx_lon)
295	if ((iim*jjm).gt.1) then
296	DO i = 1, iim
297	zx_lon(i,1) = rlon_glo(i+1)
298	zx_lon(i,jjmp1) = rlon_glo(i+1)
299	ENDDO
300	endif
301	CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat_glo,zx_lat)
302
303	DO i=1,pim
304	! print*,'CFMIP_iophy i tabij lon lat',i,tabij(i),plon(i),plat(i)
305
306	plon_bounds(i,1)=zx_lon(ipt(i)-1,jpt(i))
307	plon_bounds(i,2)=zx_lon(ipt(i)+1,jpt(i))
308
309	if (ipt(i).EQ.1) then
310	plon_bounds(i,1)=zx_lon(iim,jpt(i))
311	plon_bounds(i,2)=360.+zx_lon(ipt(i)+1,jpt(i))
312	endif
313
314	if (ipt(i).EQ.iim) then
315	plon_bounds(i,2)=360.+zx_lon(1,jpt(i))
316	endif
317
318	plat_bounds(i,1)=zx_lat(ipt(i),jpt(i)-1)
319	plat_bounds(i,2)=zx_lat(ipt(i),jpt(i)+1)
320
321	if (jpt(i).EQ.1) then
322	plat_bounds(i,1)=zx_lat(ipt(i),1)+0.001
323	plat_bounds(i,2)=zx_lat(ipt(i),1)-0.001
324	endif
325
326	if (jpt(i).EQ.jjmp1) then
327	plat_bounds(i,1)=zx_lat(ipt(i),jjmp1)+0.001
328	plat_bounds(i,2)=zx_lat(ipt(i),jjmp1)-0.001
329	endif
330	!
331	! print*,'CFMIP_iophy point i lon lon_bds',i,plon_bounds(i,1),rlon(tabij(i)),plon_bounds(i,2)
332	! print*,'CFMIP_iophy point i lat lat_bds',i,plat_bounds(i,1),rlat(tabij(i)),plat_bounds(i,2)
333	!
334	ENDDO
335	! print*,'iophy is_sequential nname, nnhori, nnid_day=',trim(nname),nnhori,nnid_day
336	call histbeg(nname,pim,plon,plon_bounds, &
337	plat,plat_bounds, &
338	itau0, zjulian, dtime, nnhori, nnid_day)
339	else
340	npproc=0
341	DO ip=1, pim
342	tabprocbeg=klon_mpi_begin
343	tabprocend=klon_mpi_end
344	IF(tabij(ip).GE.tabprocbeg.AND.tabij(ip).LE.tabprocend) THEN
345	npproc=npproc+1
346	npstn=npproc
347	ENDIF
348	ENDDO
349	! print*,'CFMIP_iophy mpi_rank npstn',mpi_rank,npstn
350	IF(.NOT. ALLOCATED(nptabij)) THEN
351	ALLOCATE(nptabij(npstn))
352	ALLOCATE(npplon(npstn), npplat(npstn))
353	ALLOCATE(npplon_bounds(npstn,2), npplat_bounds(npstn,2))
354	ENDIF
355	npproc=0
356	DO ip=1, pim
357	IF(tabij(ip).GE.tabprocbeg.AND.tabij(ip).LE.tabprocend) THEN
358	npproc=npproc+1
359	nptabij(npproc)=tabij(ip)
360	! print*,'mpi_rank npproc ip plon plat tabij=',mpi_rank,npproc,ip, &
361	! plon(ip),plat(ip),tabij(ip)
362	npplon(npproc)=plon(ip)
363	npplat(npproc)=plat(ip)
364	npplon_bounds(npproc,1)=plon_bounds(ip,1)
365	npplon_bounds(npproc,2)=plon_bounds(ip,2)
366	npplat_bounds(npproc,1)=plat_bounds(ip,1)
367	npplat_bounds(npproc,2)=plat_bounds(ip,2)
368	!!!
369	!!! print qui sert a reordonner les points stations selon l'ordre CFMIP
370	!!! ne pas enlever
371	print*,'iophy_mpi rank ip lon lat',mpi_rank,ip,plon(ip),plat(ip)
372	!!!
373	ENDIF
374	ENDDO
375	call histbeg(nname,npstn,npplon,npplon_bounds, &
376	npplat,npplat_bounds, &
377	itau0,zjulian,dtime,nnhori,nnid_day,phys_domain_id)
378	endif
379	!$OMP END MASTER
380
381	end SUBROUTINE histbeg_phy_points
382
383
384	SUBROUTINE histdef2d_old (iff,lpoint,flag_var,nomvar,titrevar,unitvar)
385
386	USE ioipsl
387	USE dimphy
388	USE mod_phys_lmdz_para
389
390	IMPLICIT NONE
391
392	INCLUDE "dimensions.h"
393	INCLUDE "temps.h"
394	INCLUDE "clesphys.h"
395
396	INTEGER :: iff
397	LOGICAL :: lpoint
398	INTEGER, DIMENSION(nfiles) :: flag_var
399	CHARACTER(LEN=20) :: nomvar
400	CHARACTER(LEN=*) :: titrevar
401	CHARACTER(LEN=*) :: unitvar
402
403	REAL zstophym
404
405	IF (type_ecri(iff)=='inst(X)'.OR.type_ecri(iff)=='once') THEN
406	zstophym=zoutm(iff)
407	ELSE
408	zstophym=zdtime_moy
409	ENDIF
410
411	! Appel a la lecture des noms et niveau d'ecriture des variables dans output.def
412	CALL conf_physoutputs(nomvar,flag_var)
413
414	IF(.NOT.lpoint) THEN
415	IF ( flag_var(iff)<=lev_files(iff) ) THEN
416	CALL histdef (nid_files(iff),nomvar,titrevar,unitvar, &
417	iim,jj_nb,nhorim(iff), 1,1,1, -99, 32, &
418	type_ecri(iff), zstophym,zoutm(iff))
419	ENDIF
420	ELSE
421	IF ( flag_var(iff)<=lev_files(iff) ) THEN
422	CALL histdef (nid_files(iff),nomvar,titrevar,unitvar, &
423	npstn,1,nhorim(iff), 1,1,1, -99, 32, &
424	type_ecri(iff), zstophym,zoutm(iff))
425	ENDIF
426	ENDIF
427
428	! Set swaero_diag=true if at least one of the concerned variables are defined
429	IF (nomvar=='topswad' .OR. nomvar=='topswai' .OR. nomvar=='solswad' .OR. nomvar=='solswai' ) THEN
430	IF ( flag_var(iff)<=lev_files(iff) ) THEN
431	swaero_diag=.TRUE.
432	END IF
433	END IF
434	END SUBROUTINE histdef2d_old
435
436
437
438	SUBROUTINE histdef3d_old (iff,lpoint,flag_var,nomvar,titrevar,unitvar)
439
440	USE ioipsl
441	USE dimphy
442	USE mod_phys_lmdz_para
443
444	IMPLICIT NONE
445
446	INCLUDE "dimensions.h"
447	INCLUDE "temps.h"
448	! INCLUDE "indicesol.h"
449	INCLUDE "clesphys.h"
450
451	INTEGER :: iff
452	LOGICAL :: lpoint
453	INTEGER, DIMENSION(nfiles) :: flag_var
454	CHARACTER(LEN=20) :: nomvar
455	CHARACTER(LEN=*) :: titrevar
456	CHARACTER(LEN=*) :: unitvar
457
458	REAL zstophym
459
460	! Appel a la lecture des noms et niveau d'ecriture des variables dans output.def
461	CALL conf_physoutputs(nomvar,flag_var)
462
463	IF (type_ecri(iff)=='inst(X)'.OR.type_ecri(iff)=='once') THEN
464	zstophym=zoutm(iff)
465	ELSE
466	zstophym=zdtime_moy
467	ENDIF
468
469	IF(.NOT.lpoint) THEN
470	IF ( flag_var(iff)<=lev_files(iff) ) THEN
471	CALL histdef (nid_files(iff), nomvar, titrevar, unitvar, &
472	iim, jj_nb, nhorim(iff), klev, levmin(iff), &
473	levmax(iff)-levmin(iff)+1, nvertm(iff), 32, type_ecri(iff), &
474	zstophym, zoutm(iff))
475	ENDIF
476	ELSE
477	IF ( flag_var(iff)<=lev_files(iff) ) THEN
478	CALL histdef (nid_files(iff), nomvar, titrevar, unitvar, &
479	npstn,1,nhorim(iff), klev, levmin(iff), &
480	levmax(iff)-levmin(iff)+1, nvertm(iff), 32, &
481	type_ecri(iff), zstophym,zoutm(iff))
482	ENDIF
483	ENDIF
484	END SUBROUTINE histdef3d_old
485
486
487
488
489
490
491
492
493	SUBROUTINE histdef2d (iff,var)
494
495	USE ioipsl
496	USE dimphy
497	USE mod_phys_lmdz_para
498
499	IMPLICIT NONE
500
501	INCLUDE "dimensions.h"
502	INCLUDE "temps.h"
503	INCLUDE "clesphys.h"
504
505	INTEGER :: iff
506	TYPE(ctrl_out) :: var
507
508	REAL zstophym
509	CHARACTER(LEN=20) :: typeecrit
510
511
512	! ug On récupère le type écrit de la structure:
513	! Assez moche, à refaire si meilleure méthode...
514	IF (INDEX(var%type_ecrit(iff), "once") > 0) THEN
515	typeecrit = 'once'
516	ELSE IF(INDEX(var%type_ecrit(iff), "t_min") > 0) THEN
517	typeecrit = 't_min(X)'
518	ELSE IF(INDEX(var%type_ecrit(iff), "t_max") > 0) THEN
519	typeecrit = 't_max(X)'
520	ELSE IF(INDEX(var%type_ecrit(iff), "inst") > 0) THEN
521	typeecrit = 'inst(X)'
522	ELSE
523	typeecrit = type_ecri_files(iff)
524	ENDIF
525
526	IF (typeecrit=='inst(X)'.OR.typeecrit=='once') THEN
527	zstophym=zoutm(iff)
528	ELSE
529	zstophym=zdtime_moy
530	ENDIF
531
532	! Appel a la lecture des noms et niveau d'ecriture des variables dans output.def
533	CALL conf_physoutputs(var%name, var%flag)
534
535	IF(.NOT.clef_stations(iff)) THEN
536	#ifdef CPP_XIOS
537	CALL wxios_add_field_to_file(var%name, 2, nid_files(iff), phys_out_filenames(iff), &
538	var%description, var%unit, var%flag(iff), typeecrit)
539	#endif
540
541	IF ( var%flag(iff)<=lev_files(iff) ) THEN
542	CALL histdef (nid_files(iff), var%name, var%description, var%unit, &
543	iim,jj_nb,nhorim(iff), 1,1,1, -99, 32, &
544	typeecrit, zstophym,zoutm(iff))
545	ENDIF
546	ELSE
547	IF ( var%flag(iff)<=lev_files(iff)) THEN
548	CALL histdef (nid_files(iff), var%name, var%description, var%unit, &
549	npstn,1,nhorim(iff), 1,1,1, -99, 32, &
550	typeecrit, zstophym,zoutm(iff))
551	ENDIF
552	ENDIF
553
554	! Set swaero_diag=true if at least one of the concerned variables are defined
555	IF (var%name=='topswad' .OR. var%name=='topswai' .OR. var%name=='solswad' .OR. var%name=='solswai' ) THEN
556	IF ( var%flag(iff)<=lev_files(iff) ) THEN
557	swaero_diag=.TRUE.
558	END IF
559	END IF
560	END SUBROUTINE histdef2d
561	SUBROUTINE histdef3d (iff,var)
562
563	USE ioipsl
564	USE dimphy
565	USE mod_phys_lmdz_para
566
567	IMPLICIT NONE
568
569	INCLUDE "dimensions.h"
570	INCLUDE "temps.h"
571	INCLUDE "clesphys.h"
572
573	INTEGER :: iff
574	TYPE(ctrl_out) :: var
575
576	REAL zstophym
577	CHARACTER(LEN=20) :: typeecrit
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
594	! Appel a la lecture des noms et niveau d'ecriture des variables dans output.def
595	CALL conf_physoutputs(var%name,var%flag)
596
597	IF (typeecrit=='inst(X)'.OR.typeecrit=='once') THEN
598	zstophym=zoutm(iff)
599	ELSE
600	zstophym=zdtime_moy
601	ENDIF
602
603	IF(.NOT.clef_stations(iff)) THEN
604	#ifdef CPP_XIOS
605	CALL wxios_add_field_to_file(var%name, 3, nid_files(iff), phys_out_filenames(iff), &
606	var%description, var%unit, var%flag(iff), typeecrit)
607	#endif
608
609	IF ( var%flag(iff)<=lev_files(iff) ) THEN
610	CALL histdef (nid_files(iff), var%name, var%description, var%unit, &
611	iim, jj_nb, nhorim(iff), klev, levmin(iff), &
612	levmax(iff)-levmin(iff)+1, nvertm(iff), 32, typeecrit, &
613	zstophym, zoutm(iff))
614	ENDIF
615	ELSE
616	IF ( var%flag(iff)<=lev_files(iff)) THEN
617	CALL histdef (nid_files(iff), var%name, var%description, var%unit, &
618	npstn,1,nhorim(iff), klev, levmin(iff), &
619	levmax(iff)-levmin(iff)+1, nvertm(iff), 32, &
620	typeecrit, zstophym,zoutm(iff))
621	ENDIF
622	ENDIF
623	END SUBROUTINE histdef3d
624
625	SUBROUTINE conf_physoutputs(nam_var,flag_var)
626	!!! Lecture des noms et niveau de sortie des variables dans output.def
627	! en utilisant les routines getin de IOIPSL
628	use ioipsl
629
630	IMPLICIT NONE
631
632	include 'iniprint.h'
633
634	CHARACTER(LEN=20) :: nam_var
635	INTEGER, DIMENSION(nfiles) :: flag_var
636
637	IF(prt_level>10) WRITE(lunout,*)'Avant getin: nam_var flag_var ',nam_var,flag_var(:)
638	CALL getin('flag_'//nam_var,flag_var)
639	CALL getin('name_'//nam_var,nam_var)
640	IF(prt_level>10) WRITE(lunout,*)'Apres getin: nam_var flag_var ',nam_var,flag_var(:)
641
642	END SUBROUTINE conf_physoutputs
643
644
645
646	SUBROUTINE histwrite2d_phy_old(nid,lpoint,name,itau,field)
647	USE dimphy
648	USE mod_phys_lmdz_para
649	USE ioipsl
650	IMPLICIT NONE
651	include 'dimensions.h'
652	include 'iniprint.h'
653
654	integer,INTENT(IN) :: nid
655	logical,INTENT(IN) :: lpoint
656	character(), INTENT(IN) :: name
657	integer, INTENT(IN) :: itau
658	REAL,DIMENSION(:),INTENT(IN) :: field
659	REAL,DIMENSION(klon_mpi) :: buffer_omp
660	INTEGER, allocatable, DIMENSION(:) :: index2d
661	REAL :: Field2d(iim,jj_nb)
662
663	integer :: ip
664	REAL,allocatable,DIMENSION(:) :: fieldok
665
666
667	IF (size(field)/=klon) CALL abort_gcm('iophy::histwrite2d','Field first DIMENSION not equal to klon',1)
668
669	CALL Gather_omp(field,buffer_omp)
670	!$OMP MASTER
671	CALL grid1Dto2D_mpi(buffer_omp,Field2d)
672	if(.NOT.lpoint) THEN
673	ALLOCATE(index2d(iim*jj_nb))
674	ALLOCATE(fieldok(iim*jj_nb))
675	IF (prt_level >= 9) write(lunout,*)'Sending ',name,' to IOIPSL'
676	CALL histwrite(nid,name,itau,Field2d,iim*jj_nb,index2d)
677	IF (prt_level >= 9) write(lunout,*)'Finished sending ',name,' to IOIPSL'
678	else
679	ALLOCATE(fieldok(npstn))
680	ALLOCATE(index2d(npstn))
681
682	if(is_sequential) then
683	! klon_mpi_begin=1
684	! klon_mpi_end=klon
685	DO ip=1, npstn
686	fieldok(ip)=buffer_omp(nptabij(ip))
687	ENDDO
688	else
689	DO ip=1, npstn
690	! print*,'histwrite2d is_sequential npstn ip name nptabij',npstn,ip,name,nptabij(ip)
691	IF(nptabij(ip).GE.klon_mpi_begin.AND. &
692	nptabij(ip).LE.klon_mpi_end) THEN
693	fieldok(ip)=buffer_omp(nptabij(ip)-klon_mpi_begin+1)
694	ENDIF
695	ENDDO
696	endif
697	IF (prt_level >= 9) write(lunout,*)'Sending ',name,' to IOIPSL'
698	CALL histwrite(nid,name,itau,fieldok,npstn,index2d)
699	IF (prt_level >= 9) write(lunout,*)'Finished sending ',name,' to IOIPSL'
700	!
701	endif
702	deallocate(index2d)
703	deallocate(fieldok)
704	!$OMP END MASTER
705
706
707	end SUBROUTINE histwrite2d_phy_old
708
709	SUBROUTINE histwrite3d_phy_old(nid,lpoint,name,itau,field)
710	USE dimphy
711	USE mod_phys_lmdz_para
712
713	use ioipsl
714	IMPLICIT NONE
715	include 'dimensions.h'
716	include 'iniprint.h'
717
718	integer,INTENT(IN) :: nid
719	logical,INTENT(IN) :: lpoint
720	character(), INTENT(IN) :: name
721	integer, INTENT(IN) :: itau
722	REAL,DIMENSION(:,:),INTENT(IN) :: field ! --> field(klon,:)
723	REAL,DIMENSION(klon_mpi,size(field,2)) :: buffer_omp
724	REAL :: Field3d(iim,jj_nb,size(field,2))
725	INTEGER :: ip, n, nlev
726	INTEGER, ALLOCATABLE, DIMENSION(:) :: index3d
727	REAL,allocatable, DIMENSION(:,:) :: fieldok
728
729
730	IF (size(field,1)/=klon) CALL abort_gcm('iophy::histwrite3d','Field first DIMENSION not equal to klon',1)
731	nlev=size(field,2)
732
733	! print*,'hist3d_phy mpi_rank npstn=',mpi_rank,npstn
734
735	! DO ip=1, npstn
736	! print*,'hist3d_phy mpi_rank nptabij',mpi_rank,nptabij(ip)
737	! ENDDO
738
739	CALL Gather_omp(field,buffer_omp)
740	!$OMP MASTER
741	CALL grid1Dto2D_mpi(buffer_omp,field3d)
742	if(.NOT.lpoint) THEN
743	ALLOCATE(index3d(iimjj_nbnlev))
744	ALLOCATE(fieldok(iim*jj_nb,nlev))
745	IF (prt_level >= 9) write(lunout,*)'Sending ',name,' to IOIPSL'
746	CALL histwrite(nid,name,itau,Field3d,iimjj_nbnlev,index3d)
747	IF (prt_level >= 9) write(lunout,*)'Finished sending ',name,' to IOIPSL'
748	else
749	nlev=size(field,2)
750	ALLOCATE(index3d(npstn*nlev))
751	ALLOCATE(fieldok(npstn,nlev))
752
753	if(is_sequential) then
754	! klon_mpi_begin=1
755	! klon_mpi_end=klon
756	DO n=1, nlev
757	DO ip=1, npstn
758	fieldok(ip,n)=buffer_omp(nptabij(ip),n)
759	ENDDO
760	ENDDO
761	else
762	DO n=1, nlev
763	DO ip=1, npstn
764	IF(nptabij(ip).GE.klon_mpi_begin.AND. &
765	nptabij(ip).LE.klon_mpi_end) THEN
766	fieldok(ip,n)=buffer_omp(nptabij(ip)-klon_mpi_begin+1,n)
767	ENDIF
768	ENDDO
769	ENDDO
770	endif
771	IF (prt_level >= 9) write(lunout,*)'Sending ',name,' to IOIPSL'
772	CALL histwrite(nid,name,itau,fieldok,npstn*nlev,index3d)
773	IF (prt_level >= 9) write(lunout,*)'Finished sending ',name,' to IOIPSL'
774	endif
775	deallocate(index3d)
776	deallocate(fieldok)
777	!$OMP END MASTER
778
779	end SUBROUTINE histwrite3d_phy_old
780
781
782
783
784	! ug NOUVELLE VERSION DES WRITE AVEC LA BOUCLE DO RENTREE
785	SUBROUTINE histwrite2d_phy(var,field, STD_iff)
786	USE dimphy
787	USE mod_phys_lmdz_para
788	USE ioipsl
789
790
791
792	#ifdef CPP_XIOS
793	USE wxios
794	#endif
795
796
797	IMPLICIT NONE
798	INCLUDE 'dimensions.h'
799	INCLUDE 'iniprint.h'
800
801	TYPE(ctrl_out), INTENT(IN) :: var
802	REAL, DIMENSION(:), INTENT(IN) :: field
803	INTEGER, INTENT(IN), OPTIONAL :: STD_iff ! ug RUSTINE POUR LES STD LEVS.....
804
805	INTEGER :: iff, iff_beg, iff_end
806
807	REAL,DIMENSION(klon_mpi) :: buffer_omp
808	INTEGER, allocatable, DIMENSION(:) :: index2d
809	REAL :: Field2d(iim,jj_nb)
810
811	INTEGER :: ip
812	REAL, ALLOCATABLE, DIMENSION(:) :: fieldok
813
814	IF (prt_level >= 9) WRITE(lunout,*)'Begin histrwrite2d ',var%name
815
816	! ug RUSTINE POUR LES STD LEVS.....
817	IF (PRESENT(STD_iff)) THEN
818	iff_beg = STD_iff
819	iff_end = STD_iff
820	ELSE
821	iff_beg = 1
822	iff_end = nfiles
823	END IF
824
825	! On regarde si on est dans la phase de définition ou d'écriture:
826	IF(.NOT.vars_defined) THEN
827	!$OMP MASTER
828	!Si phase de définition.... on définit
829	DO iff=iff_beg, iff_end
830	IF (clef_files(iff)) THEN
831	CALL histdef2d(iff, var)
832	ENDIF
833	ENDDO
834	!$OMP END MASTER
835	ELSE
836
837	!Et sinon on.... écrit
838	IF (SIZE(field)/=klon) CALL abort_gcm('iophy::histwrite2d','Field first DIMENSION not equal to klon',1)
839
840	CALL Gather_omp(field,buffer_omp)
841	!$OMP MASTER
842	CALL grid1Dto2D_mpi(buffer_omp,Field2d)
843
844	! La boucle sur les fichiers:
845	DO iff=iff_beg, iff_end
846	IF (var%flag(iff) <= lev_files(iff) .AND. clef_files(iff)) THEN
847
848	IF(.NOT.clef_stations(iff)) THEN
849	ALLOCATE(index2d(iim*jj_nb))
850	ALLOCATE(fieldok(iim*jj_nb))
851
852	CALL histwrite(nid_files(iff),var%name,itau_iophy,Field2d,iim*jj_nb,index2d)
853	#ifdef CPP_XIOS
854	IF (iff == iff_beg) THEN
855	CALL wxios_write_2D(var%name, Field2d)
856	ENDIF
857	#endif
858	ELSE
859	ALLOCATE(fieldok(npstn))
860	ALLOCATE(index2d(npstn))
861
862	IF (is_sequential) THEN
863	DO ip=1, npstn
864	fieldok(ip)=buffer_omp(nptabij(ip))
865	ENDDO
866	ELSE
867	DO ip=1, npstn
868	PRINT*,'histwrite2d is_sequential npstn ip namenptabij',npstn,ip,var%name,nptabij(ip)
869	IF(nptabij(ip).GE.klon_mpi_begin.AND. &
870	nptabij(ip).LE.klon_mpi_end) THEN
871	fieldok(ip)=buffer_omp(nptabij(ip)-klon_mpi_begin+1)
872	ENDIF
873	ENDDO
874	ENDIF
875
876	CALL histwrite(nid_files(iff),var%name,itau_iophy,fieldok,npstn,index2d)
877	ENDIF
878
879	deallocate(index2d)
880	deallocate(fieldok)
881	ENDIF !levfiles
882	ENDDO
883	!$OMP END MASTER
884	ENDIF ! vars_defined
885	IF (prt_level >= 9) WRITE(lunout,*)'End histrwrite2d ',var%name
886	END SUBROUTINE histwrite2d_phy
887
888
889	! ug NOUVELLE VERSION DES WRITE AVEC LA BOUCLE DO RENTREE
890	SUBROUTINE histwrite3d_phy(var, field, STD_iff)
891	USE dimphy
892	USE mod_phys_lmdz_para
893	USE ioipsl
894
895
896	#ifdef CPP_XIOS
897	! USE WXIOS
898	#endif
899
900
901	IMPLICIT NONE
902	INCLUDE 'dimensions.h'
903	INCLUDE 'iniprint.h'
904
905	TYPE(ctrl_out), INTENT(IN) :: var
906	REAL, DIMENSION(:,:), INTENT(IN) :: field ! --> field(klon,:)
907	INTEGER, INTENT(IN), OPTIONAL :: STD_iff ! ug RUSTINE POUR LES STD LEVS.....
908
909	INTEGER :: iff, iff_beg, iff_end
910
911	REAL,DIMENSION(klon_mpi,SIZE(field,2)) :: buffer_omp
912	REAL :: Field3d(iim,jj_nb,SIZE(field,2))
913	INTEGER :: ip, n, nlev
914	INTEGER, ALLOCATABLE, DIMENSION(:) :: index3d
915	REAL,ALLOCATABLE, DIMENSION(:,:) :: fieldok
916
917	IF (prt_level >= 9) write(lunout,*)'Begin histrwrite3d ',var%name
918
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	!Si phase de définition.... on définit
931	!$OMP MASTER
932	DO iff=iff_beg, iff_end
933	IF (clef_files(iff)) THEN
934	CALL histdef3d(iff, var)
935	ENDIF
936	ENDDO
937	!$OMP END MASTER
938	ELSE
939	!Et sinon on.... écrit
940	IF (SIZE(field,1)/=klon) CALL abort_gcm('iophy::histwrite3d','Field first DIMENSION not equal to klon',1)
941	nlev=SIZE(field,2)
942
943
944	CALL Gather_omp(field,buffer_omp)
945	!$OMP MASTER
946	CALL grid1Dto2D_mpi(buffer_omp,field3d)
947
948
949	! BOUCLE SUR LES FICHIERS
950	DO iff=iff_beg, iff_end
951	IF (var%flag(iff) <= lev_files(iff) .AND. clef_files(iff)) THEN
952	IF (.NOT.clef_stations(iff)) THEN
953	ALLOCATE(index3d(iimjj_nbnlev))
954	ALLOCATE(fieldok(iim*jj_nb,nlev))
955	CALL histwrite(nid_files(iff),var%name,itau_iophy,Field3d,iimjj_nbnlev,index3d)
956
957	#ifdef CPP_XIOS
958	IF (iff == 1) THEN
959	CALL wxios_write_3D(var%name, Field3d(:,:,1:klev))
960	ENDIF
961	#endif
962
963	ELSE
964	nlev=size(field,2)
965	ALLOCATE(index3d(npstn*nlev))
966	ALLOCATE(fieldok(npstn,nlev))
967
968	IF (is_sequential) THEN
969	DO n=1, nlev
970	DO ip=1, npstn
971	fieldok(ip,n)=buffer_omp(nptabij(ip),n)
972	ENDDO
973	ENDDO
974	ELSE
975	DO n=1, nlev
976	DO ip=1, npstn
977	IF(nptabij(ip).GE.klon_mpi_begin.AND. &
978	nptabij(ip).LE.klon_mpi_end) THEN
979	fieldok(ip,n)=buffer_omp(nptabij(ip)-klon_mpi_begin+1,n)
980	ENDIF
981	ENDDO
982	ENDDO
983	ENDIF
984	CALL histwrite(nid_files(iff),var%name,itau_iophy,fieldok,npstn*nlev,index3d)
985	ENDIF
986	deallocate(index3d)
987	deallocate(fieldok)
988	ENDIF
989	ENDDO
990	!$OMP END MASTER
991	ENDIF ! vars_defined
992	IF (prt_level >= 9) write(lunout,*)'End histrwrite3d ',var%name
993	END SUBROUTINE histwrite3d_phy
994
995	end module iophy

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

Download in other formats:

Original Format