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