Context Navigation

iophy.F90 @ 1794

Last change on this file since 1794 was 1791, checked in by Ehouarn Millour, 12 years ago

Enrichissement et organisation en module de la structure ctrl_out des variables de sortie: ajout des champs description, unité et type_ecrit. Adaptation en conséquence des routines histdef et histwrite.
UG
...................................................

Improvement and transformation into a module of the ctrl_out structure describing output vars. New fields: description, unit and type_ecrit. Creation of new routines histwrite and histdef to take advantage of this structure.
UG

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

File size: 19.6 KB

Rev	Line
[879]	1	!
	2	! $Header$
	3	!
[629]	4	module iophy
	5
[931]	6	! abd REAL,private,allocatable,dimension(:),save :: io_lat
	7	! abd REAL,private,allocatable,dimension(:),save :: io_lon
[1791]	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)
[629]	16
	17	INTERFACE histwrite_phy
[1791]	18	MODULE PROCEDURE histwrite2d_phy,histwrite3d_phy,histwrite2d_phy_old,histwrite3d_phy_old
[1001]	19	END INTERFACE
[629]	20
[1539]	21	INTERFACE histbeg_phy_all
	22	MODULE PROCEDURE histbeg_phy,histbeg_phy_points
	23	END INTERFACE
[1001]	24
[1539]	25
[629]	26	contains
	27
[1001]	28	subroutine init_iophy_new(rlat,rlon)
	29	USE dimphy
	30	USE mod_phys_lmdz_para
	31	USE mod_grid_phy_lmdz
	32	USE ioipsl
	33	implicit none
	34	include 'dimensions.h'
	35	real,dimension(klon),intent(in) :: rlon
	36	real,dimension(klon),intent(in) :: rlat
	37
	38	REAL,dimension(klon_glo) :: rlat_glo
	39	REAL,dimension(klon_glo) :: rlon_glo
	40
	41	INTEGER,DIMENSION(2) :: ddid
	42	INTEGER,DIMENSION(2) :: dsg
	43	INTEGER,DIMENSION(2) :: dsl
	44	INTEGER,DIMENSION(2) :: dpf
	45	INTEGER,DIMENSION(2) :: dpl
	46	INTEGER,DIMENSION(2) :: dhs
	47	INTEGER,DIMENSION(2) :: dhe
	48	INTEGER :: i
	49
	50	CALL gather(rlat,rlat_glo)
	51	CALL bcast(rlat_glo)
	52	CALL gather(rlon,rlon_glo)
	53	CALL bcast(rlon_glo)
	54
	55	!$OMP MASTER
[1674]	56	ALLOCATE(io_lat(jjm+1-1/(iim*jjm)))
[1001]	57	io_lat(1)=rlat_glo(1)
[1674]	58	io_lat(jjm+1-1/(iim*jjm))=rlat_glo(klon_glo)
	59	IF ((iim*jjm) > 1) then
[1001]	60	DO i=2,jjm
	61	io_lat(i)=rlat_glo(2+(i-2)*iim)
	62	ENDDO
	63	ENDIF
	64
	65	ALLOCATE(io_lon(iim))
[1674]	66	io_lon(:)=rlon_glo(2-1/(iimjjm):iim+1-1/(iimjjm))
[1001]	67
	68	ddid=(/ 1,2 /)
[1674]	69	dsg=(/ iim, jjm+1-1/(iim*jjm) /)
[1001]	70	dsl=(/ iim, jj_nb /)
	71	dpf=(/ 1,jj_begin /)
	72	dpl=(/ iim, jj_end /)
	73	dhs=(/ ii_begin-1,0 /)
	74	if (mpi_rank==mpi_size-1) then
	75	dhe=(/0,0/)
	76	else
	77	dhe=(/ iim-ii_end,0 /)
	78	endif
	79
	80	call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
	81	'APPLE',phys_domain_id)
	82
	83	!$OMP END MASTER
	84
	85	end subroutine init_iophy_new
	86
