Context Navigation

← Previous Revision
Next Revision →
Normal
Revision Log

iophy.F90

Last change on this file was 3003, checked in by Laurent Fairhead, 7 years ago
Modifications to the code and xml files to output Ap and B, the coefficients of the hybrid coordinates as requested by the CMIP6 DataRequest? LF (with guidance from A. Caubel and S. Senesi)
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: 47.8 KB

Rev	Line
[879]	1	!
[1897]	2	! $Id: iophy.F90 3003 2017-10-03 14:45:26Z lebasn $
[879]	3	!
[1807]	4	MODULE iophy
	5
[1797]	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)
[1852]	16
	17	#ifdef CPP_XIOS
[629]	18	INTERFACE histwrite_phy
[2660]	19	!#ifdef CPP_XIOSnew
[2645]	20	MODULE PROCEDURE histwrite2d_phy,histwrite3d_phy,histwrite2d_phy_old,histwrite3d_phy_old,histwrite2d_xios,histwrite3d_xios,histwrite0d_xios
[2660]	21	!#else
	22	! MODULE PROCEDURE histwrite2d_phy,histwrite3d_phy,histwrite2d_phy_old,histwrite3d_phy_old,histwrite2d_xios,histwrite3d_xios
	23	!#endif
	24
[1852]	25	END INTERFACE
	26	#else
	27	INTERFACE histwrite_phy
[1791]	28	MODULE PROCEDURE histwrite2d_phy,histwrite3d_phy,histwrite2d_phy_old,histwrite3d_phy_old
[1001]	29	END INTERFACE
[1852]	30	#endif
[629]	31
[1539]	32	INTERFACE histbeg_phy_all
[1825]	33	MODULE PROCEDURE histbeg_phy,histbeg_phyxios,histbeg_phy_points
[1539]	34	END INTERFACE
[1001]	35
[1539]	36
[1797]	37	CONTAINS
[629]	38
[1797]	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)
[2854]	47	USE dimphy, ONLY: klon
	48	USE mod_phys_lmdz_para, ONLY: gather, bcast, &
[1897]	49	jj_nb, jj_begin, jj_end, ii_begin, ii_end, &
	50	mpi_size, mpi_rank, klon_mpi, &
[2429]	51	is_sequential, is_south_pole_dyn
[2854]	52	USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, klon_glo
[2319]	53	USE print_control_mod, ONLY: prt_level,lunout
[1897]	54	#ifdef CPP_IOIPSL
[2854]	55	USE ioipsl, ONLY: flio_dom_set
[1897]	56	#endif
	57	#ifdef CPP_XIOS
[2854]	58	USE wxios, ONLY: wxios_domain_param
[1897]	59	#endif
[1797]	60	IMPLICIT NONE
	61	REAL,DIMENSION(klon),INTENT(IN) :: rlon
	62	REAL,DIMENSION(klon),INTENT(IN) :: rlat
[1001]	63
[1797]	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
[1852]	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
[2350]	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)
[2344]	89	DO i=2,nbp_lat-1
	90	io_lat(i)=rlat_glo(2+(i-2)*nbp_lon)
[1001]	91	ENDDO
	92	ENDIF
	93
[2344]	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
[1852]	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 /)
[2344]	117	dsg=(/ nbp_lon, nbp_lat /)
	118	dsl=(/ nbp_lon, jj_nb /)
[1001]	119	dpf=(/ 1,jj_begin /)
[2344]	120	dpl=(/ nbp_lon, jj_end /)
[1001]	121	dhs=(/ ii_begin-1,0 /)
[1797]	122	IF (mpi_rank==mpi_size-1) THEN
[1001]	123	dhe=(/0,0/)
[1797]	124	ELSE
[2344]	125	dhe=(/ nbp_lon-ii_end,0 /)
[1797]	126	ENDIF
[1852]	127
[2097]	128	#ifndef CPP_IOIPSL_NO_OUTPUT
[1797]	129	CALL flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
[1001]	130	'APPLE',phys_domain_id)
[1852]	131	#endif
[1825]	132	#ifdef CPP_XIOS
[1897]	133	! Set values for the mask:
[1852]	134	IF (mpi_rank == 0) THEN
	135	data_ibegin = 0
	136	ELSE
	137	data_ibegin = ii_begin - 1
[2854]	138	ENDIF
[1852]	139
	140	IF (mpi_rank == mpi_size-1) THEN
	141	data_iend = nbp_lon
	142	ELSE
	143	data_iend = ii_end + 1
[2854]	144	ENDIF
[1852]	145
[2854]	146	IF (prt_level>=10) THEN
[1897]	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
[2429]	151	write(lunout,*) "init_iophy_new: mpirank=",mpi_rank," is_south_pole=",is_south_pole_dyn
[2854]	152	ENDIF
[1852]	153
[1897]	154	! Initialize the XIOS domain coreesponding to this process:
[1852]	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, &
[2429]	158	io_lat, io_lon,is_south_pole_dyn,mpi_rank)
[1825]	159	#endif
[1001]	160	!$OMP END MASTER
	161
[1797]	162	END SUBROUTINE init_iophy_new
[1001]	163
[1797]	164	SUBROUTINE init_iophy(lat,lon)
[2854]	165	USE mod_phys_lmdz_para, ONLY: jj_begin, jj_end, ii_begin, ii_end, jj_nb, &
[1897]	166	mpi_size, mpi_rank
[2854]	167	USE ioipsl, ONLY: flio_dom_set
[2344]	168	USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat
[1797]	169	IMPLICIT NONE
[2344]	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
[2854]	182	ALLOCATE(io_lat(nbp_lat))
[629]	183	io_lat(:)=lat(:)
[2854]	184	ALLOCATE(io_lon(nbp_lon))
[629]	185	io_lon(:)=lon(:)
[1331]	186
[766]	187	ddid=(/ 1,2 /)
[2344]	188	dsg=(/ nbp_lon, nbp_lat /)
	189	dsl=(/ nbp_lon, jj_nb /)
[776]	190	dpf=(/ 1,jj_begin /)
[2344]	191	dpl=(/ nbp_lon, jj_end /)
[776]	192	dhs=(/ ii_begin-1,0 /)
[2854]	193	IF (mpi_rank==mpi_size-1) THEN
[766]	194	dhe=(/0,0/)
[2854]	195	ELSE
[2344]	196	dhe=(/ nbp_lon-ii_end,0 /)
[2854]	197	ENDIF
[766]	198
[2097]	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)
[1852]	202	#endif
[766]	203	!$OMP END MASTER
	204
[2854]	205	END SUBROUTINE init_iophy
[1825]	206
	207	SUBROUTINE histbeg_phyxios(name,itau0,zjulian,dtime,ffreq,lev,nhori,nid_day)
[1897]	208	! USE dimphy
[2854]	209	USE mod_phys_lmdz_para, ONLY: is_sequential, is_using_mpi, is_mpi_root, &
[1897]	210	jj_begin, jj_end, jj_nb
[2344]	211	USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat
[2854]	212	USE ioipsl, ONLY: histbeg
[1897]	213	#ifdef CPP_XIOS
[2854]	214	USE wxios, ONLY: wxios_add_file
[1897]	215	#endif
[1825]	216	IMPLICIT NONE
[2114]	217	include 'clesphys.h'
[1825]	218
[2854]	219	CHARACTER(), INTENT(IN) :: name
	220	INTEGER, INTENT(IN) :: itau0
[1825]	221	REAL,INTENT(IN) :: zjulian
	222	REAL,INTENT(IN) :: dtime
[2854]	223	CHARACTER(LEN=*), INTENT(IN) :: ffreq
[1825]	224	INTEGER,INTENT(IN) :: lev
[2854]	225	INTEGER,INTENT(OUT) :: nhori
	226	INTEGER,INTENT(OUT) :: nid_day
[1825]	227
	228	!$OMP MASTER
[2854]	229	IF (is_sequential) THEN
[2344]	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)
[2854]	232	ELSE
[2344]	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)
[2854]	235	ENDIF
[1825]	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
[2114]	241	IF (.not. ok_all_xml) THEN
[1825]	242	CALL wxios_add_file(name, ffreq, lev)
[2114]	243	ENDIF
[2854]	244	ENDIF
[1825]	245	#endif
	246	!$OMP END MASTER
