[mpich-discuss] Internal memory allocation error?

[Brian Harker]

Hi list-

Here's my sample code for those that are wary of opening email
attachments  :)  Didn't think about that until just now.

PROGRAM mpi_main

USE subroutines  ! contains subroutine "invert_pixel"
IMPLICIT NONE

INCLUDE "mpif.h"

! total number of pixels
INTEGER, PARAMETER :: np = nx * ny   !nx,ny specified in module "subroutines"

! parameter at each pixel
DOUBLE PRECISION :: par

! full-size parameter array
DOUBLE PRECISION, DIMENSION(nx,ny) :: map

! pixel coordinates
INTEGER, DIMENSION(2) :: pxl

! dummy termination message
INTEGER, PARAMETER :: term = 0

! MPI-related
INTEGER :: proc_id
INTEGER :: proc_num
INTEGER :: master
INTEGER :: ierr
INTEGER :: sender
INTEGER :: tag
INTEGER :: numsent
INTEGER :: request
INTEGER, DIMENSION(MPI_STATUS_SIZE) :: status

! local indices
INTEGER :: i

!********************************************************************!
!************************** BEGIN PROGRAM ***************************!
!********************************************************************!
master = 0

! initialize MPI libraries...
CALL MPI_Init( ierr )
CALL MPI_Comm_size( MPI_COMM_WORLD, proc_num, ierr )
CALL MPI_Comm_rank( MPI_COMM_WORLD, proc_id, ierr )

! --------------------------------------------- !
!             master process code               !
! --------------------------------------------- !
IF ( proc_id == master ) THEN

 ! dispatch first group of pixels to slave processes...
 numsent = 0
 DO i = 1, proc_num - 1

  pxl(1) = INT(numsent/ny) + 1
  pxl(2) = MOD(numsent,ny) + 1
  CALL MPI_Send( pxl, 2, MPI_INTEGER, i, numsent+1, MPI_COMM_WORLD, ierr )
  numsent = numsent + 1

 END DO

 mstr: DO

        ! receive inferred parameter back from a slave...
        CALL MPI_Recv( par, 1, MPI_DOUBLE_PRECISION, MPI_ANY_SOURCE,
MPI_ANY_TAG, MPI_COMM_WORLD, status, ierr )
        sender = status(MPI_SOURCE)
        tag = status(MPI_TAG)

        ! assemble into full-size array...
        x = INT(tag/ny) + 1
        y = MOD(tag,ny) + 1

        map(x,y) = par

        IF ( tag == np ) THEN
         ! all done, send termination message...
         DO j = 1, proc_num - 1
          CALL MPI_Send( term, 1, MPI_INTEGER, j, 0, MPI_COMM_WORLD, ierr )
         END DO
         EXIT mstr
        END IF

        ! send the next available pixel to same slave...
        pxl(1) = INT((numsent+1) / ny) + 1
        pxl(2) = MOD((numsent+1), ny) + 1

        CALL MPI_Send( pxl, 2, MPI_INTEGER, sender, numsent+1,
MPI_COMM_WORLD, ierr )
        numsent = numsent + 1

       END DO mstr
! --------------------------------------------- !
!              slave process code               !
! --------------------------------------------- !
ELSE

 slv: DO

       ! receive pixel coordinates from master...
       CALL MPI_Irecv( pxl, 2, MPI_INTEGER, master, MPI_ANY_TAG,
MPI_COMM_WORLD, request, ierr )
       CALL MPI_Wait( request, status, ierr )
       tag = status(MPI_TAG)
       IF ( tag == 0 ) THEN
        ! all done, exit program...
        EXIT slv
       END IF

       ! call genetic algorithm for inversion...
       CALL invert_pixel( pxl, par )

       ! send parameter result back to master...
       CALL MPI_Send( par, 1, MPI_DOUBLE_PRECISION, master, tag,
MPI_COMM_WORLD, ierr )
      END DO slv

END IF

! shut down MPI...
CALL MPI_Finalize( ierr )
WRITE(*,*) ""
IF ( ierr == 0 ) WRITE(*,*) "Goodbye from process",proc_id

!********************************************************************!
!**************************** END PROGRAM ***************************!
!********************************************************************!

STOP
END PROGRAM mpi_main




-- 
Cheers,
Brian
brian.harker at gmail.com


"In science, there is only physics; all the rest is stamp-collecting."

-Ernest Rutherford