Scrambler  1
message_declarations.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 !    message_declarations.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 MessageDeclarations
00035 
00036    USE GlobalDeclarations
00037 
00038    IMPLICIT NONE
00039    PRIVATE
00040 
00041    PUBLIC RequestList, CreateMpiRequest, ClearAllRequests, ProcessorList, AddMpiRequest
00042    PUBLIC MessageBlock, CreateMessageBlock, ClearMessageBlocks, ClearAllMessageBlocks, AddMessageBlock
00043    PUBLIC PackedMessage, CreatePackedMessageObject, DestroyPackedMessageObject
00044    PUBLIC MessageList, DestroyMessageListObject
00045    PUBLIC StageMessageGroup, CreateMessageGroupObject, DestroyMessageGroupObject, pStageMessageGroup
00046    PUBLIC AppendProcessorToList, AddProcessorToMGList, AddMessageToList
00047    PUBLIC TERMINATIONBOX, TERMINATION_BOX_BYTES
00048 
00049    INTEGER, PUBLIC, PARAMETER :: STD_BUFFER_SIZE = 16384    ! 16 KB
00050 
00051 
00052 
00053    INTEGER, PUBLIC, PARAMETER :: I_FIRST_REQUESTS = 1
00054    INTEGER, PUBLIC, PARAMETER :: I_CURRENT_REQUESTS = 2
00055    INTEGER, PUBLIC, PARAMETER :: I_LAST_REQUESTS = 3
00056 
00057    !INTEGER, PUBLIC, PARAMETER :: TAG_LEVEL_MULTIPLIER = 200
00058    !INTEGER, PUBLIC, PARAMETER :: TAG_STAGE_MULTIPLIER = 2000
00059    INTEGER, PUBLIC, PARAMETER :: MAX_MESSAGE_PIECES = 100 !max number of messages for one stage
00060 
00062    TYPE RequestList
00063       INTEGER :: request
00064       TYPE(RequestList), POINTER :: next
00065       LOGICAL :: completed
00066    END TYPE RequestList
00067 
00069    TYPE MessageBlock
00070       CHARACTER, ALLOCATABLE, DIMENSION(:) :: buffer
00071       INTEGER :: block_offset
00072       INTEGER :: buffer_size
00073       INTEGER :: block_id
00074       TYPE(MessageBlock), POINTER :: next
00075    END TYPE MessageBlock
00076 
00078    TYPE PackedMessage
00079       INTEGER :: remote_proc
00080       INTEGER :: level
00081       INTEGER :: header
00082       INTEGER :: offset
00083       INTEGER :: nMessages
00084       INTEGER :: tag
00085       INTEGER :: nRequests
00086       INTEGER :: buffer_size
00087       TYPE(RequestList), POINTER :: requests
00088       TYPE(RequestList), POINTER :: current_request
00089       TYPE(RequestList), POINTER :: last_request
00090       TYPE(MessageBlock), POINTER :: blocks
00091       TYPE(MessageBlock), POINTER :: current_block
00092       TYPE(MessageBlock), POINTER :: last_block
00093       LOGICAL :: closed
00094       LOGICAL :: lSend
00095       LOGICAL :: first_block_received
00096       LOGICAL :: lMultiBlock
00097    END TYPE PackedMessage
00098 
00100    Type MessageList
00101       TYPE(PackedMessage), POINTER :: self
00102       TYPE(MessageList), POINTER :: next
00103    End Type MessageList
00104 
00106    TYPE ProcessorList
00107       INTEGER :: self
00108       TYPE(ProcessorList), POINTER :: next
00109    END TYPE ProcessorList
00110 
00112    TYPE StageMessageGroup
00113       TYPE(ProcessorList), POINTER :: proclist
00114       TYPE(ProcessorList), POINTER :: last_proc
00115       TYPE(MessageList), POINTER :: messages
00116       TYPE(MessageList), POINTER :: last_message
00117       INTEGER :: nPackedMessages    
00118       LOGICAL :: lSend
00119       INTEGER :: level
00120       INTEGER :: iStageTag
00121    End TYPE StageMessageGroup
00122 
00124    TYPE pStageMessageGroup
00125       TYPE(StageMessageGroup), POINTER :: p
00126    END TYPE pStageMessageGroup
00127 
00128 
00129 CONTAINS
00130 
00131  
00134 
00140    SUBROUTINE CreateMpiRequest(mpi_request, last_request, first_request, current_request)
00141 
00142       TYPE(RequestList), POINTER :: last_request
00143       TYPE(RequestList), POINTER, OPTIONAL :: first_request
00144       TYPE(RequestList), POINTER, OPTIONAL :: current_request
00145       INTEGER :: mpi_request
00146 
00147       INTEGER :: iErr
00148 
00149 !  TEsting
00150       iErr = 0
00151 
00152      IF (.NOT. ASSOCIATED(last_request)) THEN
00153          ALLOCATE(last_request, STAT=iErr)
00154 
00155          IF (PRESENT(first_request)) THEN
00156             first_request => last_request
00157          END IF
00158 
00159          IF (PRESENT(current_request)) THEN
00160             current_request => last_request
00161          END IF
00162 
00163      ELSE
00164          IF (ASSOCIATED(last_request%next)) THEN
00165             PRINT *, "CreateMpiRequest error: last_request%next is associated."
00166             STOP
00167          END IF
00168 
00169          ALLOCATE(last_request%next, STAT=iErr)
00170 
00171          last_request => last_request%next
00172       END IF
00173 
00174       IF (iErr /= 0) THEN
00175          PRINT *, "CreateMpiRequest() error: unable to allocate MPI Request object."
00176          STOP
00177       END IF
00178 
00179       last_request%request = mpi_request
00180       last_request%completed = .FALSE.
00181       NULLIFY(last_request%next)
00182 
00183    END SUBROUTINE CreateMpiRequest
00184 
00185 
00189    RECURSIVE SUBROUTINE ClearRequestList(request_list)
00190 
00191       TYPE(RequestList), POINTER :: request_list
00192 
00193 
00194       IF (.NOT. ASSOCIATED(request_list))  RETURN
00195 
00196       IF (ASSOCIATED(request_list%next))  CALL ClearRequestList(request_list%next)
00197 
00198       NULLIFY(request_list%next)
00199       DEALLOCATE(request_list)
00200       NULLIFY(request_list)
00201 
00202    END SUBROUTINE ClearRequestList
00203 
00206    SUBROUTINE ClearAllRequests(message)
00207 
00208       TYPE(PackedMessage), POINTER :: message
00209 
00210 
00211       NULLIFY(message%last_request)
00212       NULLIFY(message%current_request)
00213       CALL ClearRequestList(message%requests)
00214       NULLIFY(message%requests)
00215       message%nRequests = 0
00216 
00217    END SUBROUTINE ClearAllRequests
00218 
00223    SUBROUTINE AddMpiRequest(message, request, init_message)
00224 
00225       TYPE(PackedMessage), POINTER :: message
00226       INTEGER :: request
00227       LOGICAL :: init_message
00228 
00229       IF (init_message) THEN
00230          CALL CreateMpiRequest(request, message%last_request, message%requests, message%current_request)
00231       ELSE
00232          CALL CreateMpiRequest(request, message%last_request)
00233       END IF
00234 
00235       message%nRequests = message%nRequests + 1
00236 
00237    END SUBROUTINE AddMpiRequest
00238 
00239 
00241 
00244 
00250    SUBROUTINE CreateMessageBlock(message_size, last_block, first_block, current_block)
00251 
00252       INTEGER :: message_size
00253       TYPE(MessageBlock), POINTER :: last_block
00254       TYPE(MessageBlock), POINTER, OPTIONAL :: first_block
00255       TYPE(MessageBlock), POINTER, OPTIONAL :: current_block
00256 
00257       INTEGER :: iErr
00258 
00259 
00260       iErr = 0
00261 
00262       IF (message_size <= 0) THEN
00263           PRINT *, "CreateMessageBlock() error: invalid message buffer size ', i, '.')", message_size
00264       END IF
00265 
00266       IF (.NOT. ASSOCIATED(last_block)) THEN
00267          ALLOCATE(last_block, STAT=iErr)
00268          IF (PRESENT(first_block))  first_block => last_block
00269          IF (PRESENT(current_block))  current_block => first_block
00270 
00271       ELSE
00272 
00273          IF (ASSOCIATED(last_block%next)) THEN
00274             PRINT *, "CreateMessageBlock error: last_block%next associated."
00275             STOP
00276          END IF
00277 
00278          ALLOCATE(last_block%next, STAT=iErr)
00279          last_block => last_block%next
00280 
00281       END IF
00282 
00283       IF (iErr /= 0) THEN
00284          PRINT *, "CreateMessageBlock() error: unable to allocate new message block."
00285          STOP
00286       END IF
00287 
00288       ALLOCATE(last_block%buffer(message_size))
00289       CALL CheckAllocation(MessageAllocator, message_size)
00290       
00291       last_block%block_offset = 0
00292       last_block%buffer_size = 0
00293       last_block%block_id = 0
00294       NULLIFY(last_block%next)
00295 
00296    END SUBROUTINE CreateMessageBlock
00297 
00300    RECURSIVE SUBROUTINE ClearMessageBlocks(block_list)
00301 
00302       TYPE(MessageBlock), POINTER :: block_list
00303 
00304 
00305       IF (.NOT. ASSOCIATED(block_list))  RETURN
00306 
00307       IF (ASSOCIATED(block_list%next))  CALL ClearMessageBlocks(block_list%next)
00308       CALL CheckDeAllocation(MessageAllocator, size(block_list%buffer))
00309       DEALLOCATE(block_list%buffer)
00310       DEALLOCATE(block_list)
00311       NULLIFY(block_list)
00312 
00313    END SUBROUTINE ClearMessageBlocks
00314 
00317    SUBROUTINE ClearAllMessageBlocks(message)
00318 
00319       TYPE(PackedMessage), POINTER :: message
00320 
00321 
00322       NULLIFY(message%last_block)
00323       NULLIFY(message%current_block)
00324       IF (ASSOCIATED(message%blocks))  CALL ClearMessageBlocks(message%blocks)
00325       NULLIFY(message%blocks)
00326       Message%nMessages = 0
00327 
00328    END SUBROUTINE ClearAllMessageBlocks
00329 
00334    SUBROUTINE AddMessageBlock(message, init_message, message_size)
00335 
00336       TYPE(PackedMessage), POINTER :: message
00337       LOGICAL :: init_message
00338       INTEGER :: message_size
00339       INTEGER :: iErr
00340 
00341 
00342       IF (init_message) THEN
00343          CALL CreateMessageBlock(message_size, message%last_block, message%blocks, message%current_block)
00344       ELSE
00345          CALL CreateMessageBlock(message_size, message%last_block)
00346       END IF
00347 
00348       message%nMessages = message%nMessages + 1
00349       message%last_block%block_id = message%nMessages
00350 
00351       ! If the message has TAG_LEVEL_MULTIPLIER block or more, then the blocks run the risk
00352       ! of colliding with messages on other levels or overwriting blocks that belong to other
00353       ! messages.  Therefore, if this new block pushes the message to the TAG_LEVEL_MULTIPLIER
00354       ! limit, then kill the program (with a clear-ish explanation of what happened).
00355       !IF (message%nMessages >= TAG_LEVEL_MULTIPLIER) THEN
00356       IF (message%nMessages >= MAX_MESSAGE_PIECES) THEN
00357           PRINT "('AddMessageBlock() error::message block overrun (count=', i, ').')", message%nMessages
00358           PRINT "('   AddMessageBlock() error::message tag = ', i5, '.')", message%tag
00359           PRINT "('   AddMessageBlock() error::buffer size = ', i, '.')", message%buffer_size
00360           PRINT "('   AddMessageBlock() error::lSend = ', l, '.')", message%lSend
00361           PRINT *
00362           PRINT *, "*** ERROR ***:  This run failed because your message block size was too small.  ", &
00363                    "message block size and try again."
00364           CALL MPI_FINALIZE(iErr)
00365           STOP
00366       END IF
00367 
00368    END SUBROUTINE AddMessageBlock
00369 
00371 
00374 
00382    SUBROUTINE CreatePackedMessageObject(level, remote_proc, tag, lSend, message_size, message)
00383 
00384       INTEGER :: level
00385       INTEGER :: remote_proc
00386       INTEGER :: tag
00387       LOGICAL :: lSend
00388       INTEGER :: message_size
00389       TYPE(PackedMessage), POINTER :: message
00390       INTEGER :: iErr
00391 
00392 
00393 !      IF (ASSOCIATED(message)) THEN
00394 !         PRINT *, "CreatePackedMessage() error:  message object is already associated."
00395 !         STOP
00396 !      END IF
00397 
00398       IF (remote_proc == MPI_id) THEN
00399           PRINT "('CreatePackedMessage() error: Proc ', i4, ' attempting to post a message for itself.')", remote_proc
00400           STOP
00401       END IF
00402 
00403       IF (message_size <= 0) THEN
00404           PRINT "('CreatePackedMessage(', i1, '=>', i1,', level=', i2, ', tag=', i6, ') error: invalid message size ', i10, '.')", MPI_id, remote_proc, level, tag, message_size
00405           STOP
00406       END IF
00407 
00408       ALLOCATE(message, STAT=iErr)
00409 
00410       IF (iErr /= 0) THEN
00411          PRINT *, "CreatePackedMessage() error: unable to allocate message object."
00412          STOP
00413       END IF
00414 
00415       message%level = level
00416       message%tag = tag
00417       message%remote_proc = remote_proc
00418       message%offset = 0
00419       message%nMessages = 0
00420       message%nRequests = 0
00421       message%lSend = lSend
00422       message%buffer_size = message_size
00423 
00424       message%closed = .FALSE.
00425 
00426       NULLIFY(message%requests)
00427       NULLIFY(message%current_request)
00428       NULLIFY(message%last_request)
00429       NULLIFY(message%blocks)
00430       NULLIFY(message%current_block)
00431       NULLIFY(message%last_block)
00432 
00433    END SUBROUTINE CreatePackedMessageObject
00434 
00437    SUBROUTINE DestroyPackedMessageObject(message)
00438 
00439       TYPE(PackedMessage), POINTER :: message
00440 
00441 
00442       IF (.NOT. ASSOCIATED(message))  RETURN
00443 
00444       CALL ClearAllRequests(message)
00445       CALL ClearAllMessageBlocks(message)
00446       DEALLOCATE(message)
00447       NULLIFY(message)
00448 
00449    END SUBROUTINE DestroyPackedMessageObject
00450 
00452 
00455 
00460    SUBROUTINE AddMessageToList(message,last_message,msg_list)
00461       TYPE(MessageList), POINTER :: last_message
00462       TYPE(PackedMessage), POINTER :: message
00463       TYPE(MessageList), POINTER, OPTIONAL :: msg_list
00464       INTEGER :: iErr
00465 
00466 
00467       IF (.NOT. ASSOCIATED(last_message)) THEN     
00468          ALLOCATE(last_message, STAT=iErr)
00469          NULLIFY(last_message%next)
00470          NULLIFY(last_message%self)
00471          IF (iErr /= 0) THEN
00472             PRINT *, "AddMessage() error: unable to allocate last_message list object."
00473             STOP
00474          END IF
00475          IF (present(msg_list)) msg_list=>last_message
00476       ELSE
00477          IF (ASSOCIATED(last_message%next)) THEN
00478             PRINT *, "Error - last message next allocated"
00479             STOP
00480          END IF
00481          ALLOCATE(last_message%next, STAT=iErr)
00482          IF (iErr /= 0) THEN
00483              PRINT *, "AddMessage() error: unable to allocate last_message%next list object."
00484              STOP
00485          END IF
00486          last_message=>last_message%next         
00487          NULLIFY(last_message%next)
00488          NULLIFY(last_message%self)
00489 
00490       END IF
00491       IF (ASSOCIATED(message)) THEN
00492          last_message%self=>message
00493       ELSE
00494          ALLOCATE(last_message%self, STAT=iErr)
00495          
00496          IF (iErr /= 0) THEN
00497             PRINT *, "AddMessage() error: unable to allocate last_message%self object."
00498             STOP
00499          END IF         
00500          message=>last_message%self         
00501       END IF
00502    END SUBROUTINE AddMessageToList
00503 
00506    RECURSIVE SUBROUTINE DestroyMessageListObject(message_list)
00507 
00508       TYPE(MessageList), POINTER :: message_list
00509 
00510 
00511       IF (.NOT. ASSOCIATED(message_list))  RETURN
00512 
00513       IF (ASSOCIATED(message_list%next))  CALL DestroyMessageListObject(message_list%next)
00514       IF (ASSOCIATED(message_list%self))  CALL DestroyPackedMessageObject(message_list%self)
00515 
00516       DEALLOCATE(message_list)
00517       NULLIFY(message_list)
00518 
00519    END SUBROUTINE DestroyMessageListObject
00520 
00522 
00525 
00531    SUBROUTINE CreateMessageGroupObject(sm_group, iStageTag, lSend, level)
00532 
00533       TYPE(StageMessageGroup), POINTER :: sm_group
00534       INTEGER :: iStageTag
00535       LOGICAL :: lSend
00536       INTEGER :: level
00537 
00538       INTEGER :: iErr
00539 
00540 !      write(*,*) "creating message group object", iStageTag, lSend, level
00541       IF (ASSOCIATED(sm_group)) THEN
00542          PRINT *, "CreateMessageGroup() error: message group already allocated."
00543          print*, iStageTag, lSend, level
00544          STOP
00545       END IF
00546 
00547       ALLOCATE(sm_group, STAT=iErr)
00548       
00549       IF (iErr /= 0) THEN
00550          PRINT *, "CreateMessageGroup() error: unable to allocate StageMessageGroup object."
00551       END IF
00552 
00553       NULLIFY(sm_group%proclist)
00554       NULLIFY(sm_group%last_proc)                
00555       NULLIFY(sm_group%messages)
00556       NULLIFY(sm_group%last_message)
00557 
00558       sm_group%nPackedMessages = 0
00559       sm_group%iStageTag = iStageTag
00560       sm_group%lSend = lSend
00561       sm_group%level = level
00562 
00563    END SUBROUTINE CreateMessageGroupObject
00564 
00567    SUBROUTINE DestroyMessageGroupObject(sm_group)
00568       TYPE(StageMessageGroup), POINTER :: sm_group
00569 
00570 
00571       IF (.NOT. ASSOCIATED(sm_group))  RETURN
00572 
00573       NULLIFY(sm_group%last_proc)
00574       NULLIFY(sm_group%last_message)
00575 
00576       IF (ASSOCIATED(sm_group%messages)) CALL DestroyMessageListObject(sm_group%messages)
00577       IF (ASSOCIATED(sm_group%proclist)) CALL ClearProcessorList(sm_group%proclist)
00578 
00579       DEALLOCATE(sm_group)
00580       NULLIFY(sm_group)
00581 
00582    END SUBROUTINE DestroyMessageGroupObject
00583 
00585 
00588 
00593    SUBROUTINE AppendProcessorToList(proc_id, last_proc, proc_list)
00594       TYPE(ProcessorList), POINTER :: last_proc
00595       TYPE(ProcessorList), POINTER, OPTIONAL :: proc_list
00596       INTEGER :: proc_id
00597       INTEGER :: iErr
00598 
00599       IF (.NOT. ASSOCIATED(Last_proc)) THEN     
00600         ALLOCATE(Last_proc, STAT=iErr)
00601         NULLIFY(Last_proc%next)
00602         IF (iErr /= 0) THEN
00603            PRINT *, "AppendProcessorToList() error: unable to allocate Last_proc list object."
00604            STOP
00605          END IF
00606          IF (present(proc_list)) proc_list=>last_proc
00607       ELSE
00608          IF (ASSOCIATED(Last_proc%next)) THEN
00609             PRINT *, "Error - last proc_id next allocated"
00610             STOP
00611          END IF
00612          ALLOCATE(Last_proc%next, STAT=iErr)
00613          IF (iErr /= 0) THEN
00614              PRINT *, "AddProc_id() error: unable to allocate Last_proc%next list object."
00615              STOP
00616          END IF
00617          Last_proc=>Last_proc%next         
00618          NULLIFY(Last_proc%next)
00619       END IF
00620       Last_proc%self=proc_id
00621    END SUBROUTINE AppendProcessorToList
00622 
00623 
00627    SUBROUTINE AddProcessorToMGList(sm_group, proc_id)
00628       TYPE(StageMessageGroup), POINTER :: sm_group
00629       INTEGER :: proc_id
00630 
00631 
00632       IF (.NOT. ASSOCIATED(sm_group)) THEN
00633          PRINT *, "AddProcessorToMGList() error: no message group associated."
00634          STOP
00635       END IF
00636 
00637       CALL AppendProcessorToList(proc_id, sm_group%last_proc, sm_group%proclist)
00638 
00639    END SUBROUTINE AddProcessorToMGList
00640 
00641 
00642 
00643 
00644 
00647    RECURSIVE SUBROUTINE ClearProcessorList(proc_list)
00648 
00649       TYPE(ProcessorList), POINTER :: proc_list
00650 
00651 
00652       IF (.NOT. ASSOCIATED(proc_list))  RETURN
00653 
00654       IF (ASSOCIATED(proc_list%next))  CALL ClearProcessorList(proc_list%next)
00655 
00656       DEALLOCATE(proc_list)
00657       NULLIFY(proc_list)
00658 
00659    END SUBROUTINE ClearProcessorList
00660 
00662 
00663 
00664 END MODULE MessageDeclarations
00665 
00666 
 All Classes Files Functions Variables