Scrambler  1
pth_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 !    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
 All Classes Files Functions Variables