Context Navigation

iophy.F90 @ 2687

Last change on this file since 2687 was 2669, checked in by Laurent Fairhead, 8 years ago
Merged trunk changes r2640:2664 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: 44.4 KB

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

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

Download in other formats:

Original Format