Scrambler
1
|
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