Scrambler
1
|
00001 !######################################################################### 00002 ! 00003 ! Copyright (C) 2003-2012 Department of Physics and Astronomy, 00004 ! University of Rochester, 00005 ! Rochester, NY 00006 ! 00007 ! mpi_packing.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 MpiPacking 00035 00036 USE TreeDeclarations 00037 USE GlobalDeclarations 00038 USE MessageDeclarations 00039 USE MpiTransmission 00040 USE Boundary 00041 00042 IMPLICIT NONE 00043 ! INCLUDE 'mpif.h' 00044 PRIVATE 00045 00046 PUBLIC CreatePackedMessage, ClosePackedMessage, DestroyPackedMessage 00047 PUBLIC CreateMessageGroup, CloseMessageGroup, DestroyMessageGroup, ExtractMessageFromGroup 00048 PUBLIC MGBlockOnFirstMessages, MGFinishMessageGroupMessages 00049 PUBLIC GetProcListAsArray, RemoveFirstMessageFromGroup, SendTerminationBox, PackTerminationBox 00050 PUBLIC StrictGetNextBox 00051 PUBLIC PACK_INTEGER_SIZE, PACK_FLOAT_SIZE, PACK_DOUBLE_SIZE, PACK_BOX_SIZE 00052 00053 PUBLIC PackData, UnpackData, PackList, UnpackList 00054 ! PUBLIC PackInt0D, PackInt1D, PackInt2D, PackInt3D 00055 ! PUBLIC PackFloat0D, PackFloat1D, PackFloat2D, PackFloat3D 00056 ! PUBLIC PackDouble0D, PackDouble1D, PackDouble2D, PackDouble3D, PackDouble4D 00057 00058 00059 00061 INTERFACE PackData 00062 MODULE PROCEDURE PackInt0D, PackInt1D, PackInt2D, PackInt3D, PackInt4D, & 00063 PackFloat0D, PackFloat1D, PackFloat2D, PackFloat3D, PackFloat4D, & 00064 PackDouble0D, PackDouble1D, PackDouble2D, PackDouble3D, PackDouble4D, & 00065 PackBox, PackBoundary 00066 END INTERFACE 00067 00069 INTERFACE UnpackData 00070 MODULE PROCEDURE UnpackInt0D, UnpackInt1D, UnpackInt2D, UnpackInt3D, UnpackInt4D, & 00071 UnpackFloat0D, UnpackFloat1D, UnpackFloat2D, UnpackFloat3D, UnpackFloat4D, & 00072 UnpackDouble0D, UnpackDouble1D, UnpackDouble2D, UnpackDouble3D, UnpackDouble4D, & 00073 UnpackBox, UnPackBoundary 00074 00075 END INTERFACE 00076 00077 00079 INTERFACE PackList 00080 MODULE PROCEDURE PackIntList, PackFloatList, PackDoubleList 00081 END INTERFACE 00082 00084 INTERFACE UnpackList 00085 MODULE PROCEDURE UnpackIntList, UnpackFloatList, UnpackDoubleList 00086 END INTERFACE 00087 00088 PUBLIC GetNextBox 00089 CONTAINS 00090 00093 00101 SUBROUTINE CreatePackedMessage(level, remote_proc, tag, lSend, message, message_size) 00102 00103 INTEGER :: level 00104 INTEGER :: remote_proc 00105 INTEGER :: tag 00106 LOGICAL :: lSend 00107 TYPE(PackedMessage), POINTER :: message 00108 INTEGER, OPTIONAL :: message_size 00109 00110 INTEGER :: msize 00111 00112 00113 ! If there is no message size passed in, then use the standard buffer size for this message. This will be the 00114 ! default option for tree messages, which are unlikely to need massive buffer sizes. 00115 IF (PRESENT(message_size)) THEN 00116 msize = message_size 00117 ELSE 00118 msize = STD_BUFFER_SIZE 00119 END IF 00120 00121 CALL CreatePackedMessageObject(level, remote_proc, tag, lSend, msize, message) 00122 00123 IF (PRESENT(message_size)) THEN 00124 message%lMultiBlock=.false. 00125 ELSE 00126 message%lMultiBlock=.true. 00127 END IF 00128 00129 00130 IF (lSend) THEN 00131 CALL SetUpSend(message) 00132 ELSE 00133 CALL SetUpRecv(message) 00134 END IF 00135 00136 END SUBROUTINE CreatePackedMessage 00137 00140 SUBROUTINE DestroyPackedMessage(message) 00141 00142 TYPE(PackedMessage), POINTER :: message 00143 00144 00145 IF (.NOT. ASSOCIATED(message)) RETURN 00146 00147 ! Close out the current message block. 00148 IF (.NOT. message%closed) THEN 00149 CALL ClosePackedMessage(message) 00150 END IF 00151 00152 ! Finish sending any unsent messages. 00153 IF (message%nMessages > 0 .AND. message%lSend) THEN 00154 CALL WaitOnMessageBlocks(message) 00155 END IF 00156 00157 CALL DestroyPackedMessageObject(message) 00158 00159 END SUBROUTINE DestroyPackedMessage 00160 00161 00164 SUBROUTINE ClosePackedMessage(message) 00165 00166 TYPE(PackedMessage), POINTER :: message 00167 00168 00169 message%closed = .TRUE. 00170 00171 IF (message%lSend) THEN 00172 CALL SendPackedMessage(message) 00173 ELSE 00174 IF (message%lMultiBlock) CALL CancelLastMessageBlockRecv(message) 00175 END IF 00176 00177 END SUBROUTINE ClosePackedMessage 00178 00181 LOGICAL FUNCTION MessageIsClosed(message) 00182 00183 TYPE(PackedMessage), POINTER :: message 00184 00185 MessageIsClosed = message%closed 00186 00187 END FUNCTION MessageIsClosed 00188 00190 00191 00194 00200 SUBROUTINE CreateMessageGroup(sm_group, iStageTag, lSend, level) 00201 00202 TYPE(StageMessageGroup), POINTER :: sm_group 00203 INTEGER :: iStageTag 00204 LOGICAL :: lSend 00205 INTEGER :: level 00206 00207 ! Allocate and assemble message group object. 00208 CALL CreateMessageGroupObject(sm_group, iStageTag, lSend, level) 00209 00210 END SUBROUTINE CreateMessageGroup 00211 00214 SUBROUTINE CloseMessageGroup(sm_group) 00215 00216 TYPE(StageMessageGroup), POINTER :: sm_group 00217 00218 TYPE(MessageList), POINTER :: msg_list 00219 TYPE(RequestList), POINTER :: req_list 00220 00221 msg_list => sm_group%messages 00222 00223 DO WHILE (ASSOCIATED(msg_list)) 00224 IF (.NOT. msg_list%self%closed) CALL ClosePackedMessage(msg_list%self) 00225 00226 msg_list => msg_list%next 00227 END DO 00228 00229 END SUBROUTINE CloseMessageGroup 00230 00233 SUBROUTINE DestroyMessageGroup(sm_group) 00234 00235 TYPE(StageMessageGroup), POINTER :: sm_group 00236 00237 00238 IF (.NOT. ASSOCIATED(sm_group)) THEN 00239 print*, sm_group%level 00240 PRINT *, "DestroyMessageGroup() error: message_group not associated." 00241 STOP 00242 END IF 00243 00244 ! IF (.NOT. MessageGroupIsAllClosed(sm_group)) CALL CloseMessageGroup(sm_group) 00245 CALL CloseMessageGroup(sm_group) 00246 CALL MGFinishMessageGroupMessages(sm_group) 00247 CALL DestroyMessageGroupObject(sm_group) 00248 00249 END SUBROUTINE DestroyMessageGroup 00250 00254 SUBROUTINE AddMessageToGroupList(sm_group, message) 00255 00256 TYPE(StageMessageGroup), POINTER :: sm_group 00257 TYPE(PackedMessage), POINTER :: message 00258 00259 CALL AddMessageToList(message, sm_group%last_message, sm_group%messages) 00260 ! IF (.NOT. ASSOCIATED(sm_group%messages) .AND. ASSOCIATED(sm_group%last_message)) sm_group%messages => sm_group%last_message 00261 sm_group%nPackedMessages = sm_group%nPackedMessages + 1 00262 ! PRINT *, "nPackedMessages=", sm_group%nPackedMessages 00263 END SUBROUTINE AddMessageToGroupList 00264 00270 SUBROUTINE ExtractMessageFromGroup(sm_group, proc_id, message, message_size) 00271 00272 TYPE(StageMessageGroup), POINTER :: sm_group 00273 INTEGER :: proc_id 00274 TYPE(PackedMessage), POINTER :: message 00275 INTEGER, OPTIONAL :: message_size 00276 00277 TYPE(MessageList), POINTER :: msg_list 00278 INTEGER :: msize 00279 00280 00281 NULLIFY(message) 00282 00283 msg_list => sm_group%messages 00284 00285 IF (proc_id == MPI_id) THEN 00286 PRINT *, "ExtractMessageFromGroup() error: proc_id ", proc_id, "matched process rank." 00287 STOP 00288 END IF 00289 00290 ! If a message with this processor ID already exists in the list, simply return that message. 00291 DO WHILE (ASSOCIATED(msg_list)) 00292 IF (msg_list%self%remote_proc == proc_id) THEN 00293 message => msg_list%self 00294 EXIT 00295 END IF 00296 msg_list => msg_list%next 00297 END DO 00298 00299 ! If no message was found with the given processor ID, then create a new PackedMessageObject. 00300 IF (.NOT. ASSOCIATED(message)) THEN 00301 00302 IF (PRESENT(message_size)) THEN 00303 msize = message_size 00304 ELSE 00305 msize = STD_BUFFER_SIZE 00306 END IF 00307 00308 CALL CreatePackedMessage(sm_group%level, proc_id, sm_group%iStageTag, sm_group%lSend, message, msize) 00309 00310 IF (PRESENT(message_size)) THEN 00311 message%lMultiBlock=.false. 00312 ELSE 00313 message%lMultiBlock=.true. 00314 END IF 00315 00316 CALL AddMessageToGroupList(sm_group, message) 00317 CALL AddProcessorToMGList(sm_group, proc_id) 00318 END IF 00319 00320 END SUBROUTINE ExtractMessageFromGroup 00321 00324 SUBROUTINE RemoveFirstMessageFromGroup(sm_group) 00325 00326 TYPE(StageMessageGroup), POINTER :: sm_group 00327 00328 TYPE(MessageList), POINTER :: dead_list 00329 00330 00331 dead_list => sm_group%messages 00332 sm_group%messages => sm_group%messages%next 00333 NULLIFY(dead_list%next) 00334 CALL DestroyMessageListObject(dead_list) ! Will close and destroy the PackedMessage object as well. 00335 sm_group%nPackedMessages = sm_group%nPackedMessages - 1 00336 00337 END SUBROUTINE RemoveFirstMessageFromGroup 00338 00339 00342 LOGICAL FUNCTION MessageGroupIsAllClosed(sm_group) 00343 00344 TYPE(StageMessageGroup) :: sm_group 00345 00346 TYPE(MessageList), POINTER :: msg_list 00347 00348 00349 MessageGroupIsAllClosed = .TRUE. 00350 00351 msg_list => sm_group%messages 00352 00353 ! Loop over messages in group to see if they are closed. Return if any of them aren't. 00354 DO WHILE (ASSOCIATED(msg_list)) 00355 IF (.NOT. msg_list%self%closed) THEN 00356 MessageGroupIsAllClosed = .FALSE. 00357 EXIT 00358 END IF 00359 msg_list => msg_list%next 00360 END DO 00361 00362 END FUNCTION MessageGroupIsAllClosed 00363 00367 SUBROUTINE MGBlockOnFirstMessages(sm_group, message) 00368 00369 TYPE(StageMessageGroup) :: sm_group 00370 TYPE(PackedMessage), POINTER :: message 00371 00372 00373 CALL WaitOnAnyMessageGroupRecv(sm_group, message, I_FIRST_REQUESTS) 00374 00375 END SUBROUTINE MGBlockOnFirstMessages 00376 00379 SUBROUTINE MGFinishMessageGroupMessages(sm_group) 00380 00381 TYPE(StageMessageGroup), POINTER :: sm_group 00382 00383 TYPE(PackedMessage), POINTER :: message 00384 LOGICAL :: lRepeat 00385 00386 NULLIFY(message) 00387 lRepeat = .TRUE. 00388 00389 IF (sm_group%lSend) CALL WaitOnAllMessageGroupSends(sm_group) 00390 00391 END SUBROUTINE MGFinishMessageGroupMessages 00392 00396 SUBROUTINE GetProcListAsArray(sm_group, proc_array) 00397 00398 TYPE(StageMessageGroup), POINTER :: sm_group 00399 INTEGER, POINTER, DIMENSION(:) :: proc_array 00400 00401 INTEGER :: proc_count 00402 TYPE(ProcessorList), POINTER :: proc_list 00403 INTEGER :: iErr 00404 INTEGER :: m 00405 00406 00407 IF (ASSOCIATED(proc_array)) THEN 00408 DEALLOCATE(proc_array) 00409 NULLIFY(proc_array) 00410 END IF 00411 00412 proc_count = 0 00413 00414 proc_list => sm_group%proclist 00415 00416 ! Establish the size of the processor array. We have to do this because we can't 00417 ! guarantee that there will only be one message for each processor in a message group. 00418 DO WHILE (ASSOCIATED(proc_list)) 00419 proc_count = proc_count + 1 00420 proc_list => proc_list%next 00421 END DO 00422 00423 IF (proc_count > 0) THEN 00424 ALLOCATE(proc_array(proc_count), STAT=iErr) 00425 00426 IF (iErr /= 0) THEN 00427 PRINT *, "GetProcListAsArray() error: unable to allocate processor array." 00428 STOP 00429 END IF 00430 00431 proc_list => sm_group%proclist 00432 m = 1 00433 00434 ! Populate the outgoing processor array. 00435 DO WHILE (ASSOCIATED(proc_list)) 00436 proc_array(m) = proc_list%self 00437 proc_list => proc_list%next 00438 m=m+1 00439 END DO 00440 00441 END IF 00442 00443 END SUBROUTINE GetProcListAsArray 00444 00445 00448 SUBROUTINE PackTerminationBox(message) 00449 TYPE(PackedMessage), POINTER :: message 00450 00451 CALL PackData(message, TERMINATIONBOX) 00452 00453 END SUBROUTINE PackTerminationBox 00454 00455 00458 SUBROUTINE SendTerminationBox(MessageGroup) 00459 TYPE(StageMessageGroup), POINTER :: MessageGroup 00460 TYPE(PackedMessage), POINTER :: message 00461 INTEGER, DIMENSION(:), POINTER :: ProcList 00462 INTEGER :: i 00463 INTEGER :: list_size 00464 NULLIFY(ProcList) 00465 CALL GetProcListAsArray(MessageGroup, ProcList) 00466 IF (ASSOCIATED(ProcList)) THEN 00467 list_size = SIZE(ProcList) 00468 ELSE 00469 list_size = 0 00470 END IF 00471 00472 DO i=1, list_size 00473 CALL ExtractMessageFromGroup(MessageGroup, ProcList(i), message) 00474 00475 CALL PackData(message, TERMINATIONBOX) 00476 END DO 00477 00478 IF (ASSOCIATED(ProcList)) THEN 00479 DEALLOCATE(ProcList) 00480 NULLIFY(ProcList) 00481 END IF 00482 00483 END SUBROUTINE SendTerminationBox 00484 00485 00487 00488 00491 00495 SUBROUTINE PackInt0D(message, type_data) 00496 TYPE(PackedMessage), POINTER :: message 00497 INTEGER :: type_data 00498 INTEGER, DIMENSION(1) :: array_data 00499 array_data(1)=type_data 00500 CALL PackInt1D(message, array_data) 00501 END SUBROUTINE PackInt0D 00502 00506 SUBROUTINE PackInt1D(message, type_array) 00507 00508 TYPE(PackedMessage), POINTER :: message 00509 INTEGER, DIMENSION(:) :: type_array 00510 00511 INTEGER :: array_size, array_position, iErr 00512 INTEGER :: remaining_data, remaining_block_data, next_block 00513 00514 array_size = SIZE(type_array) 00515 00516 remaining_data = array_size ! Will keep track of unpacked data in this array. 00517 array_position= lBound(type_array,1) 00518 00519 DO WHILE (remaining_data > 0) 00520 00521 ! If the current block is full, then send the current message. 00522 IF (message%last_block%block_offset + PACK_INTEGER_SIZE > message%buffer_size) THEN !We can't pack any more integers 00523 CALL SendPackedMessage(message) 00524 END IF 00525 00526 ! Calculate the remaining block space (in integers, not bytes). 00527 remaining_block_data = FLOOR((message%buffer_size - message%last_block%block_offset) * 1.0/PACK_INTEGER_SIZE) 00528 00529 ! Determine the size of the block that will be packed in this pass. 00530 next_block = MIN(remaining_data, remaining_block_data) 00531 00532 ! Pack the array data into the current message block. 00533 CALL MPI_PACK(type_array(array_position), & 00534 next_block, & 00535 MPI_INTEGER, & 00536 message%last_block%buffer, & 00537 message%buffer_size, & 00538 message%last_block%block_offset, & 00539 MPI_COMM_WORLD, & 00540 iErr) 00541 00542 ! Increment the array counters by bytes or integers. 00543 array_position = array_position + next_block 00544 ! Decrement the remaining data count (in integers). 00545 remaining_data = remaining_data - next_block 00546 END DO 00547 00548 END SUBROUTINE PackInt1D 00549 00553 SUBROUTINE PackInt2D(message, type_array) 00554 00555 TYPE(PackedMessage), POINTER :: message 00556 INTEGER, DIMENSION(:,:) :: type_array 00557 00558 CALL PackInt1D(message, RESHAPE(type_array, (/ SIZE(type_array) /))) 00559 00560 END SUBROUTINE PackInt2D 00561 00565 SUBROUTINE PackInt3D(message, type_array) 00566 00567 TYPE(PackedMessage), POINTER :: message 00568 INTEGER, DIMENSION(:,:,:) :: type_array 00569 00570 00571 CALL PackInt1D(message, RESHAPE(type_array, (/ SIZE(type_array) /))) 00572 00573 END SUBROUTINE PackInt3D 00574 00578 SUBROUTINE PackInt4D(message, type_array) 00579 00580 TYPE(PackedMessage), POINTER :: message 00581 INTEGER, DIMENSION(:,:,:,:) :: type_array 00582 00583 00584 CALL PackInt1D(message, RESHAPE(type_array, (/ SIZE(type_array) /))) 00585 00586 END SUBROUTINE PackInt4D 00587 00588 00592 SUBROUTINE PackFloat0D(message, type_data) 00593 TYPE(PackedMessage), POINTER :: message 00594 REAL :: type_data 00595 REAL, DIMENSION(1) :: array_data 00596 array_data(1)=type_data 00597 CALL PackFloat1D(message, array_data) 00598 END SUBROUTINE PackFloat0D 00599 00603 SUBROUTINE PackFloat1D(message, type_array) 00604 TYPE(PackedMessage), POINTER :: message 00605 REAL, DIMENSION(:) :: type_array 00606 00607 INTEGER :: array_size, array_position, iErr 00608 INTEGER :: remaining_data, remaining_block_data, next_block 00609 00610 array_size = SIZE(type_array) 00611 00612 remaining_data = array_size ! Will keep track of unpacked data in this array. 00613 array_position= lBound(type_array,1) 00614 00615 DO WHILE (remaining_data > 0) 00616 00617 ! If the current block is full, then send the current message. 00618 IF (message%last_block%block_offset + PACK_FLOAT_SIZE > message%buffer_size) THEN !We can't pack any more integers 00619 CALL SendPackedMessage(message) 00620 END IF 00621 00622 ! Calculate the remaining block space (in integers, not bytes). 00623 remaining_block_data = FLOOR((message%buffer_size - message%last_block%block_offset) * 1.0/PACK_FLOAT_SIZE) 00624 00625 ! Determine the size of the block that will be packed in this pass. 00626 next_block = MIN(remaining_data, remaining_block_data) 00627 00628 ! Pack the array data into the current message block. 00629 CALL MPI_PACK(type_array(array_position), & 00630 next_block, & 00631 MPI_REAL, & 00632 message%last_block%buffer, & 00633 message%buffer_size, & 00634 message%last_block%block_offset, & 00635 MPI_COMM_WORLD, & 00636 iErr) 00637 00638 ! Decrement the remaining data count (in integers). 00639 remaining_data = remaining_data - next_block 00640 array_position = array_position + next_block 00641 END DO 00642 END SUBROUTINE PackFloat1D 00643 00647 SUBROUTINE PackFloat2D(message, type_array) 00648 TYPE(PackedMessage), POINTER :: message 00649 REAL, DIMENSION(:,:) :: type_array 00650 CALL PackFloat1D(message, RESHAPE(type_array, (/ SIZE(type_array) /))) 00651 END SUBROUTINE PackFloat2D 00652 00656 SUBROUTINE PackFloat3D(message, type_array) 00657 TYPE(PackedMessage), POINTER :: message 00658 REAL, DIMENSION(:,:,:) :: type_array 00659 CALL PackFloat1D(message, RESHAPE(type_array, (/ SIZE(type_array) /))) 00660 END SUBROUTINE PackFloat3D 00661 00665 SUBROUTINE PackFloat4D(message, type_array) 00666 TYPE(PackedMessage), POINTER :: message 00667 REAL, DIMENSION(:,:,:,:) :: type_array 00668 CALL PackFloat1D(message, RESHAPE(type_array, (/ SIZE(type_array) /))) 00669 END SUBROUTINE PackFloat4D 00670 00674 SUBROUTINE PackDouble0D(message, type_data) 00675 TYPE(PackedMessage), POINTER :: message 00676 REAL(KIND=qPREC) :: type_data 00677 REAL(KIND=qPREC), DIMENSION(1) :: array_data 00678 array_data(1)=type_data 00679 CALL PackDouble1D(message, array_data) 00680 END SUBROUTINE PackDouble0D 00681 00685 SUBROUTINE PackDouble1D(message, type_array) 00686 TYPE(PackedMessage), POINTER :: message 00687 REAL(KIND=qPREC), DIMENSION(:) :: type_array 00688 00689 INTEGER :: array_size, array_position, iErr 00690 INTEGER :: remaining_data, remaining_block_data, next_block 00691 00692 array_size = SIZE(type_array) 00693 00694 remaining_data = array_size ! Will keep track of unpacked data in this array. 00695 array_position= lBound(type_array,1) 00696 00697 DO WHILE (remaining_data > 0) 00698 00699 ! If the current block is full, then send the current message. 00700 IF (message%last_block%block_offset + PACK_DOUBLE_SIZE > message%buffer_size) THEN !We can't pack any more integers 00701 CALL SendPackedMessage(message) 00702 END IF 00703 00704 ! Calculate the remaining block space (in integers, not bytes). 00705 remaining_block_data = FLOOR((message%buffer_size - message%last_block%block_offset) * 1.0/PACK_DOUBLE_SIZE) 00706 00707 ! Determine the size of the block that will be packed in this pass. 00708 next_block = MIN(remaining_data, remaining_block_data) 00709 00710 ! Pack the array data into the current message block. 00711 CALL MPI_PACK(type_array(array_position), & 00712 next_block, & 00713 MPI_DOUBLE_PRECISION, & 00714 message%last_block%buffer, & 00715 message%buffer_size, & 00716 message%last_block%block_offset, & 00717 MPI_COMM_WORLD, & 00718 iErr) 00719 00720 ! Decrement the remaining data count (in integers). 00721 remaining_data = remaining_data - next_block 00722 array_position = array_position + next_block 00723 END DO 00724 00725 END SUBROUTINE PackDouble1D 00726 00730 SUBROUTINE PackDouble2D(message, type_array) 00731 TYPE(PackedMessage), POINTER :: message 00732 REAL(KIND=qPrec), DIMENSION(:,:) :: type_array 00733 CALL PackDouble1D(message, RESHAPE(type_array, (/ SIZE(type_array) /))) 00734 END SUBROUTINE PackDouble2D 00735 00739 SUBROUTINE PackDouble3D(message, type_array) 00740 TYPE(PackedMessage), POINTER :: message 00741 REAL(KIND=qPrec), DIMENSION(:,:,:) :: type_array 00742 CALL PackDouble1D(message, RESHAPE(type_array, (/ SIZE(type_array) /))) 00743 END SUBROUTINE PackDouble3D 00744 00748 SUBROUTINE PackDouble4D(message, type_array) 00749 TYPE(PackedMessage), POINTER :: message 00750 REAL(KIND=qPrec), DIMENSION(:,:,:,:) :: type_array 00751 CALL PackDouble1D(message, RESHAPE(type_array, (/ SIZE(type_array) /))) 00752 END SUBROUTINE PackDouble4D 00753 00754 00758 SUBROUTINE PackBoundary(message, boundary) 00759 TYPE(PackedMessage), POINTER :: message 00760 TYPE(Boundaries) :: boundary 00761 INTEGER :: i 00762 DO i=1,nDim 00763 CALL PackDouble4D(message, boundary%side(i)%data) 00764 END DO 00765 END SUBROUTINE PackBoundary 00766 00770 SUBROUTINE PackBox(message, box) 00771 TYPE(NodeBox) :: box 00772 TYPE(PackedMessage), POINTER :: message 00773 CALL PackInt2D(message,box%mGlobal) 00774 CALL PackInt0D(message,box%MPI_ID) 00775 END SUBROUTINE PackBox 00776 00778 00779 00782 00786 SUBROUTINE UnpackInt0D(message, type_data) 00787 TYPE(PackedMessage), POINTER :: message 00788 INTEGER :: type_data 00789 INTEGER, DIMENSION(1) :: array_data 00790 CALL UnPackInt1D(message, array_data) 00791 type_data=array_data(1) 00792 END SUBROUTINE UnpackInt0D 00793 00797 SUBROUTINE UnpackInt1D(message, type_array) 00798 TYPE(PackedMessage), POINTER :: message 00799 INTEGER, DIMENSION(:) :: type_array 00800 00801 INTEGER :: array_size, array_position, iErr 00802 INTEGER :: remaining_data, remaining_block_data, next_block 00803 00804 00805 array_size = SIZE(type_array) 00806 00807 remaining_data = array_size ! Indicates how much data remains to be unpacked. 00808 array_position= lBound(type_array,1) 00809 00810 DO WHILE (remaining_data > 0) 00811 00812 IF (message%current_block%block_offset + PACK_INTEGER_SIZE > message%current_block%buffer_size) THEN 00813 CALL ReceivePackedMessage(message) 00814 END IF 00815 00816 ! Calculate the number of integers remaining in the current message block. 00817 remaining_block_data = FLOOR((message%current_block%buffer_size - message%current_block%block_offset) * 1.0 / PACK_INTEGER_SIZE) 00818 00819 ! Determine the size of the block to be read in during this pass. 00820 next_block = MIN(remaining_data, remaining_block_data) 00821 00822 ! Extract the data from the message buffer. 00823 CALL MPI_UNPACK(message%current_block%buffer, & 00824 message%current_block%buffer_size, & 00825 message%current_block%block_offset, & 00826 type_array(array_position), & 00827 next_block, & 00828 MPI_INTEGER, & 00829 MPI_COMM_WORLD, & 00830 iErr) 00831 00832 ! Increment the array counters by bytes or integers. 00833 array_position = array_position + next_block 00834 ! Decrement the remaining data counters by bytes or integers. 00835 remaining_data = remaining_data - next_block 00836 END DO 00837 00838 END SUBROUTINE UnpackInt1D 00839 00843 SUBROUTINE UnpackInt2D(message, type_array) 00844 TYPE(PackedMessage), POINTER :: message 00845 INTEGER, DIMENSION(:,:) :: type_array 00846 INTEGER, ALLOCATABLE, DIMENSION(:) :: data_array 00847 ALLOCATE(data_array(SIZE(type_array))) ! This is where the unpacked data will be stored. 00848 CALL UnpackInt1D(message, data_array) 00849 ! Reshape the data to fit into type_array. Note that this relies on RESHAPE being a symmetric transformation; 00850 ! if it's not then we'll have to do this the hard way (cell by cell). 00851 type_array = RESHAPE(data_array, SHAPE(type_array)) 00852 DEALLOCATE(data_array) 00853 END SUBROUTINE UnpackInt2D 00854 00858 SUBROUTINE UnpackInt3D(message, type_array) 00859 00860 TYPE(PackedMessage), POINTER :: message 00861 INTEGER, DIMENSION(:,:,:) :: type_array 00862 INTEGER, ALLOCATABLE, DIMENSION(:) :: data_array 00863 00864 ALLOCATE(data_array(SIZE(type_array))) ! This is where the unpacked data will be stored. 00865 CALL UnpackInt1D(message, data_array) 00866 00867 ! Reshape the data to fit into type_array. Note that this relies on RESHAPE being a symmetric transformation; 00868 ! if it's not then we'll have to do this the hard way (cell by cell). 00869 type_array=RESHAPE(data_array, SHAPE(type_array)) 00870 DEALLOCATE(data_array) 00871 END SUBROUTINE UnpackInt3D 00872 00876 SUBROUTINE UnpackInt4D(message, type_array) 00877 00878 TYPE(PackedMessage), POINTER :: message 00879 INTEGER, DIMENSION(:,:,:,:) :: type_array 00880 INTEGER, ALLOCATABLE, DIMENSION(:) :: data_array 00881 00882 ALLOCATE(data_array(SIZE(type_array))) ! This is where the unpacked data will be stored. 00883 CALL UnpackInt1D(message, data_array) 00884 00885 ! Reshape the data to fit into type_array. Note that this relies on RESHAPE being a symmetric transformation; 00886 ! if it's not then we'll have to do this the hard way (cell by cell). 00887 type_array=RESHAPE(data_array, SHAPE(type_array)) 00888 DEALLOCATE(data_array) 00889 00890 END SUBROUTINE UnpackInt4D 00891 00895 SUBROUTINE UnpackFloat0D(message, type_data) 00896 TYPE(PackedMessage), POINTER :: message 00897 REAL :: type_data 00898 REAL, DIMENSION(1) :: array_data 00899 CALL UnPackFloat1D(message, array_data) 00900 type_data=array_data(1) 00901 END SUBROUTINE UnpackFloat0D 00902 00903 00907 SUBROUTINE UnpackFloat1D(message, type_array) 00908 00909 TYPE(PackedMessage), POINTER :: message 00910 REAL, DIMENSION(:) :: type_array 00911 00912 INTEGER :: array_size, array_position, iErr 00913 INTEGER :: remaining_data, remaining_block_data, next_block 00914 00915 00916 array_size = SIZE(type_array) 00917 00918 remaining_data = array_size ! Indicates how much data remains to be unpacked. 00919 array_position= lBound(type_array,1) 00920 00921 DO WHILE (remaining_data > 0) 00922 00923 IF (message%current_block%block_offset + PACK_FLOAT_SIZE > message%current_block%buffer_size) THEN 00924 CALL ReceivePackedMessage(message) 00925 END IF 00926 00927 ! Calculate the number of integers remaining in the current message block. 00928 remaining_block_data = FLOOR((message%current_block%buffer_size - message%current_block%block_offset) * 1.0 / PACK_FLOAT_SIZE) 00929 00930 ! Determine the size of the block to be read in during this pass. 00931 next_block = MIN(remaining_data, remaining_block_data) 00932 00933 ! Extract the data from the message buffer. 00934 CALL MPI_UNPACK(message%current_block%buffer, & 00935 message%current_block%buffer_size, & 00936 message%current_block%block_offset, & 00937 type_array(array_position), & 00938 next_block, & 00939 MPI_REAL, & 00940 MPI_COMM_WORLD, & 00941 iErr) 00942 00943 ! Increment the array counters by bytes or integers. 00944 array_position = array_position + next_block 00945 ! Decrement the remaining data counters by bytes or integers. 00946 remaining_data = remaining_data - next_block 00947 END DO 00948 00949 END SUBROUTINE UnpackFloat1D 00950 00954 SUBROUTINE UnpackFloat2D(message, type_array) 00955 TYPE(PackedMessage), POINTER :: message 00956 REAL, DIMENSION(:,:) :: type_array 00957 REAL, ALLOCATABLE, DIMENSION(:) :: data_array 00958 ALLOCATE(data_array(SIZE(type_array))) ! This is where the unpacked data will be stored. 00959 CALL UnpackFloat1D(message, data_array) 00960 00961 ! Reshape the data to fit into type_array. Note that this relies on RESHAPE being a symmetric transformation; 00962 ! if it's not then we'll have to do this the hard way (cell by cell). 00963 type_array=RESHAPE(data_array, SHAPE(type_array)) 00964 00965 DEALLOCATE(data_array) 00966 00967 END SUBROUTINE UnpackFloat2D 00968 00972 SUBROUTINE UnpackFloat3D(message, type_array) 00973 TYPE(PackedMessage), POINTER :: message 00974 REAL, DIMENSION(:,:,:) :: type_array 00975 REAL, ALLOCATABLE, DIMENSION(:) :: data_array 00976 ALLOCATE(data_array(SIZE(type_array))) ! This is where the unpacked data will be stored. 00977 CALL UnpackFloat1D(message, data_array) 00978 00979 ! Reshape the data to fit into type_array. Note that this relies on RESHAPE being a symmetric transformation; 00980 ! if it's not then we'll have to do this the hard way (cell by cell). 00981 type_array=RESHAPE(data_array, SHAPE(type_array)) 00982 00983 DEALLOCATE(data_array) 00984 00985 END SUBROUTINE UnpackFloat3D 00986 00991 SUBROUTINE UnpackFloat4D(message, type_array) 00992 00993 TYPE(PackedMessage), POINTER :: message 00994 REAL, DIMENSION(:,:,:,:) :: type_array 00995 00996 REAL, ALLOCATABLE, DIMENSION(:) :: data_array 00997 00998 ALLOCATE(data_array(SIZE(type_array))) ! This is where the unpacked data will be stored. 00999 01000 CALL UnpackFloat1D(message, data_array) 01001 01002 ! Reshape the data to fit into type_array. Note that this relies on RESHAPE being a symmetric transformation; 01003 ! if it's not then we'll have to do this the hard way (cell by cell). 01004 type_array=RESHAPE(data_array, SHAPE(type_array)) 01005 DEALLOCATE(data_array) 01006 END SUBROUTINE UnpackFloat4D 01007 01011 SUBROUTINE UnpackDouble0D(message, type_data) 01012 TYPE(PackedMessage), POINTER :: message 01013 REAL(KIND=qPREC) :: type_data 01014 REAL(KIND=qPREC), DIMENSION(1) :: array_data 01015 CALL UnPackDouble1D(message, array_data) 01016 type_data=array_data(1) 01017 END SUBROUTINE UnpackDouble0D 01018 01022 SUBROUTINE UnpackDouble1D(message, type_array) 01023 01024 TYPE(PackedMessage), POINTER :: message 01025 REAL(KIND=qPREC), DIMENSION(:) :: type_array 01026 01027 INTEGER :: array_size, array_position, iErr 01028 INTEGER :: remaining_data, remaining_block_data, next_block 01029 01030 01031 array_size = SIZE(type_array) 01032 01033 remaining_data = array_size ! Indicates how much data remains to be unpacked. 01034 array_position= lBound(type_array,1) 01035 01036 DO WHILE (remaining_data > 0) 01037 01038 IF (message%current_block%block_offset + PACK_DOUBLE_SIZE > message%current_block%buffer_size) THEN 01039 CALL ReceivePackedMessage(message) 01040 END IF 01041 01042 ! Calculate the number of integers remaining in the current message block. 01043 remaining_block_data = FLOOR((message%current_block%buffer_size - message%current_block%block_offset) * 1.0 / PACK_DOUBLE_SIZE) 01044 01045 ! Determine the size of the block to be read in during this pass. 01046 next_block = MIN(remaining_data, remaining_block_data) 01047 01048 ! Extract the data from the message buffer. 01049 CALL MPI_UNPACK(message%current_block%buffer, & 01050 message%current_block%buffer_size, & 01051 message%current_block%block_offset, & 01052 type_array(array_position), & 01053 next_block, & 01054 MPI_DOUBLE_PRECISION, & 01055 MPI_COMM_WORLD, & 01056 iErr) 01057 01058 ! Increment the array counters by bytes or integers. 01059 array_position = array_position + next_block 01060 ! Decrement the remaining data counters by bytes or integers. 01061 remaining_data = remaining_data - next_block 01062 END DO 01063 01064 END SUBROUTINE UnpackDouble1D 01065 01069 SUBROUTINE UnpackDouble2D(message, type_array) 01070 TYPE(PackedMessage), POINTER :: message 01071 REAL(KIND=qPrec), DIMENSION(:,:) :: type_array 01072 REAL(KIND=qPrec), ALLOCATABLE, DIMENSION(:) :: data_array 01073 ALLOCATE(data_array(SIZE(type_array))) ! This is where the unpacked data will be stored. 01074 CALL UnpackDouble1D(message, data_array) 01075 01076 ! Reshape the data to fit into type_array. Note that this relies on RESHAPE being a symmetric transformation; 01077 ! if it's not then we'll have to do this the hard way (cell by cell). 01078 type_array=RESHAPE(data_array, SHAPE(type_array)) 01079 DEALLOCATE(data_array) 01080 01081 END SUBROUTINE UnpackDouble2D 01082 01086 SUBROUTINE UnpackDouble3D(message, type_array) 01087 TYPE(PackedMessage), POINTER :: message 01088 REAL(KIND=qPrec), DIMENSION(:,:,:) :: type_array 01089 REAL(KIND=qPrec), ALLOCATABLE, DIMENSION(:) :: data_array 01090 ALLOCATE(data_array(SIZE(type_array))) ! This is where the unpacked data will be stored. 01091 CALL UnpackDouble1D(message, data_array) 01092 01093 ! Reshape the data to fit into type_array. Note that this relies on RESHAPE being a symmetric transformation; 01094 ! if it's not then we'll have to do this the hard way (cell by cell). 01095 type_array=RESHAPE(data_array, SHAPE(type_array)) 01096 DEALLOCATE(data_array) 01097 01098 END SUBROUTINE UnpackDouble3D 01099 01103 SUBROUTINE UnpackDouble4D(message, type_array) 01104 TYPE(PackedMessage), POINTER :: message 01105 REAL(KIND=qPrec), DIMENSION(:,:,:,:) :: type_array 01106 REAL(KIND=qPrec), ALLOCATABLE, DIMENSION(:) :: data_array 01107 ALLOCATE(data_array(SIZE(type_array))) ! This is where the unpacked data will be stored. 01108 CALL UnpackDouble1D(message, data_array) 01109 01110 ! Reshape the data to fit into type_array. Note that this relies on RESHAPE being a symmetric transformation; 01111 ! if it's not then we'll have to do this the hard way (cell by cell). 01112 type_array=RESHAPE(data_array, SHAPE(type_array)) 01113 DEALLOCATE(data_array) 01114 END SUBROUTINE UnpackDouble4D 01115 01119 SUBROUTINE UnpackBoundary(message, boundary) 01120 TYPE(PackedMessage), POINTER :: message 01121 TYPE(Boundaries) :: boundary 01122 INTEGER :: i 01123 01124 DO i=1,nDim 01125 CALL UnPackDouble4D(message, boundary%side(i)%data) 01126 END DO 01127 01128 END SUBROUTINE UnpackBoundary 01129 01133 SUBROUTINE UnpackBox(message,box) 01134 01135 TYPE(PackedMessage), POINTER :: message 01136 TYPE(NodeBox) :: box 01137 01138 CALL UnpackInt2D(message,box%mGlobal) 01139 CALL UnpackInt0D(message,box%MPI_ID) 01140 01141 END SUBROUTINE UnpackBox 01142 01143 01144 LOGICAL FUNCTION GetNextBox(message,mGlobal) 01145 TYPE(PackedMessage), POINTER :: message 01146 INTEGER, DIMENSION(3,2) :: mGlobal 01147 01148 ! LOGICAL GetNextBox 01149 01150 01151 mGlobal = TERMINATIONBOX 01152 CALL UnPackData(message, mGlobal) 01153 GetNextBox = (.NOT. ALL(mGlobal == TERMINATIONBOX)) 01154 END FUNCTION GetNextBox 01155 01156 01157 LOGICAL FUNCTION StrictGetNextBox(message, mGlobal, caller) 01158 01159 INTEGER, DIMENSION(3,2) :: mGlobal 01160 TYPE(PackedMessage), POINTER :: message 01161 CHARACTER(*) :: caller 01162 LOGICAL :: gnb_result 01163 01164 gnb_result = GetNextBox(message, mGlobal) 01165 01166 IF (gnb_result .AND. ANY(mGlobal < 1)) THEN 01167 PRINT *, caller, "::StrictGetNextBox() error: bad box [", mGlobal, "]." 01168 PRINT *, " level = ", message%level, ", remote_proc = ", message%remote_proc 01169 STOP 01170 END IF 01171 01172 StrictGetNextBox = gnb_result 01173 01174 END FUNCTION StrictGetNextBox 01175 01176 01178 01179 01182 01186 SUBROUTINE PackIntList(message, array) 01187 01188 TYPE(PackedMessage), POINTER :: message 01189 INTEGER, DIMENSION(:) :: array 01190 01191 01192 CALL packint0d(message,size(array)) 01193 CALL packint1D(message,array) 01194 END SUBROUTINE PackIntList 01195 01196 01200 SUBROUTINE PackFloatList(message, array) 01201 TYPE(PackedMessage), POINTER :: message 01202 REAL, DIMENSION(:) :: array 01203 01204 CALL packint0d(message,size(array)) 01205 CALL packfloat1D(message,array) 01206 01207 END SUBROUTINE PackFloatList 01208 01212 SUBROUTINE PackDoubleList(message, array) 01213 TYPE(PackedMessage), POINTER :: message 01214 REAL(KIND=qPrec), DIMENSION(:) :: array 01215 01216 CALL PackInt0D(message,size(array)) 01217 CALL PackDouble1D(message,array) 01218 01219 END SUBROUTINE PackDoubleList 01220 01221 01223 01226 01230 SUBROUTINE UnpackIntList(message, type_array) 01231 TYPE(PackedMessage), POINTER :: message 01232 INTEGER, DIMENSION(:), POINTER :: type_array 01233 01234 INTEGER :: n 01235 01236 01237 CALL UnpackInt0D(message,n) 01238 01239 !PRINT *, "UnpackList::n = ", n 01240 ALLOCATE(type_array(n)) 01241 01242 !PRINT *, "UnpackList::old type_array = ", type_array 01243 01244 CALL UnpackInt1D(message,type_array) 01245 01246 !PRINT *, "UnpackList::new type_array = ", type_array 01247 01248 END SUBROUTINE UnpackIntList 01249 01253 SUBROUTINE UnpackFloatList(message, type_array) 01254 TYPE(PackedMessage), POINTER :: message 01255 REAL, DIMENSION(:), POINTER :: type_array 01256 01257 INTEGER :: n 01258 01259 01260 CALL UnpackInt0D(message,n) 01261 ALLOCATE(type_array(n)) 01262 CALL UnpackFloat1D(message,type_array) 01263 01264 END SUBROUTINE UnpackFloatList 01265 01269 SUBROUTINE UnpackDoubleList(message, type_array) 01270 TYPE(PackedMessage), POINTER :: message 01271 REAL(KIND=qPrec), DIMENSION(:), POINTER :: type_array 01272 01273 INTEGER :: n 01274 01275 01276 CALL UnpackInt0D(message,n) 01277 ALLOCATE(type_array(n)) 01278 CALL UnpackDouble1D(message,type_array) 01279 01280 END SUBROUTINE UnpackDoubleList 01282 01283 END MODULE MpiPacking 01284