| PUMA 219 Portable University Model of the Atmosphere

- Main Page
- Data Types List
- Files

- File List
- File Members

/Users/home/WC/puma/src/mpimod_multi.f90
Go to the documentation of this file.

    00001       module mpimod
    00002       use pumamod
    00003       use mpi
    00004
    00005       integer :: mpi_itype = MPI_INTEGER4
    00006       integer :: mpi_rtype = MPI_REAL4
    00007       integer :: mpi_ltype = MPI_LOGICAL
    00008
    00009       end module mpimod
    00010
    00011
    00012 !     ==================
    00013 !     SUBROUTINE MPSTART
    00014 !     ==================
    00015
    00016       subroutine mpstart ! initialization
    00017       use mpimod
    00018       integer :: itest = 0
    00019       real    :: rtest = 0.0
    00020
    00021       if (kind(itest) == 8) mpi_itype = MPI_INTEGER8
    00022       if (kind(rtest) == 8) mpi_rtype = MPI_REAL8
    00023
    00024       call mpi_init(mrinfo)
    00025       mrworld=MPI_COMM_WORLD
    00026
    00027       call mpi_comm_size(mrworld,mrnum,mrinfo)
    00028       call mpi_comm_rank(mrworld,mrpid,mrinfo)
    00029       allocate(ympname(mrnum)) ; ympname(:) = ' '  ! process names
    00030       call mpi_get_processor_name(ympname(1),ilen,mrinfo)
    00031
    00032       call mpi_gather(ympname,80,mpi_character,   &
    00033                       ympname,80,mpi_character,   &
    00034                       nroot,mrworld,mrinfo)
    00035       return
    00036       end subroutine mpstart
    00037
    00038
    00039 !     =======================
    00040 !     subroutine mrdimensions
    00041 !     =======================
    00042
    00043       subroutine mrdimensions
    00044       use mpimod
    00045
    00046       allocate(mrtru(mrnum)) ! all truncations
    00047       mrtru(1) = ntru
    00048       call mpi_gather(mrtru,1,mpi_itype,   &
    00049                       mrtru,1,mpi_itype,   &
    00050                       nroot,mrworld,mrinfo)
    00051
    00052       call mrbcin(mrtru,mrnum)  ! broadcast truncations
    00053       mintru = minval(mrtru(1:mrnum))
    00054       mrdim  = (mintru+1) * (mintru+2)
    00055       return
    00056       end
    00057
    00058 !     =================
    00059 !     subroutine mpstop
    00060 !     =================
    00061
    00062       subroutine mpstop
    00063       use mpimod
    00064
    00065       call mpi_barrier(mrworld,mrinfo)
    00066       call mpi_finalize(mrinfo)
    00067
    00068       return
    00069       end subroutine mpstop
    00070
    00071
    00072 !     ================
    00073 !     subroutine mrsum
    00074 !     ================
    00075
    00076       subroutine mrsum(k)
    00077       use mpimod
    00078       integer :: k,n
    00079 !     print *,'mrsum b[',mrpid,']',k
    00080       call mpi_allreduce(k,n,1,mpi_itype,MPI_SUM,mrworld,mrinfo)
    00081 !     print *,'mrsum a[',mrpid,']',n
    00082       k = n
    00083       return
    00084       end
    00085
    00086
    00087 !     =================
    00088 !     subroutine mrdiff
    00089 !     =================
    00090
    00091       subroutine mrdiff(pa,pd,kesp,klev)
    00092       use mpimod
    00093
    00094       real :: pa(kesp,klev)
    00095       real :: pd(kesp,klev)
    00096       real :: px(mrdim)
    00097       real :: py(mrdim)
    00098
    00099       do jlev = 1 , klev
    00100          if (kesp == mrdim) then
    00101             px(:) = pa(:,jlev)
    00102          else
    00103             call mrtrunc(pa(1,jlev),ntru,px,mintru)
    00104          endif
    00105          call mpi_allreduce(px,py,mrdim,mpi_rtype,MPI_SUM,mrworld,mrinfo)
    00106          py(:) = py(:) - 2.0 * px(:)
    00107          if (kesp == mrdim) then
    00108             pd(:,jlev) = py(:)
    00109          else
    00110             call mrexpand(py,mintru,pd(1,jlev),ntru)
    00111          endif
    00112       enddo
    00113       return
    00114       end
    00115
    00116
    00117 !     =================
    00118 !     subroutine mrbcin
    00119 !     =================
    00120
    00121       subroutine mrbcin(k,n)
    00122       use mpimod
    00123       integer :: k(n)
    00124
    00125       call mpi_bcast(k,n,mpi_itype,NROOT,mrworld,mrinfo)
    00126
    00127       return
    00128       end
    00129
    00130
    00131 !     ==================
    00132 !     subroutine mrtrunc
    00133 !     ==================
    00134
    00135 !     Reduce truncation from nthi to ntlo
    00136
    00137       subroutine mrtrunc(sphi,nthi,splo,ntlo)
    00138       complex :: sphi(*)
    00139       complex :: splo(*)
    00140
    00141       jl = 1
    00142       jh = 1
    00143       do jm = 0 , ntlo
    00144          jn = ntlo - jm
    00145          splo(jl:jl+jn) = sphi(jh:jh+jn)
    00146          jl = jl + ntlo - jm + 1
    00147          jh = jh + nthi - jm + 1
    00148       enddo
    00149       return
    00150       end
    00151
    00152
    00153 !     ===================
    00154 !     subroutine mrexpand
    00155 !     ===================
    00156
    00157 !     Expand truncation from ntlo to nthi
    00158
    00159       subroutine mrexpand(splo,ntlo,sphi,nthi)
    00160       complex :: sphi(*)
    00161       complex :: splo(*)
    00162
    00163       sphi(1:nthi) = (0.0,0.0)
    00164       jl = 1
    00165       jh = 1
    00166       do jm = 0 , ntlo
    00167          jn = ntlo - jm
    00168          sphi(jh:jh+jn) = splo(jl:jl+jn)
    00169          jl = jl + ntlo - jm + 1
    00170          jh = jh + nthi - jm + 1
    00171       enddo
    00172       return
    00173       end
    00174
    00175
    00176       subroutine mpbci(k) ! broadcast 1 integer
    00177       return
    00178       end
    00179
    00180       subroutine mpbcin(k,n) ! broadcast n integer
    00181       integer :: k(n)
    00182       return
    00183       end
    00184
    00185       subroutine mpbcr(p) ! broadcast 1 real
    00186       return
    00187       end
    00188
    00189       subroutine mpbcrn(p,n) ! broadcast n real
    00190       real :: p(n)
    00191       return
    00192       end
    00193
    00194       subroutine mpbcl(k) ! broadcast 1 logical
    00195       logical :: k
    00196       return
    00197       end
    00198
    00199       subroutine mpscin(k,n) ! scatter n integer
    00200       integer :: k(n)
    00201       return
    00202       end
    00203
    00204       subroutine mpscrn(p,n) ! scatter n real
    00205       real :: p(n)
    00206       return
    00207       end
    00208
    00209       subroutine mpscdn(p,n) ! scatter n double precision
    00210       real (kind=8) :: p(n)
    00211       return
    00212       end
    00213
    00214       subroutine mpscsp(pf,pp,klev) ! scatter spectral fields
    00215       use pumamod
    00216       real pf(nesp,klev)
    00217       real pp(nspp,klev)
    00218       pp(1:nspp,1:klev) = pf(1:nspp,1:klev)
    00219       return
    00220       end
    00221
    00222       subroutine mpscgp(pf,pp,klev) ! scatter gridpoint fields
    00223       use pumamod
    00224       real pf(nlon*nlat,klev)
    00225       real pp(nhor,klev)
    00226       pp(1:nhor,1:klev) = pf(1:nhor,1:klev)
    00227       return
    00228       end
    00229
    00230       subroutine mpgasp(pf,pp,klev) ! gather spectral fields
    00231       use pumamod
    00232       real pf(nesp,klev)
    00233       real pp(nspp,klev)
    00234       pf(1:nspp,1:klev) = pp(1:nspp,1:klev)
    00235       return
    00236       end
    00237
    00238       subroutine mpgagp(pf,pp,klev) ! gather gridpoint fields
    00239       use pumamod
    00240       real pf(nhor,klev)
    00241       real pp(nhor,klev)
    00242       pf = pp
    00243       return
    00244       end
    00245
    00246       subroutine mpgacs(pcs) ! gather cross sections
    00247       return
    00248       end
    00249
    00250       subroutine mpgallsp(pf,pp,klev) ! gather spectral to all
    00251       use pumamod
    00252       real pf(nesp,klev)
    00253       real pp(nspp,klev)
    00254       pf(1:nspp,1:klev) = pp(1:nspp,1:klev)
    00255       return
    00256       end
    00257
    00258       subroutine mpsum(psp,klev) ! sum spectral fields
    00259       return
    00260       end
    00261
    00262       subroutine mpsumsc(psf,psp,klev) ! sum & scatter spectral
    00263       use pumamod
    00264       real psf(nesp,klev)
    00265       real psp(nspp,klev)
    00266       psp(1:nspp,1:klev) = psf(1:nspp,1:klev)
    00267       return
    00268       end
    00269
    00270       subroutine mpsumr(pr,kdim) ! sum kdim reals
    00271       return
    00272       end subroutine mpsumr
    00273
    00274       subroutine mpsumbcr(pr,kdim) ! sum & broadcast kdim reals
    00275       return
    00276       end
    00277
    00278       subroutine mpreadsp(ktape,p,kdim,klev)
    00279       real p(kdim,klev)
    00280       read (ktape) p
    00281       return
    00282       end
    00283
    00284       subroutine mpreadgp(ktape,p,kdim,klev)
    00285       real p(kdim,klev)
    00286       read (ktape) p
    00287       return
    00288       end
    00289
    00290       subroutine mpwritesp(ktape,p,kdim,klev)
    00291       real p(kdim,klev)
    00292       write (ktape) p
    00293       return
    00294       end
    00295
    00296       subroutine mpwritegp(ktape,p,kdim,klev)
    00297       real p(kdim,klev)
    00298       write (ktape) p
    00299       return
    00300       end
    00301
    00302       subroutine mpwritegph(ktape,p,kdim,klev,ihead)
    00303       real :: p(kdim,klev)
    00304       integer :: ihead(8)
    00305       write (ktape) ihead
    00306       write (ktape) p
    00307
    00308       return
    00309       end
    00310
    00311
    00312       subroutine mpi_info(nprocess,pid)    ! get nproc and pid
    00313       integer nprocess, pid
    00314       nprocess = 1
    00315       pid = 0
    00316       return
    00317       end subroutine mpi_info
    00318
    00319
    00320       subroutine mpgetsp(yn,p,kdim,klev)
    00321       character (len=*) :: yn
    00322       real :: p(kdim,klev)
    00323       call get_restart_array(yn,p,kdim,kdim,klev)
    00324       return
    00325       end subroutine mpgetsp
    00326
    00327
    00328       subroutine mpgetgp(yn,p,kdim,klev)
    00329       character (len=*) :: yn
    00330       real :: p(kdim,klev)
    00331       call get_restart_array(yn,p,kdim,kdim,klev)
    00332       return
    00333       end subroutine mpgetgp
    00334
    00335
    00336       subroutine mpputsp(yn,p,kdim,klev)
    00337       character (len=*) :: yn
    00338       real :: p(kdim,klev)
    00339       call put_restart_array(yn,p,kdim,kdim,klev)
    00340       return
    00341       end subroutine mpputsp
    00342
    00343
    00344       subroutine mpputgp(yn,p,kdim,klev)
    00345       character (len=*) :: yn
    00346       real :: p(kdim,klev)
    00347       call put_restart_array(yn,p,kdim,kdim,klev)
    00348       return
    00349       end subroutine mpputgp
    00350
    00351
    00352 !      subroutine mpsurfgp(yn,p,kdim,klev)
    00353 !      character (len=*) :: yn
    00354 !      real :: p(kdim,klev)
    00355 !      call get_surf_array(yn,p,kdim,kdim,klev,iread)
    00356 !      return
    00357 !      end subroutine mpsurfgp
    00358 !
    00359 !
    00360 !      subroutine mpsurfyear(yn,p,kdim,kmon)
    00361 !      character (len=*) :: yn
    00362 !      real :: p(kdim,kmon)
    00363 !      call get_surf_year(yn,p,kdim,kmon,iread)
    00364 !      return
    00365 !      end subroutine mpsurfyear
    00366 !
    00367 !
    00368 !      subroutine mp3dyear(yn,p,kdim,klev,kmon)
    00369 !      character (len=*) :: yn
    00370 !      real :: p(kdim,klev,kmon)
    00371 !      call get_3d_year(yn,p,kdim,klev,kmon,iread)
    00372 !      return
    00373 !      end subroutine mp3dyear
    00374
    00375
    00376       subroutine mpmaxval(p,kdim,klev,pmax)
    00377       real :: p(kdim,klev)
    00378       pmax = maxval(p(:,:))
    00379       return
    00380       end subroutine mpmaxval
    00381
    00382
    00383       subroutine mpsumval(p,kdim,klev,psum)
    00384       real :: p(kdim,klev)
    00385       psum = sum(p(:,:))
    00386       return
    00387       end subroutine mpsumval
    00388