!########################################################################
!########################################################################
!######### #########
!######### SUBROUTINE MPIPROCESS #########
!######### #########
!######### Developed by #########
!######### Center for Analysis and Prediction of Storms #########
!######### University of Oklahoma #########
!######### #########
!########################################################################
!########################################################################
SUBROUTINE mpiprocess(nobmpi,indexmpi,np,kitem,kitemmax, & 2,4
isrc,item1,nx,ny,xmpi,ympi,xs,ys)
!-----------------------------------------------------------------------
!
! PURPOSE:
!
! Determine which processor "owns" an ob. Later, when we need info,
! we know who to "contact".
!
!-----------------------------------------------------------------------
!
! AUTHOR: Kevin W. Thomas, CAPS
! December 2, 2005
!
! MODIFICATION HISTORY:
!
!-----------------------------------------------------------------------
!
! Force explicit declarations
!
!-----------------------------------------------------------------------
IMPLICIT NONE
!-----------------------------------------------------------------------
!
! Subroutine arguments
!
!-----------------------------------------------------------------------
INTEGER, INTENT(IN) :: nobmpi ! Total number of single-point
! observations stored in arrays
INTEGER, INTENT(INOUT) :: indexmpi(nobmpi) ! Owner
INTEGER, INTENT(IN) :: np ! Number of processors (nprocs)
INTEGER, INTENT(INOUT) :: kitem(np) ! Number obs handled by each processor
INTEGER, INTENT(INOUT) :: kitemmax ! Largest "kitem" value
INTEGER, INTENT(INOUT) :: isrc(nobmpi) ! Data source number
INTEGER, INTENT(INOUT) :: item1(nobmpi) ! Work array
REAL, INTENT(INOUT) :: xmpi(nobmpi) ! Observation x grid coordinate (m)
REAL, INTENT(INOUT) :: ympi(nobmpi) ! Observation y grid coordinate (m)
INTEGER, INTENT(IN) :: nx,ny ! Grid dimensions.
REAL, INTENT(IN) :: xs(nx) ! x-coordinates of grid scalar points (m)
REAL, INTENT(IN) :: ys(ny) ! y-coordinates of grid scalar points (m)
!-----------------------------------------------------------------------
!
! Include files:
!
!-----------------------------------------------------------------------
INCLUDE 'mp.inc'
!-----------------------------------------------------------------------
!
! Misc. local variables
!
!-----------------------------------------------------------------------
INTEGER :: ksta
INTEGER :: ipt,jpt
INTEGER :: indom
INTEGER :: ierror
INTEGER :: k
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
! Beginning of executable code...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
DO ksta=1,nobmpi
indexmpi(ksta) = -1
!
! If we've been declared "bad" or joined via "suprob", then stop here.
!
IF (isrc(ksta) == 0 ) CYCLE
CALL findlc
(nx,ny,xs,ys,xmpi(ksta),ympi(ksta),ipt,jpt,indom)
IF (indom == 0 ) indexmpi(ksta) = myproc
END DO
!
! Collect and merge the data.
!
IF (myproc > 0 ) THEN
CALL mpsendi(indexmpi,nobmpi,0,1000+myproc,ierror)
ELSE
DO k=1,nprocs-1
CALL mprecvi(item1,nobmpi,k,1000+k,ierror)
DO ksta=1,nobmpi
IF ( item1(ksta) == -1 ) CYCLE
!-------------------------------------------------------------------------
!
! Since there are overlapping grids in MPI, it is possible for an ob to
! be available to more than one processor. We select the first processor.
! There is no need for more than one processor to make identical
! computations.
!
! The WARNING message is commented out, as it is useful for debugging,
! however, it will likely confuse anyone else.
!
!-------------------------------------------------------------------------
! IF ( indexmpi(ksta) .ne. -1 ) THEN
! WRITE(6,*) 'WARNING: station ',ksta,' found in ', &
! indexmpi(ksta),' and ',item1(ksta)
! END IF
indexmpi(ksta) = item1(ksta)
END DO
END DO
END IF
! Dump the station to processor mapping. Useful only for code debugging.
! if ( myproc == 0 ) then
! write(6,*) 'MAPPING: '
! do ksta=1,nobmpi
! write(6,*) ksta,indexmpi(ksta)
! end do
! endif
CALL mpupdatei(indexmpi,nobmpi)
!
! Everybody computes the same table of how many obs each processor owns.
!
kitem = 0
DO k=1,nobmpi
IF(indexmpi(k) >= 0) kitem(indexmpi(k)+1) = kitem(indexmpi(k)+1) + 1
END DO
kitemmax = 0
DO k=1,np
IF(kitem(k) > kitemmax) kitemmax = kitem(k)
ENDDO
RETURN
END SUBROUTINE mpiprocess
!########################################################################
!########################################################################
!######### #########
!######### SUBROUTINE MPIPROCESS_UPDATE #########
!######### #########
!######### Developed by #########
!######### Center for Analysis and Prediction of Storms #########
!######### University of Oklahoma #########
!######### #########
!########################################################################
!########################################################################
!SUBROUTINE mpiprocess_update(nobmpi,indexmpi,item1)
SUBROUTINE mpiprocess_update(nobmpi,indexmpi) 1,3
!-----------------------------------------------------------------------
!
! PURPOSE:
!
! Update the communications index table if it has been altered. This
! is a hook for cloud soundings.
!
!-----------------------------------------------------------------------
!
! AUTHOR: Kevin W. Thomas, CAPS
! December 2, 2005
!
! MODIFICATION HISTORY:
!
!-----------------------------------------------------------------------
!
! Force explicit declarations
!
!-----------------------------------------------------------------------
IMPLICIT NONE
!-----------------------------------------------------------------------
!
! Subroutine arguments
!
!-----------------------------------------------------------------------
INTEGER, INTENT(IN) :: nobmpi ! Total number of single-point
! observations stored in arrays
INTEGER, INTENT(INOUT) :: indexmpi(nobmpi) ! Owner
! INTEGER, INTENT(INOUT) :: item1(nobmpi) ! Work array
INTEGER :: item1(nobmpi)
!-----------------------------------------------------------------------
!
! Include files:
!
!-----------------------------------------------------------------------
INCLUDE 'mp.inc'
!-----------------------------------------------------------------------
!
! Misc. local variables
!
!-----------------------------------------------------------------------
INTEGER :: ksta
INTEGER :: ipt,jpt
INTEGER :: indom
INTEGER :: ierror
INTEGER :: k
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
! Beginning of executable code...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
! Collect and merge the data.
!
IF (myproc > 0 ) THEN
CALL mpsendi(indexmpi,nobmpi,0,1000+myproc,ierror)
ELSE
DO k=1,nprocs-1
CALL mprecvi(item1,nobmpi,k,1000+k,ierror)
DO ksta=1,nobmpi
IF ( item1(ksta) == -1 ) CYCLE
!-------------------------------------------------------------------------
!
! Since there are overlapping grids in MPI, it is possible for an ob to
! be available to more than one processor. We select the first processor.
! There is no need for more than one processor to make identical
! computations.
!
! The WARNING message is commented out, as it is useful for debugging,
! however, it will likely confuse anyone else.
!
! There is a potential issue affecting cloud soundings that doesn't exist
! in "mpiprocess" above. Stations *outside* of the domain are permitted.
! These are assigned a processor inside of "insert_sao1". It *is* possible
! for a point to be assigned to more than one processors, however, only one
! of them is correct, if the non-MPI and MPI solutions are to be the same.
!
! For now, we'll use the rule that processor 0 will always override any
! other ownership claims. This is based on one case. If other problems
! are seen, something else will have to be done.
!
!
!-------------------------------------------------------------------------
IF ( indexmpi(ksta) .eq. 0 ) CYCLE
! IF ( indexmpi(ksta) .ne. -1 ) THEN
! WRITE(6,*) 'WARNING: station ',ksta,' found in ', &
! indexmpi(ksta),' and ',item1(ksta)
! END IF
indexmpi(ksta) = item1(ksta)
END DO
END DO
END IF
! Dump the station to processor mapping. Useful only for code debugging.
! if ( myproc == 0 ) then
! write(6,*) 'MAPPING: '
! do ksta=1,nobmpi
! write(6,*) ksta,indexmpi(ksta)
! end do
! endif
CALL mpupdatei(indexmpi,nobmpi)
RETURN
END SUBROUTINE mpiprocess_update
SUBROUTINE make_mpi_map(mpi_map,nmap,iproc,jproc,nx,ny) 1
!-----------------------------------------------------------------------
!
! PURPOSE:
! Build a map of who needs to communicate with other processors.
!
!-----------------------------------------------------------------------
!
! AUTHOR: Kevin W. Thomas, CAPS
! October 6, 2006
!
! MODIFICATION HISTORY:
!
!-----------------------------------------------------------------------
!
! Force explicit declarations
!
!-----------------------------------------------------------------------
IMPLICIT NONE
!-----------------------------------------------------------------------
!
! Subroutine arguments
!
!-----------------------------------------------------------------------
INTEGER, INTENT(IN) :: nmap ! Number of map entries
INTEGER, INTENT(INOUT) :: mpi_map(nmap,2) ! The map
INTEGER, INTENT(IN) :: iproc ! Number of x-direction offsets
INTEGER, INTENT(IN) :: jproc ! Number of y-direction offsets
INTEGER, INTENT(IN) :: nx ! Number of x-direction grid pts
INTEGER, INTENT(IN) :: ny ! Number of y-direction grid pts
!-----------------------------------------------------------------------
!
! Include files:
!
!-----------------------------------------------------------------------
INCLUDE 'mp.inc'
!-----------------------------------------------------------------------
!
! Misc. local variables
!
!-----------------------------------------------------------------------
INTEGER :: i,j,k,n
INTEGER :: lx, ly
IF (mp_opt == 0) RETURN
mpi_map = -1
!
! Receive map.
!
k = 0
DO j=-jproc,jproc
ly = loc_y + j
IF (ly < 1 .OR. ly > nproc_y) THEN
k = k + (2 * iproc + 1 )
CYCLE
END IF
DO i=-iproc,iproc
k = k + 1
IF (i == 0 .and. j == 0) CYCLE
lx = loc_x + i
IF (lx < 1 .OR. lx > nproc_x) CYCLE
n = myproc + j * nproc_x + i
IF (n >= nprocs) CYCLE
mpi_map(k,2) = n
END DO
END DO
!
! Send map, just flip flop the receive map.
!
DO k=1,nmap
mpi_map(k,1) = mpi_map(nmap-k+1,2)
END DO
END SUBROUTINE make_mpi_map
SUBROUTINE mpi_1di_collect(m, nobmpi, indexmpi, & 1,4
np, kdata, kdatamax, mpi_map, nmap, tmps, tmpr )
!-----------------------------------------------------------------------
!
! PURPOSE:
!
! Collect all the processor dependent calculations and merge them into a
! single array which we will broadcast.
!
!-----------------------------------------------------------------------
!
! AUTHOR: Kevin W. Thomas, CAPS
! January 10, 2006
!
! MODIFICATION HISTORY:
!
!-----------------------------------------------------------------------
!
! Force explicit declarations
!
!-----------------------------------------------------------------------
IMPLICIT NONE
!-----------------------------------------------------------------------
!
! Subroutine arguments
!
!-----------------------------------------------------------------------
INTEGER, INTENT(IN) :: nobmpi ! Actual number of stations
INTEGER, INTENT(IN) :: indexmpi(nobmpi) ! Array saying which ob is on which
! processor.
REAL, INTENT(INOUT) :: m(nobmpi) ! Data to be collected and updated.
INTEGER, INTENT(IN) :: np ! Just "nprocs"
INTEGER, INTENT(IN) :: kdata(np) ! Number of obs owned by each processor
INTEGER, INTENT(IN) :: kdatamax ! Largest "kdata" value
INTEGER, INTENT(IN) :: nmap ! Number of entries in "mpi_map"
INTEGER, INTENT(IN) :: mpi_map(nmap,2)! Mapping scheme
REAL, INTENT(INOUT) :: tmps(kdatamax)
REAL, INTENT(INOUT) :: tmpr(kdatamax)
!-----------------------------------------------------------------------
!
! Include files:
!
!-----------------------------------------------------------------------
INCLUDE 'mp.inc'
!-----------------------------------------------------------------------
!
! Misc. local variables
!
!-----------------------------------------------------------------------
INTEGER :: istat
INTEGER :: isum
INTEGER :: itag
INTEGER :: ierror
INTEGER :: i, j, k, l, ksta
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
! Beginning of executable code...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
isum = kdatamax
!
! Save our data.
!
k = 0
DO j=1,nobmpi
IF (indexmpi(j) == myproc) THEN
k=k+1
tmps(k) = m(j)
END IF
END DO
!
! Sanity.
!
IF ( k .ne. kdata(myproc+1) ) THEN
WRITE(6,*) 'mpi_1di_collect inconsistency: ',k,kdata(myproc+1)
CALL arpsstop("mpi_1di_collect",1)
END IF
DO k=1,nmap
CALL inctag
itag = gentag
!
! Are we a sender?
!
IF (mpi_map(k,1) .NE. -1 ) THEN
CALL mpsendr(tmps,isum,mpi_map(k,1),itag,ierror)
ENDIF
!
! Are we a receiver?
!
IF (mpi_map(k,2) .NE. -1) THEN
CALL mprecvr(tmpr,isum,mpi_map(k,2),itag,ierror)
ELSE
CYCLE
END IF
l = 0
DO ksta=1,nobmpi
!
! Make sure we are the right processor.
!
IF (indexmpi(ksta) .NE. mpi_map(k,2)) CYCLE
l = l + 1
m(ksta) = tmpr(l)
END DO
END DO
RETURN
END SUBROUTINE mpi_1di_collect
SUBROUTINE mpi_1dr_collect(m, nobmpi, indexmpi, & 4,4
np, kdata, kdatamax, mpi_map, nmap, tmps, tmpr )
!-----------------------------------------------------------------------
!
! PURPOSE:
!
! Collect all the processor dependent calculations and merge them into a
! single array which we will broadcast.
!
!-----------------------------------------------------------------------
!
! AUTHOR: Kevin W. Thomas, CAPS
! January 10, 2006
!
! MODIFICATION HISTORY:
!
!-----------------------------------------------------------------------
!
! Force explicit declarations
!
!-----------------------------------------------------------------------
IMPLICIT NONE
!-----------------------------------------------------------------------
!
! Subroutine arguments
!
!-----------------------------------------------------------------------
INTEGER, INTENT(IN) :: nobmpi ! Actual number of stations
INTEGER, INTENT(IN) :: indexmpi(nobmpi) ! Array saying which ob is on which
! processor.
REAL, INTENT(INOUT) :: m(nobmpi) ! Data to be collected and updated.
INTEGER, INTENT(IN) :: np ! Just "nprocs"
INTEGER, INTENT(IN) :: kdata(np) ! Number of obs owned by each processor
INTEGER, INTENT(IN) :: kdatamax ! Largest "kdata" value
INTEGER, INTENT(IN) :: nmap ! Number of entries in "mpi_map"
INTEGER, INTENT(IN) :: mpi_map(nmap,2)! Mapping scheme
REAL, INTENT(INOUT) :: tmps(kdatamax)
REAL, INTENT(INOUT) :: tmpr(kdatamax)
!-----------------------------------------------------------------------
!
! Include files:
!
!-----------------------------------------------------------------------
INCLUDE 'mp.inc'
!-----------------------------------------------------------------------
!
! Misc. local variables
!
!-----------------------------------------------------------------------
INTEGER :: istat
INTEGER :: isum
INTEGER :: itag
INTEGER :: ierror
INTEGER :: i, j, k, l, ksta
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
! Beginning of executable code...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
isum = kdatamax
!
! Save our data.
!
k = 0
DO j=1,nobmpi
IF (indexmpi(j) == myproc) THEN
k=k+1
tmps(k) = m(j)
END IF
END DO
!
! Sanity.
!
IF ( k .ne. kdata(myproc+1) ) THEN
WRITE(6,*) 'mpi_1dr_collect inconsistency: ',k,kdata(myproc+1)
CALL arpsstop("mpi_1dr_collect",1)
END IF
DO k=1,nmap
CALL inctag
itag = gentag
!
! Are we a sender?
!
IF (mpi_map(k,1) .NE. -1 ) THEN
CALL mpsendr(tmps,isum,mpi_map(k,1),itag,ierror)
ENDIF
!
! Are we a receiver?
!
IF (mpi_map(k,2) .NE. -1) THEN
CALL mprecvr(tmpr,isum,mpi_map(k,2),itag,ierror)
ELSE
CYCLE
END IF
l = 0
DO ksta=1,nobmpi
!
! Make sure we are the right processor.
!
IF (indexmpi(ksta) .NE. mpi_map(k,2)) CYCLE
l = l + 1
m(ksta) = tmpr(l)
END DO
END DO
RETURN
END SUBROUTINE mpi_1dr_collect
SUBROUTINE mpi_2dr_collect(q, nvar, mxmpi, nobmpi, indexmpi, & 9,4
np, kdata, kdatamax, mpi_map, nmap, tmps, tmpr )
!-----------------------------------------------------------------------
!
! PURPOSE:
!
! Collect all the processor dependent calculations and merge them into a
! single array which we will broadcast.
!
!-----------------------------------------------------------------------
!
! AUTHOR: Kevin W. Thomas, CAPS
! January 10, 2006
!
! MODIFICATION HISTORY:
!
!-----------------------------------------------------------------------
!
! Force explicit declarations
!
!-----------------------------------------------------------------------
IMPLICIT NONE
!-----------------------------------------------------------------------
!
! Subroutine arguments
!
!-----------------------------------------------------------------------
INTEGER, INTENT(IN) :: nvar ! Number of variables
INTEGER, INTENT(IN) :: mxmpi ! Max possible stations
INTEGER, INTENT(IN) :: nobmpi ! Actual number of stations
INTEGER, INTENT(IN) :: indexmpi(nobmpi) ! Array saying which ob is on which
! processor.
REAL, INTENT(INOUT) :: q(nvar,mxmpi) ! Data to be collected and updated.
INTEGER, INTENT(IN) :: np ! Just "nprocs"
INTEGER, INTENT(IN) :: kdata(np) ! Number of obs owned by each processor
INTEGER, INTENT(IN) :: kdatamax ! Largest "kdata" value
INTEGER, INTENT(IN) :: nmap ! Number of entries in "mpi_map"
INTEGER, INTENT(IN) :: mpi_map(nmap,2)! Mapping scheme
REAL, INTENT(INOUT) :: tmps(nvar,kdatamax)
REAL, INTENT(INOUT) :: tmpr(nvar,kdatamax)
!-----------------------------------------------------------------------
!
! Include files:
!
!-----------------------------------------------------------------------
INCLUDE 'mp.inc'
!-----------------------------------------------------------------------
!
! Misc. local variables
!
!-----------------------------------------------------------------------
INTEGER :: istat
INTEGER :: isum
INTEGER :: itag
INTEGER :: ierror
INTEGER :: i, j, k, l, ksta
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
! Beginning of executable code...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
isum = nvar * kdatamax
!
! Save our data.
!
k = 0
DO j=1,nobmpi
IF (indexmpi(j) == myproc) THEN
k=k+1
DO i=1,nvar
tmps(i,k) = q(i,j)
END DO
END IF
END DO
!
! Sanity.
!
IF ( k .ne. kdata(myproc+1) ) THEN
WRITE(6,*) 'mpi_2dr_collect inconsistency: ',k,kdata(myproc+1)
CALL arpsstop("mpi_2dr_collect",1)
END IF
DO k=1,nmap
CALL inctag
itag = gentag
!
! Are we a sender?
!
IF (mpi_map(k,1) .NE. -1 ) THEN
CALL mpsendr(tmps,isum,mpi_map(k,1),itag,ierror)
ENDIF
!
! Are we a receiver?
!
IF (mpi_map(k,2) .NE. -1) THEN
CALL mprecvr(tmpr,isum,mpi_map(k,2),itag,ierror)
ELSE
CYCLE
END IF
l = 0
DO ksta=1,nobmpi
!
! Make sure we are the right processor.
!
IF (indexmpi(ksta) .NE. mpi_map(k,2)) CYCLE
l = l + 1
DO i=1,nvar
q(i,ksta) = tmpr(i,l)
END DO
END DO
END DO
RETURN
END SUBROUTINE mpi_2dr_collect
SUBROUTINE mpi_2dcr_collect(q, mxmpi, nvar, nobmpi, indexmpi ) 2,4
!-----------------------------------------------------------------------
!
! PURPOSE:
!
! Collect all the processor dependent calculations and merge them into a
! single array which we will broadcast.
!
! Same as "mpi_2dr_collect" except the subscripts are reversed. Most of
! the arrays have the station index as the last subscript. For "cloud
! soundings, the station index is the first subscript.
!
!-----------------------------------------------------------------------
!
! AUTHOR: Kevin W. Thomas, CAPS
! September 15, 2006
!
! MODIFICATION HISTORY:
!
!-----------------------------------------------------------------------
!
! Force explicit declarations
!
!-----------------------------------------------------------------------
IMPLICIT NONE
!-----------------------------------------------------------------------
!
! Subroutine arguments
!
!-----------------------------------------------------------------------
INTEGER, INTENT(IN) :: nvar ! Number of variables
INTEGER, INTENT(IN) :: mxmpi ! Max possible stations
INTEGER, INTENT(IN) :: nobmpi ! Actual number of stations
INTEGER, INTENT(IN) :: indexmpi(nobmpi) ! Array saying which ob is on which
! processor.
REAL, INTENT(INOUT) :: q(mxmpi,nvar) ! Data to be collected and updated.
!-----------------------------------------------------------------------
!
! Include files:
!
!-----------------------------------------------------------------------
INCLUDE 'mp.inc'
!-----------------------------------------------------------------------
!
! Misc. local variables
!
!-----------------------------------------------------------------------
REAL, ALLOCATABLE :: tmp(:,:)
INTEGER :: istat
INTEGER :: isum
INTEGER :: ierror
INTEGER :: i, k, ksta
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
! Beginning of executable code...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
ALLOCATE(tmp(mxmpi,nvar),STAT=istat)
CALL check_alloc_status(istat, "mpi_2dcr_collect:tmp")
isum = nvar * mxmpi
!
! Collect and merge the data.
!
IF (myproc > 0 ) THEN
CALL mpsendr(q,isum,0,4000+myproc,ierror)
ELSE
DO k=1,nprocs-1
CALL mprecvr(tmp,isum,k,4000+k,ierror)
!
! We only have to process "nobmpi" of the obs, even the array has space for
! "mxmpi" obs.
!
DO ksta=1,nobmpi
!
! Make sure we are the right processor.
!
IF (indexmpi(ksta) .NE. k) CYCLE
DO i=1,nvar
q(ksta,i) = tmp(ksta,i)
END DO
END DO
END DO
END IF
CALL mpupdater(q,isum)
DEALLOCATE(tmp)
RETURN
END SUBROUTINE mpi_2dcr_collect
SUBROUTINE mpi_3dr_collect(q, nvar, nzmpi, mxmpi, nobmpi, indexmpi, & 9,4
np, kdata, kdatamax, mpi_map, nmap, tmps, tmpr)
!-----------------------------------------------------------------------
!
! PURPOSE:
!
! Collect all the processor dependent calculations and merge them into a
! single array which we will broadcast.
!
!-----------------------------------------------------------------------
!
! AUTHOR: Kevin W. Thomas, CAPS
! January 10, 2006
!
! MODIFICATION HISTORY:
!
!-----------------------------------------------------------------------
!
! Force explicit declarations
!
!-----------------------------------------------------------------------
IMPLICIT NONE
!-----------------------------------------------------------------------
!
! Subroutine arguments
!
!-----------------------------------------------------------------------
INTEGER, INTENT(IN) :: nvar ! Number of variables
INTEGER, INTENT(IN) :: nzmpi ! Number of vertical levels
INTEGER, INTENT(IN) :: mxmpi ! Max possible stations
INTEGER, INTENT(IN) :: nobmpi ! Actual number of stations
INTEGER, INTENT(IN) :: indexmpi(nobmpi) ! Array saying which ob is on which
! processor.
REAL, INTENT(INOUT) :: q(nvar,nzmpi,mxmpi)! Data to be collected and updated.
INTEGER, INTENT(IN) :: np ! Just "nprocs"
INTEGER, INTENT(IN) :: kdata(np) ! Number of obs owned by each processor
INTEGER, INTENT(IN) :: kdatamax ! Largest "kdata" value
INTEGER, INTENT(IN) :: nmap ! Number of entries in "mpi_map"
INTEGER, INTENT(IN) :: mpi_map(nmap,2)! Mapping scheme
REAL, INTENT(INOUT) :: tmps(nvar,nzmpi,kdatamax)
REAL, INTENT(INOUT) :: tmpr(nvar,nzmpi,kdatamax)
!-----------------------------------------------------------------------
!
! Include files:
!
!-----------------------------------------------------------------------
INCLUDE 'mp.inc'
!-----------------------------------------------------------------------
!
! Misc. local variables
!
!-----------------------------------------------------------------------
INTEGER :: istat
INTEGER :: isum
INTEGER :: itag
INTEGER :: ierror
INTEGER :: i, j, k, l, m, ksta
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
! Beginning of executable code...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
isum = nvar * nzmpi *kdatamax
!
! Save our data.
!
m = 0
DO k=1,nobmpi
IF (indexmpi(k) == myproc) THEN
m=m+1
DO j=1,nzmpi
DO i=1,nvar
tmps(i,j,m) = q(i,j,k)
END DO
END DO
END IF
END DO
!
! Sanity.
!
IF ( m .ne. kdata(myproc+1) ) THEN
WRITE(6,*) 'mpi_3dr_collect inconsistency: ',m,kdata(myproc+1)
CALL arpsstop("mpi_3dr_collect",1)
END IF
DO l=1,nmap
CALL inctag
itag = gentag
!
! Are we a sender?
!
IF (mpi_map(l,1) .NE. -1 ) THEN
CALL mpsendr(tmps,isum,mpi_map(l,1),itag,ierror)
ENDIF
!
! Are we a receiver?
!
IF (mpi_map(l,2) .NE. -1) THEN
CALL mprecvr(tmpr,isum,mpi_map(l,2),itag,ierror)
ELSE
CYCLE
END IF
m = 0
DO ksta=1,nobmpi
!
! Make sure we are the right processor.
!
IF (indexmpi(ksta) .NE. mpi_map(l,2)) CYCLE
m = m + 1
DO j=1,nzmpi
DO i=1,nvar
q(i,j,ksta) = tmpr(i,j,m)
END DO
END DO
END DO
END DO
RETURN
END SUBROUTINE mpi_3dr_collect