Scrambler
1
|
00001 !######################################################################### 00002 ! 00003 ! Copyright (C) 2003-2012 Department of Physics and Astronomy, 00004 ! University of Rochester, 00005 ! Rochester, NY 00006 ! 00007 ! resistive.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 ResistiveSrc 00024 USE GlobalDeclarations 00025 USE TreeDeclarations 00026 USE DataDeclarations 00027 USE ExplicitDeclarations 00028 USE PhysicsDeclarations 00029 USE EOS 00030 00031 CONTAINS 00032 00033 SUBROUTINE ResistiveGridAdvance(n,stepping) 00034 INTEGER :: n,stepping 00035 TYPE(NodeDef), POINTER :: node 00036 TYPE(NodeDefList), POINTER :: nodelist 00037 !alternative solution: REAL ALLOCATABLE :: q,aux 00038 IF(MPI_ID==0) PRINT*, "Advancing Resistive Solver on Grid..." 00039 nodelist=>nodes(n)%p 00040 DO WHILE (associated(nodelist)) 00041 node=>nodelist%self 00042 CALL ResistiveSource(n,node%info,stepping) 00043 !alternative solution: store q and aux 00044 nodelist=>nodelist%next 00045 END DO 00046 00047 END SUBROUTINE ResistiveGridAdvance 00048 00049 SUBROUTINE ResistiveGridGetMaxSpeed(n) 00050 INTEGER :: n 00051 TYPE(NodeDef), POINTER :: node 00052 TYPE(NodeDefList), POINTER :: nodelist 00053 00054 nodelist=>Nodes(n)%p 00055 DO WHILE (associated(nodelist)) 00056 node=>nodelist%self 00057 CALL ResistiveGetMaxSpeed(node%info) 00058 nodelist=>nodelist%next 00059 END DO 00060 00061 END SUBROUTINE ResistiveGridGetMaxSpeed 00062 00063 SUBROUTINE ResistiveSource(n,Info,stepping) 00064 TYPE(InfoDef) :: Info 00065 LOGICAL :: consist_en=.true. 00066 INTEGER :: n 00067 INTEGER :: i,j,k,z_off,stepping,mx,my,mz,mbc,zmbc 00068 INTEGER :: msx(3,2),msy(3,2),msz(3,2), mjx(3,2), mjy(3,2), mjz(3,2) 00069 INTEGER, ALLOCATABLE, DIMENSION(:) :: iflux,bflux 00070 REAL(KIND=qPREC) :: dx,dt,check_en,off_en 00071 REAL(KIND=qPREC), ALLOCATABLE, DIMENSION(:) :: new_b 00072 REAL(KIND=qPREC), ALLOCATABLE, DIMENSION(:,:,:) :: jx, jy, jz 00073 REAL(KIND=qPREC), ALLOCATABLE, DIMENSION(:,:,:,:) :: xflux, yflux, zflux 00074 REAL(KIND=qPREC), ALLOCATABLE, DIMENSION(:,:,:,:) :: fjx, fjy 00075 00076 mx=Info%mX(1);my=Info%mX(2);mz=Info%mX(3) 00077 00078 mbc=levels(n)%ambc(levels(n)%step)-stepping 00079 00080 IF(MPI_ID==0) THEN 00081 PRINT*, "level =",n,"mbc =",mbc 00082 END IF 00083 00084 SELECT CASE(nDim) 00085 CASE(2) 00086 zmbc=0;z_off=0 00087 CASE(3) 00088 zmbc=mbc;z_off=1 00089 END SELECT 00090 dx=levels(n)%dx; dt=levels(n)%dt 00091 00092 ALLOCATE(iflux(1)) 00093 iflux(:)=iE 00094 00095 ! bounds for edge centered currents 00096 mjx=reshape((/1-mbc,1-mbc,1-zmbc,mx+mbc,my+mbc+1,mz+zmbc+z_off/),(/3,2/)) 00097 mjy=reshape((/1-mbc,1-mbc,1-zmbc,mx+mbc+1,my+mbc,mz+zmbc+z_off/),(/3,2/)) 00098 mjz=reshape((/1-mbc,1-mbc,1-zmbc,mx+mbc+1,my+mbc+1,mz+zmbc/),(/3,2/)) 00099 00100 ALLOCATE(jx(mjx(1,1):mjx(1,2),mjx(2,1):mjx(2,2),mjx(3,1):mjx(3,2))) 00101 ALLOCATE(jy(mjy(1,1):mjy(1,2),mjy(2,1):mjy(2,2),mjy(3,1):mjy(3,2))) 00102 ALLOCATE(jz(mjz(1,1):mjz(1,2),mjz(2,1):mjz(2,2),mjz(3,1):mjz(3,2))) 00103 00104 jx=resistivity;jy=resistivity;jz=resistivity 00105 ! if resistivity is not constant 00106 IF(ResType==2)THEN 00107 DO i=mjx(1,1),mjx(1,2); DO j=mjx(2,1),mjx(2,2); DO k=mjx(3,1),mjx(3,2) 00108 CALL RealResistivity(Info,i,j,k,jx(i,j,k),dx,1) 00109 END DO; END DO; END DO 00110 DO i=mjy(1,1),mjy(1,2); DO j=mjy(2,1),mjy(2,2); DO k=mjy(3,1),mjy(3,2) 00111 CALL RealResistivity(Info,i,j,k,jy(i,j,k),dx,2) 00112 END DO; END DO; END DO 00113 DO i=mjz(1,1),mjz(1,2); DO j=mjz(2,1),mjz(2,2); DO k=mjz(3,1),mjz(3,2) 00114 CALL RealResistivity(Info,i,j,k,jz(i,j,k),dx,3) 00115 END DO; END DO; END DO 00116 END IF 00117 00118 ! j = curl B 00119 DO i=mjx(1,1),mjx(1,2); DO j=mjx(2,1),mjx(2,2); DO k=mjx(3,1),mjx(3,2) 00120 IF(nDim==2)THEN 00121 jx(i,j,k) = -jx(i,j,k)*(Info%q(i,j-1,k,iBz)-Info%q(i,j,k,iBz))/dx 00122 ELSE 00123 jx(i,j,k) = -jx(i,j,k)*((Info%aux(i,j,k,2)-Info%aux(i,j,k-1,2))+(Info%aux(i,j-1,k,3)-Info%aux(i,j,k,3)))/dx 00124 END IF 00125 !Info%emf(i,j,k,iEx) = Info%emf(i,j,k,iEx)+jx(i,j,k)*dt/dx 00126 END DO; END DO; END DO 00127 00128 DO i=mjy(1,1),mjy(1,2); DO j=mjy(2,1),mjy(2,2); DO k=mjy(3,1),mjy(3,2) 00129 IF(nDim==2)THEN 00130 jy(i,j,k) = -jy(i,j,k)*(Info%q(i,j,k,iBz)-Info%q(i-1,j,k,iBz))/dx 00131 ELSE 00132 jy(i,j,k) = -jy(i,j,k)*((Info%aux(i,j,k,3)-Info%aux(i-1,j,k,3))+(Info%aux(i,j,k-1,1)-Info%aux(i,j,k,1)))/dx 00133 END IF 00134 !Info%emf(i,j,k,iEy) = Info%emf(i,j,k,iEy)+jy(i,j,k)*dt/dx 00135 END DO; END DO; END DO 00136 00137 DO i=mjz(1,1),mjz(1,2); DO j=mjz(2,1),mjz(2,2); DO k=mjz(3,1),mjz(3,2) 00138 jz(i,j,k) = -jz(i,j,k)*((Info%aux(i,j,k,1)-Info%aux(i,j-1,k,1))+(Info%aux(i-1,j,k,2)-Info%aux(i,j,k,2)))/dx 00139 !Info%emf(i,j,k,iEz) = Info%emf(i,j,k,iEz)+jz(i,j,k)*dt/dx 00140 END DO; END DO; END DO 00141 00142 ! store x,y emfs. 00143 IF(nDim==2)THEN 00144 ALLOCATE(fjx(mjy(1,1):mjy(1,2),mjy(2,1):mjy(2,2),mjy(3,1):mjy(3,2),1)) 00145 ALLOCATE(fjy(mjx(1,1):mjx(1,2),mjx(2,1):mjx(2,2),mjx(3,1):mjx(3,2),1)) 00146 ALLOCATE(bflux(1)) 00147 bflux(:)=iBz 00148 fjx(:,:,:,1)=jy(:,:,:)*dt/dx 00149 fjy(:,:,:,1)=-jx(:,:,:)*dt/dx 00150 CALL storefixupfluxes(Info,mjy,1,fjx,bflux) 00151 CALL storefixupfluxes(Info,mjx,2,fjy,bflux) 00152 DEALLOCATE(bflux) 00153 DEALLOCATE(fjx); DEALLOCATE(fjy) 00154 ELSE 00155 CALL StoreEmfs(Info,mjx,1,jx*dt/dx) 00156 CALL StoreEmfs(Info,mjy,2,jy*dt/dx) 00157 END IF 00158 00159 ! store z emf. The same for 2D and 3D 00160 CALL StoreEmfs(Info,mjz,3,jz*dt/dx) 00161 00162 ! bounds for face centered fluxes 00163 msx=reshape((/1-mbc,1-mbc,1-zmbc,mx+mbc+1,my+mbc,mz+zmbc/),(/3,2/)) 00164 msy=reshape((/1-mbc,1-mbc,1-zmbc,mx+mbc,my+mbc+1,mz+zmbc/),(/3,2/)) 00165 msz=reshape((/1-mbc,1-mbc,1-zmbc,mx+mbc,my+mbc,mz+zmbc+z_off/),(/3,2/)) 00166 00167 ALLOCATE(xflux(msx(1,1):msx(1,2),msx(2,1):msx(2,2),msx(3,1):msx(3,2),1)) 00168 ALLOCATE(yflux(msy(1,1):msy(1,2),msy(2,1):msy(2,2),msy(3,1):msy(3,2),1)) 00169 IF(nDim==3) ALLOCATE(zflux(msz(1,1):msz(1,2),msz(2,1):msz(2,2),msz(3,1):msz(3,2),1)) 00170 00171 DO i=msx(1,1),msx(1,2); DO j=msx(2,1),msx(2,2); DO k=msx(3,1),msx(3,2) 00172 IF(nDim==2)THEN 00173 Info%aux(i,j,k,1) = Info%aux(i,j,k,1)+(jz(i,j,k)-jz(i,j+1,k))*dt/dx 00174 xflux(i,j,k,1)=-0.25*(jz(i,j+1,k)+jz(i,j,k))*(Info%q(i-1,j,k,iBy)+Info%q(i,j,k,iBy)) 00175 ELSE 00176 Info%aux(i,j,k,1) = Info%aux(i,j,k,1)+((jy(i,j,k+1)-jy(i,j,k))+(jz(i,j,k)-jz(i,j+1,k)))*dt/dx 00177 xflux(i,j,k,1)=0.25*(jy(i,j,k+1)+jy(i,j,k))*(Info%q(i-1,j,k,iBz)+Info%q(i,j,k,iBz))-0.25*(jz(i,j+1,k)+jz(i,j,k))*(Info%q(i-1,j,k,iBy)+Info%q(i,j,k,iBy)) 00178 END IF 00179 END DO; END DO; END DO 00180 DO i=msy(1,1),msy(1,2); DO j=msy(2,1),msy(2,2); DO k=msy(3,1),msy(3,2) 00181 IF(nDim==2)THEN 00182 Info%aux(i,j,k,2) = Info%aux(i,j,k,2)+(jz(i+1,j,k)-jz(i,j,k))*dt/dx 00183 yflux(i,j,k,1)=0.25*(jz(i+1,j,k)+jz(i,j,k))*(Info%q(i,j-1,k,iBx)+Info%q(i,j,k,iBx)) 00184 ELSE 00185 Info%aux(i,j,k,2) = Info%aux(i,j,k,2)+((jz(i+1,j,k)-jz(i,j,k))+(jx(i,j,k)-jx(i,j,k+1)))*dt/dx 00186 yflux(i,j,k,1)=0.25*(jz(i+1,j,k)+jz(i,j,k))*(Info%q(i,j-1,k,iBx)+Info%q(i,j,k,iBx))-0.25*(jx(i,j,k+1)+jx(i,j,k))*(Info%q(i,j-1,k,iBz)+Info%q(i,j,k,iBz)) 00187 END IF 00188 END DO; END DO; END DO 00189 DO i=msz(1,1),msz(1,2); DO j=msz(2,1),msz(2,2); DO k=msz(3,1),msz(3,2) 00190 IF(nDim==2)THEN 00191 Info%q(i,j,k,iBz) = Info%q(i,j,k,iBz)+((jx(i,j+1,k)-jx(i,j,k))+(jy(i,j,k)-jy(i+1,j,k)))*dt/dx 00192 ELSE 00193 Info%aux(i,j,k,3) = Info%aux(i,j,k,3)+((jx(i,j+1,k)-jx(i,j,k))+(jy(i,j,k)-jy(i+1,j,k)))*dt/dx 00194 zflux(i,j,k,1)=0.25*(jx(i,j+1,k)+jx(i,j,k))*(Info%q(i,j,k-1,iBy)+Info%q(i,j,k,iBy))-0.25*(jy(i+1,j,k)+jy(i,j,k))*(Info%q(i,j,k-1,iBx)+Info%q(i,j,k,iBx)) 00195 END IF 00196 END DO; END DO; END DO 00197 00198 DEALLOCATE(jx); DEALLOCATE(jy); DEALLOCATE(jz) 00199 00200 !ALLOCATE(new_b(1:nDim)) 00201 00202 off_en=0d0 00203 DO k=1-zmbc, mz+zmbc; DO j=1-mbc, my+mbc; DO i=1-mbc, mx+mbc 00204 !check_en=Info%q(i,j,k,iE)-0.5*SUM(Info%q(i,j,k,iBx:iBz)**2) 00205 IF(nDim==2)THEN 00206 Info%q(i,j,k,iE)=Info%q(i,j,k,iE)-dt*((xflux(i+1,j,k,1)-xflux(i,j,k,1))+(yflux(i,j+1,k,1)-yflux(i,j,k,1)))/dx 00207 ELSE 00208 Info%q(i,j,k,iE)=Info%q(i,j,k,iE)-dt*((xflux(i+1,j,k,1)-xflux(i,j,k,1))+(yflux(i,j+1,k,1)-yflux(i,j,k,1))+(zflux(i,j,k+1,1)-zflux(i,j,k,1)))/dx 00209 END IF 00210 !new_b(1) = 0.5*(Info%aux(i,j,k,1)+Info%aux(i+1,j,k,1)) 00211 !new_b(2) = 0.5*(Info%aux(i,j,k,2)+Info%aux(i,j+1,k,2)) 00212 !new_b(3) = 0.5*(Info%aux(i,j,k,3)+Info%aux(i,j,k+1,3)) 00213 !off_en=max(off_en,abs(check_en-(Info%q(i,j,k,iE)-0.5*SUM(new_b(:)**2)))/check_en) 00214 END DO; END DO; END DO 00215 00216 !IF(off_en.gt.1d-3) PRINT*, MPI_ID, "Energy Inconsistency Found: ", off_en 00217 00218 CALL storefixupfluxes(Info,msx,1,xflux,iflux) 00219 CALL storefixupfluxes(Info,msy,2,yflux,iflux) 00220 IF(nDim==3) CALL storefixupfluxes(Info,msz,3,zflux,iflux) 00221 00222 DEALLOCATE(iflux)!; DEALLOCATE(new_b) 00223 DEALLOCATE(xflux); DEALLOCATE(yflux); 00224 IF(nDim==3) DEALLOCATE(zflux) 00225 00226 ! update field components in q. 00227 DO i=1-mbc,mx+mbc; DO j=1-mbc,my+mbc; DO k=1-zmbc,mz+zmbc 00228 Info%q(i,j,k,iBx)=.5*(Info%aux(i,j,k,1)+Info%aux(i+1,j,k,1)) 00229 Info%q(i,j,k,iBy)=.5*(Info%aux(i,j,k,2)+Info%aux(i,j+1,k,2)) 00230 IF(nDim==3) Info%q(i,j,k,iBz)=.5*(Info%aux(i,j,k,3)+Info%aux(i,j,k+1,3)) 00231 END DO; END DO; END DO 00232 00233 END SUBROUTINE ResistiveSource 00234 00235 00236 SUBROUTINE RealResistivity(Info,i,j,k,resi,dx,dir) 00237 TYPE(InfoDef) :: Info 00238 INTEGER :: i,j,k,l,m,n,dir 00239 REAL(KIND=qPREC) :: dx,resi,temp,t,r,r0,rho,rhotemp,Cln,pos(3) 00240 00241 IF(dir==1)THEN 00242 pos=Info%xBounds(1:3,1)+(/REAL(i)-half,REAL(j)-1d0,REAL(k)-1d0/)*dx 00243 ELSE IF(dir==2)THEN 00244 pos=Info%xBounds(1:3,1)+(/REAL(i)-1d0,REAL(j)-half,REAL(k)-1d0/)*dx 00245 ELSE IF(dir==3)THEN 00246 pos=Info%xBounds(1:3,1)+(/REAL(i)-1d0,REAL(j)-1d0,REAL(k)-half/)*dx 00247 END IF 00248 r=sqrt(pos(1)**2+pos(2)**2) 00249 r0=0.5 00250 resi=resistivity*(0.1+0.9*exp(-r**2/r0**2)) 00251 00252 !n=1;t=0d0;rho=0d0 00253 !DO l=-1,0; DO m=-1,0 00254 ! SELECT CASE(dir) 00255 ! CASE(1) 00256 ! CALL getT(Info,i,j+l,k+m,temp) 00257 ! rhotemp = Info%q(i,j+l,k+m,1) 00258 ! CASE(2) 00259 ! CALL getT(Info,i+l,j,k+m,temp) 00260 ! rhotemp = Info%q(i+l,j,k+m,1) 00261 ! CASE(3) 00262 ! CALL getT(Info,i+l,j+m,k,temp) 00263 ! rhotemp = Info%q(i+l,j+m,k,1) 00264 ! END SELECT 00265 ! t=t+temp; rho=rho+rhotemp; n=n+1 00266 !END DO; END DO 00267 !t=0.25*t;rho=0.25*rho 00268 ! 00269 ! IF(t*tScale.le.4.2e5)THEN 00270 ! Cln=16.3+1.5*LOG(t*tScale)-0.5*LOG(rho*rScale/(mH*Xmu)) 00271 ! ELSE 00272 ! Cln=22.8+LOG(t*tScale)-0.5*LOG(rho*rScale/(mH*Xmu)) 00273 ! END IF 00274 00275 ! resistivity = 0.14*me**0.5*c^2, scaled 00276 !resi=SpitzerResistivity*Xmu*Cln*FZeff*t**(-1.5) 00277 00278 END SUBROUTINE RealResistivity 00279 00280 SUBROUTINE ResistiveGetMaxSpeed(Info) 00281 TYPE(InfoDef) :: Info 00282 INTEGER :: level, m 00283 REAL(KIND=qPREC) :: dx 00284 00285 level=Info%level 00286 dx=levels(level)%dx 00287 00288 explicit_maxspeed(level) = max(explicit_maxspeed(level),2d0*resistivity/dx) 00289 00290 END SUBROUTINE ResistiveGetMaxSpeed 00291 00292 00293 !SUBROUTINE getT(Info,i,j,k,temp) 00294 ! TYPE(InfoDef) :: Info 00295 ! INTEGER :: i,j,k 00296 ! REAL(KIND=qPREC) :: temp 00297 00298 ! temp=(gamma-1d0)*(Info%q(i,j,k,iE)-0.5*SUM(Info%q(i,j,k,2:4)**2)/Info%q(i,j,k,1)& 00299 ! -0.5*SUM(Info%q(i,j,k,iBx:iBz)**2))/Info%q(i,j,k,1) 00300 00301 !END SUBROUTINE getT 00302 00303 00304 END MODULE ResistiveSrc 00305 00306 00307