[629]	87	subroutine init_iophy(lat,lon)
[776]	88	USE dimphy
	89	USE mod_phys_lmdz_para
[766]	90	use ioipsl
[629]	91	implicit none
[793]	92	include 'dimensions.h'
[629]	93	real,dimension(iim),intent(in) :: lon
[1674]	94	real,dimension(jjm+1-1/(iim*jjm)),intent(in) :: lat
[766]	95
	96	INTEGER,DIMENSION(2) :: ddid
	97	INTEGER,DIMENSION(2) :: dsg
	98	INTEGER,DIMENSION(2) :: dsl
	99	INTEGER,DIMENSION(2) :: dpf
	100	INTEGER,DIMENSION(2) :: dpl
	101	INTEGER,DIMENSION(2) :: dhs
	102	INTEGER,DIMENSION(2) :: dhe
	103
	104	!$OMP MASTER
[1674]	105	allocate(io_lat(jjm+1-1/(iim*jjm)))
[629]	106	io_lat(:)=lat(:)
	107	allocate(io_lon(iim))
	108	io_lon(:)=lon(:)
[1331]	109
[766]	110	ddid=(/ 1,2 /)
[1674]	111	dsg=(/ iim, jjm+1-1/(iim*jjm) /)
[776]	112	dsl=(/ iim, jj_nb /)
	113	dpf=(/ 1,jj_begin /)
	114	dpl=(/ iim, jj_end /)
	115	dhs=(/ ii_begin-1,0 /)
	116	if (mpi_rank==mpi_size-1) then
[766]	117	dhe=(/0,0/)
	118	else
[776]	119	dhe=(/ iim-ii_end,0 /)
[766]	120	endif
	121
[776]	122	call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
[766]	123	'APPLE',phys_domain_id)
[629]	124
[766]	125	!$OMP END MASTER
	126
[629]	127	end subroutine init_iophy
	128
	129	subroutine histbeg_phy(name,itau0,zjulian,dtime,nhori,nid_day)
[776]	130	USE dimphy
	131	USE mod_phys_lmdz_para
[629]	132	use ioipsl
	133	use write_field
	134	implicit none
[793]	135	include 'dimensions.h'
[629]	136
	137	character(), intent(IN) :: name
	138	integer, intent(in) :: itau0
	139	real,intent(in) :: zjulian
	140	real,intent(in) :: dtime
	141	integer,intent(out) :: nhori
	142	integer,intent(out) :: nid_day
[766]	143
	144	!$OMP MASTER
[776]	145	if (is_sequential) then
	146	call histbeg(name,iim,io_lon, jj_nb,io_lat(jj_begin:jj_end), &
	147	1,iim,1,jj_nb,itau0, zjulian, dtime, nhori, nid_day)
[629]	148	else
[776]	149	call histbeg(name,iim,io_lon, jj_nb,io_lat(jj_begin:jj_end), &
	150	1,iim,1,jj_nb,itau0, zjulian, dtime, nhori, nid_day,phys_domain_id)
[629]	151	endif
[766]	152	!$OMP END MASTER
[629]	153
	154	end subroutine histbeg_phy
[1539]	155
	156	subroutine histbeg_phy_points(rlon,rlat,pim,tabij,ipt,jpt, &
	157	plon,plat,plon_bounds,plat_bounds, &
	158	nname,itau0,zjulian,dtime,nnhori,nnid_day)
[776]	159	USE dimphy
	160	USE mod_phys_lmdz_para
