Scrambler
1
|
00001 !######################################################################### 00002 ! 00003 ! Copyright (C) 2003-2012 Department of Physics and Astronomy, 00004 ! University of Rochester, 00005 ! Rochester, NY 00006 ! 00007 ! elliptic_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 !######################################################################### 00025 00028 00031 00035 00038 MODULE EllipticControl 00039 USE Timing 00040 USE GlobalDeclarations 00041 USE CommunicationDeclarations 00042 USE TreeDeclarations 00043 USE DataDeclarations 00044 USE Poisson 00045 USE PhysicsDeclarations 00046 USE EllipticComms 00047 IMPLICIT NONE 00048 PUBLIC EllipticInit, EllipticSetup, EllipticSolve, EllipticDestroy, ApplyEllipticBC 00049 INTEGER :: isolve=0 00050 CONTAINS 00051 00052 00055 00057 SUBROUTINE EllipticInit 00058 INTEGER :: i 00059 INTEGER :: iErr 00060 lEllipticPeriodic=.false. 00061 NrEllipticObjects=0 00062 ALLOCATE(elliptic_maxspeed(0:MaxLevel)) 00063 elliptic_maxspeed = 0.d0 00064 lPoissonSolve=(lSelfGravity) 00065 IF (lPoissonSolve) THEN 00066 NrEllipticObjects=NrEllipticObjects+1 00067 iPoissonSolve=NrEllipticObjects 00068 END IF 00069 IF (NrEllipticObjects > 0) THEN 00070 ALLOCATE(EllipticObjects(NrEllipticObjects)) 00071 END IF 00072 IF (iPoissonSolve .ne. 0) CALL Poisson_Init(EllipticObjects(iPoissonSolve)) 00073 DO i=1,NrEllipticObjects 00074 ALLOCATE(EllipticObjects(i)%LevelObjects(0:MaxLevel)) 00075 END DO 00076 lAnyPeriodic=lAnyPeriodic .OR. lEllipticPeriodic 00077 END SUBROUTINE EllipticInit 00079 00082 00085 SUBROUTINE InitialElliptic(n) 00086 INTEGER :: n 00087 TYPE(NodeDef), POINTER :: node 00088 TYPE(NodeDefList), POINTER :: nodelist 00089 INTEGER :: matrixID, ierr 00090 REAL(KIND=qPREC) :: temp 00091 CALL StartTimer(iElliptic, n) 00092 temp=levels(n)%dt 00093 levels(n)%dt=0d0 00094 IF (lElliptic) THEN 00095 CALL EllipticSetup(n) 00096 CALL EllipticSolve(n) 00097 CALL EllipticDestroy(n) 00098 CALL PostElliptic(n) 00099 ! IF (nEllipticTransferFields > 0) THEN 00100 ! CALL EllipticTransfer(n, EllipticTransferFields, levels(n)%egmbc(1)) 00101 ! END IF 00102 END IF 00103 levels(n)%dt=temp 00104 CALL StopTimer(iElliptic, n) 00105 END SUBROUTINE InitialElliptic 00106 00109 SUBROUTINE Elliptic(n) 00110 INTEGER :: n, iErr 00111 CALL StartTimer(iElliptic, n) 00112 IF (lElliptic) THEN 00113 CALL MPI_ALLREDUCE(lRequestRestart, RestartStep, 1, MPI_LOGICAL, MPI_LOR, MPI_COMM_WORLD, iErr) 00114 IF (RestartStep) THEN 00115 ! IF (levels(n)%step > 1) THEN !We already setup the grid etc... 00116 ! CALL EllipticDestroy(n) 00117 ! END IF 00118 ! IF (MPI_ID == 0) write(*,*) 'Skipping elliptic solve since restart was requested' 00119 RETURN 00120 END IF 00121 ! IF (levels(n)%step == 1) THEN 00122 CALL EllipticSetup(n) 00123 ! END IF 00124 CALL EllipticSolve(n) 00125 ! IF (levels(n)%step == levels(n)%steps) THEN 00126 CALL EllipticDestroy(n) 00127 ! END IF 00128 CALL PostElliptic(n) 00129 END IF 00130 CALL StopTimer(iElliptic, n) 00131 END SUBROUTINE Elliptic 00132 00134 00135 00138 00141 SUBROUTINE EllipticSetup(n) 00142 INTEGER :: n 00143 TYPE(NodeDefList), POINTER :: nodelist 00144 INTEGER :: iErr 00145 INTEGER :: i, nnodes, totalnodes, mb(3,2), minmb(3), maxmb(3), minmbo(3), maxmbo(3), minsize, maxsize, minsizeo, maxsizeo 00146 REAL(8) :: datasize, totaldatasize 00147 CHARACTER(LEN=21) :: s_filename 00148 !First create the grid for this level to be used by all elliptic equations 00149 CALL C_StructGridCreate(levels(n)%MPI_COMM, nDim, levels(n)%Grid, iErr); CALL CheckErr('C_StructGridCreate',iErr) 00150 nodelist=>nodes(n)%p 00151 datasize=0 00152 nnodes=0 00153 minmb=2**10 00154 maxmb=-2**10 00155 minsize=2**10 00156 maxsize=-2**10 00157 DO WHILE (associated(nodelist)) 00158 CALL C_StructGridSetExtents(levels(n)%Grid, nodelist%self%box%mGlobal(1:nDim,1), nodelist%self%box%mGlobal(1:nDim,2), iErr) 00159 CALL CheckErr('C_StructGridSetExtents',iErr) 00160 ! mB=nodelist%self%box%mGlobal(1:nDim,:) 00161 ! datasize=datasize+product(mB(:,2)-mB(:,1) + 1) 00162 ! minmb=min(minmb, mB(:,1)) 00163 ! maxmb=max(maxmb, mB(:,2)) 00164 ! minsize=min(minsize, product(mB(:,2)-mB(:,1)+1)) 00165 ! maxsize=max(maxsize, product(mB(:,2)-mB(:,1)+1)) 00166 ! nnodes=nnodes+1 00167 nodelist=>nodelist%next 00168 END DO 00169 00170 !! CALL MPI_REDUCE(nnodes, totalnodes, 1, MPI_INTEGER, MPI_SUM, 0, MPI_COMM_WORLD, iErr) 00171 ! CALL MPI_REDUCE(datasize, totaldatasize, 1, MPI_DOUBLE_PRECISION, MPI_SUM, 0, MPI_COMM_WORLD, iErr) 00172 ! CALL MPI_REDUCE(minmb, minmbo, 3, MPI_INTEGER, MPI_MIN, 0, MPI_COMM_WORLD, iErr) 00173 ! CALL MPI_REDUCE(maxmb, maxmbo, 3, MPI_INTEGER, MPI_MAX, 0, MPI_COMM_WORLD, iErr) 00174 ! CALL MPI_REDUCE(minsize, minsizeo, 1, MPI_INTEGER, MPI_MIN, 0, MPI_COMM_WORLD, iErr) 00175 ! CALL MPI_REDUCE(maxsize, maxsizeo, 1, MPI_INTEGER, MPI_MAX, 0, MPI_COMM_WORLD, iErr) 00176 00177 ! IF (MPI_ID == 0) write(*,*) n, totalnodes, totaldatasize, minmbo, maxmbo, minsizeo, maxsizeo 00178 00179 ! CALL MPI_BARRIER(MPI_COMM_WORLD, iErr) 00180 IF (ANY(lEllipticPeriodic(1:nDim))) CALL C_StructGridSetPeriodic(levels(n)%Grid,levels(n)%mX(1:nDim), iErr) 00181 !If Self Gravity and Thermal Diffusion are not both periodic this will break 00182 CALL CheckErr('StructGridSetPeriodic',iErr) 00183 CALL C_StructGridAssemble(levels(n)%Grid, iErr); CALL CheckErr('C_StructGridAssemble',iErr) 00184 !Next setup matrices for different elliptic objects 00185 DO i=1,NrEllipticObjects 00186 CALL C_StructMatrixCreate(levels(n)%MPI_COMM, levels(n)%Grid, EllipticObjects(i)%Stencil, EllipticObjects(i)%LevelObjects(n)%Matrix, iErr) ;CALL CheckErr('C_StructMatrixCreate',iErr) 00187 CALL C_StructMatrixInitialize(EllipticObjects(i)%LevelObjects(n)%Matrix, iErr); CALL CheckErr('C_StructMatrixInitialize',iErr) 00188 IF (i == iPoissonSolve) THEN 00189 CALL Poisson_Setup(n,EllipticObjects(i)%LevelObjects(n)) 00190 END IF 00191 CALL C_StructMatrixAssemble(EllipticObjects(i)%LevelObjects(n)%Matrix, iErr);CALL CheckErr('C_StructMatrixAssemble',iErr) 00192 IF (EllipticObjects(i)%hVerbosity > 0) THEN 00193 write(s_filename,'(A7,I2.2,A1,I2.2,A1,I4.4,A4)') "matrix_",n,"_",i,"_",isolve,".dat" 00194 CALL C_StructMatrixPrint(s_filename, EllipticObjects(i)%LevelObjects(n)%Matrix, 0, ierr) 00195 CALL CheckErr('C_SStructMatrixPrint', iErr) 00196 END IF 00197 END DO 00198 END SUBROUTINE EllipticSetup 00199 00202 SUBROUTINE EllipticSolve(n) 00203 INTEGER :: n 00204 INTEGER :: i 00205 INTEGER :: ierr, iters 00206 CHARACTER(LEN=25) :: s_filename 00207 LOGICAL :: done_solving 00208 isolve=isolve+1 00209 elliptic_maxspeed(n)=0 00210 DO i=1,NrEllipticObjects 00211 done_solving=.false. 00212 CALL PreSolveComm(i,n,done_solving) 00213 DO WHILE (.not. done_solving) 00214 CALL C_StructVectorCreate(levels(n)%MPI_COMM, levels(n)%Grid, EllipticObjects(i)%LevelObjects(n)%VariableVector, iErr) ;CALL CheckErr('C_StructVectorCreate',iErr) 00215 CALL C_StructVectorCreate(levels(n)%MPI_COMM, levels(n)%Grid, EllipticObjects(i)%LevelObjects(n)%SolutionVector, iErr) ;CALL CheckErr('C_StructVectorCreate',iErr) 00216 CALL C_StructVectorInitialize(EllipticObjects(i)%LevelObjects(n)%VariableVector, iErr); CALL CheckErr('C_StructVectorInitialize',iErr) 00217 CALL C_StructVectorInitialize(EllipticObjects(i)%LevelObjects(n)%SolutionVector, iErr); CALL CheckErr('C_StructVectorInitialize', iErr) 00218 IF (i == iPoissonSolve) THEN 00219 CALL Poisson_LoadVectors(n,EllipticObjects(iPoissonSolve)%LevelObjects(n)) 00220 END IF 00221 CALL C_StructVectorAssemble(EllipticObjects(i)%LevelObjects(n)%VariableVector, iErr) ;CALL CheckErr('C_StructVectorAssemble',iErr) 00222 CALL C_StructVectorAssemble(EllipticObjects(i)%LevelObjects(n)%SolutionVector, iErr) ;CALL CheckErr('C_StructVectorAssemble',iErr) 00223 IF (EllipticObjects(i)%hVerbosity > 0) THEN 00224 write(s_filename,'(A11,I2.2,A1,I2.2,A1,I4.4,A4)') "rhs_vector_",n,"_",i,"_",isolve,".dat" 00225 CALL C_StructVectorPrint(s_filename, EllipticObjects(i)%LevelObjects(n)%VariableVector, 0, ierr) 00226 CALL CheckErr('C_StructMatrixPrint', iErr) 00227 write(s_filename,'(A11,I2.2,A1,I2.2,A1,I4.4,A4)') "lhs_vector_",n,"_",i,"_",isolve,".dat" 00228 CALL C_StructVectorPrint(s_filename, EllipticObjects(i)%LevelObjects(n)%SolutionVector, 0, ierr) 00229 CALL CheckErr('C_StructVectorPrint', iErr) 00230 END IF 00231 00232 SELECT CASE(EllipticObjects(i)%solver) !Choose correct solver 00233 CASE(StructPCG) 00234 CALL C_StructPCGCreate(levels(n)%MPI_COMM, EllipticObjects(i)%LevelObjects(n)%Solver, iErr); CALL CheckErr('C_SStructPCGCreate',iErr) 00235 00236 ! set solver parameters 00237 CALL C_StructPCGSetTol(EllipticObjects(i)%LevelObjects(n)%Solver, EllipticObjects(i)%tolerance, iErr) 00238 CALL CheckErr('C_StructPCGSetTol',iErr) 00239 00240 ! set solver parameters 00241 CALL C_StructPCGSetMaxIter(EllipticObjects(i)%LevelObjects(n)%Solver, EllipticObjects(i)%MaxIters, iErr) 00242 CALL CheckErr('C_StructPCGSetMaxIter',iErr) 00243 00244 CALL C_StructPCGSetPrintLevel(EllipticObjects(i)%LevelObjects(n)%Solver, EllipticObjects(i)%printlevel, iErr) 00245 CALL CheckErr('C_StructPCGSetPrintLevel',iErr) 00246 00247 ! setup and solve 00248 CALL C_StructPCGSetup(EllipticObjects(i)%LevelObjects(n)%Solver, EllipticObjects(i)%LevelObjects(n)%Matrix, EllipticObjects(i)%LevelObjects(n)%VariableVector, EllipticObjects(i)%LevelObjects(n)%SolutionVector, iErr) 00249 CALL CheckErr('C_StructPCGSetup',iErr) 00250 CALL C_StructPCGSolve(EllipticObjects(i)%LevelObjects(n)%Solver, EllipticObjects(i)%LevelObjects(n)%Matrix, EllipticObjects(i)%LevelObjects(n)%VariableVector, EllipticObjects(i)%LevelObjects(n)%SolutionVector, iErr) 00251 CALL CheckErr('C_StructPCGSolve',iErr) 00252 CALL C_StructPCGGetNumIterations(EllipticObjects(i)%LevelObjects(n)%Solver, Iters, iErr) 00253 CALL CheckErr('C_StructPCGSolve',iErr) 00254 CALL CheckIters(Iters, EllipticObjects(i)%MaxIters) 00255 CALL C_StructPCGDestroy(EllipticObjects(i)%LevelObjects(n)%Solver,iErr) 00256 CALL CheckErr('C_StructPCGDestroy',iErr) 00257 CASE(StructGMRES) 00258 00259 CALL C_StructGMRESCreate(levels(n)%MPI_COMM, EllipticObjects(i)%LevelObjects(n)%Solver, iErr); CALL CheckErr('C_SStructGMRESCreate',iErr) 00260 00261 ! set solver parameters 00262 CALL C_StructGMRESSetTol(EllipticObjects(i)%LevelObjects(n)%Solver, EllipticObjects(i)%tolerance, iErr) 00263 CALL CheckErr('C_StructGMRESSetTol',iErr) 00264 00265 CALL C_StructGMRESSetMaxIter(EllipticObjects(i)%LevelObjects(n)%Solver, EllipticObjects(i)%maxIters, iErr) 00266 CALL CheckErr('C_StructGMRESSetMaxIter',iErr) 00267 00268 CALL C_StructGMRESSetPrintLevel(EllipticObjects(i)%LevelObjects(n)%Solver, EllipticObjects(i)%printlevel, iErr) 00269 CALL CheckErr('C_StructGMRESSetPrintLevel',iErr) 00270 00271 ! setup and solve 00272 CALL C_StructGMRESSetup(EllipticObjects(i)%LevelObjects(n)%Solver, EllipticObjects(i)%LevelObjects(n)%Matrix, EllipticObjects(i)%LevelObjects(n)%VariableVector, EllipticObjects(i)%LevelObjects(n)%SolutionVector, iErr) 00273 CALL CheckErr('C_StructGMRESSetup',iErr) 00274 CALL C_StructGMRESSolve(EllipticObjects(i)%LevelObjects(n)%Solver, EllipticObjects(i)%LevelObjects(n)%Matrix, EllipticObjects(i)%LevelObjects(n)%VariableVector, EllipticObjects(i)%LevelObjects(n)%SolutionVector, iErr) 00275 CALL CheckErr('C_StructGMRESSolve',iErr) 00276 CALL C_StructGMRESGetNumIterations(EllipticObjects(i)%LevelObjects(n)%Solver, Iters, iErr) 00277 CALL CheckErr('C_StructPCGSolve',iErr) 00278 CALL CheckIters(Iters, EllipticObjects(i)%MaxIters) 00279 CALL C_StructGMRESDestroy(EllipticObjects(i)%LevelObjects(n)%Solver,iErr) 00280 CALL CheckErr('C_StructGMRESDesetroy',iErr) 00281 00282 END SELECT 00283 00284 !Choose correct routine to unload vector objects 00285 IF (i == iPoissonSolve) THEN 00286 CALL Poisson_UnLoadVectors(n,EllipticObjects(iPoissonSolve)%LevelObjects(n)) 00287 END IF 00288 CALL C_StructVectorDestroy(EllipticObjects(i)%LevelObjects(n)%VariableVector, iErr) ;CALL CheckErr('C_StructVectorDestroy',iErr) 00289 CALL C_StructVectorDestroy(EllipticObjects(i)%LevelObjects(n)%SolutionVector, iErr) ;CALL CheckErr('C_StructVectorDestroy',iErr) 00290 CALL BetweenSolveComm(i,n,done_solving) 00291 END DO 00292 CALL PostSolveComm(i,n) 00293 END DO 00294 END SUBROUTINE EllipticSolve 00295 00298 SUBROUTINE EllipticDestroy(n) 00299 INTEGER :: n 00300 TYPE(NodeDefList), POINTER :: nodelist 00301 INTEGER :: ierr 00302 INTEGER :: i 00303 !First create the grid for this level to be used by all elliptic equations 00304 DO i=1,NrEllipticObjects 00305 CALL C_StructMatrixDestroy(EllipticObjects(i)%LevelObjects(n)%Matrix, iErr) ;CALL CheckErr('C_StructMatrixDestroy',iErr) 00306 END DO 00307 CALL C_StructGridDestroy(levels(n)%Grid, iErr); CALL CheckErr('C_StructGridDesetroy',iErr) 00308 END SUBROUTINE EllipticDestroy 00309 00312 SUBROUTINE PostElliptic(n) 00313 INTEGER :: i 00314 INTEGER :: n 00315 DO i=1,NrEllipticObjects 00316 IF (i == iPoissonSolve) THEN 00317 CALL PoissonPostElliptic(n) 00318 END IF 00319 END DO 00320 END SUBROUTINE PostElliptic 00322 00323 00326 00331 SUBROUTINE PreSolveComm(i,n,done_solving) 00332 INTEGER :: i 00333 INTEGER :: n 00334 LOGICAL :: done_solving 00335 IF (i == iPoissonSolve) THEN 00336 CALL PoissonPreSolveComm(n,done_solving) 00337 END IF 00338 END SUBROUTINE PreSolveComm 00339 00344 SUBROUTINE BetweenSolveComm(i,n,done_solving) 00345 INTEGER :: i 00346 INTEGER :: n 00347 LOGICAL :: done_solving 00348 IF (i == iPoissonSolve) THEN 00349 CALL PoissonBetweenSolveComm(n,done_solving) 00350 END IF 00351 END SUBROUTINE BetweenSolveComm 00352 00356 SUBROUTINE PostSolveComm(i,n) 00357 INTEGER :: i 00358 INTEGER :: n 00359 LOGICAL :: done_solving 00360 IF (i == iPoissonSolve) THEN 00361 CALL PoissonPostSolveComm(n) 00362 END IF 00363 END SUBROUTINE PostSolveComm 00364 00365 00366 00367 SUBROUTINE ApplyEllipticBC(n) 00368 INTEGER :: n 00369 CALL StartTimer(iApplyEllipticBCs, n) 00370 IF (lPoissonSolve) CALL PoissonSetBC(n) 00371 CALL StopTimer(iApplyEllipticBCs, n) 00372 END SUBROUTINE ApplyEllipticBC 00373 00374 00375 00377 00378 00379 00380 00381 END MODULE EllipticControl 00382