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 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