!######################################################################## !######################################################################## !######### ######### !######### 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