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