[1539]	161	USE mod_grid_phy_lmdz
	162	use ioipsl
	163	use write_field
	164	implicit none
	165	include 'dimensions.h'
	166
	167	real,dimension(klon),intent(in) :: rlon
	168	real,dimension(klon),intent(in) :: rlat
	169	integer, intent(in) :: itau0
	170	real,intent(in) :: zjulian
	171	real,intent(in) :: dtime
	172	integer, intent(in) :: pim
	173	integer, intent(out) :: nnhori
	174	character(len=20), intent(in) :: nname
	175	INTEGER, intent(out) :: nnid_day
	176	integer :: i
	177	REAL,dimension(klon_glo) :: rlat_glo
	178	REAL,dimension(klon_glo) :: rlon_glo
	179	INTEGER, DIMENSION(pim), intent(in) :: tabij
	180	REAL,dimension(pim), intent(in) :: plat, plon
	181	INTEGER,dimension(pim), intent(in) :: ipt, jpt
	182	REAL,dimension(pim,2), intent(out) :: plat_bounds, plon_bounds
	183
	184	INTEGER, SAVE :: tabprocbeg, tabprocend
	185	!$OMP THREADPRIVATE(tabprocbeg, tabprocend)
	186	INTEGER :: ip
	187	INTEGER, PARAMETER :: nip=1
	188	INTEGER :: npproc
	189	REAL, allocatable, dimension(:) :: npplat, npplon
	190	REAL, allocatable, dimension(:,:) :: npplat_bounds, npplon_bounds
	191	INTEGER, PARAMETER :: jjmp1=jjm+1-1/jjm
	192	REAL, dimension(iim,jjmp1) :: zx_lon, zx_lat
	193
	194	CALL gather(rlat,rlat_glo)
	195	CALL bcast(rlat_glo)
	196	CALL gather(rlon,rlon_glo)
	197	CALL bcast(rlon_glo)
	198
	199	!$OMP MASTER
	200	DO i=1,pim
	201
	202	! print*,'CFMIP_iophy i tabij lon lat',i,tabij(i),plon(i),plat(i)
	203
	204	plon_bounds(i,1)=rlon_glo(tabij(i)-1)
	205	plon_bounds(i,2)=rlon_glo(tabij(i)+1)
	206	if(plon_bounds(i,2).LE.0..AND.plon_bounds(i,1).GE.0.) THEN
	207	if(rlon_glo(tabij(i)).GE.0.) THEN
	208	plon_bounds(i,2)=-1*plon_bounds(i,2)
	209	endif
	210	endif
	211	if(plon_bounds(i,2).GE.0..AND.plon_bounds(i,1).LE.0.) THEN
	212	if(rlon_glo(tabij(i)).LE.0.) THEN
	213	plon_bounds(i,2)=-1*plon_bounds(i,2)
	214	endif
	215	endif
	216	!
	217	IF ( tabij(i).LE.iim) THEN
	218	plat_bounds(i,1)=rlat_glo(tabij(i))
	219	ELSE
	220	plat_bounds(i,1)=rlat_glo(tabij(i)-iim)
	221	ENDIF
	222	plat_bounds(i,2)=rlat_glo(tabij(i)+iim)
	223	!
	224	! print*,'CFMIP_iophy point i lon lon_bds',i,plon_bounds(i,1),rlon_glo(tabij(i)),plon_bounds(i,2)
	225	! print*,'CFMIP_iophy point i lat lat_bds',i,plat_bounds(i,1),rlat_glo(tabij(i)),plat_bounds(i,2)
	226	!
	227	ENDDO
	228	if (is_sequential) then
	229
	230	npstn=pim
	231	IF(.NOT. ALLOCATED(nptabij)) THEN
	232	ALLOCATE(nptabij(pim))
	233	ENDIF
	234	DO i=1,pim
	235	nptabij(i)=tabij(i)
	236	ENDDO
	237
	238	CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon_glo,zx_lon)
