Scrambler
1
|
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