Scrambler
1
|
00001 !######################################################################### 00002 ! 00003 ! Copyright (C) 2003-2012 Department of Physics and Astronomy, 00004 ! University of Rochester, 00005 ! Rochester, NY 00006 ! 00007 ! refinements.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 MODULE Refinements 00033 USE GlobalDeclarations 00034 USE DataDeclarations 00035 USE PhysicsDeclarations 00036 USE EOS 00037 USE Fields 00038 USE ObjectDeclarations 00039 IMPLICIT NONE 00041 00042 LOGICAL, PARAMETER :: GREATERTHAN=.false., LESSTHAN=.true. 00043 TYPE RefinementDef 00044 INTEGER :: field = 0 !Field id. See fields module for a complete list 00045 INTEGER :: ScaleField = 0 !Field id. See fields module for a complete list 00046 REAL(KIND=qPREC) :: tolerance=1d0 !Relative tolerance (multipled by qtolerance for level 00047 REAL(KIND=qPREC), DIMENSION(0:MaxDepth) :: Threshold = UNDEFINED 00048 INTEGER :: scale = LOGSCALE !Scale to use for gradients 00049 INTEGER :: BufferCells = 2 !Number of cells to nest regions 00050 LOGICAL :: limit = GREATERTHAN 00051 INTEGER :: MaxLevel = MAXDEPTH 00052 TYPE(ShapeDef), POINTER :: Shape=>NULL() 00053 INTEGER :: RefinementId 00054 INTEGER :: ObjId 00055 END TYPE RefinementDef 00056 00057 !new declaration 00058 TYPE pRefinementDef 00059 TYPE(RefinementDef), POINTER :: ptr 00060 END TYPE pRefinementDef 00061 TYPE(pRefinementDef) :: pRefinement 00062 00063 INTEGER :: nRefinements=0 00064 INTEGER, PARAMETER :: DEREFINE_OUTSIDE=-1d0, DEREFINE_INSIDE=-2d0 00065 ! 00066 00067 00068 CONTAINS 00069 00070 SUBROUTINE AddRefinementCriterion(field, tolerance, scaleField, Scale) 00071 INTEGER :: Field 00072 REAL(KIND=qPREC), OPTIONAL :: Tolerance 00073 INTEGER, OPTIONAL :: ScaleField 00074 INTEGER, OPTIONAL :: scale 00075 TYPE(RefinementDef), POINTER :: Refinement 00076 CALL CreateRefinement(Refinement) 00077 Refinement%field=field 00078 IF (Present(tolerance)) Refinement%tolerance=tolerance 00079 IF (Present(ScaleField)) Refinement%scalefield=ScaleField 00080 IF (Present(Scale)) Refinement%scale=scale 00081 END SUBROUTINE AddRefinementCriterion 00082 00083 SUBROUTINE AddRefinementThreshold(field, limit, threshold, scaleField) 00084 INTEGER :: Field 00085 REAL(KIND=qPREC), DIMENSION(:) :: threshold 00086 INTEGER, OPTIONAL :: ScaleField 00087 TYPE(RefinementDef), POINTER :: Refinement 00088 LOGICAL :: limit 00089 CALL CreateRefinement(Refinement) 00090 Refinement%field=field 00091 Refinement%threshold(0:size(threshold)-1)=threshold 00092 Refinement%limit=limit 00093 IF (Present(ScaleField)) Refinement%scalefield=ScaleField 00094 END SUBROUTINE AddRefinementThreshold 00095 00096 SUBROUTINE CreateRefinement(Refinement) 00097 TYPE(RefinementDef), POINTER :: Refinement 00098 ALLOCATE(Refinement) 00099 CALL AddRefinementToList(Refinement) 00100 nRefinements=nRefinements+1 00101 Refinement%RefinementID=nRefinements 00102 END SUBROUTINE CreateRefinement 00103 00104 SUBROUTINE UpdateRefinement(Refinement) 00105 TYPE(RefinementDef), POINTER :: Refinement 00106 !update attributes that needs to be updated, if any 00107 END SUBROUTINE UpdateRefinement 00108 00109 SUBROUTINE AddRefinementToList(Refinement) 00110 TYPE(RefinementDef), POINTER :: Refinement 00111 TYPE(ObjectDef), POINTER :: Object 00112 Refinement%ObjId = ObjectListAdd(Object,REFINEMENTOBJ) 00113 pRefinement%ptr => Refinement 00114 len = size(transfer(pRefinement, dummy_char)) 00115 ALLOCATE(Object%storage(len)) 00116 Object%storage = transfer(pRefinement, Object%storage) 00117 END SUBROUTINE AddRefinementToList 00118 00119 00120 SUBROUTINE DestroyRefinement(Refinement) 00121 TYPE(RefinementDef),POINTER :: Refinement 00122 CALL ObjectListRemove(Refinement%ObjId) 00123 IF (ASSOCIATED(Refinement%Shape)) DEALLOCATE(Refinement%Shape) 00124 DEALLOCATE(Refinement) 00125 NULLIFY(Refinement) 00126 END SUBROUTINE DestroyRefinement 00127 00128 00129 !SUBROUTINE ClearAllRefinements() 00130 ! TYPE(RefinementDef), POINTER :: temp 00131 ! DO WHILE (ASSOCIATED(FirstRefinement)) 00132 ! temp=>FirstRefinement 00133 ! FirstRefinement=>FirstRefinement%next 00134 ! CALL DestroyRefinement(temp) 00135 ! END DO 00136 !END SUBROUTINE ClearAllRefinements 00137 00138 SUBROUTINE ClearAllRefinements() 00139 TYPE(ObjectDef), POINTER :: Object 00140 Object => ListHead 00141 DO WHILE (ASSOCIATED(Object)) 00142 IF(Object%type == REFINEMENTOBJ) THEN 00143 pRefinement = transfer(Object%storage,pRefinement) 00144 CALL DestroyRefinement(pRefinement%ptr) 00145 ENDIF 00146 Object => Object%next 00147 END DO 00148 nRefinements=0 00149 END SUBROUTINE ClearAllRefinements 00150 00151 00152 SUBROUTINE RefinementSetErrFlag(Info, Refinement) 00153 TYPE(InfoDef) :: Info 00154 INTEGER, DIMENSION(3,2) :: mS, mT 00155 INTEGER, POINTER, DIMENSION(:,:,:) :: mSs 00156 REAL(KIND=qPREC) :: dx, dy, dz, MinScale, w 00157 REAL(KIND=qPREC), DIMENSION(3) :: offset, pos, rpos 00158 REAL(KIND=qPREC), POINTER, DIMENSION(:,:) :: offsets 00159 REAL(KIND=qPREC), DIMENSIOn(3,2) :: tempbounds 00160 Type(RefinementDef), POINTER :: Refinement 00161 INTEGER :: nOverlaps, n, i, j, k 00162 LOGICAL :: lrefine 00163 LOGICAL, DIMENSION(:,:,:), POINTER :: flags, inshape 00164 REAL(KIND=qPREC), DIMENSION(:,:,:), POINTER :: buffer 00165 00166 00167 IF (Info%level >= Refinement%MaxLevel) RETURN 00168 dx=levels(Info%level)%dx 00169 dy=merge(dx,0d0,nDim>=2) 00170 dz=merge(dx,0d0,nDim>=3) 00171 00172 minScale=merge(1d0,0d0,Refinement%ScaleField /= 0) 00173 IF (ASSOCIATED(Refinement%Shape)) THEN 00174 Refinement%Shape%size_param=Refinement%Shape%size_param+(Refinement%BufferCells)*levels(Info%level)%dx 00175 CALL SetShapeBounds(Refinement%Shape) 00176 END IF 00177 IF (ASSOCIATED(Refinement%Shape) .AND. Refinement%Tolerance >= 0) THEN 00178 CALL CalcPhysicalOverlaps(Info, GetShapeBounds(Refinement%Shape, levels(Info%level)%tnow), mSs, nOverlaps, offsets, IEVERYWHERE, lHydroPeriodic, 0) 00179 ELSE 00180 nOverlaps=1 00181 ALLOCATE(mSs(1,3,2)) 00182 ALLOCATE(offsets(1,3)) 00183 offsets=0d0 00184 mSs(1,:,1)=1 00185 mSs(1,:,2)=Info%mX(:) 00186 END IF 00187 IF (nOverlaps > 0) THEN 00188 DO n=1,nOverlaps 00189 mS=mSs(n,:,:) 00190 offset=offsets(n,:) 00191 ! write(*,*) n, offset 00192 00193 mT=mS 00194 mS(1:nDim,1)=mS(1:nDim,1)-1 00195 mS(1:nDim,2)=mS(1:nDim,2)+1 00196 00197 ALLOCATE(buffer(mS(1,1):mS(1,2), mS(2,1):mS(2,2), mS(3,1):mS(3,2))) 00198 ALLOCATE(inshape(mS(1,1):mS(1,2), mS(2,1):mS(2,2), mS(3,1):mS(3,2))) 00199 ALLOCATE(flags(mS(1,1):mS(1,2), mS(2,1):mS(2,2), mS(3,1):mS(3,2))) 00200 flags=.false. 00201 DO i=mS(1,1), mS(1,2) 00202 pos(1)=Info%xBounds(1,1)+(REAL(i)-half)*dx-offset(1) 00203 DO j=mS(2,1), mS(2,2) 00204 pos(2)=Info%xBounds(2,1)+(REAL(j)-half)*dy-offset(2) 00205 DO k=mS(3,1), mS(3,2) 00206 pos(3)=Info%xBounds(3,1)+(REAL(k)-half)*dz-offset(3) 00207 IF (ASSOCIATED(Refinement%Shape)) THEN 00208 inshape(i,j,k)=IsInShape(Refinement%Shape, pos, rpos, levels(Info%level)%tnow) 00209 ! IF (ALL((/i,j,k/)==(/16,16,16/))) THEN 00210 ! write(*,*) pos, rpos, levels(Info%level)%tnow 00211 ! STOP 00212 ! END IF 00213 00214 END IF 00215 ! write(*,*) i,j,k 00216 IF (Refinement%Field /= 0) THEN 00217 IF (Refinement%ScaleField /= 0) THEN 00218 buffer(i,j,k)=GetField(Info, i, j, k, Refinement%Field, pos)/GetField(Info, i, j, k, Refinement%ScaleField, pos) 00219 ELSE 00220 buffer(i,j,k)=GetField(Info, i, j, k, Refinement%Field, pos) 00221 END IF 00222 END IF 00223 END DO 00224 END DO 00225 END DO 00226 IF (ANY(Refinement%Threshold(0:MaxLevel) /= UNDEFINED)) THEN !ignore gradients and just look at thresholds 00227 IF (Refinement%Threshold(Info%level) /= UNDEFINED) THEN !have a defined threshold for this level 00228 IF (Refinement%limit .EQV. GREATERTHAN) THEN 00229 IF (ASSOCIATED(Refinement%Shape)) THEN 00230 WHERE (inshape(mT(1,1):mT(1,2), mT(2,1):mT(2,2), mT(3,1):mT(3,2)) .AND. & 00231 buffer(mT(1,1):mT(1,2), mT(2,1):mT(2,2), mT(3,1):mT(3,2)) >= Refinement%Threshold(Info%level)) 00232 Info%ErrFlag(mT(1,1):mT(1,2), mT(2,1):mT(2,2), mT(3,1):mT(3,2))=Info%ErrFlag(mT(1,1):mT(1,2), mT(2,1):mT(2,2), mT(3,1):mT(3,2))+2**Refinement%RefinementID 00233 END WHERE 00234 ELSE 00235 WHERE (buffer(mT(1,1):mT(1,2), mT(2,1):mT(2,2), mT(3,1):mT(3,2)) >= Refinement%threshold(Info%level)) 00236 Info%ErrFlag(mT(1,1):mT(1,2), mT(2,1):mT(2,2), mT(3,1):mT(3,2))=Info%ErrFlag(mT(1,1):mT(1,2), mT(2,1):mT(2,2), mT(3,1):mT(3,2))+2**Refinement%RefinementID 00237 END WHERE 00238 END IF 00239 ELSE !Refinement%Limit = Upper 00240 IF (ASSOCIATED(Refinement%Shape)) THEN 00241 WHERE (inshape(mT(1,1):mT(1,2), mT(2,1):mT(2,2), mT(3,1):mT(3,2)) .AND. & 00242 buffer(mT(1,1):mT(1,2), mT(2,1):mT(2,2), mT(3,1):mT(3,2)) <= Refinement%threshold(Info%level)) 00243 Info%ErrFlag(mT(1,1):mT(1,2), mT(2,1):mT(2,2), mT(3,1):mT(3,2))=Info%ErrFlag(mT(1,1):mT(1,2), mT(2,1):mT(2,2), mT(3,1):mT(3,2))+2**Refinement%RefinementID 00244 END WHERE 00245 ELSE 00246 WHERE (buffer(mT(1,1):mT(1,2), mT(2,1):mT(2,2), mT(3,1):mT(3,2)) <= Refinement%threshold(Info%level)) 00247 Info%ErrFlag(mT(1,1):mT(1,2), mT(2,1):mT(2,2), mT(3,1):mT(3,2))=Info%ErrFlag(mT(1,1):mT(1,2), mT(2,1):mT(2,2), mT(3,1):mT(3,2))+2**Refinement%RefinementID 00248 END WHERE 00249 END IF 00250 END IF 00251 END IF 00252 ELSE 00253 IF (Refinement%Tolerance == DEREFINE_OUTSIDE) THEN 00254 WHERE (.NOT. inshape(mT(1,1):mT(1,2), mT(2,1):mT(2,2), mT(3,1):mT(3,2))) 00255 Info%ErrFlag(mT(1,1):mT(1,2), mT(2,1):mT(2,2), mT(3,1):mT(3,2))=0 00256 END WHERE 00257 ! write(*,*) inshape 00258 ELSEIF (Refinement%Tolerance == DEREFINE_INSIDE) THEN 00259 WHERE (inshape(mT(1,1):mT(1,2), mT(2,1):mT(2,2), mT(3,1):mT(3,2))) 00260 Info%ErrFlag(mT(1,1):mT(1,2), mT(2,1):mT(2,2), mT(3,1):mT(3,2))=0 00261 END WHERE 00262 ELSE 00263 IF (Refinement%Field /= 0) THEN 00264 CALL SetFlags(mT, flags, buffer, Refinement%Scale, Refinement%Tolerance/levels(Info%level)%qtolerance, MinScale) 00265 ELSE 00266 flags=.true. 00267 END IF 00268 IF (ASSOCIATED(Refinement%Shape)) THEN 00269 WHERE((flags(mT(1,1):mT(1,2), mT(2,1):mT(2,2), mT(3,1):mT(3,2)) .AND. & 00270 inshape(mT(1,1):mT(1,2), mT(2,1):mT(2,2), mT(3,1):mT(3,2)))) 00271 Info%ErrFlag(mT(1,1):mT(1,2), mT(2,1):mT(2,2), mT(3,1):mT(3,2))=Info%ErrFlag(mT(1,1):mT(1,2), mT(2,1):mT(2,2), mT(3,1):mT(3,2))+2**Refinement%RefinementID 00272 END WHERE 00273 00274 ! write(*,*) inshape 00275 ELSE 00276 WHERE(flags(mT(1,1):mT(1,2), mT(2,1):mT(2,2), mT(3,1):mT(3,2))) 00277 Info%ErrFlag(mT(1,1):mT(1,2), mT(2,1):mT(2,2), mT(3,1):mT(3,2))=1 00278 END WHERE 00279 END IF 00280 END IF 00281 END IF 00282 DEALLOCATE(buffer, inshape, flags) 00283 END DO 00284 DEALLOCATE(mSs, offsets) 00285 END IF 00286 IF (ASSOCIATED(Refinement%Shape)) THEN 00287 Refinement%Shape%size_param=Refinement%Shape%size_param-(Refinement%BufferCells)*levels(Info%level)%dx 00288 CALL SetShapeBounds(Refinement%Shape) 00289 END IF 00290 END SUBROUTINE RefinementSetErrFlag 00291 00292 SUBROUTINE SetFlags(mT,flags, buffer, scale, tolerance, MinScale) 00293 INTEGER, DIMENSION(3,2) :: mA, mB, mT 00294 LOGICAL, DIMENSION(:,:,:), POINTER :: flags 00295 REAL(KIND=qPREC), DIMENSION(:,:,:), POINTER :: buffer 00296 INTEGER :: scale, i 00297 REAL(KIND=qPREC) :: tolerance, MinScale 00298 mA=mT 00299 mB=mT 00300 DO i=1,nDim 00301 mA(i,:)=mT(i,:)-1 00302 mB(i,:)=mT(i,:)+1 00303 IF (scale==LOGSCALE) THEN 00304 WHERE(ABS(buffer(mB(1,1):mB(1,2), mB(2,1):mB(2,2), mB(3,1):mB(3,2)) - & 00305 buffer(mA(1,1):mA(1,2), mA(2,1):mA(2,2), mA(3,1):mA(3,2))) * tolerance > & 00306 00307 half*MAX((ABS(buffer(mB(1,1):mB(1,2), mB(2,1):mB(2,2), mB(3,1):mB(3,2))) + & 00308 ABS(buffer(mA(1,1):mA(1,2), mA(2,1):mA(2,2), mA(3,1):mA(3,2)))), MinScale)) 00309 00310 Flags(mB(1,1):mB(1,2), mB(2,1):mB(2,2), mB(3,1):mB(3,2))=.true. 00311 Flags(mA(1,1):mA(1,2), mA(2,1):mA(2,2), mA(3,1):mA(3,2))=.true. 00312 END WHERE 00313 ELSE 00314 WHERE(ABS(buffer(mB(1,1):mB(1,2), mB(2,1):mB(2,2), mB(3,1):mB(3,2)) - & 00315 buffer(mA(1,1):mA(1,2), mA(2,1):mA(2,2), mA(3,1):mA(3,2))) * tolerance > & 00316 1d0) 00317 Flags(mB(1,1):mB(1,2), mB(2,1):mB(2,2), mB(3,1):mB(3,2))=.true. 00318 Flags(mA(1,1):mA(1,2), mA(2,1):mA(2,2), mA(3,1):mA(3,2))=.true. 00319 END WHERE 00320 END IF 00321 00322 mA(i,:)=mT(i,:) 00323 mB(i,:)=mT(i,:) 00324 00325 END DO 00326 00327 END SUBROUTINE SetFlags 00328 00329 00330 END MODULE Refinements 00331