Blame test/mpi/f90/rma/winscale2f90.f90

Packit Service c5cf8c
! This file created from f77/rma/winscale2f.f with f77tof90
Packit Service c5cf8c
! -*- Mode: Fortran; -*- 
Packit Service c5cf8c
!
Packit Service c5cf8c
!  (C) 2003 by Argonne National Laboratory.
Packit Service c5cf8c
!      See COPYRIGHT in top-level directory.
Packit Service c5cf8c
!
Packit Service c5cf8c
      program main
Packit Service c5cf8c
      use mpi
Packit Service c5cf8c
      integer ierr, errs
Packit Service c5cf8c
      integer win, intsize
Packit Service c5cf8c
      integer left, right, rank, size
Packit Service c5cf8c
      integer nrows, ncols
Packit Service c5cf8c
      parameter (nrows=25,ncols=10)
Packit Service c5cf8c
      integer buf(1:nrows,0:ncols+1)
Packit Service c5cf8c
      integer comm, group, group2, ans
Packit Service c5cf8c
      integer nneighbors, nbrs(2), i, j
Packit Service c5cf8c
      logical mtestGetIntraComm
Packit Service c5cf8c
      logical flag
Packit Service c5cf8c
! Include addsize defines asize as an address-sized integer
Packit Service c5cf8c
      integer (kind=MPI_ADDRESS_KIND) asize
Packit Service c5cf8c
Packit Service c5cf8c
      
Packit Service c5cf8c
      errs = 0
Packit Service c5cf8c
      call mtest_init( ierr )
Packit Service c5cf8c
Packit Service c5cf8c
      call mpi_type_size( MPI_INTEGER, intsize, ierr )
Packit Service c5cf8c
      do while( mtestGetIntraComm( comm, 2, .false. ) ) 
Packit Service c5cf8c
         asize = nrows * (ncols + 2) * intsize
Packit Service c5cf8c
         call mpi_win_create( buf, asize, intsize * nrows,  &
Packit Service c5cf8c
      &                        MPI_INFO_NULL, comm, win, ierr )
Packit Service c5cf8c
         
Packit Service c5cf8c
! Create the group for the neighbors
Packit Service c5cf8c
         call mpi_comm_size( comm, size, ierr )
Packit Service c5cf8c
         call mpi_comm_rank( comm, rank, ierr )
Packit Service c5cf8c
         nneighbors = 0
Packit Service c5cf8c
         left = rank - 1
Packit Service c5cf8c
         if (left .lt. 0) then
Packit Service c5cf8c
            left = MPI_PROC_NULL
Packit Service c5cf8c
         else
Packit Service c5cf8c
            nneighbors = nneighbors + 1
Packit Service c5cf8c
            nbrs(nneighbors) = left
Packit Service c5cf8c
         endif
Packit Service c5cf8c
         right = rank + 1
Packit Service c5cf8c
         if (right .ge. size) then
Packit Service c5cf8c
            right = MPI_PROC_NULL
Packit Service c5cf8c
         else
Packit Service c5cf8c
            nneighbors = nneighbors + 1
Packit Service c5cf8c
            nbrs(nneighbors) = right
Packit Service c5cf8c
         endif
Packit Service c5cf8c
         call mpi_comm_group( comm, group, ierr )
Packit Service c5cf8c
         call mpi_group_incl( group, nneighbors, nbrs, group2, ierr )
Packit Service c5cf8c
         call mpi_group_free( group, ierr )
Packit Service c5cf8c
!
Packit Service c5cf8c
! Initialize the buffer 
Packit Service c5cf8c
         do i=1,nrows
Packit Service c5cf8c
            buf(i,0)       = -1
Packit Service c5cf8c
            buf(i,ncols+1) = -1
Packit Service c5cf8c
         enddo
Packit Service c5cf8c
         do j=1,ncols
Packit Service c5cf8c
            do i=1,nrows
Packit Service c5cf8c
               buf(i,j) = rank * (ncols * nrows) + i + (j-1) * nrows
Packit Service c5cf8c
            enddo
Packit Service c5cf8c
         enddo
Packit Service c5cf8c
         call mpi_win_post( group2, 0, win, ierr )
Packit Service c5cf8c
         call mpi_win_start( group2, 0, win, ierr )
Packit Service c5cf8c
!         
Packit Service c5cf8c
         asize = ncols+1
Packit Service c5cf8c
         call mpi_put( buf(1,1), nrows, MPI_INTEGER, left, asize, &
Packit Service c5cf8c
      &                 nrows, MPI_INTEGER, win, ierr )
Packit Service c5cf8c
         asize = 0
Packit Service c5cf8c
         call mpi_put( buf(1,ncols), nrows, MPI_INTEGER, right, asize,  &
Packit Service c5cf8c
      &                 nrows, MPI_INTEGER, win, ierr )
Packit Service c5cf8c
!         
Packit Service c5cf8c
         call mpi_win_complete( win, ierr )
Packit Service c5cf8c
         flag = .false.
Packit Service c5cf8c
         do while (.not. flag)
Packit Service c5cf8c
            call mpi_win_test( win, flag, ierr )
Packit Service c5cf8c
         enddo
Packit Service c5cf8c
!
Packit Service c5cf8c
! Check the results
Packit Service c5cf8c
         if (left .ne. MPI_PROC_NULL) then
Packit Service c5cf8c
            do i=1, nrows
Packit Service c5cf8c
               ans = rank * (ncols * nrows) - nrows + i
Packit Service c5cf8c
               if (buf(i,0) .ne. ans) then
Packit Service c5cf8c
                  errs = errs + 1
Packit Service c5cf8c
                  if (errs .le. 10) then
Packit Service c5cf8c
                     print *, ' buf(',i,',0) = ', buf(i,0),  &
Packit Service c5cf8c
      &    'expected ', ans
Packit Service c5cf8c
                  endif
Packit Service c5cf8c
               endif
Packit Service c5cf8c
            enddo
Packit Service c5cf8c
         endif
Packit Service c5cf8c
         if (right .ne. MPI_PROC_NULL) then
Packit Service c5cf8c
            do i=1, nrows
Packit Service c5cf8c
               ans = (rank+1) * (ncols * nrows) + i
Packit Service c5cf8c
               if (buf(i,ncols+1) .ne. ans) then
Packit Service c5cf8c
                  errs = errs + 1
Packit Service c5cf8c
                  if (errs .le. 10) then
Packit Service c5cf8c
                     print *, ' buf(',i,',',ncols+1,') = ',  &
Packit Service c5cf8c
      &                          buf(i,ncols+1), ' expected ', ans
Packit Service c5cf8c
                  endif
Packit Service c5cf8c
               endif
Packit Service c5cf8c
            enddo
Packit Service c5cf8c
         endif
Packit Service c5cf8c
         call mpi_group_free( group2, ierr )
Packit Service c5cf8c
         call mpi_win_free( win, ierr )
Packit Service c5cf8c
         call mtestFreeComm( comm )
Packit Service c5cf8c
      enddo
Packit Service c5cf8c
Packit Service c5cf8c
      call mtest_finalize( errs )
Packit Service c5cf8c
      end