Context Navigation

iophy.F90 @ 1807

Last change on this file since 1807 was 1807, checked in by Ehouarn Millour, 11 years ago

Unification de la définition et de l'écriture des variables dans la routine histwrite_phy (le premier appel définit les variables, les suivants écrivent). Nettoyage de phys_output_mod, déplacement des histdef_23d dans iophy. Ajout de prints de débogage dans histwrite_phy.
UG
...................................................

Unification of definition and writing of vars in histwrite_phy routine (the first call defines vars, the others do the writing). Cleaning up of phys_output_mod, moving of histdef23_d routines into iophy. Adding debugging prints to histwrite_phy.
UG

Property svn:eol-style set to native
Property svn:keywords set to Author Date Id Revision

File size: 27.4 KB

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

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

Download in other formats:

Original Format