[1674]	239	if ((iim*jjm).gt.1) then
[1539]	240	DO i = 1, iim
	241	zx_lon(i,1) = rlon_glo(i+1)
	242	zx_lon(i,jjmp1) = rlon_glo(i+1)
	243	ENDDO
	244	endif
	245	CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat_glo,zx_lat)
	246
	247	DO i=1,pim
	248	! print*,'CFMIP_iophy i tabij lon lat',i,tabij(i),plon(i),plat(i)
	249
	250	plon_bounds(i,1)=zx_lon(ipt(i)-1,jpt(i))
	251	plon_bounds(i,2)=zx_lon(ipt(i)+1,jpt(i))
	252
	253	if (ipt(i).EQ.1) then
	254	plon_bounds(i,1)=zx_lon(iim,jpt(i))
	255	plon_bounds(i,2)=360.+zx_lon(ipt(i)+1,jpt(i))
	256	endif
	257
	258	if (ipt(i).EQ.iim) then
	259	plon_bounds(i,2)=360.+zx_lon(1,jpt(i))
	260	endif
	261
	262	plat_bounds(i,1)=zx_lat(ipt(i),jpt(i)-1)
	263	plat_bounds(i,2)=zx_lat(ipt(i),jpt(i)+1)
	264
	265	if (jpt(i).EQ.1) then
	266	plat_bounds(i,1)=zx_lat(ipt(i),1)+0.001
	267	plat_bounds(i,2)=zx_lat(ipt(i),1)-0.001
	268	endif
	269
	270	if (jpt(i).EQ.jjmp1) then
	271	plat_bounds(i,1)=zx_lat(ipt(i),jjmp1)+0.001
	272	plat_bounds(i,2)=zx_lat(ipt(i),jjmp1)-0.001
	273	endif
	274	!
	275	! print*,'CFMIP_iophy point i lon lon_bds',i,plon_bounds(i,1),rlon(tabij(i)),plon_bounds(i,2)
	276	! print*,'CFMIP_iophy point i lat lat_bds',i,plat_bounds(i,1),rlat(tabij(i)),plat_bounds(i,2)
	277	!
	278	ENDDO
	279	! print*,'iophy is_sequential nname, nnhori, nnid_day=',trim(nname),nnhori,nnid_day
	280	call histbeg(nname,pim,plon,plon_bounds, &
	281	plat,plat_bounds, &
	282	itau0, zjulian, dtime, nnhori, nnid_day)
	283	else
	284	npproc=0
	285	DO ip=1, pim
	286	tabprocbeg=klon_mpi_begin
	287	tabprocend=klon_mpi_end
	288	IF(tabij(ip).GE.tabprocbeg.AND.tabij(ip).LE.tabprocend) THEN
	289	npproc=npproc+1
	290	npstn=npproc
	291	ENDIF
	292	ENDDO
	293	! print*,'CFMIP_iophy mpi_rank npstn',mpi_rank,npstn
	294	IF(.NOT. ALLOCATED(nptabij)) THEN
	295	ALLOCATE(nptabij(npstn))
	296	ALLOCATE(npplon(npstn), npplat(npstn))
	297	ALLOCATE(npplon_bounds(npstn,2), npplat_bounds(npstn,2))
	298	ENDIF
	299	npproc=0
	300	DO ip=1, pim
	301	IF(tabij(ip).GE.tabprocbeg.AND.tabij(ip).LE.tabprocend) THEN
	302	npproc=npproc+1
	303	nptabij(npproc)=tabij(ip)
	304	! print*,'mpi_rank npproc ip plon plat tabij=',mpi_rank,npproc,ip, &
	305	! plon(ip),plat(ip),tabij(ip)
	306	npplon(npproc)=plon(ip)
	307	npplat(npproc)=plat(ip)
	308	npplon_bounds(npproc,1)=plon_bounds(ip,1)
	309	npplon_bounds(npproc,2)=plon_bounds(ip,2)
	310	npplat_bounds(npproc,1)=plat_bounds(ip,1)
	311	npplat_bounds(npproc,2)=plat_bounds(ip,2)
	312	!!!
	313	!!! print qui sert a reordonner les points stations selon l'ordre CFMIP
	314	!!! ne pas enlever
	315	print*,'iophy_mpi rank ip lon lat',mpi_rank,ip,plon(ip),plat(ip)
	316	!!!
	317	ENDIF
	318	ENDDO
	319	call histbeg(nname,npstn,npplon,npplon_bounds, &
	320	npplat,npplat_bounds, &
	321	itau0,zjulian,dtime,nnhori,nnid_day,phys_domain_id)
	322	endif
	323	!$OMP END MASTER
	324
	325	end subroutine histbeg_phy_points
	326
