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 EinfeldtRarefaction 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 CALL CreateTotal(Total) 00063 Total%Field%Component=GASCOMP 00064 Total%Field%id=ivx 00065 Total%Field%name=FieldName(ivx) 00066 CALL CreateTotal(Total) 00067 Total%Field%Component=GASCOMP 00068 Total%Field%id=1 00069 Total%Field%name=FieldName(1) 00070 CALL CreateTotal(Total) 00071 Total%Field%Component=GASCOMP 00072 Total%Field%id=iE 00073 Total%Field%name=FieldName(iE) 00074 00075 position=(/1d-6,1d-6,0d0/) 00076 phi=Pi 00077 theta=half*Pi 00078 qabove=0 00079 qbelow=0 00080 OPEN(UNIT=PROBLEM_DATA_HANDLE, FILE='problem.data', STATUS="OLD") 00081 READ(PROBLEM_DATA_HANDLE,NML=ProblemData) 00082 CALL CreateSplitRegion(SplitRegion) 00083 SplitRegion%Shape%type=Rectangular_Prism 00084 SplitRegion%Shape%size_param=(/.5,.5,.5/) 00085 CALL SetShapeOrientation(Splitregion%Shape,0d0,0d0,0d0) 00086 CALL SetShapeBounds(splitregion%Shape) 00087 ! write(*,*) splitregion%shape%xbounds 00088 SplitRegion%InterfaceObj%position=position 00089 CALL SetInterfaceOrientation(SplitRegion%InterfaceObj, theta, phi) 00090 SplitRegion%qabove=qabove 00091 SplitRegion%qbelow=qbelow 00092 CALL prim_to_cons(SplitRegion%qabove) 00093 CALL prim_to_cons(SplitRegion%qbelow) 00094 IF (lMHD .AND. GmX(1)==GmX(2)) THEN 00095 SplitRegion%PersistInBoundaries=.true. 00096 SplitRegion%subsample=20 00097 ELSE 00098 SplitRegion%PersistInBoundaries=.false. 00099 END IF 00100 ! READ(PROBLEM_DATA_HANDLE,NML=AmbientData) 00101 ! Ambient%density=qabove(1)!rhoOut 00102 ! Ambient%pressure=qabove(2)!pOut 00103 ! Ambient%B(:)=(/BxOut, ByOut, BzOut/) 00104 ! Ambient%v(:)=(/vxOut, vyOut, vzOut/) 00105 ! CLOSE(PROBLEM_DATA_HANDLE) 00106 00107 END SUBROUTINE ProblemModuleInit 00108 00111 SUBROUTINE ProblemGridInit(Info) 00112 TYPE(InfoDef) :: Info 00113 INTEGER :: i,j 00114 IF (MaintainAuxArrays) THEN 00115 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) 00116 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) 00117 IF (lMHD .AND. Info%mX(1) == Info%mX(2)) THEN !Angled aux fields - need to calculate potential 00118 DO j=1, Info%mX(2) 00119 Info%aux(1:j,Info%mx(2)+1-j,1,1)=Info%q(1,1,1,iBx) 00120 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) 00121 END DO 00122 DO i=1, Info%mX(1) 00123 Info%aux(info%mx(1)+1-i,1:i,1,2)=Info%q(1,1,1,iBy) 00124 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) 00125 END DO 00126 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)) 00127 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)) 00128 END IF 00129 END IF 00130 END SUBROUTINE ProblemGridInit 00131 00134 SUBROUTINE ProblemBeforeStep(Info) 00135 TYPE(InfoDef) :: Info 00136 INTEGER :: rmbc,i,j 00137 REAL(KIND=qPREC), DIMENSION(:,:,:), POINTER :: tempaux 00138 rmbc=levels(Info%level)%gmbc(1) 00139 IF (lMHD .AND. nDim == 2 .AND. Info%mX(1) == Info%mX(2)) THEN !Angled aux fields - need to calculate potential 00140 ALLOCATE(tempaux(1:Info%mX(1)+1,1:Info%mX(2)+1,2)) 00141 tempaux=Info%aux(1:Info%mX(1)+1,1:Info%mX(2)+1,1,1:2) 00142 00143 DO j=-rmbc, Info%mX(2)+rmbc 00144 Info%aux(1-rmbc:j,Info%mx(2)+1-j,1,1)=Info%q(1,1,1,iBx) 00145 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) 00146 END DO 00147 DO i=1-rmbc, Info%mX(1)+rmbc 00148 Info%aux(info%mx(1)+1-i,1-rmbc:i,1,2)=Info%q(1,1,1,iBy) 00149 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) 00150 END DO 00151 Info%aux(1:Info%mX(1)+1,1:Info%mX(2),1,1)=tempaux(1:Info%mX(1)+1,1:Info%mX(2),1) 00152 Info%aux(1:Info%mX(1),1:Info%mX(2)+1,1,2)=tempaux(1:Info%mX(1),1:Info%mX(2)+1,2) 00153 00154 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)) 00155 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)) 00156 DEALLOCATE(tempaux) 00157 END IF 00158 00159 END SUBROUTINE ProblemBeforeStep 00160 00163 SUBROUTINE ProblemAfterStep(Info) 00164 TYPE(InfoDef) :: Info 00165 INTEGER :: i 00166 REAL(KIND=qPREC), ALLOCATABLE, DIMENSION(:,:) :: qExact 00167 REAL(KIND=qPREC) :: um, s, max_speed 00168 REAL(KIND=qPREC), ALLOCATABLE, DIMENSION(:) :: wmiddle 00169 IF (levels(info%level)%tnow+levels(info%level)%dt == final_time) THEN 00170 OPEN(UNIT=11, FILE='out/data.curve', status='unknown') 00171 write(11,*) '# rho' 00172 DO i=1, Info%mX(1) 00173 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) 00174 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) 00175 END DO 00176 write(11,*) 00177 write(11,*) 00178 write(11,*) '# vx' 00179 DO i=1, Info%mX(1) 00180 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) 00181 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) 00182 END DO 00183 write(11,*) 00184 write(11,*) 00185 write(11,*) '# P' 00186 DO i=1, Info%mX(1) 00187 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,:))) 00188 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,:))) 00189 END DO 00190 write(11,*) 00191 write(11,*) 00192 00193 IF (lMHD) THEN 00194 write(11,*) '# vy' 00195 DO i=1, Info%mX(1) 00196 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) 00197 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) 00198 END DO 00199 write(11,*) 00200 write(11,*) 00201 write(11,*) '# vz' 00202 DO i=1, Info%mX(1) 00203 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) 00204 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) 00205 END DO 00206 write(11,*) 00207 write(11,*) 00208 write(11,*) '# Bx' 00209 DO i=1, Info%mX(1) 00210 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) 00211 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) 00212 END DO 00213 write(11,*) 00214 write(11,*) 00215 write(11,*) '# By' 00216 DO i=1, Info%mX(1) 00217 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) 00218 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) 00219 END DO 00220 write(11,*) 00221 write(11,*) 00222 write(11,*) '# Bz' 00223 DO i=1, Info%mX(1) 00224 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) 00225 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) 00226 END DO 00227 write(11,*) 00228 write(11,*) 00229 ELSE 00230 ALLOCATE(qExact(Info%mX(1), NrHydroVars)) 00231 ALLOCATE(wmiddle(1:NrHydroVars)) 00232 DO i=1, Info%mX(1) 00233 S=(Info%xBounds(1,1)+(REAL(i)-half)*Levels(Info%level)%dx-position(1))/final_time 00234 IF (Info%mX(1)==Info%mX(2)) S=S*sqrt(2d0) 00235 CALL vacuum_solve(qabove((/1,3,2/)), qbelow((/1,3,2/)), wmiddle, um, s, max_speed) 00236 qExact(i,:)=wmiddle 00237 END DO 00238 write(11,*) '# rho_Exact' 00239 DO i=1, Info%mX(1) 00240 write(11,*) Info%xbounds(1,1)+(REAL(i)-half)*levels(Info%level)%dx, qExact(i,1) 00241 END DO 00242 write(11,*) 00243 write(11,*) 00244 write(11,*) '# vx_Exact' 00245 DO i=1, Info%mX(1) 00246 write(11,*) Info%xbounds(1,1)+(REAL(i)-half)*levels(Info%level)%dx, qExact(i,3) 00247 END DO 00248 write(11,*) 00249 write(11,*) 00250 write(11,*) '# P_Exact' 00251 DO i=1, Info%mX(1) 00252 write(11,*) Info%xbounds(1,1)+(REAL(i)-half)*levels(Info%level)%dx, qExact(i,2) 00253 END DO 00254 CLOSE(11) 00255 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) 00256 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) 00257 END IF 00258 END IF 00259 00260 END SUBROUTINE ProblemAfterStep 00261 00264 SUBROUTINE ProblemSetErrFlag(Info) 00265 TYPE(InfoDef) :: Info 00266 END SUBROUTINE ProblemSetErrFlag 00267 00268 SUBROUTINE ProblemBeforeGlobalStep(n) 00269 INTEGER :: n 00270 END SUBROUTINE ProblemBeforeGlobalStep 00271 00272 END MODULE Problem 00273