Scrambler  1
EinfeldtRarefaction/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 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 
 All Classes Files Functions Variables