diff --git a/plasim/src/mpimod.f90 b/plasim/src/mpimod.f90 index c1818e1..83e7557 100644 --- a/plasim/src/mpimod.f90 +++ b/plasim/src/mpimod.f90 @@ -21,6 +21,7 @@ subroutine mpbci(k) ! broadcast 1 integer use mpimod + integer :: k(*) call mpi_bcast(k,1,mpi_itype,NROOT,myworld,mpinfo) @@ -34,7 +35,7 @@ subroutine mpbcin(k,n) ! broadcast n integer use mpimod - integer k(n) + integer :: k(n) call mpi_bcast(k,n,mpi_itype,NROOT,myworld,mpinfo) @@ -47,6 +48,7 @@ subroutine mpbcr(p) ! broadcast 1 real use mpimod + REAL :: p(*) call mpi_bcast(p,1,mpi_rtype,NROOT,myworld,mpinfo) @@ -59,8 +61,7 @@ subroutine mpbcrn(p,n) ! broadcast n real use mpimod - - real p(n) + real :: p(n) call mpi_bcast(p,n,mpi_rtype,NROOT,myworld,mpinfo) @@ -71,11 +72,11 @@ ! SUBROUTINE MPBCL ! ================ - subroutine mpbcl(k) ! broadcast 1 logical + subroutine mpbcl(l) ! broadcast 1 logical use mpimod - logical k + logical :: l(*) - call mpi_bcast(k,1,mpi_ltype,NROOT,myworld,mpinfo) + call mpi_bcast(l,1,mpi_ltype,NROOT,myworld,mpinfo) return end subroutine mpbcl @@ -87,10 +88,9 @@ subroutine mpscin(k,n) ! scatter n integer use mpimod - integer k(*) + integer :: k(n) - call mpi_scatter(k,n,mpi_itype,k,n,mpi_itype & - & ,NROOT,myworld,mpinfo) + call mpi_scatter(k,n,mpi_itype,k,n,mpi_itype,NROOT,myworld,mpinfo) return end subroutine mpscin @@ -102,7 +102,7 @@ subroutine mpscrn(p,n) ! scatter n real use mpimod - real p(*) + real :: p(*) call mpi_scatter(p,n,mpi_rtype,p,n,mpi_rtype,NROOT,myworld,mpinfo) @@ -130,12 +130,12 @@ subroutine mpscgp(pf,pp,klev) ! scatter gridpoint fields use mpimod - real pf(NUGP,klev) - real pp(NHOR,klev) + real :: pf(NUGP,klev) + real :: pp(NHOR,klev) do jlev = 1 , klev - call mpi_scatter(pf(1,jlev),NHOR,mpi_rtype, & - & pp(1,jlev),NHOR,mpi_rtype, & + call mpi_scatter(pf(:,jlev),NHOR,mpi_rtype, & + & pp(:,jlev),NHOR,mpi_rtype, & & NROOT,myworld,mpinfo) enddo @@ -149,12 +149,12 @@ subroutine mpgagp(pf,pp,klev) ! gather gridpoint fields use mpimod - real pf(NLON*NLAT,klev) - real pp(NHOR,klev) + real :: pf(NLON*NLAT,klev) + real :: pp(NHOR,klev) do jlev = 1 , klev - call mpi_gather(pp(1,jlev),NHOR,mpi_rtype, & - & pf(1,jlev),NHOR,mpi_rtype, & + call mpi_gather(pp(:,jlev),NHOR,mpi_rtype, & + & pf(:,jlev),NHOR,mpi_rtype, & & NROOT,myworld,mpinfo) enddo @@ -168,12 +168,12 @@ subroutine mpgallgp(pf,pp,klev) ! gather gritpoint to all use mpimod - real pf(NLON*NLAT,klev) - real pp(NHOR,klev) + real :: pf(NLON*NLAT,klev) + real :: pp(NHOR,klev) do jlev = 1 , klev - call mpi_allgather(pp(1,jlev),NHOR,mpi_rtype, & - & pf(1,jlev),NHOR,mpi_rtype, & + call mpi_allgather(pp(:,jlev),NHOR,mpi_rtype, & + & pf(:,jlev),NHOR,mpi_rtype, & & myworld,mpinfo) enddo @@ -187,12 +187,12 @@ subroutine mpscsp(pf,pp,klev) ! scatter spectral fields use mpimod - real pf(NESP,klev) - real pp(NSPP,klev) + real :: pf(NESP,klev) + real :: pp(NSPP,klev) do jlev = 1 , klev - call mpi_scatter(pf(1,jlev),NSPP,mpi_rtype & - & ,pp(1,jlev),NSPP,mpi_rtype & + call mpi_scatter(pf(:,jlev),NSPP,mpi_rtype & + & ,pp(:,jlev),NSPP,mpi_rtype & & ,NROOT,myworld,mpinfo) enddo @@ -206,12 +206,12 @@ subroutine mpgasp(pf,pp,klev) ! gather spectral fields use mpimod - real pf(NESP,klev) - real pp(NSPP,klev) + real :: pf(NESP,klev) + real :: pp(NSPP,klev) do jlev = 1 , klev - call mpi_gather(pp(1,jlev),NSPP,mpi_rtype & - & ,pf(1,jlev),NSPP,mpi_rtype & + call mpi_gather(pp(:,jlev),NSPP,mpi_rtype & + & ,pf(:,jlev),NSPP,mpi_rtype & & ,NROOT,myworld,mpinfo) enddo @@ -225,11 +225,11 @@ subroutine mpgacs(pcs) ! gather cross sections use mpimod - real pcs(NLAT,NLEV) + real :: pcs(NLAT,NLEV) do jlev = 1 , NLEV - call mpi_gather(pcs(1,jlev),NLPP,mpi_rtype & - & ,pcs(1,jlev),NLPP,mpi_rtype & + call mpi_gather(pcs(:,jlev),NLPP,mpi_rtype & + & ,pcs(:,jlev),NLPP,mpi_rtype & & ,NROOT,myworld,mpinfo) enddo @@ -243,12 +243,12 @@ subroutine mpgallsp(pf,pp,klev) ! gather spectral to all use mpimod - real pf(NESP,klev) - real pp(NSPP,klev) + real :: pf(NESP,klev) + real :: pp(NSPP,klev) do jlev = 1 , klev - call mpi_allgather(pp(1,jlev),NSPP,mpi_rtype & - & ,pf(1,jlev),NSPP,mpi_rtype & + call mpi_allgather(pp(:,jlev),NSPP,mpi_rtype & + & ,pf(:,jlev),NSPP,mpi_rtype & & ,myworld,mpinfo) enddo @@ -262,10 +262,10 @@ subroutine mpsum(psp,klev) ! sum spectral fields use mpimod - real psp(NESP,klev) - real tmp(NESP,klev) + real :: psp(NESP*klev) + real :: tmp(NESP*klev) - call mpi_reduce(psp(1,1),tmp(1,1),NESP*klev,mpi_rtype,MPI_SUM & + call mpi_reduce(psp,tmp,NESP*klev,mpi_rtype,MPI_SUM & & ,NROOT,myworld,mpinfo) if (mypid == NROOT) psp = tmp @@ -279,11 +279,11 @@ subroutine mpsumsc(psf,psp,klev) ! sum & scatter spectral use mpimod - real psf(NESP,klev) - real psp(NSPP,klev) + real :: psf(NESP,klev) + real :: psp(NSPP,klev) do jlev = 1 , klev - call mpi_reduce_scatter(psf(1,jlev),psp(1,jlev),nscatsp & + call mpi_reduce_scatter(psf(:,jlev),psp(:,jlev),nscatsp & & ,mpi_rtype,MPI_SUM,myworld,mpinfo) enddo @@ -660,10 +660,11 @@ character (len=*) :: yn real :: p(kdim,klev) real :: z(NUGP,klev) + integer :: iread(1) if (mypid == NROOT) call get_surf_array(yn,z,NUGP,klev,iread) call mpbci(iread) - if (iread == 1) call mpscgp(z,p,klev) + if (iread(1) == 1) call mpscgp(z,p,klev) return end subroutine mpsurfgp @@ -677,8 +678,10 @@ use mpimod real :: p(kdim,klev) + real :: pmax(1) + real zmax(1) - zmax = maxval(p(:,:)) + zmax(1) = maxval(p(:,:)) call mpi_allreduce(zmax,pmax,1,mpi_rtype,MPI_MAX,myworld,mpinfo) return @@ -693,6 +696,8 @@ use mpimod real :: p(kdim,klev) + real :: psum(1) + real :: zsum(1) zsum = sum(p(:,:)) call mpi_allreduce(zsum,psum,1,mpi_rtype,MPI_SUM,myworld,mpinfo)