Scrambler  1
data_info_ops.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_info_ops.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 
00032 
00033 MODULE DataInfoOps
00034    USE GlobalDeclarations
00035    USE DataDeclarations
00036    USE PhysicsDeclarations
00037    USE Boundary
00038    USE HyperbolicDeclarations
00039    !  USE EllipticDeclarations
00040    IMPLICIT NONE
00041 
00042    !Pair-wise data operations
00043    PUBLIC :: ProlongateParentData, ApplyOverlap, ApplyChildData, ApplyInitialChildData, SyncFlux, ApplyGenericOverlap
00044 
00045    !Pair-wise data sub-operations (because of periodic bounds - and multiple stencil locations for fluxes and emfs)
00046    PUBLIC :: ApplySingleOverlap, ApplySingleAuxOverlap, ApplySingleCostMapOverlap, SyncSingleFlux, SyncSingleEmf  !Pairwise intralevel data operations ('communication')
00047 
00048    !Sincle grid data operations
00049    PUBLIC :: ProlongationFixup, AccumulateFlux, RestrictionFixup, CoarsenDataForParent, CoarsenInitialDataForParent, UpdateTimeDeriv, ClearFixupFlux, ClearParentFixup, ClearChildFixup
00050 
00051    PUBLIC :: ChildMaskOverlap, UpdateAux, UpdateChildMask, UpdateSelfChildMask
00052 
00053    PUBLIC :: GetChildCosts, GetSubTreeCost, GetMyCosts, NewSubGrids
00054 
00055 CONTAINS
00056 
00059 
00060 
00064    SUBROUTINE ProlongateParentData(Parent,Info)
00065       USE SLOPELIM
00066       TYPE(InfoDef) :: Info
00067       TYPE(InfoDef) :: Parent
00068       INTEGER, DIMENSION(3,2) :: mB
00069       INTEGER r,n,rmbc,iError,i,j,m,nd,mbc,p,k
00070       INTEGER l(3),ic(3,2),ip(3,2),iq(3,2)
00071       REAL (KIND=xPrec) :: fact, dxp, dxc
00072       REAL (KIND=qPrec), ALLOCATABLE, DIMENSION(:,:,:,:) :: dqf,dqb
00073            ,dauxf,dauxb
00074       REAL(KIND=xPrec), DIMENSION(:), ALLOCATABLE :: dx,hdx, hdx2
00075       REAL(KIND=qPREC), DIMENSION(:,:,:,:), POINTER :: q, aux
00076       TYPE(InfoDef), POINTER :: InfoCopy
00077       !    Info%CostPerCell=Parent%CostPerCell
00078       !    Info%OldCostPerCell=Parent%CostPerCell
00079 
00080       IF (Info%level > 0) THEN
00081          IF (MaintainAuxArrays) Info%aux=UNDEFINED
00082          r=levels(Info%level-1)%CoarsenRatio
00083          mB=Info%mBounds
00084          ! Linear interpolation of coarse grid values into fine grid
00085          mbc=levels(Info%level-1)%pmbc!ceiling(real(rmbc)/real(r))!levels(Info%level-1)%CoarsenRatio
00086          rmbc=mbc*r !levels(Info%level)%ombc(1)
00087          ip=1
00088          ip(1:nDim,1)=mB(1:nDim,1)-mbc
00089          ip(1:nDim,2)=mB(1:nDim,2)+mbc
00090          ic=1        
00091          ic(1:nDim,1)=1-rmbc
00092          ic(1:nDim,2)=Info%mX(1:nDim)+rmbc
00093          DO m=1,nProlongate
00094             CALL ProlongateCellCenteredData(Parent%qChild(ip(1,1):ip(1,2),ip(2,1):ip(2,2),ip(3,1):ip(3,2), m), &
00095                  Info%q(ic(1,1):ic(1,2), ic(2,1):ic(2,2), ic(3,1):ic(3,2), ProlongateFields(m)), &
00096                  r, 0, InterpMethod(ProlongateFields(m)))
00097          END DO
00098 
00099          IF (MaintainAuxArrays) THEN
00100             dxp=levels(Info%level-1)%dx
00101             dxc=levels(Info%level)%dx
00102 
00103             ALLOCATE(dx(0:r-1), hdx(0:r-1),hdx2(0:r-1))
00104             DO i=0,r-1
00105                dx(i)= 0.5d0*( (2.d0*i+1.d0)/REAL(r,KIND=qprec) - 1.d0)
00106                hdx(i)=0.5d0*dx(i)
00107                hdx2(i)=dx(i)*hdx(i)
00108             END DO
00109 
00110             DO i=1,nDim
00111                DO j=0,r**nDim-1
00112                   IF (MOD(j/r**(i-1),r)==1) CYCLE
00113                   DO n=1,nDim
00114                      l(n)=MOD(j/r**(n-1),r)  
00115                   END DO
00116                   ic(1:nDim,1)=1+l(1:nDim)-rmbc; ic(1:nDim,2)=Info%mX(1:nDim)-r+1+l(1:nDim)+rmbc;ic(i,2)=ic(i,2)+2
00117                   ip(1:nDim,1)=mB(1:nDim,1)-mbc; ip(1:nDim,2)=mB(1:nDim,2)+mbc;ip(i,2)=ip(i,2)+1
00118                   Info%aux(ic(1,1):ic(1,2):r,ic(2,1):ic(2,2):r,ic(3,1):ic(3,2):r,i) =     &
00119                        Parent%auxChild(ip(1,1):ip(1,2)  ,ip(2,1):ip(2,2)  ,ip(3,1):ip(3,2)  ,i)
00120                END DO
00121             END DO
00122             IF (ANY(InterpMethod(auxfields) /= SPREAD(CONSTANT_INTERP,1,naux))) THEN
00123 
00124                ip(1:nDim,1)=mB(1:nDim,1)-mbc; ip(1:nDim,2)=mB(1:nDim,2)+mbc+1
00125                ALLOCATE(dauxf(ip(1,1):ip(1,2),ip(2,1):ip(2,2),ip(3,1):ip(3,2),1), &
00126                     dauxb(ip(1,1):ip(1,2),ip(2,1):ip(2,2),ip(3,1):ip(3,2),1), &
00127                     STAT=iError)
00128                IF (iError/=0) THEN
00129                   PRINT *,'Error: Unable to allocate daux work arrays in InitFields.'
00130                   STOP
00131                END IF
00132                ! Add first order correction (linear interpolation)
00133                DO m=1,nDim !B-field direction
00134                   IF (InterpMethod(auxfields(m)) == CONSTANT_INTERP) CYCLE
00135                   DO n=1,nDim
00136                      IF (n==m) CYCLE !Don't calculate gradients normal to field
00137                      l=0; l(n)=1
00138                      ip(1:nDim,1) = mB(1:nDim,1)-mbc
00139                      ip(1:nDim,2) = mB(1:nDim,2)+mbc
00140                      ip(m,2)=ip(m,2)+1
00141 
00142                      ! Compute derivative of parent array data along direction n
00143 
00144                      ! Forward differences
00145                      ip(n,1) = mB(n,1)-mbc; ip(n,2)=ip(n,2)-1
00146                      iq(1:nDim,:)=ip(1:nDim,:)+Spread(l(1:nDim),2,2)
00147                      IF (iCylindrical==NoCyl   .or.   n>1) THEN
00148                         dauxf(ip(1,1):ip(1,2),ip(2,1):ip(2,2),ip(3,1):ip(3,2),1) = &
00149                              Parent%auxChild(iq(1,1):iq(1,2),iq(2,1):iq(2,2),iq(3,1):iq(3,2),m) - &
00150                              Parent%auxChild(ip(1,1):ip(1,2),ip(2,1):ip(2,2),ip(3,1):ip(3,2),m)
00151 
00152                         ! Extrapolate forward difference to last cell along this direction
00153                         ip(n,1)=mB(n,2)+mbc; ip(n,2)=mB(n,2)+mbc
00154                         iq(1:nDim,:)=ip(1:nDim,:)-Spread(l(1:nDim),2,2)
00155                         dauxf(ip(1,1):ip(1,2),ip(2,1):ip(2,2),ip(3,1):ip(3,2),1) =  &
00156                              dauxf(iq(1,1):iq(1,2),iq(2,1):iq(2,2),iq(3,1):iq(3,2),1)
00157 
00158                         ! Backward differences
00159                         ip(n,1)=mB(n,1)-mbc+1;ip(n,2) = mB(n,2)+mbc
00160                         iq(1:nDim,:)=ip(1:nDim,:)-Spread(l(1:nDim),2,2)
00161                         dauxb(ip(1,1):ip(1,2),ip(2,1):ip(2,2),ip(3,1):ip(3,2),1) = &
00162                              Parent%auxChild(ip(1,1):ip(1,2),ip(2,1):ip(2,2),ip(3,1):ip(3,2),m) -        &
00163                              Parent%auxChild(iq(1,1):iq(1,2),iq(2,1):iq(2,2),iq(3,1):iq(3,2),m)
00164 
00165                         ! Extrapolate backward difference to first cell along this direction
00166                         ip(n,1)=mB(n,1)-mbc; ip(n,2)=mB(n,1)-mbc
00167                         iq(1:nDim,:)=ip(1:nDim,:)+Spread(l(1:nDim),2,2)
00168                         dauxb(ip(1,1):ip(1,2),ip(2,1):ip(2,2),ip(3,1):ip(3,2),1) =  &
00169                              dauxb(iq(1,1):iq(1,2),iq(2,1):iq(2,2),iq(3,1):iq(3,2),1)
00170                      ELSE
00171                         DO i=ip(1,1),ip(1,2)
00172                            dauxf(i,ip(2,1):ip(2,2),ip(3,1):ip(3,2),1) = &
00173                                 (  Parent%auxChild(i+1,iq(2,1):iq(2,2),iq(3,1):iq(3,2),m) - &
00174                                 Parent%auxChild(i,ip(2,1):ip(2,2),ip(3,1):ip(3,2),m)   )*&
00175                                 (Parent%xBounds(1,1)+i*dxp)
00176 
00177                         END DO
00178                         ! Extrapolate forward difference to last cell along this direction
00179                         i=mB(n,2)+mbc
00180                         !ip(n,1)=mB(n,2)+mbc; ip(n,2)=mB(n,2)+mbc
00181                         iq(2:nDim,:)=ip(2:nDim,:)-Spread(l(2:nDim),2,2)
00182                         dauxf(i,ip(2,1):ip(2,2),ip(3,1):ip(3,2),1) =  &
00183                              (  Parent%auxChild(i,iq(2,1):iq(2,2),iq(3,1):iq(3,2),m) - &
00184                              Parent%auxChild(i-1,ip(2,1):ip(2,2),ip(3,1):ip(3,2),m)   )*&
00185                              (Parent%xBounds(1,1)+i*dxp)
00186 
00187 
00188                         ! Backward differences
00189                         ip(n,1)=mB(n,1)-mbc+1;ip(n,2) = mB(n,2)+mbc
00190                         iq(1:nDim,:)=ip(1:nDim,:)-Spread(l(1:nDim),2,2)
00191                         DO i=ip(1,1),ip(1,2)
00192                            dauxb(i,ip(2,1):ip(2,2),ip(3,1):ip(3,2),1) = &
00193                                 (   Parent%auxChild(i,ip(2,1):ip(2,2),ip(3,1):ip(3,2),m) -        &
00194                                 Parent%auxChild(i-1,iq(2,1):iq(2,2),iq(3,1):iq(3,2),m) )*&
00195                                 (Parent%xBounds(1,1)+(i-1)*dxp)
00196                         END DO
00197                         ! Extrapolate backward difference to first cell along this direction
00198                         i=mB(n,1)-mbc
00199                         !ip(n,1)=mB(n,1)-mbc; ip(n,2)=mB(n,1)-mbc
00200                         iq(2:nDim,:)=ip(2:nDim,:)+Spread(l(2:nDim),2,2)
00201                         dauxb(i,ip(2,1):ip(2,2),ip(3,1):ip(3,2),1) =  &
00202                              (   Parent%auxChild(i+1,ip(2,1):ip(2,2),ip(3,1):ip(3,2),m) -        &
00203                              Parent%auxChild(i,iq(2,1):iq(2,2),iq(3,1):iq(3,2),m) )*&
00204                              (Parent%xBounds(1,1)+i*dxp)
00205 
00206                      ENDIF
00207 
00208                      SELECT CASE(InterpMethod(AuxFields(m)))
00209                      CASE(CONSTANT_INTERP, MINMOD_INTERP, SUPERBEE_INTERP, VANLEER_INTERP, MC_INTERP, LINEAR_INTERP)
00210                         ! Choose derivative to be used; choice is stored in dqf
00211                         dauxf=limiter(dauxf,dauxb,InterpMethod(AuxFields(m)))
00212 
00213 
00214                         ! Add correction term, taking into account offset of child cell center from
00215                         ! parent cell center
00216                         ip(n,1) = mB(n,1)-mbc
00217                         ip(n,2) = mB(n,2)+mbc
00218 
00219                         DO j=0,r**nDim-1
00220                            IF (MOD(j/r**(m-1),r)==1) CYCLE
00221                            DO nd=1,nDim
00222                               l(nd)=MOD(j/r**(nd-1),r)  
00223                            END DO
00224                            ic(1:nDim,1)=1+l(1:nDim)-rmbc; ic(1:nDim,2)=Info%mX(1:nDim)-r+1+l(1:nDim)+rmbc;ic(m,2)=ic(m,2)+2
00225                            IF (iCylindrical==NoCyl   .or.   n>1) THEN
00226                               Info%aux(ic(1,1):ic(1,2):r,ic(2,1):ic(2,2):r,ic(3,1):ic(3,2):r,m) =     &
00227                                    Info%aux(ic(1,1):ic(1,2):r,ic(2,1):ic(2,2):r,ic(3,1):ic(3,2):r,m) + &
00228                                    dx(l(n))*dauxf(ip(1,1):ip(1,2)  ,ip(2,1):ip(2,2)  ,ip(3,1):ip(3,2)  ,1)
00229                            ELSE
00230                               p=ip(1,1)
00231                               DO i=ic(1,1),ic(1,2),r
00232                                  Info%aux(i,ic(2,1):ic(2,2):r,ic(3,1):ic(3,2):r,m) =     &
00233                                       Info%aux(i,ic(2,1):ic(2,2):r,ic(3,1):ic(3,2):r,m) + &
00234                                       dx(l(n))*dauxf(p,ip(2,1):ip(2,2)  ,ip(3,1):ip(3,2)  ,1)/&
00235                                       (Info%xBounds(1,1)+(REAL(i)-half)*dxc)
00236                                  p=p+1
00237                               END DO
00238                            END IF
00239                         END DO
00240                      CASE(PARABOLIC_INTERP)
00241                         IF (iCylindrical>NoCyl   .AND.   n==1) THEN
00242                            print*,
00243 'data_info_ops.f90: Parabolic interpolation of bz + cylindrical terms not &                                supported yet' ; stop
00244                         ELSE
00245                            Info%aux(ic(1,1):ic(1,2):r,ic(2,1):ic(2,2):r,ic(3,1):ic(3,2):r,m) =     &
00246                                 Info%aux(ic(1,1):ic(1,2):r,ic(2,1):ic(2,2):r,ic(3,1):ic(3,2):r,m) + &
00247                                 (hdx(l(n))+hdx2(l(n)))*dauxf(ip(1,1):ip(1,2)  ,ip(2,1):ip(2,2)  ,ip(3,1):ip(3,2)  ,1) + &
00248                                 (hdx(l(n))-hdx2(l(n)))*dauxb(ip(1,1):ip(1,2)  ,ip(2,1):ip(2,2)  ,ip(3,1):ip(3,2)  ,1)
00249                         END IF
00250                      END SELECT
00251                   END DO
00252                END DO
00253                DEALLOCATE(dauxb,dauxf)
00254             END IF
00255             DEALLOCATE(dx,hdx,hdx2) 
00256          END IF
00257  
00258          !       write(*,*) '==========Info%q=
00259          !       write(*,*) Info%q(:,:,:,1)
00260          !       write(*,*) Info%aux(:,:,:,1)
00261          !       write(*,*) Info%aux(:,:,:,2)
00262 
00263          IF (.NOT. lRegridLevel(Info%level)) THEN
00264             ALLOCATE(InfoCopy)
00265             InfoCopy=Info
00266             InfoCopy%q=>q
00267             InfoCopy%aux=>aux
00268             CALL ApplyOverlap(Info, InfoCopy, Info%level)
00269             DEALLOCATE(InfoCopy%q)
00270             IF (MaintainAuxArrays) DEALLOCATE(InfoCopy%aux)
00271             DEALLOCATE(InfoCopy)
00272          END IF
00273 
00274       END IF
00275 
00276    END SUBROUTINE ProlongateParentData
00277 
00278 
00279 
00284    SUBROUTINE ApplyOverlap(Info,Source,n)
00285       ! Transfers data from Source within mbc cells of Info
00286       TYPE(InfoDef) :: Info, Source
00287       INTEGER, DIMENSION(3,2) :: mT, mS
00288       INTEGER, POINTER, DIMENSION(:,:,:) :: mTs, mSs
00289       INTEGER :: nOverlaps,i,n,dir,level
00290       level=Info%level
00291       CALL CalcOverlaps(Info%mGlobal,Source%mGlobal,mTs,mSs,nOverlaps,level,lHydroPeriodic,0)
00292 
00293       !    DO i=1,nOverlaps
00294       !       mT=mTs(i,:,:)
00295       !       mS=mSs(i,:,:)
00296       !       IF (LOC(Info)==LOC(Source) .AND. ALL(mT==mS)) CYCLE
00297       !       CALL ApplySingleCostMapOverlap(Info,Source,mS,mT)
00298       !    END DO
00299 
00300       IF (nOverlaps > 0) THEN
00301          DEALLOCATE(mTs,mSs)
00302          NULLIFY(mTs,mSs)
00303       END IF
00304 
00305       IF (n >-1) THEN
00306          CALL CalcOverlaps(Info%mGlobal,Source%mGlobal,mTs,mSs,nOverlaps,level,lHydroPeriodic, levels(level)%gmbc(levels(level)%step))
00307 
00308          DO i=1,nOverlaps
00309             mT=mTs(i,:,:)
00310             mS=mSs(i,:,:)
00311             IF (LOC(Info)==LOC(Source) .AND. ALL(mT==mS)) CYCLE
00312             CALL ApplySingleOverlap(Info, Source, mS, mT, GCopyFields)
00313          END DO
00314 
00315          IF (nOverlaps > 0) THEN
00316             DEALLOCATE(mTs,mSs)
00317             NULLIFY(mTs,mSs)
00318          END IF
00319 
00320          !Solution for potential has to come from base grid...
00321          !But we don't just want to prolongate solution onto finer grid - so we need to resolve for finer grid potential after regridding?  It should agree with old grid solution although that was calculated using the coarse phi-dot and the fine density field...  Probably should solve for the potential after regridding using the new potential
00322 
00323 !         IF (n >= BaseLevel .AND. (n == 0 .OR. levels(n)%step > 1) .AND. EGVars > 0) THEN 
00324 
00325             ! Don't copy overlaps from BaseLevel since this will have been done after last elliptic solve
00326             ! If BaseLevel is -1 then level n grids will be new and we want to copy old values - before the first step
00327             ! Otherwise we only want to copy old values if we are not on the first step
00328          IF (n > BaseLevel .AND. ((n == 0 .AND. levels(n)%step <= 1) .OR. levels(n)%step > 1) .AND. EGVars > 0) THEN
00329 
00330             CALL CalcOverlaps(Info%mGlobal,Source%mGlobal,mTs,mSs,nOverlaps,level,lEllipticPeriodic,levels(level)%egmbc(levels(level)%step))
00331             DO i=1,nOverlaps
00332                mT=mTs(i,:,:)
00333                mS=mSs(i,:,:)
00334                IF (LOC(Info)==LOC(Source) .AND. ALL(mT==mS)) CYCLE
00335                CALL ApplySingleOverlap(Info, Source, mS, mT, EGCopyFields)
00336             END DO
00337 
00338             IF (nOverlaps > 0) THEN
00339                DEALLOCATE(mTs,mSs)
00340                NULLIFY(mTs,mSs)
00341             END IF
00342          END IF
00343 
00344          IF (MaintainAuxArrays) THEN
00345             DO dir=1,nDim
00346                CALL CalcAuxOverlaps(Info%mGlobal,Source%mGlobal,mTs,mSs,nOverlaps,level,dir,lHydroPeriodic)
00347 
00348                DO i=1,nOverlaps
00349                   mT=mTs(i,:,:)
00350                   mS=mSs(i,:,:)
00351 
00352                   IF (LOC(Info)==LOC(Source) .AND. ALL(mT==mS)) CYCLE
00353 
00354                   CALL ApplySingleAuxOverlap(Info, Source, mS, mT,dir)
00355 
00356                END DO
00357 
00358                IF (nOverlaps > 0) THEN
00359                   DEALLOCATE(mTs,mSs)
00360                   NULLIFY(mTs,mSs)
00361                END IF
00362 
00363             END DO
00364          END IF
00365       END IF
00366       !    DO i=1, size(Info%q,4)
00367       !       write(*,*) "finished applying overlaps",i, minval(Info%q(:,:,:,i)), maxval(Info%q(:,:,:,i))
00368       !    END DO
00369    END SUBROUTINE ApplyOverlap
00370 
00371 
00378    SUBROUTINE ApplyGenericOverlap(Info,Source,n,fields,nghost,lPeriodic)
00379       ! Transfers data from Source within mbc cells of Info
00380       TYPE(InfoDef) :: Info, Source
00381       INTEGER, DIMENSION(3,2) :: mT, mS
00382       INTEGER, POINTER, DIMENSION(:,:,:) :: mTs, mSs
00383       INTEGER :: nOverlaps,i,n,dir
00384       INTEGER, DIMENSION(:) :: fields
00385       INTEGER :: nghost
00386       LOGICAL, DIMENSION(3) :: lPeriodic
00387       CALL CalcOverlaps(Info%mGlobal,Source%mGlobal,mTs,mSs,nOverlaps,Info%level,lPeriodic, nghost)
00388       IF (nOverlaps > 0) THEN
00389          DO i=1,nOverlaps
00390             mT=mTs(i,:,:)
00391             mS=mSs(i,:,:)
00392             IF (LOC(Info)==LOC(Source) .AND. ALL(mT==mS)) CYCLE
00393             CALL ApplySingleoverlap(Info,Source,mS,mT,fields)
00394          END DO
00395          DEALLOCATE(mTs,mSs)
00396          NULLIFY(mTs,mSs)
00397       END IF
00398    END SUBROUTINE ApplyGenericOverlap
00399 
00406    SUBROUTINE ApplySingleOverlap(Info, Source, mS, mT, fields)
00407       TYPE(InfoDef) :: Info, Source
00408       INTEGER, DIMENSION(3,2) :: mT, mS
00409       INTEGER, DIMENSION(:) :: fields
00410       Info%q(mT(1,1):mT(1,2),mT(2,1):mT(2,2),mT(3,1):mT(3,2),Fields)=&
00411            Source%q(mS(1,1):mS(1,2),mS(2,1):mS(2,2),mS(3,1):mS(3,2),Fields)
00412 
00413    END SUBROUTINE ApplySingleOverlap
00414 
00421    SUBROUTINE ApplySingleAuxOverlap(Info, Source, mS, mT, dir)
00422       TYPE(InfoDef) :: Info, Source
00423       INTEGER, DIMENSION(3,2) :: mT, mS
00424       INTEGER :: dir
00425       Info%aux(mT(1,1):mT(1,2),mT(2,1):mT(2,2),mT(3,1):mT(3,2),dir)= &
00426            Source%aux(mS(1,1):mS(1,2),mS(2,1):mS(2,2),mS(3,1):mS(3,2),dir)
00427    END SUBROUTINE ApplySingleAuxOverlap
00428 
00434    SUBROUTINE ApplySingleCostMapOverlap(Info,Source,mS,mT)
00435       TYPE(InfoDef) :: Info, Source
00436       INTEGER, DIMENSION(3,2) :: mT, mS
00437 
00438       Info%costmap(mT(1,1):mT(1,2),mT(2,1):mT(2,2),mT(3,1):mT(3,2),1)=&
00439            Source%costmap(mS(1,1):mS(1,2),mS(2,1):mS(2,2),mS(3,1):mS(3,2),1)
00440 
00441       !    Info%CostPerCell=Info%CostPerCell+(Source%CostPerCell-Info%OldCostPerCell)*PRODUCT(mT(1:nDim,2)-mT(1:nDim,1)+1)&
00442       !         &/PRODUCT(Info%mX(1:nDim))
00443    END SUBROUTINE ApplySingleCostMapOverlap
00444 
00450    SUBROUTINE ApplyChildData(Info,Child,ChildID,n)
00451       TYPE(InfoDef) :: Info, Child
00452       INTEGER, DIMENSION(3,2) :: mG,ip,iq,ir,mB
00453       INTEGER :: i,edge,m,ChildID,n
00454       TYPE(Boundaries), POINTER :: parentfixups, childfixups
00455       REAL(KIND=qPREC), DIMENSION(:,:,:,:), POINTER :: parentfixup, childfixup
00456 
00457       mB=Child%mBounds
00458 
00459       !    Info%CostMap(mB(1,1):mB(1,2), mB(2,1):mB(2,2), mB(3,1):mB(3,2), 1) = &
00460       !         Child%ParentCostmap(mB(1,1):mB(1,2), mB(2,1):mB(2,2), mB(3,1):mB(3,2), 1)
00461 
00462       IF (n > -1) THEN
00463          ! First update cell centered quantities from children
00464          Info%q(mB(1,1):mB(1,2), mB(2,1):mB(2,2), mB(3,1):mB(3,2), RestrictFields) = &
00465               Child%qParent(mB(1,1):mB(1,2), mB(2,1):mB(2,2), mB(3,1):mB(3,2), :)
00466 
00467          ! Then apply differences between parent's stored fluxes and child's parentfixup
00468          mG=1
00469          mG(1:nDim,2)=Info%mX(1:nDim)    
00470          parentfixups=>Info%childfixups(ChildID)%p
00471          childfixups=>Child%parentfixup
00472          DO i=1,nDim
00473             parentfixup=>parentfixups%side(i)%data
00474             childfixup=>childfixups%side(i)%data
00475             DO edge=1,2
00476 
00477                iq=mB
00478                ir=mB
00479                iq(i,:)=edge
00480                ir(i,:)=Child%mBounds(i,edge)            
00481                ir(i,:)=ir(i,:)+(-1)**edge !neighboring cell
00482 
00483                FORALL(m=1:nFlux)
00484                   WHERE(Info%ChildMask(ir(1,1):ir(1,2),ir(2,1):ir(2,2),ir(3,1):ir(3,2)) < 1)
00485                      Info%q(ir(1,1):ir(1,2),ir(2,1):ir(2,2),ir(3,1):ir(3,2),FluxFields(m)) = &
00486                           Info%q(ir(1,1):ir(1,2),ir(2,1):ir(2,2),ir(3,1):ir(3,2),FluxFields(m)) + &
00487                           (-1)**edge*(childfixup(iq(1,1):iq(1,2),iq(2,1):iq(2,2),iq(3,1):iq(3,2),m) - &
00488                           parentfixup(iq(1,1):iq(1,2),iq(2,1):iq(2,2),iq(3,1):iq(3,2),m))
00489                   END WHERE
00490                END FORALL
00491                IF (Child%mBounds(i,edge)==mG(i,edge)) THEN
00492                   Info%fixupflux%side(i)%data(iq(1,1):iq(1,2),iq(2,1):iq(2,2),iq(3,1):iq(3,2),:) = &
00493                        childfixup(iq(1,1):iq(1,2),iq(2,1):iq(2,2),iq(3,1):iq(3,2),:)
00494                END IF
00495             END DO
00496          END DO
00497 
00498          IF (MaintainAuxArrays) THEN
00499             ! Second store child emf's to be differenced later
00500             SELECT CASE(ndim)
00501             CASE(2)
00502                Info%childemf(mB(1,1):mB(1,2)+1,mB(2,1):mB(2,2)+1,1,1)=&
00503                     child%parentemf(mB(1,1):mB(1,2)+1,mB(2,1):mB(2,2)+1,1,1)
00504             CASE(3)
00505                Info%childemf(mB(1,1):mB(1,2)  ,mB(2,1):mB(2,2)+1,mB(3,1):mB(3,2)+1,1) = &
00506                     child%parentemf(mB(1,1):mB(1,2)  ,mB(2,1):mB(2,2)+1,mB(3,1):mB(3,2)+1,1)
00507                Info%childemf(mB(1,1):mB(1,2)+1,mB(2,1):mB(2,2)  ,mB(3,1):mB(3,2)+1,2) = &
00508                     child%parentemf(mB(1,1):mB(1,2)+1,mB(2,1):mB(2,2)  ,mB(3,1):mB(3,2)+1,2)
00509                Info%childemf(mB(1,1):mB(1,2)+1,mB(2,1):mB(2,2)+1,mB(3,1):mB(3,2)  ,3) = &
00510                     child%parentemf(mB(1,1):mB(1,2)+1,mB(2,1):mB(2,2)+1,mB(3,1):mB(3,2)  ,3)
00511             END SELECT
00512          END IF
00513 
00514       END IF
00515    END SUBROUTINE ApplyChildData
00516 
00521    SUBROUTINE ApplyInitialChildData(Info,Child,n)
00522       TYPE(InfoDef) :: Info, Child
00523       INTEGER, DIMENSION(3,2) :: ip,mB
00524       INTEGER :: i,n
00525 
00526       mB=Child%mBounds
00527       !    Info%CostMap(mb(1,1):mb(1,2), mb(2,1):mb(2,2), mb(3,1):mb(3,2), 1) = &
00528       !         Child%ParentCostmap(mb(1,1):mb(1,2), mb(2,1):mb(2,2), mb(3,1):mb(3,2), 1)
00529 
00530       IF (n > -1) THEN
00531          ! First update cell centered quantities from children
00532          Info%q(mb(1,1):mb(1,2), mb(2,1):mb(2,2), mb(3,1):mb(3,2), RestrictFields) = &
00533               Child%qParent(mb(1,1):mb(1,2), mb(2,1):mb(2,2), mb(3,1):mb(3,2), :)
00534 
00535          ! Then update B-fields from children (From now on we'll only update the fluxes(emfs) for the B-fields)
00536          IF (MaintainAuxArrays) THEN
00537             DO i=1,nAux
00538                ip=mb
00539                ip(i,2)=mb(i,2)+1
00540                Info%aux(ip(1,1):ip(1,2),ip(2,1):ip(2,2),ip(3,1):ip(3,2),i) = &
00541                     child%auxParent(ip(1,1):ip(1,2),ip(2,1):ip(2,2),ip(3,1):ip(3,2),i)
00542             END DO
00543             CALL UpdateAux(Info, mB)
00544          END IF
00545       END IF
00546    END SUBROUTINE ApplyInitialChildData
00547 
00551    SUBROUTINE SyncFlux(Info,Source)
00552       TYPE(InfoDef) :: Info, Source
00553       INTEGER, DIMENSION(3,2) :: mT, mS
00554       INTEGER, DIMENSION(3) :: offset
00555       INTEGER, DIMENSION(:,:,:), POINTER :: mTs, mSs
00556       INTEGER, DIMENSION(:,:), POINTER :: Offsets
00557       INTEGER, DIMENSION(:), POINTER :: edges
00558       INTEGER :: nOverlaps,i,dir,edge
00559 
00560 
00561       DO dir=1,nDim
00562          CALL CalcFluxOverlaps(Info%mGlobal,Source%mGlobal,mTs,mSs,edges,nOverlaps,Info%level,dir,lHydroPeriodic)
00563          DO i=1,nOverlaps
00564             mT=mTs(i,:,:)
00565             mS=mSs(i,:,:)            
00566             edge=edges(i)
00567             IF (LOC(Info)==LOC(Source) .AND. ALL(mT==mS)) CYCLE
00568             CALL SyncSingleFlux(Info, Source, mT, mS,dir,edge)
00569          END DO
00570          IF (nOverlaps > 0) THEN
00571             DEALLOCATE(mTs,mSs,edges)
00572             NULLIFY(mTs,mSs,edges)
00573          END IF
00574       END DO
00575 
00576       IF (MaintainAuxArrays) THEN
00577          DO dir=1,nEMF
00578             CALL CalcEmfOverlaps(Info%mGlobal,Source%mGlobal,mTs,mSs,nOverlaps,offsets,Info%level,EmfDir(dir), lHydroPeriodic)
00579             DO i=1,nOverlaps
00580                mT=mTs(i,:,:)
00581                mS=mSs(i,:,:)
00582                offset=offsets(i,:)
00583                IF (LOC(Info)==LOC(Source) .AND. ALL(mT==mS)) CYCLE
00584                CALL SyncSingleEMF(Info, Source, mT, mS, offset,EmfDir(dir))
00585             END DO
00586             IF (nOverlaps > 0) THEN
00587                DEALLOCATE(mTs,mSs, offsets)
00588                NULLIFY(mTs,mSs, offsets)
00589             END IF
00590          END DO
00591       END IF
00592 
00593       !    IF (nEllipticTransfers > 0) THEN
00594       !       CALL CalcOverlaps(Info%mGlobal, Source%mGlobal,mTs,mSs,nOverlaps,Info%level, lEllipticPeriodic)
00595       !       DO i=1,nOverlaps
00596       !          mT=mTs(i,:,:)
00597       !          mS=mSs(i,:,:)
00598 
00599       !          IF (LOC(Info)==LOC(Source) .AND. ALL(mT==mS)) CYCLE
00600 
00601       !          CALL ApplySingleOverlap(Info, Source, mS, mT,EllipticTransferFields)
00602 
00603       !       END DO
00604       !       IF (nOverlaps > 0) THEN
00605       !          DEALLOCATE(mTs,mSs)
00606       !          NULLIFY(mTs,mSs)
00607       !       END IF
00608       !    END IF
00609    END SUBROUTINE SyncFlux
00610 
00611 
00619    SUBROUTINE SyncSingleFlux(Info, Source, mT, mS, dir,edge)
00620       TYPE(InfoDef) :: Info, Source
00621       INTEGER, DIMENSION(3,2) :: mT, mS
00622       INTEGER :: dir,edge
00623       IF (Info%level==MaxLevel) THEN
00624          CALL SyncMaxLevelHydroFlux(Info,Source,mT,mS,dir,edge)
00625       ELSE
00626          CALL SyncHydroFlux(Info,Source,mT,mS,dir,edge)
00627       END IF
00628    END SUBROUTINE SyncSingleFlux
00629 
00638    SUBROUTINE SyncSingleEMF(Info, Source, mT, mS, offset,dir)
00639       TYPE(InfoDef) :: Info, Source
00640       INTEGER, DIMENSION(3,2) :: mT, mS
00641       INTEGER, DIMENSION(3) :: offset
00642       INTEGER :: dir
00643       IF (Info%level==MaxLevel) THEN
00644          CALL SyncMaxLevelEMF(Info,Source,mT,mS,dir)
00645       ELSE
00646          CALL SyncEMF(Info,Source,mT,mS,offset,dir)
00647       END IF
00648    END SUBROUTINE SyncSingleEMF
00649 
00657    SUBROUTINE SyncHydroFlux(Info,Source,mT,mS,dir,edge)
00658       TYPE(InfoDef) :: Info, Source
00659       INTEGER, DIMENSION(3,2) :: mT, mS, mF,mU,mC,mD,mV, mW, mb, ip, ic
00660       INTEGER :: dir,i,j,edge, r, l(3),n 
00661       REAL(KIND=qPREC), DIMENSION(:,:,:,:), ALLOCATABLE :: correction
00662       REAL(KIND=qPREC), DIMENSION(:,:,:,:), POINTER :: infofixupflux,
00663             sourcefixupflux
00664       mF=mT
00665       mC=mT
00666       mD=mT
00667       mU=mT  
00668       mV=mS
00669       mW=mS
00670       mU(dir,:)=mT(dir,:)-1
00671       mW(dir,:)=mS(dir,:)-1
00672       mF(dir,:)=edge
00673       mV(dir,:)=3-edge
00674 
00675       IF (edge==1) THEN !mT(dim,1)==1
00676          mC(dir,:)=1
00677          mD(dir,:)=0
00678       ELSE ! (edge==2) !(mT(dim,2)==Info%mx(dim)+1) THEN
00679          mC(dir,:)=Info%mX(dir)
00680          mD(dir,:)=Info%mX(dir)+1
00681       END IF
00682 
00683       infofixupflux=>Info%fixupflux%side(dir)%data
00684       sourcefixupflux=>Source%fixupflux%side(dir)%data
00685 
00686       ALLOCATE(correction(mF(1,1):mF(1,2),mF(2,1):mF(2,2),mF(3&
00687            &,1):mF(3,2),nFlux))
00688 
00689 !!! If cell is shared by child, then don't change fixupflux
00690 !!! otherwise, assume neighbor has child and copy neighbors fixupflux
00691       FORALL(j=1:nFlux)
00692          WHERE (info%ChildMask(mC(1,1):mC(1,2),mC(2,1):mC(2,2),mC(3&
00693               &,1):mC(3,2))==0) ! Child mask for my fluxes
00694             WHERE(info%ChildMask(mD(1,1):mD(1,2),mD(2,1):mD(2,2),mD(3&
00695                  &,1):mD(3,2))==0)
00696 
00697                correction(mF(1,1):mF(1,2),mF(2,1):mF(2,2),mF(3&
00698                     &,1):mF(3,2),j) = half*(Sourcefixupflux(mV(1&
00699                     &,1):mV(1,2),mV(2,1):mV(2,2),mV(3,1):mV(3,2),j) -&
00700                     & Infofixupflux(mF(1,1):mF(1,2),mF(2,1):mF(2,2)&
00701                     &,mF(3,1):mF(3,2),j))
00702 
00703                !               Infofixupflux(mF(1,1):mF(1,2),mF(2,1):mF(2,2),mF(3&
00704                !                    &,1):mF(3,2),j) = Infofixupflux(mF(1,1):mF(1,2)&
00705                !                    &,mF(2,1):mF(2,2),mF(3,1):mF(3,2),j) +&
00706                !                    & correction(mF(1,1):mF(1,2),mF(2,1):mF(2,2),mF(3&
00707                !                    &,1):mF(3,2),j)
00708 
00709                !               Sourcefixupflux(mV(1,1):mV(1,2), mV(2,1):mV(2,2), mV(3&
00710                !                    &,1):mV(3,2),j) = Sourcefixupflux(mV(1,1):mV(1,2)&
00711                !                    &,mV(2,1):mV(2,2), mV(3,1):mV(3,2),j) -& 
00712                !                    & correction(mF(1,1):mF(1,2),mF(2,1):mF(2,2),mF(3&
00713                !                    &,1):mF(3,2),j)
00714 
00715             ELSEWHERE
00716                correction(mF(1,1):mF(1,2),mF(2,1):mF(2,2),mF(3&
00717                     &,1):mF(3,2),j) = Sourcefixupflux(mV(1,1):mV(1,2)&
00718                     &,mV(2,1):mV(2,2),mV(3,1):mV(3,2),j) -&
00719                     & Infofixupflux(mF(1,1):mF(1,2),mF(2,1):mF(2,2)&
00720                     &,mF(3,1):mF(3,2),j)
00721 
00722                !               Infofixupflux(mF(1,1):mF(1,2),mF(2,1):mF(2,2),mF(3&
00723                !                    &,1):mF(3,2),j) = Sourcefixupflux(mV(1,1):mV(1,2)&
00724                !                    &,mV(2,1):mV(2,2),mV(3,1):mV(3,2),j)
00725 
00726 
00727             END WHERE
00728             Info%q(mT(1,1):mT(1,2),mT(2,1):mT(2,2),mT(3,1):mT(3,2)&
00729                  &,FluxFields(j)) = Info%q(mT(1,1):mT(1,2),mT(2&
00730                  &,1):mT(2,2),mT(3,1):mT(3,2),FluxFields(j)) +&
00731                  & correction(mF(1,1):mF(1,2),mF(2,1):mF(2,2),mF(3&
00732                  &,1):mF(3,2),j)              
00733 
00734             Info%q(mU(1,1):mU(1,2),mU(2,1):mU(2,2),mU(3,1):mU(3,2)&
00735                  &,FluxFields(j)) = Info%q(mU(1,1):mU(1,2),mU(2&
00736                  &,1):mU(2,2),mU(3,1):mU(3,2),FluxFields(j)) -&
00737                  & correction(mF(1,1):mF(1,2),mF(2,1):mF(2,2),mF(3&
00738                  &,1):mF(3,2),j)               
00739 
00740 
00741             !            Source%q(mS(1,1):mS(1,2),mS(2,1):mS(2,2),mS(3,1):mS(3,2)&
00742             !                 &,FluxFields(j)) = Source%q(mS(1,1):mS(1,2),mS(2&
00743             !                 &,1):mS(2,2),mS(3,1):mS(3,2),FluxFields(j)) -&
00744             !                 & correction(mF(1,1):mF(1,2),mF(2,1):mF(2,2),mF(3&
00745             !                 &,1):mF(3,2),j)              
00746 
00747             !            Source%q(mW(1,1):mW(1,2),mW(2,1):mW(2,2),mW(3,1):mW(3,2)&
00748             !                 &,FluxFields(j)) = Source%q(mW(1,1):mW(1,2),mW(2&
00749             !                 &,1):mW(2,2),mW(3,1):mW(3,2),FluxFields(j)) +&
00750             !                 & correction(mF(1,1):mF(1,2),mF(2,1):mF(2,2),mF(3&
00751             !                 &,1):mF(3,2),j)               
00752 
00753          ELSEWHERE
00754             correction(mF(1,1):mF(1,2),mF(2,1):mF(2,2),mF(3,1):mF(3,2),j)=0
00755          END WHERE
00756       END FORALL
00757       IF (Info%level > 0) THEN !adjust parentfixups...
00758          mb=Info%mBounds
00759          r=levels(Info%level-1)%CoarsenRatio               
00760          ic=mF
00761          !         ic(1:nDim,2)=Info%mX(1:nDim)
00762          ip(:,1)=Info%mBounds(:,1)+(mF(:,1) - 1)/r
00763          ip(:,2)=Info%mBounds(:,1)-1+(mF(:,2))/r
00764          ip(dir,:)=edge
00765          DO j=0,r**nDim-1
00766             IF (MOD(j/r**(dir-1),r)==1) CYCLE
00767             DO n=1,nDim
00768                l(n)=MOD(j/r**(n-1),r)  
00769             END DO
00770             ic(1:nDim,1)=mF(1:nDim,1)+l(1:nDim)
00771             ic(1:nDim,2)=mF(1:nDim,2)-r+1+l(1:nDim)
00772             ic(dir,:)=edge            
00773 
00774             !PRINT *, "ASSOCIATED(Info%parentfixup%side(", i, ")%data) = ", ASSOCIATED(Info%parentfixup%side(i)%data)
00775             Info%parentfixup%side(dir)%data(ip(1,1):ip(1,2)  ,ip(2,1):ip(2,2)  ,ip(3,1):ip(3,2)  ,:) = &
00776                  Info%parentfixup%side(dir)%data(ip(1,1):ip(1,2)  ,ip(2,1):ip(2,2)  ,ip(3,1):ip(3,2)  ,:) + &
00777                  correction(ic(1,1):ic(1,2):r,ic(2,1):ic(2,2):r,ic(3,1):ic(3,2):r,:)
00778          END DO
00779       END IF
00780 
00781 
00782       DEALLOCATE(correction) 
00783 
00784    END SUBROUTINE SyncHydroFlux
00785 
00793    SUBROUTINE SyncMaxLevelHydroFlux(Info,Source,mT,mS,dir,edge)
00794       ! This routine synchronizes fixupfluxes at the appropriate
00795       !  boundary based on mT and mS and
00796       ! updates any conserved quantities in the adjacent cells.
00797       TYPE(InfoDef) :: Info, Source
00798       INTEGER, DIMENSION(3,2) :: mT, mS, mF,mU,mC,mD,mV, mW,mb,ip,ic
00799       INTEGER :: dir,i,j,edge, r,l(3), n
00800       REAL(KIND=qPREC), DIMENSION(:,:,:,:), ALLOCATABLE :: correction
00801       REAL(KIND=qPREC), DIMENSION(:,:,:,:), POINTER :: infofixupflux,
00802             sourcefixupflux
00803       mF=mT
00804       mC=mT
00805       mD=mT
00806       mU=mT  
00807       mV=mS
00808       mW=mS
00809       mU(dir,:)=mT(dir,:)-1
00810       mW(dir,:)=mS(dir,:)-1
00811       mF(dir,:)=edge
00812       mV(dir,:)=3-edge
00813 
00814       IF (edge == 1) THEN !mT(dir,1)==1) THEN
00815          mC(dir,:)=1
00816          mD(dir,:)=0
00817       ELSEIF (edge == 2) THEN !(mT(dir,2)==Info%mx(dir)+1) THEN
00818          mC(dir,:)=Info%mX(dir)
00819          mD(dir,:)=Info%mX(dir)+1
00820       END IF
00821       infofixupflux=>Info%fixupflux%side(dir)%data
00822       sourcefixupflux=>Source%fixupflux%side(dir)%data
00823       ALLOCATE(correction(mF(1,1):mF(1,2),mF(2,1):mF(2,2),mF(3&
00824            &,1):mF(3,2),nFlux))
00825 
00826 
00827 
00828 !!! If cell is shared by child, then don't change fixupflux
00829 !!! otherwise, assume neighbor has child and copy neighbors fixupflux
00830       DO j=1,nFlux !FORALL(j=1:nFlux)
00831 
00832          correction(mF(1,1):mF(1,2),mF(2,1):mF(2,2),mF(3,1):mF(3,2)&
00833               &,j) = half*(Sourcefixupflux(mV(1,1):mV(1,2),mV(2&
00834               &,1):mV(2,2),mV(3,1):mV(3,2),j) - Infofixupflux(mF(1&
00835               &,1):mF(1,2),mF(2,1):mF(2,2),mF(3,1):mF(3,2),j))
00836 
00837          !         Infofixupflux(mF(1,1):mF(1,2),mF(2,1):mF(2,2),mF(3,1):mF(3&
00838          !              &,2),j) = Infofixupflux(mF(1,1):mF(1,2),mF(2,1):mF(2,2)&
00839          !              &,mF(3,1):mF(3,2),j) + correction(mF(1,1):mF(1,2),mF(2&
00840          !              &,1):mF(2,2),mF(3,1):mF(3,2),j)
00841 
00842 
00843          !         Sourcefixupflux(mV(1,1):mV(1,2), mV(2,1):mV(2,2), mV(3&
00844          !              &,1):mV(3,2),j) = Sourcefixupflux(mV(1,1):mV(1,2)&
00845          !              &,mV(2,1):mV(2,2), mV(3,1):mV(3,2),j) -& 
00846          !              & correction(mF(1,1):mF(1,2),mF(2,1):mF(2,2),mF(3&
00847          !              &,1):mF(3,2),j)
00848 
00849 
00850          Info%q(mT(1,1):mT(1,2),mT(2,1):mT(2,2),mT(3,1):mT(3,2)&
00851               &,FluxFields(j)) = Info%q(mT(1,1):mT(1,2),mT(2,1):mT(2&
00852               &,2),mT(3,1):mT(3,2),FluxFields(j)) + correction(mF(1&
00853               &,1):mF(1,2),mF(2,1):mF(2,2),mF(3,1):mF(3,2),j)
00854 
00855 
00856          Info%q(mU(1,1):mU(1,2),mU(2,1):mU(2,2),mU(3,1):mU(3,2)&
00857               &,FluxFields(j)) = Info%q(mU(1,1):mU(1,2),mU(2,1):mU(2,2)&
00858               &,mU(3,1):mU(3,2),FluxFields(j)) - correction(mF(1,1):mF(1&
00859               &,2),mF(2,1):mF(2,2),mF(3,1):mF(3,2),j)               
00860 
00861          !         Source%q(mS(1,1):mS(1,2),mS(2,1):mS(2,2),mS(3,1):mS(3,2)&
00862          !              &,FluxFields(j)) = Source%q(mS(1,1):mS(1,2),mS(2&
00863          !              &,1):mS(2,2),mS(3,1):mS(3,2),FluxFields(j)) -&
00864          !              & correction(mF(1,1):mF(1,2),mF(2,1):mF(2,2),mF(3&
00865          !              &,1):mF(3,2),j)              
00866 
00867          !         Source%q(mW(1,1):mW(1,2),mW(2,1):mW(2,2),mW(3,1):mW(3,2)&
00868          !              &,FluxFields(j)) = Source%q(mW(1,1):mW(1,2),mW(2&
00869          !              &,1):mW(2,2),mW(3,1):mW(3,2),FluxFields(j)) +&
00870          !              & correction(mF(1,1):mF(1,2),mF(2,1):mF(2,2),mF(3&
00871          !              &,1):mF(3,2),j)               
00872 
00873 
00874          !    END FORALL
00875       END DO
00876       IF (Info%level > 0) THEN !adjust parentfixups...
00877          mb=Info%mBounds
00878          r=levels(Info%level-1)%CoarsenRatio               
00879          ic=mF
00880          ip=1
00881          !         ic(1:nDim,2)=Info%mX(1:nDim)
00882          ip(1:nDim,1)=Info%mBounds(1:nDim,1)+(mF(1:nDim,1) - 1)/r
00883          ip(1:nDim,2)=Info%mBounds(1:nDim,1)-1+(mF(1:nDim,2))/r
00884          ip(dir,:)=edge
00885          DO j=0,r**nDim-1
00886             IF (MOD(j/r**(dir-1),r)==1) CYCLE
00887             DO n=1,nDim
00888                l(n)=MOD(j/r**(n-1),r)  
00889             END DO
00890             ic(1:nDim,1)=mF(1:nDim,1)+l(1:nDim)
00891             ic(1:nDim,2)=mF(1:nDim,2)-r+1+l(1:nDim)
00892             ic(dir,:)=edge            
00893             !PRINT *, "ASSOCIATED(Info%parentfixup%side(", i, ")%data) = ", ASSOCIATED(Info%parentfixup%side(i)%data)
00894             Info%parentfixup%side(dir)%data(ip(1,1):ip(1,2)  ,ip(2,1):ip(2,2)  ,ip(3,1):ip(3,2)  ,:) = &
00895                  Info%parentfixup%side(dir)%data(ip(1,1):ip(1,2)  ,ip(2,1):ip(2,2)  ,ip(3,1):ip(3,2)  ,:) + &
00896                  correction(ic(1,1):ic(1,2):r,ic(2,1):ic(2,2):r,ic(3,1):ic(3,2):r,:)
00897          END DO
00898       END IF
00899       DEALLOCATE(correction) 
00900    END SUBROUTINE SyncMaxLevelHydroFlux
00901 
00910    SUBROUTINE SyncEMF(Info,Source,mT,mS,offset,dir)
00911       !This routine synchronizes any common emf's used by two
00912       ! adjacent grids along their boundary and updates adjacent B
00913       ! -fields.
00914       TYPE(InfoDef) :: Info, Source
00915       INTEGER, DIMENSION(3,2) :: mT, mS, mA, mB, mC, mCm,tempmT,tempmS
00916       REAL(KIND=qPREC), DIMENSION(:,:,:,:), ALLOCATABLE :: correction
00917       LOGICAL, DIMENSION(:,:,:), ALLOCATABLE :: sourceauxchildmask,
00918             sourcechildmask
00919       INTEGER :: i,dim,dir,inorm,level,edge,j,k,l
00920       REAL(KIND=qPREC) :: dtdxdim, dtdxnorm, dx, ri,rl,rh
00921       INTEGER, DIMENSION(3) :: offset
00922       ! Find direction of shared boundary (If neighbor is diagonal
00923       !  this will pick the lower of the two dims - but it shouldn't
00924       !   matter)
00925       level=Info%level
00926       dx=levels(level)%dx
00927       SELECT CASE(nDim)
00928 
00929       CASE(2) !nDim
00930          !We have Source%mGlobal and we want to create an emf mask
00931          ! for sources children
00932          !Need to make a cell centered mask for source only
00933          !
00934          DO i=1,nDim
00935             mC(i,1)=mT(i,1)-1
00936             mC(i,2)=mT(i,2)
00937          END DO
00938          ALLOCATE(sourcechildmask(mC(1,1):mC(1,2),mC(2,1):mC(2,2),1))
00939          sourcechildmask=.false.
00940          DO i=1,nDim
00941             mC(i,1)=max(mC(i,1),Source%mGlobal(i,1)+offset(i)-Info&
00942                  &%mGlobal(i,1)+1) !Ensure that left boundary is
00943             ! inside of source
00944             mC(i,2)=min(mC(i,2),Source%mGlobal(i,2)+offset(i)-Info&
00945                  &%mGlobal(i,1)+1)
00946          END DO
00947          sourcechildmask(mC(1,1):mC(1,2),mC(2,1):mC(2,2),1)=(Info&
00948               &%ChildMask(mC(1,1):mC(1,2),mC(2,1):mC(2,2),1)&
00949               &==NEIGHBORCHILD)
00950          ALLOCATE(correction(mT(1,1):mT(1,2),mT(2,1):mT(2,2),1,1),&
00951               & sourceauxchildmask(mT(1,1):mT(1,2),mT(2,1):mT(2,2),1))
00952          sourceauxchildmask=.false.         
00953          mC=mT              
00954          DO j=-1,0
00955             DO k=-1,0
00956                !              IF (i==dim .AND. j==-1) CYCLE
00957                mC(1,:)=mT(1,:)+j
00958                mC(2,:)=mT(2,:)+k
00959                sourceauxchildmask(mT(1,1):mT(1,2),mT(2,1):mT(2,2),1)=&
00960                     & sourceauxchildmask(mT(1,1):mT(1,2),mT(2,1):mT(2&
00961                     &,2),1) .OR. sourcechildmask(mC(1,1):mC(1,2),mC(2&
00962                     &,1):mC(2,2),1)
00963             END DO
00964          END DO
00965          mA=mT
00966          mB=mT
00967          mA(2 ,:)=mT(2  ,:)-1      !Shift for updating aux(inorm)
00968          mB(1,:)=mT(1,:)-1      !Shift for updating aux(dim)
00969          IF (iCylindrical==NoCyl) THEN
00970             WHERE (Info%childemf(mT(1,1):mT(1,2),mT(2,1):mT(2,2),1,1) ==&
00971                  & undefined) !don't have refined data
00972 
00973                ! If Source%childemf is communicated then...
00974                !            WHERE (Source%childemf(mS(1,1):mS(1,2),mS(2
00975                !            ,1):mS(2,2),1,1,dir) /= undefined)
00976                !             !neighbor has refined data
00977                ! Else we can calculate sourceauxchildmask from childmask
00978                !  data in the ghost regions
00979                WHERE(sourceauxchildmask(mT(1,1):mT(1,2),mT(2,1):mT(2,2)&
00980                     &,1)) !neighbor has refined data
00981 
00982                   correction(mT(1,1):mT(1,2),mT(2,1):mT(2,2),1,1) =&
00983                        & Source%emf(mS(1,1):mS(1,2),mS(2,1):mS(2,2),1,1)&
00984                        &- Info%emf(mT(1,1):mT(1,2),mT(2,1):mT(2,2),1,1)
00985 
00986                   Info%childemf(mT(1,1):mT(1,2),mT(2,1):mT(2,2),1,1) =&
00987                        & Source%emf(mS(1,1):mS(1,2),mS(2,1):mS(2,2),1,1)
00988 
00989                   Info%emf(mT(1,1):mT(1,2),mT(2,1):mT(2,2),1,1) = Source&
00990                        &%emf(mS(1,1):mS(1,2),mS(2,1):mS(2,2),1,1)
00991 
00992                   ! And apply correction
00993                   Info%aux(mT(1,1):mT(1,2),mT(2,1):mT(2,2),1,1)=&
00994                        & Info%aux(mT(1,1):mT(1,2),mT(2,1):mT(2,2),1&
00995                        &,1)+ correction(mT(1,1):mT(1,2),mT(2&
00996                        &,1):mT(2,2),1,1    )
00997 
00998                   Info%aux(mA(1,1):mA(1,2),mA(2,1):mA(2,2),1,1)=&
00999                        & Info%aux(mA(1,1):mA(1,2),mA(2,1):mA(2,2),1&
01000                        &,1)- correction(mT(1,1):mT(1,2),mT(2&
01001                        &,1):mT(2,2),1,1    )
01002 
01003                   Info%aux(mT(1,1):mT(1,2),mT(2,1):mT(2,2),1,2  )=&
01004                        & Info%aux(mT(1,1):mT(1,2),mT(2,1):mT(2,2),1,2 &
01005                        & )- correction(mT(1,1):mT(1,2),mT(2&
01006                        &,1):mT(2,2),1,1    )
01007 
01008                   Info%aux(mB(1,1):mB(1,2),mB(2,1):mB(2,2),1,2  )=&
01009                        & Info%aux(mB(1,1):mB(1,2),mB(2,1):mB(2,2),1,2 &
01010                        & )+ correction(mT(1,1):mT(1,2),mT(2&
01011                        &,1):mT(2,2),1,1    )
01012 
01013 
01014                ELSEWHERE !Neither grid has refined data yet - so take
01015                   ! minimum abs
01016                   WHERE(ABS(  Info%emf(mT(1,1):mT(1,2),mT(2,1):mT(2,2),1&
01017                        &,1)) > ABS(Source%emf(mS(1,1):mS(1,2),mS(2&
01018                        &,1):mS(2,2),1,1)))
01019 
01020                      correction(mT(1,1):mT(1,2),mT(2,1):mT(2,2),1,1) =&
01021                           & Source%emf(mS(1,1):mS(1,2),mS(2,1):mS(2,2),1&
01022                           &,1)- Info%emf(mT(1,1):mT(1,2),mT(2,1):mT(2,2)&
01023                           &,1,1)
01024 
01025                      Info%emf(mT(1,1):mT(1,2),mT(2,1):mT(2,2),1,1)=&
01026                           & Source%emf(mS(1,1):mS(1,2),mS(2,1):mS(2,2),1&
01027                           &,1)
01028 
01029                      ! And apply correction
01030                      Info%aux(mT(1,1):mT(1,2),mT(2,1):mT(2,2),1,1)=&
01031                           & Info%aux(mT(1,1):mT(1,2),mT(2,1):mT(2,2),1&
01032                           &,1)+ correction(mT(1,1):mT(1,2)&
01033                           &,mT(2,1):mT(2,2),1,1    )
01034 
01035                      Info%aux(mA(1,1):mA(1,2),mA(2,1):mA(2,2),1,1)=&
01036                           & Info%aux(mA(1,1):mA(1,2),mA(2,1):mA(2,2),1&
01037                           &,1)- correction(mT(1,1):mT(1,2)&
01038                           &,mT(2,1):mT(2,2),1,1    )
01039 
01040                      Info%aux(mT(1,1):mT(1,2),mT(2,1):mT(2,2),1,2  )=&
01041                           & Info%aux(mT(1,1):mT(1,2),mT(2,1):mT(2,2),1&
01042                           &,2  )- correction(mT(1,1):mT(1,2)&
01043                           &,mT(2,1):mT(2,2),1,1    )
01044 
01045                      Info%aux(mB(1,1):mB(1,2),mB(2,1):mB(2,2),1,2  )=&
01046                           & Info%aux(mB(1,1):mB(1,2),mB(2,1):mB(2,2),1&
01047                           &,2  )+ correction(mT(1,1):mT(1,2)&
01048                           &,mT(2,1):mT(2,2),1,1    )
01049 
01050 
01051                   END WHERE
01052                END WHERE
01053             END WHERE
01054          ELSE
01055             DO i=mT(1,1),mT(1,2)          
01056                j=i-mT(1,1)+mS(1,1)
01057                k=i-mT(1,1)+mA(1,1)
01058                l=i-mT(1,1)+mB(1,1)
01059                ri=(Info%xBounds(1,1)+(i-1)*dx)
01060                rl=1.d0/(Info%xBounds(1,1)+(REAL(i)-half)*dx)
01061                rh=1.d0/(Info%xBounds(1,1)+(REAL(i)+half)*dx)
01062 
01063                WHERE (Info%childemf(i,mT(2,1):mT(2,2),1,1) ==&
01064                     & undefined) !don't have refined data
01065 
01066                   ! If Source%childemf is communicated then...
01067                   !            WHERE (Source%childemf(j,mS(2
01068                   !            ,1):mS(2,2),1,1,dir) /= undefined)
01069                   !             !neighbor has refined data
01070                   ! Else we can calculate sourceauxchildmask from childmask
01071                   !  data in the ghost regions
01072                   WHERE(sourceauxchildmask(i,mT(2,1):mT(2,2)&
01073                        &,1)) !neighbor has refined data
01074 
01075                      correction(i,mT(2,1):mT(2,2),1,1) =&
01076                           & Source%emf(j,mS(2,1):mS(2,2),1,1)&
01077                           &- Info%emf(i,mT(2,1):mT(2,2),1,1)
01078 
01079                      Info%childemf(i,mT(2,1):mT(2,2),1,1) =&
01080                           & Source%emf(j,mS(2,1):mS(2,2),1,1)
01081 
01082                      Info%emf(i,mT(2,1):mT(2,2),1,1) = Source&
01083                           &%emf(j,mS(2,1):mS(2,2),1,1)
01084 
01085                      ! And apply correction
01086                      Info%aux(i,mT(2,1):mT(2,2),1,1)=&
01087                           & Info%aux(i,mT(2,1):mT(2,2),1&
01088                           &,1)+ correction(i,mT(2&
01089                           &,1):mT(2,2),1,1    )
01090 
01091                      Info%aux(k,mA(2,1):mA(2,2),1,1)=&
01092                           & Info%aux(k,mA(2,1):mA(2,2),1&
01093                           &,1)- correction(i,mT(2&
01094                           &,1):mT(2,2),1,1    )
01095 
01096                      Info%aux(i,mT(2,1):mT(2,2),1,2  )=&
01097                           & Info%aux(i,mT(2,1):mT(2,2),1,2 &
01098                           & )- correction(i,mT(2&
01099                           &,1):mT(2,2),1,1    )*&
01100                           ri*rh
01101 
01102                      Info%aux(l,mB(2,1):mB(2,2),1,2  )=&
01103                           & Info%aux(l,mB(2,1):mB(2,2),1,2 &
01104                           & )+ correction(i,mT(2&
01105                           &,1):mT(2,2),1,1    )*&
01106                           ri*rl
01107 
01108 
01109                   ELSEWHERE !Neither grid has refined data yet - so take
01110                      ! minimum abs
01111                      WHERE(ABS(  Info%emf(i,mT(2,1):mT(2,2),1&
01112                           &,1)) > ABS(Source%emf(j,mS(2&
01113                           &,1):mS(2,2),1,1)))
01114 
01115                         correction(i,mT(2,1):mT(2,2),1,1) =&
01116                              & Source%emf(j,mS(2,1):mS(2,2),1&
01117                              &,1)- Info%emf(i,mT(2,1):mT(2,2)&
01118                              &,1,1)
01119 
01120                         Info%emf(i,mT(2,1):mT(2,2),1,1)=&
01121                              & Source%emf(j,mS(2,1):mS(2,2),1&
01122                              &,1)
01123 
01124                         ! And apply correction
01125                         Info%aux(i,mT(2,1):mT(2,2),1,1)=&
01126                              & Info%aux(i,mT(2,1):mT(2,2),1&
01127                              &,1)+ correction(i&
01128                              &,mT(2,1):mT(2,2),1,1    )
01129 
01130                         Info%aux(k,mA(2,1):mA(2,2),1,1)=&
01131                              & Info%aux(k,mA(2,1):mA(2,2),1&
01132                              &,1)- correction(i&
01133                              &,mT(2,1):mT(2,2),1,1    )
01134 
01135                         Info%aux(i,mT(2,1):mT(2,2),1,2  )=&
01136                              & Info%aux(i,mT(2,1):mT(2,2),1&
01137                              &,2  )- correction(i&
01138                              &,mT(2,1):mT(2,2),1,1    )*&
01139                              ri*rh
01140 
01141                         Info%aux(l,mB(2,1):mB(2,2),1,2  )=&
01142                              & Info%aux(l,mB(2,1):mB(2,2),1&
01143                              &,2  )+ correction(i&
01144                              &,mT(2,1):mT(2,2),1,1    )*&
01145                              ri*rl
01146 
01147 
01148                      END WHERE
01149                   END WHERE
01150                END WHERE
01151             END DO
01152          END IF!icyl
01153          DEALLOCATE(correction,sourceauxchildmask,sourcechildmask) 
01154 
01155       CASE(3) !nDim
01156          DO i=1,nDim
01157             mC(i,1)=mT(i,1)-1!max(mT(i,1)-1,1+Source%mGlobal(i,1)
01158             !-Info%mGlobal(i,1))
01159             mC(i,2)=mT(i,2)!min(mT(i,2),  1+Source%mGlobal(i,2)-Info
01160             !%mGlobal(i,1))
01161          END DO
01162          mC(dir,:)=mT(dir,:) !don't need to shrink direction of emf!
01163          ALLOCATE(sourcechildmask(mC(1,1):mC(1,2),mC(2,1):mC(2,2)&
01164               &,mC(3,1):mC(3,2)))           
01165          sourcechildmask=.false.
01166          DO i=1,nDim
01167             !            IF (i == dir) cycle
01168             mC(i,1)=max(mC(i,1),Source%mGlobal(i,1)+offset(i)-Info&
01169                  &%mGlobal(i,1)+1) !Ensure that left boundary is
01170             ! inside of source
01171             mC(i,2)=min(mC(i,2),Source%mGlobal(i,2)+offset(i)-Info&
01172                  &%mGlobal(i,1)+1)
01173          END DO
01174          sourcechildmask(mC(1,1):mC(1,2),mC(2,1):mC(2,2),mC(3,1):mC(3&
01175               &,2))=(Info%ChildMask(mC(1,1):mC(1,2),mC(2,1):mC(2,2)&
01176               &,mC(3,1):mC(3,2))==NEIGHBORCHILD)
01177 
01178          ! sourceauxchildmask(:,:,:,:,1) is a flag for neighbor's
01179          !  emfs being refined or no
01180          ALLOCATE(correction(mT(1,1):mT(1,2),mT(2,1):mT(2,2),mT(3&
01181               &,1):mT(3,2),1), sourceauxchildmask(mT(1,1):mT(1,2)&
01182               &,mT(2,1):mT(2,2),mT(3,1):mT(3,2)))
01183          sourceauxchildmask=.false.
01184          dim=modulo(dir-2,3)+1
01185          inorm=6-dim-dir               !direction normal to edge
01186          ! and emf           
01187          mC=mT
01188          DO j=-1,0
01189             DO k=-1,0
01190                mC(dim,:)=mT(dim,:)+j
01191                mC(inorm,:)=mT(inorm,:)+k
01192                sourceauxchildmask(mT(1,1):mT(1,2),mT(2,1):mT(2,2)&
01193                     &,mT(3,1):mT(3,2))= sourceauxchildmask(mT(1&
01194                     &,1):mT(1,2),mT(2,1):mT(2,2),mT(3,1):mT(3,2))&
01195                     & .OR. sourcechildmask(mC(1,1):mC(1,2),mC(2&
01196                     &,1):mC(2,2),mC(3,1):mC(3,2))
01197             END DO
01198          END DO
01199          mA=mT
01200          mB=mT
01201          mA(dim  ,:)=mT(dim  ,:)-1      !Shift for updating
01202          ! aux(inorm)
01203          mB(inorm,:)=mT(inorm,:)-1      !Shift for updating
01204          ! aux(dim)
01205 
01206          !if have childemf - do nothing
01207          !else if neighbors have child - apply correction and
01208          ! store emf and update childemf
01209          !else calc correction and update emf...
01210 
01211          WHERE (Info%childemf(mT(1,1):mT(1,2),mT(2,1):mT(2,2),mT(3&
01212               &,1):mT(3,2),dir) == undefined) !don't have refined
01213             ! data
01214 
01215             ! If Source%childemf is communicated then...
01216             !            WHERE (Source%childemf(mS(1,1):mS(1,2)
01217             !            ,mS(2,1):mS(2,2),mS(3,1):mS(3,2),1,dir)
01218             !            /= undefined) !neighbor has refined data
01219             ! Else we can calculate sourceauxchildmask from
01220             !  childmask data in the ghost regions
01221             WHERE(sourceauxchildmask(mT(1,1):mT(1,2),mT(2,1):mT(2&
01222                  &,2),mT(3,1):mT(3,2))) !neighbor has refined data
01223 
01224                correction(mT(1,1):mT(1,2),mT(2,1):mT(2,2),mT(3&
01225                     &,1):mT(3,2),1   ) = Source%emf(mS(1,1):mS(1&
01226                     &,2),mS(2,1):mS(2,2),mS(3,1):mS(3,2),dir)-&
01227                     & Info%emf(mT(1,1):mT(1,2),mT(2,1):mT(2,2)&
01228                     &,mT(3,1):mT(3,2),dir)
01229 
01230                Info%childemf(mT(1,1):mT(1,2),mT(2,1):mT(2,2),mT(3&
01231                     &,1):mT(3,2),dir) = Source%emf(mS(1,1):mS(1&
01232                     &,2),mS(2,1):mS(2,2),mS(3,1):mS(3,2),dir)
01233 
01234                Info%emf(mT(1,1):mT(1,2),mT(2,1):mT(2,2),mT(3&
01235                     &,1):mT(3,2),dir) = Source%emf(mS(1,1):mS(1&
01236                     &,2),mS(2,1):mS(2,2),mS(3,1):mS(3,2),dir)
01237 
01238                ! And apply correction
01239                Info%aux(mT(1,1):mT(1,2),mT(2,1):mT(2,2),mT(3&
01240                     &,1):mT(3,2),inorm)= Info%aux(mT(1,1):mT(1,2)&
01241                     &,mT(2,1):mT(2,2),mT(3,1):mT(3,2),inorm)+&
01242                     & correction(mT(1,1):mT(1,2),mT(2&
01243                     &,1):mT(2,2),mT(3,1):mT(3,2),1    )
01244 
01245                Info%aux(mA(1,1):mA(1,2),mA(2,1):mA(2,2),mA(3&
01246                     &,1):mA(3,2),inorm)= Info%aux(mA(1,1):mA(1,2)&
01247                     &,mA(2,1):mA(2,2),mA(3,1):mA(3,2),inorm)-&
01248                     & correction(mT(1,1):mT(1,2),mT(2&
01249                     &,1):mT(2,2),mT(3,1):mT(3,2),1    )
01250 
01251                Info%aux(mT(1,1):mT(1,2),mT(2,1):mT(2,2),mT(3&
01252                     &,1):mT(3,2),dim  )= Info%aux(mT(1,1):mT(1,2)&
01253                     &,mT(2,1):mT(2,2),mT(3,1):mT(3,2),dim  )-&
01254                     & correction(mT(1,1):mT(1,2),mT(2&
01255                     &,1):mT(2,2),mT(3,1):mT(3,2),1    )
01256 
01257                Info%aux(mB(1,1):mB(1,2),mB(2,1):mB(2,2),mB(3&
01258                     &,1):mB(3,2),dim  )= Info%aux(mB(1,1):mB(1,2)&
01259                     &,mB(2,1):mB(2,2),mB(3,1):mB(3,2),dim  )+&
01260                     & correction(mT(1,1):mT(1,2),mT(2&
01261                     &,1):mT(2,2),mT(3,1):mT(3,2),1    )
01262 
01263 
01264             ELSEWHERE !Neither grid has refined data yet - so take
01265                ! minimum abs
01266                WHERE(ABS(  Info%emf(mT(1,1):mT(1,2),mT(2,1):mT(2&
01267                     &,2),mT(3,1):mT(3,2),dir)) > ABS(Source&
01268                     &%emf(mS(1,1):mS(1,2),mS(2,1):mS(2,2),mS(3&
01269                     &,1):mS(3,2),dir)))
01270 
01271                   correction(mT(1,1):mT(1,2),mT(2,1):mT(2,2),mT(3&
01272                        &,1):mT(3,2),1   ) = Source%emf(mS(1&
01273                        &,1):mS(1,2),mS(2,1):mS(2,2),mS(3,1):mS(3&
01274                        &,2),dir)- Info%emf(mT(1,1):mT(1,2),mT(2&
01275                        &,1):mT(2,2),mT(3,1):mT(3,2),dir)
01276 
01277                   Info%emf(mT(1,1):mT(1,2),mT(2,1):mT(2,2),mT(3&
01278                        &,1):mT(3,2),dir)= Source%emf(mS(1,1):mS(1&
01279                        &,2),mS(2,1):mS(2,2),mS(3,1):mS(3,2),dir)
01280 
01281                   ! And apply correction
01282                   Info%aux(mT(1,1):mT(1,2),mT(2,1):mT(2,2),mT(3&
01283                        &,1):mT(3,2),inorm)= Info%aux(mT(1,1):mT(1&
01284                        &,2),mT(2,1):mT(2,2),mT(3,1):mT(3,2),inorm)&
01285                        &+ correction(mT(1,1):mT(1,2),mT(2&
01286                        &,1):mT(2,2),mT(3,1):mT(3,2),1    )
01287 
01288                   Info%aux(mA(1,1):mA(1,2),mA(2,1):mA(2,2),mA(3&
01289                        &,1):mA(3,2),inorm)= Info%aux(mA(1,1):mA(1&
01290                        &,2),mA(2,1):mA(2,2),mA(3,1):mA(3,2),inorm)&
01291                        &- correction(mT(1,1):mT(1,2),mT(2&
01292                        &,1):mT(2,2),mT(3,1):mT(3,2),1    )
01293 
01294                   Info%aux(mT(1,1):mT(1,2),mT(2,1):mT(2,2),mT(3&
01295                        &,1):mT(3,2),dim  )= Info%aux(mT(1,1):mT(1&
01296                        &,2),mT(2,1):mT(2,2),mT(3,1):mT(3,2),dim  )&
01297                        &- correction(mT(1,1):mT(1,2),mT(2&
01298                        &,1):mT(2,2),mT(3,1):mT(3,2),1    )
01299 
01300                   Info%aux(mB(1,1):mB(1,2),mB(2,1):mB(2,2),mB(3&
01301                        &,1):mB(3,2),dim  )= Info%aux(mB(1,1):mB(1&
01302                        &,2),mB(2,1):mB(2,2),mB(3,1):mB(3,2),dim  )&
01303                        &+ correction(mT(1,1):mT(1,2),mT(2&
01304                        &,1):mT(2,2),mT(3,1):mT(3,2),1    )
01305 
01306 
01307                END WHERE
01308             END WHERE
01309 
01310          END WHERE
01311 
01312          DEALLOCATE(correction,sourceauxchildmask,sourcechildmask) 
01313       END SELECT
01314    END SUBROUTINE SyncEMF
01315 
01323    SUBROUTINE SyncMaxLevelEMF(Info,Source,mT,mS,dir)
01324       !This routine synchronizes any common emf's used by two
01325       ! adjacent grids along their boundary and updates adjacent B
01326       ! -fields.
01327       TYPE(InfoDef) :: Info, Source
01328       INTEGER, DIMENSION(3,2) :: mT, mS, mA, mB, mC, mCm
01329       REAL(KIND=qPREC), DIMENSION(:,:,:,:), ALLOCATABLE :: correction
01330       LOGICAL, DIMENSION(:,:,:), ALLOCATABLE :: sourceauxchildmask
01331       INTEGER :: i,dim,dir,inorm,level,j,k,l
01332       REAL(KIND=qPREC) :: dtdxdim, dtdxnorm, dx, ri, rh, rl
01333       ! Find direction of shared boundary (If neighbor is diagonal
01334       !  this will pick the lower of the two dims - but it shouldn't
01335       !   matter)
01336       level=Info%level
01337       dx=levels(level)%dx
01338 
01339       SELECT CASE(nDim)
01340       CASE(2) !nDim
01341          IF (dir /= 3) THEN
01342             WRITE(*,*) "Error in SyncMaxLevelEMF"
01343             STOP
01344          END IF
01345          mA=mT
01346          mB=mT
01347          mA(2,:)=mT(2,:)-1      !Shift for updating aux(inorm)
01348          mB(1,:)=mT(1,:)-1      !Shift for updating aux(dim)
01349 
01350          ALLOCATE(correction(mT(1,1):mT(1,2),mT(2,1):mT(2,2),1,1))
01351 
01352          IF (iCylindrical==NoCyl) THEN
01353             WHERE(ABS(  Info%emf(mT(1,1):mT(1,2),mT(2,1):mT(2,2),1,1)) > & 
01354                  ABS(Source%emf(mS(1,1):mS(1,2),mS(2,1):mS(2,2),1,1)))
01355 
01356                correction(mT(1,1):mT(1,2),mT(2,1):mT(2,2),1,1) = &
01357                     Source%emf(mS(1,1):mS(1,2),mS(2,1):mS(2,2),1,1) - &
01358                     Info%emf(mT(1,1):mT(1,2),mT(2,1):mT(2,2),1,1)
01359 
01360                Info%emf(mT(1,1):mT(1,2),mT(2,1):mT(2,2),1,1) = &
01361                     Source%emf(mS(1,1):mS(1,2),mS(2,1):mS(2,2),1,1)
01362 
01363                ! And apply correction
01364                Info%aux(mT(1,1):mT(1,2),mT(2,1):mT(2,2),1,1) = &
01365                     Info%aux(mT(1,1):mT(1,2),mT(2,1):mT(2,2),1,1)+&
01366                     correction(mT(1,1):mT(1,2),mT(2,1):mT(2,2),1,1)
01367 
01368                Info%aux(mA(1,1):mA(1,2),mA(2,1):mA(2,2),1,1) = &
01369                     Info%aux(mA(1,1):mA(1,2),mA(2,1):mA(2,2),1,1)-&
01370                     correction(mT(1,1):mT(1,2),mT(2,1):mT(2,2),1,1)
01371 
01372                Info%aux(mT(1,1):mT(1,2),mT(2,1):mT(2,2),1,2) = &
01373                     Info%aux(mT(1,1):mT(1,2),mT(2,1):mT(2,2),1,2)-&
01374                     correction(mT(1,1):mT(1,2),mT(2,1):mT(2,2),1,1)
01375 
01376                Info%aux(mB(1,1):mB(1,2),mB(2,1):mB(2,2),1,2) = &
01377                     Info%aux(mB(1,1):mB(1,2),mB(2,1):mB(2,2),1,2)+&
01378                     correction(mT(1,1):mT(1,2),mT(2,1):mT(2,2),1,1)
01379 
01380 
01381             END WHERE
01382          ELSE
01383             DO i=mT(1,1),mT(1,2)          
01384                j=i-mT(1,1)+mS(1,1)
01385                k=i-mT(1,1)+mA(1,1)
01386                l=i-mT(1,1)+mB(1,1)
01387                ri=(Info%xBounds(1,1)+(i-1)*dx)
01388                rl=1.d0/(Info%xBounds(1,1)+(REAL(i)-half)*dx)
01389                rh=1.d0/(Info%xBounds(1,1)+(REAL(i)+half)*dx)
01390 
01391                WHERE(ABS(  Info%emf(i,mT(2,1):mT(2,2),1,1)) > & 
01392                     ABS(Source%emf(j,mS(2,1):mS(2,2),1,1)))
01393 
01394                   correction(i,mT(2,1):mT(2,2),1,1) = &
01395                        Source%emf(j,mS(2,1):mS(2,2),1,1) - &
01396                        Info%emf(i,mT(2,1):mT(2,2),1,1)
01397 
01398                   Info%emf(i,mT(2,1):mT(2,2),1,1) = &
01399                        Source%emf(j,mS(2,1):mS(2,2),1,1)
01400 
01401                   ! And apply correction
01402                   Info%aux(i,mT(2,1):mT(2,2),1,1) = &
01403                        Info%aux(i,mT(2,1):mT(2,2),1,1)+&
01404                        correction(i,mT(2,1):mT(2,2),1,1)
01405 
01406                   Info%aux(k,mA(2,1):mA(2,2),1,1) = &
01407                        Info%aux(k,mA(2,1):mA(2,2),1,1)-&
01408                        correction(i,mT(2,1):mT(2,2),1,1)
01409 
01410                   Info%aux(i,mT(2,1):mT(2,2),1,2) = &
01411                        Info%aux(i,mT(2,1):mT(2,2),1,2)-&
01412                        correction(i,mT(2,1):mT(2,2),1,1)*&
01413                        ri*rh
01414 
01415                   Info%aux(l,mB(2,1):mB(2,2),1,2) = &
01416                        Info%aux(l,mB(2,1):mB(2,2),1,2)+&
01417                        correction(i,mT(2,1):mT(2,2),1,1)*&
01418                        ri*rl
01419 
01420                END WHERE
01421             END DO
01422          END IF!icyl
01423          DEALLOCATE(correction) 
01424 
01425       CASE(3) !nDim
01426 
01427          ! sourceauxchildmask(:,:,:,:,1) is a flag for neighbor's
01428          !  emfs being refined or no
01429          ALLOCATE(correction(mT(1,1):mT(1,2),mT(2,1):mT(2,2),mT(3,1):mT(3,2),1))
01430 
01431          dim=modulo(dir-2,3)+1
01432          inorm=6-dim-dir               !direction normal to edge
01433          ! and emf
01434 
01435          mA=mT
01436          mB=mT
01437          mA(dim  ,:)=mT(dim  ,:)-1      !Shift for updating
01438          ! aux(inorm)
01439          mB(inorm,:)=mT(inorm,:)-1      !Shift for updating
01440          ! aux(dim)
01441 
01442          !if have childemf - do nothing
01443          !else if neighbors have child - apply correction and
01444          ! store emf and update childemf
01445          !else calc correction and update emf...
01446 
01447          WHERE(ABS(  Info%emf(mT(1,1):mT(1,2),mT(2,1):mT(2,2),mT(3,1):mT(3,2),dir)) > &
01448               ABS(Source%emf(mS(1,1):mS(1,2),mS(2,1):mS(2,2),mS(3,1):mS(3,2),dir)))
01449 
01450             correction(mT(1,1):mT(1,2),mT(2,1):mT(2,2),mT(3,1):mT(3,2),1) = &
01451                  Source%emf(mS(1,1):mS(1,2),mS(2,1):mS(2,2),mS(3,1):mS(3,2),dir) - &
01452                  Info%emf(mT(1,1):mT(1,2),mT(2,1):mT(2,2),mT(3,1):mT(3,2),dir)
01453 
01454             Info%emf(mT(1,1):mT(1,2),mT(2,1):mT(2,2),mT(3,1):mT(3,2),dir) = &
01455                  Source%emf(mS(1,1):mS(1,2),mS(2,1):mS(2,2),mS(3,1):mS(3,2),dir)
01456 
01457             ! And apply correction
01458             Info%aux(mT(1,1):mT(1,2),mT(2,1):mT(2,2),mT(3,1):mT(3,2),inorm) = &
01459                  Info%aux(mT(1,1):mT(1,2),mT(2,1):mT(2,2),mT(3,1):mT(3,2),inorm) + &
01460                  correction(mT(1,1):mT(1,2),mT(2,1):mT(2,2),mT(3,1):mT(3,2),1)
01461 
01462             Info%aux(mA(1,1):mA(1,2),mA(2,1):mA(2,2),mA(3,1):mA(3,2),inorm) = &
01463                  Info%aux(mA(1,1):mA(1,2),mA(2,1):mA(2,2),mA(3,1):mA(3,2),inorm) - &
01464                  correction(mT(1,1):mT(1,2),mT(2,1):mT(2,2),mT(3,1):mT(3,2),1)
01465 
01466             Info%aux(mT(1,1):mT(1,2),mT(2,1):mT(2,2),mT(3,1):mT(3,2),dim) = &
01467                  Info%aux(mT(1,1):mT(1,2),mT(2,1):mT(2,2),mT(3,1):mT(3,2),dim) - &
01468                  correction(mT(1,1):mT(1,2),mT(2,1):mT(2,2),mT(3,1):mT(3,2),1)
01469 
01470             Info%aux(mB(1,1):mB(1,2),mB(2,1):mB(2,2),mB(3,1):mB(3,2),dim) = &
01471                  Info%aux(mB(1,1):mB(1,2),mB(2,1):mB(2,2),mB(3,1):mB(3,2),dim) + &
01472                  correction(mT(1,1):mT(1,2),mT(2,1):mT(2,2),mT(3,1):mT(3,2),1)
01473 
01474 
01475          END WHERE
01476          DEALLOCATE(correction)
01477       END SELECT
01478 
01479    END SUBROUTINE SyncMaxLevelEMF
01480 
01481 
01483 
01486 
01489    SUBROUTINE ProlongationFixup(Info)
01490       !Should only be called after last overlap of first round of overlaps
01491       TYPE(InfoDef) :: Info
01492       REAL(KIND=qprec), DIMENSION(:,:,:,:), POINTER :: aux
01493       INTEGER :: i,j,k,rmbc
01494       INTEGER,DIMENSION(3,2) :: mb
01495       REAL(KIND=qPREC), DIMENSION(12) :: temp
01496 
01497       ! These 2D and 3D matrices come from solving the divergence equation.  For a derivation
01498       ! of this, see Cunningham '09.  If it's not there, e-mail us and yell at us.
01499 
01500       REAL(KIND=qprec), PARAMETER, DIMENSION(4,8) :: A2D = 
01501            0.25d0*RESHAPE((/ 
01502            2.d0, 0.d0, 1.d0, 1.d0,  
01503            0.d0, 2.d0, -1.d0, -1.d0, 
01504            2.d0, 0.d0, -1.d0, -1.d0, 
01505            0.d0, 2.d0, 1.d0, 1.d0, 
01506            1.d0, 1.d0, 2.d0, 0.d0, 
01507            -1.d0, -1.d0, 2.d0, 0.d0, 
01508            -1.d0, -1.d0, 0.d0, 2.d0, 
01509            1.d0, 1.d0, 0.d0, 2.d0 
01510            /),(/4,8/) )
01511 
01512       REAL(KIND=qprec), PARAMETER, DIMENSION(12,24) :: A3D = 
01513            0.0625d0*RESHAPE((/ 
01514            8.d0, 0.d0, 0.d0, 0.d0, 3.d0, 1.d0, 3.d0, 1.d0, 3.d0, 1.d0, 3.d0, 1.d0, 
01515            0.d0, 8.d0, 0.d0, 0.d0, 1.d0, 3.d0, 1.d0, 3.d0, -3.d0, -1.d0, -3.d0, -1.d0, 
01516            0.d0, 0.d0, 8.d0, 0.d0, -3.d0, -1.d0, -3.d0, -1.d0, 1.d0, 3.d0, 1.d0, 3.d0, 
01517            0.d0, 0.d0, 0.d0, 8.d0, -1.d0, -3.d0, -1.d0, -3.d0, -1.d0, -3.d0, -1.d0, -3.d0, 
01518            8.d0, 0.d0, 0.d0, 0.d0, -3.d0, -1.d0, -3.d0, -1.d0, -3.d0, -1.d0, -3.d0, -1.d0, 
01519            0.d0, 8.d0, 0.d0, 0.d0, -1.d0, -3.d0, -1.d0, -3.d0, 3.d0, 1.d0, 3.d0, 1.d0, 
01520            0.d0, 0.d0, 8.d0, 0.d0, 3.d0, 1.d0, 3.d0, 1.d0, -1.d0, -3.d0, -1.d0, -3.d0, 
01521            0.d0, 0.d0, 0.d0, 8.d0, 1.d0, 3.d0, 1.d0, 3.d0, 1.d0, 3.d0, 1.d0, 3.d0, 
01522            3.d0, 1.d0, 3.d0, 1.d0, 8.d0, 0.d0, 0.d0, 0.d0, 3.d0, 3.d0, 1.d0, 1.d0, 
01523            1.d0, 3.d0, 1.d0, 3.d0, 0.d0, 8.d0, 0.d0, 0.d0, -3.d0, -3.d0, -1.d0, -1.d0, 
01524            -3.d0, -1.d0, -3.d0, -1.d0, 8.d0, 0.d0, 0.d0, 0.d0, -3.d0, -3.d0, -1.d0, -1.d0, 
01525            -1.d0, -3.d0, -1.d0, -3.d0, 0.d0, 8.d0, 0.d0, 0.d0, 3.d0, 3.d0, 1.d0, 1.d0, 
01526            -3.d0, -1.d0, -3.d0, -1.d0, 0.d0, 0.d0, 8.d0, 0.d0, 1.d0, 1.d0, 3.d0, 3.d0, 
01527            -1.d0, -3.d0, -1.d0, -3.d0, 0.d0, 0.d0, 0.d0, 8.d0, -1.d0, -1.d0, -3.d0, -3.d0, 
01528            3.d0, 1.d0, 3.d0, 1.d0, 0.d0, 0.d0, 8.d0, 0.d0, -1.d0, -1.d0, -3.d0, -3.d0, 
01529            1.d0, 3.d0, 1.d0, 3.d0, 0.d0, 0.d0, 0.d0, 8.d0, 1.d0, 1.d0, 3.d0, 3.d0, 
01530            3.d0, 3.d0, 1.d0, 1.d0, 3.d0, 3.d0, 1.d0, 1.d0, 8.d0, 0.d0, 0.d0, 0.d0, 
01531            -3.d0, -3.d0, -1.d0, -1.d0, -3.d0, -3.d0, -1.d0, -1.d0, 8.d0, 0.d0, 0.d0, 0.d0, 
01532            1.d0, 1.d0, 3.d0, 3.d0, -3.d0, -3.d0, -1.d0, -1.d0, 0.d0, 8.d0, 0.d0, 0.d0, 
01533            -1.d0, -1.d0, -3.d0, -3.d0, 3.d0, 3.d0, 1.d0, 1.d0, 0.d0, 8.d0, 0.d0, 0.d0, 
01534            -3.d0, -3.d0, -1.d0, -1.d0, 1.d0, 1.d0, 3.d0, 3.d0, 0.d0, 0.d0, 8.d0, 0.d0, 
01535            3.d0, 3.d0, 1.d0, 1.d0, -1.d0, -1.d0, -3.d0, -3.d0, 0.d0, 0.d0, 8.d0, 0.d0, 
01536            -1.d0, -1.d0, -3.d0, -3.d0, -1.d0, -1.d0, -3.d0, -3.d0, 0.d0, 0.d0, 0.d0, 8.d0, 
01537            1.d0, 1.d0, 3.d0, 3.d0, 1.d0, 1.d0, 3.d0, 3.d0, 0.d0, 0.d0, 0.d0, 8.d0 
01538            /),(/12,24/) )
01539 
01540       aux=>Info%aux
01541       rmbc=levels(Info%level-1)%pmbc*levels(Info%level-1)%CoarsenRatio
01542       mb=1
01543       mb(1:nDim,1)=1-rmbc
01544       mb(1:nDim,2)=Info%mx(1:nDim)+rmbc
01545 
01546       IF (nDim == 2) THEN
01547          DO i=mb(1,1),mb(1,2),2
01548             DO j=mb(2,1),mb(2,2),2
01549                IF (aux(i+1,j,1,1)==UNDEFINED) THEN !Assume all
01550                   temp(1:4)=MATMUL(A2D, &            
01551                        (/aux(i  ,j  ,1,1),     &
01552                        aux(i  ,j+1,1,1),   &
01553                        aux(i+2,j  ,1,1),   &
01554                        aux(i+2,j+1,1,1), &
01555                        aux(i  ,j  ,1,2),     &
01556                        aux(i  ,j+2,1,2),   &
01557                        aux(i+1,j  ,1,2),   &
01558                        aux(i+1,j+2,1,2) /))
01559                   aux(i+1,j  ,1,1)=temp(1)
01560                   aux(i+1,j+1,1,1)=temp(2)
01561                   aux(i  ,j+1,1,2)=temp(3)
01562                   aux(i+1,j+1,1,2)=temp(4)
01563                END IF
01564             END DO
01565          END DO
01566 
01567       ELSE
01568          DO i=mb(1,1),mb(1,2),2
01569             DO j=mb(2,1),mb(2,2),2
01570                DO k=mb(3,1),mb(3,2),2
01571                   IF (aux(i+1,j,k,1) == UNDEFINED) THEN !Assume
01572                      temp = MATMUL(A3D, &
01573                           (/aux(i  ,j  ,k  ,1),&
01574                           aux(i  ,j  ,k+1,1),&
01575                           aux(i  ,j+1,k  ,1),&
01576                           aux(i  ,j+1,k+1,1),&
01577                           aux(i+2,j  ,k  ,1),&
01578                           aux(i+2,j  ,k+1,1),&
01579                           aux(i+2,j+1,k  ,1),&
01580                           aux(i+2,j+1,k+1,1),&
01581                           aux(i  ,j  ,k  ,2),&
01582                           aux(i  ,j  ,k+1,2),&
01583                           aux(i  ,j+2,k  ,2),&
01584                           aux(i  ,j+2,k+1,2),&
01585                           aux(i+1,j  ,k  ,2),&
01586                           aux(i+1,j  ,k+1,2),&
01587                           aux(i+1,j+2,k  ,2),&
01588                           aux(i+1,j+2,k+1,2),&
01589                           aux(i  ,j  ,k  ,3),&
01590                           aux(i  ,j  ,k+2,3),&
01591                           aux(i  ,j+1,k  ,3),&
01592                           aux(i  ,j+1,k+2,3),&
01593                           aux(i+1,j  ,k  ,3),&
01594                           aux(i+1,j  ,k+2,3),&
01595                           aux(i+1,j+1,k  ,3),&
01596                           aux(i+1,j+1,k+2,3)/))
01597                      aux(i+1,j  ,k  ,1) = temp(1)
01598                      aux(i+1,j  ,k+1,1) = temp(2)
01599                      aux(i+1,j+1,k  ,1) = temp(3)
01600                      aux(i+1,j+1,k+1,1) = temp(4)
01601                      aux(i  ,j+1,k  ,2) = temp(5)
01602                      aux(i  ,j+1,k+1,2) = temp(6)
01603                      aux(i+1,j+1,k  ,2) = temp(7)
01604                      aux(i+1,j+1,k+1,2) = temp(8)
01605                      aux(i  ,j  ,k+1,3) = temp(9)
01606                      aux(i  ,j+1,k+1,3) = temp(10)
01607                      aux(i+1,j  ,k+1,3) = temp(11)
01608                      aux(i+1,j+1,k+1,3) = temp(12)
01609                   END IF
01610                END DO
01611             END DO
01612          END DO
01613       END IF
01614       CALL UpdateAux(Info,mb)
01615    END SUBROUTINE ProlongationFixup
01616 
01617 
01621    SUBROUTINE CoarsenDataForParent(Info,n)
01622       TYPE(InfoDef) :: Info
01623       INTEGER :: n
01624       !    CALL CoarsenCostMapForParent(Info)      
01625       IF (n > 0) THEN
01626          CALL CoarsenQForParent(Info)
01627          CALL CoarsenFluxesForParent(Info)
01628       END IF
01629    END SUBROUTINE CoarsenDataForParent
01630 
01634    SUBROUTINE CoarsenInitialDataForParent(Info,n)
01635       TYPE(InfoDef) :: Info
01636       INTEGER :: n
01637       !    CALL CoarsenCostMapForParent(Info)
01638       IF (n > 0) THEN
01639          CALL CoarsenQForParent(Info)
01640          IF (MaintainAuxArrays) CALL CoarsenAuxForParent(Info)
01641       END IF
01642    END SUBROUTINE CoarsenInitialDataForParent
01643 
01646    SUBROUTINE CoarsenCostMapForParent(Info)
01647       TYPE(InfoDef) :: Info
01648       INTEGER, DIMENSION(3,2) :: mB
01649       INTEGER i,j,l(3),n,r
01650       INTEGER,DIMENSION(3,2) :: ic,ip
01651       REAL(KIND=qPrec) :: factor,factor_aux,factor_emf,factor_flux
01652       INTEGER :: ermbc
01653       REAL :: grid_size_factor
01654 
01655       ! Bounds within parent    
01656       mB=Info%mBounds
01657       r=levels(Info%level-1)%CoarsenRatio
01658       ic(ndim+1:3,:)=1
01659       Info%ParentCostMap(mB(1,1):mB(1,2),mB(2,1):mB(2,2),mB(3,1):mB(3,2),1) = 0d0
01660       l=0
01661 
01662       ! hyperbolic_mbc has r layers of ghost zones on the first step, r-1 on the second step, etc.
01663       ! So ermbc will be r(r+1)/2 times hyperbolic_mbc (because sum(1:r) = r(r+1)/2).  Multiply the
01664       ! result by 2, since ghost cells appear on both sides of an edge.  Since this
01665       ! is being done in the parent's frame of reference, though, ermbc will be divided by r.
01666 
01667       ! average_mbc = 2 * (hyperbolic_mbc * sum(1:r)/r) = 2 * hyperbolic_mbc * r(r+1)/2r = (r+1) * hyperbolic_mbc
01668       !    ermbc = (r+1) * hyperbolic_mbc
01669       ermbc=0
01670 
01671       ! The grid size factor is the number of cells in the extended grid (core grid + ghost zones)
01672       ! divided by the number of cells in the core grid (no ghost zones).
01673       grid_size_factor = PRODUCT(mB(1:nDim,2)-mB(1:nDim,1) + 1 + ermbc) * 1.0 / &
01674            PRODUCT(mB(1:nDim,2)-mB(1:nDim,1) + 1)
01675 
01676       DO i=0,r**nDim-1  ! i loops over all child subcells
01677 
01678          DO n=1,nDim
01679             l(n)=MOD(i/r**(n-1),r)
01680          END DO
01681 
01682          ic(1:nDim,1)=1 + l(1:nDim)
01683          ic(1:nDim,2)=Info%mX(1:nDim) - r + l(1:nDim) + 1
01684 
01685          Info%ParentCostMap(mB(1,1):mB(1,2)  ,mB(2,1):mB(2,2)  ,mB(3,1):mB(3,2)  ,1) =       &
01686               Info%ParentCostMap(mB(1,1):mB(1,2)  ,mB(2,1):mB(2,2)  ,mB(3,1):mB(3,2)  ,1) +  &
01687               Info%CostMap(ic(1,1):ic(1,2):r,ic(2,1):ic(2,2):r,ic(3,1):ic(3,2):r,1) + &
01688               Info%CostMap(ic(1,1):ic(1,2):r, ic(2,1):ic(2,2):r, ic(3,1):ic(3,2):r,2)
01689 
01690       END DO
01691       IF (Info%level > -1) Info%ParentCostmap(mB(1,1):mB(1,2)  ,mB(2,1):mB(2,2)  ,mB(3,1):mB(3,2)  ,1)=&
01692            Info%ParentCostmap(mB(1,1):mB(1,2)  ,mB(2,1):mB(2,2)  ,mB(3,1):mB(3,2)  ,1)*REAL(r) !+&
01693       !         sum(Info%CostPerGrid(:))./product(mB(1:nDim,2)-mB(1:nDim,1)+1) 
01694 
01695    END SUBROUTINE CoarsenCostMapForParent
01696 
01699    SUBROUTINE CoarsenQForParent(Info)
01700       TYPE(InfoDef) :: Info
01701       INTEGER i,l(3),n,r
01702       INTEGER,DIMENSION(3,2) :: ic,mB
01703       REAL(KIND=qPrec) :: factor
01704 
01705       ! Bounds within parent    
01706       mB=Info%mBounds
01707       r=levels(Info%level-1)%CoarsenRatio
01708       factor = 1d0/r**nDim
01709       ic(ndim+1:3,:)=1
01710       Info%qParent(mB(1,1):mB(1,2),mB(2,1):mB(2,2),mB(3,1):mB(3,2),:) = 0d0
01711       l=0
01712       DO i=0,r**nDim-1  ! i loops over all child subcells
01713          DO n=1,nDim
01714             l(n)=MOD(i/r**(n-1),r)
01715          END DO
01716          ic(1:nDim,1)=1 + l(1:nDim)
01717          ic(1:nDim,2)=Info%mX(1:nDim) - r + l(1:nDim) + 1
01718          Info%qParent(mB(1,1):mB(1,2)  ,mB(2,1):mB(2,2)  ,mB(3,1):mB(3,2)  ,:) =       &
01719               Info%qParent(mB(1,1):mB(1,2)  ,mB(2,1):mB(2,2)  ,mB(3,1):mB(3,2)  ,:) +  &
01720               Info%q(ic(1,1):ic(1,2):r,ic(2,1):ic(2,2):r,ic(3,1):ic(3,2):r,RestrictFields)
01721       END DO
01722       Info%qParent(mB(1,1):mB(1,2)  ,mB(2,1):mB(2,2)  ,mB(3,1):mB(3,2)  ,:) =       &
01723            Info%qParent(mB(1,1):mB(1,2)  ,mB(2,1):mB(2,2)  ,mB(3,1):mB(3,2)  ,:) * factor
01724    END SUBROUTINE CoarsenQForParent
01725 
01728    SUBROUTINE CoarsenFluxesForParent(Info)
01729       TYPE(InfoDef) :: Info
01730       INTEGER i,r
01731       INTEGER,DIMENSION(3,2) :: ic,ip,mB
01732       REAL(KIND=qPrec) :: factor_emf,factor_flux
01733 
01734       ! Bounds within parent    
01735       mB=Info%mBounds
01736       r=levels(Info%level-1)%CoarsenRatio
01737       ! Calculate the restriction factors.
01738       factor_emf = 1d0/r**(nDim-1) !(nDim-2) spatial plus time
01739       factor_flux = 1d0/r**(nDim)    !(nDim-1) spatial plus time
01740       ip(nDim+1:3,:)=1
01741       DO i=1,nDim
01742          Info%parentfixup%side(i)%data=Info%parentfixup%side(i)%data*factor_flux
01743       END DO
01744       IF (MaintainAuxArrays) THEN
01745          IF (nDim == 2) THEN
01746             ip(1:nDim,1)=mB(1:nDim,1); ip(1:nDim,2)=mB(1:nDim,2)+1;   
01747             Info%parentemf(ip(1,1):ip(1,2)  ,ip(2,1):ip(2,2)  ,ip(3,1):ip(3,2)  ,1) = &
01748                  Info%parentemf(ip(1,1):ip(1,2)  ,ip(2,1):ip(2,2)  ,ip(3,1):ip(3,2)  ,1) * factor_emf
01749          ELSE
01750             ip(1:nDim,1)=mB(1:nDim,1); ip(1:nDim,2)=mB(1:nDim,2)+1;   
01751             DO i=1,nDim
01752                ip(i,2)=ip(i,2)-1 
01753                Info%parentemf(ip(1,1):ip(1,2)  ,ip(2,1):ip(2,2)  ,ip(3,1):ip(3,2)  ,i) = &
01754                     Info%parentemf(ip(1,1):ip(1,2)  ,ip(2,1):ip(2,2)  ,ip(3,1):ip(3,2)  ,i) * factor_emf
01755                ip(i,2)=ip(i,2)+1
01756             END DO
01757          END IF
01758       END IF
01759    END SUBROUTINE CoarsenFluxesForParent
01760 
01763    SUBROUTINE CoarsenAuxForParent(Info)
01764       TYPE(InfoDef) :: Info
01765       INTEGER i,j,k,r,l(3)
01766       INTEGER,DIMENSION(3,2) :: ic,ip,mB
01767       REAL(KIND=qPrec) :: factor,factor_aux
01768 
01769       ! Bounds within parent    
01770       mB=Info%mBounds
01771       r=levels(Info%level-1)%CoarsenRatio
01772       ! Calculate the restriction factors.
01773       factor_aux=1d0/r**(nDim-1)    !(nDim-1) spatial-1
01774       ic(ndim+1:3,:)=1
01775       ip(ndim+1:3,:)=1
01776 
01777       Info%auxParent=0
01778       l=0;
01779       DO i=1,nDim !B-field direction
01780          ip(1:nDim,1) = mB(1:nDim,1)
01781          ip(1:nDim,2) = mB(1:nDim,2)            
01782          ip(i,2)=ip(i,2)+1
01783          Info%auxParent(ip(1,1):ip(1,2), ip(2,1):ip(2,2), ip(3,1):ip(3,2), i)=0
01784          DO j=0,r**nDim-1
01785             DO k=1,nDim
01786                l(k)=MOD(j/r**(k-1),r)  
01787             END DO
01788             IF (l(i)==1) CYCLE
01789             ic(1:nDim,1)=1 + l(1:nDim)
01790             ic(1:nDim,2)=Info%mX(1:nDim) - r + l(1:nDim) + 1
01791             ic(i,:)=(/1,Info%mX(i)+1/)
01792             Info%auxParent(ip(1,1):ip(1,2), ip(2,1):ip(2,2), ip(3,1):ip(3,2), i) = &
01793                  Info%auxParent(ip(1,1):ip(1,2), ip(2,1):ip(2,2), ip(3,1):ip(3,2), i) + &
01794                  Info%aux(ic(1,1):ic(1,2):r,ic(2,1):ic(2,2):r,ic(3,1):ic(3,2):r,i)
01795          END DO
01796          Info%auxParent(ip(1,1):ip(1,2), ip(2,1):ip(2,2), ip(3,1):ip(3,2), i) = &
01797               Info%auxParent(ip(1,1):ip(1,2), ip(2,1):ip(2,2), ip(3,1):ip(3,2), i)*factor_aux
01798       END DO
01799    END SUBROUTINE CoarsenAuxForParent
01800 
01803    SUBROUTINE AccumulateFlux(Info)
01804       TYPE(InfoDef) :: Info
01805       INTEGER, DIMENSION(3,2) :: ip, ic, mb
01806       INTEGER :: i,j,l(3),r,edge,n    
01807       mb=Info%mBounds
01808       r=levels(Info%level-1)%CoarsenRatio      
01809 
01810       ic=1
01811       ic(1:nDim,2)=Info%mX(1:nDim)
01812 
01813       !PRINT *, "AccumulateFlux::level = ", Info%level
01814       !PRINT *, "ASSOCIATED(Info%parentfixup) = ", ASSOCIATED(Info%parentfixup)
01815       !PRINT *, "ASSOCIATED(Info%parentfixup%side) = ", ASSOCIATED(Info%parentfixup%side)
01816 
01817       DO i=1,nDim
01818          DO edge=1,2
01819             DO j=0,r**nDim-1
01820                IF (MOD(j/r**(i-1),r)==1) CYCLE
01821                DO n=1,nDim
01822                   l(n)=MOD(j/r**(n-1),r)  
01823                END DO
01824                ic(1:nDim,1)=1+l(1:nDim); ic(1:nDim,2)=Info%mX(1:nDim)-r+1+l(1:nDim);ic(i,:)=edge
01825                ip=mb; ip(i,:)=edge
01826                !PRINT *, "ASSOCIATED(Info%parentfixup%side(", i, ")%data) = ", ASSOCIATED(Info%parentfixup%side(i)%data)
01827                Info%parentfixup%side(i)%data(ip(1,1):ip(1,2)  ,ip(2,1):ip(2,2)  ,ip(3,1):ip(3,2)  ,:) = &
01828                     Info%parentfixup%side(i)%data(ip(1,1):ip(1,2)  ,ip(2,1):ip(2,2)  ,ip(3,1):ip(3,2)  ,:) + &
01829                     Info%fixupflux%side(i)%data(ic(1,1):ic(1,2):r,ic(2,1):ic(2,2):r,ic(3,1):ic(3,2):r,:)
01830             END DO
01831          END DO
01832       END DO
01833       IF (MaintainAuxArrays) THEN
01834          IF (nDim == 2) THEN
01835             ip(1:nDim,1)=mb(1:nDim,1)
01836             ip(1:nDim,2)=mb(1:nDim,2)+1
01837             ic(1:nDim,1)=1
01838             ic(1:nDim,2)=Info%mX(1:nDim)+1
01839             Info%parentemf(ip(1,1):ip(1,2)  ,ip(2,1):ip(2,2)  ,1,1) = &
01840                  Info%parentemf(ip(1,1):ip(1,2)  ,ip(2,1):ip(2,2)  ,1,1) + &
01841                  Info%emf(ic(1,1):ic(1,2):2,ic(2,1):ic(2,2):2,1,1)
01842          ELSE
01843             DO i=1,3
01844                ip(1:nDim,1)=mb(1:nDim,1)
01845                ip(1:nDim,2)=mb(1:nDim,2)+1
01846                ip(i,2)=ip(i,2)-1
01847                ic(1:nDim,2)=Info%mX(1:nDim)+1
01848                ic(1:nDim,1)=1
01849                DO j=0,1
01850                   ic(i,1)=1+j
01851                   ic(i,2)=Info%mX(i)-1+j
01852                   Info%parentemf(ip(1,1):ip(1,2)  ,ip(2,1):ip(2,2)  ,ip(3,1):ip(3,2)  ,i) = &
01853                        Info%parentemf(ip(1,1):ip(1,2)  ,ip(2,1):ip(2,2)  ,ip(3,1):ip(3,2)  ,i) + &
01854                        Info%emf(ic(1,1):ic(1,2):2,ic(2,1):ic(2,2):2,ic(3,1):ic(3,2):2,i)
01855                END DO
01856             END DO
01857          END IF
01858       END IF
01859    END SUBROUTINE AccumulateFlux
01860 
01863    SUBROUTINE RestrictionFixup(Info)
01864       TYPE(InfoDef) :: Info
01865       INTEGER, DIMENSION(3,2):: ip,mB,ia,ib
01866       REAL(KIND=qPREC), DIMENSION(:,:,:), ALLOCATABLE :: correction
01867       INTEGER :: i,l(3),level
01868       REAL(KIND=qPREC) :: dx,rl,rh,ri
01869       level=Info%level
01870       dx=levels(level)%dx
01871 
01872       mB=1
01873       mB(:,2)=Info%mx
01874       ip=mB
01875       IF (Info%level < MaxLevel) THEN
01876          SELECT CASE (nDim)
01877          CASE(2)
01878             ip(1:nDim,2)=mB(1:nDim,2)+1          
01879             ALLOCATE(correction(ip(1,1):ip(1,2), ip(2,1):ip(2,2),1))
01880             IF (iCylindrical==NoCyl) THEN     
01881                WHERE (Info%childemf(ip(1,1):ip(1,2),ip(2,1):ip(2,2),1,1) /= undefined)
01882                   correction(ip(1,1):ip(1,2),ip(2,1):ip(2,2),1) = &
01883                        Info%childemf(ip(1,1):ip(1,2),ip(2,1):ip(2,2),1,1)- &
01884                        Info%emf(ip(1,1):ip(1,2),ip(2,1):ip(2,2),1,1)
01885 
01886                   Info%aux(ip(1,1)  :ip(1,2)  ,ip(2,1)  :ip(2,2)  ,1,1)= &
01887                        Info%aux(ip(1,1)  :ip(1,2)  ,ip(2,1)  :ip(2,2)  ,1,1)+ &
01888                        correction(ip(1,1)  :ip(1,2)  ,ip(2,1)  :ip(2,2)  ,1  )
01889 
01890                   Info%aux(ip(1,1)  :ip(1,2)  ,ip(2,1)-1:ip(2,2)-1,1,1)= &
01891                        Info%aux(ip(1,1)  :ip(1,2)  ,ip(2,1)-1:ip(2,2)-1,1,1)- &
01892                        correction(ip(1,1)  :ip(1,2)  ,ip(2,1)  :ip(2,2)  ,1  )
01893 
01894                   Info%aux(ip(1,1)  :ip(1,2)  ,ip(2,1)  :ip(2,2)  ,1,2)= &
01895                        Info%aux(ip(1,1)  :ip(1,2)  ,ip(2,1)  :ip(2,2)  ,1,2)- &
01896                        correction(ip(1,1)  :ip(1,2)  ,ip(2,1)  :ip(2,2)  ,1  )
01897 
01898                   Info%aux(ip(1,1)-1:ip(1,2)-1,ip(2,1)  :ip(2,2)  ,1,2)= &
01899                        Info%aux(ip(1,1)-1:ip(1,2)-1,ip(2,1)  :ip(2,2)  ,1,2)+ &
01900                        correction(ip(1,1)  :ip(1,2)  ,ip(2,1)  :ip(2,2)  ,1  )
01901 
01902                   Info%emf(ip(1,1):ip(1,2),ip(2,1):ip(2,2),1,1)= &
01903                        Info%childemf(ip(1,1):ip(1,2),ip(2,1):ip(2,2),1,1)
01904                END WHERE
01905             ELSE
01906                DO i=ip(1,1),ip(1,2) 
01907                   ri=(Info%xBounds(1,1)+(i-1)*dx)
01908                   rl=1.d0/(Info%xBounds(1,1)+(REAL(i)-half)*dx)
01909                   rh=1.d0/(Info%xBounds(1,1)+(REAL(i)+half)*dx)
01910                   WHERE (Info%childemf(i,ip(2,1):ip(2,2),1,1) /= undefined)
01911                      correction(i,ip(2,1):ip(2,2),1) = &
01912                           Info%childemf(i,ip(2,1):ip(2,2),1,1)- &
01913                           Info%emf(i,ip(2,1):ip(2,2),1,1)
01914 
01915                      Info%aux(i,ip(2,1)  :ip(2,2)  ,1,1)= &
01916                           Info%aux(i,ip(2,1)  :ip(2,2)  ,1,1)+ &
01917                           correction(i,ip(2,1)  :ip(2,2)  ,1  )
01918 
01919                      Info%aux(i  ,ip(2,1)-1:ip(2,2)-1,1,1)= &
01920                           Info%aux(i  ,ip(2,1)-1:ip(2,2)-1,1,1)- &
01921                           correction(i  ,ip(2,1)  :ip(2,2)  ,1  )
01922 
01923                      Info%aux(i  ,ip(2,1)  :ip(2,2)  ,1,2)= &
01924                           Info%aux(i  ,ip(2,1)  :ip(2,2)  ,1,2)- &
01925                           correction(i  ,ip(2,1)  :ip(2,2)  ,1  )*&
01926                           rh*ri
01927 
01928                      Info%aux(i-1,ip(2,1)  :ip(2,2)  ,1,2)= &
01929                           Info%aux(i-1,ip(2,1)  :ip(2,2)  ,1,2)+ &
01930                           correction(i  ,ip(2,1)  :ip(2,2)  ,1  )*&
01931                           rl*ri
01932 
01933                      Info%emf(i,ip(2,1):ip(2,2),1,1)= &
01934                           Info%childemf(i,ip(2,1):ip(2,2),1,1)
01935                   END WHERE
01936                END DO
01937             END IF!icyl
01938             DEALLOCATE(correction)
01939          CASE(3)
01940             DO i=1,3
01941                ip(1:nDim,2)=mB(1:nDim,2)+1          
01942                ip(i,2)=ip(i,2)-1
01943                l(2:3)=modulo((/i,i+1/),3)+1
01944                ia=ip
01945                ib=ip
01946                ia(l(3),:)=ip(l(3),:)-1
01947                ib(l(2),:)=ip(l(2),:)-1
01948                ALLOCATE(correction(ip(1,1):ip(1,2), ip(2,1):ip(2,2),ip(3,1):ip(3,2)))
01949                WHERE (Info%childemf(ip(1,1):ip(1,2),ip(2,1):ip(2,2),ip(3,1):ip(3,2),i) /= undefined)
01950                   correction(ip(1,1):ip(1,2),ip(2,1):ip(2,2),ip(3,1):ip(3,2)) = &
01951                        Info%childemf(ip(1,1):ip(1,2),ip(2,1):ip(2,2),ip(3,1):ip(3,2),i)- &
01952                        Info%emf(ip(1,1):ip(1,2),ip(2,1):ip(2,2),ip(3,1):ip(3,2),i)
01953 
01954                   Info%aux(ip(1,1):ip(1,2),ip(2,1):ip(2,2),ip(3,1):ip(3,2),l(2))= &
01955                        Info%aux(ip(1,1):ip(1,2),ip(2,1):ip(2,2),ip(3,1):ip(3,2),l(2))+ &
01956                        correction(ip(1,1):ip(1,2),ip(2,1):ip(2,2),ip(3,1):ip(3,2))
01957 
01958                   Info%aux(ia(1,1):ia(1,2),ia(2,1):ia(2,2),ia(3,1):ia(3,2),l(2))= &
01959                        Info%aux(ia(1,1):ia(1,2),ia(2,1):ia(2,2),ia(3,1):ia(3,2),l(2))- &
01960                        correction(ip(1,1):ip(1,2),ip(2,1):ip(2,2),ip(3,1):ip(3,2))
01961 
01962                   Info%aux(ip(1,1):ip(1,2),ip(2,1):ip(2,2),ip(3,1):ip(3,2),l(3))= &
01963                        Info%aux(ip(1,1):ip(1,2),ip(2,1):ip(2,2),ip(3,1):ip(3,2),l(3))- &
01964                        correction(ip(1,1):ip(1,2),ip(2,1):ip(2,2),ip(3,1):ip(3,2))
01965 
01966                   Info%aux(ib(1,1):ib(1,2),ib(2,1):ib(2,2),ib(3,1):ib(3,2),l(3))= &
01967                        Info%aux(ib(1,1):ib(1,2),ib(2,1):ib(2,2),ib(3,1):ib(3,2),l(3))+ &
01968                        correction(ip(1,1):ip(1,2),ip(2,1):ip(2,2),ip(3,1):ip(3,2))
01969 
01970                   Info%emf(ip(1,1):ip(1,2),ip(2,1):ip(2,2),ip(3,1):ip(3,2),i)= &
01971                        Info%childemf(ip(1,1):ip(1,2),ip(2,1):ip(2,2),ip(3,1):ip(3,2),i)
01972                END WHERE
01973                DEALLOCATE(correction)
01974             END DO
01975          END SELECT
01976       END IF
01977       CALL UpdateAux(Info, mB)
01978    END SUBROUTINE RestrictionFixup
01979 
01982    SUBROUTINE UpdateTimeDeriv(Info)
01983       TYPE(InfoDef) :: Info
01984       INTEGER :: i, j
01985       DO i=1, nProlongate
01986          DO j=1, TDVars
01987             IF (ProlongateFields(i) == TimeDerivFields(j)) THEN
01988                Info%qchild(:,:,:,i)=Info%q(:,:,:,TimeDerivFields(j))
01989             END IF
01990          END DO
01991       END DO
01992    END SUBROUTINE UpdateTimeDeriv
01993 
01994 
01995    SUBROUTINE ClearFixupFlux(Info)
01996       TYPE(InfoDef) :: Info
01997       INTEGER :: i
01998       DO i=1,nDim
01999          Info%fixupflux%side(i)%data=0
02000       END DO
02001       IF (MaintainAuxArrays) Info%emf=0
02002       IF (lStoreMassFlux) Info%MassFlux=0
02003    END SUBROUTINE ClearFixupFlux
02004 
02005 
02006    SUBROUTINE ClearParentFixup(Info)
02007       TYPE(InfoDef) :: Info
02008       INTEGER :: i
02009       DO i=1,nDim
02010          Info%parentfixup%side(i)%data=0d0
02011       END DO
02012       IF (MaintainAuxArrays) Info%parentemf=0d0
02013    END SUBROUTINE ClearParentFixup
02014 
02015    SUBROUTINE ClearChildFixup(Info)
02016       TYPE(InfoDef) :: Info
02017       INTEGER :: i,j
02018       IF (ASSOCIATED(Info%childfixups)) THEN
02019          DO j=1,size(Info%childfixups)
02020             DO i=1,nDim
02021                Info%childfixups(j)%p%side(i)%data=0d0
02022             END DO
02023          END DO
02024       END IF
02025       IF (MaintainAuxArrays) THEN
02026          IF (Associated(Info%childemf)) Info%childemf=undefined
02027          Info%AuxChild=Info%aux
02028       END IF
02029       Info%qChild=Info%q(:,:,:,ProlongateFields)
02030    END SUBROUTINE ClearChildFixup
02031 
02032 
02034    SUBROUTINE ChildMaskOverlap(Info,neighbormGlobal)
02035       TYPE(InfoDef) :: Info
02036       INTEGER, DIMENSION(3,2) :: mO,neighbormGlobal,mGlobal,ioffset
02037       INTEGER :: i,j,k,l
02038       ioffset=0
02039       WHERE(lAnyPeriodic(1:nDim)) ioffset(1:nDim,2)=1!nperiodic_overlaps(1:nDim)
02040       ioffset(1:nDim,1)=-ioffset(1:nDim,2)
02041       mO(nDim+1:3,:)=1
02042       DO i=ioffset(1,1),ioffset(1,2)
02043          DO j=ioffset(2,1),ioffset(2,2)
02044             DO k=ioffset(3,1),ioffset(3,2)
02045 
02046                mGlobal(:,:)=neighbormGlobal(:,:)+SPREAD((/i,j,k/)*levels(Info%level)%mX(:),2,2)
02047 
02048                mO(1:nDim,1)=max(Info%mGlobal(1:nDim,1)-1,mGlobal(1:nDim,1)) 
02049                mO(1:nDim,2)=min(Info%mGlobal(1:nDim,2)+1,mGlobal(1:nDim,2))
02050                IF (ALL(mO(1:nDim,1) <= mO(1:nDim,2))) THEN
02051                   mO(1:nDim,:)=mO(1:nDim,:)-Spread( Info%mGlobal(1:nDim,1),2,2)+1
02052                   Info%ChildMask(mO(1,1):mO(1,2), mO(2,1):mO(2,2), mO(3,1):mO(3,2))=0
02053                END IF
02054             END DO
02055          END DO
02056       END DO
02057    END SUBROUTINE ChildMaskOverlap
02058 
02059 
02061    SUBROUTINE UpdateChildMask(Info,neighborchildmGlobal)
02062       TYPE(InfoDef) :: Info
02063       INTEGER, DIMENSION(3,2) :: mO,neighbormGlobal,mGlobal,ioffset,neighborchildmGlobal
02064       INTEGER :: i,j,k,l
02065       ioffset=0
02066       WHERE(lAnyPeriodic(1:nDim)) ioffset(1:nDim,2)=1!nperiodic_overlaps(1:nDim)
02067       ioffset(1:nDim,1)=-ioffset(1:nDim,2)
02068       mO(nDim+1:3,:)=1
02069       neighbormGlobal(nDim+1:3,:)=1
02070       neighbormGlobal(1:nDim,2)=neighborchildmGlobal(1:nDim,2)/levels(Info%level)%CoarsenRatio
02071       neighbormGlobal(1:nDim,1)=(neighborchildmGlobal(1:nDim,1)-1)/levels(Info%level)%CoarsenRatio+1
02072       DO i=ioffset(1,1),ioffset(1,2)
02073          DO j=ioffset(2,1),ioffset(2,2)
02074             DO k=ioffset(3,1),ioffset(3,2)
02075 
02076                mGlobal(:,:)=neighbormGlobal(:,:)+SPREAD((/i,j,k/)*levels(Info%level)%mX(:),2,2)
02077 
02078                mO(1:nDim,1)=max(Info%mGlobal(1:nDim,1)-1,mGlobal(1:nDim,1)) 
02079                mO(1:nDim,2)=min(Info%mGlobal(1:nDim,2)+1,mGlobal(1:nDim,2))
02080                IF (ALL(mO(1:nDim,1) <= mO(1:nDim,2))) THEN
02081                   mO(1:nDim,:)=mO(1:nDim,:)-Spread( Info%mGlobal(1:nDim,1),2,2)+1
02082                   Info%ChildMask(mO(1,1):mO(1,2), mO(2,1):mO(2,2), mO(3,1):mO(3,2))=NEIGHBORCHILD
02083                END IF
02084             END DO
02085          END DO
02086       END DO
02087    END SUBROUTINE UpdateChildMask
02088 
02089 
02091    SUBROUTINE UpdateSelfChildMask(Info,childmGlobal)
02092       TYPE(InfoDef) :: Info
02093       INTEGER, DIMENSION(3,2) :: mO,mymGlobal,mGlobal,ioffset,childmglobal
02094       INTEGER :: i,j,k,l
02095       ioffset=0
02096       WHERE(lHydroPeriodic(1:nDim)) ioffset(1:nDim,2)=1!nperiodic_overlaps(1:nDim)
02097       ioffset(1:nDim,1)=-ioffset(1:nDim,2)
02098       mO(nDim+1:3,:)=1
02099       mymglobal(nDim+1:3,:)=1
02100       mymglobal(1:nDim,2)=childmglobal(1:nDim,2)/levels(Info%level)%CoarsenRatio
02101       mymglobal(1:nDim,1)=(childmglobal(1:nDim,1)-1)/levels(Info%level)%CoarsenRatio+1
02102       DO i=ioffset(1,1),ioffset(1,2)
02103          DO j=ioffset(2,1),ioffset(2,2)
02104             DO k=ioffset(3,1),ioffset(3,2)
02105                if (ALL((/i,j,k/)==0)) CYCLE
02106                mGlobal(:,:)=mymglobal(:,:)+SPREAD((/i,j,k/)*levels(Info%level)%mX(:),2,2)
02107 
02108                mO(1:nDim,1)=max(Info%mGlobal(1:nDim,1)-1,mGlobal(1:nDim,1)) 
02109                mO(1:nDim,2)=min(Info%mGlobal(1:nDim,2)+1,mGlobal(1:nDim,2))
02110                IF (ALL(mO(1:nDim,1) <= mO(1:nDim,2))) THEN
02111                   mO(1:nDim,:)=mO(1:nDim,:)-Spread( Info%mGlobal(1:nDim,1),2,2)+1
02112                   Info%ChildMask(mO(1,1):mO(1,2), mO(2,1):mO(2,2), mO(3,1):mO(3,2))=NEIGHBORCHILD
02113                END IF
02114             END DO
02115          END DO
02116       END DO
02117    END SUBROUTINE UpdateSelfChildMask
02118 
02119    SUBROUTINE UpdateAux(Info, mB)
02120       TYPE(InfoDef) :: Info
02121       INTEGER :: i, mB(3,2), ip(3,2)
02122       DO i=1,nAux
02123          ip=mb
02124          ip(i,:)=mb(i,:)+1
02125          Info%q(mb(1,1):mb(1,2),mb(2,1):mb(2,2),mb(3,1):mb(3,2),auxFields(i))=half*(&
02126               Info%aux(mb(1,1):mb(1,2),mb(2,1):mb(2,2),mb(3,1):mb(3,2),i)+&
02127               Info%aux(ip(1,1):ip(1,2),ip(2,1):ip(2,2),ip(3,1):ip(3,2),i))
02128       END DO
02129    END SUBROUTINE UpdateAux
02130 
02131 
02132 
02133    RECURSIVE SUBROUTINE GetSplitSolution(Info,n,mB,nGrids, TotalCost, solution)
02134       TYPE(InfoDef) :: Info
02135       INTEGER :: n
02136       INTEGER, DIMENSION(3,2) :: mB, mB1, mB2
02137       INTEGER :: nGrids, nGrids1, nGrids2
02138       REAL(KIND=qPREC) :: TotalCost, TotalCost1, TotalCost2
02139       INTEGER, DIMENSION(:,:,:), POINTER :: solution, solution1, solution2
02140       REAL(KIND=qPREC), PARAMETER :: FillRatioTolerance=0.95
02141       LOGICAL :: HaveSplit
02142       TotalCost=ChildAdvanceCost(mB, Info%level)
02143       !      Write(*,*) 'mB= ', mB
02144 
02145       IF (GridFlagRatio(Info,mB) < FillRatioTolerance .AND. n > 0) THEN
02146          !Print *, 'Before FindBestSplit_i'
02147          CALL FindBestSplit_i(Info, mB, mB1, mB2, HaveSplit)
02148          !         Print *, 'HaveSplit=', HaveSplit
02149          IF (HaveSplit) Then
02150             CALL GetSplitSolution(Info, n-1, mB1, nGrids1, TotalCost1, solution1)
02151             CALL GetSplitSolution(Info, n-1, mB2, nGrids2, TotalCost2, solution2)
02152             IF (TotalCost1+TotalCost2 > TotalCost .OR. .NOT. HaveSplit) THEN       
02153                nGrids=1
02154                ALLOCATE(solution(3,2,1))
02155                solution(:,:,1)=mB                      
02156             ELSE
02157                !               write(*,*) "A", nGrids1, nGrids2
02158                nGrids=nGrids1+nGrids2
02159                ALLOCATE(solution(3,2,nGrids))
02160                solution(:,:,1:nGrids1)=solution1
02161                solution(:,:,nGrids1+1:nGrids)=solution2
02162                TotalCost=TotalCost1+TotalCost2
02163             END IF
02164             DEALLOCATE(solution1, solution2)
02165 
02166          ELSE
02167             nGrids=1
02168             ALLOCATE(solution(3,2,1))
02169             solution(:,:,1)=mB                
02170          END IF
02171       ELSE
02172          nGrids=1
02173          ALLOCATE(solution(3,2,1))
02174          solution(:,:,1)=mB                
02175       END IF
02176    END SUBROUTINE GetSplitSolution
02177 
02178 
02179    SUBROUTINE FindBestSplit_i(Info, mB, mB1new, mB2new, HaveSplit)
02180       TYPE(InfoDef) :: Info
02181       INTEGER, DIMENSION(3,2) :: mB, mB1, mB2, mB1new, mB2new, ip
02182       LOGICAL :: HaveSplit
02183       INTEGER :: j, edge, level, i,  mx(3), splitdir, splitindx, maxm, maxdim, gaploc(3), maxsignature,odd
02184       REAL(KIND=qPREC) :: gapcost(3)
02185       INTEGER, DIMENSION(:,:), ALLOCATABLE :: signatures
02186       INTEGER, DIMENSION(:), ALLOCATABLE :: dSignatures
02187       ! Loop until no better grid splitting can be found
02188       HaveSplit=.FALSE.
02189       level=Info%level
02190       mx=mB(:,2)-mB(:,1)+1
02191       !      write(*,*) ' mx= ', mx
02192       maxdim=SUM(maxloc(mX(1:nDim))) !Get the largest dimension
02193       IF (mx(maxdim) < 2) RETURN
02194       HaveSplit=.true.
02195       splitdir=maxdim !Initialize default split dir
02196       splitindx=mx(maxdim)/2 ! Initialize default split loc
02197       !Look for holes from center out
02198       maxm=maxval(mX)
02199       gapcost=huge(gapcost)
02200       !     write(*,*) 'maxm=', maxm
02201       ALLOCATE(signatures(ndim,maxm))
02202       gaploc=0
02203       DO i=1,nDim
02204          ip=mB
02205          !   write(*,*) 'mX=', mX,'i=', i
02206          DO j=1,mX(i)
02207             ip(i,:)=j
02208             signatures(i,j)=sum(Info%ErrFlag(ip(1,1):ip(1,2), ip(2,1):ip(2,2), ip(3,1):ip(3,2)))
02209             !signatures(i,1:mX(i))=sum(sum(Info%ErrFlag(mB(1,1):mB(1,2),mB(2,1):mB(2,2),mB(3,1):mB(3,2)), mod(i,3)+1), mod(i+1,3)+1)       
02210          END DO
02211          odd = mod(mx(i),2)
02212          DO j=0, mx(i)/2-2+odd
02213             !            write(*,*) 'j=', j
02214             IF (signatures(i,mX(i)/2+j+1-odd) == 0) THEN
02215                CALL SplitShrink(Info, mB, i, mB(i,1)-1+mx(i)/2+j+1-odd, mB1, mB2)
02216                gapcost(i)=ChildAdvanceCost(mB1,level) + ChildAdvanceCost(mB2,level)
02217                gaploc(i)=mB(i,1)-1+mx(i)/2+j+1-odd
02218                EXIT
02219             END IF
02220             IF (signatures(i,mX(i)/2-j) == 0) THEN
02221                CALL SplitShrink(Info, mB, i, mB(i,1)-1+mx(i)/2-j, mB1, mB2)
02222                gapcost(i)=ChildAdvanceCost(mB1,level) + ChildAdvanceCost(mB2,level)
02223                gaploc(i)=mB(i,1)-1+mx(i)/2-j
02224                EXIT
02225             END IF
02226          END DO
02227       END DO
02228 
02229       IF (ANY(gaploc > 0)) THEN !Found a gap
02230          splitdir=sum(minloc(gapcost)) !Optimal split direction
02231          splitindx=gaploc(splitdir) !Location
02232          CALL SplitShrink(Info, mB, splitdir, splitindx, mB1new, mB2new) !Get subgrid bounds
02233          !         print *, 'find a gap'
02234       ELSE
02235          !Find inflections
02236          ALLOCATE(dSignatures(1:maxm))
02237          dSignatures=0
02238          !Search through second derivatives
02239          DO i=1,nDim
02240             dSignatures(1:mx(i)-1)=abs(signatures(i,2:mx(i))-(signatures(i,1:mx(i)-1)))
02241             maxsignature=-1
02242             odd=mod(mx(i),2)
02243             DO j=0, mx(i)/2-1
02244                !Write(*,*) 'j=', j
02245                IF (dSignatures(mX(i)/2-j) > maxsignature) THEN
02246                   CALL SplitShrink(Info, mB, i, mB(i,1)-1+mx(i)/2-j, mB1, mB2)
02247                   !                  Write(*,*) 'found inflection at ', mx(i)/2-j, ' dsig=',dSignatures(mX(i)/2-j)
02248                   gapcost(i)=ChildAdvanceCost(mB1,level) + ChildAdvanceCost(mB2,level)
02249                   gaploc(i)=mB(i,1)-1+mx(i)/2-j
02250                   maxsignature=dSignatures(mX(i)/2-j)
02251                END IF
02252                IF (dsignatures(mX(i)/2+j+odd) > maxsignature) THEN
02253                   !                  Write(*,*) 'found inflection at ', mx(i)/2+j+odd, ' dsig=',dSignatures(mX(i)/2+j+odd)
02254                   CALL SplitShrink(Info, mB, i, mB(i,1)-1+mx(i)/2+j+odd, mB1, mB2)
02255                   gapcost(i)=ChildAdvanceCost(mB1,level) + ChildAdvanceCost(mB2,level)
02256                   gaploc(i)=mB(i,1)-1+mx(i)/2+j+odd
02257                   maxsignature=dSignatures(mX(i)/2+j+odd)
02258                END IF
02259             END DO
02260          END DO
02261          splitdir=sum(minloc(gapcost)) !Optimal split direction
02262          splitindx=gaploc(splitdir) !Location
02263          !Write(*,*) 'found inflection splitdir=', splitdir, ' &splitindx=', splitindx
02264          CALL SplitShrink(Info, mB, splitdir, splitindx, mB1new, mB2new) !Get subgrid bounds
02265          !         write(*,'(A,8I5)') 'new suggested grids are', mB1new(1:2,:), mB2new(1:2,:)
02266          DEALLOCATE(dSignatures)
02267       END IF
02268       DEALLOCATE(signatures)
02269    END SUBROUTINE FindBestSplit_i
02270 
02271 
02272    SUBROUTINE SplitShrink(Info, mB, splitdir, splitindx, mB1new, mB2new)
02273       TYPE(InfoDef) :: Info
02274       INTEGER, DIMENSION(3,2) :: mB, mB1new, mB2new, ip
02275       INTEGER :: splitdir, splitindx, m, edge
02276       mB1new=mB(:,:)
02277       mB2new=mB(:,:)         
02278 
02279       mB1new(splitdir,2) = splitindx
02280       mB2new(splitdir,1) = splitindx+1
02281 
02282       DO m=1,ndim
02283          DO edge=1,2
02284             IF (.NOT. (m == splitdir .AND. edge == 1)) THEN
02285                !shrink mB1 along dim and edge
02286                ip=mB1new
02287                ip(m,:)=mB1new(m,edge)
02288                DO WHILE (ALL(Info%ErrFlag(ip(1,1):ip(1,2),ip(2,1):ip(2,2),ip(3,1):ip(3,2))==0))
02289                   ip(m,:)=ip(m,:)-(-1)**edge
02290                END DO
02291                mB1new(m,edge)=ip(m,1)
02292             END IF
02293             IF (.NOT. (m == splitdir .AND. edge == 2)) THEN
02294                !shrink mB2 along dim and edge
02295                ip=mB2new
02296                ip(m,:)=mB2new(m,edge)
02297                DO WHILE (ALL(Info%ErrFlag(ip(1,1):ip(1,2),ip(2,1):ip(2,2),ip(3,1):ip(3,2))==0))
02298                   ip(m,:)=ip(m,:)-(-1)**edge
02299                END DO
02300                mB2new(m,edge)=ip(m,1)
02301             END IF
02302          END DO
02303       END DO
02304    END SUBROUTINE SplitShrink
02305 
02306 
02307    SUBROUTINE FindBestSplit(Info, mB, mB1new, mB2new, HaveSplit)
02308       TYPE(InfoDef) :: Info
02309       INTEGER, DIMENSION(3,2) :: mB, mB1, mB2, mB1new, mB2new, ip
02310       LOGICAL :: HaveSplit
02311       INTEGER :: n, m, edge, level, i, i1,i2
02312       REAL(KIND=qPREC) :: MinSplitCost, SplitCost
02313       ! Loop until no better grid splitting can be found
02314       MinSplitCost=HUGE(MinSplitCost)
02315       HaveSplit=.FALSE.
02316       level=Info%level
02317       ! check splitting position along x direction ===============
02318       !write(*,'(A,4I5)') 'considering grid ', mB(1:2,:)
02319 
02320 
02321       DO n=1,ndim
02322          i1=mB(n,1); i2=mB(n,2)
02323 
02324          DO i=i1,i2-1
02325 
02326             mB1=mB(:,:)
02327             mB2=mB(:,:)         
02328 
02329             mB1(n,:)=i
02330             if(all(Info%ErrFlag(mB1(1,1):mB1(1,2), mB1(2,1):mB1(2,2), mB1(3,1):mB1(3,2))==0)) CYCLE
02331 
02332             CALL SplitShrink(Info, mB, n, i, mB1, mB2)
02333             ! Shrink along y direction
02334             SplitCost = ChildAdvanceCost(mB1,level) + ChildAdvanceCost(mB2,level);             
02335             !write(*,'(A, 8I5, E25.15)') 'evaluating ', mB1(1:2,:), mB2(1:2,:), SplitCost   
02336             if(SplitCost < MinSplitCost) then
02337                MinSplitCost = SplitCost
02338                HaveSplit = .TRUE.
02339                mB2new=mB2
02340                mB1new=mB1
02341                !write(*,*) 'x spitting at ', i, splitcost
02342                !write(*,'(100I5)') mB1(1:2,:), mB2(1:2,:)
02343                !write(*,*) 'mB now = ', mB
02344             end if
02345          END DO
02346       END DO
02347       !=====================================
02348 
02349    END SUBROUTINE FindBestSplit
02350 
02351 
02354 
02355    SUBROUTINE NewSubGrids(Info, nSubGrids, child_box_array)
02356       Type(InfoDef), POINTER :: Info
02357       INTEGER, POINTER, DIMENSION(:,:,:) :: child_box_array
02358       ! Internal declarations
02359       INTEGER :: nSubGrids
02360       IF (lUseOriginalNewSubGrids) THEN
02361          CALL OldNewSubGrids(Info, nSubGrids, child_box_array)
02362       ELSE
02363          CALL NewNewSubGrids(Info, nSubGrids, child_box_array)
02364       END IF
02365    END SUBROUTINE NewSubGrids
02366 
02372    SUBROUTINE OldNewSubGrids(Info, nSubGrids, child_box_array)
02373       ! Implementation of Berger-Rigoutsos algorithm (IEEE Trans. Systems, Man &
02374       ! Cyber., 21(5):1278-1286, 1991
02375 
02376       ! Interface declarations
02377       TYPE (InfoDef), POINTER :: Info
02378       INTEGER, POINTER, DIMENSION(:,:,:) :: child_box_array
02379 
02380       ! Internal declarations
02381       INTEGER :: nSubGrids
02382       INTEGER nGrid,min_level
02383       INTEGER, DIMENSION(3,2) :: mBounds
02384       INTEGER, DIMENSION(3,2,MAX_SUBGRIDS) :: mSubBounds
02385 
02386       INTEGER, PARAMETER :: MAX_SPLIT_PASSES=40
02387       LOGICAL HaveSplit,CanSplitGrid,CanSplit(MAX_SUBGRIDS)
02388       INTEGER i,n,iError,i1,i2,i1L,i2L,iGrid,inflect,del,maxm,minm,npass,level,nd
02389       INTEGER iSplit(MAX_DIMS),iErr,DomDecSplits(4)
02390       INTEGER, ALLOCATABLE, DIMENSION (:,:) :: Signature,ddSignature
02391       REAL FillRatio,DesiredFillRatio,rand
02392 
02393       DomDecSplits=0
02394 
02395       mBounds(1:nDim,1)=1
02396       mBounds(1:nDim,2)=Info%mX(1:nDim)
02397 
02398       level=Info%level
02399       mSubBounds = 1
02400       DesiredFillRatio = levels(level)%DesiredFillRatios
02401       nSubGrids=0
02402       ! Compute fill ratio for this grid
02403       FillRatio=GridFlagRatio(Info,mBounds)
02404 
02405       IF (FillRatio==zero) RETURN
02406 
02407       ! Allocate space for signatures
02408       maxm=MAXVAL(Info%mX(1:nDim))
02409       ALLOCATE(Signature(maxm,nDim),ddSignature(maxm,nDim), STAT=iError)
02410       IF (iError /= 0) THEN
02411          PRINT *,'NewSubGrids() error: Unable to allocate signature arrays.'
02412          STOP
02413       END IF
02414 
02415       Signature=0
02416       ddSignature=0
02417 
02418       ! Initialize list of subgrids
02419       nGrid=1
02420       CanSplit(:)=.TRUE.
02421 
02422       mSubBounds(1:nDim,1:2,nGrid)=mBounds(1:nDim,1:2)
02423       iGrid=1
02424 
02425       ! Loop until no better grid splitting can be found
02426       DO WHILE (nGrid<MAX_SUBGRIDS .AND. iGrid<=nGrid)
02427          npass=0
02428          DO WHILE (CanSplit(iGrid) .AND. npass<MAX_SPLIT_PASSES)
02429             npass=npass+1
02430             CALL CalcSignatures(Info,mSubBounds(:,:,iGrid),maxm,Signature)
02431 
02432             ! Trim unflagged points on the edges of this grid
02433             DO n=1,nDim
02434                i1=mSubBounds(n,1,iGrid); i2=mSubBounds(n,2,iGrid);
02435                DO WHILE ( Signature(i1,n)==0 .AND. i1<mSubBounds(n,2,iGrid) .AND. &
02436                     i2-i1+1 > MinimumGridPoints )
02437                   i1=i1+1
02438                END DO
02439                DO WHILE ( Signature(i2,n)==0 .AND. i2>mSubBounds(n,1,iGrid)  .AND. &
02440                     i2-i1+1 > MinimumGridPoints )
02441                   i2=i2-1
02442                END DO
02443 
02444                mSubBounds(n,1,iGrid)=i1
02445                mSubBounds(n,2,iGrid)=i2
02446             END DO
02447 
02448             FillRatio=GridFlagRatio(Info,mSubBounds(:,:,iGrid))
02449 
02450             minm=MINVAL(mSubBounds(1:nDim,2,iGrid)-mSubBounds(1:nDim,1,iGrid))+1
02451 
02452             CALL CalcSignatures(Info,mSubBounds(:,:,iGrid),maxm,Signature)
02453 
02454             ! Look for holes along which to split grid
02455             iSplit=0
02456             HaveSplit=.FALSE.
02457 
02458             DO n=1,nDim
02459                i1=mSubBounds(n,1,iGrid); i2=mSubBounds(n,2,iGrid)
02460 
02461                i1L=i1;i2L=i2               
02462                DO i=i1L,i2L-1
02463                   IF (Signature(i,n)==0 .AND. MIN(i-i1+1,i2-i) >= MinimumGridPoints) THEN
02464                      iSplit=0
02465                      iSplit(n)=i
02466                      HaveSplit=.TRUE.
02467                      EXIT
02468                   END IF
02469                END DO
02470 
02471                IF (HaveSplit) EXIT
02472             END DO
02473 
02474 
02475             IF (FillRatio<DesiredFillRatio .AND. .NOT. HaveSplit) THEN
02476                ! No split along a hole. Try split along inflection point
02477                DO n=1,nDim
02478 
02479                   i1=mSubBounds(n,1,iGrid)
02480                   i2=mSubBounds(n,2,iGrid)
02481 
02482                   DO i=i1+1,i2-1
02483                      ddSignature(i,n)=Signature(i-1,n)-2*Signature(i,n)+Signature(i+1,n)
02484                   END DO
02485 
02486                END DO
02487 
02488                inflect=0
02489 
02490                DO n=1,nDim
02491                   i1=mSubBounds(n,1,iGrid)
02492                   i2=mSubBounds(n,2,iGrid)
02493                   i1L=i1;i2L=i2
02494 
02495                   DO i=i1L,i2L-1
02496                      del=ABS(ddSignature(i+1,n)-ddSignature(i,n))
02497                      IF (del>inflect .AND. MIN(i-i1+1,i2-i) >= MinimumGridPoints) THEN
02498                         inflect=del
02499                         iSplit=0
02500                         iSplit(n)=i
02501                         HaveSplit=.TRUE.
02502                      END IF
02503                   END DO
02504 
02505                END DO
02506 
02507             END IF
02508             IF (HaveSplit) THEN
02509                ! Split the grid along a determined line
02510                DO n=1,nDim
02511                   IF (iSplit(n)>0 .AND. &
02512                        MIN( mSubBounds(n,2,iGrid)-iSplit(n) , &
02513                        iSplit(n)-mSubBounds(n,1,iGrid)+1 ) >= MinimumGridPoints) THEN
02514                      ! Add a new subgrid to the end of the grid list
02515                      nGrid=nGrid+1
02516 
02517                      CanSplit(nGrid)=.TRUE.
02518                      mSubBounds(1:nDim,1:2,nGrid)=mSubBounds(1:nDim,1:2,iGrid)
02519                      mSubBounds(n,1,nGrid)=iSplit(n)+1
02520                      ! Replace current grid with a subgrid
02521                      mSubBounds(n,2,iGrid)=iSplit(n)
02522 
02523                      EXIT
02524                   END IF
02525                END DO
02526             ELSE
02527                ! Mark grid if no split is possible
02528                CanSplit(iGrid)=.FALSE.
02529             END IF
02530          END DO
02531          iGrid=iGrid+1
02532       END DO
02533 
02534       DEALLOCATE(Signature,ddSignature,STAT=iError)
02535       IF (iError /= 0) THEN
02536          PRINT *,'Error deallocating signatures arrays in NewSubGrids'
02537          STOP
02538       END IF
02539 
02540       DO iGrid=1,nGrid
02541          IF (ALL(Info%ErrFlag(mSubBounds(1,1,iGrid):mSubBounds(1,2,iGrid), &
02542               mSubBounds(2,1,iGrid):mSubBounds(2,2,iGrid), &
02543               mSubBounds(3,1,iGrid):mSubBounds(3,2,iGrid))==0)) THEN
02544             DO i=iGrid+1,nGrid
02545                mSubBounds(:,:,i-1)=mSubBounds(:,:,i)
02546             END DO
02547             nGrid=nGrid-1
02548          END IF
02549       END DO
02550 
02551       ALLOCATE(child_box_array(3,2,nGrid), STAT=iErr)
02552 
02553       child_box_array(:,:,1:nGrid) = mSubBounds(:,:,1:nGrid)
02554       nSubGrids=nGrid
02555 
02556    END SUBROUTINE OldNewSubGrids
02557 
02563    SUBROUTINE NewNewSubGrids(Info, nSubGrids, child_box_array)
02564       ! Implementation of Berger-Rigoutsos algorithm (IEEE Trans. Systems, Man &
02565       ! Cyber., 21(5):1278-1286, 1991
02566 
02567       ! Interface declarations
02568       TYPE (InfoDef), POINTER :: Info
02569       INTEGER, POINTER, DIMENSION(:,:,:) :: child_box_array
02570 
02571       ! Internal declarations
02572       INTEGER :: nSubGrids
02573       INTEGER nGrid,min_level
02574       INTEGER, DIMENSION(3,2) :: mBounds
02575       INTEGER, DIMENSION(3,2,MAX_SUBGRIDS) :: mSubBounds
02576 
02577       INTEGER, PARAMETER :: MAX_SPLIT_PASSES=40
02578       LOGICAL HaveSplit,CanSplitGrid,CanSplit
02579       INTEGER i,n,iError,i1,i2,i1L,i2L,iGrid,inflect,del,maxm,minm,npass,level,nd,m, edge
02580       INTEGER iSplit(MAX_DIMS),iErr,DomDecSplits(4)
02581       INTEGER, ALLOCATABLE, DIMENSION (:,:) :: Signature,ddSignature
02582 
02583       REAL FillRatio,DesiredFillRatio,rand
02584       REAL(KIND=qPREC) :: TotalCost
02585 
02586       INTEGER, DIMENSION(3,2) :: mB, ip
02587 
02588       mB(:,1)=1
02589       mB(:,2)=Info%mX
02590 
02591       level=Info%level
02592       !print *, "nSubGrids=", nSubGrids
02593 
02594       nSubGrids=0
02595       ! Compute fill ratio for this grid
02596       FillRatio=GridFlagRatio(Info,mB)
02597 
02598       IF (FillRatio==zero) RETURN
02599 
02600       ! Initialize list of subgrids
02601 
02602       DO m=1,ndim
02603          DO edge=1,2
02604             !shrink mB1 along dim and edge
02605             ip=mB
02606             ip(m,:)=mB(m,edge)
02607             DO WHILE (ALL(Info%ErrFlag(ip(1,1):ip(1,2),ip(2,1):ip(2,2),ip(3,1):ip(3,2))==0))
02608                ip(m,:)=ip(m,:)-(-1)**edge
02609             END DO
02610             mB(m,edge)=ip(m,1)
02611          END DO
02612       END DO
02613 
02614       !print *, "nSubGrids=", nSubGrids
02615       CALL GetSplitSolution(Info, MAX_SPLIT_PASSES, mB, nSubGrids, TotalCost, child_box_array)
02616 
02617    END SUBROUTINE NewNewSubGrids
02618 
02619    SUBROUTINE CalcSignatures(Info,mSubBounds,maxm,Signature)
02620       ! Interface declarations
02621       TYPE (InfoDef) :: Info
02622       INTEGER mSubBounds(MAX_DIMS,2),maxm
02623       INTEGER Signature(maxm,nDim)
02624       ! Internal declarations
02625       INTEGER i,n,i1(MAX_DIMS),i2(MAX_DIMS)
02626       Signature=0
02627       i1=1; i2=1
02628       DO n=1,nDim
02629          i1(1:nDim)=mSubBounds(1:nDim,1)
02630          i2(1:nDim)=mSubBounds(1:nDim,2)
02631          DO i=mSubBounds(n,1),mSubBounds(n,2)
02632             i1(n)=i; i2(n)=i
02633             Signature(i,n)=SUM(Info%ErrFlag(i1(1):i2(1), &
02634                  i1(2):i2(2), &
02635                  i1(3):i2(3)) )
02636          END DO
02637       END DO
02638    END SUBROUTINE CalcSignatures
02639 
02640    REAL FUNCTION GridFlagRatio(Info,mBounds)
02641       ! Interface declarations
02642       TYPE (InfoDef) :: Info
02643       INTEGER mBounds(MAX_DIMS,2)
02644       ! Internal declarations
02645       REAL Total,Flagged
02646 
02647       Total=PRODUCT(mBounds(1:nDim,2)-mBounds(1:nDim,1)+1)
02648       mBounds(nDim+1:MAX_DIMS,:)=1
02649       Flagged = SUM(REAL(Info%ErrFlag(mBounds(1,1):mBounds(1,2), &
           mBounds(2,1):mBounds(2,2), &
           mBounds(3,1):mBounds(3,2)) ))
02650       GridFlagRatio=Flagged/Total
02651 
02652 
02653    END FUNCTION GridFlagRatio
02654 
02655    FUNCTION  GetMyCosts(Info, step)
02656       TYPE(InfoDef) :: Info
02657       INTEGER :: mx(3), bc, i, step
02658       REAL(KIND=qPREC) :: GetMyCosts
02659       GetMyCosts=0
02660       bc=levels(Info%level)%ambc(step)
02661       mx=1
02662       mx(1:nDim)=Info%mx(1:nDim)+2*bc
02663       GetMyCosts=GetMyCosts+AdvanceCost(mx)
02664    END Function GetMyCosts
02665 
02666    ! !> This routine calculates the cost of a child grid with bounds mB
02667    ! !! @param info Info structure
02668    ! !! @param mB Bounds of child in parent indexing space
02669    ! !! @param n level of parent
02670    REAL FUNCTION GetChildCosts(mB,level)
02671       INTEGER, DIMENSION(3,2) :: mB
02672       INTEGER :: n, r,i,bc,mx(3), level
02673       GetChildCosts=0
02674       IF (level >= 0) THEN
02675          DO i=1,levels(level)%steps
02676             bc=levels(level)%ambc(i)
02677             mx=1
02678             mx(1:nDim)=(mB(1:nDim,2)-mB(1:nDim,1)+1)+2*bc
02679             GetChildCosts=GetChildCosts+AdvanceCost(mx)
02680          END DO
02681       ELSE
02682          GetChildCosts=product(mB(:,2)-mB(:,1)+1)*tiny(1e0)
02683       END IF
02684    END FUNCTION GetChildCosts
02689    REAL FUNCTION GetSubTreeCost(info, mB)
02690       TYPE(InfoDef), POINTER :: info
02691       INTEGER, DIMENSION(3,2) :: mB
02692       GetSubTreeCost=SUM(info%costmap(mB(1,1):mB(1,2), mB(2,1):mB(2,2), mB(3,1):mB(3,2),1))
02693    END FUNCTION GetSubTreeCost
02695 
02696 END MODULE DataInfoOps
02697  
02698 
 All Classes Files Functions Variables