[629]	247
[1825]	248	END SUBROUTINE histbeg_phyxios
	249
[1797]	250	SUBROUTINE histbeg_phy(name,itau0,zjulian,dtime,nhori,nid_day)
[1897]	251
[2854]	252	USE mod_phys_lmdz_para, ONLY: jj_begin, jj_end, jj_nb, is_sequential
[2344]	253	USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat
[2854]	254	USE ioipsl, ONLY: histbeg
[1897]	255
[1797]	256	IMPLICIT NONE
[629]	257
[2854]	258	CHARACTER(), INTENT(IN) :: name
	259	INTEGER, INTENT(IN) :: itau0
[1797]	260	REAL,INTENT(IN) :: zjulian
	261	REAL,INTENT(IN) :: dtime
[2854]	262	INTEGER,INTENT(OUT) :: nhori
	263	INTEGER,INTENT(OUT) :: nid_day
[766]	264
	265	!$OMP MASTER
[2097]	266	#ifndef CPP_IOIPSL_NO_OUTPUT
[2854]	267	IF (is_sequential) THEN
[2344]	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)
[2854]	270	ELSE
[2344]	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)
[2854]	273	ENDIF
[1852]	274	#endif
[766]	275	!$OMP END MASTER
[629]	276
[1797]	277	END SUBROUTINE histbeg_phy
[1539]	278
[1825]	279
[1797]	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)
[2854]	283	USE dimphy, ONLY: klon
	284	USE mod_phys_lmdz_para, ONLY: gather, bcast, &
[1897]	285	is_sequential, klon_mpi_begin, klon_mpi_end, &
	286	mpi_rank
[2854]	287	USE mod_grid_phy_lmdz, ONLY: klon_glo, nbp_lon, nbp_lat
	288	USE ioipsl, ONLY: histbeg
[1897]	289
[1797]	290	IMPLICIT NONE
[1539]	291
[1797]	292	REAL,DIMENSION(klon),INTENT(IN) :: rlon
	293	REAL,DIMENSION(klon),INTENT(IN) :: rlat
[2854]	294	INTEGER, INTENT(IN) :: itau0
[1797]	295	REAL,INTENT(IN) :: zjulian
	296	REAL,INTENT(IN) :: dtime
[2854]	297	INTEGER, INTENT(IN) :: pim
	298	INTEGER, intent(out) :: nnhori
	299	CHARACTER(len=20), INTENT(IN) :: nname
	300	INTEGER, INTENT(OUT) :: nnid_day
	301	INTEGER :: i
[1797]	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
[1797]	314	REAL, allocatable, DIMENSION(:) :: npplat, npplon
	315	REAL, allocatable, DIMENSION(:,:) :: npplat_bounds, npplon_bounds
[2344]	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)
[2854]	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
[1539]	332	plon_bounds(i,2)=-1*plon_bounds(i,2)
[2854]	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
[1539]	337	plon_bounds(i,2)=-1*plon_bounds(i,2)
[2854]	338	ENDIF
	339	ENDIF
[1539]	340	!
[2344]	341	IF ( tabij(i).LE.nbp_lon) THEN
[1539]	342	plat_bounds(i,1)=rlat_glo(tabij(i))
	343	ELSE
[2344]	344	plat_bounds(i,1)=rlat_glo(tabij(i)-nbp_lon)
[1539]	345	ENDIF
[2344]	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
[2344]	362	CALL gr_fi_ecrit(1,klon,nbp_lon,nbp_lat,rlon_glo,zx_lon)
[2854]	363	IF ((nbp_lon*nbp_lat).GT.1) THEN
[2344]	364	DO i = 1, nbp_lon
[1539]	365	zx_lon(i,1) = rlon_glo(i+1)
[2344]	366	zx_lon(i,nbp_lat) = rlon_glo(i+1)
[1539]	367	ENDDO
[2854]	368	ENDIF
[2344]	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
[2854]	377	IF (ipt(i).EQ.1) THEN
[2344]	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))
[2854]	380	ENDIF
[1539]	381
[2854]	382	IF (ipt(i).EQ.nbp_lon) THEN
[1539]	383	plon_bounds(i,2)=360.+zx_lon(1,jpt(i))
[2854]	384	ENDIF
[1539]	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
[2854]	389	IF (jpt(i).EQ.1) THEN
[1539]	390	plat_bounds(i,1)=zx_lat(ipt(i),1)+0.001
	391	plat_bounds(i,2)=zx_lat(ipt(i),1)-0.001
[2854]	392	ENDIF
[1539]	393
[2854]	394	IF (jpt(i).EQ.nbp_lat) THEN
[2344]	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
[2854]	397	ENDIF
[1539]	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
[1897]	403
[2097]	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)
[1852]	408	#endif
[2854]	409	ELSE
[1539]	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
[2097]	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)
[1852]	449	#endif
[2854]	450	ENDIF
[1539]	451	!$OMP END MASTER
	452
[2854]	453	END SUBROUTINE histbeg_phy_points
[1807]	454
	455
	456	SUBROUTINE histdef2d_old (iff,lpoint,flag_var,nomvar,titrevar,unitvar)
	457
[2854]	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, &
[2989]	461	nid_files, nhorim, swaero_diag, dryaod_diag, nfiles, &
	462	ok_4xCO2atm
[2344]	463	USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat
[2854]	464	USE aero_mod, ONLY : naero_tot, name_aero_tau
	465
[1807]	466	IMPLICIT NONE
	467
	468	INCLUDE "clesphys.h"
	469
	470	INTEGER :: iff
[2854]	471	INTEGER :: naero
[1807]	472	LOGICAL :: lpoint
	473	INTEGER, DIMENSION(nfiles) :: flag_var
[2854]	474	CHARACTER(LEN=20) :: nomvar
[1807]	475	CHARACTER(LEN=*) :: titrevar
	476	CHARACTER(LEN=*) :: unitvar
	477
	478	REAL zstophym
	479
	480	IF (type_ecri(iff)=='inst(X)'.OR.type_ecri(iff)=='once') THEN
	481	zstophym=zoutm(iff)
	482	ELSE
	483	zstophym=zdtime_moy
	484	ENDIF
	485
	486	! Appel a la lecture des noms et niveau d'ecriture des variables dans output.def
	487	CALL conf_physoutputs(nomvar,flag_var)
	488
	489	IF(.NOT.lpoint) THEN
	490	IF ( flag_var(iff)<=lev_files(iff) ) THEN
	491	CALL histdef (nid_files(iff),nomvar,titrevar,unitvar, &
[2344]	492	nbp_lon,jj_nb,nhorim(iff), 1,1,1, -99, 32, &
[1807]	493	type_ecri(iff), zstophym,zoutm(iff))
	494	ENDIF
	495	ELSE
	496	IF ( flag_var(iff)<=lev_files(iff) ) THEN
	497	CALL histdef (nid_files(iff),nomvar,titrevar,unitvar, &
	498	npstn,1,nhorim(iff), 1,1,1, -99, 32, &
	499	type_ecri(iff), zstophym,zoutm(iff))
	500	ENDIF
	501	ENDIF
	502
	503	! Set swaero_diag=true if at least one of the concerned variables are defined
[2854]	504	IF (nomvar=='topswad' .OR. nomvar=='topswad0' .OR. nomvar=='solswad' .OR. nomvar=='solswad0' .OR. &
	505	nomvar=='toplwad' .OR. nomvar=='toplwad0' .OR. nomvar=='sollwad' .OR. nomvar=='sollwad0' .OR. &
	506	nomvar=='topswai' .OR. nomvar=='solswai' ) THEN
	507	IF ( flag_var(iff)<=lev_files(iff) ) swaero_diag=.TRUE.
	508	ENDIF
[1807]	509
[2854]	510	! Set dryaod_diag=true if at least one of the concerned variables are defined
[2856]	511	IF (nomvar=='dryod550aer') THEN
	512	IF ( flag_var(iff)<=lev_files(iff) ) dryaod_diag=.TRUE.
	513	ENDIF
