Scrambler  1
conductive.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 !    conductive.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 !#########################################################################
00023 MODULE ConductiveSrc
00024    USE GlobalDeclarations
00025    USE TreeDeclarations
00026    USE DataDeclarations
00027    USE ExplicitDeclarations
00028    USE PhysicsDeclarations
00029    USE EOS
00030 
00031    REAL(KIND=qPREC), DIMENSION(3,3), PARAMETER :: az = RESHAPE((/4.0,3.0,2.0,
00032       0.765270225971218, 0.724613694800218, 0.647648420009554, 
00033       0.084729774028782, 0.125386305199781, 0.20235157990446/),(/3,3/))
00034 
00035  CONTAINS   
00036    
00037    SUBROUTINE ConductiveGridAdvance(n,stepping)
00038      INTEGER :: n,stepping
00039      TYPE(NodeDef), POINTER :: node
00040      TYPE(NodeDefList), POINTER :: nodelist        
00041      IF(mpi_id==0)THEN
00042         PRINT*, "Advancing Conductive Solver on Grid..."
00043      END IF
00044      nodelist=>nodes(n)%p
00045      DO WHILE (associated(nodelist))
00046         node=>nodelist%self
00047         CALL ConductiveSource(n,node%info,stepping)
00048         nodelist=>nodelist%next
00049      END DO
00050 
00051    END SUBROUTINE ConductiveGridAdvance
00052 
00053    SUBROUTINE ConductiveGridGetMaxSpeed(n)
00054      INTEGER :: n
00055      TYPE(NodeDef), POINTER :: node
00056      TYPE(NodeDefList), POINTER :: nodelist
00057      
00058      nodelist=>Nodes(n)%p 
00059      DO WHILE (associated(nodelist))
00060         node=>nodelist%self 
00061         CALL ConductiveGetMaxSpeed(node%info)
00062         nodelist=>nodelist%next 
00063      END DO
00064      
00065    END SUBROUTINE ConductiveGridGetMaxSpeed
00066 
00067 
00068    SUBROUTINE ConductiveSource(n,Info,stepping)
00069      TYPE(InfoDef) :: Info
00070      INTEGER :: i,j,k,stepping,n,mx,my,mz,mbc,zmbc
00071      INTEGER :: msx(3,2),msy(3,2),msz(3,2)
00072      INTEGER :: efield(1)
00073      LOGICAL :: ndim3
00074      REAL(KIND=qPREC) :: dx,dt,deltaT,chic,chir
00075      REAL(KIND=qPREC), ALLOCATABLE, DIMENSION(:,:,:,:) :: qx, qy, qz
00076      REAL(KIND=qPrec) :: fb(3), diT(3)
00077      mx=Info%mX(1);my=Info%mX(2);mz=Info%mX(3)
00078      mbc=levels(n)%ambc(levels(n)%step)-stepping
00079      ndim3=.false.
00080      SELECT CASE(nDim)
00081      CASE(2)
00082         zmbc=0
00083      CASE(3)
00084         zmbc=mbc; ndim3=.true.
00085      END SELECT
00086      dx=levels(n)%dx; dt=levels(n)%dt; efield=iE
00087      
00088      msx=reshape((/1-mbc,mx+mbc+1,1-mbc,my+mbc,1-zmbc,mz+zmbc/),(/3,2/))
00089      msy=reshape((/1-mbc,mx+mbc,1-mbc,my+mbc+1,1-zmbc,mz+zmbc/),(/3,2/))
00090      IF(ndim3) msz=reshape((/1-mbc,mx+mbc,1-mbc,my+mbc,1-zmbc,mz+zmbc+1/),(/3,2/))
00091      
00092      
00093      ALLOCATE(qx(1-mbc:mx+mbc+1,1-mbc:my+mbc,1-zmbc:mz+zmbc,1))
00094      ALLOCATE(qy(1-mbc:mx+mbc,1-mbc:my+mbc+1,1-zmbc:mz+zmbc,1))
00095      IF(ndim3) ALLOCATE(qz(1-mbc:mx+mbc,1-mbc:my+mbc,1-zmbc:mz+zmbc+1,1))
00096 
00097      DO i=1-mbc,mx+mbc+1; DO j=1-mbc,my+mbc; DO k=1-zmbc,mz+zmbc
00098         CALL FindFacedTdx(Info,diT,i,j,k,1)
00099         CALL FindFaceB(Info,fb,i,j,k,1)
00100         CALL FindConductivity(Info,chic,chir,i,j,k,1)
00101         !PRINT*, "qx", i,j,k,diT(:)
00102         qx(i,j,k,1) = -chic*fb(1)*(fb(1)*diT(1)+fb(2)*diT(2))-chir*diT(1)
00103         IF(ndim3) qx(i,j,k,1)=qx(i,j,k,1)-chic*fb(1)*fb(3)*diT(3)
00104         IF(lThermalFluxLimiter) CALL FindSaturationFlux(Info,i,j,k,fb,qx(i,j,k,1),1)
00105         IF((lIsoDiff).and.(ConType<2)) qx(i,j,k,1) = qx(i,j,k,1)-chic*isodiffratio*diT(1)
00106      END DO; END DO; END DO
00107      DO i=1-mbc,mx+mbc; DO j=1-mbc,my+mbc+1; DO k=1-zmbc,mz+zmbc
00108         CALL FindFacedTdx(Info,diT,i,j,k,2)
00109         CALL FindFaceB(Info,fb,i,j,k,2)
00110         CALL FindConductivity(Info,chic,chir,i,j,k,2)
00111         !PRINT*, "qy", i,j,k,diT(:)
00112         qy(i,j,k,1) = -chic*fb(2)*(fb(1)*diT(1)+fb(2)*diT(2))-chir*diT(2)
00113         IF(ndim3) qy(i,j,k,1)=qy(i,j,k,1)-chic*fb(2)*fb(3)*diT(3)
00114         IF(lThermalFluxLimiter) CALL FindSaturationFlux(Info,i,j,k,fb,qy(i,j,k,1),2)
00115         IF((lIsoDiff).and.(ConType<2)) qy(i,j,k,1) = qy(i,j,k,1)-chic*isodiffratio*diT(2)
00116      END DO; END DO; END DO
00117      IF(ndim3) THEN
00118         DO i=1-mbc,mx+mbc; DO j=1-mbc,my+mbc; DO k=1-zmbc,mz+zmbc+1
00119            CALL FindFacedTdx(Info,diT,i,j,k,3)
00120            CALL FindFaceB(Info,fb,i,j,k,3)
00121            CALL FindConductivity(Info,chic,chir,i,j,k,3)
00122            qz(i,j,k,1) = -chic*fb(3)*(fb(1)*diT(1)+fb(2)*diT(2)+fb(3)*diT(3))-chir*diT(3)
00123            IF(lThermalFluxLimiter) CALL FindSaturationFlux(Info,i,j,k,fb,qz(i,j,k,1),3)
00124            IF((lIsoDiff).and.(ConType<2)) qz(i,j,k,1) = qz(i,j,k,1)-chic*isodiffratio*diT(3)
00125         END DO; END DO; END DO
00126      END IF
00127      
00128      CALL storefixupfluxes(Info,msx,1,qx,efield)
00129      CALL storefixupfluxes(Info,msy,2,qy,efield)
00130      IF(ndim3) CALL storefixupfluxes(Info,msz,3,qz,efield)
00131      
00132      DO i=1-mbc,mx+mbc; DO j=1-mbc,my+mbc; DO k=1-zmbc,mz+zmbc
00133         deltaT=(dt/dx)*(qx(i+1,j,k,1)-qx(i,j,k,1)+qy(i,j+1,k,1)-qy(i,j,k,1))
00134         IF(ndim3) deltaT=deltaT+(dt/dx)*(qz(i,j,k+1,1)-qz(i,j,k,1))
00135         !PRINT*, "Ratio of Change is: ", i,j,(Info%q(i,j,k,1)*deltaT/(gamma-1d0))/Info%q(i,j,k,iE)
00136         Info%q(i,j,k,iE)=Info%q(i,j,k,iE)-Info%q(i,j,k,1)*deltaT/(gamma-1d0)
00137      END DO; END DO; END DO
00138 
00139     ! DO i=1,mx; DO j=1,my
00140     !    PRINT*, i,j,qx(i,j,1,1),qy(i,j,1,1)
00141     ! END DO; END DO
00142      
00143      DEALLOCATE(qx); DEALLOCATE(qy)
00144      IF(ndim3) DEALLOCATE(qz)
00145      
00146    END SUBROUTINE ConductiveSource
00147 
00148    SUBROUTINE FindFacedTdx(Info,diT,i,j,k,m)
00149      TYPE(InfoDef) :: Info
00150      INTEGER :: i,j,k,m
00151      REAL(KIND=qPREC) :: diT(3)
00152      REAL(KIND=qPREC) :: mT(-1:1,-1:1,-1:1)
00153      
00154      CALL FindBodyT(Info,mT,i,j,k)
00155      diT=0d0
00156      !PRINT*
00157      !PRINT*, i,j,"mT is:"
00158      !PRINT*, mT(:,1,0)
00159      !PRINT*, mT(:,0,0)
00160      !PRINT*, mT(:,-1,0)
00161      !PRINT*
00162 
00163      SELECT CASE(m)
00164      CASE(1)
00165         diT(1)=mT(0,0,0)-mT(-1,0,0)
00166         diT(2)=0.25*(mT(0,1,0)-mT(0,-1,0)+mT(-1,1,0)-mT(-1,-1,0))
00167         IF(nDim==3) diT(3)=0.25*(mT(0,0,1)-mT(0,0,-1)+mT(-1,0,1)-mT(-1,0,-1))
00168      CASE(2)
00169         diT(1)=0.25*(mT(1,0,0)-mT(-1,0,0)+mT(1,-1,0)-mT(-1,-1,0))
00170         diT(2)=mT(0,0,0)-mT(0,-1,0)
00171         IF(nDim==3) diT(3)=0.25*(mT(0,0,1)-mT(0,0,-1)+mT(0,-1,1)-mT(0,-1,-1))
00172      CASE(3)
00173         diT(1)=0.25*(mT(1,0,0)-mT(-1,0,0)+mT(1,0,-1)-mT(-1,0,-1))
00174         diT(2)=0.25*(mT(0,1,0)-mT(0,-1,0)+mT(0,1,-1)-mT(0,-1,-1))
00175         IF(nDim==3) diT(3)=mT(0,0,0)-mT(0,0,-1)
00176      END SELECT
00177      
00178    END SUBROUTINE FindFacedTdx
00179    
00180    SUBROUTINE FindFaceB(Info,fb,i,j,k,m)
00181      TYPE(InfoDef) :: Info
00182      INTEGER :: i,j,k,m
00183      REAL(KIND=qPREC) :: ff(3),fl,fb(3)
00184      ff=0d0;fb=0d0;fl=0d0
00185      SELECT CASE(m)
00186      CASE(1)
00187         ff(1)=Info%aux(i,j,k,1)
00188         ff(2)=0.25*(Info%aux(i,j,k,2)+Info%aux(i,j+1,k,2)+Info%aux(i-1,j,k,2)+Info%aux(i-1,j+1,k,2))
00189         IF(nDim==3) ff(3)=0.25*(Info%aux(i,j,k,3)+Info%aux(i,j,k+1,3)+Info%aux(i-1,j,k,3)+Info%aux(i-1,j,k+1,3))
00190      CASE(2)
00191         ff(1)=0.25*(Info%aux(i,j,k,1)+Info%aux(i+1,j,k,1)+Info%aux(i,j-1,k,1)+Info%aux(i+1,j-1,k,1))
00192         ff(2)=Info%aux(i,j,k,2)
00193         if(nDim==3) ff(3)=0.25*(Info%aux(i,j,k,3)+Info%aux(i,j,k+1,3)+Info%aux(i,j-1,k,3)+Info%aux(i,j-1,k+1,3))
00194      CASE(3)
00195         ff(1)=0.25*(Info%aux(i,j,k,1)+Info%aux(i+1,j,k,1)+Info%aux(i,j,k-1,1)+Info%aux(i+1,j,k-1,1))
00196         ff(2)=0.25*(Info%aux(i,j,k,2)+Info%aux(i,j+1,k,2)+Info%aux(i,j,k-1,2)+Info%aux(i,j+1,k-1,2))
00197         IF(nDim==3) ff(3)=Info%aux(i,j,k,3)
00198      END SELECT
00199 
00200      fl=SQRT(SUM(ff(:)**2))
00201      IF(fl > 0d0) THEN
00202         fb(:)=ff(:)/fl
00203      ELSE
00204         fb(m)=1d0
00205      END IF
00206 
00207    END SUBROUTINE FindFaceB
00208 
00209    SUBROUTINE FindBodyT(Info,mT,i,j,k)
00210      TYPE(InfoDef) :: Info
00211      INTEGER :: i,j,k,l,m,n
00212      REAL(KIND=qPREC) :: mT(-1:1,-1:1,-1:1)
00213      
00214      mT=0d0
00215 
00216      IF(nDim==2)THEN
00217         DO l=-1,1; DO m=-1,1
00218            mT(l,m,0)=(gamma-1d0)*(Info%q(i+l,j+m,k,iE)-0.5*SUM(Info%q(i+l,j+m,k,&
00219                 imom(1:ndim))**2)/Info%q(i+l,j+m,k,1)-0.5*SUM(Info%q(i+l,j+m,k,iBx:iBx+nDim-1)**2))/Info%q(i+l,j+m,k,1)
00220         END DO; END DO
00221      ELSE IF(nDim==3) THEN
00222         DO l=-1,1; DO m=-1,1; DO n=-1,1
00223            mT(l,m,n)=(gamma-1d0)*(Info%q(i+l,j+m,k+n,iE)-0.5*SUM(Info%q(i+l,j+m,k+n,&
00224                 imom(1:ndim))**2)/Info%q(i+l,j+m,k+n,1)-0.5*SUM(Info%q(i+l,j+m,k+n,iBx:iBx+nDim-1)**2))/Info%q(i+l,j+m,k+n,1)
00225         END DO; END DO; END DO
00226      ELSE
00227         PRINT*, "Conductive Solver is 2D, 3D only!"
00228         STOP
00229      END IF
00230    END SUBROUTINE FindBodyT
00231    
00232    SUBROUTINE FindConductivity(Info,chic,chir,i,j,k,dir)
00233      TYPE(InfoDef) :: Info
00234      INTEGER :: i,j,k,ii,jj,kk,dir,shift(3)
00235      REAL(KIND=qPREC) :: rho,temp1,temp2,temp,conpara,concross,magp,chic,chir
00236      
00237      chic=0d0;chir=0d0
00238      IF(ConType<2)THEN
00239         chic=conductivity
00240         RETURN
00241      END IF
00242 
00243      shift=0;shift(dir)=-1
00244      ii=i+shift(1);jj=j+shift(2);kk=k+shift(3)
00245      
00246      rho=0.5*(Info%q(i,j,k,1)+Info%q(ii,jj,kk,1))
00247      temp1=(gamma-1d0)*(Info%q(i,j,k,iE)-0.5*SUM(Info%q(i,j,k,&
00248           imom(1:ndim))**2)/Info%q(i,j,k,1)-0.5*SUM(Info%q(i,j,k,iBx:iBx+nDim-1)**2))/Info%q(i,j,k,1)
00249      temp2=(gamma-1d0)*(Info%q(ii,jj,kk,iE)-0.5*SUM(Info%q(ii,jj,kk,&
00250           imom(1:ndim))**2)/Info%q(ii,jj,kk,1)-0.5*SUM(Info%q(ii,jj,kk,iBx:iBx+nDim-1)**2))/Info%q(ii,jj,kk,1)
00251      temp=0.5*(temp1+temp2)
00252      
00253      magp=0.25*(Info%q(i,j,k,iBx)+Info%q(ii,jj,kk,iBx))**2+&
00254           0.25*(Info%q(i,j,k,iBy)+Info%q(ii,jj,kk,iBy))**2+&
00255           0.25*(Info%q(i,j,k,iBz)+Info%q(ii,jj,kk,iBz))**2
00256      
00257      conpara=SpitzerConductivity*temp**2.5
00258      concross=CrossConductivity*rho**2/(temp**0.5*magp)
00259      
00260      chir=concross; chic=conpara-concross
00261      
00262    END SUBROUTINE FindConductivity
00263    
00264    SUBROUTINE FindSaturationFlux(Info,i,j,k,fb,qf,dir)
00265      TYPE(InfoDef) :: Info
00266      INTEGER :: i,j,k,ii,jj,kk,dir,shift(3)
00267      REAL(KIND=qPREC) :: rho,temp1,temp2,temp,qf,qs,phi,fb(3)
00268      
00269      shift=0;shift(dir)=-1
00270      ii=i+shift(1);jj=j+shift(2);kk=k+shift(3)
00271      
00272      phi=0.3
00273      
00274      rho=0.5*(Info%q(i,j,k,1)+Info%q(ii,jj,kk,1))
00275      temp1=(gamma-1d0)*(Info%q(i,j,k,iE)-0.5*SUM(Info%q(i,j,k,&
00276           imom(1:ndim))**2)/Info%q(i,j,k,1)-0.5*SUM(Info%q(i,j,k,iBx:iBx+nDim-1)**2))/Info%q(i,j,k,1)
00277      temp2=(gamma-1d0)*(Info%q(ii,jj,kk,iE)-0.5*SUM(Info%q(ii,jj,kk,&
00278           imom(1:ndim))**2)/Info%q(ii,jj,kk,1)-0.5*SUM(Info%q(ii,jj,kk,iBx:iBx+nDim-1)**2))/Info%q(ii,jj,kk,1)
00279      temp=0.5*(temp1+temp2)
00280      qs=5d0*fb(dir)*phi*rho*(gamma*temp)**1.5
00281      
00282      CALL ThermalFluxLimiter(qs,qf)
00283      
00284    END SUBROUTINE FindSaturationFlux
00285 
00286    SUBROUTINE ThermalFluxLimiter(s,r)
00287      INTEGER :: ln
00288      REAL(KIND=qPREC) :: s,r,x
00289      
00290      ln=1; x=abs(r/s)
00291 
00292      IF(x.gt.az(2,ln)) x=(x+az(3,ln))/(1d0+(x+az(3,ln))**az(1,ln))**(1d0/az(1,ln))
00293 
00294      r=SIGN(x*s,r)
00295 
00296    END SUBROUTINE ThermalFluxLimiter
00297 
00298    SUBROUTINE ConductiveGetMaxSpeed(Info)
00299     TYPE(InfoDef) :: Info
00300     INTEGER :: level, m
00301     REAL(KIND=qPREC) :: dx
00302     
00303     level=Info%level
00304     dx=levels(level)%dx
00305     
00306     explicit_maxspeed(level) = max(explicit_maxspeed(level),2d0*conductivity/dx)
00307 
00308    END SUBROUTINE ConductiveGetMaxSpeed
00309 
00310  END MODULE ConductiveSrc
00311 
00312 
00313 
00314 
00315 
00316 
00317 
00318 
00319 
00320 
 All Classes Files Functions Variables