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