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