Scrambler
1
|
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 jets 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 ParticleDeclarations 00038 USE CoolingSrc 00039 USE SourceDeclarations 00040 USE Projections !n 00041 USE Fields !n 00042 USE Refinements 00043 USE Shapes 00044 IMPLICIT NONE 00045 SAVE 00046 PUBLIC ProblemModuleInit, ProblemGridInit, & 00047 ProblemBeforeStep, ProblemAfterStep, ProblemSetErrFlag, ProblemBeforeGlobalStep 00048 INTEGER :: nParticles,itracer2,iProp 00049 REAL(KIND=qPREC) :: namb, njet, tamb, Rjet, tjet, vjet,torusalpha,torusbeta 00050 LOGICAL :: lCooling, jet, rings, stratified, anotherClump=.false.,torus,lform 00051 TYPE(CoolingDef),POINTER :: coolingobj 00052 00053 CONTAINS 00054 00056 SUBROUTINE ProblemModuleInit() 00057 ! INTEGER, PARAMETER :: MaxParticles=50 00058 00059 ![6fecb12 00060 ! TYPE(InfoDef) :: Info 00061 ! INTEGER :: i,j,k,l,m,ii,jj,kk 00062 ! INTEGER :: rmbc,zrmbc,level 00063 ! INTEGER :: mx, my, mz 00064 ! REAL (KIND=qPrec), POINTER, DIMENSION (:,:,:,:) :: q 00065 ! REAL(KIND=xprec) :: x,y,z,xl,yl,zl,dx,dy,dz,r,r2 00066 !]6feb12 00067 REAL(KIND=qPREC) :: mass=0 00068 REAL(KIND=qPREC) :: xloc(3),buff(17) 00069 REAL(KIND=qPREC) :: vel(3) 00070 TYPE(ParticleDef), POINTER :: Particle, RefParticle 00071 INTEGER :: i 00072 INTEGER :: ids(2) 00073 TYPE(ProjectionDef), POINTER :: Projection 00074 ! TYPE(AmbientDef), POINTER :: Ambient 00075 ! REAL(KIND=qPREC) :: rhoOut, pOut, vxOut, vyOut, vzOut, BxOut, ByOut, BzOut 00076 TYPE(RefinementDef), POINTER :: Refinement 00077 REAL(KIND=qPREC) :: d(3), vshape 00078 ! NAMELIST /AmbientData/ rhoOut, pOut, vxOut, vyOut, vzOut, BxOut, ByOut, BzOut 00079 NAMELIST /ProblemData/ nParticles, jet, namb, njet, tamb, Rjet, & 00080 tjet, vjet, lCooling, rings, stratified,anotherClump,torus,torusalpha,torusbeta 00081 NAMELIST /ParticleData/ mass,xloc,vel,buff 00082 NAMELIST /RestartData/ ids 00083 OPEN(UNIT=PROBLEM_DATA_HANDLE, FILE='problem.data', STATUS="OLD") 00084 READ(PROBLEM_DATA_HANDLE,NML=ProblemData) 00085 00086 CALL AddTracer(itracer2, 'Clump tracer') 00087 !CALL CreateAmbient(Ambient) 00088 !READ(PROBLEM_DATA_HANDLE,NML=AmbientData) 00089 !Ambient%density=rhoOut 00090 !Ambient%pressure=pOut 00091 !Ambient%B(:)=(/BxOut, ByOut, BzOut/) 00092 !Ambient%v(:)=(/vxOut, vyOut, vzOut/) 00093 00094 ! 00095 !!!16mar'12 00096 !CALL CreateProjection(Projection) 00097 ! Projection%Field%id=CoolingStrength_Field 00098 ! Projection%Field%component=GASCOMP 00099 ! Projection%Field%name='Cooling_integrated_emiss' 00100 ! Projection%dim=3d0 00101 !!! 00102 ! 00103 00104 00105 IF (.NOT. lRestart) THEN 00106 DO i=1,nParticles 00107 READ(PROBLEM_DATA_HANDLE,NML=ParticleData) 00108 NULLIFY(Particle) 00109 CALL CreateParticle(Particle) 00110 Particle%Q(1)=mass 00111 Particle%xloc=xloc 00112 Particle%Q(imom(1:nDim))=vel(1:nDim)/velscale 00113 if (maxval(buff).ne.0) Particle%Buffer=buff 00114 CALL AddSinkParticle(Particle) 00115 END DO 00116 CLOSE(PROBLEM_DATA_HANDLE) 00117 OPEN(UNIT=PROBLEM_DATA_HANDLE, FILE='restart.data', STATUS="UNKNOWN") 00118 WRITE(PROBLEM_DATA_HANDLE,NML=RestartData) 00119 CLOSE(PROBLEM_DATA_HANDLE) 00120 END IF 00121 00122 IF (lCooling) THEN 00123 IF (.NOT. lRestart) THEN 00124 CALL CreateCoolingObject(coolingobj) 00125 ELSE 00126 coolingobj => firstcoolingobj 00127 END IF 00128 coolingobj%iCooling=DMCool 00129 coolingobj%floortemp=100d0 !K 00130 coolingobj%mintemp=1d0 !K 00131 END IF 00132 00133 vshape = half*vjet/VelScale 00134 CALL CreateRefinement(Refinement) 00135 CALL CreateShape(Refinement%Shape) 00136 IF(iCylindrical/=0) THEN 00137 iProp = 3 ! cylindrical run, jet propagates in cylindrical z-direction 00138 d = (/ 3d0, 2d0, 3d0 /) 00139 Refinement%Shape%velocity=(/ 0d0, vshape, 0d0 /) 00140 Refinement%Shape%Position = (/ 0d0, -1d0, 3d0 /) 00141 ELSE 00142 iProp = 2 ! cartesian run, jet propagates in cartesian x-direction 00143 d = (/ 2d0, 3d0, 3d0 /) 00144 Refinement%Shape%velocity=(/ vshape, 0d0, 0d0 /) 00145 Refinement%Shape%Position = (/ -1d0, 3d0, 3d0 /) 00146 END IF 00147 CALL SetShapeType(Refinement%Shape, RECTANGULAR_PRISM, d) 00148 CALL SetShapeBounds(Refinement%Shape) 00149 Refinement%BufferCells = 4 00150 Refinement%field = Mass_Field 00151 00152 CALL AddDiagnosticVar(MPI_ID_FIELD) 00153 CALL AddDiagnosticVar(ErrFlag_Field) 00154 END SUBROUTINE ProblemModuleInit 00155 00158 SUBROUTINE ProblemGridInit(Info) 00159 TYPE(InfoDef) :: Info 00160 INTEGER :: i,j,k,l,m,ii,jj,kk 00161 INTEGER :: rmbc,zrmbc,level 00162 INTEGER :: mx, my, mz 00163 INTEGER :: iErr 00164 REAL (KIND=qPrec), POINTER, DIMENSION (:,:,:,:) :: q 00165 REAL(KIND=xprec) :: x,y,z,xl,yl,zl,dx,dy,dz,r,r2,dr,dt,r3,torus2,cos2theta,ex1,ex2,Ftheta 00166 REAL(KIND=xprec), PARAMETER :: tt=0.006945d0 !time_final/200 00167 00168 IF (lRestart) RETURN 00169 00170 level=Info%level 00171 q=>Info%q 00172 ! Calculating the number of ghost cells on each side of the grid. 00173 rmbc=levels(level)%gmbc(levels(level)%step) 00174 mx = Info%mX(1) 00175 my = Info%mX(2) 00176 mz = Info%mX(3) 00177 dx=levels(level)%dX 00178 dy=dx 00179 dz=dx 00180 zrmbc=rmbc 00181 xl=Info%xBounds(1,1) 00182 yl=Info%xBounds(2,1) 00183 zl=Info%xBounds(3,1) 00184 dt=levels(level)%dt 00185 !--------- 00186 00187 q(:,:,:,itracer2)=0d0 00188 00189 IF(nDim==2) THEN 00190 zrmbc = 0 00191 dz = 0d0 00192 END IF 00193 00194 DO i=1-rmbc, mx+rmbc ; x = (xl+(REAL(i,xPrec)-half)*dx) 00195 DO j=1-rmbc, my+rmbc ; y = (yl+(REAL(j,xPrec)-half)*dy) 00196 DO k=1-zrmbc, mz+zrmbc ; z = (zl+(REAL(k,xPrec)-half)*dz) 00197 r = SQRT( x**2 + y**2 + z**2 ) ! from origin 00198 r2 = SQRT( (x-2d0*Rjet)**2 + y**2 + z**2 ) ! from clump center 00199 dr = SQRT( dx**2 + dy**2 + dz**2 ) 00200 00201 IF(iCylindrical/=0) r2 = SQRT( x**2 + (y-2d0*Rjet)**2 + z**2 ) 00202 IF (.NOT. jet) r = r2 ! b4 27jan'12 00203 00204 !A M B I E N T 00205 q(i,j,k,1) = namb/nScale ! density 00206 00207 torus2 = 1d0 00208 IF (torus) THEN 00209 IF (r == 0d0 .OR. (x-2d0*Rjet) == 0d0) THEN 00210 PRINT*,'torus error';stop 00211 ELSE 00212 cos2theta = 2d0*ACOS((x-2d0*Rjet)/r) !----------------------------B 00213 IF (jet) cos2theta = 2d0*ACOS((x-0d0*Rjet)/r) 00214 END IF 00215 ex1 = -2d0*torusbeta 00216 ex2 = torusbeta*COS(cos2theta)-torusbeta !----------------------------B 00217 Ftheta = 1d0-( torusalpha*(dexp(ex2)-1d0)/(dexp(ex1)-1d0) ) 00218 torus2 = 1d0/Ftheta 00219 END IF 00220 q(i,j,k,1) = q(i,j,k,1)*torus2 00221 00222 IF (stratified) THEN !27jan'12 00223 IF (jet) THEN 00224 q(i,j,k,1) = q(i,j,k,1) / (r + 1d0 + .25d0*dr)**2 00225 ELSE 00226 IF (r > Rjet) q(i,j,k,1) = q(i,j,k,1) / (r-Rjet + 1d0 + .25d0*dr)**2 00227 END IF 00228 END IF 00229 00230 IF (rings) q(i,j,k,1) = q(i,j,k,1)*& 00231 ( 2d0*(exp(-(2d0*(r- 2d0/1.5d0))**2)+& 00232 exp(-(2d0*(r- 6d0/1.5d0))**2)+& 00233 exp(-(2d0*(r-10d0/1.5d0))**2)+& 00234 exp(-(2d0*(r-14d0/1.5d0))**2)+& 00235 exp(-(2d0*(r-18d0/1.5d0))**2)+& 00236 exp(-(2d0*(r-22d0/1.5d0))**2)+& 00237 exp(-(2d0*(r-26d0/1.5d0))**2)+& 00238 exp(-(2d0*(r-30d0/1.5d0))**2)+& 00239 exp(-(2d0*(r-34d0/1.5d0))**2)+& 00240 exp(-(2d0*(r-38d0/1.5d0))**2)+& 00241 exp(-(2d0*(r-42d0/1.5d0))**2)+& 00242 exp(-(2d0*(r-46d0/1.5d0))**2)+& 00243 exp(-(2d0*(r-50d0/1.5d0))**2)+& 00244 exp(-(2d0*(r-54d0/1.5d0))**2)+& 00245 exp(-(2d0*(r-58d0/1.5d0))**2)+& 00246 exp(-(2d0*(r-62d0/1.5d0))**2)+& 00247 exp(-(2d0*(r-66d0/1.5d0))**2)+& 00248 exp(-(2d0*(r-70d0/1.5d0))**2)+& 00249 exp(-(2d0*(r-74d0/1.5d0))**2)+& 00250 exp(-(2d0*(r-78d0/1.5d0))**2)+& 00251 exp(-(2d0*(r-82d0/1.5d0))**2)+& 00252 exp(-(2d0*(r-86d0/1.5d0))**2)+& 00253 exp(-(2d0*(r-90d0/1.5d0))**2)+& 00254 exp(-(2d0*(r-94d0/1.5d0))**2)+& 00255 exp(-(2d0*(r-98d0/1.5d0))**2)+& 00256 exp(-(2d0*(r-102d0/1.5d0))**2)+& 00257 exp(-(2d0*(r-106d0/1.5d0))**2)+& 00258 exp(-(2d0*(r-110d0/1.5d0))**2)+& 00259 exp(-(2d0*(r-114d0/1.5d0))**2)+& 00260 exp(-(2d0*(r-118d0/1.5d0))**2)+& 00261 exp(-(2d0*(r-122d0/1.5d0))**2)+& 00262 exp(-(2d0*(r-126d0/1.5d0))**2)+& 00263 exp(-(2d0*(r-130d0/1.5d0))**2)+& 00264 exp(-(2d0*(r-134d0/1.5d0))**2)+& 00265 exp(-(2d0*(r-138d0/1.5d0))**2)+& 00266 exp(-(2d0*(r-142d0/1.5d0))**2)+& 00267 exp(-(2d0*(r-146d0/1.5d0))**2)+& 00268 exp(-(2d0*(r-150d0/1.5d0))**2)+& 00269 .5d0) ) 00270 00271 q(i,j,k,2:m_high) = 0d0 ! momenta=number density*v 00272 q(i,j,k,iE) = q(i,j,k,1)*tamb/TempScale/gamma1 ! specific internal energy 00273 q(i,j,k,itracer2) = GetCoolingStrength(q(i,j,k,:),lform)*pScale/TimeScale ! erg/cc/s 00274 00275 IF (jet) THEN 00276 IF(iCylindrical/=0) THEN 00277 IF (y > dy) CYCLE 00278 r = DSQRT( x**2 + z**2) 00279 ELSE 00280 IF (x > dx) CYCLE 00281 r = DSQRT( y**2 + z**2 ) 00282 END IF 00283 IF (r <= Rjet) THEN 00284 q(i,j,k,1) = njet/nscale ![cu] 00285 q(i,j,k,iProp) = vjet/500d0*q(i,j,k,1)/velScale*(1d0-.1d0*(r/Rjet)**2) 00286 q(i,j,k,iE) = q(i,j,k,1)*tjet/TempScale/gamma1 + & ! internal enegy [cu] 00287 half*SUM(q(i,j,k,2:m_high)**2)/q(i,j,k,1) ! kinetic energy 00288 END IF ! r < Rjet 00289 ELSE 00290 IF (r2 <= Rjet) THEN 00291 q(i,j,k,1) = nAmb/nScale + njet/nscale*(1d0-(r2/Rjet)**2) ! [cu] !27jul11 00292 q(i,j,k,iProp) = vjet*q(i,j,k,1)/velscale ![cu] 00293 q(i,j,k,iE) = q(i,j,k,1)*tjet/TempScale/gamma1 + & ! internal enegy [cu] 00294 half*SUM(q(i,j,k,2:m_high)**2)/q(i,j,k,1) ! kinetic energy 00295 END IF ! r < Rjet 00296 END IF ! jet/clump 00297 END DO 00298 END DO 00299 END DO 00300 END SUBROUTINE ProblemGridInit 00301 00304 SUBROUTINE ProblemBeforeStep(Info) 00305 TYPE(InfoDef) :: Info 00306 REAL (KIND=qPrec), POINTER, DIMENSION (:,:,:,:) :: q 00307 INTEGER :: i,j,k,ii,jj,kk,mx,my,mz,rmbc,zrmbc,level,iErr 00308 REAL(KIND=xprec) :: x,y,z,xl,yl,zl,dx,dy,dz,time, r, dt, dr,velFactor,torus2,cos2theta,ex1,ex2,Ftheta 00309 REAL(KIND=xprec), PARAMETER :: tt=0.006945d0 !time_final/200 00310 00311 level=Info%level 00312 dt=levels(level)%dt 00313 time=levels(level)%tnow 00314 if (time.eq.dt) return 00315 !we don't want to overwrite the initial conditions 00316 !and for the clump case we don't want to use this routine 00317 00318 q=>Info%q 00319 !Calculating the number of ghost cells on each side of the grid. 00320 rmbc=levels(level)%gmbc(levels(level)%step) 00321 mx = Info%mX(1) 00322 my = Info%mX(2) 00323 mz = Info%mX(3) 00324 dx=levels(level)%dX 00325 dy=dx 00326 dz=dx 00327 zrmbc=rmbc 00328 xl=Info%xBounds(1,1) 00329 yl=Info%xBounds(2,1) 00330 zl=Info%xBounds(3,1) 00331 00332 IF (nDim == 2) THEN 00333 zrmbc = 0 00334 dz = 0d0 00335 END IF 00336 00337 !emission 00338 DO i=1-rmbc, mx+rmbc ; DO j=1-rmbc, my+rmbc ; DO k=1-zrmbc, mz+zrmbc 00339 q(i,j,k,itracer2) = GetCoolingStrength(q(i,j,k,:),lform) 00340 END DO;END DO;END DO 00341 !!! 00342 00343 IF (.NOT. jet) RETURN 00344 DO i=1-rmbc, mx+rmbc 00345 x = (xl+(REAL(i,xPrec)-half)*dx) 00346 00347 ! ONLY DO THE FOLLOWING INSIDE THE -Z BOUNDARY: 00348 IF (iCylindrical==0 .AND. x > 0d0) CYCLE 00349 00350 DO j=1-rmbc, my+rmbc 00351 y = (yl+(REAL(j,xPrec)-half)*dy) 00352 IF (iCylindrical/=0 .AND. y > 0d0) CYCLE 00353 DO k=1-zrmbc, mz+zrmbc 00354 z = (zl+(REAL(k,xPrec)-half)*dz) 00355 00356 IF(iCylindrical/=0) y = x ! cylindrical run changes symmetry axis 00357 00358 !A M B I E N T 00359 r =SQRT( y**2 + z**2 ) 00360 dr =SQRT( dy**2 + dz**2 ) 00361 q(i,j,k,1) = namb/nScale !density 00362 00363 ! 00364 !!! TORUS 00365 !From Frnak & Mellema, 1994ApJ...430..800F: 00366 !produced a pole-to-equator density contrast 00367 torus2 = 1d0 00368 IF (torus) THEN 00369 IF (r == 0d0) THEN 00370 PRINT*,'torus error';stop 00371 ELSE 00372 cos2theta = 2d0*ACOS(x/r) 00373 END IF 00374 ex1 = -2d0*torusbeta 00375 ex2 = torusbeta*COS(cos2theta)-torusbeta 00376 Ftheta = 1d0-( torusalpha*(dexp(ex2)-1d0)/(dexp(ex1)-1d0) ) 00377 torus2 = 1d0/Ftheta 00378 END IF 00379 q(i,j,k,1) = q(i,j,k,1)*torus2 00380 !!! 00381 ! 00382 00383 IF (stratified) q(i,j,k,1) = q(i,j,k,1) / (r + 1d0 + .5d0*dr)**2 ! 12 jul '11 00384 q(i,j,k,2:m_high) = 0d0 00385 q(i,j,k,iE) = q(i,j,k,1)*tamb/TempScale/gamma1 !specific internal energy 00386 00387 IF (r <= Rjet) THEN 00388 q(i,j,k,1) = njet/nscale ![cu] 00389 ! q(i,j,k,itracer2) = q(i,j,k,1) !tracer 00390 00391 ! ramps up the jet vel: 00392 IF (time <= 0.0001d0) THEN 00393 velFactor = 1d0/500d0 00394 ELSE IF (time > 0.0001d0 .AND. time < tt) THEN 00395 velFactor = (1d0-1d0/500d0)/(tt-0.0001d0)*(time-0.0001d0)+1d0/500d0 00396 ELSE 00397 velFactor = 1d0 00398 END IF 00399 q(i,j,k,iProp) = vjet*q(i,j,k,1)/velScale*(1d0 - .1d0*(r/Rjet)**2)*velFactor 00400 q(i,j,k,iE) = q(i,j,k,1)*tjet/TempScale/gamma1 + & ! internal enegy [cu] 00401 half*SUM(q(i,j,k,2:m_high)**2)/q(i,j,k,1) ! kinetic energy 00402 END IF ! r < Rjet 00403 00404 END DO ; END DO ; END DO 00405 00406 END SUBROUTINE ProblemBeforeStep 00407 00410 SUBROUTINE ProblemAfterStep(Info) 00411 TYPE(InfoDef) :: Info 00412 END SUBROUTINE ProblemAfterStep 00413 00416 SUBROUTINE ProblemSetErrFlag(Info) 00417 TYPE(InfoDef) :: Info 00418 REAL (KIND=qPrec), POINTER, DIMENSION (:,:,:,:) :: q 00419 INTEGER :: i,j,k,mx,my,mz,rmbc,zrmbc,level 00420 REAL(KIND=xprec) :: x,y,z,xl,yl,zl,dx,dy,dz 00421 00422 ! IF(.NOT. jet) RETURN 00423 ! q=>Info%q 00424 ! level=Info%level 00425 ! rmbc=levels(level)%gmbc(levels(level)%step) 00426 ! SELECT CASE(nDim) 00427 ! CASE(2) 00428 ! zrmbc=0 00429 ! CASE(3) 00430 ! zrmbc=rmbc 00431 ! END SELECT 00432 ! mx = Info%mX(1) 00433 ! my = Info%mX(2) 00434 ! mz = Info%mX(3) 00435 ! dx=levels(level)%dX 00436 ! dy=dx;dz=dx 00437 ! xl=Info%xBounds(1,1) 00438 ! yl=Info%xBounds(2,1) 00439 ! zl=Info%xBounds(3,1) 00440 00441 ! DO i=1, mx ; x = (xl+(REAL(i,xPrec)-half)*dx) 00442 ! if (x>2d0*dx) cycle 00443 ! DO k=1,mz ; z = (zl+(REAL(k,xPrec)-half)*dz) 00444 ! if (sqrt(z**2).gt.Rjet*1.15d0) cycle 00445 ! DO j=1, my ; y = (yl+(REAL(j,xPrec)-half)*dy) 00446 ! if (sqrt(y**2+z**2).lt.Rjet*1.15d0) Info%ErrFlag(i,j,k)=1 00447 ! END DO; END DO; END DO 00448 00449 IF (nDim == 2) THEN 00450 IF (vjet/VelScale * levels(Info%level)%tnow <= 2d0*levels(0)%dx) THEN 00451 i=min(Info%mX(1),ceiling((Rjet-Info%xBounds(1,1))/levels(info%level)%dx)) 00452 j=min(Info%mX(2),ceiling((vjet/VelScale * levels(Info%level)%tnow+levels(Info%level)%dx - Info%xBounds(2,1))/levels(Info%level)%dx)) 00453 IF (i >= 1 .AND. j >= 1) Info%ErrFlag(1:i,1:j,1)=1 00454 END IF 00455 END IF 00456 00457 00458 END SUBROUTINE ProblemSetErrFlag 00459 00460 SUBROUTINE ProblemBeforeGlobalStep(n) 00461 INTEGER :: n 00462 END SUBROUTINE ProblemBeforeGlobalStep 00463 00464 END MODULE Problem 00465