Context Navigation

iophy.F90 @ 2435

Last change on this file since 2435 was 2435, checked in by Laurent Fairhead, 9 years ago
Merged trunk changes r2396:2434 into testing branch
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: 43.6 KB

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

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

Download in other formats:

Original Format