Context Navigation

iophy.F90 @ 2018

Last change on this file since 2018 was 2002, checked in by Ehouarn Millour, 11 years ago
Further cleanup concerning XIOS (mainly about axes being defined as axes and not as groups of axes). EM
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: 41.4 KB

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

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

Download in other formats:

Original Format