Scrambler
1
|
00001 !######################################################################### 00002 ! 00003 ! Copyright (C) 2003-2012 Department of Physics and Astronomy, 00004 ! University of Rochester, 00005 ! Rochester, NY 00006 ! 00007 ! pth_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 !######################################################################### 00023 MODULE PthDeclarations 00024 USE GlobalDeclarations 00025 USE HyperbolicDeclarations 00026 USE Timing 00027 IMPLICIT NONE 00028 include 'fpth.f' 00029 INTEGER, PARAMETER :: nAdvanceSleeps=4, AdvanceSleepTime=1 00030 INTEGER, PARAMETER :: nControlSleeps=1, ControlSleepTime=1 00031 TYPE IntStatus 00032 integer, POINTER :: val 00033 END type IntStatus 00034 INTEGER, DIMENSION(-2:MaxDepth) :: threadarg 00035 REAL(8) :: NextBarrierTime 00036 INTEGER :: returnstatus(-2:MaxDepth) 00037 TYPE(fpth_t) :: control_thread, advance_threads(-2:MaxDepth), comm_thread 00038 TYPE(fpth_attr_t) :: control_attribute, advance_attributes(-2:MaxDepth), comm_attribute 00039 INTEGER :: Advance_StackSize=10*1024*1024 !100 mB 00040 00041 LOGICAL, DIMENSION(-2:MaxDepth) :: lAdvanceActive, lAdvanceCompleted 00042 LOGICAL :: lControlActive 00043 00044 00045 INTEGER :: pVerBose=0 00046 INTEGER, PARAMETER :: nIters=0 00047 00048 INTEGER, PARAMETER :: TESTANY=0, TESTALL=1, TESTONE=2, TESTNONE=3 00049 00050 INTEGER, SAVE :: Curr_TestType=TESTNONE 00051 INTEGER, SAVE, POINTER, DIMENSION(:) :: Curr_req_array 00052 INTEGER, SAVE, POINTER :: Curr_req=>NULL() 00053 INTEGER, SAVE, POINTER, DIMENSION(:) :: Curr_mpi_status 00054 INTEGER, SAVE, POINTER :: Curr_ierr=>NULL() 00055 LOGICAL, SAVE, POINTER :: curr_success=>NULL() 00056 INTEGER, SAVE, POINTER :: curr_req_index=>NULL() 00057 INTEGER, SAVE, POINTER :: Curr_nreqs=>NULL() 00058 00059 INTEGER, PARAMETER :: commint=-1 00060 00061 ! routines by which the control thread yields 00062 PUBLIC :: pth_MPI_WAIT, pth_MPI_WAITANY, pth_MPI_WAITALL, pth_MPI_BARRIER, pth_MPI_BARRIER2, pth_MPI_BARRIER3 00063 00064 ! routine by which the advance threads yield 00065 PUBLIC :: yield 00066 00067 contains 00068 00069 00070 00071 SUBROUTINE pth_MPI_WAIT(mpi_request, mpi_status, ierr) 00072 INTEGER,TARGET :: mpi_request, ierr, mpi_status(MPI_STATUS_SIZE) 00073 INTEGER :: yield_err, ierr2, n 00074 TYPE(IntStatus) :: status 00075 LOGICAL, TARGET :: success 00076 ! CALL MPI_WAIT(mpi_request, mpi_status, ierr) 00077 ! write(*,*) 'MPIW', mpi_request, mpi_status, ierr 00078 ! RETURN 00079 00080 IF (ANY(lAdvanceActive(0:MaxLevel))) THEN 00081 ! write(*,*) 'waiting', 00082 success=.false. 00083 CALL MPI_TEST(mpi_request, success, mpi_status, ierr) 00084 IF (.not. success) THEN 00085 write(*,*) 'waiting for request', mpi_request 00086 Curr_req=>mpi_request 00087 Curr_mpi_status=>mpi_status 00088 Curr_ierr=>ierr 00089 Curr_TestType=TESTONE 00090 Curr_success=>success 00091 ! write(*,'(20I)') 0, MPI_ID, loc(curr_req), loc(curr_success), loc(curr_ierr), loc(curr_mpi_status) 00092 ! write(*,'(20I)') 0, TESTONE, MPI_ID, curr_req, curr_success, curr_ierr, curr_mpi_status 00093 DO WHILE (.NOT. success .AND. ANY(lAdvanceActive(0:MaxLevel))) 00094 IF (pVerbose >= 2) writE(*,*) 'wait yielding' 00095 DO n=MaxLevel, 0, -1 00096 IF (lAdvanceActive(n)) EXIT 00097 END DO 00098 IF (pVerbose >=2 ) write(*,*) 'yielding to advance thread', n 00099 CALL fpth_yield(advance_threads(n), ierr) 00100 CALL pth_checkerr(ierr, 'fpth_yield') 00101 ! CALL fpth_yield_any(yield_err) 00102 IF (pVerbose >= 2) write(*,*) 'wait resuming' 00103 END DO 00104 ! write(*,*) 'wait resuming' 00105 ! CALL fpth_spawn(comm_thread, comm_attribute, yield, commint) 00106 ! CALl yield(0) 00107 ! CALL fpth_join(comm_thread, status, ierr2) 00108 00109 IF (.NOT. success) THEN 00110 ! write(*,*) 'waiting' 00111 CALL StartTimer(iBarrier, 0) 00112 CALL MPI_WAIT(mpi_request, mpi_status, ierr) 00113 CALL StopTimer(iBarrier, 0) 00114 END IF 00115 NULLIFY(Curr_req, Curr_mpi_status, Curr_ierr, Curr_success) 00116 Curr_TestType=TESTNONE 00117 ! write(*,*) 'reseetting curr_testtype' 00118 END IF 00119 ! write(*,*) 'completed', mpi_request, mpi_status, ierr 00120 ELSE 00121 IF (pverbose >= 2) write(*,*) 'waiting mpi_wait ' 00122 CALL StartTimer(iBarrier, 0) 00123 CALL MPI_WAIT(mpi_request, mpi_status, ierr) 00124 CALL StopTimer(iBarrier, 0) 00125 END IF 00126 00127 END SUBROUTINE pth_MPI_WAIT 00128 00129 00130 SUBROUTINE pth_MPI_WAITANY(nreqs, req_array, req_index, mpi_status, iErr) 00131 INTEGER, TARGET :: iErr, nreqs, req_index, mpi_status(MPI_STATUS_SIZE) 00132 INTEGER, POINTER, DIMENSION(:) :: req_array 00133 LOGICAL, TARGET :: success 00134 INTEGER :: yield_err, ierr2, n 00135 TYPE(IntStatus) :: status 00136 IF (ANY(lAdvanceActive(0:MaxLevel))) THEN 00137 success=.false. 00138 CALL MPI_TESTANY(nreqs, req_array, req_index, success, mpi_status, iErr) 00139 IF (.NOT. success) THEN 00140 ! write(*,*) 'failed to find waiting for request', mpi_request 00141 00142 Curr_nreqs=>nreqs 00143 Curr_req_array=>req_array 00144 Curr_req_index=>req_index 00145 Curr_mpi_status=>mpi_status 00146 Curr_ierr=>ierr 00147 ! write(*,*) 'setting currtesttype to', TESTANY, loc(threadarg(-1)), threadarg(-1) 00148 Curr_TestType=TESTANY 00149 Curr_success=>success 00150 ! write(*,*) 'commint=', commint 00151 ! CALL fpth_spawn(comm_thread, comm_attribute, yield, threadarg(-1)) 00152 ! CALl yield(0) 00153 ! CALL fpth_join(comm_thread, status, ierr2) 00154 00155 ! CALL yield(0) 00156 ! write(*,'(20I)') 0, MPI_ID, loc(curr_req_array), loc(curr_nreqs), loc(curr_success), loc(curr_ierr), loc(curr_mpi_status), loc(curr_req_index) 00157 ! write(*,'(20I)') 0, TESTANY, MPI_ID, curr_req_array, curr_nreqs, curr_success, curr_ierr, curr_mpi_status, curr_req_index 00158 DO WHILE (.NOT. success .AND. ANY(lAdvanceActive(0:MaxLevel))) 00159 IF (pVerbose >= 2) write(*,*) 'wait any yielding', lAdvanceActive(0:MaxLevel) 00160 DO n=MaxLevel, 0, -1 00161 IF (lAdvanceActive(n)) EXIT 00162 END DO 00163 IF (pVerbose >=2 ) write(*,*) 'yielding to advance thread', n 00164 CALL fpth_yield(advance_threads(n), ierr) 00165 CALL pth_checkerr(ierr, 'fpth_yield') 00166 ! CALL fpth_yield_any(yield_err) 00167 IF (pVerbose >= 2) write(*,*) 'wait any resuming' 00168 END DO 00169 IF (.NOT. success) THEN 00170 ! write(*,*) 'waitanying' 00171 CALL StartTimer(iBarrier,0) 00172 CALL MPI_WAITANY(nreqs, req_array, req_index, mpi_status, iErr) 00173 CALL StopTimer(iBarrier,0) 00174 END IF 00175 00176 NULLIFY(Curr_req_array, Curr_mpi_status, Curr_ierr, Curr_success, Curr_req_index, Curr_nreqs) 00177 Curr_TestType=TESTNONE 00178 ! write(*,*) 'reseetting curr_testtype' 00179 END IF 00180 00181 ELSE 00182 ! IF (pverbose >= 2) write(*,*) 'waiting mpi_waitany' 00183 CALL StartTimer(iBarrier,0) 00184 CALL MPI_WAITANY(nreqs, req_array, req_index, mpi_status, iErr) 00185 CALL StopTimer(iBarrier,0) 00186 END IF 00187 END SUBROUTINE pth_MPI_WAITANY 00188 00189 SUBROUTINE pth_MPI_WAITALL(nreqs, req_array, iErr) 00190 INTEGER, TARGET :: iErr, nreqs, req_index 00191 INTEGER, POINTER, DIMENSION(:) :: req_array 00192 INTEGER :: yield_err, ierr2, n 00193 TYPE(IntStatus) :: status 00194 LOGICAL, TARGET :: success 00195 IF (ANY(lAdvanceActive(0:MaxLevel))) THEN 00196 success=.false. 00197 CALL MPI_TESTALL(nreqs, req_array, success, MPI_STATUSES_IGNORE, iErr) 00198 IF (.NOT. success) THEN 00199 Curr_req_array=>req_array 00200 Curr_ierr=>ierr 00201 Curr_TestType=TESTALL 00202 Curr_success=>success 00203 Curr_nreqs=>nreqs 00204 ! CALL fpth_spawn(comm_thread, comm_attribute, yield, threadarg(-1)) 00205 ! CALl yield(0) 00206 ! CALL fpth_join(comm_thread, status, ierr2) 00207 00208 ! CALl yield(0) 00209 00210 ! write(*,'(20I)') 0, MPI_ID, loc(curr_req_array), loc(curr_nreqs), loc(curr_success), loc(curr_ierr) 00211 ! write(*,'(20I)') 0, TESTALL, MPI_ID, curr_req_array, curr_nreqs, curr_success, curr_ierr 00212 DO WHILE (.NOT. success .AND. ANY(lAdvanceActive(0:MaxLevel))) 00213 IF (pVerbose >= 2) write(*,*) 'wait all yielding', lAdvanceActive(0:MaxLevel) 00214 DO n=MaxLevel, 0, -1 00215 IF (lAdvanceActive(n)) EXIT 00216 END DO 00217 IF (pVerbose >=2 ) write(*,*) 'yielding to advance thread', n 00218 CALL fpth_yield(advance_threads(n), ierr) 00219 CALL pth_checkerr(ierr, 'fpth_yield') 00220 ! CALL fpth_yield_any(yield_err) 00221 IF (pVerbose >= 2) write(*,*) 'wait all resuming' 00222 END DO 00223 IF (.NOT. success) THEN 00224 ! write(*,*) 'waitalling' 00225 CALL StartTimer(iBarrier,0) 00226 CALL MPI_WAITALL(nreqs, req_array, MPI_STATUSES_IGNORE, iErr) 00227 CALL StopTimer(iBarrier,0) 00228 END IF 00229 NULLIFY(Curr_req_array, Curr_ierr, Curr_success, Curr_nreqs) 00230 Curr_TestType=TESTNONE 00231 ! write(*,*) 'reseetting curr_testtype' 00232 END IF 00233 ELSE 00234 IF (pverbose >= 2) write(*,*) 'waiting mpi_waitall' 00235 CALL StartTimer(iBarrier,0) 00236 CALL MPI_WAITALL(nreqs, req_array, MPI_STATUSES_IGNORE, iErr) 00237 CALL StopTimer(iBarrier,0) 00238 END IF 00239 END SUBROUTINE pth_MPI_WAITALL 00240 00241 SUBROUTINE pth_MPI_BARRIER(comm, ierr) 00242 INTEGER :: iErr, nreqs, req_index,i 00243 INTEGER, POINTER, DIMENSION(:) :: req_array 00244 INTEGER :: dummy_int 00245 INTEGER :: pth_BarrierTag=160000 00246 INTEGER :: comm 00247 !This subroutine needs to perform a nonblocking mpi_barrier call. One way to do this is to have every processor send a small message to one processor - and have that one processor then send a message back to everyone. 00248 00249 ! IF (MPI_ID == 0) THEN 00250 IF (MPI_NP == 1) RETURN 00251 00252 ! IF (ANY(lAdvanceActive(0:MaxLevel))) THEN 00253 nreqs=2*(MPI_NP-1) 00254 ALLOCATE(req_array(nreqs)) 00255 DO i=1, MPI_NP-1 00256 CALL MPI_IRECV(dummy_int, 1, MPI_INTEGER, modulo(MPI_ID+i, MPI_NP), pth_BarrierTag, MPI_COMM_WORLD, req_array(i), iErr) 00257 END DO 00258 DO i=1, MPI_NP-1 00259 CALL MPI_ISEND(dummy_int, 1, MPI_INTEGER, modulo(MPI_ID+i, MPI_NP), pth_BarrierTag, MPI_COMM_WORLD, req_array(MPI_NP-1+i), iErr) 00260 END DO 00261 CALL StartTimer(iBarrier,0) 00262 CALL pth_MPI_WAITALL(nreqs, req_array, iErr) 00263 CALL StopTimer(iBarrier,0) 00264 ! ELSE 00265 ! write(*,*) 'waiting mpi_barrier', lAdvanceActive(0:MaxLevel) 00266 ! CALL MPI_BARRIER(comm, ierr) 00267 ! END IF 00268 END SUBROUTINE pth_MPI_BARRIER 00269 00270 SUBROUTINE pth_MPI_BARRIER2(comm, ierr) 00271 INTEGER :: iErr, nreqs, req_index,i 00272 INTEGER, POINTER, DIMENSION(:) :: req_array 00273 INTEGER :: dummy_int 00274 INTEGER :: pth_BarrierTag=16000 00275 INTEGER :: comm 00276 !This subroutine needs to perform a nonblocking mpi_barrier call. One way to do this is to have every processor send a small message to one processor - and have that one processor then send a message back to everyone. 00277 00278 IF (MPI_ID == 0) THEN 00279 nreqs=MPI_NP-1 00280 ALLOCATE(req_array(nreqs)) 00281 DO i=1, MPI_NP-1 00282 CALL MPI_IRECV(dummy_int, 1, MPI_INTEGER, i, pth_BarrierTag, MPI_COMM_WORLD, req_array(i), iErr) 00283 END DO 00284 CALL pth_MPI_WAITALL(nreqs, req_array, iErr) 00285 00286 DO i=1, MPI_NP-1 00287 CALL MPI_ISEND(dummy_int, 1, MPI_INTEGER, i, pth_BarrierTag, MPI_COMM_WORLD, req_array(i), iErr) 00288 END DO 00289 CALL pth_MPI_WAITALL(nreqs, req_array, iErr) 00290 ELSE 00291 nreqs=2 00292 ALLOCATE(req_array(nreqs)) 00293 CALL MPI_IRECV(dummy_int, 1, MPI_INTEGER, 0, pth_BarrierTag, MPI_COMM_WORLD, req_array(1), iErr) 00294 CALL MPI_ISEND(dummy_int, 1, MPI_INTEGER, 0, pth_BarrierTag, MPI_COMM_WORLD, req_array(2), iErr) 00295 CALL pth_MPI_WAITALL(nreqs, req_array, iErr) 00296 END IF 00297 DEALLOCATE(req_array) 00298 END SUBROUTINE Pth_MPI_BARRIER2 00299 00300 00301 SUBROUTINE pth_MPI_BARRIER3(comm, ierr) 00302 REAL(8) :: current_time 00303 INTEGER :: comm, ierr 00304 INTEGER :: n, yield_err 00305 IF (NextBarrierTime > MPI_WTIME()) THEN 00306 IF (ANY(lAdvanceActive(0:MaxLevel))) THEN 00307 DO n=MaxLevel, 0, -1 00308 IF (lAdvanceActive(n)) EXIT 00309 END DO 00310 CALL fpth_yield(advance_threads(n), ierr) 00311 CALL pth_checkerr(ierr, 'fpth_yield') 00312 ! CALL fpth_yield_any(yield_err) 00313 END IF 00314 END IF 00315 END SUBROUTINE pth_MPI_BARRIER3 00316 00317 SUBROUTINE yield(n) 00318 INTEGER :: ierr 00319 INTEGER, INTENT(IN) :: n 00320 TYPE(fpth_t) :: my_thread 00321 LOGICAL :: lRepeat 00322 REAL(8) :: tused 00323 IF (lControlActive) THEN !We are waiting to join the current thread 00324 IF (ASSOCIATED(Curr_success)) THEN !Curr_TestType /= TESTNONE) 00325 00326 ! update time for modifying redistributions.. 00327 tused = mpi_wtime()-t_startadvance(n) 00328 WorkDoneByLevel(n)=WorkDoneByLevel(n)+tused 00329 WorkDoneByGrid(n)=WorkDoneByGrid(n)+tused 00330 00331 SELECT CASE(Curr_TestType) 00332 CASE(TESTONE) 00333 CALL MPI_TEST(Curr_req, Curr_success, Curr_mpi_status, Curr_ierr) 00334 CASE(TESTANY) 00335 CALL MPI_TESTANY(Curr_nreqs,Curr_req_array, Curr_req_index, Curr_success, Curr_mpi_status, Curr_iErr) 00336 CASE(TESTALL) 00337 CALL MPI_TESTALL(Curr_nreqs, Curr_req_array, Curr_success, MPI_STATUSES_IGNORE, Curr_iErr) 00338 END SELECT 00339 00340 IF (Curr_success) THEN !Request has completed 00341 IF (pVerbose >= 1) write(*,*) 'yielding to control thread' 00342 CALL StopTimer(iAdvanceGrids, n) 00343 CALL fpth_yield(control_thread, ierr) 00344 CALL pth_checkerr(ierr, 'fpth_yield') 00345 CALL StartTimer(iAdvanceGrids, n) 00346 IF (pVerbose >= 1) write(*,*) 'advance thread resuming on level ', n 00347 END IF 00348 t_startadvance(n)=mpi_wtime() 00349 ELSE ! the control thread is active but there is no active request? 00350 00351 ! we maybe waiting for a certain walltime 00352 00353 write(*,*) 'whoops in pth_declarations' 00354 STOP 00355 ! IF (MPI_WTIME() > NextBarrierTime) CALL fpth_yield(control_thread, ierr) 00356 ! CALL pth_checkerr(ierr, 'fpth_yield') 00357 00358 END IF 00359 END IF 00360 ! write(*,*) 'continuing advance' 00361 END SUBROUTINE yield 00362 00363 SUBROUTINE pth_CheckErr(iErr, errString) 00364 CHARACTER(*) :: errString 00365 INTEGER :: iErr 00366 00367 IF(iErr/=1) THEN 00368 PRINT'(A,A)','*** Threads returned an error on ',errString 00369 PRINT'(A,I8)',' with error code ',iErr 00370 STOP 00371 END IF 00372 END SUBROUTINE Pth_CheckErr 00373 00374 00375 END MODULE PthDeclarations