[1791]	327	SUBROUTINE histwrite2d_phy_old(nid,lpoint,name,itau,field)
[1539]	328	USE dimphy
	329	USE mod_phys_lmdz_para
[1791]	330	USE phys_output_var_mod
[776]	331	USE ioipsl
[1791]	332	IMPLICIT NONE
[793]	333	include 'dimensions.h'
[1775]	334	include 'iniprint.h'
[629]	335
	336	integer,intent(in) :: nid
[1539]	337	logical,intent(in) :: lpoint
[629]	338	character(), intent(IN) :: name
	339	integer, intent(in) :: itau
[1331]	340	real,dimension(:),intent(in) :: field
[776]	341	REAL,dimension(klon_mpi) :: buffer_omp
[1539]	342	INTEGER, allocatable, dimension(:) :: index2d
[1331]	343	REAL :: Field2d(iim,jj_nb)
	344
[1539]	345	integer :: ip
	346	real,allocatable,dimension(:) :: fieldok
	347
[1791]	348
[1331]	349	IF (size(field)/=klon) CALL abort_gcm('iophy::histwrite2d','Field first dimension not equal to klon',1)
[776]	350
	351	CALL Gather_omp(field,buffer_omp)
[766]	352	!$OMP MASTER
[1331]	353	CALL grid1Dto2D_mpi(buffer_omp,Field2d)
[1539]	354	if(.NOT.lpoint) THEN
	355	ALLOCATE(index2d(iim*jj_nb))
	356	ALLOCATE(fieldok(iim*jj_nb))
[1775]	357	IF (prt_level >= 9) write(lunout,*)'Sending ',name,' to IOIPSL'
[1539]	358	CALL histwrite(nid,name,itau,Field2d,iim*jj_nb,index2d)
[1775]	359	IF (prt_level >= 9) write(lunout,*)'Finished sending ',name,' to IOIPSL'
[1539]	360	else
	361	ALLOCATE(fieldok(npstn))
	362	ALLOCATE(index2d(npstn))
	363
	364	if(is_sequential) then
	365	! klon_mpi_begin=1
	366	! klon_mpi_end=klon
	367	DO ip=1, npstn
	368	fieldok(ip)=buffer_omp(nptabij(ip))
	369	ENDDO
	370	else
	371	DO ip=1, npstn
	372	! print*,'histwrite2d is_sequential npstn ip name nptabij',npstn,ip,name,nptabij(ip)
	373	IF(nptabij(ip).GE.klon_mpi_begin.AND. &
	374	nptabij(ip).LE.klon_mpi_end) THEN
	375	fieldok(ip)=buffer_omp(nptabij(ip)-klon_mpi_begin+1)
	376	ENDIF
	377	ENDDO
	378	endif
[1775]	379	IF (prt_level >= 9) write(lunout,*)'Sending ',name,' to IOIPSL'
[1539]	380	CALL histwrite(nid,name,itau,fieldok,npstn,index2d)
[1775]	381	IF (prt_level >= 9) write(lunout,*)'Finished sending ',name,' to IOIPSL'
[1539]	382	!
	383	endif
	384	deallocate(index2d)
	385	deallocate(fieldok)
[1791]	386	!$OMP END MASTER
[1331]	387
[1791]	388
	389	end subroutine histwrite2d_phy_old
	390
	391	subroutine histwrite3d_phy_old(nid,lpoint,name,itau,field)
[776]	392	USE dimphy
	393	USE mod_phys_lmdz_para
[1791]	394	USE phys_output_var_mod
[776]	395
[629]	396	use ioipsl
	397	implicit none
