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 FieldLoopAdvection 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 00036 MODULE Problem 00037 00038 USE DataDeclarations 00039 USE GlobalDeclarations 00040 USE PhysicsDeclarations 00041 USE Ambients 00042 IMPLICIT NONE 00043 SAVE 00044 PRIVATE 00045 00046 PUBLIC ProblemModuleInit, ProblemGridInit, & 00047 ProblemBeforeStep, ProblemAfterStep, ProblemSetErrFlag, ProblemBeforeGlobalStep 00048 00049 REAL(KIND=qPrec) :: rho,p,v(3),Ao,thickness,R,phi,theta 00050 REAL(KIND=qPREC), DIMENSION(:,:,:), ALLOCATABLE :: infoq 00051 INTEGER :: sample_res=16 00052 00053 LOGICAL :: lCooling 00054 LOGICAL :: lResolutionTest=.false. 00055 INTEGER :: iCooling 00056 00057 00058 CONTAINS 00059 00061 SUBROUTINE ProblemModuleInit 00062 INTEGER :: iErr 00063 TYPE(AmbientDef), POINTER :: Ambient 00064 NAMELIST /ProblemData/ rho,p,v,Ao,R,thickness,phi,theta,lCooling,iCooling, lResolutionTest 00065 00066 OPEN(UNIT=PROBLEM_DATA_HANDLE, FILE='problem.data') 00067 00068 READ(PROBLEM_DATA_HANDLE,NML=ProblemData) 00069 00070 CLOSE(PROBLEM_DATA_HANDLE, IOSTAT=iErr) 00071 00072 00073 IF (nDim == 2 .AND. ((phi /= zero) .OR. (theta /= zero))) THEN 00074 PRINT *, "CalcConstantProblem() error: phi and theta need to be 0 in a 2D problem." 00075 STOP 00076 END IF 00077 NULLIFY(Ambient) 00078 CALL CreateAmbient(Ambient) 00079 Ambient%density=rho 00080 Ambient%pressure=p 00081 Ambient%velocity=v 00082 END SUBROUTINE ProblemModuleInit 00083 00086 SUBROUTINE ProblemGridInit(Info) 00087 !! @brief Initializes the grid data according to the requirements of the problem. 00088 !! @param Info A grid structure. 00089 TYPE (InfoDef) :: Info 00090 INTEGER :: i,j,k,l,m,ii,jj,kk 00091 INTEGER :: rmbc,zrmbc 00092 INTEGER :: mx, my, mz 00093 REAL(KIND=qPrec) :: pos(3), mini_pos(3), x_rotated(3), s, temp(3) 00094 REAL(KIND=qPrec), DIMENSION(:,:,:,:), ALLOCATABLE :: A 00095 INTEGER :: iErr 00096 00097 00098 ! IF (ALLOCATED(A)) DEALLOCATE(A) 00099 00100 ! Calculating the number of ghost cells on each side of the grid. 00101 rmbc = levels(Info%level)%gmbc(1)!CoarsenRatio(Info%level-1) * mbc 00102 SELECT CASE(nDim) 00103 CASE(2) 00104 zrmbc=0 00105 CASE(3) 00106 zrmbc=rmbc 00107 END SELECT 00108 00109 mx = Info%mX(1) 00110 my = Info%mX(2) 00111 mz = Info%mX(3) 00112 ! write(*,*) Info%mX, Info%xBounds 00113 ! write(*,*) Info%level 00114 ! write(*,*) levels(Info%level)%dx 00115 CALL ConvertTotalToInternalEnergy(Info%q(1:Info%mX(1), 1:Info%mX(2), 1:Info%mX(3), :)) 00116 00117 IF (nDim == 3) THEN 00118 00119 ALLOCATE(A(1-rmbc:mx+1+rmbc,1-rmbc:my+1+rmbc, 1-zrmbc:mz+1+zrmbc,3), STAT=iErr) 00120 00121 IF (iErr /= 0) THEN 00122 PRINT *, "DomainInitProblem() error: u unable to allocate 3D array." 00123 STOP 00124 END IF 00125 00126 00127 A=0.0 ! A = Magnetic potential (B = curl(A)). 00128 00129 DO k=1-zrmbc, mz+1+zrmbc 00130 DO j=1-rmbc, my+1+rmbc 00131 DO i=1-rmbc, mx+1+rmbc 00132 DO ii=0,0 00133 DO jj=0,0 00134 DO kk=0,0 00135 IF (maxval(abs(A(i,j,k,:))) == 0) THEN 00136 ! write(*,*) shape(pos) 00137 ! write(*,*) shape(Info%xBounds) 00138 ! write(*,*) pos 00139 ! write(*,*) Info%xBounds(1:3,1) 00140 pos=Info%xBounds(1:3,1) 00141 pos=levels(Info%level)%dx 00142 pos=(/REAL(i,KIND=qPREC)-1d0, REAL(j,KIND=qPREC)-1d0, REAL(k,KIND=qPREC)-1d0/) * levels(Info%level)%dx 00143 pos=(/REAL(i,8)-1, REAL(j,8)-1, REAL(k,8)-1/) * levels(Info%level)%dx 00144 00145 00146 pos=Info%xBounds(1:3,1)+(/REAL(i,8)-1, REAL(j,8)-1, REAL(k,8)-1/) * levels(Info%level)%dx 00147 pos(1)=pos(1)+(GxBounds(1,2)-GxBounds(1,1))*(modulo(ii+1,3)-1) 00148 pos(2)=pos(2)+(GxBounds(2,2)-GxBounds(2,1))*(modulo(jj+1,3)-1) 00149 pos(3)=pos(3)+(GxBounds(3,2)-GxBounds(3,1))*(modulo(kk+1,3)-1) 00150 00151 DO l=1,3 00152 mini_pos=pos 00153 DO m=1,sample_res 00154 mini_pos(l) = pos(l) + levels(Info%level)%dx*(REAL(m,8)-half)/REAL(sample_res,8) !sub sample each edge 00155 x_rotated=rotate_y(rotate_z(mini_pos,-phi),-theta) !rotate coordinates again so that vector along jet-axis is along x-axis 00156 s=sqrt(x_rotated(1)**2+x_rotated(2)**2) 00157 IF (abs(x_rotated(3)) < half*thickness .AND. s <= R) THEN !inside of loop region 00158 temp=emf_source_3D(s) 00159 A(i,j,k,l)=A(i,j,k,l)+temp(l) 00160 END IF 00161 END DO 00162 END DO 00163 END IF 00164 END DO 00165 END DO 00166 END DO 00167 END DO 00168 END DO 00169 END DO 00170 00171 A=A/REAL(sample_res, 8) 00172 00173 ! Calculate magnetic fluxes from A (B = curl(A)). 00174 00175 IF (MaintainAuxArrays) THEN 00176 Info%aux=0.0 00177 00178 Info%aux(1-rmbc:mx+rmbc+1, 1-rmbc:my+rmbc, 1-zrmbc:mz+zrmbc, 1)=& 00179 (A(1-rmbc:mx+rmbc+1, 2-rmbc:my+rmbc+1,1-zrmbc:mz+zrmbc, 3) & 00180 - A(1-rmbc:mx+rmbc+1, 1-rmbc:my+rmbc,1-zrmbc:mz+zrmbc, 3))/levels(Info%level)%dX & 00181 - (A(1-rmbc:mx+rmbc+1, 1-rmbc:my+rmbc,2-zrmbc:mz+zrmbc+1, 2)& 00182 - A(1-rmbc:mx+rmbc+1, 1-rmbc:my+rmbc,1-zrmbc:mz+zrmbc, 2))/levels(Info%level)%dx 00183 00184 Info%aux(1-rmbc:mx+rmbc, 1-rmbc:my+rmbc+1, 1-zrmbc:mz+zrmbc, 2)=& 00185 (A(1-rmbc:mx+rmbc, 1-rmbc:my+rmbc+1,2-zrmbc:mz+zrmbc+1, 1)& 00186 - A(1-rmbc:mx+rmbc, 1-rmbc:my+rmbc+1,1-zrmbc:mz+zrmbc, 1))/levels(Info%level)%dx& 00187 - (A(2-rmbc:mx+rmbc+1, 1-rmbc:my+rmbc+1,1-zrmbc:mz+zrmbc, 3)& 00188 - A(1-rmbc:mx+rmbc, 1-rmbc:my+rmbc+1,1-zrmbc:mz+zrmbc, 3))/levels(Info%level)%dx 00189 00190 Info%aux(1-rmbc:mx+rmbc, 1-rmbc:my+rmbc, 1-zrmbc:mz+zrmbc+1, 3)=& 00191 (A(2-rmbc:mx+rmbc+1, 1-rmbc:my+rmbc,1-zrmbc:mz+zrmbc+1, 2)& 00192 - A(1-rmbc:mx+rmbc, 1-rmbc:my+rmbc,1-zrmbc:mz+zrmbc+1, 2))/levels(Info%level)%dx& 00193 - (A(1-rmbc:mx+rmbc, 2-rmbc:my+rmbc+1,1-zrmbc:mz+zrmbc+1, 1)& 00194 - A(1-rmbc:mx+rmbc, 1-rmbc:my+rmbc,1-zrmbc:mz+zrmbc+1, 1))/levels(Info%level)%dx 00195 END IF 00196 ! Info%q=0d0 00197 00198 ! Calculate B-fields 00199 IF (MaintainAuxArrays) THEN 00200 forall(i=1-rmbc:mx+rmbc,j=1-rmbc:my+rmbc, k=1-zrmbc:mz+zrmbc) 00201 Info%q(i,j,k,iBx)=half*(Info%aux(i,j,k,1)+Info%aux(i+1,j,k,1)) 00202 Info%q(i,j,k,iBy)=half*(Info%aux(i,j,k,2)+Info%aux(i,j+1,k,2)) 00203 Info%q(i,j,k,iBz)=half*(Info%aux(i,j,k,3)+Info%aux(i,j,k+1,3)) 00204 end forall 00205 END IF 00206 00207 ! v = rotate_z(rotate_y(v,theta),phi) 00208 ELSE 00209 00210 ! 2D case. 00211 00212 ALLOCATE(A(1-rmbc:mx+rmbc+1,1-rmbc:my+rmbc+1, 1-zrmbc:mz+zrmbc,1), STAT=iErr) 00213 00214 IF (iErr /= 0) THEN 00215 PRINT *, "DomainInitProblem() error: unable to allocate 2D array." 00216 STOP 00217 END IF 00218 00219 A=0.0 ! A = magnetic potential. 00220 00221 ! Initialize A. 00222 DO j=1-rmbc, my+rmbc+1 00223 DO i=1-rmbc, mx+rmbc+1 00224 DO ii=0,2 00225 DO jj=0,2 00226 IF (maxval(abs(A(i,j,1,:))) == 0) THEN 00227 pos=Info%xBounds(1:3,1)+(/REAL(i,8)-1, REAL(j,8)-1, 0d0/) * levels(Info%level)%dx 00228 pos(1)=pos(1)+(GxBounds(1,2)-GxBounds(1,1))*(modulo(ii+1,3)-1) 00229 pos(2)=pos(2)+(GxBounds(2,2)-GxBounds(2,1))*(modulo(jj+1,3)-1) 00230 mini_pos=pos 00231 x_rotated=mini_pos 00232 s=sqrt(x_rotated(1)**2+x_rotated(2)**2) 00233 IF (s <= R) THEN !inside of loop region 00234 temp=emf_source_3D(s) 00235 A(i,j,1,1)=temp(3) 00236 END IF 00237 END IF 00238 END DO 00239 END DO 00240 END DO 00241 END DO 00242 00243 ! Calculate magnetic fluxes (B = curl(A)). 00244 IF (MaintainAuxArrays) THEN 00245 Info%aux=0.0 00246 00247 Info%aux(1-rmbc:mx+1+rmbc, 1-rmbc:my+rmbc, 1-zrmbc:mz+zrmbc, 1)=& 00248 (A(1-rmbc:mx+rmbc+1, 2-rmbc:my+rmbc+1,1-zrmbc:mz+zrmbc, 1) & 00249 -A(1-rmbc:mx+rmbc+1, 1-rmbc:my+rmbc,1-zrmbc:mz+zrmbc, 1))/levels(Info%level)%dx 00250 00251 Info%aux(1-rmbc:mx+rmbc, 1-rmbc:my+rmbc+1, 1-zrmbc:mz+zrmbc, 2)=& 00252 -(A(2-rmbc:mx+rmbc+1, 1-rmbc:my+rmbc+1,1-zrmbc:mz+zrmbc, 1)& 00253 -A(1-rmbc:mx+rmbc, 1-rmbc:my+rmbc+1,1-zrmbc:mz+zrmbc, 1))/levels(Info%level)%dx 00254 END IF 00255 00256 ! Info%q=0d0 00257 00258 ! Calculate magnetic field values from fluxes. 00259 IF (MaintainAuxArrays) THEN 00260 forall(i=1-rmbc:mx+rmbc,j=1-rmbc:my+rmbc, k=1-zrmbc:mz+zrmbc) 00261 Info%q(i,j,k,iBx)=half*(Info%aux(i,j,k,1)+Info%aux(i+1,j,k,1)) 00262 Info%q(i,j,k,iBy)=half*(Info%aux(i,j,k,2)+Info%aux(i,j+1,k,2)) 00263 end forall 00264 END IF 00265 00266 END IF 00267 00268 ! Set other variables. 00269 00270 ! Info%q(:,:,:,1)=rho 00271 ! Info%q(:,:,:,2)=rho*v(1) 00272 ! Info%q(:,:,:,3)=rho*v(2) 00273 ! Info%q(:,:,:,4)=rho*v(3) 00274 00275 ! Calculate the total energy (E_total = E_thermal + E_kinetic + E_magnetic). 00276 00277 CALL ConvertInternalToTotalEnergy(Info%q(1:Info%mX(1), 1:Info%mX(2), 1:Info%mX(3), :)) 00278 00279 DEALLOCATE(A) 00280 00281 END SUBROUTINE ProblemGridInit 00282 00285 SUBROUTINE ProblemBeforeStep(Info) 00286 !! @brief Performs any tasks required before the advance step. 00287 !! @param Info A grid structure. 00288 TYPE (InfoDef) :: Info 00289 INTEGER, DIMENSION(0:2) :: Steps = (/1,4,11/) 00290 LOGICAL, DIMENSION(0:2) :: RestartTriggered=(/.false.,.false.,.false./) 00291 INTEGER :: i 00292 IF (Info%level > 2) RETURN 00293 i = levels(Info%level)%CurrentLevelStep 00294 IF (steps(Info%level) == i .AND. MPI_ID == 0 .AND. .NOT. RestartTriggered(Info%level)) THEN 00295 write(*,*) 'Processor ', MPI_ID, ' purposely requesting restart on level ', Info%level, 'step ', i, 'to test code' 00296 lRequestRestart=.true. 00297 RestartTriggered(Info%level)=.true. 00298 END IF 00299 END SUBROUTINE ProblemBeforeStep 00300 00303 SUBROUTINE ProblemAfterStep(Info) 00304 !! @brief Performs any post-step corrections that are required. 00305 !! @param Info A grid structure. 00306 TYPE (InfoDef) :: Info 00307 REAL(KIND=qPREC) :: dx, t, x, y, s, Bx, By, err 00308 INTEGER :: i,j 00309 IF (lResolutionTest) THEN 00310 t=levels(Info%level)%tnow+levels(Info%level)%dt 00311 IF (abs(t-.1d0) < 1e-6) THEN 00312 write(*,*) 'saving at t=', t 00313 ALLOCATE(infoq(1:Info%mX(1),1:Info%mX(2),2)) 00314 infoq=Info%q(1:Info%mX(1),1:Info%mX(2),1,iBx:iBy) 00315 ELSE IF (abs(t-1.1) < 1e-6) THEN 00316 write(*,*) 'checking at t=', t 00317 dx=levels(Info%level)%dx 00318 err=0 00319 DO i=1, Info%mX(1) 00320 x = GxBounds(1,1)+modulo(Info%xBounds(1,1)+(REAL(i,8)+half)*dx - v(1)*(t-.1) - GxBounds(1,1), GxBounds(1,2)-GxBounds(1,1)) 00321 DO j=1, Info%mX(2) 00322 y = GxBounds(2,1)+modulo(Info%xBounds(2,1)+(REAL(j,8)+half)*dx - v(2)*(t-.1) - GxBounds(2,1), GxBounds(2,2)-GxBounds(2,1)) 00323 s=sqrt(x**2+y**2) 00324 ! IF (s <= R) THEN 00325 ! Bx=-Ao*y/s 00326 ! By=Ao*x/s 00327 ! ELSE 00328 ! Bx=0 00329 ! By=0 00330 ! END IF 00331 if (r > R/2d0) THEN 00332 err=err+sum(abs(infoq(i,j,:)-info%q(i,j,1,iBx:iBy)))*dx**2 00333 END if 00334 END DO 00335 END DO 00336 write(*,*) 'resolution, error= ', dx, err 00337 END IF 00338 END IF 00339 END SUBROUTINE ProblemAfterStep 00340 00343 SUBROUTINE ProblemSetErrFlag(Info) 00344 !! @brief Sets error flags according to problem-specific conditions.. 00345 !! @param Info A grid structure. 00346 TYPE (InfoDef) :: Info 00347 END SUBROUTINE ProblemSetErrFlag 00348 00349 SUBROUTINE ProblemBeforeGlobalStep(n) 00350 INTEGER :: n 00351 END SUBROUTINE ProblemBeforeGlobalStep 00352 00353 00356 FUNCTION emf_source_3D(s) 00357 !! @param s A double-precision number. 00358 REAL(KIND=qPrec) :: s,w(3),emf_source_3D(3) 00359 w=(/0d0,0d0,1d0/)*Ao*(R-s) 00360 emf_source_3D(1:3)=rotate_z(rotate_y(w,theta),phi) !rotate coordinates again so that vector along jet-axis is along x-axis 00361 END FUNCTION emf_source_3D 00362 00363 00364 END MODULE Problem