Scrambler
1
|
00001 !######################################################################### 00002 ! 00003 ! Copyright (C) 2003-2012 Department of Physics and Astronomy, 00004 ! University of Rochester, 00005 ! Rochester, NY 00006 ! 00007 ! data_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 !######################################################################### 00025 00029 00030 00040 MODULE DataDeclarations 00041 USE GlobalDeclarations 00042 USE Boundary 00043 USE SlopeLim 00044 IMPLICIT NONE 00045 PRIVATE 00046 00047 PUBLIC :: InfoDef 00048 00049 PUBLIC :: InitInfo, InitialInitInfo, AllocChildFixups, BackupInfo 00050 00051 PUBLIC :: NullifyInfoFields, DestroyInfo, DeAllocChildFixups 00052 00053 PUBLIC :: BoxOverlap, LevelUp, LevelDown, GetMBounds, stretch, stretchaux, MapToLevel 00054 00055 PUBLIC :: CalcOverlaps, CalcAuxOverlaps, CalcEMFOverlaps, CalcFluxOverlaps, GhostOverlap, CalcPhysicalOverlaps, CalcCellOverlaps, CellPos, PosCell, storefixupfluxes, storeemfs, MapBoxToInfo, MapBoxToLevel, ProlongateCellCenteredData, expand 00056 00058 TYPE InfoDef 00059 SEQUENCE 00060 ! Defined by AMR module 00061 INTEGER :: level ! AMR level 00062 INTEGER, DIMENSION(3,2) :: mGlobal ! Global Index of child on level 00063 INTEGER, DIMENSION(3,2) :: mBounds ! Index of child within parent grid 00064 INTEGER, DIMENSION(3,2) :: mthbc ! boundary conditions (should be 3x2) 00065 REAL(KIND=xPrec), DIMENSION(3,2) :: xBounds ! physical bounds of grid 00066 INTEGER, DIMENSION(3) :: mX ! Size of grid 00067 ! REAL(KIND=qPrec) :: CostPerCell ! Average computational cost per cell for this info 00068 ! REAL(KIND=qPrec) :: OldCostPerCell ! Average computational cost per cell for this info 00069 REAL(KIND=qPrec), DIMENSION(:), ALLOCATABLE :: CostPerGrid ! Average computational cost per grid for this info 00070 REAL(KIND=qPrec), DIMENSION(:,:,:,:), POINTER :: costmap ! stores the sub tree cost per cell 00071 REAL(KIND=qPrec), DIMENSION(:,:,:,:), POINTER :: Parentcostmap ! accumulates cost for the parent 00072 INTEGER, DIMENSION(:,:,:), POINTER :: ChildMask ! Contains child ID's for refined cells 00073 00074 ! Defined by advance module 00075 INTEGER, DIMENSION(:,:,:), POINTER :: ErrFlag ! Pointer to Refinement Flags 00076 00077 ! Updated by processing module 00078 REAL(KIND=qPREC), DIMENSION(:,:,:,:), POINTER :: diagnostics ! Pointer to cell-centered quantities 00079 00080 ! Updated by advance module 00081 REAL(KIND=qPREC), DIMENSION(:,:,:,:), POINTER :: q ! Pointer to cell-centered quantities 00082 REAL(KIND=qPREC), DIMENSION(:,:,:,:), POINTER :: aux ! Pointer to B-fields (face centered) 00083 REAL(KIND=qPREC), DIMENSION(:,:,:,:), POINTER :: qParent ! Pointer to parents cell-centered fields 00084 REAL(KIND=qPREC), DIMENSION(:,:,:,:), POINTER :: auxParent ! Pointer to parents face centered fields (used for first reconstruction) 00085 REAL(KIND=qPREC), DIMENSION(:,:,:,:), POINTER :: qChild ! Back up of q for child prolongation 00086 REAL(KIND=qPREC), DIMENSION(:,:,:,:), POINTER :: auxChild ! Back up of aux for child prolongation 00087 REAL(KIND=qPREC), DIMENSION(:,:,:,:), POINTER :: MassFlux ! Pointer to mass flux arrays needed to make self gravity 2nd order 00088 00089 ! Fluxes stored to preserve interlevel and intralevel conservation 00090 TYPE(Boundaries), POINTER :: fixupflux ! Pointer to fluxes at grid edges (for synchronization with neighbors) 00091 TYPE(Boundaries), POINTER :: parentfixup ! coarsened fluxes for parents (for synchronization with parents) 00092 TYPE(pBoundaries), POINTER, DIMENSION(:) :: childfixups ! Pointers to coarse fluxes applied at childrens' edges to be differenced with children's parentfixup 00093 00094 ! EMF's stored to preserve interlevel and intralevel Divergence of B 00095 REAL(KIND=qPREC), DIMENSION(:,:,:,:), POINTER :: emf ! Pointer to emf's (edge centered) 00096 REAL(KIND=qPREC), DIMENSION(:,:,:,:), POINTER :: parentemf ! Accumulated emf's for parent 00097 REAL(KIND=qPREC), DIMENSION(:,:,:,:), POINTER :: childemf ! Pointer to accumulated child emf's (edge centered) 00098 00099 END TYPE InfoDef 00100 00101 CONTAINS 00102 00105 00110 SUBROUTINE InitInfo(Info, level, mGlobal, ParentmGlobal) 00111 TYPE(InfoDef), POINTER :: Info 00112 INTEGER, DIMENSION(3,2) :: mGlobal 00113 INTEGER, DIMENSION(3,2), OPTIONAL :: ParentmGlobal 00114 INTEGER :: level,rmbc 00115 INTEGER, DIMENSION(3,2) :: mB !Bounds for cell-centered grid values (costmap, qChild, ErrFlag) 00116 INTEGER, DIMENSION(3,2) :: mA !Bounds for face/edge centered grid values (AuxChild, ChildEmf) 00117 INTEGER, DIMENSION(3,2) :: mCext !Extended bounds for mass flux 00118 INTEGER, DIMENSION(3,2) :: mBext !Extended bounds for grid values (q) 00119 INTEGER, DIMENSION(3,2) :: mAext !Extended bounds for aux values (aux,emf) 00120 INTEGER, DIMENSION(3,2) :: mC !1-cell extended cell-centered values (childmask) 00121 INTEGER, DIMENSION(3,2) :: PmB !Parents Cell centered bounds (qParent, ParentFixup) 00122 INTEGER, DIMENSION(3,2) :: PmA !Parents face/edge centered bounds (ParentEMF, auxParent) 00123 00124 if (level < 0) THEN 00125 write(*,*) "shouldn't be allocating info" 00126 STOP 00127 END if 00128 ALLOCATE(Info) 00129 00130 ALLOCATE(Info%CostPerGrid(1:levels(level)%steps)) 00131 ! ALLOCATE(Info%CostPerGrid(1:levels(Info%level)%steps)) 00132 00133 CALL NullifyInfoFields(Info) 00134 Info%level=level 00135 ! Info%CostPerCell=1 00136 ! Info%OldCostPerCell=1 00137 ! Info%level=level 00138 Info%mGlobal=mGlobal 00139 IF (Present(ParentmGlobal)) THEN 00140 Info%mBounds=GetmBounds(mGlobal, ParentmGlobal, Info%level) 00141 ELSE 00142 Info%mBounds=mGlobal 00143 END IF 00144 Info%mX=mGlobal(:,2)-mGlobal(:,1)+1 00145 Info%xBounds(:,1)=GxBounds(:,1)+(mGlobal(:,1)-1)*levels(level)%dx 00146 Info%xBounds(:,2)=GxBounds(:,1)+(mGlobal(:,2))*levels(level)%dx 00147 mB=1 00148 mA=1 00149 mAext=1 00150 mBext=1 00151 mC=1 00152 pmA=1 00153 mCext=1 00154 mB(1:nDim,2)=Info%mX(1:nDim) 00155 mA(1:nDim,2)=Info%mX(1:nDim)+1 00156 PmB=Info%mBounds 00157 PmA(1:nDim,2)=PmB(1:nDim,2)+1 00158 PmA(1:nDim,1)=PmB(1:nDim,1) 00159 mC(1:nDim,1)=0;mC(1:nDim,2)=Info%mX(1:nDim)+1 00160 rmbc=levels(level-1)%pmbc*levels(level-1)%CoarsenRatio 00161 mBext(1:nDim,1)=mB(1:nDim,1)-rmbc;mBext(1:nDim,2)=mB(1:nDim,2)+rmbc 00162 mAext(1:nDim,1)=mA(1:nDim,1)-rmbc;mAext(1:nDim,2)=mA(1:nDim,2)+rmbc 00163 mCext(1:nDim,1)=1-levels(Info%level)%ambc(1);mCext(1:nDim,2)=Info%mX(1:nDim)+1+levels(Info%level)%ambc(1) !range of mass flux 00164 00165 ! Info%CostPerGrid = Info%CostPerCell * PRODUCT(Info%mX) 00166 00167 ! ALLOCATE(Info%costmap(mB(1,1):mB(1,2),mB(2,1):mB(2,2),mB(3,1):mB(3,2),2)) 00168 ! Info%costmap=0 00169 IF (Info%level >= 0) THEN 00170 CALL AllocBoundaries(Info%fixupflux,mB) 00171 ALLOCATE(Info%q(mBext(1,1):mBext(1,2),mBext(2,1):mBext(2,2),mBext(3,1):mBext(3,2),NrVars)) 00172 CALL CheckAllocation(InfoAllocator, size(Info%q)*8, 'q') 00173 INfo%q(:,:,:,:) = 0d0/0d0 00174 IF (lStoreMassFlux) THEN 00175 ALLOCATE(Info%MassFlux(mCext(1,1):mCext(1,2), mCext(2,1):mCext(2,2), mCext(3,1):mCext(3,2),1:nDim)) 00176 CALL CheckAllocation(InfoAllocator, size(Info%massflux)*8,"massflux") 00177 Info%MassFlux=0 00178 END IF 00179 00180 IF (MaintainAuxArrays) THEN 00181 ALLOCATE(Info%aux(mAext(1,1):mAext(1,2),mAext(2,1):mAext(2,2),mAext(3,1):mAext(3,2),1:nAux)) 00182 CALL CheckAllocation(InfoAllocator, size(Info%aux)*8,"aux") 00183 ALLOCATE(Info%emf(mAext(1,1):mAext(1,2),mAext(2,1):mAext(2,2),mAext(3,1):mAext(3,2),1:nEMF)) !Don't need space to receive child emf's 00184 CALL CheckAllocation(InfoAllocator, size(Info%emf)*8,"emf") 00185 Info%emf=0 !Clear emf so it can accumulate 00186 END IF 00187 00188 IF (Info%level < MaxLevel) THEN 00189 ALLOCATE(Info%ErrFlag(mC(1,1):mC(1,2),mC(2,1):mC(2,2),mC(3,1):mC(3,2))) 00190 CALL CheckAllocation(InfoAllocator, size(Info%ErrFlag)*4,"ErrFlag") 00191 ALLOCATE(Info%qChild(mBext(1,1):mBext(1,2),mBext(2,1):mBext(2,2),mBext(3,1):mBext(3,2),nProlongate)) 00192 CALL CheckAllocation(InfoAllocator, size(Info%qChild)*8,"qChild") 00193 IF (MaintainAuxArrays) THEN 00194 ALLOCATE(Info%childemf(mA(1,1):mA(1,2),mA(2,1):mA(2,2),mA(3,1):mA(3,2),1:nEMf)) 00195 CALL CheckAllocation(InfoAllocator, size(Info%childemf)*8,"childemf") 00196 ALLOCATE(Info%auxChild(mAext(1,1):mAext(1,2),mAext(2,1):mAext(2,2),mAext(3,1):mAext(3,2),1:nAux)) 00197 CALL CheckAllocation(InfoAllocator, size(Info%auxchild)*8) 00198 END IF 00199 END IF 00200 ALLOCATE(Info%ChildMask(mC(1,1):mC(1,2),mC(2,1):mC(2,2),mC(3,1):mC(3,2))) 00201 CALL CheckAllocation(InfoAllocator, size(Info%childmask)*4,"childmask") 00202 Info%ChildMask=-1 !Assume we are isolated 00203 ! IF (Info%level == 0) Info%ChildMask=0 00204 00205 IF (Info%level > 0) THEN 00206 ! Most things we need two copies of - the child's version and the parent's version - so they can be differenced or merged correctly. 00207 ! The cell centered quantities being the only exception. Here the parent's values just get overwritten by child values... 00208 ! Two avoid allocating extra space and performing an extra copy on child grids that are on the same processor as their parent 00209 ! it is better to just have the child grids point to their parents 00210 ! IF (Present(Parent)) THEN 00211 ! Info%qParent=>Parent%q 00212 ! ELSE 00213 ALLOCATE(Info%qParent(PmB(1,1):PmB(1,2),PmB(2,1):PmB(2,2),PmB(3,1):PmB(3,2),nRestrict)) 00214 CALL CheckAllocation(InfoAllocator, size(Info%qParent)*8,"qParent") 00215 ! END IF 00216 CALL AllocBoundaries(Info%parentfixup,PmB) 00217 IF (MaintainAuxArrays) THEN 00218 ALLOCATE(Info%parentemf(PmA(1,1):PmA(1,2),PmA(2,1):PmA(2,2),PmA(3,1):PmA(3,2),nEMF)) 00219 CALL CheckAllocation(InfoAllocator, size(Info%Parentemf)*8,"Parentemf") 00220 END IF 00221 END IF 00222 END IF 00223 00224 ! IF (Info%level > -2) THEN 00225 ! mB=Info%mBounds 00226 ! ALLOCATE(Info%ParentCostMap(mB(1,1):mB(1,2),mB(2,1):mB(2,2),mB(3,1):mB(3,2),1)) 00227 ! END IF 00228 END SUBROUTINE InitInfo 00229 00230 00235 SUBROUTINE InitialInitInfo(Info, level, mGlobal, ParentmGlobal) 00236 TYPE(InfoDef), POINTER :: Info 00237 INTEGER, DIMENSION(3,2) :: mGlobal 00238 INTEGER, DIMENSION(3,2), OPTIONAL :: ParentmGlobal 00239 INTEGER :: level, rmbc 00240 INTEGER, DIMENSION(3,2) :: mB !Bounds for cell-centered grid values (costmap, qChild, ErrFlag) 00241 INTEGER, DIMENSION(3,2) :: mA !Bounds for face/edge centered grid values (AuxChild, ChildEmf) 00242 INTEGER, DIMENSION(3,2) :: mBext !Extended bounds for grid values (q) 00243 INTEGER, DIMENSION(3,2) :: mAext !Extended bounds for aux values (aux,emf) 00244 INTEGER, DIMENSION(3,2) :: mC !1-cell extended cell-centered values (childmask) 00245 INTEGER, DIMENSION(3,2) :: PmB !Parents Cell centered bounds (qParent, ParentFixup) 00246 INTEGER, DIMENSION(3,2) :: PmA !Parents face/edge centered bounds (ParentEMF, auxParent) 00247 00248 IF (Present(ParentmGlobal)) THEN 00249 CALL InitInfo(Info, level, mGlobal, ParentmGlobal) 00250 ELSE 00251 CALL InitInfo(Info, level, mGlobal) 00252 END IF 00253 ! Info%costmap(:,:,:,1)=0d0 !tiny(1e0)!d0!1e-10!tiny(1e0)!0!1!2**((nDim+1)*(MaxLevel-max(level,0))) 00254 ! Info%costmap(:,:,:,2)=0d0 00255 00256 IF (Info%level > 0) THEN 00257 IF (MaintainAuxArrays) THEN 00258 PmA=Info%mBounds 00259 00260 PmA(1:nDim,2)=PmA(1:nDim,2)+1 00261 ALLOCATE(Info%auxParent(PmA(1,1):PmA(1,2),PmA(2,1):PmA(2,2),PmA(3,1):PmA(3,2),nAux)) 00262 CALL CheckAllocation(InfoAllocator, size(Info%auxParent)*8, "auxParent") 00263 END IF 00264 END IF 00265 00266 END SUBROUTINE InitialInitInfo 00267 00268 00273 SUBROUTINE storefixupfluxes(Info, mS, dim, f, fields) 00274 TYPE(InfoDef) :: Info 00275 INTEGER :: mS(3,2), mT(3,2), dim, pos(3), edges(2), ip(3,2), iq(3,2), childleft, childright,i,j,k, l,posl(3) 00276 REAL(KIND=qPREC), DIMENSION(:,:,:,:) :: f 00277 INTEGER, DIMENSION(:), OPTIONAL :: fields 00278 INTEGER :: fluxloc, mbc 00279 00280 IF (lStoreMassFlux) THEN 00281 fluxloc=0 00282 IF (present(fields)) THEN 00283 DO j=1,size(fields) 00284 IF (fields(j) == 1) THEN 00285 fluxloc=j 00286 END IF 00287 END DO 00288 ELSE 00289 fluxloc=1 00290 END IF 00291 IF (fluxloc /= 0) THEN 00292 mbc=levels(Info%level)%ambc(levels(Info%level)%step) 00293 mT=mS 00294 mT(1:nDim,1)=max(mS(1:nDim,1),1-mbc) 00295 mT(1:nDim,2)=min(mS(1:nDim,2),Info%mX(1:nDim)+mbc) 00296 mT(dim,2)=min(mS(dim,2), Info%mX(dim)+mbc+1) 00297 iq=mT-spread(mS(:,1),2,2)+1 00298 Info%MassFlux(mT(1,1):mT(1,2), mT(2,1):mT(2,2), mT(3,1):mT(3,2), dim) = & 00299 f(iq(1,1):iq(1,2), iq(2,1):iq(2,2), iq(3,1):iq(3,2),fluxloc) 00300 END IF 00301 END IF 00302 00303 00304 mT=mS 00305 mT(:,1)=max(mS(:,1),1) 00306 mT(:,2)=min(mS(:,2),Info%mX) 00307 mT(dim,2)=min(mS(dim,2), Info%mX(dim)+1) 00308 ip=mT 00309 iq=mT 00310 edges=(/1,Info%mX(dim)+1/) 00311 DO i=1,2 00312 IF (mT(dim,1) <= edges(i) .AND. edges(i) <= mT(dim,2)) THEN 00313 ip(dim,:)=i 00314 iq=mT-spread(mS(:,1),2,2)+1 00315 iq(dim,:)=edges(i)-mS(dim,1)+1 00316 IF (present(fields)) THEN 00317 DO j=1,size(fields) 00318 fluxloc=invFluxFields(fields(j)) 00319 IF (fluxloc /= 0) THEN 00320 Info%fixupflux%side(dim)%data(ip(1,1):ip(1,2),ip(2,1):ip(2,2),ip(3,1):ip(3,2),fluxloc) = & 00321 Info%fixupflux%side(dim)%data(ip(1,1):ip(1,2),ip(2,1):ip(2,2),ip(3,1):ip(3,2),fluxloc) + & 00322 f(iq(1,1):iq(1,2), iq(2,1):iq(2,2), iq(3,1):iq(3,2),j) 00323 END IF 00324 END DO 00325 ELSE 00326 Info%fixupflux%side(dim)%data(ip(1,1):ip(1,2),ip(2,1):ip(2,2),ip(3,1):ip(3,2),:) = & 00327 Info%fixupflux%side(dim)%data(ip(1,1):ip(1,2),ip(2,1):ip(2,2),ip(3,1):ip(3,2),:) + & 00328 f(iq(1,1):iq(1,2), iq(2,1):iq(2,2), iq(3,1):iq(3,2),FluxFields) 00329 END IF 00330 00331 END IF 00332 END DO 00333 IF (Info%level < MaxLevel) THEN !store values at child boundaries 00334 DO i=mT(1,1),mT(1,2) 00335 DO j=mT(2,1),mT(2,2) 00336 DO k=mT(3,1),mT(3,2) 00337 pos=(/i,j,k/) 00338 posl=pos 00339 posl(dim)=pos(dim)-1 00340 childleft=Info%ChildMask(posl(1),posl(2),posl(3)) 00341 childright=Info%ChildMask(pos(1),pos(2),pos(3)) 00342 IF (childleft <= 0 .AND. childright <= 0) CYCLE 00343 IF (childleft > 0 .AND. childright > 0) CYCLE 00344 IF (childleft > 0) THEN !ChildCell left 00345 posl(dim)=2 00346 IF (present(fields)) THEN 00347 DO l=1,size(fields) 00348 fluxloc=invFluxFields(fields(l)) 00349 IF (fluxloc /= 0) THEN 00350 Info%childfixups(childleft)%p%side(dim)%data(posl(1),posl(2),posl(3),fluxloc) = & 00351 Info%childfixups(childleft)%p%side(dim)%data(posl(1),posl(2),posl(3),fluxloc) + & 00352 f(pos(1)-mS(1,1)+1,pos(2)-mS(2,1)+1,pos(3)-mS(3,1)+1,l) 00353 END IF 00354 END DO 00355 ELSE 00356 Info%childfixups(childleft)%p%side(dim)%data(posl(1),posl(2),posl(3),:) = & 00357 Info%childfixups(childleft)%p%side(dim)%data(posl(1),posl(2),posl(3),:) + & 00358 f(pos(1)-mS(1,1)+1,pos(2)-mS(2,1)+1,pos(3)-mS(3,1)+1,FluxFields) 00359 END IF 00360 ELSE 00361 posl(dim)=1 00362 IF (present(fields)) THEN 00363 DO l=1,size(fields) 00364 fluxloc=invFluxFields(fields(l)) 00365 IF (fluxloc /= 0) THEN 00366 Info%childfixups(childright)%p%side(dim)%data(posl(1),posl(2),posl(3),fluxloc) = & 00367 Info%childfixups(childright)%p%side(dim)%data(posl(1),posl(2),posl(3),fluxloc) + & 00368 f(pos(1)-mS(1,1)+1,pos(2)-mS(2,1)+1,pos(3)-mS(3,1)+1,l) 00369 END IF 00370 END DO 00371 ELSE 00372 Info%childfixups(childright)%p%side(dim)%data(posl(1),posl(2),posl(3),:) = & 00373 Info%childfixups(childright)%p%side(dim)%data(posl(1),posl(2),posl(3),:) + & 00374 f(pos(1)-mS(1,1)+1,pos(2)-mS(2,1)+1,pos(3)-mS(3,1)+1,FluxFields) 00375 END IF 00376 END IF 00377 END DO 00378 END DO 00379 END DO 00380 END IF 00381 END SUBROUTINE storefixupfluxes 00382 00388 SUBROUTINE StoreEmfs(Info, mS, dim, emf) 00389 TYPE(InfoDef) :: Info 00390 INTEGER :: mS(3,2), mT(3,2), dim,iq(3,2) 00391 REAL(KIND=qPREC), DIMENSION(:,:,:) :: emf 00392 ! return 00393 mT=mS 00394 mT(:,1)=max(mS(:,1),1) 00395 mT(:,2)=min(mS(:,2),Info%mX+1) 00396 mT(dim,2)=min(mS(dim,2),Info%mX(dim)) 00397 iq=mT-spread(mS(:,1),2,2)+1 00398 IF (product(iq(:,2)-iq(:,1)+1) > 0) THEN 00399 Info%emf(mT(1,1):mT(1,2), mT(2,1):mT(2,2), mT(3,1):mT(3,2),emfloc(dim)) = & 00400 Info%emf(mT(1,1):mT(1,2), mT(2,1):mT(2,2), mT(3,1):mT(3,2),emfloc(dim)) + & 00401 emf(iq(1,1):iq(1,2),iq(2,1):iq(2,2),iq(3,1):iq(3,2)) 00402 END IF 00403 END SUBROUTINE StoreEmfs 00404 00405 00409 SUBROUTINE BackupInfo(original, info, lRestore) 00410 TYPE(InfoDef), POINTER :: original, info 00411 LOGICAL :: lRestore 00412 INTEGER, DIMENSION(3,2) :: ip 00413 INTEGER, DIMENSION(3,2) :: mc 00414 INTEGER, DIMENSION(3,2) :: ParentmB 00415 00416 IF (lRegridLevel(original%level)) THEN 00417 ip(:,1)=1 00418 ip(:,2)=original%mx 00419 ELSE 00420 ip=1 00421 ip(1:nDim,2)=original%mx(1:nDim)+levels(BaseLevel)%gmbc(1) 00422 ip(1:nDim,1)=1-levels(BaseLevel)%gmbc(1) 00423 END IF 00424 IF (.NOT. lRegridLevel(original%level) .AND. lRestore) THEN 00425 CALL DestroyInfo(info) 00426 CALL InitInfo(info,original%level, original%mGlobal, GetParentmGlobal(original%mGlobal, original%mBounds, original%level)) 00427 ELSE 00428 IF (ASSOCIATED(info)) THEN 00429 write(*,*) 'whoops - info should not be associated in data_declarations' 00430 STOP 00431 END IF 00432 ALLOCATE(Info) 00433 CALL NullifyInfoFields(info) 00434 Info%level=original%level 00435 Info%mGlobal=original%mGlobal 00436 Info%mBounds=original%mBounds 00437 Info%xBounds=original%xBounds 00438 Info%mX=original%mX 00439 END IF 00440 00441 IF (.NOT. ALLOCATED(info%costpergrid)) ALLOCATE(Info%CostPerGrid(size(original%costpergrid))) 00442 Info%costpergrid=original%costpergrid 00443 00444 ! IF (.NOT. ASSOCIATED(Info%Costmap)) ALLOCATE(Info%Costmap(ip(1),ip(2),ip(3),size(original%costmap, 4))) 00445 ! Info%Costmap(1:ip(1),1:ip(2),1:ip(3),:)= & 00446 ! original%costmap(1:ip(1),1:ip(2),1:ip(3),:) 00447 IF (info%level > -1) THEN 00448 IF (.NOT. ASSOCIATED(Info%q)) THEN 00449 ALLOCATE(Info%q(ip(1,1):ip(1,2),ip(2,1):ip(2,2),ip(3,1):ip(3,2),size(original%q, 4))) 00450 CALL CheckAllocation(InfoAllocator, size(Info%q)*8, "backup q") 00451 END IF 00452 00453 00454 Info%q(ip(1,1):ip(1,2),ip(2,1):ip(2,2),ip(3,1):ip(3,2),:)= & 00455 original%q(ip(1,1):ip(1,2),ip(2,1):ip(2,2),ip(3,1):ip(3,2),:) 00456 IF (MaintainAuxArrays) THEN 00457 ip(1:nDim,2)=ip(1:nDim,2)+1 00458 IF (.NOT. ASSOCIATED(Info%aux)) THEN 00459 ALLOCATE(Info%aux(ip(1,1):ip(1,2),ip(2,1):ip(2,2),ip(3,1):ip(3,2),size(original%aux, 4))) 00460 CALL CheckAllocation(InfoAllocator, size(Info%aux)*8, "backup aux") 00461 END IF 00462 Info%aux(ip(1,1):ip(1,2), ip(2,1):ip(2,2),ip(3,1):ip(3,2),:)=& 00463 original%aux(ip(1,1):ip(1,2), ip(2,1):ip(2,2),ip(3,1):ip(3,2),:) 00464 END IF 00465 END IF 00466 IF (.NOT. lRegridLevel(Info%level)) THEN !Need to also backup/restore childmask 00467 mC=1 00468 ! mC(nDim+1:3,:)=1 00469 mC(1:nDim,1)=0;mC(1:nDim,2)=Info%mX(1:nDim)+1 00470 IF (.NOT. ASSOCIATED(Info%ChildMask)) THEN 00471 ALLOCATE(Info%ChildMask(mc(1,1):mC(1,2),mC(2,1):mC(2,2), mC(3,1):mC(3,2))) 00472 CALL CheckAllocation(InfoAllocator, size(Info%ChildMask)*4, "backup childmask") 00473 END IF 00474 Info%ChildMask(mC(1,1):mC(1,2),mC(2,1):mC(2,2),mC(3,1):mc(3,2))=& 00475 original%ChildMask(mC(1,1):mC(1,2),mC(2,1):mC(2,2),mC(3,1):mc(3,2)) 00476 END IF 00477 END SUBROUTINE BackupInfo 00478 00479 00480 00482 SUBROUTINE AllocChildFixups(Info, childgrids) 00483 TYPE(InfoDef), POINTER :: Info 00484 INTEGER, DIMENSION(:,:,:), POINTER :: childgrids 00485 TYPE(Boundaries), POINTER :: childfixup 00486 INTEGER :: i, n, tempmX(3), ip(3,2) 00487 ! If there was a child (own or neighbors) then there must still be a parent.. 00488 WHERE(Info%ChildMask > 0 .OR. Info%ChildMask==NEIGHBORCHILD) Info%ChildMask=0 00489 IF (ASSOCIATED(childgrids)) THEN 00490 n=size(childgrids,3) 00491 IF (n > 0) THEN 00492 00493 ALLOCATE(Info%childfixups(n)) 00494 00495 DO i=1,n 00496 NULLIFY(Info%childfixups(i)%p) 00497 ip=leveldown(childgrids(:,:,i), Info%level+1)-SPREAD(Info%mGlobal(:,1)-1,2,2) 00498 CALL AllocBoundaries(Info%childfixups(i)%p,ip) 00499 Info%ChildMask(ip(1,1):ip(1,2), & 00500 ip(2,1):ip(2,2), & 00501 ip(3,1):ip(3,2)) = i 00502 END DO 00503 00504 END IF 00505 END IF 00506 END SUBROUTINE AllocChildFixups 00507 00509 00512 00515 SUBROUTINE NullifyInfoFields(Info) 00516 00517 TYPE(InfoDef) :: Info 00518 00519 00520 NULLIFY(Info%costmap, Info%ChildMask, Info%ErrFlag, & 00521 Info%q, Info%aux, Info%qParent, Info%auxParent, & 00522 Info%fixupflux, Info%parentfixup, Info%childfixups, Info%emf, & 00523 Info%parentemf, Info%childemf, Info%ParentCostMap, Info%AuxChild, Info%qChild, Info%massflux) 00524 00525 END SUBROUTINE NullifyInfoFields 00526 00531 SUBROUTINE DestroyInfo(Info) 00532 TYPE(InfoDef), POINTER :: Info 00533 00534 IF (.NOT. ASSOCIATED(Info)) RETURN 00535 00536 00537 IF (ALLOCATED(Info%CostPerGrid)) THEN 00538 DEALLOCATE(Info%CostPerGrid) 00539 END IF 00540 00541 IF (ASSOCIATED(Info%costmap)) THEN 00542 DEALLOCATE(Info%costmap) 00543 NULLIFY(Info%costmap) 00544 END IF 00545 IF (ASSOCIATED(Info%ParentCostMap)) THEN 00546 DEALLOCATE(Info%ParentCostMap) 00547 NULLIFY(Info%ParentCostMap) 00548 END IF 00549 ! IF (Info%level >= 0) THEN 00550 IF (ASSOCIATED(Info%q)) THEN 00551 CALL CheckDeAllocation(InfoAllocator, size(Info%q)*8) 00552 DEALLOCATE(Info%q) 00553 NULLIFY(Info%q) 00554 END IF 00555 00556 IF (ASSOCIATED(Info%MassFlux)) THEN 00557 CALL CheckDeAllocation(InfoAllocator, size(Info%massflux)*8) 00558 DEALLOCATE(Info%MassFlux) 00559 NULLIFY(Info%MassFlux) 00560 END IF 00561 IF (ASSOCIATED(Info%ChildMask)) THEN 00562 CALL CheckDeAllocation(InfoAllocator, size(Info%childmask)*4) 00563 DEALLOCATE(Info%ChildMask) 00564 NULLIFY(Info%ChildMask) 00565 END IF 00566 00567 IF (ASSOCIATED(Info%fixupflux)) CALL DeAllocBoundaries(Info%fixupflux) 00568 IF (MaintainAuxArrays) THEN 00569 IF (ASSOCIATED(Info%aux)) THEN 00570 CALL CheckDeAllocation(InfoAllocator, size(Info%aux)*8) 00571 DEALLOCATE(Info%aux) 00572 NULLIFY(Info%aux) 00573 END IF 00574 IF (ASSOCIATED(Info%emf)) THEN 00575 CALL CheckDeAllocation(InfoAllocator, size(Info%emf)*8) 00576 DEALLOCATE(Info%emf) 00577 NULLIFY(Info%emf) 00578 END IF 00579 END IF 00580 IF (Info%level > 0) THEN 00581 CALL DeAllocBoundaries(Info%parentfixup) 00582 IF (ASSOCIATED(Info%qParent)) THEN 00583 CALL CheckDeAllocation(InfoAllocator, size(Info%qParent)*8) 00584 DEALLOCATE(Info%qParent) 00585 NULLIFY(Info%qParent) 00586 END IF 00587 IF (MaintainAuxArrays) THEN 00588 IF (ASSOCIATED(Info%parentemf)) THEN 00589 CALL CheckDeAllocation(InfoAllocator, size(Info%Parentemf)*8) 00590 DEALLOCATE(Info%parentemf) 00591 NULLIFY(Info%parentemf) 00592 END IF 00593 IF (ASSOCIATED(Info%auxParent)) THEN 00594 CALL CheckDeAllocation(InfoAllocator, size(Info%auxParent)*8) 00595 DEALLOCATE(Info%auxParent) 00596 NULLIFY(Info%auxParent) 00597 END IF 00598 END IF 00599 END IF 00600 IF (Info%level < MaxLevel) THEN 00601 00602 IF (ASSOCIATED(Info%ErrFlag)) THEN 00603 CALL CheckDeAllocation(InfoAllocator, size(Info%ErrFlag)*4) 00604 DEALLOCATE(Info%ErrFlag) 00605 NULLIFY(Info%ErrFlag) 00606 END IF 00607 00608 IF (ASSOCIATED(Info%qChild)) THEN 00609 CALL CheckDeAllocation(InfoAllocator, size(Info%qchild)*8) 00610 DEALLOCATE(Info%qChild) 00611 NULLIFY(Info%qChild) 00612 END IF 00613 00614 IF (MaintainAuxArrays) THEN 00615 00616 IF (ASSOCIATED(Info%auxChild)) THEN 00617 CALL CheckDeAllocation(InfoAllocator, size(Info%auxchild)*8) 00618 DEALLOCATE(Info%auxChild) 00619 NULLIFY(Info%auxChild) 00620 END IF 00621 00622 IF (ASSOCIATED(Info%childemf)) THEN 00623 CALL CheckDeAllocation(InfoAllocator, size(Info%childemf)*8) 00624 DEALLOCATE(Info%childemf) 00625 NULLIFY(Info%childemf) 00626 END IF 00627 END IF 00628 CALL DeAllocChildFixups(Info) 00629 END IF 00630 00631 00632 DEALLOCATE(Info) 00633 NULLIFY(Info) 00634 00635 00636 END SUBROUTINE DestroyInfo 00637 00640 SUBROUTINE DeallocChildFixups(Info) 00641 00642 TYPE(InfoDef), POINTER :: Info 00643 00644 INTEGER :: i, n 00645 00646 00647 IF (.NOT. ASSOCIATED(Info)) RETURN 00648 00649 IF (.NOT. ASSOCIATED(Info%childfixups)) RETURN 00650 DO i = 1, SIZE(Info%childfixups) 00651 CALL DeAllocBoundaries(Info%childfixups(i)%p) 00652 END DO 00653 DEALLOCATE(Info%childfixups) 00654 NULLIFY(Info%childfixups) 00655 END SUBROUTINE DeallocChildFixups 00656 00658 00661 00670 SUBROUTINE CalcOverlaps(InfomGlobal,SourcemGlobal,mTs,mSs,nOverlaps,level,lPeriodic,nghost) 00671 ! Calculates overlap bounds of cell-centered quantities for 00672 ! overlapping grids. 00673 INTEGER, DIMENSION(3,2) :: InfomGlobal, SourcemGlobal 00674 INTEGER, DIMENSION(3,2) :: mO,mGlobal,iOffSet 00675 INTEGER, DIMENSION(3) :: pOffSet 00676 INTEGER, DIMENSION(:,:,:), POINTER :: mTs, mSs 00677 INTEGER, DIMENSION(27,3,2) :: MaxMTs, MaxMSs 00678 INTEGER :: i,j,k,rmbc,nOverlaps,level 00679 INTEGER, OPTIONAL :: nghost 00680 LOGICAL, DIMENSION(:) :: lPeriodic 00681 IF (present(nGhost)) THEN 00682 rmbc=nGhost 00683 ELSE 00684 rmbc = levels(level)%gmbc(levels(level)%step) !CoarsenRatio(level-1) * mbc 00685 END IF 00686 NULLIFY(mTs, mSs) 00687 nOverlaps=0 00688 mO=1 00689 ! mO(nDim+1:3,:)=1 00690 ioffset=0 00691 WHERE(lPeriodic(1:nDim)) ioffset(1:nDim,2)=nperiodic_overlaps(1:nDim) 00692 ioffset(1:nDim,1)=-ioffset(1:nDim,2) 00693 DO i=ioffset(1,1),ioffset(1,2) 00694 DO j=ioffset(2,1),ioffset(2,2) 00695 DO k=ioffset(3,1),ioffset(3,2) 00696 pOffSet=(/i,j,k/)*levels(level)%mX(:) 00697 mGlobal(:,:)=SourcemGlobal(:,:)+SPREAD(pOffSet,2,2) 00698 00699 mO(1:nDim,1)=max(InfomGlobal(1:nDim,1)-rmbc& 00700 &,mGlobal(1:nDim,1)) 00701 mO(1:nDim,2)=min(InfomGlobal(1:nDim,2)+rmbc& 00702 &,mGlobal(1:nDim,2)) 00703 00704 IF (ALL(mO(1:nDim,2) >= mO(1:nDim,1))) THEN 00705 nOverlaps=nOverlaps+1 00706 MaxMTs(nOverlaps,:,:)=mO-Spread( InfomGlobal(:,1)& 00707 &,2,2)+1 00708 MaxMSs(nOverlaps,:,:)=mO-Spread(SourcemGlobal(:,1)& 00709 &+pOffset,2,2)+1 00710 END IF 00711 00712 END DO 00713 END DO 00714 END DO 00715 IF (nOverlaps > 0) THEN 00716 ALLOCATE(MTs(nOverlaps,3,2),MSs(nOverlaps,3,2)) 00717 MTs=MaxMTs(1:nOverlaps,:,:) 00718 MSs=MaxMSs(1:nOverlaps,:,:) 00719 END IF 00720 END SUBROUTINE CalcOverlaps 00721 00731 SUBROUTINE CalcAuxOverlaps(InfomGlobal,SourcemGlobal,mTs,mSs,nOverlaps,level,dir,lPeriodic, nghost) 00732 ! Calculates overlap bounds of cell-centered quantities for 00733 ! overlapping grids. 00734 INTEGER, DIMENSION(3,2) :: InfomGlobal, SourcemGlobal 00735 INTEGER, DIMENSION(3,2) :: mO,mGlobal,iOffSet 00736 INTEGER, DIMENSION(3) :: pOffSet 00737 INTEGER, DIMENSION(:,:,:), POINTER :: mTs, mSs 00738 INTEGER, DIMENSION(27,3,2) :: MaxMTs, MaxMSs 00739 INTEGER :: i,j,k,rmbc,nOverlaps,level,l,dir 00740 INTEGER, OPTIONAL :: nghost 00741 LOGICAL, DIMENSION(:) :: lPeriodic 00742 IF (present(nGhost)) THEN 00743 rmbc=nGhost 00744 ELSE 00745 rmbc = levels(level)%gmbc(levels(level)%step) !CoarsenRatio(level-1) * mbc 00746 END IF 00747 NULLIFY(mTs, mSs) 00748 nOverlaps=0 00749 mO=1 00750 ! mO(nDim+1:3,:)=1 00751 ioffset=0 00752 WHERE(lPeriodic(1:nDim)) ioffset(1:nDim,2)=nperiodic_overlaps(1:nDim) 00753 ioffset(1:nDim,1)=-ioffset(1:nDim,2) 00754 DO i=ioffset(1,1),ioffset(1,2) 00755 DO j=ioffset(2,1),ioffset(2,2) 00756 DO k=ioffset(3,1),ioffset(3,2) 00757 pOffSet=(/i,j,k/)*levels(level)%mX(:) 00758 mGlobal(:,:)=SourcemGlobal(:,:)+SPREAD(pOffSet,2,2) 00759 00760 mO(1:nDim,1)=max(InfomGlobal(1:nDim,1)-rmbc,mGlobal(1:nDim,1)) 00761 mO(1:nDim,2)=min(InfomGlobal(1:nDim,2)+rmbc,mGlobal(1:nDim,2)) 00762 mO(dir,2)=mO(dir,2)+1 !Shift upper bound for Aux fields 00763 IF (ALL(mO(1:nDim,2) >= (mO(1:nDim,1)))) THEN 00764 nOverlaps=nOverlaps+1 00765 MaxMTs(nOverlaps,:,:)=mO-Spread( InfomGlobal(:,1)& 00766 &,2,2)+1 00767 MaxMSs(nOverlaps,:,:)=mO-Spread(SourcemGlobal(:,1)& 00768 &+pOffset,2,2)+1 00769 ! write(*,*) 'found overlap' 00770 ! write(*,'(6I5.2)') MaxMSs(nOverlaps,:,:) 00771 ! write(*,'(6I5.2)') MaxMTs(nOverlaps,:,:) 00772 END IF 00773 00774 END DO 00775 END DO 00776 END DO 00777 IF (nOverlaps > 0) THEN 00778 ALLOCATE(MTs(nOverlaps,3,2),MSs(nOverlaps,3,2)) 00779 MTs=MaxMTs(1:nOverlaps,:,:) 00780 MSs=MaxMSs(1:nOverlaps,:,:) 00781 END IF 00782 END SUBROUTINE CalcAuxOverlaps 00783 00784 00794 SUBROUTINE CalcEMFOverlaps(InfomGlobal,SourcemGlobal,mTs,mSs,nOverlaps,offsets,level,dir, lPeriodic) 00795 ! Calculates overlap bounds of cell-centered quantities for 00796 ! overlapping grids. 00797 INTEGER, DIMENSION(3,2) :: InfomGlobal, SourcemGlobal 00798 INTEGER, DIMENSION(3,2) :: mO,mGlobal,iOffSet 00799 INTEGER, DIMENSION(3) :: pOffSet 00800 INTEGER, DIMENSION(:,:,:), POINTER :: mTs, mSs 00801 INTEGER, DIMENSION(:,:), POINTER :: offsets 00802 INTEGER, DIMENSION(27,3,2) :: MaxMTs, MaxMSs 00803 INTEGER, DIMENSION(27,3) :: MaxOffsets 00804 INTEGER :: i,j,k,nOverlaps,level,l,dir 00805 LOGICAL, DIMENSION(:) :: lPeriodic 00806 NULLIFY(mTs, mSs) 00807 nOverlaps=0 00808 mO=1 00809 ! mO(nDim+1:3,:)=1 00810 ioffset=0 00811 WHERE(lPeriodic(1:nDim)) ioffset(1:nDim,2)=1 !nperiodic_overlaps(1:nDim) 00812 ioffset(1:nDim,1)=-ioffset(1:nDim,2) 00813 DO i=ioffset(1,1),ioffset(1,2) 00814 DO j=ioffset(2,1),ioffset(2,2) 00815 DO k=ioffset(3,1),ioffset(3,2) 00816 pOffSet=(/i,j,k/)*levels(level)%mX(:) 00817 mGlobal(:,:)=SourcemGlobal(:,:)+SPREAD(pOffSet,2,2) 00818 00819 mO(1:nDim,1)=max(InfomGlobal(1:nDim,1)& 00820 &,mGlobal(1:nDim,1)) 00821 mO(1:nDim,2)=min(InfomGlobal(1:nDim,2)& 00822 &,mGlobal(1:nDim,2)) 00823 mO(:,2)=mO(:,2)+1 !Shift upper bound for emf fields !This works for 2 or 3D 00824 mO(dir,2)=mO(dir,2)-1 !Shorten normal direction 00825 IF (ALL(mO(1:nDim,2) >= (mO(1:nDim,1)))) THEN 00826 nOverlaps=nOverlaps+1 00827 MaxMTs(nOverlaps,:,:)=mO-Spread( InfomGlobal(:,1)& 00828 &,2,2)+1 00829 MaxMSs(nOverlaps,:,:)=mO-Spread(SourcemGlobal(:,1)& 00830 &+pOffset,2,2)+1 00831 MaxOffsets(nOverlaps,:)=pOffSet 00832 END IF 00833 00834 END DO 00835 END DO 00836 END DO 00837 IF (nOverlaps > 0) THEN 00838 ALLOCATE(MTs(nOverlaps,3,2),MSs(nOverlaps,3,2) & 00839 &,offsets(nOverlaps,3)) 00840 MTs=MaxMTs(1:nOverlaps,:,:) 00841 MSs=MaxMSs(1:nOverlaps,:,:) 00842 offsets=MaxOffsets(1:nOverlaps,:) 00843 END IF 00844 END SUBROUTINE CalcEMFOverlaps 00845 00855 SUBROUTINE CalcFluxOverlaps(InfomGlobal,SourcemGlobal,mTs,mSs,edges,nOverlaps,level,dir,lPeriodic) 00856 ! Calculates overlap bounds of cell-centered quantities for 00857 ! overlapping grids. 00858 INTEGER, DIMENSION(3,2) :: InfomGlobal, SourcemGlobal 00859 INTEGER, DIMENSION(3,2) :: mO,mGlobal,iOffSet 00860 INTEGER, DIMENSION(3) :: pOffSet 00861 INTEGER, DIMENSION(:,:,:), POINTER :: mTs, mSs 00862 INTEGER, DIMENSION(:), POINTER :: edges 00863 INTEGER, DIMENSION(2,3,2) :: MaxMTs, MaxMSs 00864 INTEGER, DIMENSION(2) :: Maxedges 00865 INTEGER :: i,j,k,nOverlaps,level,dir 00866 LOGICAL, DIMENSION(:) :: lPeriodic 00867 NULLIFY(mTs, mSs) 00868 nOverlaps=0 00869 mO=1 00870 ! mO(nDim+1:3,:)=1 00871 ioffset=0 00872 IF (lPeriodic(dir)) THEN 00873 ioffset(dir,2)=1!nperiodic_overlaps(dir) 00874 ioffset(dir,1)=-1!-nperiodic_overlaps(dir) 00875 END IF 00876 DO i=ioffset(1,1),ioffset(1,2) 00877 DO j=ioffset(2,1),ioffset(2,2) 00878 DO k=ioffset(3,1),ioffset(3,2) 00879 pOffSet=(/i,j,k/)*levels(level)%mX(:) 00880 mGlobal(:,:)=SourcemGlobal(:,:)+SPREAD(pOffSet,2,2) 00881 IF (ALL(InfomGlobal==mGlobal)) CYCLE !Skip self... 00882 mO(1:nDim,1)=max(InfomGlobal(1:nDim,1),mGlobal(1:nDim& 00883 &,1)) 00884 mO(1:nDim,2)=min(InfomGlobal(1:nDim,2),mGlobal(1:nDim& 00885 &,2)) 00886 mO(dir,2)=mO(dir,2)+1 !Stretch bounds of overlap 00887 ! regions for face fields 00888 IF (ALL(mO(1:nDim,2) >= mO(1:nDim,1))) THEN 00889 nOverlaps=nOverlaps+1 00890 IF (nOverlaps > 2) THEN 00891 write(*,*) 'too many overlaps' 00892 STOP 00893 END IF 00894 00895 MaxMTs(nOverlaps,:,:)=mO-Spread( InfomGlobal(:,1)& 00896 &,2,2)+1 00897 MaxMSs(nOverlaps,:,:)=mO-Spread(SourcemGlobal(:,1)& 00898 &+pOffSet,2,2)+1 00899 IF (mO(dir,1)==InfomGlobal(dir,1)) THEN 00900 MaxEdges(nOverlaps)=1 00901 ELSEIF (mO(dir,2)==InfomGlobal(dir,2)+1) THEN 00902 MaxEdges(nOverlaps)=2 00903 ELSE 00904 PRINT*, "error in flux overlaps" 00905 END IF 00906 END IF 00907 END DO 00908 END DO 00909 END DO 00910 IF (nOverlaps > 0) THEN 00911 ALLOCATE(MTs(nOverlaps,3,2),MSs(nOverlaps,3,2)& 00912 &,edges(nOverlaps)) 00913 MTs=MaxMTs(1:nOverlaps,:,:) 00914 MSs=MaxMSs(1:nOverlaps,:,:) 00915 edges=MaxEdges(1:nOverlaps) 00916 END IF 00917 END SUBROUTINE CalcFluxOverlaps 00918 00919 00926 SUBROUTINE CalcPhysicalOverlaps(Info, PhysicalRegion, mSs, nOverlaps, offsets, location, lPeriodic, rmbcOpt) 00927 REAL(KIND=qPREC), DIMENSION(3,2) :: PhysicalRegion 00928 TYPE(InfoDef) :: Info 00929 INTEGER :: nOverlaps, location 00930 REAL(KIND=qPREC), DIMENSION(:,:), POINTER :: offsets 00931 INTEGER, DIMENSION(:,:,:), POINTER :: mSs 00932 INTEGER :: rmbc, i, j, k, dir, edge 00933 REAL(KIND=qPREC), DIMENSION(27,3) :: MaxOffsets 00934 INTEGER, DIMENSION(27,3,2) :: MaxmSs 00935 INTEGER, DIMENSION(3,2) :: mO,iOffSet,ip 00936 REAL(KIND=qPREC), DIMENSION(3) :: pOffSet 00937 INTEGER, OPTIONAL :: rmbcOpt 00938 LOGICAL, DIMENSION(:) :: lPeriodic 00939 IF (PRESENT(rmbcOpt)) THEN 00940 rmbc=rmbcOpt 00941 ELSE 00942 rmbc=levels(Info%level)%gmbc(levels(Info%level)%step) 00943 END IF 00944 NULLIFY(mSs) 00945 nOverlaps=0 00946 mO=1 00947 ! mO(nDim+1:3,:)=1 00948 ioffset=0 00949 WHERE(lPeriodic(1:nDim)) ioffset(1:nDim,2)=nperiodic_overlaps(1:nDim) 00950 ioffset(1:nDim,1)=-ioffset(1:nDim,2) 00951 DO i=ioffset(1,1),ioffset(1,2) 00952 DO j=ioffset(2,1),ioffset(2,2) 00953 DO k=ioffset(3,1),ioffset(3,2) 00954 pOffSet=(/i,j,k/)*(GxBounds(:,2)-GxBounds(:,1)) !Physical offset for info structure 00955 IF (location == IEVERYWHERE) THEN 00956 mO(1:nDim,1)=max(1-rmbc,ceiling((PhysicalRegion(1:nDim,1)-(Info%xBounds(1:nDim,1)+pOffset(1:nDim)))/levels(Info%level)%dx)) 00957 mO(1:nDim,2)=min(Info%mX(1:nDim)+rmbc,ceiling((PhysicalRegion(1:nDim,2)-(Info%xBounds(1:nDim,1)+pOffset(1:nDim)))/levels(Info%level)%dx)) 00958 IF (ALL(mO(1:nDim,2) >= mO(1:nDim,1))) THEN 00959 nOverlaps=nOverlaps+1 00960 MaxMSs(nOverlaps,:,:)=mO(:,:) 00961 MaxOffsets(nOverlaps,:)=pOffset 00962 END IF 00963 ELSEIF (location == IBOUNDARIES) THEN 00964 DO dir=1,nDim 00965 DO edge=1,2 00966 IF (GhostOverlap(Info, dir, edge, ip)) THEN 00967 mO(1:nDim,1)=max(ip(1:nDim,1),ceiling((PhysicalRegion(1:nDim,1)-(Info%xBounds(1:nDim,1)+pOffset(1:nDim)))/levels(Info%level)%dx)) 00968 mO(1:nDim,2)=min(ip(1:nDim,2),ceiling((PhysicalRegion(1:nDim,2)-(Info%xBounds(1:nDim,1)+pOffset(1:nDim)))/levels(Info%level)%dx)) 00969 IF (ALL(mO(1:nDim,2) >= mO(1:nDim,1))) THEN 00970 nOverlaps=nOverlaps+1 00971 MaxMSs(nOverlaps,:,:)=mO(:,:) 00972 MaxOffsets(nOverlaps,:)=pOffset 00973 END IF 00974 END IF 00975 END DO 00976 END DO 00977 ELSE 00978 DO dir=1,nDim 00979 DO edge=1,2 00980 IF (location == IBOUNDARY(dir,edge)) THEN 00981 IF (GhostOverlap(Info, dir, edge, ip)) THEN 00982 mO(1:nDim,1)=max(ip(1:nDim,1),ceiling((PhysicalRegion(1:nDim,1)-(Info%xBounds(1:nDim,1)+pOffset(1:nDim)))/levels(Info%level)%dx)) 00983 mO(1:nDim,2)=min(ip(1:nDim,2),ceiling((PhysicalRegion(1:nDim,2)-(Info%xBounds(1:nDim,1)+pOffset(1:nDim)))/levels(Info%level)%dx)) 00984 IF (ALL(mO(1:nDim,2) >= mO(1:nDim,1))) THEN 00985 nOverlaps=nOverlaps+1 00986 MaxMSs(nOverlaps,:,:)=mO(:,:) 00987 MaxOffsets(nOverlaps,:)=pOffset 00988 END IF 00989 END IF 00990 END IF 00991 END DO 00992 END DO 00993 END IF 00994 END DO 00995 END DO 00996 END DO 00997 IF (nOverlaps > 0) THEN 00998 ALLOCATE(MSs(nOverlaps,3,2),offsets(nOverlaps,3)) 00999 MSs=MaxMSs(1:nOverlaps,:,:) 01000 offsets=MaxOffsets(1:nOverlaps,:) 01001 END IF 01002 END SUBROUTINE CalcPhysicalOverlaps 01003 01010 SUBROUTINE CalcCellOverlaps(Info, PhysicalRegion, mSs, nOverlaps, offsets, location, lPeriodic, rmbcOpt) 01011 INTEGER, DIMENSION(3,2) :: PhysicalRegion 01012 TYPE(InfoDef) :: Info 01013 INTEGER :: nOverlaps, location 01014 INTEGER, DIMENSION(:,:), POINTER :: offsets 01015 INTEGER, DIMENSION(:,:,:), POINTER :: mSs 01016 INTEGER :: rmbc, i, j, k, dir, edge 01017 INTEGER, DIMENSION(27,3) :: MaxOffsets 01018 INTEGER, DIMENSION(27,3,2) :: MaxmSs 01019 INTEGER, DIMENSION(3,2) :: mO,iOffSet,ip 01020 INTEGER, DIMENSION(3) :: pOffSet 01021 INTEGER, OPTIONAL :: rmbcOpt 01022 LOGICAL, DIMENSION(:) :: lPeriodic 01023 IF (PRESENT(rmbcOpt)) THEN 01024 rmbc=rmbcOpt 01025 ELSE 01026 rmbc=levels(Info%level)%gmbc(levels(Info%level)%step) 01027 END IF 01028 NULLIFY(mSs) 01029 nOverlaps=0 01030 mO=1 01031 ioffset=0 01032 WHERE(lPeriodic(1:nDim)) ioffset(1:nDim,2)=nperiodic_overlaps(1:nDim) 01033 ioffset(1:nDim,1)=-ioffset(1:nDim,2) 01034 DO i=ioffset(1,1),ioffset(1,2) 01035 DO j=ioffset(2,1),ioffset(2,2) 01036 DO k=ioffset(3,1),ioffset(3,2) 01037 pOffSet=(/i,j,k/)*(levels(Info%level)%mx(:)) !Physical offset for info structure 01038 IF (location == IEVERYWHERE) THEN 01039 mO(1:nDim,1)=max(1-rmbc,PhysicalRegion(1:nDim,1)-(Info%mGlobal(1:nDim,1)+pOffset(1:nDim))+1) 01040 mO(1:nDim,2)=min(Info%mX(1:nDim)+rmbc,PhysicalRegion(1:nDim,2)-(Info%mGlobal(1:nDim,1)+pOffset(1:nDim))+1) 01041 ! write(*,'(A,7I)') 'A', MPI_ID, mO 01042 ! IF (MPI_id == 3) THEN 01043 ! write(*,'(A,7I)') 'B', PhysicalRegion 01044 ! write(*,'(A,7I)') 'B', info%mGlobal 01045 ! write(*,'(A,7I)') 'B', mO 01046 ! END IF 01047 IF (ALL(mO(1:nDim,2) >= mO(1:nDim,1))) THEN 01048 nOverlaps=nOverlaps+1 01049 MaxMSs(nOverlaps,:,:)=mO(:,:) 01050 MaxOffsets(nOverlaps,:)=pOffset 01051 END IF 01052 ELSEIF (location == IBOUNDARIES) THEN 01053 DO dir=1,nDim 01054 DO edge=1,2 01055 IF (GhostOverlap(Info, dir, edge, ip)) THEN 01056 mO(1:nDim,1)=max(ip(1:nDim,1),PhysicalRegion(1:nDim,1)-(Info%mGlobal(:,1)+pOffset(1:nDim))+1) 01057 mO(1:nDim,2)=min(ip(1:nDim,2),PhysicalRegion(1:nDim,2)-(Info%mGlobal(1:nDim,1)+pOffset(1:nDim))+1) 01058 IF (ALL(mO(1:nDim,2) >= mO(1:nDim,1))) THEN 01059 nOverlaps=nOverlaps+1 01060 MaxMSs(nOverlaps,:,:)=mO(:,:) 01061 MaxOffsets(nOverlaps,:)=pOffset 01062 END IF 01063 END IF 01064 END DO 01065 END DO 01066 ELSE 01067 WRITE(*,*) "unrecognized location in data_declarations.f90 - stopping" 01068 END IF 01069 01070 END DO 01071 END DO 01072 END DO 01073 IF (nOverlaps > 0) THEN 01074 ALLOCATE(MSs(nOverlaps,3,2),offsets(nOverlaps,3)) 01075 MSs=MaxMSs(1:nOverlaps,:,:) 01076 offsets=MaxOffsets(1:nOverlaps,:) 01077 END IF 01078 END SUBROUTINE CalcCellOverlaps 01079 01081 01084 01088 LOGICAL FUNCTION BoxOverlap(mGlobal1,mGlobal2) 01089 INTEGER, DIMENSION(3,2) :: mGlobal1, mGlobal2 01090 BoxOverlap= ALL(mGlobal1(1:nDim,2) >= mGlobal2(1:nDim,1) .AND. & 01091 mGlobal1(1:nDim,1) <= mGlobal2(1:nDim,2)) 01092 END FUNCTION BoxOverlap 01093 01099 FUNCTION GhostOverlap(Info, dim, edge,ip) 01100 TYPE(InfoDef) :: Info 01101 INTEGER, DIMENSION(3,2) :: ip, lGmGlobal 01102 INTEGER :: dim 01103 INTEGER :: edge 01104 LOGICAL :: GhostOverlap 01105 INTEGER :: level, rmbc 01106 level=Info%level 01107 rmbc=levels(level)%gmbc(levels(level)%step) 01108 ip=1 01109 01110 ! ip(1:dim-1,1)=1 !No need to include corner ghost cells multiple times 01111 ! ip(dim:ndim,1)=1-rmbc 01112 ip(1:nDim,1)=1-rmbc 01113 ! ip(1:dim-1,2)=Info%mX(1:dim-1) 01114 ! ip(dim:nDim,2)=Info%mX(dim:nDim)+rmbc 01115 ip(1:nDim,2)=Info%mX(1:nDim)+rmbc 01116 lGmGlobal(:,1)=GmGlobal(:,1) 01117 lGmGlobal(:,2)=GmGlobal(:,2)*PRODUCT(levels(0:level-1)%CoarsenRatio) 01118 IF (edge == 1) THEN 01119 ip(dim,2)=lGmGlobal(dim,1)-Info%mGlobal(dim,1) !first cell on left boundary 01120 ! nCells=start-(1-rmbc)+1 01121 ELSE 01122 ip(dim,1)=(lGmGlobal(dim,2)+1)-(Info%mGlobal(dim,1)-1) !first ghost cell on right boundary 01123 END IF 01124 GhostOverlap=ALL(ip(:,2) >= ip(:,1)) 01125 END FUNCTION GhostOverlap 01126 01127 01131 FUNCTION LevelUp(mGlobal,level, levelnew_opt) 01132 INTEGER, DIMENSION(3,2) :: mGlobal, LevelUp 01133 INTEGER :: level, n, levelnew 01134 INTEGER, OPTIONAL :: levelnew_opt 01135 IF (PRESENT(levelnew_opt)) THEN 01136 levelnew=levelnew_opt 01137 ELSE 01138 levelnew=level+1 01139 END IF 01140 LevelUp=mGlobal 01141 DO n=level, levelnew-1 01142 LevelUp(1:nDim,1)=(LevelUp(1:nDim,1)-1)*levels(n)%CoarsenRatio+1 01143 LevelUp(1:nDim,2)=LevelUp(1:nDim,2)*levels(n)%CoarsenRatio 01144 END DO 01145 END FUNCTION LevelUp 01146 01150 FUNCTION LevelDown(mGlobal,level,levelnew_opt) 01151 INTEGER, DIMENSION(3,2) :: mGlobal, LevelDown 01152 INTEGER :: level, n, levelnew 01153 INTEGER, OPTIONAL :: levelnew_opt 01154 IF (PRESENT(levelnew_opt)) THEN 01155 levelnew=levelnew_opt 01156 ELSE 01157 levelnew=level-1 01158 END IF 01159 LevelDown=mGlobal 01160 DO n=level, levelnew+1, -1 01161 LevelDown(1:nDim,1)=(LevelDown(1:nDim,1)-1)/levels(n-1)%CoarsenRatio+1 01162 LevelDown(1:nDim,2)=(LevelDown(1:nDim,2)-1)/levels(n-1)%CoarsenRatio+1 01163 END DO 01164 END FUNCTION LevelDown 01165 01166 01167 FUNCTION MapToLevel(index, a, b) 01168 INTEGER :: MapToLevel(2) !Cell indices in level b's mGlobal space 01169 INTEGER :: index !Cell index in level a's mGlobal space 01170 INTEGER :: a !current level 01171 INTEGER :: b !level to map to 01172 IF (a == b) THEN 01173 MapToLevel=index 01174 ELSEIF (a < b) THEN !need to determine bounds of child cells... 01175 MapToLevel(1)=(index-1)*PRODUCT(levels(a:b-1)%CoarsenRatio)+1 01176 MapToLevel(2)=(index)*PRODUCT(levels(a:b-1)%CoarsenRatio) 01177 ELSE !a > b 01178 MapToLevel(:)=(index-1)/PRODUCT(levels(b:a-1)%CoarsenRatio)+1 01179 END IF 01180 END FUNCTION MapToLevel 01181 01182 01187 FUNCTION GetMBounds(mGlobal, ParentmGlobal, level) 01188 INTEGER, DIMENSION(3,2) :: GetmBounds, mGlobal, ParentmGlobal 01189 INTEGER :: level 01190 GetmBounds=leveldown(mGlobal, level)-spread(ParentmGlobal(:,1)-1,2,2) 01191 END FUNCTION GetMBounds 01192 01193 01198 FUNCTION GetParentmGlobal(mGlobal, mBounds, level) 01199 INTEGER, DIMENSION(3,2) :: mBounds, mGlobal, GetParentmGlobal 01200 INTEGER :: level 01201 GetparentmGlobal=leveldown(mGlobal, level)-spread(mBounds(:,1)-1,2,2) 01202 END FUNCTION GetParentmGlobal 01203 01204 01208 FUNCTION stretch(mB,dist) 01209 INTEGER, DIMENSION(3,2) :: stretch, mB 01210 INTEGER :: dist 01211 ! stretch(nDim+1:3,:)=1 01212 stretch=1 01213 stretch(1:nDim,1)=mB(1:nDim,1)-dist 01214 stretch(1:nDim,2)=mB(1:nDim,2)+dist 01215 END FUNCTION stretch 01216 01220 FUNCTION stretchaux(mB,dist) 01221 INTEGER, DIMENSION(3,2) :: stretchaux, mB 01222 INTEGER :: dist 01223 ! stretchaux(nDim+1:3,:)=1 01224 stretchaux=1 01225 stretchaux(1:nDim,1)=mB(1:nDim,1)-dist 01226 stretchaux(1:nDim,2)=mB(1:nDim,2)+dist+1 01227 END FUNCTION stretchaux 01228 01229 01230 FUNCTION MapBoxToInfo(xB, Info, nghost) 01231 REAL(KIND=qPREC) :: xB(3,2) 01232 INTEGER :: MapBoxToInfo(3,2) 01233 INTEGER :: nGhost 01234 TYPE(InfoDef) :: Info 01235 MapBoxToInfo=ceiling((xb-spread(Info%xbounds(:,1),2,2))/levels(Info%level)%dx) 01236 MapBoxToInfo(1:nDim,1)=max(MapBoxToInfo(1:nDim,1), 1-nghost) 01237 MapBoxToInfo(1:nDim,2)=min(MapBoxToInfo(1:nDim,2), Info%mX(1:nDim)+nGhost) 01238 END FUNCTION MapBoxToInfo 01239 01240 FUNCTION MapBoxToLevel(xB, level, nghost) 01241 INTEGER :: level, nghost 01242 INTEGER :: MapBoxToLevel(3,2) 01243 REAL(KIND=qPREC) :: xB(3,2) 01244 MapBoxToLevel=ceiling(xb-spread(GxBounds(:,1),2,2))/levels(level)%dx 01245 MapBoxToLevel(1:nDim,1)=max(MapBoxToLevel(1:nDim,1), 1-nGhost) 01246 MapBoxToLevel(1:nDim,2)=min(MapBoxToLevel(1:nDim,2), levels(level)%mX(1:nDim)+nGhost) 01247 write(*,*) xb, GxBounds, level, nGhost, MapBoxTolevel 01248 END FUNCTION MapBoxToLevel 01249 01250 01251 FUNCTION CellPos(Info,i,j,k) 01252 TYPE(InfoDef) :: Info 01253 REAL(KIND=qPREC), DIMENSION(3) :: CellPos 01254 INTEGER :: i,j,k 01255 ! CellPos=Info%XBounds(:,1)+levels(Info%level)%dx*REAL((/i,j,k/)-half) 01256 CellPos=Info%XBounds(:,1)+merge(levels(Info%level)%dx*REAL((/i,j,k/)-half), (/0d0,0d0,0d0/), nDim >= (/1,2,3/)) 01257 END FUNCTION CellPos 01258 01259 FUNCTION PosCell(Info,x,y,z) 01260 TYPE(InfoDef) :: Info 01261 INTEGER, DIMENSION(3) :: PosCell 01262 REAL(KIND=qPREC) :: x,y,z 01263 PosCell(:)=ceiling(((/x,y,z/)-GxBounds(:,1))/levels(Info%level)%dx) - Info%mGlobal(:,1) + 1 01264 ! write(*,'(A,4I)') 'poscell', poscell 01265 ! write(*,'(A,4I)') 'xyz',x,y,z 01266 ! write(*,'(A,4I)') 'mglobal', Info%mGlobal(:,1) 01267 ! STOP 01268 01269 PosCell(nDim+1:)=1 01270 END FUNCTION PosCell 01271 01273 01274 01275 SUBROUTINE ProlongateCellCenteredData(pdata, cdata, r, nGhost, method) 01276 REAL(KIND=qPREC), DIMENSION(:,:,:) :: pdata !parent data to prolongate (includes any ghost zones) 01277 REAL(KIND=qPREC), DIMENSION(:,:,:) :: cdata !child data to populate 01278 REAL(KIND=qPREC), ALLOCATABLE, DIMENSION(:,:,:) :: sided, slopes!work arrays for storing slopes 01279 INTEGER :: method !prolongation method 01280 INTEGER :: r !Refinement Ratio 01281 INTEGER :: nGhost !number of ghost parent cells available 01282 INTEGER, DIMENSION(3,2) :: ic !work array for child cells 01283 INTEGER, DIMENSION(3,2) :: ip, iq, ir, is !work arrays for parent cells 01284 REAL(KIND=xPrec), DIMENSION(:), ALLOCATABLE :: dx,hdx,hdx2 !cell spacing arrays 01285 INTEGER :: l(3) !offset array for filling in child cells 01286 INTEGER :: i, d, n !loop counters 01287 INTEGER :: nZones !number of zones to do method correctly 01288 01289 !Calculate ip to prolongate NOT including ghost zones 01290 !ic has child cells 01291 01292 ip=1 01293 ip(1:nDim,1)=nGhost+1 01294 ic=1 01295 DO i=1,nDim 01296 ip(i,2)=size(pdata, i) - nGhost 01297 ic(i,2)=size(cdata, i) 01298 END DO 01299 01300 !Sanity check that number of ghost zones, refinement ratios, and sizes of arrays are consistent 01301 IF (ANY((ip(1:nDim,2)-ip(1:nDim,1)+1)*r /= ic(1:nDim,2)-ic(1:nDim,1)+1)) THEN 01302 write(*,*) 'mismatch between size of arrays, number of parent ghost zones, and refinement ratio.' 01303 write(*,*) 'parent bounds = ', ip(1:nDim,:) 01304 write(*,*) 'child bounds = ', ic(1:nDim,:) 01305 STOP 01306 END IF 01307 01308 01309 !First do constant prolongation regardless 01310 DO i=0,r**nDim-1 ! i loops over all r**nDim child subcells 01311 DO n=1,nDim ! maps integer i to particular n-Dimensional offset array l 01312 l(n)=MOD(i/r**(n-1),r) 01313 END DO 01314 ic(1:nDim,1)=ic(1:nDim,1)+l(1:nDim) !shift 01315 ic(1:nDim,2)=ic(1:nDim,2)-r+1+l(1:nDim) !child cells 01316 cdata(ic(1,1):ic(1,2):r,ic(2,1):ic(2,2):r,ic(3,1):ic(3,2):r) = & 01317 pdata(ip(1,1):ip(1,2),ip(2,1):ip(2,2),ip(3,1):ip(3,2)) 01318 ic(1:nDim,1)=ic(1:nDim,1)-l(1:nDim) !undo shift 01319 ic(1:nDim,2)=ic(1:nDim,2)+r-1-l(1:nDim) 01320 END DO 01321 01322 IF (method /= CONSTANT_INTERP) THEN 01323 !need to calculate slopes etc. 01324 01325 !first calculate deltas for prolongation to child cell centers in parent cell width units. 01326 ALLOCATE(dx(0:r-1), hdx(0:r-1),hdx2(0:r-1)) 01327 DO i=0,r-1 01328 dx(i)= 0.5d0*( (2.d0*i+1.d0)/REAL(r,KIND=qprec) - 1.d0) 01329 hdx(i)=0.5d0*dx(i) 01330 hdx2(i)=dx(i)*hdx(i) 01331 END DO 01332 01333 nZones=GetnGhost(method) 01334 01335 ! Allocate work array for cell centered slopes 01336 ALLOCATE(slopes(ip(1,1):ip(1,2), ip(2,1):ip(2,2), ip(3,1):ip(3,2))) 01337 01338 ! Loop through each dimension and add slopes to child data 01339 DO d=1,nDim 01340 01341 !ip is 1 sided slopes we need to calculate 01342 ip(d,2)=ip(d,2)+1 01343 ALLOCATE(sided(ip(1,1):ip(1,2), ip(2,1):ip(2,2), ip(3,1):ip(3,2))) 01344 01345 !iq is 1 sided bounds we can AND need to calculate 01346 iq=ip 01347 iq(d,1)=max(ip(d,1),1+nZones) 01348 iq(d,2)=min(ip(d,2),size(pdata,d)-nZones) 01349 !ir is offset along dimension 01350 ir=iq 01351 ir(d,:)=ir(d,:)-1 01352 sided(iq(1,1):iq(1,2),iq(2,1):iq(2,2),iq(3,1):iq(3,2)) = & 01353 pdata(iq(1,1):iq(1,2),iq(2,1):iq(2,2),iq(3,1):iq(3,2))-& 01354 pdata(ir(1,1):iq(1,2),ir(2,1):iq(2,2),ir(3,1):ir(3,2)) 01355 01356 01357 !now ir is bounds we need but could not calculate for lower boundary 01358 ir(d,1)=ip(d,1) 01359 ir(d,2)=iq(d,1)-1 01360 01361 IF (ir(d,2) >= ir(d,1)) THEN 01362 !is is slab to copy from 01363 is=ir 01364 is(d,:)=iq(d,1) 01365 sided(ir(1,1):ir(1,2), ir(2,1):ir(2,2), ir(3,1):ir(3,2)) = & 01366 spread(sum(sided(is(1,1):is(1,2), is(2,1):is(2,2), is(3,1):is(3,2)), d), d, ir(d,2)-ir(d,1)+1) 01367 END IF 01368 01369 01370 !now ir is bounds we need to extrapolate for upper boundary 01371 ir(d,1)=iq(d,2)+1 01372 ir(d,2)=ip(d,2) 01373 01374 IF (ir(d,2) >= ir(d,1)) THEN 01375 !is is slab to copy from 01376 is=ir 01377 is(d,:)=iq(d,2) 01378 sided(ir(1,1):ir(1,2), ir(2,1):ir(2,2), ir(3,1):ir(3,2)) = & 01379 spread(sum(sided(is(1,1):is(1,2), is(2,1):is(2,2), is(3,1):is(3,2)), d), d, ir(d,2)-ir(d,1)+1) 01380 END IF 01381 01382 ! now we shrink ip to refer to cell centered slopes we need (and can calculate from sided slopes) 01383 ip(d,2)=ip(d,2)-1 01384 01385 SELECT CASE (method) 01386 01387 CASE(CONSTANT_INTERP, MINMOD_INTERP, SUPERBEE_INTERP, VANLEER_INTERP, MC_INTERP, LINEAR_INTERP) 01388 01389 ! iq is offset for calculated centered limited slopes from sided slopes 01390 iq=ip 01391 iq(d,:)=ip(d,:)+1 01392 01393 slopes(ip(1,1):ip(1,2), ip(2,1):ip(2,2), ip(3,1):ip(3,2)) = limiter( & 01394 sided(ip(1,1):ip(1,2), ip(2,1):ip(2,2), ip(3,1):ip(3,2)), & 01395 sided(iq(1,1):iq(1,2), iq(2,1):iq(2,2), iq(3,1):iq(3,2)), method) 01396 01397 01398 DO i=0,r**nDim-1 ! i loops over all r**nDim child subcells 01399 DO n=1,nDim ! maps integer i to particular n-Dimensional offset array l 01400 l(n)=MOD(i/r**(n-1),r) 01401 END DO 01402 ic(1:nDim,1)=ic(1:nDim,1)+l(1:nDim) 01403 ic(1:nDim,2)=ic(1:nDim,2)-r+1+l(1:nDim) 01404 cdata(ic(1,1):ic(1,2):r,ic(2,1):ic(2,2):r,ic(3,1):ic(3,2):r) = & 01405 cdata(ic(1,1):ic(1,2):r,ic(2,1):ic(2,2):r,ic(3,1):ic(3,2):r) + & 01406 dx(l(d))*slopes(ip(1,1):ip(1,2),ip(2,1):ip(2,2),ip(3,1):ip(3,2)) 01407 ic(1:nDim,1)=ic(1:nDim,1)-l(1:nDim) 01408 ic(1:nDim,2)=ic(1:nDim,2)+r-1-l(1:nDim) 01409 END DO 01410 CASE(PARABOLIC_INTERP) 01411 iq=ip 01412 iq(d,:)=ip(d,:)+1 01413 DO i=0,r**nDim-1 ! i loops over all r**nDim child subcells 01414 DO n=1,nDim ! maps integer i to particular n-Dimensional offset array l 01415 l(n)=MOD(i/r**(n-1),r) 01416 END DO 01417 ic(1:nDim,1)=ic(1:nDim,1)+l(1:nDim) 01418 ic(1:nDim,2)=ic(1:nDim,2)-r+1+l(1:nDim) 01419 cdata(ic(1,1):ic(1,2):r,ic(2,1):ic(2,2):r,ic(3,1):ic(3,2):r) = & 01420 cdata(ic(1,1):ic(1,2):r,ic(2,1):ic(2,2):r,ic(3,1):ic(3,2):r) + & 01421 (hdx(l(d))+hdx2(l(d)))*sided(iq(1,1):iq(1,2),iq(2,1):iq(2,2),iq(3,1):iq(3,2)) + & 01422 (hdx(l(d))-hdx2(l(d)))*sided(ip(1,1):ip(1,2),ip(2,1):ip(2,2),ip(3,1):ip(3,2)) 01423 ic(1:nDim,1)=ic(1:nDim,1)-l(1:nDim) 01424 ic(1:nDim,2)=ic(1:nDim,2)+r-1-l(1:nDim) 01425 END DO 01426 01427 END SELECT 01428 DEALLOCATE(sided) 01429 END DO 01430 DEALLOCATE(slopes) 01431 DEALLOCATE(dx,hdx,hdx2) 01432 END IF 01433 01434 END SUBROUTINE ProlongateCellCenteredData 01435 01436 FUNCTION expand(mB, nGhost) 01437 INTEGER, DIMENSION(3,2) :: expand, mB 01438 INTEGER :: nGhost 01439 expand=mB 01440 expand(1:nDim,1)=mB(1:nDim,1)-nGhost 01441 expand(1:nDim,2)=mB(1:nDim,2)+nGhost 01442 END FUNCTION expand 01443 END MODULE DataDeclarations 01444 01445 01446 01447