!######################################################################### ! ! Copyright (C) 2003-2012 Department of Physics and Astronomy, ! University of Rochester, ! Rochester, NY ! ! scrambler.f90 is part of AstroBEAR. ! ! AstroBEAR is free software: you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation, either version 3 of the License, or ! (at your option) any later version. ! ! AstroBEAR is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with AstroBEAR. If not, see . ! !######################################################################### !> @mainpage Scrambler Documentation !> @file scrambler.f90 !! @brief Main program file program scrambler USE GlobalDeclarations USE PhysicsControl USE ModuleControl USE SourceControl USE SourceDeclarations USE IOControl USE AmrControl USE TreeLevelOps USE DataLevelOps USE DistributionControl USE TreeDeclarations USE CommunicationControl USE HyperbolicControl USE TimeStep USE Scheduling USE ParticleControl, ONLY: Particle_ReadData, NrSinkParticles USE ProcessingControl USE Timing # if defined PTH USE PthControl # endif IMPLICIT NONE SAVE INTEGER :: iErr, provided # if defined PTH ! CALL MPI_INIT_THREAD(MPI_THREAD_FUNNELED, provided, ierr) provided=0 CALL fpth_init(ierr) CALL pth_checkerr(ierr, 'fpth_init') CALL MPI_INIT(ierr) # else CALL MPI_INIT(ierr) # endif CALL MPI_Comm_rank(MPI_COMM_WORLD, MPI_ID, ierr) CALL MPI_Comm_size(MPI_COMM_WORLD, MPI_NP, ierr) # if defined PTH IF (provided /= MPI_THREAD_FUNNELED) THEN IF (MPI_ID == 0) write(*,*) 'WARNING: MPI_INIT_FUNNELED not supported' ! STOP END IF #endif CALL AstroBear() CALL MPI_FINALIZE(iErr) CONTAINS SUBROUTINE AstroBEAR() INTEGER :: TempBaseLevel REAL(KIND=qPREC) :: tnext, t_programend, t_start INTEGER :: iErr, n, i TYPE(NodeBox), POINTER :: root_box TYPE(NodeDef), POINTER :: root_node TYPE(NodeDefList), POINTER :: nodelist, childlist CALL AMRInit CALL IOInit() CALL CommInit() CALL WriteHeader() IF (MPI_ID == 0) WRITE(*,*) 'Running on ', MPI_NP, ' cores' CALL DomainInit() CALL SrcInit(ExplicitSource,0) CALL PhysicsInit() CALL ProcessInit() CALL LevelsInit() CALL DistributionInit CALL ModuleObjectsInit() CALL ModuleProblemInit() CALL PhysicsFinalizeInit() CALL HyperbolicInit() CALL BoundaryZoneInit() CALL SrcFinalizeInit() CALL SchedulingInit() CALL ProfileAdvance() CALL TimeStepInit() CALL TimerInit() BaseLevel=-1 ! Default Baselevel is domain level lRegridLevel=.true. lRegridLevel(-2)=.false. IF (iThreaded == NON_THREADED .OR. LevelBalance(2)==0d0 .OR. MaxLevel == 0) BaseLevel = 0 IF (lPostProcess) THEN DO WHILE (restart_frame <= final_frame) current_frame=restart_frame CALL DestroyParticleList(SinkParticles) NULLIFY(LastSinkParticle) NrSinkParticles=0 CALL Particle_ReadData(restart_frame) CALL IORestartInit(restart_frame) levels(:)%tnow=current_time CALL AMRStart(-2) CALL IORestartFinalize(restart_frame) CALL ProcessData() IF (lReOutput) CALL WriteDataFrame(restart_frame) ! Write the initial data frame to a file. CALL PostIO(restart_frame) CALL DestroyAllNodes NULLIFY(root_box, root_node) CALL CreateNodeBox(GmGlobal, root_box, 0) CALL AddNode(-2, root_box, root_node) CALl DestroyNodeBox(root_box) restart_frame=restart_frame+1 END DO ELSE IF (lRestart .OR. lRegrid) THEN ! [BDS][20110114]: Read in particle data here so that all source term and particle restart data ! is available when the module is initialized. IF (lRestart) CALL Particle_ReadData(restart_frame) t_start = MPI_Wtime() CALL IORestartInit(restart_frame) levels(:)%tnow=current_time CALL AMRStart(-2) CALL IORestartFinalize(restart_frame) current_frame = restart_frame levels(:)%dt=0 IF (lRegrid) THEN IF (MPI_NP > 1) THEN PRINT*, 'Err - Regrid only supports 1 processor currently' STOP END IF ! CALL UpdateOverlaps(BaseLevel) BaseLevel = -2 lRegridLevel=.true. lRegridLevel(-2:BaseLevel) = .false. CALL AMR(BaseLevel) !Give level 0 grids a chance to redistribute if we are using a different number of cores DO i=-1, MaxLevel IF (i-1 >= 0) THEN !shift nodelists up... Nodes(i-1)%p=>Nodes(i)%p LastLocalNode(i-1)%p=>LastLocalNode(i)%p ELSE !Keep nodelists but increase the size by 2... IF (i-1 == -1) THEN !Don't want to create MPI_NP level 1 nodes but we do want to inherit grandchildren as children. This is possible if we are on one processor nodelist=>Nodes(i-1)%p DO WHILE (ASSOCIATED(nodelist)) childlist=>nodelist%self%children NULLIFY(nodelist%self%children) NULLIFY(nodelist%self%lastchild) DO WHILE (ASSOCIATED(childlist)) !Assume that every level 0 child has 1 level 1 grandchild ! CALL AddChild(nodelist%self, childlist%self%children%self) childlist=>childlist%next END DO CALL ClearNodeList(childlist) nodelist=>nodelist%next END DO END IF nodelist=>Nodes(i-1)%p DO WHILE (ASSOCIATED(nodelist)) nodelist%self%box%mGlobal=levelUp(nodelist%self%box%mGlobal,0,1) nodelist=>nodelist%next END DO END IF END DO domains(1)%mGlobal=levelUp(domains(1)%mGlobal,0,1) GmGlobal=levelUp(GmGlobal, 0, 1) Gmx=GmGlobal(:,2)-GmGlobal(:,1)+1 olddt=olddt/2d0 !Adjust this for restarts since the time step should be cut in half NULLIFY(Nodes(MaxLevel)%p, OldNodes(MaxLevel)%p, ExternalNodes(MaxLevel)%p, OldExternalNodes(MaxLevel)%p, LastLocalNode(MaxLevel)%p, LastOldLocalNode(MaxLevel)%p, LastExternalNode(MaxLevel)%p, LastOldExternalNode(MaxLevel)%p) ! CALL ProcessData() ! CALL WriteDataFrame(restart_frame) IF (MPI_ID == 0) THEN write(*,'(A,4I4)') 'Done Regridding to level ', 1 write(*,'(A,3I6)') 'Gmx should be adjusted to ', levels(1)%mX write(*,'(A,6I6)') 'And Domain%mGlobal should be reset to ', 1, 1, 1, levels(1)%mX END IF CALL MPI_BARRIER(MPI_COMM_WORLD, iErr) CALL MPI_FINALIZE(iErr) ELSE tempBaseLevel=BaseLevel BaseLevel = -1 lRegridLevel=.true. lRegridLevel(-2:BaseLevel) = .false. CALL AMR(BaseLevel) ! on a restart we need to give the level 0 grids a chance to redistribute DO i=0,min(LastStaticLevel, MaxLevel) CALL DestroyOldNodes(i) !And we can get rid of the data we read in now. END DO BaseLevel = tempBaseLevel IF (current_frame-start_frame /= nint(REAL(current_time-start_time)/(final_time-start_time)*final_frame-start_frame)) THEN DO current_frame=start_frame, final_frame tnext=REAL((current_frame-start_frame))*(final_time-start_time)/REAL(final_frame-start_frame) IF (tnext > current_time) EXIT END DO current_frame=current_frame-1 PRINT*, 'Adjusting current frame from ', restart_frame, 'to ', current_frame, 'probably because of a change in the number of output frames' END IF CALL ProcessData() CALL WriteDataFrame(restart_frame) CALL MPI_FINALIZE(iErr) END IF ELSE current_frame = start_frame current_time = start_time levels(:)%dt=0 levels(:)%tnow=start_time CALL AMRStart(-2) ! Set up initial Grids ! tempBaseLevel=BaseLevel ! BaseLevel = -1 lRegridLevel=.true. lRegridLevel(-2:BaseLevel) = .false. ! write(*,*) 'BaseLevel', BaseLevel CALL AMR(BaseLevel) ! BaseLevel = tempBaseLevel ! lRegridLevel=.true. ! lRegridLevel(-2:BaseLevel) = .false. ! write(*,*) 'PostAMR', BaseLevel ! STOP CALL GetFirstTimeStep ! This determines olddt in case of restarts from frame 0 CALL ProcessData() CALL WriteDataFrame(start_frame) ! Creates the initial data file. CALL PostIO(start_frame) END IF LastStaticLevel=min(MaxLevel, max(BaseLevel, LastStaticLevel)) lRegridLevel=.true. lRegridLevel(-2:LastStaticLevel)=.false. CALL StartTimer(iBarrier, -2) CALL MPI_BARRIER(MPI_COMM_WORLD, iErr) CALL StopTimer(iBarrier, -2) StartTime = MPI_Wtime() Timers(iBarrier)%Accumulator=0 Timers(iAmr)%Accumulator=0 ! Advance the simulation until the final frame has been completed. DO WHILE (current_frame < final_frame) current_frame=current_frame+1 ! Calculate the next frame time. The simulation will be advanced from tnow to tnext. tnext=start_time+REAL((current_frame-start_frame))*(final_time-start_time)/REAL(final_frame-start_frame) CALL AMRAdvance(tnext) ! Advance to next output time CALL ProcessData() ! Do any processing CALL WriteDataFrame(current_frame) ! Write the new data frame to a file. CALL PostIO(current_frame) END DO END IF CALL PrintAllocations ! Close all open I/O handles and parameters. CALL IOClose() t_programend = MPI_Wtime() IF (MPI_id == 0) THEN PRINT * PRINT "('Total Runtime = ', f25.16, ' seconds.')", t_programend - StartTime END IF ! CALL WriteStats() ! CALL HyperbolicFinalize() CALL DestroyAllNodes() CALL PrintAllocations() END SUBROUTINE AstroBEAR SUBROUTINE WriteHeader IF (MPI_ID == 0) THEN write(*,'(A78)') "==============================================================================" write(*,'(A78)') "| _ _ ____ _____ _ ____ ____ ___ |" write(*,'(A78)') "| / \ ___| |_ _ __ ___ | __ )| ____| / \ | _ \ |___ \ / _ \ |" write(*,'(A78)') "| / _ \ / __| __| '__/ _ \| _ \| _| / _ \ | |_) | __) | | | | | |" write(*,'(A78)') "| / ___ \\__ \ |_| | | (_) | |_) | |___ / ___ \| _ < / __/ _| |_| | |" write(*,'(A78)') "| /_/ \_\___/\__|_| \___/|____/|_____/_/ \_\_| \_\ |_____(_)\___/ |" write(*,'(A78)') "| |" write(*,'(A78)') "==============================================================================" END IF END SUBROUTINE WriteHeader END program scrambler