Scrambler  1
CorotatingBinary/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 CorotatingBinary 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 Ambients
00038   USE Winds
00039   USE PhysicsDeclarations
00040   USE CommonFunctions
00041   USE ParticleDeclarations
00042   USE PointGravitySrc
00043   IMPLICIT NONE
00044   SAVE
00045 
00046   PUBLIC ProblemModuleInit, ProblemGridInit, &
00047        ProblemBeforeStep, ProblemAfterStep, ProblemSetErrFlag, ProblemBeforeGlobalStep
00048   REAL(KIND=qPREC) :: wind_density, wind_temp, r_p, v_w, omega_star, star_phi, r_bondi, xloc(3), iAccretion=KRUMHOLZ_ACCRETION
00049   LOGICAL :: lCreateParticle=.false.
00050 CONTAINS
00051 
00052 
00054    SUBROUTINE ProblemModuleInit()
00055      TYPE(ParticleDef), POINTER :: Particle
00056      TYPE(WindDef), POINTER :: Wind
00057      INTEGER :: i
00058      NAMELIST /AmbientData/ wind_density, wind_temp, r_p, v_w, Omega_star, star_phi, xloc, r_bondi, lCreateParticle, iAccretion
00059      OPEN(UNIT=PROBLEM_DATA_HANDLE, FILE='problem.data', STATUS="OLD")
00060      READ(PROBLEM_DATA_HANDLE,NML=AmbientData)    
00061      IF (lCreateParticle) THEN
00062         NULLIFY(Particle)
00063         CALL CreateParticle(Particle)
00064         Particle%q(1)=v_w**2*r_bondi/ScaleGrav
00065         Particle%xloc=xloc
00066         Particle%iAccrete=iAccretion
00067         CALL CreatePointGravityObject(Particle%PointGravityObj)
00068         Particle%lFixed=.true.
00069         Particle%PointGravityObj%soft_length=4d0*sink_dx
00070         Particle%PointGravityObj%Mass=Particle%q(1)
00071         Particle%PointGravityObj%x0=Particle%xloc
00072         CALL AddSinkParticle(Particle)
00073      END IF
00074      IF (nDim == 3) THEN
00075         DO i=1,2
00076            CALL CreateWind(Wind)
00077            Wind%dir=3
00078            Wind%edge=i
00079            Wind%Type=OUTFLOW_ONLY
00080            Wind%density=wind_density
00081            Wind%temperature=wind_temp
00082         END DO
00083      END IF
00084    END SUBROUTINE ProblemModuleInit
00085 
00088   SUBROUTINE ProblemGridInit(Info)
00089     TYPE(InfoDef) :: Info
00090     INTEGER, DIMENSION(3,2) :: ip
00091     ip=1
00092     ip(1:nDim,2)=Info%mX(1:nDim)
00093 !    write(*,*) 'setting wind params for', ip
00094     CALL SetWind(Info, ip)  
00095 !    DO i=1,48
00096 !       IF (ANY(Info%q(i,ip(2,1):
00097   END SUBROUTINE ProblemGridInit
00098 
00101   SUBROUTINE ProblemBeforeStep(Info)
00102     TYPE(InfoDef) :: Info
00103     INTEGER :: l, ip(3,2)
00104     INTEGER, PARAMETER, DIMENSION(2) :: winddir=(/1,2/), windedge=(/1,2/)
00105 !    ip=1
00106 !    ip(1:nDim,1)=60
00107 !    ip(1:nDim,2)=68
00108     DO l=1,2
00109        IF (GhostOverlap(Info, winddir(l), windedge(l),ip)) THEN
00110           CALL SetWind(Info, ip)
00111        END IF
00112     END DO
00113   END SUBROUTINE ProblemBeforeStep
00114 
00115   SUBROUTINE SetWind(Info, ip)
00116     TYPE(InfoDef) :: Info
00117     INTEGER :: i,j,k, ip(3,2)
00118     REAL(KIND=qPREC) :: dx, dz,pos(3), t
00119     dx=levels(Info%level)%dx
00120     dz=merge(dx, 0d0, nDim==3)
00121     t=levels(Info%level)%tnow
00122     DO i=ip(1,1), ip(1,2)
00123        pos(1)=Info%xBounds(1,1)+(REAL(i)-half)*dx
00124        DO j=ip(2,1), ip(2,2)
00125           pos(2)=Info%xBounds(2,1)+(REAL(j)-half)*dx
00126           DO k=ip(3,1), ip(3,2)
00127              pos(3)=Info%xBounds(3,1)+(REAL(k)-half)*dz
00128              CALL SetWindq(Info%q(i,j,k,:),pos,t)
00129           END DO
00130        END DO
00131     END DO
00132   END SUBROUTINE SetWind
00133 
00134 
00135   SUBROUTINE SetWindq(q, pos,t)
00136     REAL(KIND=qPREC), DIMENSION(:) :: q
00137     REAL(KIND=qPREC), DIMENSION(3) :: pos
00138     INTEGER, PARAMETER :: nIters=8
00139     INTEGER :: i
00140     REAL(KIND=qPREC) :: t_r, r, d(3), xp(3),v(3), dmag,t,vp(3),n(3)
00141     r=sqrt(sum(pos**2))
00142     t_r=t-r/v_w    
00143 !    IF (r > v_w/Omega_star) THEN
00144 !       write(*,*) 'WARNING ... multiple solutions exist... - consider shrinking grid'
00145        !STOP
00146 !    END IF
00147 !    write(*,*) pos
00148     DO i=1,nIters
00149        xp=r_p*(/cos(star_phi+Omega_star*t_r-OmegaRot*t), sin(star_phi+Omega_star*t_r-OmegaRot*t), 0d0/)
00150        d=(pos-xP)
00151        dmag=sqrt(sum(d**2))
00152        vp=r_p*Omega_star*(/-sin(star_phi+Omega_star*t_r-OmegaRot*t), cos(star_phi+Omega_star*t_r-OmegaRot*t), 0d0/)
00153        n=SolveCrossEq(d, -Cross3D(vp, d)/v_w)
00154        v=v_w*n+vp
00155        t_r=t-dmag/sqrt(sum(v**2))
00156 !       write(*,*) i, t_r
00157     END DO
00158     v=v+Omegarot*(/pos(2), -pos(1),0d0/)
00159     q(1)=wind_density/dmag**(REAL(nDim)-1d0)
00160 !    q(1)=100d0+omega_star*t_r
00161     q(imom(1:nDim))=q(1)*v(1:nDim)
00162 
00163     IF (iE /= 0) q(iE)=half*sum(q(imom(1:nDim))**2)/q(1)+gamma7*q(1)*wind_temp
00164 !    write(*,*) 'setting wind q', pos, q(1), wind_density
00165   END SUBROUTINE SetWindq
00166 
00169   SUBROUTINE ProblemAfterStep(Info)
00170     TYPE(InfoDef) :: Info
00171   END SUBROUTINE ProblemAfterStep
00172 
00175   SUBROUTINE ProblemSetErrFlag(Info)
00176     TYPE(InfoDef) :: Info
00177   END SUBROUTINE ProblemSetErrFlag
00178 
00179   SUBROUTINE ProblemBeforeGlobalStep(n)
00180      INTEGER :: n
00181   END SUBROUTINE ProblemBeforeGlobalStep
00182 
00183 END MODULE Problem
00184 
 All Classes Files Functions Variables