Scrambler  1
refinements.f90
Go to the documentation of this file.
00001 !#########################################################################
00002 !               
00003 !    Copyright (C) 2003-2012 Department of Physics and Astronomy,
00004 !                            University of Rochester,
00005 !                            Rochester, NY
00006 !
00007 !    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 
 All Classes Files Functions Variables