Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Normal
Revision Log

iophy.F90 @ 3663

Last change on this file since 3663 was 3331, checked in by acozic, 6 years ago
Add modification for isotopes
Property svn:executable set to ``*
File size: 44.0 KB

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

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

Download in other formats:

Original Format