hydro/MPP/module_mpp_GWBUCKET.F

   1 !  Program Name:
   2 !  Author(s)/Contact(s):
   3 !  Abstract:
   4 !  History Log:
   5 !
   6 !  Usage:
   7 !  Parameters: <Specify typical arguments passed>
   8 !  Input Files:
   9 !        <list file names and briefly describe the data they include>
  10 !  Output Files:
  11 !        <list file names and briefly describe the information they include>
  12 !
  13 !  Condition codes:
  14 !        <list exit condition or error codes returned >
  15 !        If appropriate, descriptive troubleshooting instructions or
  16 !        likely causes for failures could be mentioned here with the
  17 !        appropriate error code
  18 !
  19 !  User controllable options: <if applicable>
  20
  21 !   This is used as a coupler with the WRF model.
  22 MODULE MODULE_mpp_GWBUCKET
  23
  24   use MODULE_CPL_LAND, only: HYDRO_COMM_WORLD
  25   use module_mpp_land, only:  io_id, my_id, mpp_status, mpp_land_max_int1, numprocs, &
  26                  mpp_land_bcast_real, sum_real8,  mpp_land_sync
  27   use iso_fortran_env, only: int64
  28   use mpi
  29   implicit none
  30
  31
  32
  33
  34   integer,allocatable,dimension(:) :: sizeInd  ! size of Basins for each tile
  35   integer ::  maxSizeInd
  36
  37   integer :: gw_ini
  38
  39   contains
  40
  41   subroutine gwbucket_ini()
  42      allocate(sizeInd(numprocs))
  43      sizeInd = 0
  44      gw_ini = 99
  45      maxSizeInd = 0
  46   end subroutine gwbucket_ini
  47
  48
  49   subroutine collectSizeInd(numbasns)
  50      implicit none
  51      integer, intent(in) :: numbasns
  52      integer :: i, ierr, tag, rcv
  53
  54       call mpp_land_sync()
  55
  56      if(gw_ini .ne. 99) call gwbucket_ini()
  57
  58      if(my_id .ne. IO_id) then
  59           tag = 66
  60           call mpi_send(numbasns,1,MPI_INTEGER, IO_id,     &
  61                 tag,HYDRO_COMM_WORLD,ierr)
  62      else
  63           do i = 0, numprocs - 1
  64               if(i .eq. IO_id) then
  65                  sizeInd(i+1) = numbasns
  66               else
  67                  tag = 66
  68                  call mpi_recv(rcv,1,&
  69                      MPI_INTEGER,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr)
  70
  71                  sizeInd(i+1) = rcv
  72               end if
  73               if(sizeInd(i+1) .gt. maxSizeInd) maxSizeInd = sizeInd(i+1)
  74           end do
  75       end if
  76   end subroutine collectSizeInd
  77
  78   subroutine gw_write_io_real(numbasns,inV,ind,outV)
  79      implicit none
  80      integer, intent(in) :: numbasns
  81      integer :: i, ierr, tag, tag2,k
  82      real,intent(in), dimension(numbasns) :: inV
  83      integer(kind=int64), intent(in), dimension(numbasns) :: ind
  84      real, dimension(:) :: outV
  85      real, allocatable,dimension(:) :: vbuff
  86      integer(kind=int64), allocatable,dimension(:) :: ibuff
  87
  88      if(gw_ini .ne. 99) then
  89         stop "FATAL ERROR: mpp_GWBUCKET not initialized."
  90      endif
  91
  92      if(my_id .eq. IO_id) then
  93          outV = 0.0
  94          allocate(vbuff(maxSizeInd))
  95          allocate(ibuff(maxSizeInd))
  96      else
  97          allocate(vbuff(1))
  98          allocate(ibuff(1))
  99      endif
 100
 101      if(my_id .ne. IO_id) then
 102         if(numbasns .gt. 0) then
 103           tag = 62
 104           call mpi_send(inV,numbasns,MPI_REAL, IO_id,     &
 105                 tag,HYDRO_COMM_WORLD,ierr)
 106           tag2 = 63
 107           call mpi_send(ind,numbasns,MPI_INTEGER8, IO_id,     &
 108                 tag2,HYDRO_COMM_WORLD,ierr)
 109         endif
 110       else
 111
 112           do k = 1, numbasns
 113               outV(ind(k)) = inV(k)
 114           end do
 115
 116           do i = 0, numprocs - 1
 117             if(i .ne. IO_id) then
 118                if(sizeInd(i+1) .gt. 0) then
 119                   tag = 62
 120                   call mpi_recv(vbuff(1:sizeInd(i+1)),sizeInd(i+1),&
 121                       MPI_REAL,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr)
 122                   tag2 = 63
 123                   call mpi_recv(ibuff(1:sizeInd(i+1)),sizeInd(i+1),&
 124                       MPI_INTEGER8,i,tag2,HYDRO_COMM_WORLD,mpp_status,ierr)
 125                   do k = 1, sizeInd(i+1)
 126                      outV(ibuff(k)) = vbuff(k)
 127                   end do
 128                endif
 129              end if
 130            end do
 131       end if
 132       if(allocated(ibuff)) deallocate(ibuff)
 133       if(allocated(vbuff)) deallocate(vbuff)
 134   end subroutine gw_write_io_real
 135
 136   subroutine gw_write_io_int(numbasns,inV,ind,outV)
 137       implicit none
 138       integer, intent(in) :: numbasns
 139       integer :: i, ierr, tag, tag2,k
 140       integer(kind=int64),intent(in), dimension(numbasns) :: inV
 141       integer(kind=int64),intent(in), dimension(numbasns) :: ind
 142       integer(kind=int64), dimension(:) :: outV
 143       integer(kind=int64), allocatable,dimension(:) :: vbuff
 144       integer(kind=int64), allocatable,dimension(:) :: ibuff
 145
 146       if(gw_ini .ne. 99) then
 147          stop "FATAL ERROR: mpp_GWBUCKET not initialized."
 148       endif
 149
 150       if(my_id .eq. IO_id) then
 151           outV = 0.0
 152           allocate(vbuff(maxSizeInd))
 153           allocate(ibuff(maxSizeInd))
 154       else
 155           allocate(vbuff(1))
 156           allocate(ibuff(1))
 157       endif
 158
 159       if(my_id .ne. IO_id) then
 160          if(numbasns .gt. 0) then
 161            tag = 62
 162            call mpi_send(inV,numbasns,MPI_INTEGER8, IO_id,     &
 163                  tag,HYDRO_COMM_WORLD,ierr)
 164            tag2 = 63
 165            call mpi_send(ind,numbasns,MPI_INTEGER8, IO_id,     &
 166                  tag2,HYDRO_COMM_WORLD,ierr)
 167          endif
 168        else
 169
 170            do k = 1, numbasns
 171                outV(ind(k)) = inV(k)
 172            end do
 173
 174            do i = 0, numprocs - 1
 175              if(i .ne. IO_id) then
 176                 if(sizeInd(i+1) .gt. 0) then
 177                    tag = 62
 178                    call mpi_recv(vbuff(1:sizeInd(i+1)),sizeInd(i+1),&
 179                        MPI_INTEGER8,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr)
 180                    tag2 = 63
 181                    call mpi_recv(ibuff(1:sizeInd(i+1)),sizeInd(i+1),&
 182                        MPI_INTEGER8,i,tag2,HYDRO_COMM_WORLD,mpp_status,ierr)
 183                    do k = 1, sizeInd(i+1)
 184                       outV(ibuff(k)) = vbuff(k)
 185                    end do
 186                 endif
 187               end if
 188             end do
 189        end if
 190        deallocate(ibuff)
 191        deallocate(vbuff)
 192    end subroutine gw_write_io_int
 193
 194   subroutine gw_decompose_real(gnumbasns,numbasns,ind,inV,outV)
 195      implicit none
 196      integer, intent(in) :: numbasns, gnumbasns
 197      integer :: i, ierr, tag, bas
 198      real,intent(in), dimension(:) :: inV
 199      integer(kind=int64),intent(in), dimension(:) :: ind
 200      real, dimension(:) :: outV
 201      real, dimension(gnumbasns) :: buff
 202
 203      outV = 0
 204      if(gnumbasns .lt. 0) return
 205
 206      if(my_id .eq. io_id) buff = inV
 207      call mpp_land_bcast_real(gnumbasns,buff)
 208
 209      do i = 1, numbasns
 210         bas = ind(i)
 211         outV(i) = buff(bas)
 212      end do
 213   end subroutine gw_decompose_real
 214
 215    subroutine gw_sum_real(vinout,nsize,gsize,ind)
 216        implicit none
 217        integer nsize,i,j,tag,ierr,gsize, k
 218        real*8, dimension(nsize):: vinout
 219        integer(kind=int64), dimension(nsize) :: ind
 220        real*8, dimension(gsize) :: vbuff
 221
 222        vbuff = 0
 223        do k = 1, nsize
 224           vbuff(ind(k)) = vinout(k)
 225        end do
 226        call sum_real8(vbuff,gsize)
 227        do k = 1, nsize
 228           vinout(k) = vbuff(ind(k))
 229        end do
 230     end subroutine gw_sum_real
 231
 232
 233
 234 end MODULE MODULE_mpp_GWBUCKET