[793]	398	include 'dimensions.h'
[1775]	399	include 'iniprint.h'
[629]	400
	401	integer,intent(in) :: nid
[1539]	402	logical,intent(in) :: lpoint
[629]	403	character(), intent(IN) :: name
	404	integer, intent(in) :: itau
[1331]	405	real,dimension(:,:),intent(in) :: field ! --> field(klon,:)
	406	REAL,dimension(klon_mpi,size(field,2)) :: buffer_omp
	407	REAL :: Field3d(iim,jj_nb,size(field,2))
[1539]	408	INTEGER :: ip, n, nlev
	409	INTEGER, ALLOCATABLE, dimension(:) :: index3d
	410	real,allocatable, dimension(:,:) :: fieldok
	411
[1791]	412
[1331]	413	IF (size(field,1)/=klon) CALL abort_gcm('iophy::histwrite3d','Field first dimension not equal to klon',1)
	414	nlev=size(field,2)
[1539]	415
	416	! print*,'hist3d_phy mpi_rank npstn=',mpi_rank,npstn
	417
	418	! DO ip=1, npstn
	419	! print*,'hist3d_phy mpi_rank nptabij',mpi_rank,nptabij(ip)
	420	! ENDDO
	421
[776]	422	CALL Gather_omp(field,buffer_omp)
[766]	423	!$OMP MASTER
[1331]	424	CALL grid1Dto2D_mpi(buffer_omp,field3d)
[1539]	425	if(.NOT.lpoint) THEN
	426	ALLOCATE(index3d(iimjj_nbnlev))
	427	ALLOCATE(fieldok(iim*jj_nb,nlev))
[1775]	428	IF (prt_level >= 9) write(lunout,*)'Sending ',name,' to IOIPSL'
[1539]	429	CALL histwrite(nid,name,itau,Field3d,iimjj_nbnlev,index3d)
[1775]	430	IF (prt_level >= 9) write(lunout,*)'Finished sending ',name,' to IOIPSL'
	431	else
[1539]	432	nlev=size(field,2)
	433	ALLOCATE(index3d(npstn*nlev))
	434	ALLOCATE(fieldok(npstn,nlev))
	435
	436	if(is_sequential) then
	437	! klon_mpi_begin=1
	438	! klon_mpi_end=klon
	439	DO n=1, nlev
	440	DO ip=1, npstn
	441	fieldok(ip,n)=buffer_omp(nptabij(ip),n)
	442	ENDDO
	443	ENDDO
	444	else
	445	DO n=1, nlev
	446	DO ip=1, npstn
	447	IF(nptabij(ip).GE.klon_mpi_begin.AND. &
	448	nptabij(ip).LE.klon_mpi_end) THEN
	449	fieldok(ip,n)=buffer_omp(nptabij(ip)-klon_mpi_begin+1,n)
	450	ENDIF
	451	ENDDO
	452	ENDDO
	453	endif
[1775]	454	IF (prt_level >= 9) write(lunout,*)'Sending ',name,' to IOIPSL'
[1539]	455	CALL histwrite(nid,name,itau,fieldok,npstn*nlev,index3d)
[1775]	456	IF (prt_level >= 9) write(lunout,*)'Finished sending ',name,' to IOIPSL'
[1539]	457	endif
	458	deallocate(index3d)
	459	deallocate(fieldok)
[766]	460	!$OMP END MASTER
[1791]	461
	462	end subroutine histwrite3d_phy_old
	463
	464
	465	! ug NOUVELLE VERSION DES WRITE AVEC LA BOUCLE DO RENTREE
	466	SUBROUTINE histwrite2d_phy(var,field, STD_iff)
	467	USE dimphy
	468	USE mod_phys_lmdz_para
	469	USE ioipsl
	470	!Pour avoir nfiles, nidfiles tout ça tout ça...
	471	USE phys_output_var_mod