[2854]	514	DO naero = 1, naero_tot-1
	515	IF (nomvar=='dryod550_'//name_aero_tau(naero)) THEN
	516	IF ( flag_var(iff)<=lev_files(iff) ) dryaod_diag=.TRUE.
	517	ENDIF
	518	ENDDO
[1807]	519
[2989]	520	! Set ok_4xCO2atm=true if at least one of the concerned variables are
	521	! defined
	522	IF (nomvar=='rsut4co2'.OR.nomvar=='rlut4co2'.OR.nomvar=='rsutcs4co2' &
	523	.OR. nomvar=='rlutcs4co2'.OR.nomvar=='rsu4co2'.OR.nomvar=='rsucs4co2' &
	524	.OR.nomvar=='rsu4co2'.OR.nomvar=='rsucs4co2'.OR.nomvar=='rsd4co2'.OR. &
	525	nomvar=='rsdcs4co2'.OR.nomvar=='rlu4co2'.OR.nomvar=='rlucs4co2'.OR.&
	526	nomvar=='rld4co2'.OR.nomvar=='rldcs4co2') THEN
	527	IF ( flag_var(iff)<=lev_files(iff) ) ok_4xCO2atm=.TRUE.
	528	ENDIF
[2854]	529	END SUBROUTINE histdef2d_old
[1807]	530
	531	SUBROUTINE histdef3d_old (iff,lpoint,flag_var,nomvar,titrevar,unitvar)
	532
[2854]	533	USE ioipsl, ONLY: histdef
	534	USE dimphy, ONLY: klev
	535	USE mod_phys_lmdz_para, ONLY: jj_nb
	536	USE phys_output_var_mod, ONLY: type_ecri, zoutm, lev_files, nid_files, &
[1897]	537	nhorim, zdtime_moy, levmin, levmax, &
	538	nvertm, nfiles
[2344]	539	USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat
[1807]	540	IMPLICIT NONE
	541
	542	INCLUDE "clesphys.h"
	543
	544	INTEGER :: iff
	545	LOGICAL :: lpoint
	546	INTEGER, DIMENSION(nfiles) :: flag_var
	547	CHARACTER(LEN=20) :: nomvar
	548	CHARACTER(LEN=*) :: titrevar
	549	CHARACTER(LEN=*) :: unitvar
	550
	551	REAL zstophym
	552
	553	! Appel a la lecture des noms et niveau d'ecriture des variables dans output.def
	554	CALL conf_physoutputs(nomvar,flag_var)
	555
	556	IF (type_ecri(iff)=='inst(X)'.OR.type_ecri(iff)=='once') THEN
	557	zstophym=zoutm(iff)
	558	ELSE
	559	zstophym=zdtime_moy
	560	ENDIF
	561
	562	IF(.NOT.lpoint) THEN
	563	IF ( flag_var(iff)<=lev_files(iff) ) THEN
	564	CALL histdef (nid_files(iff), nomvar, titrevar, unitvar, &
[2344]	565	nbp_lon, jj_nb, nhorim(iff), klev, levmin(iff), &
[1807]	566	levmax(iff)-levmin(iff)+1, nvertm(iff), 32, type_ecri(iff), &
	567	zstophym, zoutm(iff))
	568	ENDIF
	569	ELSE
	570	IF ( flag_var(iff)<=lev_files(iff) ) THEN
	571	CALL histdef (nid_files(iff), nomvar, titrevar, unitvar, &
	572	npstn,1,nhorim(iff), klev, levmin(iff), &
	573	levmax(iff)-levmin(iff)+1, nvertm(iff), 32, &
	574	type_ecri(iff), zstophym,zoutm(iff))
	575	ENDIF
	576	ENDIF
	577	END SUBROUTINE histdef3d_old
	578
	579	SUBROUTINE histdef2d (iff,var)
	580
[2854]	581	USE ioipsl, ONLY: histdef
	582	USE mod_phys_lmdz_para, ONLY: jj_nb
	583	USE phys_output_var_mod, ONLY: ctrl_out, type_ecri_files, zoutm, zdtime_moy, &
[1897]	584	clef_stations, phys_out_filenames, lev_files, &
[2989]	585	nid_files, nhorim, swaero_diag, dryaod_diag,&
	586	ok_4xCO2atm
[2319]	587	USE print_control_mod, ONLY: prt_level,lunout
[2344]	588	USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat
[2854]	589	USE aero_mod, ONLY : naero_tot, name_aero_tau
[1897]	590	#ifdef CPP_XIOS
[2854]	591	USE wxios, ONLY: wxios_add_field_to_file
[1897]	592	#endif
[1807]	593	IMPLICIT NONE
	594
	595	INCLUDE "clesphys.h"
	596
	597	INTEGER :: iff
[2854]	598	INTEGER :: naero
[1807]	599	TYPE(ctrl_out) :: var
	600
	601	REAL zstophym
	602	CHARACTER(LEN=20) :: typeecrit
	603
	604	! ug On récupère le type écrit de la structure:
	605	! Assez moche, à refaire si meilleure méthode...
	606	IF (INDEX(var%type_ecrit(iff), "once") > 0) THEN
	607	typeecrit = 'once'
	608	ELSE IF(INDEX(var%type_ecrit(iff), "t_min") > 0) THEN
	609	typeecrit = 't_min(X)'
	610	ELSE IF(INDEX(var%type_ecrit(iff), "t_max") > 0) THEN
	611	typeecrit = 't_max(X)'
	612	ELSE IF(INDEX(var%type_ecrit(iff), "inst") > 0) THEN
	613	typeecrit = 'inst(X)'
	614	ELSE
	615	typeecrit = type_ecri_files(iff)
	616	ENDIF
	617
	618	IF (typeecrit=='inst(X)'.OR.typeecrit=='once') THEN
	619	zstophym=zoutm(iff)
	620	ELSE
	621	zstophym=zdtime_moy
	622	ENDIF
	623
	624	! Appel a la lecture des noms et niveau d'ecriture des variables dans output.def
	625	CALL conf_physoutputs(var%name, var%flag)
	626
	627	IF(.NOT.clef_stations(iff)) THEN
[1852]	628
[1825]	629	#ifdef CPP_XIOS
[2114]	630	IF (.not. ok_all_xml) THEN
	631	IF ( var%flag(iff)<=lev_files(iff) ) THEN
	632	CALL wxios_add_field_to_file(var%name, 2, iff, phys_out_filenames(iff), &
	633	var%description, var%unit, var%flag(iff), typeecrit)
	634	IF (prt_level >= 10) THEN
	635	WRITE(lunout,*) 'histdef2d: call wxios_add_field_to_file var%name iff: ', &
	636	trim(var%name),iff
	637	ENDIF
[2001]	638	ENDIF
	639	ENDIF
[1825]	640	#endif
[2097]	641	#ifndef CPP_IOIPSL_NO_OUTPUT
[1825]	642
[1807]	643	IF ( var%flag(iff)<=lev_files(iff) ) THEN
	644	CALL histdef (nid_files(iff), var%name, var%description, var%unit, &
[2344]	645	nbp_lon,jj_nb,nhorim(iff), 1,1,1, -99, 32, &
[1807]	646	typeecrit, zstophym,zoutm(iff))
	647	ENDIF
	648	ELSE
	649	IF ( var%flag(iff)<=lev_files(iff)) THEN
	650	CALL histdef (nid_files(iff), var%name, var%description, var%unit, &
	651	npstn,1,nhorim(iff), 1,1,1, -99, 32, &
	652	typeecrit, zstophym,zoutm(iff))
	653	ENDIF
[1852]	654	#endif
[1807]	655	ENDIF
	656
[2854]	657	! Set swaero_diag=true if at least one of the concerned variables are defined
[2529]	658	!--OB 30/05/2016 use wider set of variables
	659	IF ( var%name=='topswad' .OR. var%name=='topswad0' .OR. var%name=='solswad' .OR. var%name=='solswad0' .OR. &
	660	var%name=='topswai' .OR. var%name=='solswai' .OR. ( iflag_rrtm==1 .AND. ( &
	661	var%name=='toplwad' .OR. var%name=='toplwad0' .OR. var%name=='sollwad' .OR. var%name=='sollwad0' .OR. &
	662	var%name=='toplwai' .OR. var%name=='sollwai' ) ) ) THEN
[2854]	663	IF ( var%flag(iff)<=lev_files(iff) ) swaero_diag=.TRUE.
	664	ENDIF
	665
	666	! set dryaod_dry=true if at least one of the concerned variables are defined
	667	IF (var%name=='dryod550aer') THEN
	668	IF ( var%flag(iff)<=lev_files(iff) ) dryaod_diag=.TRUE.
	669	ENDIF
	670	!
	671	DO naero = 1, naero_tot-1
	672	IF (var%name=='dryod550_'//name_aero_tau(naero)) THEN
	673	IF ( var%flag(iff)<=lev_files(iff) ) dryaod_diag=.TRUE.
	674	ENDIF
	675	ENDDO
[2989]	676	! Set ok_4xCO2atm=true if at least one of the concerned variables are
	677	! defined
	678	IF (var%name=='rsut4co2'.OR.var%name=='rlut4co2'.OR.var%name=='rsutcs4co2' &
	679	.OR. var%name=='rlutcs4co2'.OR.var%name=='rsu4co2'.OR.var%name=='rsucs4co2' &
	680	.OR.var%name=='rsu4co2'.OR.var%name=='rsucs4co2'.OR.var%name=='rsd4co2'.OR. &
	681	var%name=='rsdcs4co2'.OR.var%name=='rlu4co2'.OR.var%name=='rlucs4co2'.OR.&
	682	var%name=='rld4co2'.OR.var%name=='rldcs4co2') THEN
	683	IF ( var%flag(iff)<=lev_files(iff) ) ok_4xCO2atm=.TRUE.
	684	ENDIF
[1807]	685	END SUBROUTINE histdef2d
[2001]	686
[1807]	687	SUBROUTINE histdef3d (iff,var)
	688
[2854]	689	USE ioipsl, ONLY: histdef
	690	USE dimphy, ONLY: klev
	691	USE mod_phys_lmdz_para, ONLY: jj_nb
	692	USE phys_output_var_mod, ONLY: ctrl_out, type_ecri_files, zoutm, zdtime_moy, &
[1897]	693	clef_stations, phys_out_filenames, lev_files, &
[2854]	694	nid_files, nhorim, swaero_diag, dryaod_diag, levmin, &
[1897]	695	levmax, nvertm
[2311]	696	USE print_control_mod, ONLY: prt_level,lunout
[2344]	697	USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat
[1897]	698	#ifdef CPP_XIOS
[2854]	699	USE wxios, ONLY: wxios_add_field_to_file
[1897]	700	#endif
[1807]	701	IMPLICIT NONE
	702
	703	INCLUDE "clesphys.h"
	704
	705	INTEGER :: iff
	706	TYPE(ctrl_out) :: var
	707
	708	REAL zstophym
	709	CHARACTER(LEN=20) :: typeecrit
	710
	711	! ug On récupère le type écrit de la structure:
	712	! Assez moche, à refaire si meilleure méthode...
	713	IF (INDEX(var%type_ecrit(iff), "once") > 0) THEN
	714	typeecrit = 'once'
	715	ELSE IF(INDEX(var%type_ecrit(iff), "t_min") > 0) THEN
	716	typeecrit = 't_min(X)'
	717	ELSE IF(INDEX(var%type_ecrit(iff), "t_max") > 0) THEN
	718	typeecrit = 't_max(X)'
	719	ELSE IF(INDEX(var%type_ecrit(iff), "inst") > 0) THEN
	720	typeecrit = 'inst(X)'
	721	ELSE
	722	typeecrit = type_ecri_files(iff)
	723	ENDIF
	724
	725
	726	! Appel a la lecture des noms et niveau d'ecriture des variables dans output.def
	727	CALL conf_physoutputs(var%name,var%flag)
	728
	729	IF (typeecrit=='inst(X)'.OR.typeecrit=='once') THEN
	730	zstophym=zoutm(iff)
	731	ELSE
	732	zstophym=zdtime_moy
	733	ENDIF
	734
	735	IF(.NOT.clef_stations(iff)) THEN
[1852]	736
[1825]	737	#ifdef CPP_XIOS
[2114]	738	IF (.not. ok_all_xml) THEN
	739	IF ( var%flag(iff)<=lev_files(iff) ) THEN
	740	CALL wxios_add_field_to_file(var%name, 3, iff, phys_out_filenames(iff), &
	741	var%description, var%unit, var%flag(iff), typeecrit)
	742	IF (prt_level >= 10) THEN
	743	WRITE(lunout,*) 'histdef3d: call wxios_add_field_to_file var%name iff: ', &
	744	trim(var%name),iff
	745	ENDIF
	746	ENDIF
	747	ENDIF
[1825]	748	#endif
[2097]	749	#ifndef CPP_IOIPSL_NO_OUTPUT
[1825]	750
[1807]	751	IF ( var%flag(iff)<=lev_files(iff) ) THEN
	752	CALL histdef (nid_files(iff), var%name, var%description, var%unit, &
[2344]	753	nbp_lon, jj_nb, nhorim(iff), klev, levmin(iff), &
[1807]	754	levmax(iff)-levmin(iff)+1, nvertm(iff), 32, typeecrit, &
	755	zstophym, zoutm(iff))
	756	ENDIF
	757	ELSE
	758	IF ( var%flag(iff)<=lev_files(iff)) THEN
	759	CALL histdef (nid_files(iff), var%name, var%description, var%unit, &
	760	npstn,1,nhorim(iff), klev, levmin(iff), &
	761	levmax(iff)-levmin(iff)+1, nvertm(iff), 32, &
	762	typeecrit, zstophym,zoutm(iff))
	763	ENDIF
[1852]	764	#endif
[1807]	765	ENDIF
	766	END SUBROUTINE histdef3d
	767
	768	SUBROUTINE conf_physoutputs(nam_var,flag_var)
	769	!!! Lecture des noms et niveau de sortie des variables dans output.def
	770	! en utilisant les routines getin de IOIPSL
[2854]	771	USE ioipsl, ONLY: getin
	772	USE phys_output_var_mod, ONLY: nfiles
[2311]	773	USE print_control_mod, ONLY: prt_level,lunout
[1807]	774	IMPLICIT NONE
	775
	776	CHARACTER(LEN=20) :: nam_var
	777	INTEGER, DIMENSION(nfiles) :: flag_var
	778
	779	IF(prt_level>10) WRITE(lunout,*)'Avant getin: nam_var flag_var ',nam_var,flag_var(:)
	780	CALL getin('flag_'//nam_var,flag_var)
	781	CALL getin('name_'//nam_var,nam_var)
	782	IF(prt_level>10) WRITE(lunout,*)'Apres getin: nam_var flag_var ',nam_var,flag_var(:)
	783
	784	END SUBROUTINE conf_physoutputs
	785
[1539]	786
[1791]	787	SUBROUTINE histwrite2d_phy_old(nid,lpoint,name,itau,field)
[2854]	788	USE dimphy, ONLY: klon
	789	USE mod_phys_lmdz_para, ONLY: Gather_omp, grid1Dto2D_mpi, &
[1897]	790	is_sequential, klon_mpi_begin, klon_mpi_end, &
	791	jj_nb, klon_mpi
[2854]	792	USE ioipsl, ONLY: histwrite
[2311]	793	USE print_control_mod, ONLY: prt_level,lunout
[2344]	794	USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat
[1791]	795	IMPLICIT NONE
[629]	796
[2854]	797	INTEGER,INTENT(IN) :: nid
	798	LOGICAL,INTENT(IN) :: lpoint
	799	CHARACTER(), INTENT(IN) :: name
	800	INTEGER, INTENT(IN) :: itau
[1797]	801	REAL,DIMENSION(:),INTENT(IN) :: field
	802	REAL,DIMENSION(klon_mpi) :: buffer_omp
	803	INTEGER, allocatable, DIMENSION(:) :: index2d
[2344]	804	REAL :: Field2d(nbp_lon,jj_nb)
[1331]	805
[2854]	806	INTEGER :: ip
	807	REAL,ALLOCATABLE,DIMENSION(:) :: fieldok
[1539]	808
[2311]	809	IF (size(field)/=klon) CALL abort_physic('iophy::histwrite2d','Field first DIMENSION not equal to klon',1)
[776]	810
	811	CALL Gather_omp(field,buffer_omp)
[766]	812	!$OMP MASTER
[1331]	813	CALL grid1Dto2D_mpi(buffer_omp,Field2d)
[1539]	814	if(.NOT.lpoint) THEN
[2344]	815	ALLOCATE(index2d(nbp_lon*jj_nb))
	816	ALLOCATE(fieldok(nbp_lon*jj_nb))
[1897]	817	IF (prt_level >= 10) write(lunout,*)'Sending ',name,' to IOIPSL'
[2344]	818	CALL histwrite(nid,name,itau,Field2d,nbp_lon*jj_nb,index2d)
[1897]	819	IF (prt_level >= 10) write(lunout,*)'Finished sending ',name,' to IOIPSL'
[2854]	820	ELSE
[1539]	821	ALLOCATE(fieldok(npstn))
	822	ALLOCATE(index2d(npstn))
	823
[2854]	824	IF (is_sequential) THEN
[1539]	825	! klon_mpi_begin=1
	826	! klon_mpi_end=klon
	827	DO ip=1, npstn
	828	fieldok(ip)=buffer_omp(nptabij(ip))
	829	ENDDO
[2854]	830	ELSE
[1539]	831	DO ip=1, npstn
	832	! print*,'histwrite2d is_sequential npstn ip name nptabij',npstn,ip,name,nptabij(ip)
	833	IF(nptabij(ip).GE.klon_mpi_begin.AND. &
	834	nptabij(ip).LE.klon_mpi_end) THEN
	835	fieldok(ip)=buffer_omp(nptabij(ip)-klon_mpi_begin+1)
	836	ENDIF
	837	ENDDO
[2854]	838	ENDIF
[1897]	839	IF (prt_level >= 10) write(lunout,*)'Sending ',name,' to IOIPSL'
[1539]	840	CALL histwrite(nid,name,itau,fieldok,npstn,index2d)
[1897]	841	IF (prt_level >= 10) write(lunout,*)'Finished sending ',name,' to IOIPSL'
[1539]	842	!
[2854]	843	ENDIF
	844	DEALLOCATE(index2d)
	845	DEALLOCATE(fieldok)
[1791]	846	!$OMP END MASTER
[1331]	847
[1791]	848
[2854]	849	END SUBROUTINE histwrite2d_phy_old
[1791]	850
[1797]	851	SUBROUTINE histwrite3d_phy_old(nid,lpoint,name,itau,field)
[2854]	852	USE dimphy, ONLY: klon
	853	USE mod_phys_lmdz_para, ONLY: Gather_omp, grid1Dto2D_mpi, &
[1897]	854	is_sequential, klon_mpi_begin, klon_mpi_end, &
	855	jj_nb, klon_mpi
[2344]	856	USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat
[2854]	857	USE ioipsl, ONLY: histwrite
[2311]	858	USE print_control_mod, ONLY: prt_level,lunout
[1797]	859	IMPLICIT NONE
[629]	860
[2854]	861	INTEGER,INTENT(IN) :: nid
	862	LOGICAL,INTENT(IN) :: lpoint
	863	CHARACTER(), INTENT(IN) :: name
	864	INTEGER, INTENT(IN) :: itau
[1797]	865	REAL,DIMENSION(:,:),INTENT(IN) :: field ! --> field(klon,:)
	866	REAL,DIMENSION(klon_mpi,size(field,2)) :: buffer_omp
[2344]	867	REAL :: Field3d(nbp_lon,jj_nb,size(field,2))
[1539]	868	INTEGER :: ip, n, nlev
[1797]	869	INTEGER, ALLOCATABLE, DIMENSION(:) :: index3d
	870	REAL,allocatable, DIMENSION(:,:) :: fieldok
[1539]	871
[1791]	872
[2311]	873	IF (size(field,1)/=klon) CALL abort_physic('iophy::histwrite3d','Field first DIMENSION not equal to klon',1)
[1331]	874	nlev=size(field,2)
[1539]	875
[776]	876	CALL Gather_omp(field,buffer_omp)
[766]	877	!$OMP MASTER
[1331]	878	CALL grid1Dto2D_mpi(buffer_omp,field3d)
[2854]	879	IF (.NOT.lpoint) THEN
[2344]	880	ALLOCATE(index3d(nbp_lonjj_nbnlev))
	881	ALLOCATE(fieldok(nbp_lon*jj_nb,nlev))
[1897]	882	IF (prt_level >= 10) write(lunout,*)'Sending ',name,' to IOIPSL'
[2344]	883	CALL histwrite(nid,name,itau,Field3d,nbp_lonjj_nbnlev,index3d)
[1897]	884	IF (prt_level >= 10) write(lunout,*)'Finished sending ',name,' to IOIPSL'
[2854]	885	ELSE
[1539]	886	nlev=size(field,2)
	887	ALLOCATE(index3d(npstn*nlev))
	888	ALLOCATE(fieldok(npstn,nlev))
	889
[2854]	890	IF (is_sequential) THEN
[1539]	891	! klon_mpi_begin=1
	892	! klon_mpi_end=klon
	893	DO n=1, nlev
	894	DO ip=1, npstn
	895	fieldok(ip,n)=buffer_omp(nptabij(ip),n)
	896	ENDDO
	897	ENDDO
[2854]	898	ELSE
[1539]	899	DO n=1, nlev
	900	DO ip=1, npstn
	901	IF(nptabij(ip).GE.klon_mpi_begin.AND. &
	902	nptabij(ip).LE.klon_mpi_end) THEN
	903	fieldok(ip,n)=buffer_omp(nptabij(ip)-klon_mpi_begin+1,n)
	904	ENDIF
	905	ENDDO
	906	ENDDO
[2854]	907	ENDIF
[1897]	908	IF (prt_level >= 10) write(lunout,*)'Sending ',name,' to IOIPSL'
[1539]	909	CALL histwrite(nid,name,itau,fieldok,npstn*nlev,index3d)
[1897]	910	IF (prt_level >= 10) write(lunout,*)'Finished sending ',name,' to IOIPSL'
[2854]	911	ENDIF
	912	DEALLOCATE(index3d)
	913	DEALLOCATE(fieldok)
[766]	914	!$OMP END MASTER
[1791]	915
[2854]	916	END SUBROUTINE histwrite3d_phy_old
[1791]	917
	918
[1807]	919
	920
[1791]	921	! ug NOUVELLE VERSION DES WRITE AVEC LA BOUCLE DO RENTREE
	922	SUBROUTINE histwrite2d_phy(var,field, STD_iff)
[3003]	923	USE dimphy, ONLY: klon, klev
[2854]	924	USE mod_phys_lmdz_para, ONLY: gather_omp, grid1dto2d_mpi, &
[1897]	925	jj_nb, klon_mpi, klon_mpi_begin, &
	926	klon_mpi_end, is_sequential
[2854]	927	USE ioipsl, ONLY: histwrite
	928	USE phys_output_var_mod, ONLY: ctrl_out, clef_files, lev_files, &
[1897]	929	nfiles, vars_defined, clef_stations, &
	930	nid_files
[2311]	931	USE print_control_mod, ONLY: prt_level,lunout
[2344]	932	USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat
[1791]	933	#ifdef CPP_XIOS
[2854]	934	USE xios, ONLY: xios_send_field
[1791]	935	#endif
	936
[1825]	937
[1791]	938	IMPLICIT NONE
[2114]	939	include 'clesphys.h'
[1791]	940
[1807]	941	TYPE(ctrl_out), INTENT(IN) :: var
	942	REAL, DIMENSION(:), INTENT(IN) :: field
	943	INTEGER, INTENT(IN), OPTIONAL :: STD_iff ! ug RUSTINE POUR LES STD LEVS.....
[1791]	944
[1807]	945	INTEGER :: iff, iff_beg, iff_end
[2001]	946	LOGICAL, SAVE :: firstx
	947	!$OMP THREADPRIVATE(firstx)
	948
[1797]	949	REAL,DIMENSION(klon_mpi) :: buffer_omp
	950	INTEGER, allocatable, DIMENSION(:) :: index2d
[2344]	951	REAL :: Field2d(nbp_lon,jj_nb)
[1791]	952
	953	INTEGER :: ip
	954	REAL, ALLOCATABLE, DIMENSION(:) :: fieldok
	955
[2001]	956	IF (prt_level >= 10) THEN
	957	WRITE(lunout,*)'Begin histwrite2d_phy for ',trim(var%name)
	958	ENDIF
[1791]	959	! ug RUSTINE POUR LES STD LEVS.....
	960	IF (PRESENT(STD_iff)) THEN
	961	iff_beg = STD_iff
	962	iff_end = STD_iff
	963	ELSE
	964	iff_beg = 1
	965	iff_end = nfiles
[2854]	966	ENDIF
[1791]	967
[1807]	968	! On regarde si on est dans la phase de définition ou d'écriture:
[2854]	969	IF (.NOT.vars_defined) THEN
[1821]	970	!$OMP MASTER
[1807]	971	!Si phase de définition.... on définit
[2114]	972	IF (.not. ok_all_xml) THEN
[2854]	973	IF (prt_level >= 10) THEN
	974	WRITE (lunout,*)"histwrite2d_phy: .not.vars_defined ; time to define ", trim(var%name)
	975	ENDIF
[1807]	976	DO iff=iff_beg, iff_end
	977	IF (clef_files(iff)) THEN
	978	CALL histdef2d(iff, var)
	979	ENDIF
	980	ENDDO
[2114]	981	ENDIF
[1821]	982	!$OMP END MASTER
[1807]	983	ELSE
	984
	985	!Et sinon on.... écrit
[3003]	986	IF (SIZE(field)/=klon .AND. SIZE(field)/=klev) CALL abort_physic('iophy::histwrite2d_phy','Field first DIMENSION not equal to klon/klev',1)
[2854]	987	IF (prt_level >= 10) THEn
	988	WRITE (lunout,*)"histwrite2d_phy: .not.vars_defined ; time to gather and write ", trim(var%name)
	989	ENDIF
[1897]	990
[3003]	991
	992	IF (SIZE(field) == klon) then
	993	CALL Gather_omp(field,buffer_omp)
	994	ELSE
	995	buffer_omp(:)=0.
	996	ENDIF
[1791]	997	!$OMP MASTER
	998	CALL grid1Dto2D_mpi(buffer_omp,Field2d)
[1897]	999
[1791]	1000	! La boucle sur les fichiers:
[2001]	1001	firstx=.true.
[2114]	1002
	1003	IF (ok_all_xml) THEN
	1004	#ifdef CPP_XIOS
[2854]	1005	IF (prt_level >= 10) THEN
	1006	write(lunout,*)'Dans iophy histwrite2D,var%name ', trim(var%name)
	1007	ENDIF
[3003]	1008	IF (SIZE(field) == klon) then
	1009	CALL xios_send_field(var%name, Field2d)
	1010	ELSE
	1011	CALL xios_send_field(var%name, field)
	1012	ENDIF
[2854]	1013	IF (prt_level >= 10) THEN
	1014	WRITE (lunout,*)'Dans iophy histwrite2D,var%name apres xios_send ', trim(var%name)
	1015	ENDIF
[2114]	1016	#else
[2311]	1017	CALL abort_physic ('iophy','cannot have ok_all_xml = .T. without CPP_XIOS defined' ,1)
[2114]	1018	#endif
	1019	ELSE
	1020	DO iff=iff_beg, iff_end
[1791]	1021	IF (var%flag(iff) <= lev_files(iff) .AND. clef_files(iff)) THEN
[2001]	1022
	1023	#ifdef CPP_XIOS
	1024	IF (firstx) THEN
[2854]	1025	IF (prt_level >= 10) THEN
	1026	WRITE (lunout,*)'Dans iophy histwrite2D,iff,var%name ', iff,trim(var%name)
	1027	WRITE (lunout,*)"histwrite2d_phy:.NOT.clef_stations(iff)and iff==iff_beg, call xios_send_field"
	1028	ENDIF
[3003]	1029	IF (SIZE(field) == klon) then
	1030	CALL xios_send_field(var%name, Field2d)
	1031	ELSE
	1032	CALL xios_send_field(var%name, field)
	1033	ENDIF
[2001]	1034	firstx=.false.
	1035	ENDIF
	1036	#endif
	1037
[2854]	1038	IF (.NOT.clef_stations(iff)) THEN
[2344]	1039	ALLOCATE(index2d(nbp_lon*jj_nb))
	1040	ALLOCATE(fieldok(nbp_lon*jj_nb))
[2097]	1041	#ifndef CPP_IOIPSL_NO_OUTPUT
[2344]	1042	CALL histwrite(nid_files(iff),var%name,itau_iophy,Field2d,nbp_lon*jj_nb,index2d)
[1852]	1043	#endif
[2001]	1044	!#ifdef CPP_XIOS
	1045	! IF (iff == iff_beg) THEN
	1046	! if (prt_level >= 10) then
[2002]	1047	! write(lunout,*)"histwrite2d_phy: .NOT.clef_stations(iff) and iff==iff_beg, call xios_send_field"
[2001]	1048	! endif
[2002]	1049	! CALL xios_send_field(var%name, Field2d)
[2001]	1050	! ENDIF
	1051	!#endif
[1791]	1052	ELSE
	1053	ALLOCATE(fieldok(npstn))
	1054	ALLOCATE(index2d(npstn))
	1055
	1056	IF (is_sequential) THEN
[1897]	1057	DO ip=1, npstn
	1058	fieldok(ip)=buffer_omp(nptabij(ip))
	1059	ENDDO
	1060	ELSE
[1791]	1061	DO ip=1, npstn
[1897]	1062	write(lunout,*)'histwrite2d_phy is_sequential npstn ip namenptabij',npstn,ip,var%name,nptabij(ip)
[1791]	1063	IF(nptabij(ip).GE.klon_mpi_begin.AND. &
	1064	nptabij(ip).LE.klon_mpi_end) THEN
	1065	fieldok(ip)=buffer_omp(nptabij(ip)-klon_mpi_begin+1)
	1066	ENDIF
	1067	ENDDO
[1897]	1068	ENDIF ! of IF (is_sequential)
[2097]	1069	#ifndef CPP_IOIPSL_NO_OUTPUT
[2854]	1070	IF (prt_level >= 10) THEn
[1897]	1071	write(lunout,*)"histwrite2d_phy: clef_stations(iff) and iff==iff_beg, call wxios_write_2D"
[2854]	1072	ENDIF
[1791]	1073	CALL histwrite(nid_files(iff),var%name,itau_iophy,fieldok,npstn,index2d)
[1852]	1074	#endif
[1897]	1075	ENDIF ! of IF(.NOT.clef_stations(iff))
[1791]	1076
[2854]	1077	DEALLOCATE(index2d)
	1078	DEALLOCATE(fieldok)
[1791]	1079	ENDIF !levfiles
[2114]	1080	ENDDO ! of DO iff=iff_beg, iff_end
	1081	ENDIF
[1791]	1082	!$OMP END MASTER
[1807]	1083	ENDIF ! vars_defined
[1897]	1084	IF (prt_level >= 10) WRITE(lunout,*)'End histwrite2d_phy ',trim(var%name)
[1791]	1085	END SUBROUTINE histwrite2d_phy
	1086
	1087
	1088	! ug NOUVELLE VERSION DES WRITE AVEC LA BOUCLE DO RENTREE
[1807]	1089	SUBROUTINE histwrite3d_phy(var, field, STD_iff)
[2854]	1090	USE dimphy, ONLY: klon, klev
	1091	USE mod_phys_lmdz_para, ONLY: gather_omp, grid1dto2d_mpi, &
[1897]	1092	jj_nb, klon_mpi, klon_mpi_begin, &
	1093	klon_mpi_end, is_sequential
[2854]	1094	USE ioipsl, ONLY: histwrite
	1095	USE phys_output_var_mod, ONLY: ctrl_out, clef_files, lev_files, &
[1897]	1096	nfiles, vars_defined, clef_stations, &
	1097	nid_files
[2344]	1098	USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat
[1791]	1099	#ifdef CPP_XIOS
[2854]	1100	USE xios, ONLY: xios_send_field
[1791]	1101	#endif
[2311]	1102	USE print_control_mod, ONLY: prt_level,lunout
[1791]	1103
	1104	IMPLICIT NONE
[2114]	1105	include 'clesphys.h'
[1791]	1106
[1807]	1107	TYPE(ctrl_out), INTENT(IN) :: var
	1108	REAL, DIMENSION(:,:), INTENT(IN) :: field ! --> field(klon,:)
	1109	INTEGER, INTENT(IN), OPTIONAL :: STD_iff ! ug RUSTINE POUR LES STD LEVS.....
	1110
[1828]	1111	INTEGER :: iff, iff_beg, iff_end
[2001]	1112	LOGICAL, SAVE :: firstx
	1113	!$OMP THREADPRIVATE(firstx)
[1791]	1114	REAL,DIMENSION(klon_mpi,SIZE(field,2)) :: buffer_omp
[2344]	1115	REAL :: Field3d(nbp_lon,jj_nb,SIZE(field,2))
[2001]	1116	INTEGER :: ip, n, nlev, nlevx
[1791]	1117	INTEGER, ALLOCATABLE, DIMENSION(:) :: index3d
	1118	REAL,ALLOCATABLE, DIMENSION(:,:) :: fieldok
	1119
[1897]	1120	IF (prt_level >= 10) write(lunout,*)'Begin histrwrite3d ',var%name
[1791]	1121
[1828]	1122	! ug RUSTINE POUR LES STD LEVS.....
	1123	IF (PRESENT(STD_iff)) THEN
	1124	iff_beg = STD_iff
	1125	iff_end = STD_iff
	1126	ELSE
	1127	iff_beg = 1
	1128	iff_end = nfiles
[2854]	1129	ENDIF
[1828]	1130
[1807]	1131	! On regarde si on est dans la phase de définition ou d'écriture:
	1132	IF(.NOT.vars_defined) THEN
	1133	!Si phase de définition.... on définit
[1821]	1134	!$OMP MASTER
[1828]	1135	DO iff=iff_beg, iff_end
[1807]	1136	IF (clef_files(iff)) THEN
	1137	CALL histdef3d(iff, var)
	1138	ENDIF
	1139	ENDDO
[1821]	1140	!$OMP END MASTER
[1807]	1141	ELSE
	1142	!Et sinon on.... écrit
[3003]	1143
	1144	IF (SIZE(field,1)/=klon .AND. SIZE(field,1)/=klev) CALL abort_physic('iophy::histwrite3d_xios','Field first DIMENSION not equal to klon/klev',1)
	1145
[1807]	1146	nlev=SIZE(field,2)
[2854]	1147	IF (nlev.EQ.klev+1) THEN
[2001]	1148	nlevx=klev
[2854]	1149	ELSE
[2001]	1150	nlevx=nlev
[2854]	1151	ENDIF
[1791]	1152
[3003]	1153	IF (SIZE(field,1) == klon) then
	1154	CALL Gather_omp(field,buffer_omp)
	1155	ELSE
	1156	buffer_omp(:,:)=0.
	1157	ENDIF
[1791]	1158	!$OMP MASTER
	1159	CALL grid1Dto2D_mpi(buffer_omp,field3d)
	1160
	1161
	1162	! BOUCLE SUR LES FICHIERS
[2001]	1163	firstx=.true.
[2114]	1164
	1165	IF (ok_all_xml) THEN
	1166	#ifdef CPP_XIOS
[2854]	1167	IF (prt_level >= 10) THEN
[2114]	1168	write(lunout,*)'Dans iophy histwrite3D,var%name ',&
	1169	trim(var%name)
[2854]	1170	ENDIF
[3003]	1171	IF (SIZE(field,1) == klon) then
	1172	CALL xios_send_field(var%name, Field3d(:,:,1:nlevx))
	1173	ELSE
	1174	CALL xios_send_field(var%name, field)
	1175	ENDIF
[2114]	1176	#else
[2311]	1177	CALL abort_physic ('iophy','cannot have ok_all_xml = .T. without CPP_XIOS defined' ,1)
[2114]	1178	#endif
	1179	ELSE
	1180
	1181
[1828]	1182	DO iff=iff_beg, iff_end
[1791]	1183	IF (var%flag(iff) <= lev_files(iff) .AND. clef_files(iff)) THEN
[2001]	1184	#ifdef CPP_XIOS
	1185	IF (firstx) THEN
[2854]	1186	IF (prt_level >= 10) THEn
	1187	WRITE (lunout,*)'Dans iophy, histwrite3D iff nlev klev firstx', &
[2001]	1188	iff,nlev,klev, firstx
[2854]	1189	WRITE (lunout,*)'histwrite3d_phy: call xios_send_field for ', &
[2001]	1190	trim(var%name), ' with iim jjm nlevx = ', &
[2344]	1191	nbp_lon,jj_nb,nlevx
[2854]	1192	ENDIF
[3003]	1193	IF (SIZE(field,1) == klon) then
	1194	CALL xios_send_field(var%name, Field3d(:,:,1:nlevx))
	1195	ELSE
	1196	CALL xios_send_field(var%name, field)
	1197	ENDIF
	1198	firstx=.false.
[2001]	1199	ENDIF
	1200	#endif
[1791]	1201	IF (.NOT.clef_stations(iff)) THEN
[2344]	1202	ALLOCATE(index3d(nbp_lonjj_nbnlev))
	1203	ALLOCATE(fieldok(nbp_lon*jj_nb,nlev))
[1852]	1204
[2097]	1205	#ifndef CPP_IOIPSL_NO_OUTPUT
[2344]	1206	CALL histwrite(nid_files(iff),var%name,itau_iophy,Field3d,nbp_lonjj_nbnlev,index3d)
[1852]	1207	#endif
[1825]	1208
[2001]	1209	!#ifdef CPP_XIOS
	1210	! IF (iff == 1) THEN
[2002]	1211	! CALL xios_send_field(var%name, Field3d(:,:,1:klev))
[2001]	1212	! ENDIF
	1213	!#endif
	1214	!
[1791]	1215	ELSE
	1216	nlev=size(field,2)
	1217	ALLOCATE(index3d(npstn*nlev))
	1218	ALLOCATE(fieldok(npstn,nlev))
	1219
	1220	IF (is_sequential) THEN
	1221	DO n=1, nlev
	1222	DO ip=1, npstn
	1223	fieldok(ip,n)=buffer_omp(nptabij(ip),n)
	1224	ENDDO
	1225	ENDDO
	1226	ELSE
	1227	DO n=1, nlev
	1228	DO ip=1, npstn
	1229	IF(nptabij(ip).GE.klon_mpi_begin.AND. &
	1230	nptabij(ip).LE.klon_mpi_end) THEN
	1231	fieldok(ip,n)=buffer_omp(nptabij(ip)-klon_mpi_begin+1,n)
	1232	ENDIF
	1233	ENDDO
	1234	ENDDO
	1235	ENDIF
[2097]	1236	#ifndef CPP_IOIPSL_NO_OUTPUT
[1791]	1237	CALL histwrite(nid_files(iff),var%name,itau_iophy,fieldok,npstn*nlev,index3d)
[1852]	1238	#endif
[1791]	1239	ENDIF
[2854]	1240	DEALLOCATE(index3d)
	1241	DEALLOCATE(fieldok)
[1791]	1242	ENDIF
	1243	ENDDO
[2114]	1244	ENDIF
[1791]	1245	!$OMP END MASTER
[1807]	1246	ENDIF ! vars_defined
[1897]	1247	IF (prt_level >= 10) write(lunout,*)'End histrwrite3d ',var%name
[1791]	1248	END SUBROUTINE histwrite3d_phy
	1249
[1852]	1250
	1251	! VERSION DES HISTWRITE DEDIEES AU TOUT-XIOS-XML DEJA UTILISEE DANS PHYDEV
	1252	#ifdef CPP_XIOS
	1253	SUBROUTINE histwrite2d_xios(field_name,field)
[3003]	1254	USE dimphy, ONLY: klon, klev
[2854]	1255	USE mod_phys_lmdz_para, ONLY: gather_omp, grid1Dto2D_mpi, &
[1897]	1256	is_sequential, klon_mpi_begin, klon_mpi_end, &
	1257	jj_nb, klon_mpi
[2344]	1258	USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat
[2854]	1259	USE xios, ONLY: xios_send_field
[2311]	1260	USE print_control_mod, ONLY: prt_level,lunout
[1852]	1261
	1262	IMPLICIT NONE
	1263
	1264	CHARACTER(LEN=*), INTENT(IN) :: field_name
	1265	REAL, DIMENSION(:), INTENT(IN) :: field
	1266
	1267	REAL,DIMENSION(klon_mpi) :: buffer_omp
	1268	INTEGER, allocatable, DIMENSION(:) :: index2d
[2344]	1269	REAL :: Field2d(nbp_lon,jj_nb)
[1852]	1270
	1271	INTEGER :: ip
	1272	REAL, ALLOCATABLE, DIMENSION(:) :: fieldok
	1273
[1897]	1274	IF (prt_level >= 10) WRITE(lunout,*)'Begin histrwrite2d_xios ',field_name
[1852]	1275
	1276	!Et sinon on.... écrit
[3003]	1277	IF (SIZE(field)/=klon .AND. SIZE(field)/=klev) CALL abort_physic('iophy::histwrite2d_xios','Field first DIMENSION not equal to klon/klev',1)
[1852]	1278
[3003]	1279	IF (SIZE(field) == klev) then
[1852]	1280	!$OMP MASTER
[3003]	1281	CALL xios_send_field(field_name,field)
	1282	!$OMP END MASTER
	1283	ELSE
	1284	CALL Gather_omp(field,buffer_omp)
	1285	!$OMP MASTER
	1286	CALL grid1Dto2D_mpi(buffer_omp,Field2d)
[1852]	1287
	1288	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	1289	!ATTENTION, STATIONS PAS GEREES !
	1290	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	1291	!IF(.NOT.clef_stations(iff)) THEN
[3003]	1292	IF (.TRUE.) THEN
	1293	ALLOCATE(index2d(nbp_lon*jj_nb))
	1294	ALLOCATE(fieldok(nbp_lon*jj_nb))
	1295
	1296
	1297	CALL xios_send_field(field_name, Field2d)
	1298
	1299	ELSE
	1300	ALLOCATE(fieldok(npstn))
	1301	ALLOCATE(index2d(npstn))
	1302
	1303	IF (is_sequential) THEN
	1304	DO ip=1, npstn
	1305	fieldok(ip)=buffer_omp(nptabij(ip))
	1306	ENDDO
	1307	ELSE
	1308	DO ip=1, npstn
	1309	PRINT*,'histwrite2d_xios is_sequential npstn ip namenptabij',npstn,ip,field_name,nptabij(ip)
	1310	IF(nptabij(ip).GE.klon_mpi_begin.AND. &
	1311	nptabij(ip).LE.klon_mpi_end) THEN
	1312	fieldok(ip)=buffer_omp(nptabij(ip)-klon_mpi_begin+1)
	1313	ENDIF
	1314	ENDDO
	1315	ENDIF
	1316
[1852]	1317	ENDIF
	1318
[3003]	1319	DEALLOCATE(index2d)
	1320	DEALLOCATE(fieldok)
[1852]	1321	!$OMP END MASTER
[3003]	1322	ENDIF
[1852]	1323
[1897]	1324	IF (prt_level >= 10) WRITE(lunout,*)'End histrwrite2d_xios ',field_name
[1852]	1325	END SUBROUTINE histwrite2d_xios
	1326
	1327
	1328	! ug NOUVELLE VERSION DES WRITE AVEC LA BOUCLE DO RENTREE
	1329	SUBROUTINE histwrite3d_xios(field_name, field)
[2854]	1330	USE dimphy, ONLY: klon, klev
	1331	USE mod_phys_lmdz_para, ONLY: gather_omp, grid1Dto2D_mpi, &
[1897]	1332	is_sequential, klon_mpi_begin, klon_mpi_end, &
	1333	jj_nb, klon_mpi
[2854]	1334	USE xios, ONLY: xios_send_field
[2344]	1335	USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat
[2311]	1336	USE print_control_mod, ONLY: prt_level,lunout
[1852]	1337
	1338	IMPLICIT NONE
	1339
	1340	CHARACTER(LEN=*), INTENT(IN) :: field_name
	1341	REAL, DIMENSION(:,:), INTENT(IN) :: field ! --> field(klon,:)
	1342
	1343	REAL,DIMENSION(klon_mpi,SIZE(field,2)) :: buffer_omp
[2344]	1344	REAL :: Field3d(nbp_lon,jj_nb,SIZE(field,2))
[1852]	1345	INTEGER :: ip, n, nlev
	1346	INTEGER, ALLOCATABLE, DIMENSION(:) :: index3d
	1347	REAL,ALLOCATABLE, DIMENSION(:,:) :: fieldok
	1348
[1897]	1349	IF (prt_level >= 10) write(lunout,*)'Begin histrwrite3d_xios ',field_name
[1852]	1350
	1351	!Et on.... écrit
[3003]	1352	IF (SIZE(field,1)/=klon .AND. SIZE(field,1)/=klev) CALL abort_physic('iophy::histwrite3d_xios','Field first DIMENSION not equal to klon/klev',1)
	1353
	1354	IF (SIZE(field,1) == klev) then
	1355	!$OMP MASTER
	1356	CALL xios_send_field(field_name,field)
	1357	!$OMP END MASTER
	1358	ELSE
	1359	nlev=SIZE(field,2)
[1852]	1360
	1361
[3003]	1362	CALL Gather_omp(field,buffer_omp)
[1852]	1363	!$OMP MASTER
[3003]	1364	CALL grid1Dto2D_mpi(buffer_omp,field3d)
[1852]	1365
	1366	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	1367	!ATTENTION, STATIONS PAS GEREES !
	1368	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	1369	!IF (.NOT.clef_stations(iff)) THEN
[3003]	1370	IF(.TRUE.)THEN
	1371	ALLOCATE(index3d(nbp_lonjj_nbnlev))
	1372	ALLOCATE(fieldok(nbp_lon*jj_nb,nlev))
	1373	CALL xios_send_field(field_name, Field3d(:,:,1:nlev))
	1374
	1375	ELSE
	1376	nlev=size(field,2)
	1377	ALLOCATE(index3d(npstn*nlev))
	1378	ALLOCATE(fieldok(npstn,nlev))
	1379
	1380	IF (is_sequential) THEN
	1381	DO n=1, nlev
	1382	DO ip=1, npstn
	1383	fieldok(ip,n)=buffer_omp(nptabij(ip),n)
	1384	ENDDO
[1852]	1385	ENDDO
[3003]	1386	ELSE
	1387	DO n=1, nlev
	1388	DO ip=1, npstn
	1389	IF(nptabij(ip).GE.klon_mpi_begin.AND. &
	1390	nptabij(ip).LE.klon_mpi_end) THEN
	1391	fieldok(ip,n)=buffer_omp(nptabij(ip)-klon_mpi_begin+1,n)
	1392	ENDIF
	1393	ENDDO
[1852]	1394	ENDDO
[3003]	1395	ENDIF
	1396	ENDIF
	1397	DEALLOCATE(index3d)
	1398	DEALLOCATE(fieldok)
[1852]	1399	!$OMP END MASTER
[3003]	1400	ENDIF
[1852]	1401
[1897]	1402	IF (prt_level >= 10) write(lunout,*)'End histrwrite3d_xios ',field_name
[1852]	1403	END SUBROUTINE histwrite3d_xios
[2645]	1404
[2660]	1405	#ifdef CPP_XIOS
[2645]	1406	SUBROUTINE histwrite0d_xios(field_name, field)
[2854]	1407	USE xios, ONLY: xios_send_field
[2645]	1408	IMPLICIT NONE
	1409
	1410	CHARACTER(LEN=*), INTENT(IN) :: field_name
	1411	REAL, INTENT(IN) :: field ! --> scalar
	1412
	1413	!$OMP MASTER
[2660]	1414	CALL xios_send_field(field_name, field)
[2645]	1415	!$OMP END MASTER
	1416
	1417	END SUBROUTINE histwrite0d_xios
[1852]	1418	#endif
[2660]	1419
	1420	#endif
[629]	1421	end module iophy

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

Download in other formats:

Original Format