Scrambler  1
mpi_transmission.f90
Go to the documentation of this file.
00001 !#########################################################################
00002 !               
00003 !    Copyright (C) 2003-2012 Department of Physics and Astronomy,
00004 !                            University of Rochester,
00005 !                            Rochester, NY
00006 !
00007 !    mpi_transmission.f90 is part of AstroBEAR.
00008 !
00009 !    AstroBEAR is free software: you can redistribute it and/or modify    
00010 !    it under the terms of the GNU General Public License as published by 
00011 !    the Free Software Foundation, either version 3 of the License, or    
00012 !    (at your option) any later version.
00013 !
00014 !    AstroBEAR is distributed in the hope that it will be useful, 
00015 !    but WITHOUT ANY WARRANTY; without even the implied warranty of
00016 !    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
00017 !    GNU General Public License for more details.
00018 !
00019 !    You should have received a copy of the GNU General Public License
00020 !    along with AstroBEAR.  If not, see <http://www.gnu.org/licenses/>.
00021 !
00022 !#########################################################################
00025 
00029 
00034 MODULE MpiTransmission
00035 
00036    USE MessageDeclarations
00037    USE GlobalDeclarations
00038 #if defined PTH
00039    USE PthDeclarations
00040 #endif
00041    USE Timing
00042    IMPLICIT NONE
00043    PRIVATE
00044 
00045    PUBLIC SetUpSend, SetUpRecv
00046    PUBLIC SendPackedMessage, ReceivePackedMessage, CancelLastMessageBlockRecv
00047    PUBLIC WaitOnMessageBlocks, WaitOnAnyMessageGroupRecv, WaitOnAllMessageGroupSends
00048    PUBLIC GetMGAllRequestsArray
00049 CONTAINS
00050 
00053    SUBROUTINE SetUpSend(message)
00054 
00055       TYPE(PackedMessage), POINTER :: message
00056 
00057       ! Verify that all required objects are allocated.
00058       IF (.NOT. ASSOCIATED(message)) THEN
00059          PRINT *, "SetUpSend() error: message not associated."
00060          STOP
00061       END IF
00062 
00063       CALL AddMessageBlock(message, .NOT. ASSOCIATED(message%last_block), message%buffer_size)
00064 
00065    END SUBROUTINE SetUpSend
00066 
00069    SUBROUTINE SendPackedMessage(message)
00070 
00071       TYPE(PackedMessage), POINTER :: message
00072 
00073       INTEGER :: mpi_request
00074       INTEGER :: iErr
00075       INTEGER :: send_buffer_size
00076 
00077 
00078       ! Verify that all required objects are allocated.
00079       IF (.NOT. ASSOCIATED(message)) THEN
00080          PRINT *, "SendPackedMessage() error: message not associated."
00081          STOP
00082 
00083       ELSE IF (.NOT. ASSOCIATED(message%last_block)) THEN
00084          PRINT *, "SendPackedMessage() error: no message block allocated."
00085          STOP
00086 
00087       END IF
00088 
00089       ! Allocate the send buffer as a 1:offset array.
00090       send_buffer_size = message%last_block%block_offset
00091       message%last_block%buffer_size = send_buffer_size
00092 
00093       ! Call a non-blocking send.  The unique tags have been removed from this scheme so that the
00094       ! buffers will be received in the order they are sent.     
00095       
00096       CALL MPI_ISEND(message%last_block%buffer, &
00097            send_buffer_size, &
00098            MPI_PACKED, &
00099            message%remote_proc, &
00100            !message%tag + (message%level + 2) * TAG_LEVEL_MULTIPLIER + message%nMessages, &
00101            (message%tag*(MaxDepth+3) + (message%level + 2)) * MAX_MESSAGE_PIECES + message%nMessages, &
00102            MPI_COMM_WORLD, &
00103            mpi_request, &
00104            iErr)
00105 
00106 !      CALL MPI_SSEND(message%last_block%buffer, &
00107 !           send_buffer_size, &
00108 !           MPI_PACKED, &
00109 !           message%remote_proc, &
00110 !           message%tag + (message%level + 2) * TAG_LEVEL_MULTIPLIER + message%nMessages, &
00111 !           MPI_COMM_WORLD, &
00112 !           iErr)
00113 !      mpi_request = 0
00114 
00115       ! Store the MPI request handle in the message object.
00116       CALL AddMpiRequest(message, mpi_request, .NOT. ASSOCIATED(message%last_request))
00117 
00118       ! If the message is closed, then allocate the next message block.  This assumes that it
00119       ! is exceedingly unlikely that a message will be exactly one block long (i.e., that the
00120       ! odds of sending an additional block with nothing in it are negligible).
00121       IF (.NOT. message%closed)  CALL SetUpSend(message)
00122 !      write(*,*) 'done'
00123    END SUBROUTINE SendPackedMessage
00124 
00127    SUBROUTINE WaitOnMessageBlocks(message)
00128      USE GlobalDeclarations
00129       TYPE(PackedMessage), POINTER :: message
00130 
00131       INTEGER, POINTER, DIMENSION(:) :: req_array
00132       INTEGER :: iErr
00133 
00134 
00135       IF (.NOT. ASSOCIATED(message)) THEN
00136          PRINT *, "WaitOnMessageBlocks() error: no message associated."
00137          STOP
00138       END IF
00139 
00140       ! Retrieve the request list in array form.
00141       NULLIFY(req_array)
00142       CALL GetRequestArray(message, req_array, .TRUE., .TRUE.)
00143 
00144 !PRINT *
00145 !PRINT *, "req_array = ", req_array
00146 !PRINT *, "SIZE(req_array) = ", SIZE(req_array)
00147 !PRINT *, "message level = ", message%level
00148 !PRINT *, "MPI_WAITALL: req_array size = ", SIZE(req_array)
00149 !PRINT *, "MPI_WAITALL: sm_group%StageTag = ", message%tag
00150 !PRINT *, "MPI_WAITALL: modified tag = ", message%tag + (message%level + 2) * 100
00151 !PRINT *, "message%nMessages = ", message%nMessages
00152 !PRINT *
00153 
00154       ! Complete all outstanding waits.
00155 # if defined PTH
00156       IF (iThreaded == THREADED) THEN
00157          CALL pth_MPI_WAITALL(message%nMessages, req_array, iErr)
00158       ELSE
00159          CALL StartTimer(iBarrier, message%level)
00160          CALL MPI_WAITALL(message%nMessages, req_array, MPI_STATUSES_IGNORE, iErr)
00161          CALL StopTimer(iBarrier, message%level)
00162       END IF
00163 # else
00164       CALL StartTimer(iBarrier, message%level)
00165       CALL MPI_WAITALL(message%nMessages, req_array, MPI_STATUSES_IGNORE, iErr)
00166       CALL StopTimer(iBarrier, message%level)
00167 
00168 # endif
00169 
00170       IF (ASSOCIATED(req_array)) THEN
00171           DEALLOCATE(req_array)
00172           NULLIFY(req_array)
00173       END IF
00174 
00175    END SUBROUTINE WaitOnMessageBlocks
00176 
00179    SUBROUTINE SetUpRecv(message)
00180 
00181      TYPE(PackedMessage), POINTER :: message
00182 
00183      INTEGER :: iErr
00184      INTEGER :: mpi_request
00185 
00186 
00187      IF (.NOT. ASSOCIATED(message)) THEN
00188         PRINT *, "SetUpRecv() error: no message object associated with pointer."
00189         STOP
00190      END IF
00191 
00192      ! Create a new message block.
00193      CALL AddMessageBlock(message, .NOT. ASSOCIATED(message%last_block), message%buffer_size)
00194 
00195      !      PRINT *, "Recv ASSOCIATED(message) = ", ASSOCIATED(message)
00196      !      PRINT *, "Recv ASSOCIATED(buffer) = ", ASSOCIATED(message%last_block)
00197      !      PRINT *, "Recv remote_proc = ", message%remote_proc
00198      !      PRINT *, "Recv nMessages = ", message%nMessages
00199      !      PRINT *, "Recv message tag = ", message%tag
00200      !      PRINT *, "Recv message level = ", message%level
00201      !      PRINT *, "Recv modified tag = ", message%tag + (message%level + 2) * 100 + message%nMessages - 1
00202 
00203      ! Call a non-blocking receive on the current message buffer.
00204      CALL MPI_IRECV(message%last_block%buffer, &
00205           message%buffer_size, &
00206           MPI_PACKED, &
00207           message%remote_proc, &
00208           !message%tag + (message%level + 2) * TAG_LEVEL_MULTIPLIER + message%nMessages, &
00209           (message%tag*(MAXDEPTH+3) + (message%level + 2)) * MAX_MESSAGE_PIECES + message%nMessages, &
00210           MPI_COMM_WORLD, &
00211           mpi_request, &
00212           ierr)
00213 
00214      CALL AddMpiRequest(message, mpi_request, .NOT. ASSOCIATED(message%last_request))
00215 
00216      !      write(COMM_LOG_HANDLE,*) 'IReceiving', MPI_WTIME()-InitTime, 100*message%level+(message%nMessages-1)+message%tag/1000, message%tag + (message%level + 2) * TAG_LEVEL_MULTIPLIER + message%nMessages, message%remote_proc, message%last_request%request
00217 
00218 
00219      !IF ((message%tag == 7000) .AND. (message%level == 1) .AND. (MPI_id == 0)) THEN
00220      !PRINT "('SetUpRecv::request ', i4, ' added by proc ', i1, '.')", message%last_request%request, message%remote_proc
00221      !END IF
00222    END SUBROUTINE SetUpRecv
00223 
00226    SUBROUTINE ReceivePackedMessage(message)
00227 
00228       TYPE(PackedMessage), POINTER :: message
00229 
00230       INTEGER :: last_message
00231       INTEGER :: iErr
00232       INTEGER, DIMENSION(MPI_STATUS_SIZE) :: mpi_status
00233       INTEGER :: message_size
00234 
00235 
00236       IF (message%current_request%completed) THEN
00237          IF (ASSOCIATED(message%current_request%next)) THEN
00238             message%current_request => message%current_request%next
00239             message%current_block => message%current_block%next
00240          ELSE
00241             write(*,*) 'Error - trying to unpack additional message blocks without posting receives'
00242             write(*,*) 'If message is not a multi-block message - this could be due to a pre-calculation error'
00243             write(*,*) 'message%lMultiBlock=', message%lMultiBlock, message%tag, message%level, MPI_ID
00244             STOP
00245          END IF
00246       END IF
00247 # if defined PTH
00248       IF (iThreaded == THREADED) THEN
00249          CALL pth_MPI_WAIT(message%current_request%request, mpi_status, iErr)
00250       ELSE
00251          CALL StartTimer(iBarrier, message%level)
00252          CALL MPI_WAIT(message%current_request%request, mpi_status, iErr)
00253          CALL StopTimer(iBarrier, message%level)
00254       END IF
00255 # else
00256 
00257       CALL StartTimer(iBarrier, message%level)
00258       CALL MPI_WAIT(message%current_request%request, mpi_status, iErr)
00259       CALL StopTimer(iBarrier, message%level)
00260 # endif
00261       message%current_request%completed = .TRUE.
00262 
00263       ! Get the message's size in bytes and cache it in the message's buffer size.
00264       CALL MPI_GET_COUNT(mpi_status, MPI_PACKED, message_size, iErr)
00265 
00266       message%current_block%buffer_size = message_size
00267 
00268       IF (message%lMultiBlock) THEN
00269          ! Post the next receive; if it turns out to be unnecessary it will be
00270          ! cancelled when ClosePackedMessage() is called.
00271          CALL SetUpRecv(message)
00272       END IF
00273    END SUBROUTINE ReceivePackedMessage
00274 
00277    SUBROUTINE CancelLastMessageBlockRecv(message)
00278 
00279        TYPE(PackedMessage), POINTER :: message
00280 
00281        INTEGER :: iErr
00282        INTEGER, DIMENSION(MPI_STATUS_SIZE) :: mpi_status
00283 
00284        ! A new receive is always posted upon completion of the old one; this call to MPI_CANCEL()
00285        ! eliminates the final receive.
00286 !       write(*,*) MPI_ID, message%last_request%request
00287        CALL MPI_CANCEL(message%last_request%request, iErr)
00288 
00289        CALL StartTimer(iBarrier, message%level)
00290        CALL MPI_WAIT(message%last_request%request, mpi_status, iErr)
00291        CALL StopTimer(iBarrier, message%level)
00292        ! A new, extraneous message block will have been posted for the new receive; these lines do not
00293        ! delete the block, but it does clear out any statistics that might otherwise be misleading.
00294        message%last_request%request = 0
00295        message%last_block%buffer_size = 0
00296 
00297        message%nMessages = message%nMessages - 1
00298         
00299    END SUBROUTINE CancelLastMessageBlockRecv
00300 
00305    SUBROUTINE WaitOnAnyMessageGroupRecv(sm_group, message, request_type)
00306 
00307       TYPE(StageMessageGroup) :: sm_group
00308       TYPE(PackedMessage), POINTER :: message
00309       INTEGER :: request_type
00310 
00311       INTEGER :: i
00312       INTEGER :: message_count
00313       INTEGER, POINTER, DIMENSION(:) :: req_array
00314       INTEGER :: iErr
00315       INTEGER :: req_index
00316       TYPE(MessageList), POINTER :: msg_list
00317       INTEGER, DIMENSION(MPI_STATUS_SIZE) :: mpi_status
00318       CHARACTER, DIMENSION(MPI_MAX_ERROR_STRING) :: err_string
00319       INTEGER :: iErrClass
00320       INTEGER :: message_size
00321 
00322 
00323 
00324       req_index = 0
00325       mpi_status = 0
00326 
00327       NULLIFY(message)
00328 
00329       message_count = sm_group%nPackedMessages
00330       
00331       IF (message_count == 0) RETURN
00332       ! Setting the lOpenOnly flag to true ensures that only open requests will be returned;
00333       ! otherwise, a completed request would make the MPI_WAITANY call immediately return true 
00334       ! even if open requests remained.
00335       CALL GetMGFirstRequestArray(sm_group, req_array, .TRUE.)
00336 
00337       ! If there are any open requests, then wait until one completes and then return a reference
00338       ! to that request's message.
00339       IF (ASSOCIATED(req_array)) THEN
00340 !PRINT "('WaitOnAnyMessageGroupRecv(MPI_id = ', i1, '; level = ', i2, ')::req_array_size = ', i6, '.')", MPI_id, sm_group%level, SIZE(req_array)
00341 !PRINT *, "WaitOnAnyMsgGrpRecv(", MPI_id, ",", sm_group%level, ") req_array = ", req_array
00342 !PRINT *, "WaitOnAnyMsgGrpRecv(", MPI_id, ",", sm_group%level, ") req_index = ", req_index
00343 # if defined PTH
00344          IF (iThreaded == THREADED) THEN
00345             CALL pth_MPI_WAITANY(SIZE(req_array), req_array, req_index, mpi_status, iErr)
00346          ELSE
00347             CALL StartTimer(iBarrier, sm_group%level)
00348             CALL MPI_WAITANY(SIZE(req_array), req_array, req_index, mpi_status, iErr)
00349             CALL StopTimer(iBarrier, sm_group%level)
00350 
00351          END IF
00352 # else
00353          CALL StartTimer(iBarrier, sm_group%level)
00354          CALL MPI_WAITANY(SIZE(req_array), req_array, req_index, mpi_status, iErr)
00355          CALL StopTimer(iBarrier, sm_group%level)
00356 
00357 # endif
00358 !PRINT *, "WaitOnAnyMsgGrpRecv(", MPI_id, ",", sm_group%level, ", ", req_index, ") done."
00359 !PRINT *
00360          msg_list => sm_group%messages
00361 
00362          ! Iterate through the list until the appropriate index has been reached.
00363          IF (req_index /= MPI_UNDEFINED) THEN
00364 
00365             i=0
00366             DO WHILE (ASSOCIATED(msg_list))
00367                IF (ASSOCIATED(msg_list%self%requests)) THEN
00368                   IF (.NOT. msg_list%self%requests%completed) THEN
00369                      i=i+1
00370                      IF (i == req_index) EXIT
00371                   END IF
00372                END IF
00373                msg_list => msg_list%next
00374             END DO
00375 
00376             ! Obtain the message from the message list.
00377             IF (ASSOCIATED(msg_list)) THEN
00378 
00379                 message => msg_list%self
00380  
00381 !                IF (message%tag == 9000) write(*,'(A,I,A,100I)') 'message', MPI_ID, 'recvwait', message%requests%request, mpi_status
00382 
00383                 message%requests%completed = .TRUE.
00384                 message%requests%request = 0
00385                 message%first_block_received = .TRUE.
00386 
00387                 ! Get the message's size in bytes and cache it in the message's buffer size.
00388                 CALL MPI_GET_COUNT(mpi_status, MPI_PACKED, message_size, iErr)
00389                 message%blocks%buffer_size = message_size
00390 !                write(COMM_LOG_HANDLE,*) 'Received', MPI_WTIME()-InitTime, 100*message%level+(message%nMessages-1)+message%tag/1000, message%tag + (message%level + 2) * TAG_LEVEL_MULTIPLIER + message%nMessages, message%remote_proc
00391                 
00392                 IF (message%lMultiBlock) THEN
00393                    ! Post the next receive; if it turns out to be unnecessary then
00394                    ! it will be cancelled when the message is closed.
00395                    CALL SetUpRecv(message)
00396                 END IF
00397             END IF
00398 
00399          END IF
00400 
00401          DEALLOCATE(req_array)
00402          NULLIFY(req_array)
00403 
00404       END IF
00405 
00406    END SUBROUTINE WaitOnAnyMessageGroupRecv
00407 
00410    SUBROUTINE WaitOnAllMessageGroupSends(sm_group)
00411      USE GlobalDeclarations
00412       TYPE(StageMessageGroup), POINTER :: sm_group
00413 
00414       INTEGER, POINTER, DIMENSION(:) :: req_array
00415       INTEGER :: iErr
00416 
00417 
00418       ! This subroutine is NOT conducive to processing receives, so don't even try.
00419       IF (.NOT. sm_group%lSend)  RETURN
00420 
00421       ! Retrieve all open requests associated with this group's messages.
00422       CALL GetMGAllRequestsArray(sm_group, req_array, .TRUE., .TRUE.)
00423 
00424       ! Launch a wait all on all sends.
00425       IF (ASSOCIATED(req_array)) THEN
00426 
00427 !         IF (sm_group%iStageTag == 9000) write(*,'(A,I,A,100I)') 'message', MPI_ID, 'sendwait', req_array
00428 # if defined PTH
00429          IF (iThreaded == THREADED) THEN
00430             CALL pth_MPI_WAITALL(SIZE(req_array), req_array, iErr)
00431          ELSE
00432 
00433             CALL StartTimer(iBarrier, sm_group%level)
00434             CALL MPI_WAITALL(SIZE(req_array), req_array, MPI_STATUSES_IGNORE, iErr)
00435             CALL StopTimer(iBarrier, sm_group%level)
00436          END IF
00437 # else
00438          CALL StartTimer(iBarrier, sm_group%level)
00439          CALL MPI_WAITALL(SIZE(req_array), req_array, MPI_STATUSES_IGNORE, iErr)
00440          CALL StopTimer(iBarrier, sm_group%level)
00441 
00442 # endif
00443 !         IF (sm_group%iStageTag == 9000) write(*,'(A,I,A,100I)') 'message', MPI_ID, 'sendwait_done', req_array
00444          DEALLOCATE(req_array)
00445          NULLIFY(req_array)
00446       END IF
00447       
00448 !      write(COMM_LOG_HANDLE,*) 'Finisehd', MPI_WTIME()-InitTime, 100*message%level+(message%nMessages), message%tag + (message%level + 2) * TAG_LEVEL_MULTIPLIER + message%nMessages, message%remote_proc
00449    END SUBROUTINE WaitOnAllMessageGroupSends
00450 
00451 
00452 
00453 
00459    SUBROUTINE GetRequestArray(message, req_array, lOpenOnly, lFlagAsCompleted)
00460 
00461       TYPE(PackedMessage), POINTER :: message
00462       INTEGER, POINTER, DIMENSION(:) :: req_array, temp_array
00463 
00464       TYPE(RequestList), POINTER :: target_request
00465       INTEGER :: i
00466       LOGICAL, OPTIONAL :: lOpenOnly, lFlagAsCompleted
00467       INTEGER :: iErr
00468       LOGICAL :: open_only, flag_as_completed
00469 
00470       IF (PRESENT(lOpenOnly)) THEN
00471          open_only = lOpenOnly
00472       ELSE
00473          open_only = .FALSE.
00474       END IF
00475 
00476       IF (PRESENT(lFlagAsCompleted)) THEN
00477          flag_as_completed = lFlagAsCompleted
00478       ELSE
00479          flag_as_completed = .FALSE.
00480       END IF
00481 
00482       IF (.NOT. ASSOCIATED(message))  THEN
00483          PRINT *, "GetRequestArray() error: message object not associated."
00484          STOP
00485       END IF
00486 
00487       ! Clear the request array if it's already associated.
00488       IF (ASSOCIATED(req_array)) THEN
00489          DEALLOCATE(req_array)
00490          NULLIFY(req_array)
00491       END IF
00492 
00493       ! Allocate enough space for all of this message's message blocks.
00494       ALLOCATE(temp_array(message%nMessages), STAT=iErr)
00495       NULLIFY(req_array)
00496       IF (iErr /= 0) THEN
00497          PRINT *, "GetRequestArray() error: unable to allocate request array."
00498          STOP
00499       END IF
00500 
00501 !      req_array = 0
00502       i = 0
00503 
00504       target_request => message%requests
00505 
00506       ! Iterate over the request list and store the request handles in the array.
00507       DO WHILE (ASSOCIATED(target_request))
00508 
00509          ! Filter out requests that have already been completed.
00510          IF (.NOT. (open_only .AND. target_request%completed)) THEN
00511             i=i+1
00512             temp_array(i) = target_request%request
00513             IF (flag_as_completed)  target_request%completed = .TRUE.
00514          END IF
00515 
00516          target_request => target_request%next
00517       END DO
00518       
00519       IF (i > 0) THEN
00520          ALLOCATE(req_array(i))
00521          req_array=temp_array(1:i)
00522       END IF
00523       DEALLOCATE(temp_array)
00524    END SUBROUTINE GetRequestArray
00525 
00530    SUBROUTINE GetMGFirstRequestArray(sm_group, req_array, lOpenOnly)
00531 
00532       TYPE(StageMessageGroup) :: sm_group
00533       INTEGER, POINTER, DIMENSION(:) :: req_array, temp_array
00534       LOGICAL, OPTIONAL :: lOpenOnly
00535 
00536       TYPE(MessageList), POINTER :: msg_list
00537       INTEGER :: iErr
00538       INTEGER :: m
00539       LOGICAL :: open_only
00540 
00541 
00542       IF (PRESENT(lopenOnly)) THEN
00543          open_only = lOpenOnly
00544       ELSE
00545          open_only = .FALSE.
00546       END IF
00547 
00548 !      IF (ASSOCIATED(req_array)) THEN
00549 !         DEALLOCATE(req_array)
00550 !         NULLIFY(req_array)
00551 !      END IF
00552 
00553       ALLOCATE(temp_array(sm_group%nPackedMessages), STAT=iErr)
00554       NULLIFY(req_array)
00555       IF (iErr /= 0) THEN
00556          PRINT "('WaitOnMessageGroup() error: unable to allocate request array of size ', i2, '.')", sm_group%nPackedMessages
00557          STOP
00558       END IF
00559 
00560       !req_array = 0
00561 
00562       msg_list => sm_group%messages
00563       m = 0
00564 
00565       ! Count up the number of currently allocated messages
00566       DO WHILE (ASSOCIATED(msg_list))
00567          !PRINT *, "open_only = ", open_only
00568          !PRINT *, "ASSOCIATED(msg_list) = ", ASSOCIATED(msg_list)
00569          !PRINT *, "ASSOCIATED(msg_list%self) = ", ASSOCIATED(msg_list%self)
00570          !PRINT *, "ASSOCIATED(msg_list%self%requests) = ", ASSOCIATED(msg_list%self%requests)
00571          !PRINT *, "ASSOCIATED(msg_list%self%last_request) = ", ASSOCIATED(msg_list%self%last_request)
00572          !PRINT *, "completed = ", msg_list%self%requests%completed
00573          ! If only open requests are desired, then filter out the finished requests.
00574          IF (ASSOCIATED(msg_list%self%requests)) THEN
00575             IF (.NOT. (open_only .AND. msg_list%self%requests%completed))  THEN
00576                m=m+1
00577                temp_array(m) = msg_list%self%requests%request
00578             END IF
00579          END IF
00580          msg_list => msg_list%next
00581       END DO
00582       IF (m > 0) THEN
00583          ALLOCATE(req_array(m))
00584          req_array=temp_array(1:m)
00585       END IF
00586       DEALLOCATE(temp_array)
00587    END SUBROUTINE GetMGFirstRequestArray
00588 
00593    SUBROUTINE GetMGCurrentRequestArray(sm_group, req_array, lOpenOnly)
00594 
00595       TYPE(StageMessageGroup) :: sm_group
00596       INTEGER, POINTER, DIMENSION(:) :: req_array, temp_array
00597       LOGICAL, OPTIONAL :: lOpenOnly
00598 
00599       TYPE(MessageList), POINTER :: msg_list
00600       INTEGER :: iErr
00601       INTEGER :: m
00602       LOGICAL :: open_only
00603 
00604 
00605       IF (PRESENT(lopenOnly)) THEN
00606          open_only = lOpenOnly
00607       ELSE
00608          open_only = .FALSE.
00609       END IF
00610 
00611       IF (ASSOCIATED(req_array)) THEN
00612          DEALLOCATE(req_array)
00613          NULLIFY(req_array)
00614       END IF
00615 
00616       ALLOCATE(temp_array(sm_group%nPackedMessages), STAT=iErr)
00617 
00618       IF (iErr /= 0) THEN
00619          PRINT *, "WaitOnMessageGroup() error: unable to allocate request array."
00620          STOP
00621       END IF
00622 
00623       !req_array = 0
00624 
00625       msg_list => sm_group%messages
00626       m = 0
00627       ! Count up the number of currently allocated messages
00628       DO WHILE (ASSOCIATED(msg_list))
00629          ! If only open requests are desired, then filter out the finished
00630          ! requests.
00631          IF (ASSOCIATED(msg_list%self%current_request)) THEN
00632             IF (.NOT. (open_only .AND. msg_list%self%current_request%completed)) THEN
00633                m=m+1
00634                temp_array(m) = msg_list%self%current_request%request
00635             END IF
00636          END IF
00637          msg_list => msg_list%next
00638       END DO
00639 
00640       IF (m > 0) THEN
00641          ALLOCATE(req_array(m))
00642          req_array=temp_array(1:m)
00643       END IF
00644       DEALLOCATE(temp_array)
00645    END SUBROUTINE GetMGCurrentRequestArray
00646 
00647 
00652    SUBROUTINE GetMGLastRequestArray(sm_group, req_array, lOpenOnly)
00653 
00654       TYPE(StageMessageGroup) :: sm_group
00655       INTEGER, POINTER, DIMENSION(:) :: req_array, temp_array
00656       LOGICAL, OPTIONAL :: lOpenOnly
00657 
00658       TYPE(MessageList), POINTER :: msg_list
00659       INTEGER :: iErr
00660       INTEGER :: m
00661       LOGICAL :: open_only
00662 
00663 
00664       IF (PRESENT(lopenOnly)) THEN
00665          open_only = lOpenOnly
00666       ELSE
00667          open_only = .FALSE.
00668       END IF
00669 
00670       IF (ASSOCIATED(req_array)) THEN
00671          DEALLOCATE(req_array)
00672          NULLIFY(req_array)
00673       END IF
00674 
00675       ALLOCATE(temp_array(sm_group%nPackedMessages), STAT=iErr)
00676       NULLIFY(req_array)
00677       IF (iErr /= 0) THEN
00678          PRINT *, "WaitOnMessageGroup() error: unable to allocate request array."
00679          STOP
00680       END IF
00681 
00682 !      req_array = 0
00683 
00684       msg_list => sm_group%messages
00685       m = 0
00686 
00687       ! Count up the number of currently allocated messages
00688       DO WHILE (ASSOCIATED(msg_list))
00689          ! If only open requests are desired, then filter out the finished requests.
00690          IF (ASSOCIATED(msg_list%self%last_request)) THEN
00691             IF (.NOT. (open_only .AND. msg_list%self%last_request%completed)) THEN
00692                m=m+1
00693                temp_array(m) = msg_list%self%last_request%request               
00694             END IF
00695          END IF
00696          msg_list => msg_list%next
00697       END DO
00698       IF (m > 0) THEN
00699          ALLOCATE(req_array(m))
00700          req_array=temp_array(1:m)
00701       END IF
00702       DEALLOCATE(temp_array)
00703    END SUBROUTINE GetMGLastRequestArray
00704 
00705 
00711    SUBROUTINE GetMGAllRequestsArray(sm_group, req_array, lOpenOnly, lFlagAsCompleted)
00712 
00713       TYPE(StageMessageGroup) :: sm_group
00714       INTEGER, POINTER, DIMENSION(:) :: req_array, temp_array
00715       LOGICAL, OPTIONAL :: lOpenOnly
00716       LOGICAL, OPTIONAL ::lFlagAsCompleted
00717 
00718       TYPE(MessageList), POINTER :: msg_list
00719       TYPE(PackedMessage), POINTER :: message
00720       TYPE(RequestList), POINTER :: req_ptr
00721       INTEGER :: iErr
00722       INTEGER :: message_count
00723       INTEGER :: m
00724       LOGICAL :: open_only
00725       LOGICAL :: flag_as_completed
00726 
00727 
00728       IF (PRESENT(lOpenOnly)) THEN
00729          open_only = lOpenOnly
00730       ELSE
00731          open_only = .FALSE.
00732       END IF
00733 
00734       IF (PRESENT(lFlagAsCompleted)) THEN
00735          flag_as_completed = lFlagAsCompleted
00736       ELSE
00737          flag_as_completed = .FALSE.
00738       END IF
00739 
00740       ! Initialize tracking variables.
00741 !      IF (ASSOCIATED(req_array)) THEN
00742 !         DEALLOCATE(req_array)
00743 !         NULLIFY(req_array)
00744 !      END IF
00745 
00746       message_count = 0
00747 
00748       msg_list => sm_group%messages
00749 
00750       ! Accumulate the number of message blocks in this StageMessageGroup.
00751       DO WHILE (ASSOCIATED(msg_list))
00752 !         message_count = message_count + msg_list%self%nMessages
00753          message_count = message_count + msg_list%self%nRequests
00754 
00755 !req_ptr => msg_list%self%requests
00756 !DO WHILE (ASSOCIATED(req_ptr))
00757 !req_count = req_count + 1
00758 !PRINT *, "req_counting::req(", req_count, ") = ", req_ptr%request
00759 !PRINT *, "req_counting::req(", req_count, ") completed = ", req_ptr%completed
00760 !req_ptr => req_ptr%next
00761 !END DO 
00762 
00763          msg_list => msg_list%next
00764       END DO
00765 
00766       ALLOCATE(temp_array(message_count), STAT=iErr)
00767       NULLIFY(req_array)
00768       IF (iErr /= 0) THEN
00769          PRINT *, "WaitOnMessageGroup() error: unable to allocate request array."
00770          STOP
00771       END IF
00772 
00773 !      req_array = 0
00774 
00775       msg_list => sm_group%messages
00776       m = 0
00777 
00778       ! Count up the number of currently allocated messages
00779       DO WHILE (ASSOCIATED(msg_list))
00780 
00781          message => msg_list%self
00782          req_ptr => message%requests
00783 
00784          DO WHILE (ASSOCIATED(req_ptr))
00785             ! If only open requests are desired, then filter out the finished requests.
00786             IF (.NOT. (open_only .AND. req_ptr%completed)) THEN
00787                m=m+1
00788                temp_array(m) = req_ptr%request
00789                IF (flag_as_completed)  req_ptr%completed = .TRUE.
00790             END IF
00791 
00792             req_ptr => req_ptr%next
00793          END DO
00794 
00795          msg_list => msg_list%next
00796 
00797       END DO
00798 
00799       IF (m > 0) THEN
00800          ALLOCATE(req_array(m))
00801          req_array=temp_array(1:m)
00802       END IF
00803       DEALLOCATE(temp_array)
00804    END SUBROUTINE GetMGAllRequestsArray
00805 
00806 END MODULE MpiTransmission
00807 
00808 
 All Classes Files Functions Variables