Scrambler
1
|
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