Scrambler
1
|
00001 !######################################################################### 00002 ! 00003 ! Copyright (C) 2003-2012 Department of Physics and Astronomy, 00004 ! University of Rochester, 00005 ! Rochester, NY 00006 ! 00007 ! pth_control.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 ! This module controls the spawning and joining of advance threads as well as the initialization of the threads and the advancing of grids 00024 MODULE PthControl 00025 USE PthDeclarations 00026 USE HyperbolicControl 00027 IMPLICIT NONE 00028 CONTAINS 00029 00030 SUBROUTINE PthInit() 00031 INTEGER :: n, ierr 00032 CALL fpth_self(control_thread) 00033 CALL fpth_attr_of(control_attribute, control_thread) 00034 CALL fpth_attr_set_prio(control_attribute, FPTH_PRIO_MAX, ierr) 00035 CALL pth_checkerr(ierr, 'fpth_set_priority') 00036 DO n=0, MaxLevel 00037 CALL fpth_attr_new(advance_attributes(n)) 00038 CALL fpth_attr_set_prio(advance_attributes(n), FPTH_PRIO_MIN, ierr) 00039 CALL pth_checkerr(ierr, 'fpth_set_priority') 00040 END DO 00041 lAdvanceActive=.false. 00042 lAdvanceCompleted=.true. 00043 threadarg(-2:MaxLevel)=(/(n,n=-2,MaxLevel)/) 00044 ! write(*,*) threadarg 00045 ! CALL fpth_attr_new(comm_attribute) 00046 ! CALL fpth_attr_set_stacksize(comm_attribute, ADVANCE_STACKSIZE, ierr) 00047 ! CALL pth_checkerr(ierr, 'fpth_set_stacksize') 00048 ! CALL fpth_attr_set_prio(comm_attribute, FPTH_PRIO_MIN, ierr) 00049 ! CALL pth_checkerr(ierr, 'fpth_set_priority') 00050 lControlActive=.true. 00051 Curr_TestType=TESTNONE 00052 ! IF (MPI_ID == 0) pVerbose = 1 00053 END SUBROUTINE PthInit 00054 00055 00056 SUBROUTINE LaunchAdvanceThread(n) 00057 USE DataLevelOps 00058 INTEGER :: n, ierr,i 00059 DO i=n-1,0,-1 00060 IF (lAdvanceActive(i)) THEN 00061 IF (pVerbose >= 1) write(*,*) 'suspending', i 00062 lAdvanceActive(i)=.false. 00063 CALL fpth_suspend(advance_threads(i), ierr) 00064 CALL pth_checkerr(ierr, 'fpth_suspend') 00065 ! EXIT 00066 END IF 00067 END DO 00068 IF (pverbose >= 1) write(*,*) 'spawning', n, threadarg(n) 00069 lAdvanceActive(n)=.true. 00070 lAdvanceCompleted(n)=.false. 00071 CALL fpth_attr_set_stacksize(advance_attributes(n), AdvanceStackSize(n), ierr) 00072 CALL pth_checkerr(ierr, 'fpth_set_stacksize') 00073 CALL fpth_spawn(advance_threads(n), advance_attributes(n), PthAdvanceGrids, threadarg(n)) 00074 END SUBROUTINE LaunchAdvanceThread 00075 00076 SUBROUTINE JoinAdvanceThread(n) 00077 INTEGER :: n, ierr 00078 TYPE(IntStatus) :: status 00079 IF (pVerbose >= 1) write(*,*) 'joining', n 00080 ! If we give up control at the join - then we will want it back immediately 00081 00082 lControlActive=.false. 00083 CALL fpth_join(advance_threads(n), status, ierr) 00084 CALL pth_checkerr(ierr, 'fpth_join') 00085 levels(n)%tnow=levels(n)%tnow+levels(n)%dt 00086 lControlActive=.true. 00087 !Resume next lower advance thread that has not compoleted 00088 IF (pverbose >= 1) write(*,*) 'im back' 00089 IF (status%val /= n) THEN 00090 PRINT*, 'exit code unexpected', status%val 00091 STOP 00092 END IF 00093 00094 END SUBROUTINE JoinAdvanceThread 00095 00098 SUBROUTINE PthAdvanceGrids(n) 00099 USE TreeDeclarations 00100 USE DataDeclarations 00101 USE HyperbolicControl 00102 USE HyperbolicDeclarations 00103 USE Scheduling 00104 INTEGER :: n,i,ierr 00105 TYPE(NodeDef), POINTER :: node 00106 TYPE(NodeDefList), POINTER :: nodelist 00107 ! Yield back to control thread if not on max level 00108 ! IF (n < MaxLevel) THEN 00109 ! IF (pVerBose >= 1) write(*,*) 'yielding back to control thread' 00110 ! CALL fpth_yield(control_thread, ierr) 00111 ! CALL Pth_checkerr(ierr, 'fpth_yield') 00112 ! END IF 00113 00114 CALL StartTimer(iAdvanceGrids, n) 00115 00116 IF (pVerbose >= 1) write(*,*) 'beginning advance', n 00117 if (levels(n)%dt > 0d0) THEN 00118 nodelist=>Nodes(n)%p 00119 DO WHILE (associated(nodelist)) 00120 node=>nodelist%self 00121 CALL Advance(node%info, .true.) 00122 IF (.NOT. nodecompleted(n)) THEN 00123 write(*,*) 'error - node not updated' 00124 STOP 00125 END IF 00126 nodelist=>nodelist%next 00127 END DO 00128 00129 END if 00130 CALL StopTimer(iAdvanceGrids, n) 00131 00132 DO i=n-1,0,-1 00133 IF (.NOT. lAdvanceCompleted(i)) THEN 00134 CALL fpth_resume(advance_threads(i), ierr) 00135 CALL Pth_checkerr(ierr, 'fpth_resume') 00136 lAdvanceActive(i)=.true. 00137 IF (pverbose >= 1) write(*,*) 'resuming advance thread', i 00138 EXIT 00139 END IF 00140 END DO 00141 lAdvanceActive(n)=.false. 00142 lAdvanceCompleted(n)=.true. 00143 returnstatus(n)=n 00144 IF (pverbose >= 1) write(*,*) 'thread', n, 'exiting' 00145 CALL fpth_exit(returnstatus(n)) 00146 END SUBROUTINE PthAdvanceGrids 00147 00148 00149 00150 END module PthControl