[629]	472
[1791]	473
	474
	475	#ifdef CPP_XIOS
	476	! USE WXIOS
	477	#endif
	478
	479	IMPLICIT NONE
	480	include 'dimensions.h'
	481
	482	! integer,intent(in) :: nid
	483	! logical,intent(in) :: lpoint
	484	! character(), intent(IN) :: name
	485	! integer, intent(in) :: itau
	486	! real,dimension(:),intent(in) :: field
	487
	488	TYPE(ctrl_out), INTENT(IN) :: var
	489	REAL, DIMENSION(:), INTENT(IN) :: field
	490	INTEGER, INTENT(IN), OPTIONAL :: STD_iff ! ug RUSTINE POUR LES STD LEVS.....
	491
	492	INTEGER :: iff, iff_beg, iff_end
	493
	494	REAL,dimension(klon_mpi) :: buffer_omp
	495	INTEGER, allocatable, dimension(:) :: index2d
	496	REAL :: Field2d(iim,jj_nb)
	497
	498	INTEGER :: ip
	499	REAL, ALLOCATABLE, DIMENSION(:) :: fieldok
	500
	501	! ug RUSTINE POUR LES STD LEVS.....
	502	IF (PRESENT(STD_iff)) THEN
	503	iff_beg = STD_iff
	504	iff_end = STD_iff
	505	ELSE
	506	iff_beg = 1
	507	iff_end = nfiles
	508	END IF
	509
	510	IF (size(field)/=klon) CALL abort_gcm('iophy::histwrite2d','Field first dimension not equal to klon',1)
	511
	512	CALL Gather_omp(field,buffer_omp)
	513	!$OMP MASTER
	514	CALL grid1Dto2D_mpi(buffer_omp,Field2d)
	515
	516	! La boucle sur les fichiers:
	517	DO iff=iff_beg, iff_end
	518	IF (var%flag(iff) <= lev_files(iff) .AND. clef_files(iff)) THEN
	519
	520	IF(.NOT.clef_stations(iff)) THEN
	521	ALLOCATE(index2d(iim*jj_nb))
	522	ALLOCATE(fieldok(iim*jj_nb))
	523
	524	CALL histwrite(nid_files(iff),var%name,itau_iophy,Field2d,iim*jj_nb,index2d)
	525	#ifdef CPP_XIOS
	526	! IF (iff .EQ. 1) THEN
	527	! CALL wxios_write_2D(var%name, Field2d)
	528	! ENDIF
	529	#endif
	530	ELSE
	531	ALLOCATE(fieldok(npstn))
	532	ALLOCATE(index2d(npstn))
	533
	534	IF (is_sequential) THEN
	535	! klon_mpi_begin=1
	536	! klon_mpi_end=klon
	537	DO ip=1, npstn
	538	fieldok(ip)=buffer_omp(nptabij(ip))
	539	ENDDO
	540	ELSE
	541	DO ip=1, npstn
	542	! print*,'histwrite2d is_sequential npstn ip name nptabij',npstn,ip,name,nptabij(ip)
	543	IF(nptabij(ip).GE.klon_mpi_begin.AND. &
	544	nptabij(ip).LE.klon_mpi_end) THEN
	545	fieldok(ip)=buffer_omp(nptabij(ip)-klon_mpi_begin+1)
	546	ENDIF
	547	ENDDO
	548	ENDIF
	549
	550	CALL histwrite(nid_files(iff),var%name,itau_iophy,fieldok,npstn,index2d)
	551	ENDIF
	552
	553	deallocate(index2d)
	554	deallocate(fieldok)
	555	ENDIF !levfiles
	556	ENDDO
	557	!$OMP END MASTER
	558
	559	END SUBROUTINE histwrite2d_phy
	560
	561
	562	! ug NOUVELLE VERSION DES WRITE AVEC LA BOUCLE DO RENTREE
	563	SUBROUTINE histwrite3d_phy(var, field)
	564	USE dimphy
	565	USE mod_phys_lmdz_para
	566
	567	use ioipsl
	568	!Pour avoir nfiles, nidfiles tout ça tout ça...
	569	USE phys_output_var_mod
	570
	571
	572	#ifdef CPP_XIOS
	573	! USE WXIOS
	574	#endif
	575
	576
	577	IMPLICIT NONE
	578	include 'dimensions.h'
	579
	580	! integer,intent(in) :: nid
	581	! logical,intent(in) :: lpoint
	582	! character(), intent(IN) :: name
	583	! integer, intent(in) :: itau
	584	! real,dimension(:,:),intent(in) :: field ! --> field(klon,:)
	585
	586	TYPE(ctrl_out), INTENT(IN) :: var
	587	REAL, DIMENSION(:,:), INTENT(IN) :: field ! --> field(klon,:)
	588
	589
	590	REAL,DIMENSION(klon_mpi,SIZE(field,2)) :: buffer_omp
	591	REAL :: Field3d(iim,jj_nb,SIZE(field,2))
	592	INTEGER :: ip, n, nlev, iff
	593	INTEGER, ALLOCATABLE, DIMENSION(:) :: index3d
	594	REAL,ALLOCATABLE, DIMENSION(:,:) :: fieldok
	595
	596	IF (size(field,1)/=klon) CALL abort_gcm('iophy::histwrite3d','Field first dimension not equal to klon',1)
	597	nlev=size(field,2)
	598
	599	! print*,'hist3d_phy mpi_rank npstn=',mpi_rank,npstn
	600
	601	! DO ip=1, npstn
	602	! print*,'hist3d_phy mpi_rank nptabij',mpi_rank,nptabij(ip)
	603	! ENDDO
	604
	605	CALL Gather_omp(field,buffer_omp)
	606	!$OMP MASTER
	607	CALL grid1Dto2D_mpi(buffer_omp,field3d)
	608
	609
	610	! BOUCLE SUR LES FICHIERS
	611	DO iff=1, nfiles
	612	IF (var%flag(iff) <= lev_files(iff) .AND. clef_files(iff)) THEN
	613	IF (.NOT.clef_stations(iff)) THEN
	614	ALLOCATE(index3d(iimjj_nbnlev))
	615	ALLOCATE(fieldok(iim*jj_nb,nlev))
	616	CALL histwrite(nid_files(iff),var%name,itau_iophy,Field3d,iimjj_nbnlev,index3d)
	617	#ifdef CPP_XIOS
	618	! IF (iff .EQ. 1) THEN
	619	! CALL wxios_write_3D(var%name, Field3d(:,:,1:klev))
	620	! ENDIF
	621	#endif
	622
	623	ELSE
	624	nlev=size(field,2)
	625	ALLOCATE(index3d(npstn*nlev))
	626	ALLOCATE(fieldok(npstn,nlev))
	627
	628	IF (is_sequential) THEN
	629	! klon_mpi_begin=1
	630	! klon_mpi_end=klon
	631	DO n=1, nlev
	632	DO ip=1, npstn
	633	fieldok(ip,n)=buffer_omp(nptabij(ip),n)
	634	ENDDO
	635	ENDDO
	636	ELSE
	637	DO n=1, nlev
	638	DO ip=1, npstn
	639	IF(nptabij(ip).GE.klon_mpi_begin.AND. &
	640	nptabij(ip).LE.klon_mpi_end) THEN
	641	fieldok(ip,n)=buffer_omp(nptabij(ip)-klon_mpi_begin+1,n)
	642	ENDIF
	643	ENDDO
	644	ENDDO
	645	ENDIF
	646	CALL histwrite(nid_files(iff),var%name,itau_iophy,fieldok,npstn*nlev,index3d)
	647	ENDIF
	648	deallocate(index3d)
	649	deallocate(fieldok)
	650	ENDIF
	651	ENDDO
	652	!$OMP END MASTER
	653	END SUBROUTINE histwrite3d_phy
	654
[629]	655	end module iophy

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

Download in other formats:

Original Format