Scrambler
1
|
00001 !######################################################################### 00002 ! 00003 ! Copyright (C) 2003-2012 Department of Physics and Astronomy, 00004 ! University of Rochester, 00005 ! Rochester, NY 00006 ! 00007 ! selfgravity.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 SelfGravitySrc 00024 USE DataDeclarations 00025 USE PhysicsDeclarations 00026 USE EOS 00027 USE SourceDeclarations 00028 IMPLICIT NONE 00029 PRIVATE 00030 PUBLIC :: SelfGravity 00031 00032 CONTAINS 00033 00034 00035 00036 SUBROUTINE SelfGravity(q,dqdt,x,dx,t,Info,ip,lform) 00037 ! Interface declarations 00038 TYPE(InfoDef) :: Info 00039 INTEGER :: ip(3),ir(3),il(3) 00040 REAL(KIND=qPrec) :: q(:) 00041 REAL(KIND=qPrec) :: dqdt(:),x(3),dx,pos(3),t, pOffset(3),r2,r,f_grav(3) 00042 ! Internal declarations 00043 INTEGER :: level,i,j 00044 INTEGER :: smbc 00045 REAL(KIND=qPREC), DIMENSION(:,:,:), ALLOCATABLE :: gradPhi, Phi, rho 00046 LOGICAL :: lform 00047 level=Info%level 00048 ir=ip 00049 il=ip 00050 ! DO i=ip(1)-1,ip(1)+1 00051 ! DO j=ip(2)-1,ip(2)+1 00052 ! IF (iSNAN(Info%q(i,j,1,iPhiGas))) THEN 00053 ! write(*,*) 'found NAN in phi at', i,j 00054 ! write(*,*) 'ip =', ip 00055 ! write(*,*) 'x=', Info%xBounds(1:2,1)+levels(Info%level)%dx*REAL((/i,j/)-.5d0) 00056 ! STOP 00057 ! END IF 00058 ! IF (iSNAN(Info%q(i,j,1,iPhiDot))) THEN 00059 ! write(*,*) 'found NAN in phiDot at', i,j 00060 ! write(*,*) 'ip =', ip 00061 ! write(*,*) 'x=', Info%xBounds(1:2,1)+levels(Info%level)%dx*REAL((/i,j/)-.5d0) 00062 ! STOP 00063 ! END IF 00064 ! END DO 00065 ! END DO 00066 DO i=1,nDim 00067 ir(i)=min(ip(i)+1,uBound(Info%q,i)) 00068 il(i)=max(ir(i)-2,lBound(Info%q,i)) 00069 ir(i)=il(i)+2 00070 f_grav(i)=((Info%q(ir(1),ir(2),ir(3),iPhiGas)-Info%q(il(1),il(2),il(3),iPhiGas)))/2d0 !+ & 00071 ! (t-levels(level)%tnow)*(Info%q(ir(1),ir(2),ir(3),iPhiDot)-Info%q(il(1),il(2),il(3),iPhiDot))/2d0 00072 ir(i)=ip(i) 00073 il(i)=ip(i) 00074 END DO 00075 ! elliptic_maxspeed(level)=max(elliptic_maxspeed(level),sqrt(nDim*(maxval(abs(f_grav))))) 00076 f_grav(1:nDim)=-f_grav(1:nDim)/levels(level)%dx 00077 IF (lform .eqv. PRIMITIVE) THEN 00078 dqdt(imom(1:nDim))=dqdt(imom(1:nDim))+f_grav(1:nDim) 00079 ELSE 00080 dqdt(imom(1:nDim))=dqdt(imom(1:nDim))+f_grav(1:nDim)*q(1) 00081 IF (iE .ne. 0) dqdt(iE)=dqdt(iE)+SUM(f_grav(1:nDim)*q(imom(1:nDim))) 00082 END IF 00083 00084 END SUBROUTINE SelfGravity 00085 00086 END MODULE SelfGravitySrc