Scrambler
1
|
00001 !######################################################################### 00002 ! 00003 ! Copyright (C) 2003-2012 Department of Physics and Astronomy, 00004 ! University of Rochester, 00005 ! Rochester, NY 00006 ! 00007 ! uniformregions.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 00036 00039 MODULE Uniformregions 00040 USE GlobalDeclarations 00041 USE DataDeclarations 00042 USE PhysicsDeclarations 00043 USE DataInfoOps 00044 USE Shapes 00045 USE ObjectDeclarations 00046 IMPLICIT NONE 00048 TYPE UniformRegionDef 00049 TYPE(ShapeDef), POINTER :: Shape => null() 00050 REAL(KIND=qPREC), DIMENSION(:), ALLOCATABLE :: q 00051 INTEGER :: SubSample=1 00052 LOGICAL :: PersistInBoundaries(3,2) = .false. 00053 LOGICAL :: PersistInternal = .false. 00054 INTEGER :: ObjId 00055 END TYPE UniformRegionDef 00056 00057 !new declaration 00058 TYPE pUniformRegionDef 00059 TYPE(UniformRegionDef), POINTER :: ptr 00060 END TYPE pUniformRegionDef 00061 TYPE(pUniformRegionDef) :: pUniformRegion 00062 ! 00063 00064 !TYPE(UniformRegionDef), POINTER :: FirstUniformRegion, LastUniformRegion 00065 SAVE 00066 CONTAINS 00067 00068 00071 SUBROUTINE CreateUniformRegion(UniformRegion, Shape) 00072 TYPE(UniformRegionDef), POINTER :: UniformRegion 00073 TYPE(ShapeDef), POINTER, OPTIONAL :: Shape 00074 ALLOCATE(UniformRegion) 00075 IF (Present(Shape)) THEN 00076 UniformRegion%Shape => Shape 00077 ELSE 00078 ALLOCATE(UniformRegion%Shape) 00079 ENDIF 00080 ALLOCATE(UniformRegion%q(NrHydroVars)) 00081 CALL AddUniformRegionToList(UniformRegion) 00082 END SUBROUTINE CreateUniformRegion 00083 00084 SUBROUTINE UpdateUniformRegion(UniformRegion) 00085 TYPE(UniformRegionDef), POINTER :: UniformRegion 00086 !update attributes that needs to be updated, 00087 !if any 00088 END SUBROUTINE UpdateUniformRegion 00089 00090 SUBROUTINE AddUniformRegionToList(UniformRegion) 00091 TYPE(UniformRegionDef), POINTER :: UniformRegion 00092 TYPE(ObjectDef), POINTER :: Object 00093 UniformRegion%ObjId = ObjectListAdd(Object,UniformRegionOBJ) 00094 pUniformRegion%ptr => UniformRegion 00095 len = size(transfer(pUniformRegion, dummy_char)) 00096 ALLOCATE(Object%storage(len)) 00097 Object%storage = transfer(pUniformRegion,Object%storage) 00098 END SUBROUTINE AddUniformRegionToList 00099 00100 00101 SUBROUTINE DestroyUniformRegionObject(UniformRegionObj) 00102 TYPE(UniformRegionDef),POINTER :: UniformRegionObj 00103 CALL ObjectListRemove(UniformRegionObj%ObjId) 00104 DEALLOCATE(UniformRegionObj%q) 00105 DEALLOCATE(UniformRegionObj%Shape) 00106 DEALLOCATE(UniformRegionObj) 00107 NULLIFY(UniformRegionObj) 00108 END SUBROUTINE DestroyUniformRegionObject 00109 00110 00111 00112 SUBROUTINE UniformRegionGridInit(Info, UniformRegion) 00113 TYPE(InfoDef) :: Info 00114 TYPE(UniformRegionDef), POINTER :: UniformRegion 00115 INTEGER, POINTER, DIMENSION(:,:,:) :: mSs 00116 REAL(KIND=qPREC), POINTER, DIMENSION(:,:) :: offsets 00117 INTEGER :: nOverlaps 00118 CALL CalcPhysicalOverlaps(Info, UniformRegion%Shape%xBounds, mSs, nOverlaps, offsets, IEVERYWHERE, lHydroPeriodic) 00119 IF (nOverlaps > 0) THEN 00120 CALL PlaceUniformRegion(Info, UniformRegion, nOverlaps, mSs, offsets) 00121 DEALLOCATE(mSs, offsets) 00122 END IF 00123 END SUBROUTINE UniformRegionGridInit 00124 00125 00126 SUBROUTINE UniformRegionBeforeStep(Info, UniformRegion) 00127 TYPE(InfoDef) :: Info 00128 TYPE(UniformRegionDef), POINTER :: UniformRegion 00129 INTEGER, POINTER, DIMENSION(:,:,:) :: mSs 00130 REAL(KIND=qPREC), POINTER, DIMENSION(:,:) :: offsets 00131 INTEGER :: nOverlaps 00132 INTEGER :: i,j 00133 DO i=1,nDim 00134 DO j=1,2 00135 IF (UniformRegion%PersistInBoundaries(i,j)) THEN 00136 CALL CalcPhysicalOverlaps(Info, UniformRegion%Shape%xBounds, mSs, nOverlaps, offsets, IBOUNDARY(i,j), lHydroPeriodic) 00137 IF (nOverlaps > 0) THEN 00138 CALL PlaceUniformRegion(Info, UniformRegion, nOverlaps, mSs, offsets) 00139 DEALLOCATE(mSs, offsets) 00140 END IF 00141 END IF 00142 END DO 00143 END DO 00144 END SUBROUTINE UniformRegionBeforeStep 00145 00146 SUBROUTINE UniformRegionSetErrFlag(Info, UniformRegion) 00147 TYPE(InfoDef) :: Info 00148 Type(UniformRegionDef), POINTER :: UniformRegion 00149 END SUBROUTINE UniformRegionSetErrFlag 00150 00151 SUBROUTINE UniformRegionBeforeGlobalStep(n) 00152 INTEGER :: n 00153 END SUBROUTINE UniformRegionBeforeGlobalStep 00154 00155 SUBROUTINE PlaceUniformRegion(Info, UniformRegion, nOverlaps, mSs, offsets) 00156 TYPE(InfoDef) :: Info 00157 Type(UniformRegionDef) :: UniformRegion 00158 INTEGER :: i,j,k,n,m,ii,jj,kk, location 00159 INTEGER, DIMENSION(3,2) :: mS 00160 INTEGER, POINTER, DIMENSION(:,:,:) :: mSs 00161 REAL(KIND=qPREC), DIMENSION(3) :: offset 00162 REAL(KIND=qPREC), POINTER, DIMENSION(:,:) :: offsets 00163 REAL(KIND=qPREC), DIMENSION(3) :: xpos, pos,coords 00164 REAL(KIND=qPREC) :: sample_fact(3), q_fact, dx, xBounds(3,2) 00165 INTEGER :: sample_res(3), nOverlaps 00166 REAL(KIND=qPREC), DIMENSION(:), ALLOCATABLE :: q_source 00167 00168 dx=levels(Info%level)%dX 00169 xpos=0 00170 IF (nOverlaps > 0) THEN 00171 sample_res=1 00172 sample_fact=0d0 00173 sample_res(1:nDim)=UniformRegion%SubSample!min(2**(MaxLevel-Info%level),4) 00174 sample_fact(1:nDim)=1d0/REAL(sample_res(1:nDim),8) 00175 q_fact=product(sample_fact(1:nDim)) 00176 ALLOCATE(q_Source(NrHydroVars)) 00177 DO n=1,nOverlaps 00178 mS=mSs(n,:,:) 00179 offset=offsets(n,:) 00180 ! Now set up cell centered quantities (density and momentum) 00181 DO k=mS(3,1),mS(3,2) 00182 xpos(3)=Info%xBounds(3,1)+offset(3)+(k-1)*dx 00183 DO j=mS(2,1),mS(2,2) 00184 xpos(2)=Info%xBounds(2,1)+offset(2)+(j-1)*dx 00185 DO i=mS(1,1),mS(1,2) 00186 xpos(1)=Info%xBounds(1,1)+offset(1)+(i-1)*dx 00187 q_Source=0 00188 DO kk=1,sample_res(3) 00189 pos(3)=xpos(3)+(REAL(kk, 8)-half)*dx*sample_fact(3) 00190 DO jj=1,sample_res(2) 00191 pos(2)=xpos(2)+(REAL(jj, 8)-half)*dx*sample_fact(2) 00192 DO ii=1,sample_res(1) 00193 pos(1)=xpos(1)+(REAL(ii, 8)-half)*dx*sample_fact(1) 00194 IF (IsInShape(UniformRegion%Shape, pos, coords)) THEN 00195 q_source=q_source+(UniformRegion%q-Info%q(i,j,k,1:NrHydroVars)) 00196 END IF 00197 END DO 00198 END DO 00199 END DO 00200 Info%q(i,j,k,1:NrHydroVars)=Info%q(i,j,k,1:NrHydroVars)+q_source*q_fact 00201 END DO 00202 END DO 00203 END DO 00204 END DO 00205 DEALLOCATE(q_Source) 00206 END IF 00207 00208 00209 END SUBROUTINE PlaceUniformRegion 00210 00211 END MODULE UniformRegions 00212 00213