Scrambler
1
|
00001 !######################################################################### 00002 ! 00003 ! Copyright (C) 2003-2012 Department of Physics and Astronomy, 00004 ! University of Rochester, 00005 ! Rochester, NY 00006 ! 00007 ! problem.f90 of module BrioWuShockTube 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 00028 00032 00035 MODULE Problem 00036 USE DataDeclarations 00037 USE SplitRegions 00038 USE Shapes 00039 USE EOS 00040 USE Ambients 00041 USE RiemannSolvers 00042 USE Totals 00043 USE Fields 00044 IMPLICIT NONE 00045 SAVE 00046 00047 PUBLIC ProblemModuleInit, ProblemGridInit, & 00048 ProblemBeforeStep, ProblemAfterStep, ProblemSetErrFlag, ProblemBeforeGlobalStep 00049 REAL(KIND=qPREC), DIMENSION(MaxVars) :: qabove, qbelow 00050 TYPE(SplitRegionDef), POINTER :: SplitRegion 00051 REAL(KIND=qPREC) :: phi, theta, position(3) 00052 CONTAINS 00053 00055 SUBROUTINE ProblemModuleInit() 00056 TYPE(AmbientDef), POINTER :: Ambient 00057 REAL(KIND=qPREC) :: rhoOut, pOut, vxOut, vyOut, vzOut, BxOut, ByOut, BzOut 00058 TYPE(TotalDef), POINTER :: Total 00059 NAMELIST /AmbientData/ rhoOut, pOut, vxOut, vyOut, vzOut, BxOut, ByOut, BzOut 00060 NAMELIST /ProblemData/ position, phi, theta, qabove, qbelow 00061 CALL CreateAmbient(Ambient) 00062 00063 CALL CreateTotal(Total) 00064 Total%Field%Component=GASCOMP 00065 Total%Field%id=ivx 00066 Total%Field%name=FieldName(ivx) 00067 CALL CreateTotal(Total) 00068 Total%Field%Component=GASCOMP 00069 Total%Field%id=1 00070 Total%Field%name=FieldName(1) 00071 CALL CreateTotal(Total) 00072 Total%Field%Component=GASCOMP 00073 Total%Field%id=iE 00074 Total%Field%name=FieldName(iE) 00075 00076 position=(/1d-6,1d-6,0d0/) 00077 phi=Pi 00078 theta=half*Pi 00079 qabove=0 00080 qbelow=0 00081 OPEN(UNIT=PROBLEM_DATA_HANDLE, FILE='problem.data', STATUS="OLD") 00082 READ(PROBLEM_DATA_HANDLE,NML=ProblemData) 00083 CALL CreateSplitRegion(SplitRegion) 00084 SplitRegion%Shape%type=Rectangular_Prism 00085 SplitRegion%Shape%size_param=(/.5,.5,.5/) 00086 CALL SetShapeOrientation(Splitregion%Shape,0d0,0d0,0d0) 00087 CALL SetShapeBounds(splitregion%Shape) 00088 ! write(*,*) splitregion%shape%xbounds 00089 SplitRegion%InterfaceObj%position=position 00090 CALL SetInterfaceOrientation(SplitRegion%InterfaceObj, theta, phi) 00091 SplitRegion%qabove=qabove 00092 SplitRegion%qbelow=qbelow 00093 CALL prim_to_cons(SplitRegion%qabove) 00094 CALL prim_to_cons(SplitRegion%qbelow) 00095 IF (lMHD .AND. GmX(1)==GmX(2)) THEN 00096 SplitRegion%PersistInBoundaries=.true. 00097 SplitRegion%subsample=20 00098 ELSE 00099 SplitRegion%PersistInBoundaries=.false. 00100 END IF 00101 ! READ(PROBLEM_DATA_HANDLE,NML=AmbientData) 00102 ! Ambient%density=qabove(1)!rhoOut 00103 ! Ambient%pressure=qabove(2)!pOut 00104 ! Ambient%B(:)=(/BxOut, ByOut, BzOut/) 00105 ! Ambient%v(:)=(/vxOut, vyOut, vzOut/) 00106 ! CLOSE(PROBLEM_DATA_HANDLE) 00107 00108 END SUBROUTINE ProblemModuleInit 00109 00112 SUBROUTINE ProblemGridInit(Info) 00113 TYPE(InfoDef) :: Info 00114 INTEGER :: i,j 00115 IF (MaintainAuxArrays) THEN 00116 IF (Info%mx(1) > Info%mX(2)) Info%aux(1:Info%mX(1),1:Info%mx(2)+1,1,2) = SPREAD(Info%q(1:Info%mX(1),1,1,iBy),2,Info%mX(2)+1) 00117 IF (Info%mX(2) > Info%mX(1)) Info%aux(1:Info%mX(1)+1,1:Info%mx(2),1,1) = SPREAD(Info%q(1,1:Info%mX(2),1,iBx),1,Info%mX(1)+1) 00118 IF (lMHD .AND. Info%mX(1) == Info%mX(2)) THEN !Angled aux fields - need to calculate potential 00119 DO j=1, Info%mX(2) 00120 Info%aux(1:j,Info%mx(2)+1-j,1,1)=Info%q(1,1,1,iBx) 00121 Info%aux(j+1:Info%mX(1)+1,Info%mx(2)+1-j,1,1)=Info%q(Info%mX(1),Info%mX(2),1,iBx) 00122 END DO 00123 DO i=1, Info%mX(1) 00124 Info%aux(info%mx(1)+1-i,1:i,1,2)=Info%q(1,1,1,iBy) 00125 Info%aux(info%mx(1)+1-i,i+1:Info%mX(2)+1,1,2)=Info%q(Info%mX(1),Info%mX(2),1,iBy) 00126 END DO 00127 Info%q(1:Info%mX(1),1:Info%mX(2),1,iBx)=half*(Info%aux(1:Info%mX(1),1:Info%mX(2),1,1)+Info%aux(2:Info%mX(1)+1,1:Info%mX(2),1,1)) 00128 Info%q(1:Info%mX(1),1:Info%mX(2),1,iBy)=half*(Info%aux(1:Info%mX(1),1:Info%mX(2),1,2)+Info%aux(1:Info%mX(1),2:Info%mX(2)+1,1,2)) 00129 END IF 00130 END IF 00131 END SUBROUTINE ProblemGridInit 00132 00135 SUBROUTINE ProblemBeforeStep(Info) 00136 TYPE(InfoDef) :: Info 00137 INTEGER :: rmbc,i,j 00138 REAL(KIND=qPREC), DIMENSION(:,:,:), POINTER :: tempaux 00139 rmbc=levels(Info%level)%gmbc(1) 00140 IF (lMHD .AND. nDim == 2 .AND. Info%mX(1) == Info%mX(2)) THEN !Angled aux fields - need to calculate potential 00141 ALLOCATE(tempaux(1:Info%mX(1)+1,1:Info%mX(2)+1,2)) 00142 tempaux=Info%aux(1:Info%mX(1)+1,1:Info%mX(2)+1,1,1:2) 00143 00144 DO j=-rmbc, Info%mX(2)+rmbc 00145 Info%aux(1-rmbc:j,Info%mx(2)+1-j,1,1)=Info%q(1,1,1,iBx) 00146 Info%aux(j+1:Info%mX(1)+1+rmbc,Info%mx(2)+1-j,1,1)=Info%q(Info%mX(1),Info%mX(2),1,iBx) 00147 END DO 00148 DO i=1-rmbc, Info%mX(1)+rmbc 00149 Info%aux(info%mx(1)+1-i,1-rmbc:i,1,2)=Info%q(1,1,1,iBy) 00150 Info%aux(info%mx(1)+1-i,i+1:Info%mX(2)+1+rmbc,1,2)=Info%q(Info%mX(1),Info%mX(2),1,iBy) 00151 END DO 00152 Info%aux(1:Info%mX(1)+1,1:Info%mX(2),1,1)=tempaux(1:Info%mX(1)+1,1:Info%mX(2),1) 00153 Info%aux(1:Info%mX(1),1:Info%mX(2)+1,1,2)=tempaux(1:Info%mX(1),1:Info%mX(2)+1,2) 00154 00155 Info%q(1-rmbc:Info%mX(1)+rmbc,1-rmbc:Info%mX(2)+rmbc,1,iBx)=half*(Info%aux(1-rmbc:Info%mX(1)+rmbc,1-rmbc:Info%mX(2)+rmbc,1,1)+Info%aux(2-rmbc:Info%mX(1)+1+rmbc,1-rmbc:Info%mX(2)+rmbc,1,1)) 00156 Info%q(1-rmbc:Info%mX(1)+rmbc,1-rmbc:Info%mX(2)+rmbc,1,iBy)=half*(Info%aux(1-rmbc:Info%mX(1)+rmbc,1-rmbc:Info%mX(2)+rmbc,1,2)+Info%aux(1-rmbc:Info%mX(1)+rmbc,2-rmbc:Info%mX(2)+1+rmbc,1,2)) 00157 DEALLOCATE(tempaux) 00158 END IF 00159 00160 END SUBROUTINE ProblemBeforeStep 00161 00164 SUBROUTINE ProblemAfterStep(Info) 00165 TYPE(InfoDef) :: Info 00166 INTEGER :: i,j 00167 REAL(KIND=qPREC), ALLOCATABLE, DIMENSION(:,:) :: qExact 00168 REAL(KIND=qPREC) :: um, s, max_speed, x, rho 00169 REAL(KIND=qPREC), ALLOCATABLE, DIMENSION(:) :: wmiddle 00170 IF (levels(info%level)%tnow+levels(info%level)%dt == final_time) THEN 00171 OPEN(UNIT=11, FILE='out/data.curve', status='unknown') 00172 write(11,*) '# rho' 00173 DO i=1, Info%mX(1) 00174 IF (Info%mX(2) /= Info%mX(1)) write(11,*) Info%xbounds(1,1)+(REAL(i)-half)*levels(Info%level)%dx, Info%q(i,1,1,1) 00175 IF (Info%mX(1)==Info%mX(2)) write(11,*) Info%xbounds(1,1)+(REAL(i)-half)*levels(Info%level)%dx*sqrt(2d0), Info%q(i,i,1,1) 00176 END DO 00177 write(11,*) 00178 write(11,*) 00179 write(11,*) '# vx' 00180 DO i=1, Info%mX(1) 00181 IF (Info%mX(2) /= Info%mX(1)) write(11,*) Info%xbounds(1,1)+(REAL(i)-half)*levels(Info%level)%dx, Info%q(i,1,1,ivx)/Info%q(i,1,1,1) 00182 IF (Info%mX(1)==Info%mX(2)) write(11,*) Info%xbounds(1,1)+(REAL(i)-half)*levels(Info%level)%dx*sqrt(2d0), Info%q(i,i,1,ivx)/Info%q(i,i,1,1) 00183 END DO 00184 write(11,*) 00185 write(11,*) 00186 write(11,*) '# P' 00187 DO i=1, Info%mX(1) 00188 IF (Info%mX(2) /= Info%mX(1)) write(11,*) Info%xbounds(1,1)+(REAL(i)-half)*levels(Info%level)%dx, (Press(Info%q(i,1,1,:))) 00189 IF (Info%mX(1)==Info%mX(2)) write(11,*) Info%xbounds(1,1)+(REAL(i)-half)*levels(Info%level)%dx*sqrt(2d0), (Press(Info%q(i,i,1,:))) 00190 END DO 00191 write(11,*) 00192 write(11,*) 00193 00194 IF (lMHD) THEN 00195 write(11,*) '# vy' 00196 DO i=1, Info%mX(1) 00197 IF (Info%mX(2) /= Info%mX(1)) write(11,*) Info%xbounds(1,1)+(REAL(i)-half)*levels(Info%level)%dx, Info%q(i,1,1,ivy)/Info%q(i,1,1,1) 00198 IF (Info%mX(1)==Info%mX(2)) write(11,*) Info%xbounds(1,1)+(REAL(i)-half)*levels(Info%level)%dx*sqrt(2d0), Info%q(i,i,1,ivy)/Info%q(i,i,1,1) 00199 END DO 00200 write(11,*) 00201 write(11,*) 00202 write(11,*) '# vz' 00203 DO i=1, Info%mX(1) 00204 IF (Info%mX(2) /= Info%mX(1)) write(11,*) Info%xbounds(1,1)+(REAL(i)-half)*levels(Info%level)%dx, Info%q(i,1,1,ivz)/Info%q(i,1,1,1) 00205 IF (Info%mX(1)==Info%mX(2)) write(11,*) Info%xbounds(1,1)+(REAL(i)-half)*levels(Info%level)%dx*sqrt(2d0), Info%q(i,i,1,ivz)/Info%q(i,i,1,1) 00206 END DO 00207 write(11,*) 00208 write(11,*) 00209 write(11,*) '# Bx' 00210 DO i=1, Info%mX(1) 00211 IF (Info%mX(2) /= Info%mX(1)) write(11,*) Info%xbounds(1,1)+(REAL(i)-half)*levels(Info%level)%dx, Info%q(i,1,1,iBx) 00212 IF (Info%mX(1)==Info%mX(2)) write(11,*) Info%xbounds(1,1)+(REAL(i)-half)*levels(Info%level)%dx*sqrt(2d0), Info%q(i,i,1,iBx) 00213 END DO 00214 write(11,*) 00215 write(11,*) 00216 write(11,*) '# By' 00217 DO i=1, Info%mX(1) 00218 IF (Info%mX(2) /= Info%mX(1)) write(11,*) Info%xbounds(1,1)+(REAL(i)-half)*levels(Info%level)%dx, Info%q(i,1,1,iBy) 00219 IF (Info%mX(1)==Info%mX(2)) write(11,*) Info%xbounds(1,1)+(REAL(i)-half)*levels(Info%level)%dx*sqrt(2d0), Info%q(i,i,1,iBy) 00220 END DO 00221 write(11,*) 00222 write(11,*) 00223 write(11,*) '# Bz' 00224 DO i=1, Info%mX(1) 00225 IF (Info%mX(2) /= Info%mX(1)) write(11,*) Info%xbounds(1,1)+(REAL(i)-half)*levels(Info%level)%dx, Info%q(i,1,1,iBz) 00226 IF (Info%mX(1)==Info%mX(2)) write(11,*) Info%xbounds(1,1)+(REAL(i)-half)*levels(Info%level)%dx*sqrt(2d0), Info%q(i,i,1,iBz) 00227 END DO 00228 write(11,*) 00229 write(11,*) 00230 ALLOCATE(qExact(Info%mX(1), 1)) 00231 OPEN(UNIT=12, FILE='exact.curve', STATUS="OLD") 00232 READ(12, *) 00233 j=0 00234 DO i=1, Info%mX(1) 00235 DO while (j < 10000) 00236 READ(12,*) x, rho 00237 j=j+1 00238 IF (Info%mX(2) /= Info%mX(1)) THEN 00239 IF (x >= Info%xBounds(1,1)+(real(i)-half)*levels(Info%level)%dx) THEN 00240 qExact(i,1)=rho 00241 EXIT 00242 END IF 00243 ELSEIF (Info%mX(1)==Info%mX(2)) THEN 00244 IF (x >= Info%xBounds(1,1)+(real(i)-half)*levels(Info%level)%dx*sqrt(2d0)) THEN 00245 qExact(i,1)=rho 00246 EXIT 00247 END IF 00248 END IF 00249 END DO 00250 END DO 00251 CLOSE(12) 00252 IF (Info%mX(2) /= Info%mX(1)) write(*,*) 'dx, L2 Norm=', levels(Info%level)%dx, sum(abs(qExact(:,1)-Info%q(1:Info%mX(1),1,1,1)))/Info%mX(1) 00253 00254 ELSE 00255 ALLOCATE(qExact(Info%mX(1), NrHydroVars)) 00256 ALLOCATE(wmiddle(1:NrHydroVars)) 00257 DO i=1, Info%mX(1) 00258 S=(Info%xBounds(1,1)+(REAL(i)-half)*Levels(Info%level)%dx-position(1))/final_time 00259 IF (Info%mX(1)==Info%mX(2)) S=S*sqrt(2d0) 00260 CALL vacuum_solve(qabove((/1,3,2/)), qbelow((/1,3,2/)), wmiddle, um, s, max_speed) 00261 qExact(i,:)=wmiddle 00262 END DO 00263 write(11,*) '# rho_Exact' 00264 DO i=1, Info%mX(1) 00265 write(11,*) Info%xbounds(1,1)+(REAL(i)-half)*levels(Info%level)%dx, qExact(i,1) 00266 END DO 00267 write(11,*) 00268 write(11,*) 00269 write(11,*) '# vx_Exact' 00270 DO i=1, Info%mX(1) 00271 write(11,*) Info%xbounds(1,1)+(REAL(i)-half)*levels(Info%level)%dx, qExact(i,3) 00272 END DO 00273 write(11,*) 00274 write(11,*) 00275 write(11,*) '# P_Exact' 00276 DO i=1, Info%mX(1) 00277 write(11,*) Info%xbounds(1,1)+(REAL(i)-half)*levels(Info%level)%dx, qExact(i,2) 00278 END DO 00279 CLOSE(11) 00280 IF (Info%mX(2) /= Info%mX(1)) write(*,*) 'dx, L2 Norm=', levels(Info%level)%dx, sum(abs(qExact(:,1)-Info%q(1:Info%mX(1),1,1,1)))/Info%mX(1) 00281 IF (Info%mX(1)==Info%mX(2)) write(*,*) 'dx, L2 Norm=', levels(Info%level)%dx, sum(abs(qExact(:,1)-(/(Info%q(i,i,1,1), i=1,Info%mX(1))/)))/Info%mX(1) 00282 END IF 00283 END IF 00284 00285 END SUBROUTINE ProblemAfterStep 00286 00289 SUBROUTINE ProblemSetErrFlag(Info) 00290 TYPE(InfoDef) :: Info 00291 END SUBROUTINE ProblemSetErrFlag 00292 00293 SUBROUTINE ProblemBeforeGlobalStep(n) 00294 INTEGER :: n 00295 END SUBROUTINE ProblemBeforeGlobalStep 00296 00297 END MODULE Problem 00298