! ! $Id: iophy.F90 2429 2016-01-27 12:43:09Z jbmadeleine $ ! MODULE iophy ! abd REAL,private,allocatable,DIMENSION(:),save :: io_lat ! abd REAL,private,allocatable,DIMENSION(:),save :: io_lon REAL,ALLOCATABLE,DIMENSION(:),SAVE :: io_lat REAL,ALLOCATABLE,DIMENSION(:),SAVE :: io_lon INTEGER, SAVE :: phys_domain_id INTEGER, SAVE :: npstn INTEGER, ALLOCATABLE, DIMENSION(:), SAVE :: nptabij INTEGER, SAVE :: itau_iophy !$OMP THREADPRIVATE(itau_iophy) #ifdef CPP_XIOS INTERFACE histwrite_phy MODULE PROCEDURE histwrite2d_phy,histwrite3d_phy,histwrite2d_phy_old,histwrite3d_phy_old,histwrite2d_xios,histwrite3d_xios END INTERFACE #else INTERFACE histwrite_phy MODULE PROCEDURE histwrite2d_phy,histwrite3d_phy,histwrite2d_phy_old,histwrite3d_phy_old END INTERFACE #endif INTERFACE histbeg_phy_all MODULE PROCEDURE histbeg_phy,histbeg_phyxios,histbeg_phy_points END INTERFACE CONTAINS ! ug Routine pour définir itau_iophy depuis phys_output_write_mod: SUBROUTINE set_itau_iophy(ito) IMPLICIT NONE INTEGER, INTENT(IN) :: ito itau_iophy = ito END SUBROUTINE SUBROUTINE init_iophy_new(rlat,rlon) USE dimphy, only: klon USE mod_phys_lmdz_para, only: gather, bcast, & jj_nb, jj_begin, jj_end, ii_begin, ii_end, & mpi_size, mpi_rank, klon_mpi, & is_sequential, is_south_pole_dyn USE mod_grid_phy_lmdz, only: nbp_lon, nbp_lat, klon_glo USE print_control_mod, ONLY: prt_level,lunout #ifdef CPP_IOIPSL USE ioipsl, only: flio_dom_set #endif #ifdef CPP_XIOS use wxios, only: wxios_domain_param #endif IMPLICIT NONE REAL,DIMENSION(klon),INTENT(IN) :: rlon REAL,DIMENSION(klon),INTENT(IN) :: rlat REAL,DIMENSION(klon_glo) :: rlat_glo REAL,DIMENSION(klon_glo) :: rlon_glo INTEGER,DIMENSION(2) :: ddid INTEGER,DIMENSION(2) :: dsg INTEGER,DIMENSION(2) :: dsl INTEGER,DIMENSION(2) :: dpf INTEGER,DIMENSION(2) :: dpl INTEGER,DIMENSION(2) :: dhs INTEGER,DIMENSION(2) :: dhe INTEGER :: i INTEGER :: data_ibegin, data_iend CALL gather(rlat,rlat_glo) CALL bcast(rlat_glo) CALL gather(rlon,rlon_glo) CALL bcast(rlon_glo) !$OMP MASTER ALLOCATE(io_lat(nbp_lat)) IF (klon_glo == 1) THEN io_lat(1)=rlat_glo(1) ELSE io_lat(1)=rlat_glo(1) io_lat(nbp_lat)=rlat_glo(klon_glo) DO i=2,nbp_lat-1 io_lat(i)=rlat_glo(2+(i-2)*nbp_lon) ENDDO ENDIF ALLOCATE(io_lon(nbp_lon)) IF (klon_glo == 1) THEN io_lon(1)=rlon_glo(1) ELSE io_lon(1:nbp_lon)=rlon_glo(2:nbp_lon+1) ENDIF !! (I) dtnb : total number of domains !! (I) dnb : domain number !! (I) did(:) : distributed dimensions identifiers !! (up to 5 dimensions are supported) !! (I) dsg(:) : total number of points for each dimension !! (I) dsl(:) : local number of points for each dimension !! (I) dpf(:) : position of first local point for each dimension !! (I) dpl(:) : position of last local point for each dimension !! (I) dhs(:) : start halo size for each dimension !! (I) dhe(:) : end halo size for each dimension !! (C) cdnm : Model domain definition name. !! The names actually supported are : !! "BOX", "APPLE", "ORANGE". !! These names are case insensitive. ddid=(/ 1,2 /) dsg=(/ nbp_lon, nbp_lat /) dsl=(/ nbp_lon, jj_nb /) dpf=(/ 1,jj_begin /) dpl=(/ nbp_lon, jj_end /) dhs=(/ ii_begin-1,0 /) IF (mpi_rank==mpi_size-1) THEN dhe=(/0,0/) ELSE dhe=(/ nbp_lon-ii_end,0 /) ENDIF #ifndef CPP_IOIPSL_NO_OUTPUT CALL flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, & 'APPLE',phys_domain_id) #endif #ifdef CPP_XIOS ! Set values for the mask: IF (mpi_rank == 0) THEN data_ibegin = 0 ELSE data_ibegin = ii_begin - 1 END IF IF (mpi_rank == mpi_size-1) THEN data_iend = nbp_lon ELSE data_iend = ii_end + 1 END IF if (prt_level>=10) then 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 write(lunout,*) "init_iophy_new: mpirank=",mpi_rank," nbp_lon=",nbp_lon," nbp_lat=",nbp_lat write(lunout,*) "init_iophy_new: mpirank=",mpi_rank," data_ibegin=",data_ibegin," data_iend=",data_iend write(lunout,*) "init_iophy_new: mpirank=",mpi_rank," data_ibegin=",data_ibegin," data_iend=",data_iend write(lunout,*) "init_iophy_new: mpirank=",mpi_rank," is_south_pole=",is_south_pole_dyn endif ! Initialize the XIOS domain coreesponding to this process: CALL wxios_domain_param("dom_glo", is_sequential, nbp_lon, jj_nb, nbp_lon, nbp_lat, & 1, nbp_lon, ii_begin, ii_end, jj_begin, jj_end, & klon_mpi+2*(nbp_lon-1), data_ibegin, data_iend, & io_lat, io_lon,is_south_pole_dyn,mpi_rank) #endif !$OMP END MASTER END SUBROUTINE init_iophy_new SUBROUTINE init_iophy(lat,lon) USE mod_phys_lmdz_para, only: jj_begin, jj_end, ii_begin, ii_end, jj_nb, & mpi_size, mpi_rank USE ioipsl, only: flio_dom_set USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat IMPLICIT NONE REAL,DIMENSION(nbp_lon),INTENT(IN) :: lon REAL,DIMENSION(nbp_lat),INTENT(IN) :: lat INTEGER,DIMENSION(2) :: ddid INTEGER,DIMENSION(2) :: dsg INTEGER,DIMENSION(2) :: dsl INTEGER,DIMENSION(2) :: dpf INTEGER,DIMENSION(2) :: dpl INTEGER,DIMENSION(2) :: dhs INTEGER,DIMENSION(2) :: dhe !$OMP MASTER allocate(io_lat(nbp_lat)) io_lat(:)=lat(:) allocate(io_lon(nbp_lon)) io_lon(:)=lon(:) ddid=(/ 1,2 /) dsg=(/ nbp_lon, nbp_lat /) dsl=(/ nbp_lon, jj_nb /) dpf=(/ 1,jj_begin /) dpl=(/ nbp_lon, jj_end /) dhs=(/ ii_begin-1,0 /) if (mpi_rank==mpi_size-1) then dhe=(/0,0/) else dhe=(/ nbp_lon-ii_end,0 /) endif #ifndef CPP_IOIPSL_NO_OUTPUT call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, & 'APPLE',phys_domain_id) #endif !$OMP END MASTER end SUBROUTINE init_iophy SUBROUTINE histbeg_phyxios(name,itau0,zjulian,dtime,ffreq,lev,nhori,nid_day) ! USE dimphy USE mod_phys_lmdz_para, only: is_sequential, is_using_mpi, is_mpi_root, & jj_begin, jj_end, jj_nb USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat use ioipsl, only: histbeg #ifdef CPP_XIOS use wxios, only: wxios_add_file #endif IMPLICIT NONE include 'clesphys.h' character*(*), INTENT(IN) :: name integer, INTENT(IN) :: itau0 REAL,INTENT(IN) :: zjulian REAL,INTENT(IN) :: dtime character(LEN=*), INTENT(IN) :: ffreq INTEGER,INTENT(IN) :: lev integer,intent(out) :: nhori integer,intent(out) :: nid_day !$OMP MASTER if (is_sequential) then call histbeg(name,nbp_lon,io_lon, jj_nb,io_lat(jj_begin:jj_end), & 1,nbp_lon,1,jj_nb,itau0, zjulian, dtime, nhori, nid_day) else call histbeg(name,nbp_lon,io_lon, jj_nb,io_lat(jj_begin:jj_end), & 1,nbp_lon,1,jj_nb,itau0, zjulian, dtime, nhori, nid_day,phys_domain_id) endif #ifdef CPP_XIOS ! ug OMP en chantier... IF((.NOT. is_using_mpi) .OR. is_mpi_root) THEN ! ug Création du fichier IF (.not. ok_all_xml) THEN CALL wxios_add_file(name, ffreq, lev) ENDIF END IF #endif !$OMP END MASTER END SUBROUTINE histbeg_phyxios SUBROUTINE histbeg_phy(name,itau0,zjulian,dtime,nhori,nid_day) USE mod_phys_lmdz_para, only: jj_begin, jj_end, jj_nb, is_sequential USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat use ioipsl, only: histbeg IMPLICIT NONE character*(*), INTENT(IN) :: name integer, INTENT(IN) :: itau0 REAL,INTENT(IN) :: zjulian REAL,INTENT(IN) :: dtime integer,intent(out) :: nhori integer,intent(out) :: nid_day !$OMP MASTER #ifndef CPP_IOIPSL_NO_OUTPUT if (is_sequential) then call histbeg(name,nbp_lon,io_lon, jj_nb,io_lat(jj_begin:jj_end), & 1,nbp_lon,1,jj_nb,itau0, zjulian, dtime, nhori, nid_day) else call histbeg(name,nbp_lon,io_lon, jj_nb,io_lat(jj_begin:jj_end), & 1,nbp_lon,1,jj_nb,itau0, zjulian, dtime, nhori, nid_day,phys_domain_id) endif #endif !$OMP END MASTER END SUBROUTINE histbeg_phy SUBROUTINE histbeg_phy_points(rlon,rlat,pim,tabij,ipt,jpt, & plon,plat,plon_bounds,plat_bounds, & nname,itau0,zjulian,dtime,nnhori,nnid_day) USE dimphy, only: klon USE mod_phys_lmdz_para, only: gather, bcast, & is_sequential, klon_mpi_begin, klon_mpi_end, & mpi_rank USE mod_grid_phy_lmdz, only: klon_glo, nbp_lon, nbp_lat use ioipsl, only: histbeg IMPLICIT NONE REAL,DIMENSION(klon),INTENT(IN) :: rlon REAL,DIMENSION(klon),INTENT(IN) :: rlat integer, INTENT(IN) :: itau0 REAL,INTENT(IN) :: zjulian REAL,INTENT(IN) :: dtime integer, INTENT(IN) :: pim integer, intent(out) :: nnhori character(len=20), INTENT(IN) :: nname INTEGER, intent(out) :: nnid_day integer :: i REAL,DIMENSION(klon_glo) :: rlat_glo REAL,DIMENSION(klon_glo) :: rlon_glo INTEGER, DIMENSION(pim), INTENT(IN) :: tabij REAL,DIMENSION(pim), INTENT(IN) :: plat, plon INTEGER,DIMENSION(pim), INTENT(IN) :: ipt, jpt REAL,DIMENSION(pim,2), intent(out) :: plat_bounds, plon_bounds INTEGER, SAVE :: tabprocbeg, tabprocend !$OMP THREADPRIVATE(tabprocbeg, tabprocend) INTEGER :: ip INTEGER, PARAMETER :: nip=1 INTEGER :: npproc REAL, allocatable, DIMENSION(:) :: npplat, npplon REAL, allocatable, DIMENSION(:,:) :: npplat_bounds, npplon_bounds REAL, DIMENSION(nbp_lon,nbp_lat) :: zx_lon, zx_lat CALL gather(rlat,rlat_glo) CALL bcast(rlat_glo) CALL gather(rlon,rlon_glo) CALL bcast(rlon_glo) !$OMP MASTER DO i=1,pim ! print*,'CFMIP_iophy i tabij lon lat',i,tabij(i),plon(i),plat(i) plon_bounds(i,1)=rlon_glo(tabij(i)-1) plon_bounds(i,2)=rlon_glo(tabij(i)+1) if(plon_bounds(i,2).LE.0..AND.plon_bounds(i,1).GE.0.) THEN if(rlon_glo(tabij(i)).GE.0.) THEN plon_bounds(i,2)=-1*plon_bounds(i,2) endif endif if(plon_bounds(i,2).GE.0..AND.plon_bounds(i,1).LE.0.) THEN if(rlon_glo(tabij(i)).LE.0.) THEN plon_bounds(i,2)=-1*plon_bounds(i,2) endif endif ! IF ( tabij(i).LE.nbp_lon) THEN plat_bounds(i,1)=rlat_glo(tabij(i)) ELSE plat_bounds(i,1)=rlat_glo(tabij(i)-nbp_lon) ENDIF plat_bounds(i,2)=rlat_glo(tabij(i)+nbp_lon) ! ! print*,'CFMIP_iophy point i lon lon_bds',i,plon_bounds(i,1),rlon_glo(tabij(i)),plon_bounds(i,2) ! print*,'CFMIP_iophy point i lat lat_bds',i,plat_bounds(i,1),rlat_glo(tabij(i)),plat_bounds(i,2) ! ENDDO if (is_sequential) then npstn=pim IF(.NOT. ALLOCATED(nptabij)) THEN ALLOCATE(nptabij(pim)) ENDIF DO i=1,pim nptabij(i)=tabij(i) ENDDO CALL gr_fi_ecrit(1,klon,nbp_lon,nbp_lat,rlon_glo,zx_lon) if ((nbp_lon*nbp_lat).gt.1) then DO i = 1, nbp_lon zx_lon(i,1) = rlon_glo(i+1) zx_lon(i,nbp_lat) = rlon_glo(i+1) ENDDO endif CALL gr_fi_ecrit(1,klon,nbp_lon,nbp_lat,rlat_glo,zx_lat) DO i=1,pim ! print*,'CFMIP_iophy i tabij lon lat',i,tabij(i),plon(i),plat(i) plon_bounds(i,1)=zx_lon(ipt(i)-1,jpt(i)) plon_bounds(i,2)=zx_lon(ipt(i)+1,jpt(i)) if (ipt(i).EQ.1) then plon_bounds(i,1)=zx_lon(nbp_lon,jpt(i)) plon_bounds(i,2)=360.+zx_lon(ipt(i)+1,jpt(i)) endif if (ipt(i).EQ.nbp_lon) then plon_bounds(i,2)=360.+zx_lon(1,jpt(i)) endif plat_bounds(i,1)=zx_lat(ipt(i),jpt(i)-1) plat_bounds(i,2)=zx_lat(ipt(i),jpt(i)+1) if (jpt(i).EQ.1) then plat_bounds(i,1)=zx_lat(ipt(i),1)+0.001 plat_bounds(i,2)=zx_lat(ipt(i),1)-0.001 endif if (jpt(i).EQ.nbp_lat) then plat_bounds(i,1)=zx_lat(ipt(i),nbp_lat)+0.001 plat_bounds(i,2)=zx_lat(ipt(i),nbp_lat)-0.001 endif ! ! print*,'CFMIP_iophy point i lon lon_bds',i,plon_bounds(i,1),rlon(tabij(i)),plon_bounds(i,2) ! print*,'CFMIP_iophy point i lat lat_bds',i,plat_bounds(i,1),rlat(tabij(i)),plat_bounds(i,2) ! ENDDO #ifndef CPP_IOIPSL_NO_OUTPUT call histbeg(nname,pim,plon,plon_bounds, & plat,plat_bounds, & itau0, zjulian, dtime, nnhori, nnid_day) #endif else npproc=0 DO ip=1, pim tabprocbeg=klon_mpi_begin tabprocend=klon_mpi_end IF(tabij(ip).GE.tabprocbeg.AND.tabij(ip).LE.tabprocend) THEN npproc=npproc+1 npstn=npproc ENDIF ENDDO ! print*,'CFMIP_iophy mpi_rank npstn',mpi_rank,npstn IF(.NOT. ALLOCATED(nptabij)) THEN ALLOCATE(nptabij(npstn)) ALLOCATE(npplon(npstn), npplat(npstn)) ALLOCATE(npplon_bounds(npstn,2), npplat_bounds(npstn,2)) ENDIF npproc=0 DO ip=1, pim IF(tabij(ip).GE.tabprocbeg.AND.tabij(ip).LE.tabprocend) THEN npproc=npproc+1 nptabij(npproc)=tabij(ip) ! print*,'mpi_rank npproc ip plon plat tabij=',mpi_rank,npproc,ip, & ! plon(ip),plat(ip),tabij(ip) npplon(npproc)=plon(ip) npplat(npproc)=plat(ip) npplon_bounds(npproc,1)=plon_bounds(ip,1) npplon_bounds(npproc,2)=plon_bounds(ip,2) npplat_bounds(npproc,1)=plat_bounds(ip,1) npplat_bounds(npproc,2)=plat_bounds(ip,2) !!! !!! print qui sert a reordonner les points stations selon l'ordre CFMIP !!! ne pas enlever print*,'iophy_mpi rank ip lon lat',mpi_rank,ip,plon(ip),plat(ip) !!! ENDIF ENDDO #ifndef CPP_IOIPSL_NO_OUTPUT call histbeg(nname,npstn,npplon,npplon_bounds, & npplat,npplat_bounds, & itau0,zjulian,dtime,nnhori,nnid_day,phys_domain_id) #endif endif !$OMP END MASTER end SUBROUTINE histbeg_phy_points SUBROUTINE histdef2d_old (iff,lpoint,flag_var,nomvar,titrevar,unitvar) USE ioipsl, only: histdef USE mod_phys_lmdz_para, only: jj_nb use phys_output_var_mod, only: type_ecri, zoutm, zdtime_moy, lev_files, & nid_files, nhorim, swaero_diag, nfiles USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat IMPLICIT NONE INCLUDE "clesphys.h" INTEGER :: iff LOGICAL :: lpoint INTEGER, DIMENSION(nfiles) :: flag_var CHARACTER(LEN=20) :: nomvar CHARACTER(LEN=*) :: titrevar CHARACTER(LEN=*) :: unitvar REAL zstophym IF (type_ecri(iff)=='inst(X)'.OR.type_ecri(iff)=='once') THEN zstophym=zoutm(iff) ELSE zstophym=zdtime_moy ENDIF ! Appel a la lecture des noms et niveau d'ecriture des variables dans output.def CALL conf_physoutputs(nomvar,flag_var) IF(.NOT.lpoint) THEN IF ( flag_var(iff)<=lev_files(iff) ) THEN CALL histdef (nid_files(iff),nomvar,titrevar,unitvar, & nbp_lon,jj_nb,nhorim(iff), 1,1,1, -99, 32, & type_ecri(iff), zstophym,zoutm(iff)) ENDIF ELSE IF ( flag_var(iff)<=lev_files(iff) ) THEN CALL histdef (nid_files(iff),nomvar,titrevar,unitvar, & npstn,1,nhorim(iff), 1,1,1, -99, 32, & type_ecri(iff), zstophym,zoutm(iff)) ENDIF ENDIF ! Set swaero_diag=true if at least one of the concerned variables are defined IF (nomvar=='topswad' .OR. nomvar=='topswai' .OR. nomvar=='solswad' .OR. nomvar=='solswai' ) THEN IF ( flag_var(iff)<=lev_files(iff) ) THEN swaero_diag=.TRUE. END IF END IF END SUBROUTINE histdef2d_old SUBROUTINE histdef3d_old (iff,lpoint,flag_var,nomvar,titrevar,unitvar) USE ioipsl, only: histdef USE dimphy, only: klev USE mod_phys_lmdz_para, only: jj_nb use phys_output_var_mod, only: type_ecri, zoutm, lev_files, nid_files, & nhorim, zdtime_moy, levmin, levmax, & nvertm, nfiles USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat IMPLICIT NONE INCLUDE "clesphys.h" INTEGER :: iff LOGICAL :: lpoint INTEGER, DIMENSION(nfiles) :: flag_var CHARACTER(LEN=20) :: nomvar CHARACTER(LEN=*) :: titrevar CHARACTER(LEN=*) :: unitvar REAL zstophym ! Appel a la lecture des noms et niveau d'ecriture des variables dans output.def CALL conf_physoutputs(nomvar,flag_var) IF (type_ecri(iff)=='inst(X)'.OR.type_ecri(iff)=='once') THEN zstophym=zoutm(iff) ELSE zstophym=zdtime_moy ENDIF IF(.NOT.lpoint) THEN IF ( flag_var(iff)<=lev_files(iff) ) THEN CALL histdef (nid_files(iff), nomvar, titrevar, unitvar, & nbp_lon, jj_nb, nhorim(iff), klev, levmin(iff), & levmax(iff)-levmin(iff)+1, nvertm(iff), 32, type_ecri(iff), & zstophym, zoutm(iff)) ENDIF ELSE IF ( flag_var(iff)<=lev_files(iff) ) THEN CALL histdef (nid_files(iff), nomvar, titrevar, unitvar, & npstn,1,nhorim(iff), klev, levmin(iff), & levmax(iff)-levmin(iff)+1, nvertm(iff), 32, & type_ecri(iff), zstophym,zoutm(iff)) ENDIF ENDIF END SUBROUTINE histdef3d_old SUBROUTINE histdef2d (iff,var) USE ioipsl, only: histdef USE mod_phys_lmdz_para, only: jj_nb use phys_output_var_mod, only: ctrl_out, type_ecri_files, zoutm, zdtime_moy, & clef_stations, phys_out_filenames, lev_files, & nid_files, nhorim, swaero_diag USE print_control_mod, ONLY: prt_level,lunout USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat #ifdef CPP_XIOS use wxios, only: wxios_add_field_to_file #endif IMPLICIT NONE INCLUDE "clesphys.h" INTEGER :: iff TYPE(ctrl_out) :: var REAL zstophym CHARACTER(LEN=20) :: typeecrit ! ug On récupère le type écrit de la structure: ! Assez moche, à refaire si meilleure méthode... IF (INDEX(var%type_ecrit(iff), "once") > 0) THEN typeecrit = 'once' ELSE IF(INDEX(var%type_ecrit(iff), "t_min") > 0) THEN typeecrit = 't_min(X)' ELSE IF(INDEX(var%type_ecrit(iff), "t_max") > 0) THEN typeecrit = 't_max(X)' ELSE IF(INDEX(var%type_ecrit(iff), "inst") > 0) THEN typeecrit = 'inst(X)' ELSE typeecrit = type_ecri_files(iff) ENDIF IF (typeecrit=='inst(X)'.OR.typeecrit=='once') THEN zstophym=zoutm(iff) ELSE zstophym=zdtime_moy ENDIF ! Appel a la lecture des noms et niveau d'ecriture des variables dans output.def CALL conf_physoutputs(var%name, var%flag) IF(.NOT.clef_stations(iff)) THEN #ifdef CPP_XIOS IF (.not. ok_all_xml) THEN IF ( var%flag(iff)<=lev_files(iff) ) THEN CALL wxios_add_field_to_file(var%name, 2, iff, phys_out_filenames(iff), & var%description, var%unit, var%flag(iff), typeecrit) IF (prt_level >= 10) THEN WRITE(lunout,*) 'histdef2d: call wxios_add_field_to_file var%name iff: ', & trim(var%name),iff ENDIF ENDIF ENDIF #endif #ifndef CPP_IOIPSL_NO_OUTPUT IF ( var%flag(iff)<=lev_files(iff) ) THEN CALL histdef (nid_files(iff), var%name, var%description, var%unit, & nbp_lon,jj_nb,nhorim(iff), 1,1,1, -99, 32, & typeecrit, zstophym,zoutm(iff)) ENDIF ELSE IF ( var%flag(iff)<=lev_files(iff)) THEN CALL histdef (nid_files(iff), var%name, var%description, var%unit, & npstn,1,nhorim(iff), 1,1,1, -99, 32, & typeecrit, zstophym,zoutm(iff)) ENDIF #endif ENDIF ! Set swaero_diag=true if at least one of the concerned variables are defined IF (var%name=='topswad' .OR. var%name=='topswai' .OR. var%name=='solswad' .OR. var%name=='solswai' ) THEN IF ( var%flag(iff)<=lev_files(iff) ) THEN swaero_diag=.TRUE. END IF END IF END SUBROUTINE histdef2d SUBROUTINE histdef3d (iff,var) USE ioipsl, only: histdef USE dimphy, only: klev USE mod_phys_lmdz_para, only: jj_nb use phys_output_var_mod, only: ctrl_out, type_ecri_files, zoutm, zdtime_moy, & clef_stations, phys_out_filenames, lev_files, & nid_files, nhorim, swaero_diag, levmin, & levmax, nvertm USE print_control_mod, ONLY: prt_level,lunout USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat #ifdef CPP_XIOS use wxios, only: wxios_add_field_to_file #endif IMPLICIT NONE INCLUDE "clesphys.h" INTEGER :: iff TYPE(ctrl_out) :: var REAL zstophym CHARACTER(LEN=20) :: typeecrit ! ug On récupère le type écrit de la structure: ! Assez moche, à refaire si meilleure méthode... IF (INDEX(var%type_ecrit(iff), "once") > 0) THEN typeecrit = 'once' ELSE IF(INDEX(var%type_ecrit(iff), "t_min") > 0) THEN typeecrit = 't_min(X)' ELSE IF(INDEX(var%type_ecrit(iff), "t_max") > 0) THEN typeecrit = 't_max(X)' ELSE IF(INDEX(var%type_ecrit(iff), "inst") > 0) THEN typeecrit = 'inst(X)' ELSE typeecrit = type_ecri_files(iff) ENDIF ! Appel a la lecture des noms et niveau d'ecriture des variables dans output.def CALL conf_physoutputs(var%name,var%flag) IF (typeecrit=='inst(X)'.OR.typeecrit=='once') THEN zstophym=zoutm(iff) ELSE zstophym=zdtime_moy ENDIF IF(.NOT.clef_stations(iff)) THEN #ifdef CPP_XIOS IF (.not. ok_all_xml) THEN IF ( var%flag(iff)<=lev_files(iff) ) THEN CALL wxios_add_field_to_file(var%name, 3, iff, phys_out_filenames(iff), & var%description, var%unit, var%flag(iff), typeecrit) IF (prt_level >= 10) THEN WRITE(lunout,*) 'histdef3d: call wxios_add_field_to_file var%name iff: ', & trim(var%name),iff ENDIF ENDIF ENDIF #endif #ifndef CPP_IOIPSL_NO_OUTPUT IF ( var%flag(iff)<=lev_files(iff) ) THEN CALL histdef (nid_files(iff), var%name, var%description, var%unit, & nbp_lon, jj_nb, nhorim(iff), klev, levmin(iff), & levmax(iff)-levmin(iff)+1, nvertm(iff), 32, typeecrit, & zstophym, zoutm(iff)) ENDIF ELSE IF ( var%flag(iff)<=lev_files(iff)) THEN CALL histdef (nid_files(iff), var%name, var%description, var%unit, & npstn,1,nhorim(iff), klev, levmin(iff), & levmax(iff)-levmin(iff)+1, nvertm(iff), 32, & typeecrit, zstophym,zoutm(iff)) ENDIF #endif ENDIF END SUBROUTINE histdef3d SUBROUTINE conf_physoutputs(nam_var,flag_var) !!! Lecture des noms et niveau de sortie des variables dans output.def ! en utilisant les routines getin de IOIPSL use ioipsl, only: getin use phys_output_var_mod, only: nfiles USE print_control_mod, ONLY: prt_level,lunout IMPLICIT NONE CHARACTER(LEN=20) :: nam_var INTEGER, DIMENSION(nfiles) :: flag_var IF(prt_level>10) WRITE(lunout,*)'Avant getin: nam_var flag_var ',nam_var,flag_var(:) CALL getin('flag_'//nam_var,flag_var) CALL getin('name_'//nam_var,nam_var) IF(prt_level>10) WRITE(lunout,*)'Apres getin: nam_var flag_var ',nam_var,flag_var(:) END SUBROUTINE conf_physoutputs SUBROUTINE histwrite2d_phy_old(nid,lpoint,name,itau,field) USE dimphy, only: klon USE mod_phys_lmdz_para, only: Gather_omp, grid1Dto2D_mpi, & is_sequential, klon_mpi_begin, klon_mpi_end, & jj_nb, klon_mpi USE ioipsl, only: histwrite USE print_control_mod, ONLY: prt_level,lunout USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat IMPLICIT NONE integer,INTENT(IN) :: nid logical,INTENT(IN) :: lpoint character*(*), INTENT(IN) :: name integer, INTENT(IN) :: itau REAL,DIMENSION(:),INTENT(IN) :: field REAL,DIMENSION(klon_mpi) :: buffer_omp INTEGER, allocatable, DIMENSION(:) :: index2d REAL :: Field2d(nbp_lon,jj_nb) integer :: ip REAL,allocatable,DIMENSION(:) :: fieldok IF (size(field)/=klon) CALL abort_physic('iophy::histwrite2d','Field first DIMENSION not equal to klon',1) CALL Gather_omp(field,buffer_omp) !$OMP MASTER CALL grid1Dto2D_mpi(buffer_omp,Field2d) if(.NOT.lpoint) THEN ALLOCATE(index2d(nbp_lon*jj_nb)) ALLOCATE(fieldok(nbp_lon*jj_nb)) IF (prt_level >= 10) write(lunout,*)'Sending ',name,' to IOIPSL' CALL histwrite(nid,name,itau,Field2d,nbp_lon*jj_nb,index2d) IF (prt_level >= 10) write(lunout,*)'Finished sending ',name,' to IOIPSL' else ALLOCATE(fieldok(npstn)) ALLOCATE(index2d(npstn)) if(is_sequential) then ! klon_mpi_begin=1 ! klon_mpi_end=klon DO ip=1, npstn fieldok(ip)=buffer_omp(nptabij(ip)) ENDDO else DO ip=1, npstn ! print*,'histwrite2d is_sequential npstn ip name nptabij',npstn,ip,name,nptabij(ip) IF(nptabij(ip).GE.klon_mpi_begin.AND. & nptabij(ip).LE.klon_mpi_end) THEN fieldok(ip)=buffer_omp(nptabij(ip)-klon_mpi_begin+1) ENDIF ENDDO endif IF (prt_level >= 10) write(lunout,*)'Sending ',name,' to IOIPSL' CALL histwrite(nid,name,itau,fieldok,npstn,index2d) IF (prt_level >= 10) write(lunout,*)'Finished sending ',name,' to IOIPSL' ! endif deallocate(index2d) deallocate(fieldok) !$OMP END MASTER end SUBROUTINE histwrite2d_phy_old SUBROUTINE histwrite3d_phy_old(nid,lpoint,name,itau,field) USE dimphy, only: klon USE mod_phys_lmdz_para, only: Gather_omp, grid1Dto2D_mpi, & is_sequential, klon_mpi_begin, klon_mpi_end, & jj_nb, klon_mpi USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat use ioipsl, only: histwrite USE print_control_mod, ONLY: prt_level,lunout IMPLICIT NONE integer,INTENT(IN) :: nid logical,INTENT(IN) :: lpoint character*(*), INTENT(IN) :: name integer, INTENT(IN) :: itau REAL,DIMENSION(:,:),INTENT(IN) :: field ! --> field(klon,:) REAL,DIMENSION(klon_mpi,size(field,2)) :: buffer_omp REAL :: Field3d(nbp_lon,jj_nb,size(field,2)) INTEGER :: ip, n, nlev INTEGER, ALLOCATABLE, DIMENSION(:) :: index3d REAL,allocatable, DIMENSION(:,:) :: fieldok IF (size(field,1)/=klon) CALL abort_physic('iophy::histwrite3d','Field first DIMENSION not equal to klon',1) nlev=size(field,2) CALL Gather_omp(field,buffer_omp) !$OMP MASTER CALL grid1Dto2D_mpi(buffer_omp,field3d) if(.NOT.lpoint) THEN ALLOCATE(index3d(nbp_lon*jj_nb*nlev)) ALLOCATE(fieldok(nbp_lon*jj_nb,nlev)) IF (prt_level >= 10) write(lunout,*)'Sending ',name,' to IOIPSL' CALL histwrite(nid,name,itau,Field3d,nbp_lon*jj_nb*nlev,index3d) IF (prt_level >= 10) write(lunout,*)'Finished sending ',name,' to IOIPSL' else nlev=size(field,2) ALLOCATE(index3d(npstn*nlev)) ALLOCATE(fieldok(npstn,nlev)) if(is_sequential) then ! klon_mpi_begin=1 ! klon_mpi_end=klon DO n=1, nlev DO ip=1, npstn fieldok(ip,n)=buffer_omp(nptabij(ip),n) ENDDO ENDDO else DO n=1, nlev DO ip=1, npstn IF(nptabij(ip).GE.klon_mpi_begin.AND. & nptabij(ip).LE.klon_mpi_end) THEN fieldok(ip,n)=buffer_omp(nptabij(ip)-klon_mpi_begin+1,n) ENDIF ENDDO ENDDO endif IF (prt_level >= 10) write(lunout,*)'Sending ',name,' to IOIPSL' CALL histwrite(nid,name,itau,fieldok,npstn*nlev,index3d) IF (prt_level >= 10) write(lunout,*)'Finished sending ',name,' to IOIPSL' endif deallocate(index3d) deallocate(fieldok) !$OMP END MASTER end SUBROUTINE histwrite3d_phy_old ! ug NOUVELLE VERSION DES WRITE AVEC LA BOUCLE DO RENTREE SUBROUTINE histwrite2d_phy(var,field, STD_iff) USE dimphy, only: klon USE mod_phys_lmdz_para, only: gather_omp, grid1dto2d_mpi, & jj_nb, klon_mpi, klon_mpi_begin, & klon_mpi_end, is_sequential USE ioipsl, only: histwrite use phys_output_var_mod, only: ctrl_out, clef_files, lev_files, & nfiles, vars_defined, clef_stations, & nid_files USE print_control_mod, ONLY: prt_level,lunout USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat #ifdef CPP_XIOS USE xios, only: xios_send_field #endif IMPLICIT NONE include 'clesphys.h' TYPE(ctrl_out), INTENT(IN) :: var REAL, DIMENSION(:), INTENT(IN) :: field INTEGER, INTENT(IN), OPTIONAL :: STD_iff ! ug RUSTINE POUR LES STD LEVS..... INTEGER :: iff, iff_beg, iff_end LOGICAL, SAVE :: firstx !$OMP THREADPRIVATE(firstx) REAL,DIMENSION(klon_mpi) :: buffer_omp INTEGER, allocatable, DIMENSION(:) :: index2d REAL :: Field2d(nbp_lon,jj_nb) INTEGER :: ip REAL, ALLOCATABLE, DIMENSION(:) :: fieldok IF (prt_level >= 10) THEN WRITE(lunout,*)'Begin histwrite2d_phy for ',trim(var%name) ENDIF ! ug RUSTINE POUR LES STD LEVS..... IF (PRESENT(STD_iff)) THEN iff_beg = STD_iff iff_end = STD_iff ELSE iff_beg = 1 iff_end = nfiles END IF ! On regarde si on est dans la phase de définition ou d'écriture: IF(.NOT.vars_defined) THEN !$OMP MASTER !Si phase de définition.... on définit IF (.not. ok_all_xml) THEN if (prt_level >= 10) then write(lunout,*)"histwrite2d_phy: .not.vars_defined ; time to define ", & trim(var%name) endif DO iff=iff_beg, iff_end IF (clef_files(iff)) THEN CALL histdef2d(iff, var) ENDIF ENDDO ENDIF !$OMP END MASTER ELSE !Et sinon on.... écrit IF (SIZE(field)/=klon) CALL abort_physic('iophy::histwrite2d_phy','Field first DIMENSION not equal to klon',1) if (prt_level >= 10) then write(lunout,*)"histwrite2d_phy: .not.vars_defined ; time to gather and write ", & trim(var%name) endif CALL Gather_omp(field,buffer_omp) !$OMP MASTER CALL grid1Dto2D_mpi(buffer_omp,Field2d) ! La boucle sur les fichiers: firstx=.true. IF (ok_all_xml) THEN #ifdef CPP_XIOS if (prt_level >= 10) then write(lunout,*)'Dans iophy histwrite2D,var%name ',& trim(var%name) endif CALL xios_send_field(var%name, Field2d) if (prt_level >= 10) then write(lunout,*)'Dans iophy histwrite2D,var%name apres xios_send ',& trim(var%name) endif #else CALL abort_physic ('iophy','cannot have ok_all_xml = .T. without CPP_XIOS defined' ,1) #endif ELSE DO iff=iff_beg, iff_end IF (var%flag(iff) <= lev_files(iff) .AND. clef_files(iff)) THEN #ifdef CPP_XIOS IF (firstx) THEN if (prt_level >= 10) then write(lunout,*)'Dans iophy histwrite2D,iff,var%name ',& iff,trim(var%name) write(lunout,*)"histwrite2d_phy:.NOT.clef_stations(iff)and iff==iff_beg, call xios_send_field" endif CALL xios_send_field(var%name, Field2d) firstx=.false. ENDIF #endif IF(.NOT.clef_stations(iff)) THEN ALLOCATE(index2d(nbp_lon*jj_nb)) ALLOCATE(fieldok(nbp_lon*jj_nb)) #ifndef CPP_IOIPSL_NO_OUTPUT CALL histwrite(nid_files(iff),var%name,itau_iophy,Field2d,nbp_lon*jj_nb,index2d) #endif !#ifdef CPP_XIOS ! IF (iff == iff_beg) THEN ! if (prt_level >= 10) then ! write(lunout,*)"histwrite2d_phy: .NOT.clef_stations(iff) and iff==iff_beg, call xios_send_field" ! endif ! CALL xios_send_field(var%name, Field2d) ! ENDIF !#endif ELSE ALLOCATE(fieldok(npstn)) ALLOCATE(index2d(npstn)) IF (is_sequential) THEN DO ip=1, npstn fieldok(ip)=buffer_omp(nptabij(ip)) ENDDO ELSE DO ip=1, npstn write(lunout,*)'histwrite2d_phy is_sequential npstn ip namenptabij',npstn,ip,var%name,nptabij(ip) IF(nptabij(ip).GE.klon_mpi_begin.AND. & nptabij(ip).LE.klon_mpi_end) THEN fieldok(ip)=buffer_omp(nptabij(ip)-klon_mpi_begin+1) ENDIF ENDDO ENDIF ! of IF (is_sequential) #ifndef CPP_IOIPSL_NO_OUTPUT if (prt_level >= 10) then write(lunout,*)"histwrite2d_phy: clef_stations(iff) and iff==iff_beg, call wxios_write_2D" endif CALL histwrite(nid_files(iff),var%name,itau_iophy,fieldok,npstn,index2d) #endif ENDIF ! of IF(.NOT.clef_stations(iff)) deallocate(index2d) deallocate(fieldok) ENDIF !levfiles ENDDO ! of DO iff=iff_beg, iff_end ENDIF !$OMP END MASTER ENDIF ! vars_defined IF (prt_level >= 10) WRITE(lunout,*)'End histwrite2d_phy ',trim(var%name) END SUBROUTINE histwrite2d_phy ! ug NOUVELLE VERSION DES WRITE AVEC LA BOUCLE DO RENTREE SUBROUTINE histwrite3d_phy(var, field, STD_iff) USE dimphy, only: klon, klev USE mod_phys_lmdz_para, only: gather_omp, grid1dto2d_mpi, & jj_nb, klon_mpi, klon_mpi_begin, & klon_mpi_end, is_sequential USE ioipsl, only: histwrite use phys_output_var_mod, only: ctrl_out, clef_files, lev_files, & nfiles, vars_defined, clef_stations, & nid_files USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat #ifdef CPP_XIOS USE xios, only: xios_send_field #endif USE print_control_mod, ONLY: prt_level,lunout IMPLICIT NONE include 'clesphys.h' TYPE(ctrl_out), INTENT(IN) :: var REAL, DIMENSION(:,:), INTENT(IN) :: field ! --> field(klon,:) INTEGER, INTENT(IN), OPTIONAL :: STD_iff ! ug RUSTINE POUR LES STD LEVS..... INTEGER :: iff, iff_beg, iff_end LOGICAL, SAVE :: firstx !$OMP THREADPRIVATE(firstx) REAL,DIMENSION(klon_mpi,SIZE(field,2)) :: buffer_omp REAL :: Field3d(nbp_lon,jj_nb,SIZE(field,2)) INTEGER :: ip, n, nlev, nlevx INTEGER, ALLOCATABLE, DIMENSION(:) :: index3d REAL,ALLOCATABLE, DIMENSION(:,:) :: fieldok IF (prt_level >= 10) write(lunout,*)'Begin histrwrite3d ',var%name ! ug RUSTINE POUR LES STD LEVS..... IF (PRESENT(STD_iff)) THEN iff_beg = STD_iff iff_end = STD_iff ELSE iff_beg = 1 iff_end = nfiles END IF ! On regarde si on est dans la phase de définition ou d'écriture: IF(.NOT.vars_defined) THEN !Si phase de définition.... on définit !$OMP MASTER DO iff=iff_beg, iff_end IF (clef_files(iff)) THEN CALL histdef3d(iff, var) ENDIF ENDDO !$OMP END MASTER ELSE !Et sinon on.... écrit IF (SIZE(field,1)/=klon) CALL abort_physic('iophy::histwrite3d','Field first DIMENSION not equal to klon',1) nlev=SIZE(field,2) if (nlev.eq.klev+1) then nlevx=klev else nlevx=nlev endif CALL Gather_omp(field,buffer_omp) !$OMP MASTER CALL grid1Dto2D_mpi(buffer_omp,field3d) ! BOUCLE SUR LES FICHIERS firstx=.true. IF (ok_all_xml) THEN #ifdef CPP_XIOS if (prt_level >= 10) then write(lunout,*)'Dans iophy histwrite3D,var%name ',& trim(var%name) endif CALL xios_send_field(var%name, Field3d(:,:,1:nlevx)) #else CALL abort_physic ('iophy','cannot have ok_all_xml = .T. without CPP_XIOS defined' ,1) #endif ELSE DO iff=iff_beg, iff_end IF (var%flag(iff) <= lev_files(iff) .AND. clef_files(iff)) THEN #ifdef CPP_XIOS IF (firstx) THEN if (prt_level >= 10) then write(lunout,*)'Dans iophy, histwrite3D iff nlev klev firstx', & iff,nlev,klev, firstx write(lunout,*)'histwrite3d_phy: call xios_send_field for ', & trim(var%name), ' with iim jjm nlevx = ', & nbp_lon,jj_nb,nlevx endif CALL xios_send_field(var%name, Field3d(:,:,1:nlevx)) firstx=.false. ENDIF #endif IF (.NOT.clef_stations(iff)) THEN ALLOCATE(index3d(nbp_lon*jj_nb*nlev)) ALLOCATE(fieldok(nbp_lon*jj_nb,nlev)) #ifndef CPP_IOIPSL_NO_OUTPUT CALL histwrite(nid_files(iff),var%name,itau_iophy,Field3d,nbp_lon*jj_nb*nlev,index3d) #endif !#ifdef CPP_XIOS ! IF (iff == 1) THEN ! CALL xios_send_field(var%name, Field3d(:,:,1:klev)) ! ENDIF !#endif ! ELSE nlev=size(field,2) ALLOCATE(index3d(npstn*nlev)) ALLOCATE(fieldok(npstn,nlev)) IF (is_sequential) THEN DO n=1, nlev DO ip=1, npstn fieldok(ip,n)=buffer_omp(nptabij(ip),n) ENDDO ENDDO ELSE DO n=1, nlev DO ip=1, npstn IF(nptabij(ip).GE.klon_mpi_begin.AND. & nptabij(ip).LE.klon_mpi_end) THEN fieldok(ip,n)=buffer_omp(nptabij(ip)-klon_mpi_begin+1,n) ENDIF ENDDO ENDDO ENDIF #ifndef CPP_IOIPSL_NO_OUTPUT CALL histwrite(nid_files(iff),var%name,itau_iophy,fieldok,npstn*nlev,index3d) #endif ENDIF deallocate(index3d) deallocate(fieldok) ENDIF ENDDO ENDIF !$OMP END MASTER ENDIF ! vars_defined IF (prt_level >= 10) write(lunout,*)'End histrwrite3d ',var%name END SUBROUTINE histwrite3d_phy ! VERSION DES HISTWRITE DEDIEES AU TOUT-XIOS-XML DEJA UTILISEE DANS PHYDEV #ifdef CPP_XIOS SUBROUTINE histwrite2d_xios(field_name,field) USE dimphy, only: klon USE mod_phys_lmdz_para, only: gather_omp, grid1Dto2D_mpi, & is_sequential, klon_mpi_begin, klon_mpi_end, & jj_nb, klon_mpi USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat USE xios, only: xios_send_field USE print_control_mod, ONLY: prt_level,lunout IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: field_name REAL, DIMENSION(:), INTENT(IN) :: field REAL,DIMENSION(klon_mpi) :: buffer_omp INTEGER, allocatable, DIMENSION(:) :: index2d REAL :: Field2d(nbp_lon,jj_nb) INTEGER :: ip REAL, ALLOCATABLE, DIMENSION(:) :: fieldok IF (prt_level >= 10) WRITE(lunout,*)'Begin histrwrite2d_xios ',field_name !Et sinon on.... écrit IF (SIZE(field)/=klon) CALL abort_physic('iophy::histwrite2d_xios','Field first DIMENSION not equal to klon',1) CALL Gather_omp(field,buffer_omp) !$OMP MASTER CALL grid1Dto2D_mpi(buffer_omp,Field2d) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !ATTENTION, STATIONS PAS GEREES ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !IF(.NOT.clef_stations(iff)) THEN IF (.TRUE.) THEN ALLOCATE(index2d(nbp_lon*jj_nb)) ALLOCATE(fieldok(nbp_lon*jj_nb)) CALL xios_send_field(field_name, Field2d) ELSE ALLOCATE(fieldok(npstn)) ALLOCATE(index2d(npstn)) IF (is_sequential) THEN DO ip=1, npstn fieldok(ip)=buffer_omp(nptabij(ip)) ENDDO ELSE DO ip=1, npstn PRINT*,'histwrite2d_xios is_sequential npstn ip namenptabij',npstn,ip,field_name,nptabij(ip) IF(nptabij(ip).GE.klon_mpi_begin.AND. & nptabij(ip).LE.klon_mpi_end) THEN fieldok(ip)=buffer_omp(nptabij(ip)-klon_mpi_begin+1) ENDIF ENDDO ENDIF ENDIF deallocate(index2d) deallocate(fieldok) !$OMP END MASTER IF (prt_level >= 10) WRITE(lunout,*)'End histrwrite2d_xios ',field_name END SUBROUTINE histwrite2d_xios ! ug NOUVELLE VERSION DES WRITE AVEC LA BOUCLE DO RENTREE SUBROUTINE histwrite3d_xios(field_name, field) USE dimphy, only: klon, klev USE mod_phys_lmdz_para, only: gather_omp, grid1Dto2D_mpi, & is_sequential, klon_mpi_begin, klon_mpi_end, & jj_nb, klon_mpi USE xios, only: xios_send_field USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat USE print_control_mod, ONLY: prt_level,lunout IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: field_name REAL, DIMENSION(:,:), INTENT(IN) :: field ! --> field(klon,:) REAL,DIMENSION(klon_mpi,SIZE(field,2)) :: buffer_omp REAL :: Field3d(nbp_lon,jj_nb,SIZE(field,2)) INTEGER :: ip, n, nlev INTEGER, ALLOCATABLE, DIMENSION(:) :: index3d REAL,ALLOCATABLE, DIMENSION(:,:) :: fieldok IF (prt_level >= 10) write(lunout,*)'Begin histrwrite3d_xios ',field_name !Et on.... écrit IF (SIZE(field,1)/=klon) CALL abort_physic('iophy::histwrite3d','Field first DIMENSION not equal to klon',1) nlev=SIZE(field,2) CALL Gather_omp(field,buffer_omp) !$OMP MASTER CALL grid1Dto2D_mpi(buffer_omp,field3d) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !ATTENTION, STATIONS PAS GEREES ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !IF (.NOT.clef_stations(iff)) THEN IF(.TRUE.)THEN ALLOCATE(index3d(nbp_lon*jj_nb*nlev)) ALLOCATE(fieldok(nbp_lon*jj_nb,nlev)) CALL xios_send_field(field_name, Field3d(:,:,1:nlev)) ELSE nlev=size(field,2) ALLOCATE(index3d(npstn*nlev)) ALLOCATE(fieldok(npstn,nlev)) IF (is_sequential) THEN DO n=1, nlev DO ip=1, npstn fieldok(ip,n)=buffer_omp(nptabij(ip),n) ENDDO ENDDO ELSE DO n=1, nlev DO ip=1, npstn IF(nptabij(ip).GE.klon_mpi_begin.AND. & nptabij(ip).LE.klon_mpi_end) THEN fieldok(ip,n)=buffer_omp(nptabij(ip)-klon_mpi_begin+1,n) ENDIF ENDDO ENDDO ENDIF ENDIF deallocate(index3d) deallocate(fieldok) !$OMP END MASTER IF (prt_level >= 10) write(lunout,*)'End histrwrite3d_xios ',field_name END SUBROUTINE histwrite3d_xios #endif end module iophy