Context Navigation

iophy_F90_modifje20140505

Last change on this file was 2175, checked in by jescribano, 10 years ago
SPLA code included for first time
File size: 41.4 KB

Rev	Line
[2175]	1	!
	2	! $Id: iophy.F90 2002 2014-04-04 12:39:54Z emillour $
	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
	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
	54	IMPLICIT NONE
	55	INCLUDE 'dimensions.h'
	56	include 'iniprint.h'
	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
	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
	71	INTEGER :: data_ibegin, data_iend
	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
	79	ALLOCATE(io_lat(jjm+1-1/(iim*jjm)))
	80	io_lat(1)=rlat_glo(1)
	81	io_lat(jjm+1-1/(iim*jjm))=rlat_glo(klon_glo)
	82	IF ((iim*jjm) > 1) then
	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))
	89	io_lon(:)=rlon_glo(2-1/(iimjjm):iim+1-1/(iimjjm))
	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.
	104
	105	ddid=(/ 1,2 /)
	106	dsg=(/ iim, jjm+1-1/(iim*jjm) /)
	107	dsl=(/ iim, jj_nb /)
	108	dpf=(/ 1,jj_begin /)
	109	dpl=(/ iim, jj_end /)
	110	dhs=(/ ii_begin-1,0 /)
	111	IF (mpi_rank==mpi_size-1) THEN
	112	dhe=(/0,0/)
	113	ELSE
	114	dhe=(/ iim-ii_end,0 /)
	115	ENDIF
	116
	117	#ifndef CPP_NO_IOIPSL
	118	CALL flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
	119	'APPLE',phys_domain_id)
	120	#endif
	121	#ifdef CPP_XIOS
	122	! Set values for the mask:
	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
	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
	142
	143	! Initialize the XIOS domain coreesponding to this process:
	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, &
	147	io_lat, io_lon,is_south_pole,mpi_rank)
	148	#endif
	149	!$OMP END MASTER
	150
	151	END SUBROUTINE init_iophy_new
	152
	153	SUBROUTINE init_iophy(lat,lon)
	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
	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
	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
	171	allocate(io_lat(jjm+1-1/(iim*jjm)))
	172	io_lat(:)=lat(:)
	173	allocate(io_lon(iim))
	174	io_lon(:)=lon(:)
	175
	176	ddid=(/ 1,2 /)
	177	dsg=(/ iim, jjm+1-1/(iim*jjm) /)
	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
	183	dhe=(/0,0/)
	184	else
	185	dhe=(/ iim-ii_end,0 /)
	186	endif
	187
	188	#ifndef CPP_NO_IOIPSL
	189	call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
	190	'APPLE',phys_domain_id)
	191	#endif
	192	!$OMP END MASTER
	193
	194	end SUBROUTINE init_iophy
	195
	196	SUBROUTINE histbeg_phyxios(name,itau0,zjulian,dtime,ffreq,lev,nhori,nid_day)
	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
	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
	233
	234	END SUBROUTINE histbeg_phyxios
	235
	236	SUBROUTINE histbeg_phy(name,itau0,zjulian,dtime,nhori,nid_day)
	237
	238	USE mod_phys_lmdz_para, only: jj_begin, jj_end, jj_nb, is_sequential
	239	use ioipsl, only: histbeg
	240
	241	IMPLICIT NONE
	242	include 'dimensions.h'
	243
	244	character(), INTENT(IN) :: name
	245	integer, INTENT(IN) :: itau0
	246	REAL,INTENT(IN) :: zjulian
	247	REAL,INTENT(IN) :: dtime
	248	integer,intent(out) :: nhori
	249	integer,intent(out) :: nid_day
	250
	251	!$OMP MASTER
	252	#ifndef CPP_NO_IOIPSL
	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)
	256	else
	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)
	259	endif
	260	#endif
	261	!$OMP END MASTER
	262
	263	END SUBROUTINE histbeg_phy
	264
	265
	266	SUBROUTINE histbeg_phy_points(rlon,rlat,pim,tabij,ipt,jpt, &
	267	plon,plat,plon_bounds,plat_bounds, &
	268	nname,itau0,zjulian,dtime,nnhori,nnid_day)
	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
	276	IMPLICIT NONE
	277	include 'dimensions.h'
	278
	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
	285	integer, intent(out) :: nnhori
	286	character(len=20), INTENT(IN) :: nname
	287	INTEGER, intent(out) :: nnid_day
	288	integer :: i
	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
	295
	296	INTEGER, SAVE :: tabprocbeg, tabprocend
	297	!$OMP THREADPRIVATE(tabprocbeg, tabprocend)
	298	INTEGER :: ip
	299	INTEGER, PARAMETER :: nip=1
	300	INTEGER :: npproc
	301	REAL, allocatable, DIMENSION(:) :: npplat, npplon
	302	REAL, allocatable, DIMENSION(:,:) :: npplat_bounds, npplon_bounds
	303	INTEGER, PARAMETER :: jjmp1=jjm+1-1/jjm
	304	REAL, DIMENSION(iim,jjmp1) :: zx_lon, zx_lat
	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)
	351	if ((iim*jjm).gt.1) then
	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
	391
	392	#ifndef CPP_NO_IOIPSL
	393	call histbeg(nname,pim,plon,plon_bounds, &
	394	plat,plat_bounds, &
	395	itau0, zjulian, dtime, nnhori, nnid_day)
	396	#endif
	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
	433	#ifndef CPP_NO_IOIPSL
	434	call histbeg(nname,npstn,npplon,npplon_bounds, &
	435	npplat,npplat_bounds, &
	436	itau0,zjulian,dtime,nnhori,nnid_day,phys_domain_id)
	437	#endif
	438	endif
	439	!$OMP END MASTER
	440
	441	end SUBROUTINE histbeg_phy_points
	442
	443
	444	SUBROUTINE histdef2d_old (iff,lpoint,flag_var,nomvar,titrevar,unitvar)
	445
	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
	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
	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
	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
	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
	565	IMPLICIT NONE
	566
	567	INCLUDE "dimensions.h"
	568	INCLUDE "temps.h"
	569	INCLUDE "clesphys.h"
	570	INCLUDE "iniprint.h"
	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
	603
	604	#ifdef CPP_XIOS
	605	IF ( var%flag(iff)<=lev_files(iff) ) THEN
	606	CALL wxios_add_field_to_file(var%name, 2, iff, phys_out_filenames(iff), &
	607	var%description, var%unit, var%flag(iff), typeecrit)
	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
	613	#endif
	614	#ifndef CPP_NO_IOIPSL
	615
	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
	627	#endif
	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
	637
	638	SUBROUTINE histdef3d (iff,var)
	639
	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
	650	IMPLICIT NONE
	651
	652	INCLUDE "dimensions.h"
	653	INCLUDE "temps.h"
	654	INCLUDE "clesphys.h"
	655	INCLUDE "iniprint.h"
	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
	688
	689	#ifdef CPP_XIOS
	690	IF ( var%flag(iff)<=lev_files(iff) ) THEN
	691	CALL wxios_add_field_to_file(var%name, 3, iff, phys_out_filenames(iff), &
	692	var%description, var%unit, var%flag(iff), typeecrit)
	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
	698	#endif
	699	#ifndef CPP_NO_IOIPSL
	700
	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
	714	#endif
	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
	721	use ioipsl, only: getin
	722	use phys_output_var_mod, only: nfiles
	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
	738
	739	SUBROUTINE histwrite2d_phy_old(nid,lpoint,name,itau,field)
	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
	745	IMPLICIT NONE
	746	include 'dimensions.h'
	747	include 'iniprint.h'
	748
	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
	756	REAL :: Field2d(iim,jj_nb)
	757
	758	integer :: ip
	759	REAL,allocatable,DIMENSION(:) :: fieldok
	760
	761
	762	IF (size(field)/=klon) CALL abort_gcm('iophy::histwrite2d','Field first DIMENSION not equal to klon',1)
	763
	764	CALL Gather_omp(field,buffer_omp)
	765	!$OMP MASTER
	766	CALL grid1Dto2D_mpi(buffer_omp,Field2d)
	767	if(.NOT.lpoint) THEN
	768	ALLOCATE(index2d(iim*jj_nb))
	769	ALLOCATE(fieldok(iim*jj_nb))
	770	IF (prt_level >= 10) write(lunout,*)'Sending ',name,' to IOIPSL'
	771	CALL histwrite(nid,name,itau,Field2d,iim*jj_nb,index2d)
	772	IF (prt_level >= 10) write(lunout,*)'Finished sending ',name,' to IOIPSL'
	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
	792	IF (prt_level >= 10) write(lunout,*)'Sending ',name,' to IOIPSL'
	793	CALL histwrite(nid,name,itau,fieldok,npstn,index2d)
	794	IF (prt_level >= 10) write(lunout,*)'Finished sending ',name,' to IOIPSL'
	795	!
	796	endif
	797	deallocate(index2d)
	798	deallocate(fieldok)
	799	!$OMP END MASTER
	800
	801
	802	end SUBROUTINE histwrite2d_phy_old
	803
	804	SUBROUTINE histwrite3d_phy_old(nid,lpoint,name,itau,field)
	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
	810	IMPLICIT NONE
	811	include 'dimensions.h'
	812	include 'iniprint.h'
	813
	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
	820	REAL :: Field3d(iim,jj_nb,size(field,2))
	821	INTEGER :: ip, n, nlev
	822	INTEGER, ALLOCATABLE, DIMENSION(:) :: index3d
	823	REAL,allocatable, DIMENSION(:,:) :: fieldok
	824
	825
	826	IF (size(field,1)/=klon) CALL abort_gcm('iophy::histwrite3d','Field first DIMENSION not equal to klon',1)
	827	nlev=size(field,2)
	828
	829	CALL Gather_omp(field,buffer_omp)
	830	!$OMP MASTER
	831	CALL grid1Dto2D_mpi(buffer_omp,field3d)
	832	if(.NOT.lpoint) THEN
	833	ALLOCATE(index3d(iimjj_nbnlev))
	834	ALLOCATE(fieldok(iim*jj_nb,nlev))
	835	IF (prt_level >= 10) write(lunout,*)'Sending ',name,' to IOIPSL'
	836	CALL histwrite(nid,name,itau,Field3d,iimjj_nbnlev,index3d)
	837	IF (prt_level >= 10) write(lunout,*)'Finished sending ',name,' to IOIPSL'
	838	else
	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
	861	IF (prt_level >= 10) write(lunout,*)'Sending ',name,' to IOIPSL'
	862	CALL histwrite(nid,name,itau,fieldok,npstn*nlev,index3d)
	863	IF (prt_level >= 10) write(lunout,*)'Finished sending ',name,' to IOIPSL'
	864	endif
	865	deallocate(index3d)
	866	deallocate(fieldok)
	867	!$OMP END MASTER
	868
	869	end SUBROUTINE histwrite3d_phy_old
	870
	871
	872
	873
	874	! ug NOUVELLE VERSION DES WRITE AVEC LA BOUCLE DO RENTREE
	875	SUBROUTINE histwrite2d_phy(var,field, STD_iff)
	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
	884	#ifdef CPP_XIOS
	885	USE xios, only: xios_send_field
	886	#endif
	887
	888
	889	IMPLICIT NONE
	890	INCLUDE 'dimensions.h'
	891	INCLUDE 'iniprint.h'
	892
	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.....
	896
	897	INTEGER :: iff, iff_beg, iff_end
	898	LOGICAL, SAVE :: firstx
	899	!$OMP THREADPRIVATE(firstx)
	900
	901	REAL,DIMENSION(klon_mpi) :: buffer_omp
	902	INTEGER, allocatable, DIMENSION(:) :: index2d
	903	REAL :: Field2d(iim,jj_nb)
	904
	905	INTEGER :: ip
	906	REAL, ALLOCATABLE, DIMENSION(:) :: fieldok
	907
	908	IF (prt_level >= 10) THEN
	909	WRITE(lunout,*)'Begin histwrite2d_phy for ',trim(var%name)
	910	ENDIF
	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
	920	! On regarde si on est dans la phase de définition ou d'écriture:
	921	IF(.NOT.vars_defined) THEN
	922	!$OMP MASTER
	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
	929	!$OMP END MASTER
	930	ELSE
	931
	932	!Et sinon on.... écrit
	933	IF (SIZE(field)/=klon) CALL abort_gcm('iophy::histwrite2d_phy','Field first DIMENSION not equal to klon',1)
	934
	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)
	941	!$OMP MASTER
	942	CALL grid1Dto2D_mpi(buffer_omp,Field2d)
	943
	944	! La boucle sur les fichiers:
	945	firstx=.true.
	946	DO iff=iff_beg, iff_end
	947	IF (var%flag(iff) <= lev_files(iff) .AND. clef_files(iff)) THEN
	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)
	954	write(lunout,*)"histwrite2d_phy:.NOT.clef_stations(iff)and iff==iff_beg, call xios_send_field"
	955	endif
	956	CALL xios_send_field(var%name, Field2d)
	957	firstx=.false.
	958	ENDIF
	959	#endif
	960
	961	IF(.NOT.clef_stations(iff)) THEN
	962	ALLOCATE(index2d(iim*jj_nb))
	963	ALLOCATE(fieldok(iim*jj_nb))
	964	#ifndef CPP_NO_IOIPSL
	965	CALL histwrite(nid_files(iff),var%name,itau_iophy,Field2d,iim*jj_nb,index2d)
	966	#endif
	967	!#ifdef CPP_XIOS
	968	! IF (iff == iff_beg) THEN
	969	! if (prt_level >= 10) then
	970	! write(lunout,*)"histwrite2d_phy: .NOT.clef_stations(iff) and iff==iff_beg, call xios_send_field"
	971	! endif
	972	! CALL xios_send_field(var%name, Field2d)
	973	! ENDIF
	974	!#endif
	975	ELSE
	976	ALLOCATE(fieldok(npstn))
	977	ALLOCATE(index2d(npstn))
	978
	979	IF (is_sequential) THEN
	980	DO ip=1, npstn
	981	fieldok(ip)=buffer_omp(nptabij(ip))
	982	ENDDO
	983	ELSE
	984	DO ip=1, npstn
	985	write(lunout,*)'histwrite2d_phy is_sequential npstn ip namenptabij',npstn,ip,var%name,nptabij(ip)
	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
	991	ENDIF ! of IF (is_sequential)
	992	#ifndef CPP_NO_IOIPSL
	993	if (prt_level >= 10) then
	994	write(lunout,*)"histwrite2d_phy: clef_stations(iff) and iff==iff_beg, call wxios_write_2D"
	995	endif
	996	CALL histwrite(nid_files(iff),var%name,itau_iophy,fieldok,npstn,index2d)
	997	#endif
	998	ENDIF ! of IF(.NOT.clef_stations(iff))
	999
	1000	deallocate(index2d)
	1001	deallocate(fieldok)
	1002	ENDIF !levfiles
	1003	ENDDO ! of DO iff=iff_beg, iff_end
	1004	!$OMP END MASTER
	1005	ENDIF ! vars_defined
	1006	IF (prt_level >= 10) WRITE(lunout,*)'End histwrite2d_phy ',trim(var%name)
	1007	END SUBROUTINE histwrite2d_phy
	1008
	1009
	1010	! ug NOUVELLE VERSION DES WRITE AVEC LA BOUCLE DO RENTREE
	1011	SUBROUTINE histwrite3d_phy(var, field, STD_iff)
	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
	1020	#ifdef CPP_XIOS
	1021	USE xios, only: xios_send_field
	1022	#endif
	1023
	1024
	1025	IMPLICIT NONE
	1026	INCLUDE 'dimensions.h'
	1027	INCLUDE 'iniprint.h'
	1028
	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
	1033	INTEGER :: iff, iff_beg, iff_end
	1034	LOGICAL, SAVE :: firstx
	1035	!$OMP THREADPRIVATE(firstx)
	1036	REAL,DIMENSION(klon_mpi,SIZE(field,2)) :: buffer_omp
	1037	REAL :: Field3d(iim,jj_nb,SIZE(field,2))
	1038	INTEGER :: ip, n, nlev, nlevx
	1039	INTEGER, ALLOCATABLE, DIMENSION(:) :: index3d
	1040	REAL,ALLOCATABLE, DIMENSION(:,:) :: fieldok
	1041
	1042	IF (prt_level >= 10) write(lunout,*)'Begin histrwrite3d ',var%name
	1043
	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
	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
	1056	!$OMP MASTER
	1057	DO iff=iff_beg, iff_end
	1058	IF (clef_files(iff)) THEN
	1059	CALL histdef3d(iff, var)
	1060	ENDIF
	1061	ENDDO
	1062	!$OMP END MASTER
	1063	ELSE
	1064	!Et sinon on.... écrit
	1065	!JE IF (SIZE(field,1)/=klon) CALL abort_gcm('iophy::histwrite3d','Field first DIMENSION not equal to klon',1)
	1066	nlev=SIZE(field,2)
	1067	if (nlev.eq.klev+1) then
	1068	nlevx=klev
	1069	else
	1070	nlevx=nlev
	1071	endif
	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
	1079	firstx=.true.
	1080	DO iff=iff_beg, iff_end
	1081	IF (var%flag(iff) <= lev_files(iff) .AND. clef_files(iff)) THEN
	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
	1087	write(lunout,*)'histwrite3d_phy: call xios_send_field for ', &
	1088	trim(var%name), ' with iim jjm nlevx = ', &
	1089	iim,jj_nb,nlevx
	1090	endif
	1091	CALL xios_send_field(var%name, Field3d(:,:,1:nlevx))
	1092	firstx=.false.
	1093	ENDIF
	1094	#endif
	1095	IF (.NOT.clef_stations(iff)) THEN
	1096	ALLOCATE(index3d(iimjj_nbnlev))
	1097	ALLOCATE(fieldok(iim*jj_nb,nlev))
	1098
	1099	#ifndef CPP_NO_IOIPSL
	1100	CALL histwrite(nid_files(iff),var%name,itau_iophy,Field3d,iimjj_nbnlev,index3d)
	1101	#endif
	1102
	1103	!#ifdef CPP_XIOS
	1104	! IF (iff == 1) THEN
	1105	! CALL xios_send_field(var%name, Field3d(:,:,1:klev))
	1106	! ENDIF
	1107	!#endif
	1108	!
	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
	1130	#ifndef CPP_NO_IOIPSL
	1131	CALL histwrite(nid_files(iff),var%name,itau_iophy,fieldok,npstn*nlev,index3d)
	1132	#endif
	1133	ENDIF
	1134	deallocate(index3d)
	1135	deallocate(fieldok)
	1136	ENDIF
	1137	ENDDO
	1138	!$OMP END MASTER
	1139	ENDIF ! vars_defined
	1140	IF (prt_level >= 10) write(lunout,*)'End histrwrite3d ',var%name
	1141	END SUBROUTINE histwrite3d_phy
	1142
	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)
	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
	1151	USE xios, only: xios_send_field
	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
	1168	IF (prt_level >= 10) WRITE(lunout,*)'Begin histrwrite2d_xios ',field_name
	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
	1186	CALL xios_send_field(field_name, Field2d)
	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
	1212	IF (prt_level >= 10) WRITE(lunout,*)'End histrwrite2d_xios ',field_name
	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)
	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
	1222	USE xios, only: xios_send_field
	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
	1238	IF (prt_level >= 10) write(lunout,*)'Begin histrwrite3d_xios ',field_name
	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))
	1256	CALL xios_send_field(field_name, Field3d(:,:,1:nlev))
	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
	1284	IF (prt_level >= 10) write(lunout,*)'End histrwrite3d_xios ',field_name
	1285	END SUBROUTINE histwrite3d_xios
	1286	#endif
	1287	end module iophy

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

Download in other formats:

Original Format