Context Navigation

iophy.F90 @ 2337

Last change on this file since 2337 was 2160, checked in by Laurent Fairhead, 10 years ago
Merged trunk changes -r2070:2158 into testing branch. Compilation problems introduced by revision r2155 have been corrected by hand
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: 42.9 KB

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

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

Download in other formats:

Original Format