Scrambler  1
mpi_packing.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_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 
 All Classes Files Functions Variables