Scrambler  1
BrioWuShockTube/problem.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 !    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 
 All Classes Files Functions Variables