Scrambler
1
|
00001 !######################################################################### 00002 ! 00003 ! Copyright (C) 2003-2012 Department of Physics and Astronomy, 00004 ! University of Rochester, 00005 ! Rochester, NY 00006 ! 00007 ! sweep_scheme.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 !######################################################################### 00025 00028 00032 00033 !=============================================================================== 00034 ! Module Name: SweepScheme 00035 ! Module File: sweep.f90 00036 ! Purpose: Implements a numerical scheme for solving 00037 ! hydrodynamic equations. 00038 ! Public Methods: ReadSweepDomainData(), sweepadvance() 00039 ! Created: by Jonathan Carroll. 00040 ! Notes: MHD equations are handled by constrained transport 00041 ! through the afterstep() function. 00042 !=============================================================================== 00043 00048 MODULE SweepScheme 00049 00050 USE GlobalDeclarations 00051 USE DataDeclarations 00052 USE HyperbolicDeclarations 00053 USE SourceControl 00054 USE SourceDeclarations 00055 USE PhysicsDeclarations 00056 USE EOS 00057 USE ModuleControl 00058 USE RiemannSolvers 00059 USE DataInfoOps 00060 USE Timing 00061 USE StencilDeclarations 00062 USE SchemeDeclarations 00063 USE StencilControl 00064 USE TreeDeclarations 00065 IMPLICIT NONE 00066 PRIVATE 00067 SAVE 00068 PUBLIC SweepReadDomainData, sweepadvance, SweepAdvanceStackSize 00069 00070 CONTAINS 00071 00072 00073 00074 FUNCTION SweepAdvanceStackSize(n) 00075 INTEGER :: n, SweepAdvanceStackSize, ambc 00076 TYPE(NodeDefList), POINTER :: nodelist 00077 ambc=levels(n)%ambc(1)+hyperbolic_mbc 00078 nodelist=>Nodes(n)%p 00079 SweepAdvanceStackSize=0d0 00080 DO WHILE (ASSOCIATED(nodelist)) 00081 SweepAdvanceStackSize=max(SweepAdvanceStackSize, BufferSizes(nodelist%self%info%mGlobal)) 00082 nodelist=>nodelist%next 00083 END DO 00084 ! Advance stack size should multiplied by the size of qPREC, then by a safety factor, and then 1 MB 00085 SweepAdvanceStackSize=nint(SweepAdvanceStackSize*8*1.5)+1*1024*1024 00086 END FUNCTION SweepAdvanceStackSize 00087 00088 00090 SUBROUTINE SweepReadDomainData() 00091 INTEGER :: iErr, i 00092 00093 NAMELIST/SweepData/ lChar_Limiters, lCTU, lCautious,lLimiter,lGudonov,ViscCD,lApplyLOF,LOF_ALPHA, iTracer, SourceMethod, InterpOrder, lApplyDiffusion, DIFF_ALPHA, lUsePPML 00094 00095 ! Flags for various sweep options are initialized with defaults. 00096 lLimiter=.true. 00097 lChar_Limiters=.true. 00098 lUsePPML=.false. 00099 lCTU=.true. 00100 lCautious=.true. 00101 lHLLTypeSolver=.false. 00102 iTracer=NONLAGRANGIAN 00103 lGudonov=.false. 00104 ViscCD = 0 00105 lApplyLOF = .false. 00106 LOF_ALPHA=.075 00107 DIFF_ALPHA=.1 00108 lApplyDiffusion=.false. 00109 InterpOrder = -1 00110 00111 READ(SOLVER_DATA_HANDLE,NML=SweepData,IOStat=iErr) 00112 IF(iErr/=0) THEN 00113 PRINT*,'SweepReadDomainData() error: unable to read SweepData namelist.' 00114 STOP 00115 END IF 00116 00117 ! These methods really need to be listed by name. 00118 lIsothermal = iEOS == EOS_ISOTHERMAL 00119 00120 ! Backwards compatability for interpolation method 00121 IF (lGudonov) THEN 00122 IF (InterpOrder == -1) THEN 00123 PRINT*, 'lGudonov is being depracated. Use InterpOrder == 1 instead' 00124 InterpOrder = 1 00125 ELSEIF (InterpOrder == 1) THEN 00126 PRINT*, 'lGudonov is not needed in solver.data' 00127 ELSE 00128 PRINT*, 'lGudonov conflicts with InterpOrder /= 1. Ignoring lGudonov!!!' 00129 END IF 00130 END IF 00131 IF (InterpOrder < 1) InterpOrder = 3 00132 IF (InterpOrder == 1) lGudonov=.true. 00133 IF (InterpOrder < 3) lUsePPML=.false. 00134 ! Check choice of riemann solvers 00135 IF (iSolver == 3 .OR. iSolver == 2 .OR. iSolver == 4 .OR. iSolver == 6 .OR. iSolver == 8) THEN 00136 lHLLTypeSolver=.true. 00137 END IF 00138 00139 ! write(*,*) 'iSolver=', iSolver 00140 00141 !Setup variables for mapping q to fluxes in x y and z direction 00142 IF (lMHD) THEN 00143 NrWaves=NrCons-1 00144 ELSE 00145 NrWaves=NrCons 00146 END IF 00147 00148 nSweepFlux=nFlux 00149 IF (iTracer == NONLAGRANGIAN) THEN 00150 NrWaves=NrWaves+NrTracerVars 00151 SweepCons=NrCons+NrTracerVars 00152 nSweepFlux=nFlux 00153 ELSE 00154 SweepCons=NrCons 00155 nSweepFlux=nFlux-NrTracerVars 00156 END IF 00157 00158 ALLOCATE(SweepFluxFields(nSweepFlux)) 00159 SweepFluxFields(1:nSweepFlux)=FluxFields(1:nSweepFlux) 00160 00161 00162 ALLOCATE(oneDx_i(NrWaves),oneDy_i(NrWaves),oneDz_i(NrWaves), & 00163 wDx_i(SweepCons),wDy_i(SweepCons),wDz_i(SweepCons), & 00164 fDx_i(SweepCons),fDy_i(SweepCons),fDz_i(SweepCons), STAT=iErr) 00165 00166 IF (iErr /= 0) THEN 00167 PRINT *, "SweepReadDomainData() error: unable to allocate arrays." 00168 STOP 00169 END IF 00170 00171 IF (lMHD) THEN 00172 IF (lIsothermal) THEN 00173 oneDx_i(1:6)=(/1,2,3,4,6,7/) 00174 oneDy_i(1:6)=(/1,3,4,2,7,5/) 00175 oneDz_i(1:6)=(/1,4,2,3,5,6/) 00176 wDx_i(1:7)=(/1,2,3,4,5,6,7/) 00177 wDy_i(1:7)=(/1,3,4,2,6,7,5/) 00178 wDz_i(1:7)=(/1,4,2,3,7,5,6/) 00179 fDx_i(1:7)=(/1,2,3,4,5,6,7/) 00180 fDy_i(1:7)=(/1,4,2,3,7,5,6/) 00181 fDz_i(1:7)=(/1,3,4,2,6,7,5/) 00182 ELSE 00183 oneDx_i(1:7)=(/1,5,2,3,4,7,8/) 00184 oneDy_i(1:7)=(/1,5,3,4,2,8,6/) 00185 oneDz_i(1:7)=(/1,5,4,2,3,6,7/) 00186 wDx_i(1:8)=(/1,5,2,3,4,6,7,8/) 00187 wDy_i(1:8)=(/1,5,3,4,2,7,8,6/) 00188 wDz_i(1:8)=(/1,5,4,2,3,8,6,7/) 00189 fDx_i(1:8)=(/1,3,4,5,2,6,7,8/) 00190 fDy_i(1:8)=(/1,5,3,4,2,8,6,7/) 00191 fDz_i(1:8)=(/1,4,5,3,2,7,8,6/) 00192 END IF 00193 ELSE 00194 IF (lIsothermal) THEN 00195 IF (nDim == 1) THEN 00196 oneDx_i(1:2)=(/1,2/) 00197 wDx_i(1:2)=(/1,2/) 00198 fDx_i(1:2)=(/1,2/) 00199 ELSE IF (nDim == 2) THEN 00200 IF (iCylindrical.ne.WithAngMom) THEN 00201 oneDx_i(1:3)=(/1,2,3/) 00202 oneDy_i(1:3)=(/1,3,2/) 00203 wDx_i(1:3)=(/1,2,3/) 00204 wDy_i(1:3)=(/1,3,2/) 00205 fDx_i(1:3)=(/1,2,3/) 00206 fDy_i(1:3)=(/1,3,2/) 00207 ELSE 00208 oneDx_i(1:4)=(/1,2,3,4/) 00209 oneDy_i(1:4)=(/1,3,4,2/) 00210 ! oneDz_i(1:4)=(/1,4,2,3/) 00211 wDx_i(1:4)=(/1,2,3,4/) 00212 wDy_i(1:4)=(/1,3,4,2/) 00213 ! wDz_i(1:4)=(/1,4,2,3/) 00214 fDx_i(1:4)=(/1,2,3,4/) 00215 fDy_i(1:4)=(/1,4,2,3/) 00216 ! fDz_i(1:4)=(/1,3,4,2/) 00217 END IF 00218 ELSE 00219 oneDx_i(1:4)=(/1,2,3,4/) 00220 oneDy_i(1:4)=(/1,3,4,2/) 00221 oneDz_i(1:4)=(/1,4,2,3/) 00222 wDx_i(1:4)=(/1,2,3,4/) 00223 wDy_i(1:4)=(/1,3,4,2/) 00224 wDz_i(1:4)=(/1,4,2,3/) 00225 fDx_i(1:4)=(/1,2,3,4/) 00226 fDy_i(1:4)=(/1,4,2,3/) 00227 fDz_i(1:4)=(/1,3,4,2/) 00228 END IF 00229 ELSE 00230 IF (nDim == 1) THEN 00231 oneDx_i(1:3)=(/1,3,2/) 00232 wDx_i(1:3)=(/1,3,2/) 00233 fDx_i(1:3)=(/1,3,2/) 00234 ELSE IF (nDim == 2) THEN 00235 IF (iCylindrical.ne.WithAngMom) THEN 00236 oneDx_i(1:4)=(/1,4,2,3/) 00237 oneDy_i(1:4)=(/1,4,3,2/) 00238 wDx_i(1:4)=(/1,4,2,3/) 00239 wDy_i(1:4)=(/1,4,3,2/) 00240 00241 fDx_i(1:4)=(/1,3,4,2/) 00242 fDy_i(1:4)=(/1,4,3,2/) 00243 ELSE 00244 oneDx_i(1:5)=(/1,5,2,3,4/) 00245 oneDy_i(1:5)=(/1,5,3,4,2/) 00246 wDx_i(1:5) =(/1,5,2,3,4/) 00247 wDy_i(1:5) =(/1,5,3,4,2/) 00248 fDx_i(1:5) =(/1,3,4,5,2/) 00249 fDy_i(1:5) =(/1,5,3,4,2/) 00250 END IF 00251 ELSE 00252 oneDx_i(1:5)=(/1,5,2,3,4/) 00253 oneDy_i(1:5)=(/1,5,3,4,2/) 00254 oneDz_i(1:5)=(/1,5,4,2,3/) 00255 wDx_i(1:5)=(/1,5,2,3,4/) 00256 wDy_i(1:5)=(/1,5,3,4,2/) 00257 wDz_i(1:5)=(/1,5,4,2,3/) 00258 fDx_i(1:5)=(/1,3,4,5,2/) 00259 fDy_i(1:5)=(/1,5,3,4,2/) 00260 fDz_i(1:5)=(/1,4,5,3,2/) 00261 END IF 00262 END IF 00263 END IF 00264 00265 ! Set the number of conserved variables that are handled by sweep. The 00266 ! magnetic fields are 00267 ! handled by the CT scheme rather than the sweep itself, so they are 00268 ! not included in the number 00269 ! of conserved variables. 00270 00271 IF (NrTracerVars > 0 .AND. iTracer == NONLAGRANGIAN) THEN 00272 IF (lMHD) THEN 00273 OneDx_i(NrCons:NrWaves) = (/(i,i=nTracerLo, nTracerHi)/) 00274 OneDy_i(NrCons:NrWaves) = (/(i,i=nTracerLo, nTracerHi)/) 00275 OneDz_i(NrCons:NrWaves) = (/(i,i=nTracerLo, nTracerHi)/) 00276 ELSE 00277 OneDx_i(NrCons+1:NrWaves) = (/(i,i=nTracerLo, nTracerHi)/) 00278 OneDy_i(NrCons+1:NrWaves) = (/(i,i=nTracerLo, nTracerHi)/) 00279 OneDz_i(NrCons+1:NrWaves) = (/(i,i=nTracerLo, nTracerHi)/) 00280 END IF 00281 wDx_i(NrCons+1:SweepCons) = (/(i,i=nTracerLo, nTracerHi)/) 00282 wDy_i(NrCons+1:SweepCons) = (/(i,i=nTracerLo, nTracerHi)/) 00283 wDz_i(NrCons+1:SweepCons) = (/(i,i=nTracerLo, nTracerHi)/) 00284 fDx_i(NrCons+1:SweepCons) = (/(i,i=nTracerLo, nTracerHi)/) 00285 fDy_i(NrCons+1:SweepCons) = (/(i,i=nTracerLo, nTracerHi)/) 00286 fDz_i(NrCons+1:SweepCons) = (/(i,i=nTracerLo, nTracerHi)/) 00287 END IF 00288 00289 00290 ALLOCATE(LevelBuffers(0:MaxLevel)) !Cache for each level advance 00291 ALLOCATE(index_start_bylevel(0:MaxLevel)) !Cache index for each level's sweep for pseudo threading 00292 index_start_bylevel(:)=THEBEGINNING 00293 CALL setup() 00294 00295 END SUBROUTINE SweepReadDomainData 00296 00300 SUBROUTINE sweepAdvance(Info, dom_range, lComplete, lProfile_opt) 00301 00302 # if defined PTH 00303 USE PthDeclarations 00304 # endif 00305 USE Scheduling 00306 ! SAVE 00307 TYPE (InfoDef) :: Info 00308 LOGICAL :: lComplete, lProfile 00309 LOGICAL, OPTIONAL :: lProfile_opt 00310 ! REAL(KIND=qPREC), OPTIONAL :: TimeAvailableToSolver 00311 INTEGER :: index,level, index_start, index_finish 00312 REAL(KIND=qPREC), PARAMETER :: PPMC=1.25 00313 REAL(KIND=qPrec) :: cfl, CostPerSweep 00314 REAL(KIND=qPrec) :: dt,dtdx,dtdy,dtdz,hdtdx,hdtdy,hdtdz,hdt,qdtdx,qdtdy,qdtdz,two_thirds_dtdx, 00315 two_thirds_dtdy, two_thirds_dtdz, three_dtdx, three_dtdy, three_dtdz,dx,qdt,hdx, dv, d2, d2R, d2L, d2C, d2m 00316 REAL(KIND=qPrec) :: t_loopstart, t_loopend 00317 00318 REAL(8) :: tused 00319 INTEGER :: dom_range(3,2), bc(3) 00320 00321 LOGICAL :: partialOK 00322 00323 TYPE(StencilBufferDef), POINTER :: w_,qLx_,qRx_,qLy_,qRy_,qLz_,qRz_,fx_,fy_,fz_,q2Lx_,q2Rx_,q2Ly_,q2Ry_,q2Lz_,q2Rz_,f2x_,f2y_,f2z_,limiter_x_,limiter_y_,limiter_z_,limiter_ppm_,pT_,qex_,qey_,qez_,dqx_,dqy_,dqz_,ex_,ey_,ez_,ex_bar_,ey_bar_,ez_bar_,e2x_,e2y_,e2z_,e2x_bar_,e2y_bar_,e2z_bar_,ctfy_,ctfz_,ctfx_,ctf2x_,ctf2y_,ctf2z_,w2_,A2x_,A2y_,A2z_,Sx_,Sy_,Sz_,w3_,A3x_,A3y_,A3z_,SpeedsX_,SpeedsY_,SpeedsZ_,leftX_,leftY_,leftZ_,rightX_,rightY_,rightZ_,nWaves_,req_eigens_,adfx_,adfy_,adfz_,eta2x_,eta2y_,eta2z_,etax_,etay_,etaz_,q_,aux_,recon_,beforesweepstep_,aftersweepstep_,source_,source2_,cornerdiv_,gradphix_,gradphiy_,gradphiz_ 00324 00325 lProfile=.false. 00326 IF (PRESENT(lProfile_opt)) lProfile=lProfile_opt 00327 level=Info%level 00328 00329 dx=levels(level)%dx 00330 dv=dx**nDim 00331 dt=levels(level)%dt 00332 hdt=half*dt 00333 qdt=fourth*dt 00334 hdx=half*dx 00335 dtdx=dt/dx;dtdy=dtdx;dtdz=dtdx 00336 hdtdx=half*dtdx;hdtdy=half*dtdy;hdtdz=half*dtdz 00337 qdtdx=fourth*dtdx;qdtdy=fourth*dtdy;qdtdz=fourth*dtdz; 00338 two_thirds_dtdx=2d0/3d0*dtdx 00339 two_thirds_dtdy=2d0/3d0*dtdy 00340 two_thirds_dtdz=2d0/3d0*dtdz 00341 three_dtdx=3d0*dtdx 00342 three_dtdy=3d0*dtdy 00343 three_dtdz=3d0*dtdz 00344 ! AdvanceTimer%LastStarted(level)=MPI_WTIME() 00345 00346 t_startadvance(level)=mpi_wtime() 00347 IF (index_start_bylevel(level) == THEBEGINNING) THEN 00348 WorkDoneByGrid(level) = 0d0 00349 IF (.NOT. lProfile) CALL BeforeStep(Info) 00350 # if defined PTH 00351 IF (iThreaded == THREADED .AND. level < MaxLevel) CALL yield(level) 00352 # endif 00353 CALL initialize_buffer(LevelBuffers(level), dom_range) 00354 index_start_bylevel(level)=dom_range(1,1)-MaxLead 00355 AdvanceState=RUNNING 00356 ELSE !must be using scheduling 00357 IF (AdvanceStencil(level) /= 0) THEN 00358 AdvanceState = RESUMING 00359 ELSE 00360 AdvanceState = RUNNING 00361 END IF 00362 END IF 00363 00364 IF (lComplete) THEN 00365 tStopAdvance=FOREVER 00366 ELSE 00367 tStopAdvance=TimeAvailableToSolver 00368 END IF 00369 00370 CALL LoadLevelStencilBuffers(level) 00371 00372 00373 DO index=index_start_bylevel(level),dom_range(1,2)+MaxTrail 00374 00375 # if defined PTH 00376 IF (iThreaded == THREADED .AND. level < MaxLevel) CALL yield(level) 00377 # endif 00378 CALL SweepBeforeStep(Info,index) 00379 CALL Init_prims(Info, index) 00380 CALL Reconstruct(Info, index) 00381 IF (ViscCD == ROE_VISCOSITY .OR. ViscCD == H_VISCOSITY) CALL HVisc(Info, index) 00382 IF (nDim >= 2) THEN 00383 CALL calc_fluxes(Info, index) 00384 IF (lMHD) THEN 00385 CALL calc_emf(Info, index) 00386 CALL updateB(Info, index) 00387 CALL update_fluxes(Info, index) 00388 END IF 00389 IF (lMHD .OR. (NrTracerVars > 0 .AND. iTracer==LAGRANGIAN)) CALL updatew2(Info,index) 00390 CALL CTU(Info,index) 00391 CALL calc_final_fluxes(Info, index) 00392 IF (NrTracerVars > 0 .AND. iTracer == LAGRANGIAN) CALL calc_tracer_fluxes(Info, index) 00393 CALL update_final_fluxes(Info, index) 00394 CALL update_final(Info,index) 00395 IF (lMHD) THEN 00396 CALL calc_final_emf(Info, index) 00397 CALL updateB_final(Info, index) 00398 END IF 00399 ELSE 00400 CALL calc_fluxes_noctu(Info, index) 00401 CALL update_final_fluxes(Info, index) 00402 CALL update_final(Info,index) 00403 END IF 00404 CALL store_fixup_fluxes(Info, index) 00405 CALL SweepAfterStep(Info,index) 00406 00407 IF (AdvanceState == STOPPING) EXIT 00408 END DO 00409 00410 IF (AdvanceState == RUNNING) THEN 00411 index_start_bylevel(level) = THEBEGINNING 00412 NodeCompleted(level)=.true. 00413 00414 CALL Clear_Buffer(LevelBuffers(level)) 00415 CALL UpdateAux(Info, dom_range) 00416 IF (.NOT. lProfile) CALL AfterStep(Info) 00417 maxspeed(level)=max(maxspeed(level), GetMaxSpeed(Info%q(1:Info%mx(1),1:Info%mx(2),1:Info%mx(3),:))) 00418 00419 tused = mpi_wtime()-t_startadvance(level) 00420 WorkDoneByGrid(level)=WorkDoneByGrid(level)+tused 00421 WorkDoneByLevel(level)=WorkDoneByLevel(level)-WorkDoneByGrid(level)+Info%CostPerGrid(levels(Info%level)%step) 00422 00423 IF (.NOT. lProfile) InternalCellUpdates(level)=InternalCellUpdates(level)+product(Info%mX(1:nDim)) 00424 IF (.NOT. lProfile) CellUpdates(level)=CellUpdates(level)+product(dom_range(:,2)-dom_range(:,1)+1) 00425 AdvancePredictor%Accumulator(level)=AdvancePredictor%Accumulator(level)+info%costpergrid(levels(Info%level)%step) 00426 ! AdvanceTimer%Accumulator(level)=AdvanceTimer%Accumulator(level)+WorkDoneByGrid(level) 00427 ! MySpeedFactor=sum(AdvanceTimer%Accumulator(0:MaxLevel))/sum(AdvancePredictor%Accumulator(0:MaxLevel)) 00428 ELSE 00429 index_start_bylevel(level) = index 00430 NodeCompleted(level)=.false. 00431 tused = mpi_wtime()-t_startadvance(level) 00432 WorkDoneByLevel(level)=WorkDoneByLevel(level)+tused 00433 WorkDoneByGrid(level)=WorkDoneByGrid(level)+tused 00434 END IF 00435 00436 CONTAINS 00437 00442 SUBROUTINE SweepBeforeStep(Info, index) 00443 TYPE(InfoDef) :: Info ! Info structure currently updating 00444 INTEGER :: index ! Current row in q being updated 00445 INTEGER :: i,j,k ! Loop counters 00446 INTEGER :: mB(3,2) ! Bounds of slab to update 00447 INTEGER :: mS(3,2) ! Bounds of slab to update in grid space 00448 00449 IF (isTimeShift(index, Info%level, beforesweepstep, mB)) then 00450 ms(1,:)=index+mB(1,:) 00451 mS(2:3,:)=mB(2:3,:) 00452 00453 IF (lSourceTerms) THEN 00454 ms(1,:)=index+mB(1,:) 00455 mS(2:3,:)=mB(2:3,:) 00456 CALL Src(Info, mS, levels(info%level)%tnow, hdt) 00457 END IF 00458 DO i=mB(1,1), mB(1,2) 00459 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 00460 beforesweepstep_%data(beforesweepstep_%x(i),j,k,1,1:NrHydroVars) = & 00461 Info%q(index+i,j,k,1:NrHydroVars) 00462 END FORALL 00463 END DO 00464 mS=mB 00465 mS(1,:)=mB(1,:)+index 00466 END IF 00467 END SUBROUTINE SweepBeforeStep 00468 00473 SUBROUTINE SweepAfterStep(Info, index) 00474 TYPE(InfoDef) :: Info ! Info structure currently updating 00475 INTEGER :: index ! Current row in q being updated 00476 INTEGER :: i,j,k ! Loop counters 00477 INTEGER :: mB(3,2) ! Bounds of slab to update 00478 IF (IsTime(index, Info%level, aftersweepstep, mB)) THEN 00479 IF (lSourceTerms) THEN 00480 mb(1,:)=index+mB(1,:) 00481 CALL Src(Info, mb, levels(info%level)%tnow+hdt, hdt) 00482 END IF 00483 END IF 00484 END SUBROUTINE SweepAfterStep 00485 00486 00491 SUBROUTINE Init_prims(Info, index) 00492 TYPE(InfoDef) :: Info ! Info structure currently updating 00493 INTEGER :: index ! Current row in q being updated 00494 INTEGER :: i,j,k ! Loop counters 00495 INTEGER :: mB(3,2) ! Bounds of slab to update 00496 00497 IF (istimeshift(index, Info%level, w, mB)) THEN 00498 DO i=mB(1,1),mB(1,2) 00499 CALL cons_to_prim_2(beforesweepstep_%data(beforesweepstep_%x(i),mB(2,1):mB(2,2),mB(3,1):mB(3,2),1,1:SweepCons),w_%data(w_%x(i),mB(2,1):mB(2,2),mB(3,1):mB(3,2),1,1:SweepCons)) 00500 IF (lCautious) CALL protect_all(w_%data(w_%x(i),mB(2,1):mB(2,2),mB(3,1):mB(3,2),1,:)) 00501 END DO 00502 00503 END IF 00504 END SUBROUTINE Init_prims 00505 00512 SUBROUTINE Reconstruct(Info,index) 00513 TYPE(InfoDef) :: Info ! Info structure currently updating 00514 INTEGER :: index ! Current row in q being updated 00515 INTEGER :: i,j,k ! Loop counters 00516 INTEGER :: mB(3,2) ! Bounds of slab to update 00517 INTEGER :: mC(3,2) ! Bounds of slab to update 00518 REAL(Kind=qPrec) :: dq, sdq2,qmhsq, lambda_min, lambda_max, dp 00519 INTEGER :: m,waves,n_waves 00520 REAL(KIND=qPrec), DIMENSION(:), ALLOCATABLE :: dleft, dright, dcenter, dw, dw6,dwmdw6, dwpdw6,dw_l,deltaq,aleft,aright,acenter 00521 REAL(KIND=qPREC), DIMENSION(:), POINTER :: q 00522 00523 IF (InterpOrder == 1) THEN 00524 IF (istimeshift(index, Info%level, qRx, mB)) THEN 00525 qRx_%data(qRx_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,:) = & 00526 w_%data(w_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,:) 00527 IF (lMHD .AND. nDim == 1) qRx_%data(qRx_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,iBx) = & 00528 Info%q(1,1,1,iBx) 00529 IF (lMHD .AND. nDim >= 2) qRx_%data(qRx_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,iBx) = & 00530 Info%aux(index+mB(1,1):index+mB(1,2),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1) 00531 END IF 00532 IF (istimeshift(index, Info%level, qLx, mB)) THEN 00533 qLx_%data(qLx_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,:) = & 00534 w_%data(w_%x(mB(1,1)-1:mB(1,2)-1),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,:) 00535 IF (lMHD .AND. nDim == 1) qLx_%data(qLx_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,iBx) = & 00536 Info%q(1,1,1,iBx) 00537 IF (lMHD .AND. nDim >= 2) qLx_%data(qLx_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,iBx) = & 00538 Info%aux(index+mB(1,1):index+mB(1,2),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1) 00539 END IF 00540 IF (istimeshift(index, Info%level, qRy, mB)) THEN 00541 qRy_%data(qRy_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,:) = & 00542 w_%data(w_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,:) 00543 IF (lMHD) qRy_%data(qRy_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,iBy) = & 00544 Info%aux(index+mB(1,1):index+mB(1,2),mB(2,1):mB(2,2), mB(3,1):mB(3,2),2) 00545 END IF 00546 IF (istimeshift(index, Info%level, qLy, mB)) THEN 00547 qLy_%data(qLy_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,:) = & 00548 w_%data(w_%x(mB(1,1):mB(1,2)),mB(2,1)-1:mB(2,2)-1, mB(3,1):mB(3,2),1,:) 00549 IF (lMHD) qLy_%data(qLy_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,iBy) = & 00550 Info%aux(index+mB(1,1):index+mB(1,2),mB(2,1):mB(2,2), mB(3,1):mB(3,2),2) 00551 END IF 00552 IF (istimeshift(index, Info%level, qRz, mB)) THEN 00553 qRz_%data(qRz_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,:) = & 00554 w_%data(w_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,:) 00555 IF (lMHD) qRz_%data(qRz_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,iBz) = & 00556 Info%aux(index+mB(1,1):index+mB(1,2),mB(2,1):mB(2,2), mB(3,1):mB(3,2),3) 00557 END IF 00558 IF (istimeshift(index, Info%level, qLz, mB)) THEN 00559 qLz_%data(qLz_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,:) = & 00560 w_%data(w_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1)-1:mB(3,2)-1,1,:) 00561 IF (lMHD) qLz_%data(qLz_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,iBz) = & 00562 Info%aux(index+mB(1,1):index+mB(1,2),mB(2,1):mB(2,2), mB(3,1):mB(3,2),3) 00563 END IF 00564 00565 ELSE !Interp order = 2 or 3 00566 00567 IF (lLimiter .OR. lApplyLOF) THEN 00568 CALL calc_limiters(Info, index) 00569 END IF 00570 IF (.NOT. request_eigens(Info, index) .AND. .NOT. lRequestRestart) THEN 00571 write(*,*) "Request eigens failed at", index,j,k 00572 lRequestRestart=.true. 00573 RETURN 00574 ! STOP 00575 END IF 00576 ALLOCATE (dleft(NrWaves), dright(NrWaves), dcenter(NrWaves), dw(NrWaves), dw6(NrWaves), & 00577 dwmdw6(NrWaves), dwpdw6(NrWaves), dw_l(NrWaves), deltaq(NrWaves), & 00578 aleft(NrWaves),aright(NrWaves), acenter(NrWaves)) 00579 00580 00581 00582 ! First calculate limited slopes. If using Characteristic Limiters - first project slopes onto eigen vectors, limit characteristics, and project back. 00583 00584 00585 IF(istimeshift(index, Info%level, dqx, mB)) THEN 00586 DO i=mB(1,1),mB(1,2) 00587 DO j=mB(2,1),mB(2,2) 00588 DO k=mB(3,1),mB(3,2) 00589 DO m=1,NrWaves 00590 !Calculate right, left, and the center differences. 00591 dright(m)=w_%data(w_%x(i+1),j,k,1,oneDx_i(m))-w_%data(w_%x(i),j,k,1,oneDx_i(m)) 00592 dleft(m)=w_%data(w_%x(i),j,k,1,oneDx_i(m))-w_%data(w_%x(i-1),j,k,1,oneDx_i(m)) 00593 dcenter(m)=half*(dleft(m)+dright(m)) 00594 END DO 00595 IF (.NOT. lUsePPML) THEN !limit 1st order slopes 00596 IF (lChar_Limiters) THEN 00597 !Map gradients to characteristic variables 00598 n_waves=NINT(nWaves_%data(nWaves_%x(i),j,k,1,1)) 00599 DO m=1, n_waves 00600 aleft(m)=DOT_PRODUCT(leftX_%data(leftX_%x(i),j,k,m,:), dleft) 00601 aright(m)=DOT_PRODUCT(leftX_%data(leftX_%x(i),j,k,m,:), dright) 00602 ! Limit slopes in characteristice variables by method of VanLeer 00603 IF (SIGN(1d0,aleft(m)) == SIGN(1d0,aright(m))) THEN 00604 acenter(m)=DOT_PRODUCT(leftX_%data(leftX_%x(i),j,k,m,:), dcenter) 00605 acenter(m)=sign(min(2d0*abs(aleft(m)), 2d0*abs(aright(m)), abs(acenter(m))), acenter(m)) 00606 ELSE 00607 acenter(m)=0d0 00608 END IF 00609 END DO 00610 ! Now what are we doing here? We are symmetrizing this operation... 00611 00612 00613 IF (abs(SpeedsX_%data(SpeedsX_%x(i),j,k,1,1)) > abs(SpeedsX_%data(SpeedsX_%x(i),j,k,1,n_waves))) THEN 00614 DO m=1,NrWaves 00615 dqx_%data(dqx_%x(i),j,k,1,m)=DOT_PRODUCT(rightX_%data(rightX_%x(i),j,k,1:n_waves,m) , acenter(1:n_waves)) 00616 END DO 00617 ELSEIF (abs(SpeedsX_%data(SpeedsX_%x(i),j,k,1,1)) < abs(SpeedsX_%data(SpeedsX_%x(i),j,k,1,n_waves))) THEN 00618 DO m=1,NrWaves 00619 dqx_%data(dqx_%x(i),j,k,1,m)=DOT_PRODUCT(rightX_%data(rightX_%x(i),j,k,n_waves:1:-1,m) , acenter(n_waves:1:-1)) 00620 END DO 00621 ELSE !Do symmetric addition! 00622 DO m=1,NrWaves 00623 dqx_%data(dqx_%x(i),j,k,1,m)=half*(DOT_PRODUCT(rightX_%data(rightX_%x(i),j,k,1:n_waves,m) , acenter(1:n_waves)) + DOT_PRODUCT(rightX_%data(rightX_%x(i),j,k,n_waves:1:-1,m) , acenter(n_waves:1:-1))) 00624 END DO 00625 END IF 00626 ELSE 00627 DO m=1,NrWaves 00628 IF (SIGN(1d0,dleft(m)) == SIGN(1d0,dright(m))) THEN 00629 dqx_%data(dqx_%x(i),j,k,1,m)=sign(min(2d0*abs(dleft(m)), 2d0*abs(dright(m)), abs(dcenter(m))), dcenter(m)) 00630 ELSE 00631 dqx_%data(dqx_%x(i),j,k,1,m) = 0d0 00632 END IF 00633 END DO 00634 END IF 00635 ELSE 00636 dqx_%data(dqx_%x(i),j,k,1,1:NrWaves) = dcenter(1:NrWaves) 00637 END IF 00638 IF (lLimiter) THEN 00639 IF (limiter_ppm_%data(limiter_ppm_%x(i),j,k,1,1) < 1d0) THEN 00640 dqx_%data(dqx_%x(i),j,k,1,:)=dqx_%data(dqx_%x(i),j,k,1,:)*limiter_ppm_%data(limiter_ppm_%x(i),j,k,1,1) 00641 END IF 00642 END IF 00643 END DO 00644 END DO 00645 END DO 00646 END IF 00647 00648 IF(istimeshift(index, Info%level, dqy, mB)) THEN 00649 00650 DO i=mB(1,1),mB(1,2) 00651 DO j=mB(2,1),mB(2,2) 00652 DO k=mB(3,1),mB(3,2) 00653 DO m=1,NrWaves 00654 dright(m)=w_%data(w_%x(i),j+1,k,1,oneDy_i(m))-w_%data(w_%x(i),j,k,1,oneDy_i(m)) 00655 dleft(m)=w_%data(w_%x(i),j,k,1,oneDy_i(m))-w_%data(w_%x(i),j-1,k,1,oneDy_i(m)) 00656 dcenter(m)=half*(dleft(m)+dright(m)) 00657 END DO 00658 IF (.NOT. lUsePPML) THEN !limit 1st order slopes 00659 IF (lChar_Limiters) THEN 00660 n_waves=NINT(nWaves_%data(nWaves_%x(i),j,k,1,2)) 00661 DO m=1, n_waves 00662 aleft(m)=DOT_PRODUCT(leftY_%data(leftY_%x(i),j,k,m,:), dleft) 00663 aright(m)=DOT_PRODUCT(leftY_%data(leftY_%x(i),j,k,m,:), dright) 00664 IF (SIGN(1d0,aleft(m)) == SIGN(1d0,aright(m))) THEN 00665 acenter(m)=DOT_PRODUCT(leftY_%data(leftY_%x(i),j,k,m,:), dcenter) 00666 acenter(m)=sign(min(2d0*abs(aleft(m)), 2d0*abs(aright(m)), abs(acenter(m))), acenter(m)) 00667 ELSE 00668 acenter(m)=0d0 00669 END IF 00670 END DO 00671 IF (abs(SpeedsY_%data(SpeedsY_%x(i),j,k,1,1)) > abs(SpeedsY_%data(SpeedsY_%x(i),j,k,1,n_waves))) THEN 00672 DO m=1,NrWaves 00673 dqy_%data(dqy_%x(i),j,k,1,m)=DOT_PRODUCT(rightY_%data(rightY_%x(i),j,k,1:n_waves,m) , acenter(1:n_waves)) 00674 END DO 00675 ELSEIF (abs(SpeedsY_%data(SpeedsY_%x(i),j,k,1,1)) < abs(SpeedsY_%data(SpeedsY_%x(i),j,k,1,n_waves))) THEN 00676 DO m=1,NrWaves 00677 dqy_%data(dqy_%x(i),j,k,1,m)=DOT_PRODUCT(rightY_%data(rightY_%x(i),j,k,n_waves:1:-1,m) , acenter(n_waves:1:-1)) 00678 END DO 00679 ELSE 00680 DO m=1,NrWaves 00681 dqy_%data(dqy_%x(i),j,k,1,m)=half*(DOT_PRODUCT(rightY_%data(rightY_%x(i),j,k,1:n_waves,m) , acenter(1:n_waves)) + DOT_PRODUCT(rightY_%data(rightY_%x(i),j,k,n_waves:1:-1,m) , acenter(n_waves:1:-1))) 00682 END DO 00683 END IF 00684 ELSE 00685 DO m=1,NrWaves 00686 IF (SIGN(1d0,dleft(m)) == SIGN(1d0,dright(m))) THEN 00687 dqy_%data(dqy_%x(i),j,k,1,m)=sign(min(2d0*abs(dleft(m)), 2d0*abs(dright(m)), abs(dcenter(m))), dcenter(m)) 00688 ELSE 00689 dqy_%data(dqy_%x(i),j,k,1,m) = 0d0 00690 END IF 00691 END DO 00692 END IF 00693 ELSE 00694 dqy_%data(dqy_%x(i),j,k,1,1:NrWaves) = dcenter(1:NrWaves) 00695 END IF 00696 END DO 00697 END DO 00698 END DO 00699 END IF 00700 00701 IF(istimeshift(index, Info%level, dqz, mB)) THEN 00702 00703 DO i=mB(1,1),mB(1,2) 00704 DO j=mB(2,1),mB(2,2) 00705 DO k=mB(3,1),mB(3,2) 00706 DO m=1,NrWaves 00707 dright(m)=w_%data(w_%x(i),j,k+1,1,oneDz_i(m))-w_%data(w_%x(i),j,k,1,oneDz_i(m)) 00708 dleft(m)=w_%data(w_%x(i),j,k,1,oneDz_i(m))-w_%data(w_%x(i),j,k-1,1,oneDz_i(m)) 00709 dcenter(m)=half*(dleft(m)+dright(m)) 00710 END DO 00711 IF (.NOT. lUsePPML) THEN !limit 1st order slopes 00712 IF (lChar_Limiters) THEN 00713 n_waves=NINT(nWaves_%data(nWaves_%x(i),j,k,1,3)) 00714 DO m=1, n_waves 00715 aleft(m)=DOT_PRODUCT(leftZ_%data(leftZ_%x(i),j,k,m,:), dleft) 00716 aright(m)=DOT_PRODUCT(leftZ_%data(leftZ_%x(i),j,k,m,:), dright) 00717 IF (SIGN(1d0,aleft(m)) == SIGN(1d0,aright(m))) THEN 00718 acenter(m)=DOT_PRODUCT(leftZ_%data(leftZ_%x(i),j,k,m,:), dcenter) 00719 acenter(m)=sign(min(2d0*abs(aleft(m)), 2d0*abs(aright(m)), abs(acenter(m))), acenter(m)) 00720 ELSE 00721 acenter(m)=0d0 00722 END IF 00723 END DO 00724 IF (abs(SpeedsZ_%data(SpeedsZ_%x(i),j,k,1,1)) > abs(SpeedsZ_%data(SpeedsZ_%x(i),j,k,1,n_waves))) THEN 00725 DO m=1,NrWaves 00726 dqz_%data(dqz_%x(i),j,k,1,m)=DOT_PRODUCT(rightZ_%data(rightZ_%x(i),j,k,1:n_waves,m) , acenter(1:n_waves)) 00727 END DO 00728 ELSEIF (abs(SpeedsZ_%data(SpeedsZ_%x(i),j,k,1,1)) < abs(SpeedsZ_%data(SpeedsZ_%x(i),j,k,1,n_waves))) THEN 00729 DO m=1,NrWaves 00730 dqz_%data(dqz_%x(i),j,k,1,m)=DOT_PRODUCT(rightZ_%data(rightZ_%x(i),j,k,n_waves:1:-1,m) , acenter(n_waves:1:-1)) 00731 END DO 00732 ELSE 00733 DO m=1,NrWaves 00734 dqz_%data(dqz_%x(i),j,k,1,m)=half*(DOT_PRODUCT(rightZ_%data(rightZ_%x(i),j,k,1:n_waves,m) , acenter(1:n_waves))+DOT_PRODUCT(rightZ_%data(rightZ_%x(i),j,k,n_waves:1:-1,m) , acenter(n_waves:1:-1))) 00735 END DO 00736 END IF 00737 ELSE 00738 DO m=1,NrWaves 00739 IF (SIGN(1d0,dleft(m)) == SIGN(1d0,dright(m))) THEN 00740 dqz_%data(dqz_%x(i),j,k,1,m)=sign(min(2d0*abs(dleft(m)), 2d0*abs(dright(m)), abs(dcenter(m))), dcenter(m)) 00741 ELSE 00742 dqz_%data(dqz_%x(i),j,k,1,m) = 0d0 00743 END IF 00744 END DO 00745 END IF 00746 ELSE 00747 dqz_%data(dqz_%x(i),j,k,1,1:NrWaves) = dcenter(1:NrWaves) 00748 END IF 00749 END DO 00750 END DO 00751 END DO 00752 END IF 00753 00754 00755 IF (InterpOrder == 2) THEN 00756 00757 IF (istimeshift(index, Info%level, qRx, mB)) THEN 00758 CALL shift(index, Info%level, qLx, mC) 00759 00760 IF (ANY(mC(1,:) .ne. mB(1,:)+1)) THEN 00761 write(*,*) "qRx and qLx are Codependent but there codependent rows are not being updated at the same time" 00762 write(*,*) mC 00763 write(*,*) mB 00764 stop 00765 end IF 00766 DO i=mB(1,1),mB(1,2) 00767 DO j=mB(2,1),mB(2,2) 00768 DO k=mB(3,1),mB(3,2) 00769 n_waves=NINT(nWaves_%data(nWaves_%x(i),j,k,1,1)) 00770 lambda_min=min(0d0,SpeedsX_%data(SpeedsX_%x(i),j,k,1,1)) 00771 lambda_max=max(0d0,SpeedsX_%data(SpeedsX_%x(i),j,k,1,n_waves)) 00772 00773 dw(:)=dqx_%data(dqx_%x(i),j,k,1,:) 00774 qRx_%data(qRx_%x(i),j,k,1,oneDx_i(:))=w_%data(w_%x(i),j,k,1,oneDx_i(:))-(half+hdtdx*lambda_min)*dw 00775 qLx_%data(qLx_%x(i+1),j,k,1,oneDx_i(:))=w_%data(w_%x(i),j,k,1,oneDx_i(:))+(half-hdtdx*lambda_max)*dw 00776 00777 DO waves=1, n_waves 00778 IF (SpeedsX_%data(SpeedsX_%x(i),j,k,1,waves) < 0d0 .OR. lHLLTypeSolver) THEN 00779 deltaq=(lambda_min-SpeedsX_%data(SpeedsX_%x(i),j,k,1,waves))*dw*hdtdx 00780 qRx_%data(qRx_%x(i),j,k,1,oneDx_i(:))=qRx_%data(qRx_%x(i),j,k,1,oneDx_i(:)) + & 00781 DOT_PRODUCT(leftX_%data(leftX_%x(i),j,k,waves,:), deltaq(:))*rightX_%data(rightX_%x(i),j,k,waves,:) 00782 END IF 00783 END DO 00784 00785 DO waves=n_waves, 1,-1 00786 IF (SpeedsX_%data(SpeedsX_%x(i),j,k,1,waves) > 0d0 .OR. lHLLTypeSolver) THEN 00787 deltaq=(lambda_max-SpeedsX_%data(SpeedsX_%x(i),j,k,1,waves))*dw*hdtdx 00788 qLx_%data(qLx_%x(i+1),j,k,1,oneDx_i(:))=qLx_%data(qLx_%x(i+1),j,k,1,oneDx_i(:)) + & 00789 DOT_PRODUCT(leftX_%data(leftX_%x(i),j,k,waves,:), deltaq(:))*rightX_%data(rightX_%x(i),j,k,waves,:) 00790 END IF 00791 END DO 00792 END DO 00793 END DO 00794 END DO 00795 IF (lMHD) THEN 00796 IF (nDim == 1) THEN 00797 qLx_%data(qLx_%x(mC(1,1):mC(1,2)),mC(2,1):mC(2,2), mC(3,1):mC(3,2),1,iBx) = & 00798 Info%q(1,1,1,iBx) 00799 qRx_%data(qRx_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,iBx) = & 00800 Info%q(1,1,1,iBx) 00801 ELSE IF (nDim >= 2) THEN 00802 qLx_%data(qLx_%x(mC(1,1):mC(1,2)),mC(2,1):mC(2,2),mC(3,1):mC(3,2),1,iBx) = & 00803 Info%aux(index+mC(1,1):index+mC(1,2),mC(2,1):mC(2,2), mC(3,1):mC(3,2),1) 00804 qRx_%data(qRx_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2),mB(3,1):mB(3,2),1,iBx) = & 00805 Info%aux(index+mB(1,1):index+mB(1,2),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1) 00806 END IF 00807 END IF 00808 END IF 00809 00810 00811 IF (nDim >= 2) THEN 00812 if (istimeshift(index, Info%level, qRy, mB)) THEN 00813 CALL shift(index, Info%level, qLy, mC) 00814 00815 IF (ANY(mC(1,:) .ne. mB(1,:))) THEN 00816 write(*,*) "qRy and qLy are Codependent but there codependent rows are not being updated at the same time" 00817 STOP 00818 END IF 00819 DO i=mB(1,1),mB(1,2) 00820 DO j=mB(2,1),mB(2,2) 00821 DO k=mB(3,1),mB(3,2) 00822 n_waves=NINT(nWaves_%data(nWaves_%x(i),j,k,1,2)) 00823 lambda_min=min(0d0,SpeedsY_%data(SpeedsY_%x(i),j,k,1,1)) 00824 lambda_max=max(0d0,SpeedsY_%data(SpeedsY_%x(i),j,k,1,n_waves)) 00825 IF (lLimiter) THEN 00826 IF (limiter_ppm_%data(limiter_ppm_%x(i),j,k,1,1) < 1d0) THEN 00827 dqy_%data(dqy_%x(i),j,k,1,:)=dqy_%data(dqy_%x(i),j,k,1,:)*limiter_ppm_%data(limiter_ppm_%x(i),j,k,1,1) 00828 END IF 00829 END IF 00830 dw=dqy_%data(dqy_%x(i),j,k,1,:) 00831 qRy_%data(qRy_%x(i),j,k,1,oneDy_i(:))=w_%data(w_%x(i),j,k,1,oneDy_i(:))-(half+hdtdy*lambda_min)*dw 00832 qLy_%data(qLy_%x(i),j+1,k,1,oneDy_i(:))=w_%data(w_%x(i),j,k,1,oneDy_i(:))+(half-hdtdy*lambda_max)*dw 00833 DO waves=1, n_waves 00834 IF (SpeedsY_%data(SpeedsY_%x(i),j,k,1,waves) < 0d0 .OR. lHllTypeSolver) THEN 00835 deltaq=(lambda_min-SpeedsY_%data(SpeedsY_%x(i),j,k,1,waves))*dw*hdtdy 00836 ELSE 00837 CYCLE 00838 END IF 00839 qRy_%data(qRy_%x(i),j,k,1,oneDy_i(:))=qRy_%data(qRy_%x(i),j,k,1,oneDy_i(:)) + & 00840 DOT_PRODUCT(leftY_%data(leftY_%x(i),j,k,waves,:), deltaq(:))*rightY_%data(rightY_%x(i),j,k,waves,:) 00841 END DO 00842 DO waves=n_waves, 1,-1 00843 IF (SpeedsY_%data(SpeedsY_%x(i),j,k,1,waves) > 0d0 .OR. lHllTypeSolver) THEN 00844 deltaq=(lambda_max-SpeedsY_%data(SpeedsY_%x(i),j,k,1,waves))*dw*hdtdy 00845 ELSE 00846 CYCLE 00847 END IF 00848 qLy_%data(qLy_%x(i),j+1,k,1,oneDy_i(:))=qLy_%data(qLy_%x(i),j+1,k,1,oneDy_i(:)) + & 00849 DOT_PRODUCT(leftY_%data(leftY_%x(i),j,k,waves,:), deltaq(:))*rightY_%data(rightY_%x(i),j,k,waves,:) 00850 END DO 00851 END DO 00852 END DO 00853 END DO 00854 IF (lMHD) THEN 00855 qLy_%data(qLy_%x(mC(1,1):mC(1,2)),mC(2,1):mC(2,2),mC(3,1):mC(3,2),1,iBy) = & 00856 Info%aux(index+mC(1,1):index+mC(1,2),mC(2,1):mC(2,2), mC(3,1):mC(3,2),2) 00857 qRy_%data(qRy_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2),mB(3,1):mB(3,2),1,iBy) = & 00858 Info%aux(index+mB(1,1):index+mB(1,2),mB(2,1):mB(2,2), mB(3,1):mB(3,2),2) 00859 END IF 00860 END IF 00861 00862 IF (nDim >= 3) THEN 00863 IF (istimeshift(index, Info%level, qRz, mB)) THEN 00864 CALL shift(index, Info%level, qLz, mC) 00865 00866 IF (ANY(mC(1,:) .ne. mB(1,:))) THEN 00867 write(*,*) "qRz and qLz are Codependent but there codependent rows are not being updated at the same time" 00868 STOP 00869 END IF 00870 DO i=mB(1,1),mB(1,2) 00871 DO j=mB(2,1),mB(2,2) 00872 DO k=mB(3,1),mB(3,2) 00873 n_waves=NINT(nWaves_%data(nWaves_%x(i),j,k,1,3)) 00874 lambda_min=min(0d0,SpeedsZ_%data(SpeedsZ_%x(i),j,k,1,1)) 00875 lambda_max=max(0d0,SpeedsZ_%data(SpeedsZ_%x(i),j,k,1,n_waves)) 00876 00877 IF (lLimiter) THEN 00878 IF (limiter_ppm_%data(limiter_ppm_%x(i),j,k,1,1) < 1d0) THEN 00879 dqz_%data(dqz_%x(i),j,k,1,:)=dqz_%data(dqz_%x(i),j,k,1,:)*limiter_ppm_%data(limiter_ppm_%x(i),j,k,1,1) 00880 END IF 00881 END IF 00882 dw=dqz_%data(dqz_%x(i),j,k,1,:) 00883 qRz_%data(qRz_%x(i),j,k,1,oneDz_i(:))=w_%data(w_%x(i),j,k,1,oneDz_i(:))-(half+hdtdz*lambda_min)*dw 00884 qLz_%data(qLz_%x(i),j,k+1,1,oneDz_i(:))=w_%data(w_%x(i),j,k,1,oneDz_i(:))+(half-hdtdz*lambda_max)*dw 00885 00886 DO waves=1, n_waves 00887 IF (SpeedsZ_%data(SpeedsZ_%x(i),j,k,1,waves) < 0d0 .OR. lHLLTypeSolver) THEN 00888 deltaq=(lambda_min-SpeedsZ_%data(SpeedsZ_%x(i),j,k,1,waves))*dw*hdtdz 00889 ELSE 00890 CYCLE 00891 END IF 00892 qRz_%data(qRz_%x(i),j,k,1,oneDz_i(:))=qRz_%data(qRz_%x(i),j,k,1,oneDz_i(:)) + & 00893 DOT_PRODUCT(leftZ_%data(leftZ_%x(i),j,k,waves,:), deltaq(:))*rightZ_%data(rightZ_%x(i),j,k,waves,:) 00894 END DO 00895 DO waves=n_waves, 1,-1 00896 IF (SpeedsZ_%data(SpeedsZ_%x(i),j,k,1,waves) > 0d0 .OR. lHLLTypeSolver) THEN 00897 deltaq=(lambda_max-SpeedsZ_%data(SpeedsZ_%x(i),j,k,1,waves))*dw*hdtdz 00898 ELSE 00899 CYCLE 00900 END IF 00901 qLz_%data(qLz_%x(i),j,k+1,1,oneDz_i(:))=qLz_%data(qLz_%x(i),j,k+1,1,oneDz_i(:)) + & 00902 DOT_PRODUCT(leftZ_%data(leftZ_%x(i),j,k,waves,:), deltaq(:))*rightZ_%data(rightZ_%x(i),j,k,waves,:) 00903 END DO 00904 00905 END DO 00906 END DO 00907 END DO 00908 IF (lMHD) THEN 00909 qLz_%data(qLz_%x(mC(1,1):mC(1,2)),mC(2,1):mC(2,2),mC(3,1):mC(3,2),1,iBz) = & 00910 Info%aux(index+mC(1,1):index+mC(1,2),mC(2,1):mC(2,2), mC(3,1):mC(3,2),3) 00911 qRz_%data(qRz_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2),mB(3,1):mB(3,2),1,iBz) = & 00912 Info%aux(index+mB(1,1):index+mB(1,2),mB(2,1):mB(2,2), mB(3,1):mB(3,2),3) 00913 END IF 00914 END IF 00915 END IF 00916 END IF 00917 00918 ELSEIF (InterpOrder == 3) THEN 00919 00920 IF(istimeshift(index, Info%level, qex, mB)) THEN 00921 DO i=mB(1,1), mB(1,2) 00922 FORALL(j=mB(2,1):mB(2,2), k=mB(3,1):mB(3,2),m=1:NrWaves) 00923 qex_%data(qex_%x(i),j,k,1,m)=half*(w_%data(w_%x(i-1),j,k,1,oneDx_i(m))+w_%data(w_%x(i),j,k,1,oneDx_i(m))) - & 00924 sixth*(dqx_%data(dqx_%x(i),j,k,1,m)-dqx_%data(dqx_%x(i-1),j,k,1,m)) 00925 END FORALL 00926 00927 DO j=mB(2,1),mB(2,2) 00928 DO k=mB(3,1),mB(3,2) 00929 DO m=1, NrWaves 00930 IF ((qex_%data(qex_%x(i),j,k,1,m) - w_%data(w_%x(i-1),j,k,1,oneDx_i(m))) * & 00931 (w_%data(w_%x(i),j,k,1,oneDx_i(m))-qex_%data(qex_%x(i),j,k,1,m)) <= 0) THEN 00932 IF (lUsePPML) THEN !need to use 2nd derivatives limitings as in ColellaSekora2008 00933 !could do this with characteristic variables as well... 00934 d2=3d0*(w_%data(w_%x(i-1),j,k,1,oneDx_i(m))-2d0*qex_%data(qex_%x(i),j,k,1,m)+w_%data(w_%x(i),j,k,1,oneDx_i(m))) 00935 d2L=w_%data(w_%x(i-2),j,k,1,oneDx_i(m))-2d0*w_%data(w_%x(i-1),j,k,1,oneDx_i(m))+w_%data(w_%x(i),j,k,1,oneDx_i(m)) 00936 d2R=w_%data(w_%x(i-1),j,k,1,oneDx_i(m))-2d0*w_%data(w_%x(i),j,k,1,oneDx_i(m))+w_%data(w_%x(i+1),j,k,1,oneDx_i(m)) 00937 IF ((d2 > 0d0 .AND. d2L > 0d0 .AND. d2R > 0d0) .OR. (d2 < 0d0 .AND. d2L < 0d0 .AND. d2R < 0d0)) THEN 00938 d2m=sign(min(PPMC*abs(d2L), PPMC*abs(d2R), abs(d2)), d2) 00939 ELSE 00940 d2m=0d0 00941 END IF 00942 qex_%data(qex_%x(i),j,k,1,m) = half*(w_%data(w_%x(i-1),j,k,1,oneDx_i(m))+w_%data(w_%x(i),j,k,1,oneDx_i(m))) - sixth*d2m 00943 ELSE !constrain edge values to lie between adjacent cell averages 00944 qex_%data(qex_%x(i),j,k,1,m) = min(qex_%data(qex_%x(i),j,k,1,m), & 00945 max(w_%data(w_%x(i-1),j,k,1,oneDx_i(m)),w_%data(w_%x(i),j,k,1,oneDx_i(m)))) 00946 qex_%data(qex_%x(i),j,k,1,m) = max(qex_%data(qex_%x(i),j,k,1,m), & 00947 min(w_%data(w_%x(i-1),j,k,1,oneDx_i(m)),w_%data(w_%x(i),j,k,1,oneDx_i(m)))) 00948 END IF 00949 END IF 00950 END DO 00951 END DO 00952 END DO 00953 END DO 00954 00955 END IF 00956 00957 IF(istimeshift(index, Info%level, qey, mB)) THEN 00958 DO i=mB(1,1),mB(1,2) 00959 FORALL(j=mB(2,1):mB(2,2), k=mB(3,1):mB(3,2),m=1:NrWaves) 00960 qey_%data(qey_%x(i),j,k,1,m)=half*(w_%data(w_%x(i),j-1,k,1,oneDy_i(m))+w_%data(w_%x(i),j,k,1,oneDy_i(m))) - & 00961 sixth*(dqy_%data(dqy_%x(i),j,k,1,m)-dqy_%data(dqy_%x(i),j-1,k,1,m)) 00962 END FORALL 00963 00964 DO j=mB(2,1),mB(2,2) 00965 DO k=mB(3,1),mB(3,2) 00966 DO m=1, NrWaves 00967 IF ((qey_%data(qey_%x(i),j,k,1,m) - w_%data(w_%x(i),j-1,k,1,oneDy_i(m))) * & 00968 (w_%data(w_%x(i),j,k,1,oneDy_i(m))-qey_%data(qey_%x(i),j,k,1,m)) <= 0) THEN 00969 IF (lUsePPML) THEN 00970 d2=3d0*(w_%data(w_%x(i),j-1,k,1,oneDy_i(m))-2d0*qey_%data(qey_%x(i),j,k,1,m)+w_%data(w_%x(i),j,k,1,oneDy_i(m))) 00971 d2L=w_%data(w_%x(i),j-2,k,1,oneDy_i(m))-2d0*w_%data(w_%x(i),j-1,k,1,oneDy_i(m))+w_%data(w_%x(i),j,k,1,oneDy_i(m)) 00972 d2R=w_%data(w_%x(i),j-1,k,1,oneDy_i(m))-2d0*w_%data(w_%x(i),j,k,1,oneDy_i(m))+w_%data(w_%x(i),j+1,k,1,oneDy_i(m)) 00973 IF ((d2 > 0d0 .AND. d2L > 0d0 .AND. d2R > 0d0) .OR. (d2 < 0d0 .AND. d2L < 0d0 .AND. d2R < 0d0)) THEN 00974 d2m=sign(min(PPMC*abs(d2L), PPMC*abs(d2R), abs(d2)), d2) 00975 ELSE 00976 d2m=0d0 00977 END IF 00978 qey_%data(qey_%x(i),j,k,1,m) = half*(w_%data(w_%x(i),j-1,k,1,oneDy_i(m))+w_%data(w_%x(i),j,k,1,oneDy_i(m))) - sixth*d2m 00979 ELSE 00980 qey_%data(qey_%x(i),j,k,1,m) = min(qey_%data(qey_%x(i),j,k,1,m), & 00981 max(w_%data(w_%x(i),j-1,k,1,oneDy_i(m)),w_%data(w_%x(i),j,k,1,oneDy_i(m)))) 00982 qey_%data(qey_%x(i),j,k,1,m) = max(qey_%data(qey_%x(i),j,k,1,m), & 00983 min(w_%data(w_%x(i),j-1,k,1,oneDy_i(m)),w_%data(w_%x(i),j,k,1,oneDy_i(m)))) 00984 END IF 00985 END IF 00986 END DO 00987 END DO 00988 END DO 00989 END DO 00990 END IF 00991 00992 IF(istimeshift(index, Info%level, qez, mB)) THEN 00993 DO i=mB(1,1),mB(1,2) 00994 FORALL(j=mB(2,1):mB(2,2), k=mB(3,1):mB(3,2),m=1:NrWaves) 00995 qez_%data(qez_%x(i),j,k,1,m)=half*(w_%data(w_%x(i),j,k-1,1,oneDz_i(m))+w_%data(w_%x(i),j,k,1,oneDz_i(m))) - & 00996 sixth*(dqz_%data(dqz_%x(i),j,k,1,m)-dqz_%data(dqz_%x(i),j,k-1,1,m)) 00997 END FORALL 00998 DO j=mB(2,1),mB(2,2) 00999 DO k=mB(3,1),mB(3,2) 01000 DO m=1, NrWaves 01001 IF ((qez_%data(qez_%x(i),j,k,1,m) - w_%data(w_%x(i),j,k-1,1,oneDz_i(m))) * & 01002 (w_%data(w_%x(i),j,k,1,oneDz_i(m))-qez_%data(qez_%x(i),j,k,1,m)) <= 0) THEN 01003 IF (lUsePPML) THEN 01004 d2=3d0*(w_%data(w_%x(i),j,k-1,1,oneDz_i(m))-2d0*qez_%data(qez_%x(i),j,k,1,m)+w_%data(w_%x(i),j,k,1,oneDz_i(m))) 01005 d2L=w_%data(w_%x(i),j,k-2,1,oneDz_i(m))-2d0*w_%data(w_%x(i),j,k-1,1,oneDz_i(m))+w_%data(w_%x(i),j,k,1,oneDz_i(m)) 01006 d2R=w_%data(w_%x(i),j,k-1,1,oneDz_i(m))-2d0*w_%data(w_%x(i),j,k,1,oneDz_i(m))+w_%data(w_%x(i),j,k+1,1,oneDz_i(m)) 01007 IF ((d2 > 0d0 .AND. d2L > 0d0 .AND. d2R > 0d0) .OR. (d2 < 0d0 .AND. d2L < 0d0 .AND. d2R < 0d0)) THEN 01008 d2m=sign(min(PPMC*abs(d2L), PPMC*abs(d2R), abs(d2)), d2) 01009 ELSE 01010 d2m=0d0 01011 END IF 01012 qez_%data(qez_%x(i),j,k,1,m) = half*(w_%data(w_%x(i),j,k-1,1,oneDz_i(m))+w_%data(w_%x(i),j,k,1,oneDz_i(m))) - sixth*d2m 01013 ELSE 01014 qez_%data(qez_%x(i),j,k,1,m) = min(qez_%data(qez_%x(i),j,k,1,m), & 01015 max(w_%data(w_%x(i),j,k-1,1,oneDz_i(m)),w_%data(w_%x(i),j,k,1,oneDz_i(m)))) 01016 qez_%data(qez_%x(i),j,k,1,m) = max(qez_%data(qez_%x(i),j,k,1,m), & 01017 min(w_%data(w_%x(i),j,k-1,1,oneDz_i(m)),w_%data(w_%x(i),j,k,1,oneDz_i(m)))) 01018 END IF 01019 END IF 01020 END DO 01021 END DO 01022 END DO 01023 END DO 01024 END IF 01025 01026 !Now we have spatially interpolated interface values we can construct left and right interface states. 01027 01028 IF (istimeshift(index, Info%level, qRx, mB)) THEN 01029 CALL shift(index, Info%level, qLx, mC) 01030 IF (ANY(mC(1,:) .ne. mB(1,:)+1)) THEN 01031 write(*,*) "qRx and qLx are Codependent but there codependent rows are not being updated at the same time" 01032 stop 01033 end IF 01034 DO i=mB(1,1),mB(1,2) 01035 DO j=mB(2,1),mB(2,2) 01036 DO k=mB(3,1),mB(3,2) 01037 DO m=1,NrWaves 01038 IF (.NOT. lUsePPML) THEN 01039 IF ((qex_%data(qex_%x(i+1),j,k,1,m)-w_%data(w_%x(i),j,k,1,oneDx_i(m))) * & 01040 (w_%data(w_%x(i),j,k,1,oneDx_i(m))-qex_%data(qex_%x(i),j,k,1,m)) <= 0) THEN 01041 ! Reconstructed value is not monotone so flatten reconstruction in this cell 01042 qRx_%data(qRx_%x(i),j,k,1,oneDx_i(m))=w_%data(w_%x(i),j,k,1,oneDx_i(m)) 01043 qLx_%data(qLx_%x(i+1),j,k,1,oneDx_i(m))=w_%data(w_%x(i),j,k,1,oneDx_i(m)) 01044 ELSE ! Make sure that parabolic reconstruction does not produce local maxima/minima 01045 dq=qex_%data(qex_%x(i+1),j,k,1,m)-qex_%data(qex_%x(i),j,k,1,m) 01046 sdq2=sixth*dq**2 01047 qmhsq=dq*(w_%data(w_%x(i),j,k,1,oneDx_i(m))-half*(qex_%data(qex_%x(i),j,k,1,m)+qex_%data(qex_%x(i+1),j,k,1,m))) 01048 IF (qmhsq > sdq2) THEN 01049 qRx_%data(qRx_%x(i),j,k,1,oneDx_i(m))=3d0*w_%data(w_%x(i),j,k,1,oneDx_i(m))-2d0*qex_%data(qex_%x(i+1),j,k,1,m) 01050 qLx_%data(qLx_%x(i+1),j,k,1,oneDx_i(m))=qex_%data(qex_%x(i+1),j,k,1,m) 01051 ELSE IF (qmhsq < -sdq2) THEN 01052 qLx_%data(qLx_%x(i+1),j,k,1,oneDx_i(m))=3d0*w_%data(w_%x(i),j,k,1,oneDx_i(m))-2d0*qex_%data(qex_%x(i),j,k,1,m) 01053 qRx_%data(qRx_%x(i),j,k,1,oneDx_i(m))=qex_%data(qex_%x(i),j,k,1,m) 01054 ELSE 01055 qRx_%data(qRx_%x(i),j,k,1,oneDx_i(m))=qex_%data(qex_%x(i),j,k,1,m) 01056 qLx_%data(qLx_%x(i+1),j,k,1,oneDx_i(m))=qex_%data(qex_%x(i+1),j,k,1,m) 01057 END IF 01058 END IF 01059 ELSE 01060 IF ((qex_%data(qex_%x(i+1),j,k,1,m)-w_%data(w_%x(i),j,k,1,oneDx_i(m))) * & 01061 (w_%data(w_%x(i),j,k,1,oneDx_i(m))-qex_%data(qex_%x(i),j,k,1,m)) <= 0d0 .OR. & 01062 (w_%data(w_%x(i+1),j,k,1,oneDx_i(m)) - w_%data(w_%x(i),j,k,1,oneDx_i(m))) * & 01063 (w_%data(w_%x(i),j,k,1,oneDx_i(m)) - w_%data(w_%x(i-1),j,k,1,oneDx_i(m))) <= 0d0) THEN 01064 ! Edges produce a new local extrema or cell is an existing local extrema 01065 01066 ! Perform 2nd order limiting 01067 ! could do this with characteristic variables as well... 01068 d2= -6d0*(2d0*w_%data(w_%x(i),j,k,1,oneDx_i(m)) - (qex_%data(qex_%x(i),j,k,1,m)+qex_%data(qex_%x(i+1),j,k,1,m))) 01069 d2C=w_%data(w_%x(i-1),j,k,1,oneDx_i(m))-2d0*w_%data(w_%x(i),j,k,1,oneDx_i(m))+w_%data(w_%x(i+1),j,k,1,oneDx_i(m)) 01070 d2L=w_%data(w_%x(i-2),j,k,1,oneDx_i(m))-2d0*w_%data(w_%x(i-1),j,k,1,oneDx_i(m))+w_%data(w_%x(i),j,k,1,oneDx_i(m)) 01071 d2R=w_%data(w_%x(i),j,k,1,oneDx_i(m))-2d0*w_%data(w_%x(i+1),j,k,1,oneDx_i(m))+w_%data(w_%x(i+2),j,k,1,oneDx_i(m)) 01072 IF (abs(sum(sign(1d0, (/d2, d2C, d2L, d2R/)))) == 4d0) THEN 01073 d2m=sign(min(PPMC*abs(d2L), PPMC*abs(d2R), abs(d2)), d2) 01074 ELSE 01075 d2m=0d0 01076 END IF 01077 IF (d2 == 0d0) THEN 01078 qRx_%data(qRx_%x(i),j,k,1,oneDx_i(m))=w_%data(w_%x(i),j,k,1,oneDx_i(m)) 01079 qLx_%data(qLx_%x(i+1),j,k,1,oneDx_i(m))=w_%data(w_%x(i),j,k,1,oneDx_i(m)) 01080 ELSE 01081 qRx_%data(qRx_%x(i),j,k,1,oneDx_i(m))=w_%data(w_%x(i),j,k,1,oneDx_i(m)) + d2m/d2*(qex_%data(qex_%x(i),j,k,1,m) - w_%data(w_%x(i),j,k,1,oneDx_i(m))) 01082 qLx_%data(qLx_%x(i+1),j,k,1,oneDx_i(m))=w_%data(w_%x(i),j,k,1,oneDx_i(m)) + d2m/d2*(qex_%data(qex_%x(i+1),j,k,1,m) - w_%data(w_%x(i),j,k,1,oneDx_i(m))) 01083 END IF 01084 ELSE !use original PPM limiter 01085 dq=qex_%data(qex_%x(i+1),j,k,1,m)-qex_%data(qex_%x(i),j,k,1,m) 01086 sdq2=sixth*dq**2 01087 qmhsq=dq*(w_%data(w_%x(i),j,k,1,oneDx_i(m))-half*(qex_%data(qex_%x(i),j,k,1,m)+qex_%data(qex_%x(i+1),j,k,1,m))) 01088 IF (qmhsq > sdq2) THEN 01089 qRx_%data(qRx_%x(i),j,k,1,oneDx_i(m))=3d0*w_%data(w_%x(i),j,k,1,oneDx_i(m))-2d0*qex_%data(qex_%x(i+1),j,k,1,m) 01090 qLx_%data(qLx_%x(i+1),j,k,1,oneDx_i(m))=qex_%data(qex_%x(i+1),j,k,1,m) 01091 ELSE IF (qmhsq < -sdq2) THEN 01092 qLx_%data(qLx_%x(i+1),j,k,1,oneDx_i(m))=3d0*w_%data(w_%x(i),j,k,1,oneDx_i(m))-2d0*qex_%data(qex_%x(i),j,k,1,m) 01093 qRx_%data(qRx_%x(i),j,k,1,oneDx_i(m))=qex_%data(qex_%x(i),j,k,1,m) 01094 ELSE 01095 qRx_%data(qRx_%x(i),j,k,1,oneDx_i(m))=qex_%data(qex_%x(i),j,k,1,m) 01096 qLx_%data(qLx_%x(i+1),j,k,1,oneDx_i(m))=qex_%data(qex_%x(i+1),j,k,1,m) 01097 END IF 01098 END IF 01099 END IF 01100 END DO 01101 01102 01103 n_waves=NINT(nWaves_%data(nWaves_%x(i),j,k,1,1)) 01104 lambda_min=min(0d0,SpeedsX_%data(SpeedsX_%x(i),j,k,1,1)) 01105 lambda_max=max(0d0,SpeedsX_%data(SpeedsX_%x(i),j,k,1,n_waves)) 01106 01107 dw(:)=hdtdx*(qLx_%data(qLx_%x(i+1),j,k,1,oneDx_i(:))-qRx_%data(qRx_%x(i),j,k,1,oneDx_i(:))) 01108 dw6(:)=three_dtdx*(w_%data(w_%x(i),j,k,1,oneDx_i(:))-half* & 01109 (qLx_%data(qLx_%x(i+1),j,k,1,oneDx_i(:))+qRx_%data(qRx_%x(i),j,k,1,oneDx_i(:)))) 01110 01111 dwmdw6=dw-dw6 01112 dwpdw6=dw+dw6 01113 dw6=two_thirds_dtdx*dw6 01114 dw_l=hdtdx*dqx_%data(dqx_%x(i),j,k,1,:) 01115 01116 qRx_%data(qRx_%x(i),j,k,1,oneDx_i(:))=qRx_%data(qRx_%x(i),j,k,1,oneDx_i(:))-& 01117 lambda_min*(dwpdw6)-dw6*lambda_min**2 01118 qLx_%data(qLx_%x(i+1),j,k,1,oneDx_i(:))=qLx_%data(qLx_%x(i+1),j,k,1,oneDx_i(:))-& 01119 lambda_max*(dwmdw6)-dw6*lambda_max**2 01120 01121 DO waves=1, n_waves 01122 IF (SpeedsX_%data(SpeedsX_%x(i),j,k,1,waves) < 0d0) THEN 01123 deltaq=(lambda_min-SpeedsX_%data(SpeedsX_%x(i),j,k,1,waves))*dwpdw6 + & 01124 (lambda_min**2-SpeedsX_%data(SpeedsX_%x(i),j,k,1,waves)**2)*dw6 01125 ELSEIF (lHLLTypeSolver .AND. SpeedsX_%data(SpeedsX_%x(i),j,k,1,waves) > 0d0) THEN 01126 deltaq=(lambda_min-SpeedsX_%data(SpeedsX_%x(i),j,k,1,waves))*dw_l 01127 ELSE 01128 CYCLE 01129 END IF 01130 qRx_%data(qRx_%x(i),j,k,1,oneDx_i(:))=qRx_%data(qRx_%x(i),j,k,1,oneDx_i(:)) + & 01131 DOT_PRODUCT(leftX_%data(leftX_%x(i),j,k,waves,:), deltaq(:))*rightX_%data(rightX_%x(i),j,k,waves,:) 01132 END DO 01133 01134 DO waves=n_waves, 1,-1 01135 IF (SpeedsX_%data(SpeedsX_%x(i),j,k,1,waves) > 0d0) THEN 01136 deltaq=(lambda_max-SpeedsX_%data(SpeedsX_%x(i),j,k,1,waves))*dwmdw6 + & 01137 (lambda_max**2-SpeedsX_%data(SpeedsX_%x(i),j,k,1,waves)**2)*dw6 01138 ELSEIF (lHLLTypeSolver .AND. SpeedsX_%data(SpeedsX_%x(i),j,k,1,waves) < 0d0) THEN 01139 deltaq=(lambda_max-SpeedsX_%data(SpeedsX_%x(i),j,k,1,waves))*dw_l 01140 ELSE 01141 CYCLE 01142 END IF 01143 qLx_%data(qLx_%x(i+1),j,k,1,oneDx_i(:))=qLx_%data(qLx_%x(i+1),j,k,1,oneDx_i(:)) + & 01144 DOT_PRODUCT(leftX_%data(leftX_%x(i),j,k,waves,:), deltaq(:))*rightX_%data(rightX_%x(i),j,k,waves,:) 01145 END DO 01146 END DO 01147 END DO 01148 END DO 01149 01150 IF (lMHD) THEN 01151 IF (nDim == 1) THEN 01152 qLx_%data(qLx_%x(mC(1,1):mC(1,2)),mC(2,1):mC(2,2), mC(3,1):mC(3,2),1,iBx) = & 01153 Info%q(1,1,1,iBx) 01154 qRx_%data(qRx_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,iBx) = & 01155 Info%q(1,1,1,iBx) 01156 ELSE IF (nDim >= 2) THEN 01157 qLx_%data(qLx_%x(mC(1,1):mC(1,2)),mC(2,1):mC(2,2),mC(3,1):mC(3,2),1,iBx) = & 01158 Info%aux(index+mC(1,1):index+mC(1,2),mC(2,1):mC(2,2), mC(3,1):mC(3,2),1) 01159 qRx_%data(qRx_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2),mB(3,1):mB(3,2),1,iBx) = & 01160 Info%aux(index+mB(1,1):index+mB(1,2),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1) 01161 END IF 01162 END IF 01163 END IF 01164 IF (nDim >= 2) THEN 01165 if (istimeshift(index, Info%level, qRy, mB)) THEN 01166 CALL shift(index, Info%level, qLy, mC) 01167 IF (ANY(mC(1,:) .ne. mB(1,:))) THEN 01168 write(*,*) "qRy and qLy are Codependent but there codependent rows are not being updated at the same time" 01169 STOP 01170 END IF 01171 DO i=mB(1,1),mB(1,2) 01172 DO j=mB(2,1),mB(2,2) 01173 DO k=mB(3,1),mB(3,2) 01174 DO m=1,NrWaves 01175 IF (.NOT. lUsePPML) THEN 01176 IF ((qey_%data(qey_%x(i),j+1,k,1,m)-w_%data(w_%x(i),j,k,1,oneDy_i(m))) * & 01177 (w_%data(w_%x(i),j,k,1,oneDy_i(m))-qey_%data(qey_%x(i),j,k,1,m)) <= 0) THEN 01178 qRy_%data(qRy_%x(i),j,k,1,oneDy_i(m))=w_%data(w_%x(i),j,k,1,oneDy_i(m)) 01179 qLy_%data(qLy_%x(i),j+1,k,1,oneDy_i(m))=w_%data(w_%x(i),j,k,1,oneDy_i(m)) 01180 ELSE 01181 dq=qey_%data(qey_%x(i),j+1,k,1,m)-qey_%data(qey_%x(i),j,k,1,m) 01182 sdq2=sixth*dq**2 01183 qmhsq=dq*(w_%data(w_%x(i),j,k,1,oneDy_i(m))-half*(qey_%data(qey_%x(i),j,k,1,m)+qey_%data(qey_%x(i),j+1,k,1,m))) 01184 IF (qmhsq > sdq2) THEN 01185 qRy_%data(qRy_%x(i),j,k,1,oneDy_i(m))=3d0*w_%data(w_%x(i),j,k,1,oneDy_i(m))-2d0*qey_%data(qey_%x(i),j+1,k,1,m) 01186 qLy_%data(qLy_%x(i),j+1,k,1,oneDy_i(m))=qey_%data(qey_%x(i),j+1,k,1,m) 01187 ELSE IF (qmhsq < -sdq2) THEN 01188 qLy_%data(qLy_%x(i),j+1,k,1,oneDy_i(m))=3d0*w_%data(w_%x(i),j,k,1,oneDy_i(m))-2d0*qey_%data(qey_%x(i),j,k,1,m) 01189 qRy_%data(qRy_%x(i),j,k,1,oneDy_i(m))=qey_%data(qey_%x(i),j,k,1,m) 01190 ELSE 01191 qRy_%data(qRy_%x(i),j,k,1,oneDy_i(m))=qey_%data(qey_%x(i),j,k,1,m) 01192 qLy_%data(qLy_%x(i),j+1,k,1,oneDy_i(m))=qey_%data(qey_%x(i),j+1,k,1,m) 01193 END IF 01194 END IF 01195 ELSE 01196 IF ((qey_%data(qey_%x(i),j+1,k,1,m)-w_%data(w_%x(i),j,k,1,oneDy_i(m))) * & 01197 (w_%data(w_%x(i),j,k,1,oneDy_i(m))-qey_%data(qey_%x(i),j,k,1,m)) <= 0d0 .OR. & 01198 (w_%data(w_%x(i),j+1,k,1,oneDy_i(m)) - w_%data(w_%x(i),j,k,1,oneDy_i(m))) * & 01199 (w_%data(w_%x(i),j,k,1,oneDy_i(m)) - w_%data(w_%x(i),j-1,k,1,oneDy_i(m))) <= 0d0) THEN 01200 ! Edges produce a new local extrema or cell is an existing local extrema 01201 01202 ! Perform 2nd order limiting 01203 ! could do this with characteristic variables as well... 01204 d2= -6d0*(2d0*w_%data(w_%x(i),j,k,1,oneDy_i(m)) - (qey_%data(qey_%x(i),j,k,1,m)+qey_%data(qey_%x(i),j+1,k,1,m))) 01205 d2C=w_%data(w_%x(i),j-1,k,1,oneDy_i(m))-2d0*w_%data(w_%x(i),j,k,1,oneDy_i(m))+w_%data(w_%x(i),j+1,k,1,oneDy_i(m)) 01206 d2L=w_%data(w_%x(i),j-2,k,1,oneDy_i(m))-2d0*w_%data(w_%x(i),j-1,k,1,oneDy_i(m))+w_%data(w_%x(i),j,k,1,oneDy_i(m)) 01207 d2R=w_%data(w_%x(i),j,k,1,oneDy_i(m))-2d0*w_%data(w_%x(i),j+1,k,1,oneDy_i(m))+w_%data(w_%x(i),j+2,k,1,oneDy_i(m)) 01208 IF (abs(sum(sign(1d0, (/d2, d2C, d2L, d2R/)))) == 4d0) THEN 01209 d2m=sign(min(PPMC*abs(d2L), PPMC*abs(d2R), abs(d2)), d2) 01210 ELSE 01211 d2m=0d0 01212 END IF 01213 IF (d2 == 0d0) THEN 01214 qRy_%data(qRy_%x(i),j,k,1,oneDy_i(m))=w_%data(w_%x(i),j,k,1,oneDy_i(m)) 01215 qLy_%data(qLy_%x(i),j+1,k,1,oneDy_i(m))=w_%data(w_%x(i),j,k,1,oneDy_i(m)) 01216 ELSE 01217 qRy_%data(qRy_%x(i),j,k,1,oneDy_i(m))=w_%data(w_%x(i),j,k,1,oneDy_i(m)) + d2m/d2*(qey_%data(qey_%x(i),j,k,1,m) - w_%data(w_%x(i),j,k,1,oneDy_i(m))) 01218 qLy_%data(qLy_%x(i),j+1,k,1,oneDy_i(m))=w_%data(w_%x(i),j,k,1,oneDy_i(m)) + d2m/d2*(qey_%data(qey_%x(i),j+1,k,1,m) - w_%data(w_%x(i),j,k,1,oneDy_i(m))) 01219 END IF 01220 ELSE !use original PPM limiter 01221 dq=qey_%data(qey_%x(i),j+1,k,1,m)-qey_%data(qey_%x(i),j,k,1,m) 01222 sdq2=sixth*dq**2 01223 qmhsq=dq*(w_%data(w_%x(i),j,k,1,oneDy_i(m))-half*(qey_%data(qey_%x(i),j,k,1,m)+qey_%data(qey_%x(i),j+1,k,1,m))) 01224 IF (qmhsq > sdq2) THEN 01225 qRy_%data(qRy_%x(i),j,k,1,oneDy_i(m))=3d0*w_%data(w_%x(i),j,k,1,oneDy_i(m))-2d0*qey_%data(qey_%x(i),j+1,k,1,m) 01226 qLy_%data(qLy_%x(i),j+1,k,1,oneDy_i(m))=qey_%data(qey_%x(i),j+1,k,1,m) 01227 ELSE IF (qmhsq < -sdq2) THEN 01228 qLy_%data(qLy_%x(i),j+1,k,1,oneDy_i(m))=3d0*w_%data(w_%x(i),j,k,1,oneDy_i(m))-2d0*qey_%data(qey_%x(i),j,k,1,m) 01229 qRy_%data(qRy_%x(i),j,k,1,oneDy_i(m))=qey_%data(qey_%x(i),j,k,1,m) 01230 ELSE 01231 qRy_%data(qRy_%x(i),j,k,1,oneDy_i(m))=qey_%data(qey_%x(i),j,k,1,m) 01232 qLy_%data(qLy_%x(i),j+1,k,1,oneDy_i(m))=qey_%data(qey_%x(i),j+1,k,1,m) 01233 END IF 01234 END IF 01235 END IF 01236 END DO 01237 n_waves=NINT(nWaves_%data(nWaves_%x(i),j,k,1,2)) 01238 lambda_min=min(0d0,SpeedsY_%data(SpeedsY_%x(i),j,k,1,1)) 01239 lambda_max=max(0d0,SpeedsY_%data(SpeedsY_%x(i),j,k,1,n_waves)) 01240 01241 dw(:)=hdtdy*(qLy_%data(qLy_%x(i),j+1,k,1,oneDy_i(:))-qRy_%data(qRy_%x(i),j,k,1,oneDy_i(:))) 01242 dw6(:)=three_dtdy*(w_%data(w_%x(i),j,k,1,oneDy_i(:))-half* & 01243 (qLy_%data(qLy_%x(i),j+1,k,1,oneDy_i(:))+qRy_%data(qRy_%x(i),j,k,1,oneDy_i(:)))) 01244 01245 dwmdw6=dw-dw6 01246 dwpdw6=dw+dw6 01247 dw6=two_thirds_dtdy*dw6 01248 dw_l=hdtdy*dqy_%data(dqy_%x(i),j,k,1,:) 01249 01250 qRy_%data(qRy_%x(i),j,k,1,oneDy_i(:))=qRy_%data(qRy_%x(i),j,k,1,oneDy_i(:))-& 01251 lambda_min*(dwpdw6)-dw6*lambda_min**2 01252 qLy_%data(qLy_%x(i),j+1,k,1,oneDy_i(:))=qLy_%data(qLy_%x(i),j+1,k,1,oneDy_i(:))-& 01253 lambda_max*(dwmdw6)-dw6*lambda_max**2 01254 01255 DO waves=1, n_waves 01256 IF (SpeedsY_%data(SpeedsY_%x(i),j,k,1,waves) < 0d0) THEN 01257 deltaq=(lambda_min-SpeedsY_%data(SpeedsY_%x(i),j,k,1,waves))*dwpdw6 + & 01258 (lambda_min**2-SpeedsY_%data(SpeedsY_%x(i),j,k,1,waves)**2)*dw6 01259 ELSEIF (lHLLTypeSolver .AND. SpeedsY_%data(SpeedsY_%x(i),j,k,1,waves) > 0d0) THEN 01260 deltaq=(lambda_min-SpeedsY_%data(SpeedsY_%x(i),j,k,1,waves))*dw_l 01261 ELSE 01262 CYCLE 01263 END IF 01264 qRy_%data(qRy_%x(i),j,k,1,oneDy_i(:))=qRy_%data(qRy_%x(i),j,k,1,oneDy_i(:)) + & 01265 DOT_PRODUCT(leftY_%data(leftY_%x(i),j,k,waves,:), deltaq(:))*rightY_%data(rightY_%x(i),j,k,waves,:) 01266 END DO 01267 DO waves=n_waves, 1,-1 01268 IF (SpeedsY_%data(SpeedsY_%x(i),j,k,1,waves) > 0d0) THEN 01269 deltaq=(lambda_max-SpeedsY_%data(SpeedsY_%x(i),j,k,1,waves))*dwmdw6 + & 01270 (lambda_max**2-SpeedsY_%data(SpeedsY_%x(i),j,k,1,waves)**2)*dw6 01271 ELSEIF (lHLLTypeSolver .AND. SpeedsY_%data(SpeedsY_%x(i),j,k,1,waves) < 0d0) THEN 01272 deltaq=(SpeedsY_%data(SpeedsY_%x(i),j,k,1,n_waves)-SpeedsY_%data(SpeedsY_%x(i),j,k,1,waves))*dw_l 01273 ELSE 01274 CYCLE 01275 END IF 01276 qLy_%data(qLy_%x(i),j+1,k,1,oneDy_i(:))=qLy_%data(qLy_%x(i),j+1,k,1,oneDy_i(:)) + & 01277 DOT_PRODUCT(leftY_%data(leftY_%x(i),j,k,waves,:), deltaq(:))*rightY_%data(rightY_%x(i),j,k,waves,:) 01278 END DO 01279 END DO 01280 END DO 01281 END DO 01282 IF (lMHD) THEN 01283 qLy_%data(qLy_%x(mC(1,1):mC(1,2)),mC(2,1):mC(2,2),mC(3,1):mC(3,2),1,iBy) = & 01284 Info%aux(index+mC(1,1):index+mC(1,2),mC(2,1):mC(2,2), mC(3,1):mC(3,2),2) 01285 qRy_%data(qRy_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2),mB(3,1):mB(3,2),1,iBy) = & 01286 Info%aux(index+mB(1,1):index+mB(1,2),mB(2,1):mB(2,2), mB(3,1):mB(3,2),2) 01287 END IF 01288 01289 END if 01290 IF (nDim >= 3) THEN 01291 IF (istimeshift(index, Info%level, qRz, mB)) THEN 01292 CALL shift(index, Info%level, qLz, mC) 01293 01294 IF (ANY(mC(1,:) .ne. mB(1,:))) THEN 01295 write(*,*) "qRz and qLz are Codependent but there codependent rows are not being updated at the same time" 01296 STOP 01297 END IF 01298 DO i=mB(1,1),mB(1,2) 01299 DO j=mB(2,1),mB(2,2) 01300 DO k=mB(3,1),mB(3,2) 01301 DO m=1,NrWaves 01302 IF (.NOT. lUsePPML) THEN 01303 IF ((qez_%data(qez_%x(i),j,k+1,1,m)-w_%data(w_%x(i),j,k,1,oneDz_i(m))) * & 01304 (w_%data(w_%x(i),j,k,1,oneDz_i(m))-qez_%data(qez_%x(i),j,k,1,m)) <= 0) THEN 01305 qRz_%data(qRz_%x(i),j,k,1,oneDz_i(m))=w_%data(w_%x(i),j,k,1,oneDz_i(m)) 01306 qLz_%data(qLz_%x(i),j,k+1,1,oneDz_i(m))=w_%data(w_%x(i),j,k,1,oneDz_i(m)) 01307 ELSE 01308 dq=qez_%data(qez_%x(i),j,k+1,1,m)-qez_%data(qez_%x(i),j,k,1,m) 01309 sdq2=sixth*dq**2 01310 qmhsq=dq*(w_%data(w_%x(i),j,k,1,oneDz_i(m))-half*(qez_%data(qez_%x(i),j,k,1,m)+qez_%data(qez_%x(i),j,k+1,1,m))) 01311 IF (qmhsq > sdq2) THEN 01312 qRz_%data(qRz_%x(i),j,k,1,oneDz_i(m))=3d0*w_%data(w_%x(i),j,k,1,oneDz_i(m))-2d0*qez_%data(qez_%x(i),j,k+1,1,m) 01313 qLz_%data(qLz_%x(i),j,k+1,1,oneDz_i(m))=qez_%data(qez_%x(i),j,k+1,1,m) 01314 ELSE IF (qmhsq < -sdq2) THEN 01315 qLz_%data(qLz_%x(i),j,k+1,1,oneDz_i(m))=3d0*w_%data(w_%x(i),j,k,1,oneDz_i(m))-2d0*qez_%data(qez_%x(i),j,k,1,m) 01316 qRz_%data(qRz_%x(i),j,k,1,oneDz_i(m))=qez_%data(qez_%x(i),j,k,1,m) 01317 ELSE 01318 qRz_%data(qRz_%x(i),j,k,1,oneDz_i(m))=qez_%data(qez_%x(i),j,k,1,m) 01319 qLz_%data(qLz_%x(i),j,k+1,1,oneDz_i(m))=qez_%data(qez_%x(i),j,k+1,1,m) 01320 END IF 01321 END IF 01322 ELSE 01323 IF ((qez_%data(qez_%x(i),j,k+1,1,m)-w_%data(w_%x(i),j,k,1,oneDz_i(m))) * & 01324 (w_%data(w_%x(i),j,k,1,oneDz_i(m))-qez_%data(qez_%x(i),j,k,1,m)) <= 0d0 .OR. & 01325 (w_%data(w_%x(i),j,k+1,1,oneDz_i(m)) - w_%data(w_%x(i),j,k,1,oneDz_i(m))) * & 01326 (w_%data(w_%x(i),j,k,1,oneDz_i(m)) - w_%data(w_%x(i),j,k-1,1,oneDz_i(m))) <= 0d0) THEN 01327 ! Edges produce a new local extrema or cell is an existing local extrema 01328 01329 ! Perform 2nd order limiting 01330 ! could do this with characteristic variables as well... 01331 d2= -6d0*(2d0*w_%data(w_%x(i),j,k,1,oneDz_i(m)) - (qez_%data(qez_%x(i),j,k,1,m)+qez_%data(qez_%x(i),j,k+1,1,m))) 01332 d2C=w_%data(w_%x(i),j,k-1,1,oneDz_i(m))-2d0*w_%data(w_%x(i),j,k,1,oneDz_i(m))+w_%data(w_%x(i),j,k+1,1,oneDz_i(m)) 01333 d2L=w_%data(w_%x(i),j,k-2,1,oneDz_i(m))-2d0*w_%data(w_%x(i),j,k-1,1,oneDz_i(m))+w_%data(w_%x(i),j,k,1,oneDz_i(m)) 01334 d2R=w_%data(w_%x(i),j,k,1,oneDz_i(m))-2d0*w_%data(w_%x(i),j,k+1,1,oneDz_i(m))+w_%data(w_%x(i),j,k+2,1,oneDz_i(m)) 01335 IF (abs(sum(sign(1d0, (/d2, d2C, d2L, d2R/)))) == 4d0) THEN 01336 d2m=sign(min(PPMC*abs(d2L), PPMC*abs(d2R), abs(d2)), d2) 01337 ELSE 01338 d2m=0d0 01339 END IF 01340 IF (d2 == 0d0) THEN 01341 qRz_%data(qRz_%x(i),j,k,1,oneDz_i(m))=w_%data(w_%x(i),j,k,1,oneDz_i(m)) 01342 qLz_%data(qLz_%x(i),j,k+1,1,oneDz_i(m))=w_%data(w_%x(i),j,k,1,oneDz_i(m)) 01343 ELSE 01344 qRz_%data(qRz_%x(i),j,k,1,oneDz_i(m))=w_%data(w_%x(i),j,k,1,oneDz_i(m)) + d2m/d2*(qez_%data(qez_%x(i),j,k,1,m) - w_%data(w_%x(i),j,k,1,oneDz_i(m))) 01345 qLz_%data(qLz_%x(i),j,k+1,1,oneDz_i(m))=w_%data(w_%x(i),j,k,1,oneDz_i(m)) + d2m/d2*(qez_%data(qez_%x(i),j,k+1,1,m) - w_%data(w_%x(i),j,k,1,oneDz_i(m))) 01346 END IF 01347 ELSE 01348 dq=qez_%data(qez_%x(i),j,k+1,1,m)-qez_%data(qez_%x(i),j,k,1,m) 01349 sdq2=sixth*dq**2 01350 qmhsq=dq*(w_%data(w_%x(i),j,k,1,oneDz_i(m))-half*(qez_%data(qez_%x(i),j,k,1,m)+qez_%data(qez_%x(i),j,k+1,1,m))) 01351 IF (qmhsq > sdq2) THEN 01352 qRz_%data(qRz_%x(i),j,k,1,oneDz_i(m))=3d0*w_%data(w_%x(i),j,k,1,oneDz_i(m))-2d0*qez_%data(qez_%x(i),j,k+1,1,m) 01353 qLz_%data(qLz_%x(i),j,k+1,1,oneDz_i(m))=qez_%data(qez_%x(i),j,k+1,1,m) 01354 ELSE IF (qmhsq < -sdq2) THEN 01355 qLz_%data(qLz_%x(i),j,k+1,1,oneDz_i(m))=3d0*w_%data(w_%x(i),j,k,1,oneDz_i(m))-2d0*qez_%data(qez_%x(i),j,k,1,m) 01356 qRz_%data(qRz_%x(i),j,k,1,oneDz_i(m))=qez_%data(qez_%x(i),j,k,1,m) 01357 ELSE 01358 qRz_%data(qRz_%x(i),j,k,1,oneDz_i(m))=qez_%data(qez_%x(i),j,k,1,m) 01359 qLz_%data(qLz_%x(i),j,k+1,1,oneDz_i(m))=qez_%data(qez_%x(i),j,k+1,1,m) 01360 END IF 01361 END IF 01362 END IF 01363 END DO 01364 n_waves=NINT(nWaves_%data(nWaves_%x(i),j,k,1,3)) 01365 lambda_min=min(0d0,SpeedsZ_%data(SpeedsZ_%x(i),j,k,1,1)) 01366 lambda_max=max(0d0,SpeedsZ_%data(SpeedsZ_%x(i),j,k,1,n_waves)) 01367 01368 dw(:)=hdtdz*(qLz_%data(qLz_%x(i),j,k+1,1,oneDz_i(:))-qRz_%data(qRz_%x(i),j,k,1,oneDz_i(:))) 01369 dw6(:)=three_dtdz*(w_%data(w_%x(i),j,k,1,oneDz_i(:))-half* & 01370 (qLz_%data(qLz_%x(i),j,k+1,1,oneDz_i(:))+qRz_%data(qRz_%x(i),j,k,1,oneDz_i(:)))) 01371 01372 dwmdw6=dw-dw6 01373 dwpdw6=dw+dw6 01374 dw6=two_thirds_dtdz*dw6 01375 dw_l=hdtdz*dqz_%data(dqz_%x(i),j,k,1,:) 01376 01377 qRz_%data(qRz_%x(i),j,k,1,oneDz_i(:))=qRz_%data(qRz_%x(i),j,k,1,oneDz_i(:))-& 01378 lambda_min*(dwpdw6)-dw6*lambda_min**2 01379 qLz_%data(qLz_%x(i),j,k+1,1,oneDz_i(:))=qLz_%data(qLz_%x(i),j,k+1,1,oneDz_i(:))-& 01380 lambda_max*(dwmdw6)-dw6*lambda_max**2 01381 01382 DO waves=1, n_waves 01383 IF (SpeedsZ_%data(SpeedsZ_%x(i),j,k,1,waves) < 0d0) THEN 01384 deltaq=(lambda_min-SpeedsZ_%data(SpeedsZ_%x(i),j,k,1,waves))*dwpdw6 + & 01385 (lambda_min**2-SpeedsZ_%data(SpeedsZ_%x(i),j,k,1,waves)**2)*dw6 01386 ELSEIF (lHLLTypeSolver .AND. SpeedsZ_%data(SpeedsZ_%x(i),j,k,1,waves) > 0d0) THEN 01387 deltaq=(lambda_min-SpeedsZ_%data(SpeedsZ_%x(i),j,k,1,waves))*dw_l 01388 ELSE 01389 CYCLE 01390 END IF 01391 qRz_%data(qRz_%x(i),j,k,1,oneDz_i(:))=qRz_%data(qRz_%x(i),j,k,1,oneDz_i(:)) + & 01392 DOT_PRODUCT(leftZ_%data(leftZ_%x(i),j,k,waves,:), deltaq(:))*rightZ_%data(rightZ_%x(i),j,k,waves,:) 01393 END DO 01394 DO waves=n_waves, 1,-1 01395 IF (SpeedsZ_%data(SpeedsZ_%x(i),j,k,1,waves) > 0d0) THEN 01396 deltaq=(lambda_max-SpeedsZ_%data(SpeedsZ_%x(i),j,k,1,waves))*dwmdw6 + & 01397 (lambda_max**2-SpeedsZ_%data(SpeedsZ_%x(i),j,k,1,waves)**2)*dw6 01398 ELSEIF (lHLLTypeSolver .AND. SpeedsZ_%data(SpeedsZ_%x(i),j,k,1,waves) < 0d0) THEN 01399 deltaq=(lambda_max-SpeedsZ_%data(SpeedsZ_%x(i),j,k,1,waves))*dw_l 01400 ELSE 01401 CYCLE 01402 END IF 01403 qLz_%data(qLz_%x(i),j,k+1,1,oneDz_i(:))=qLz_%data(qLz_%x(i),j,k+1,1,oneDz_i(:)) + & 01404 DOT_PRODUCT(leftZ_%data(leftZ_%x(i),j,k,waves,:), deltaq(:))*rightZ_%data(rightZ_%x(i),j,k,waves,:) 01405 END DO 01406 END DO 01407 END DO 01408 END DO 01409 IF (lMHD) THEN 01410 qLz_%data(qLz_%x(mC(1,1):mC(1,2)),mC(2,1):mC(2,2),mC(3,1):mC(3,2),1,iBz) = & 01411 Info%aux(index+mC(1,1):index+mC(1,2),mC(2,1):mC(2,2), mC(3,1):mC(3,2),3) 01412 qRz_%data(qRz_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2),mB(3,1):mB(3,2),1,iBz) = & 01413 Info%aux(index+mB(1,1):index+mB(1,2),mB(2,1):mB(2,2), mB(3,1):mB(3,2),3) 01414 END IF 01415 END IF 01416 END IF 01417 END IF 01418 END IF 01419 01420 IF (lMHD) CALL MHD_Source_Terms(Info, index) 01421 DEALLOCATE (dleft, dright, dcenter, dw, dw6, dwmdw6, dwpdw6, dw_l, deltaq, & 01422 aleft,aright, acenter) 01423 01424 END IF 01425 01426 IF (lSelfGravity) THEN 01427 IF (istimeshift(index, Info%level, gradphix, mB)) THEN 01428 DO i=mB(1,1), mB(1,2) 01429 FORALL(j=mB(2,1):mB(2,2), k=mB(3,1):mB(3,2)) 01430 gradphix_%data(gradphix_%x(i),j,k,1,1)=(Info%q(index+i,j,k,iPhiGas)-Info%q(index+i-1,j,k,iPhiGas))/dx 01431 END FORALL 01432 END DO 01433 END IF 01434 IF (nDim >= 2) THEN 01435 IF (istimeshift(index, Info%level, gradphiy, mB)) THEN 01436 DO i=mB(1,1), mB(1,2) 01437 FORALL(j=mB(2,1):mB(2,2), k=mB(3,1):mB(3,2)) 01438 gradphiy_%data(gradphiy_%x(i),j,k,1,1)=(Info%q(index+i,j,k,iPhiGas)-Info%q(index+i,j-1,k,iPhiGas))/dx 01439 END FORALL 01440 END DO 01441 END IF 01442 IF (nDim >= 3) THEN 01443 IF (istimeshift(index, Info%level, gradphiz, mB)) THEN 01444 DO i=mB(1,1), mB(1,2) 01445 FORALL(j=mB(2,1):mB(2,2), k=mB(3,1):mB(3,2)) 01446 gradphiz_%data(gradphiz_%x(i),j,k,1,1)=(Info%q(index+i,j,k,iPhiGas)-Info%q(index+i,j,k-1,iPhiGas))/dx 01447 END FORALL 01448 END DO 01449 END IF 01450 END IF 01451 END IF 01452 01453 01454 IF (istime(index, Info%level, qRx, mB)) THEN 01455 IF (lSelfGravity) THEN 01456 qRx_%data(qRx_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,ivx) = & 01457 qRx_%data(qRx_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,ivx) - hdt*& 01458 gradphix_%data(gradphix_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,1) 01459 END IF 01460 END IF 01461 01462 IF (istime(index, Info%level, qLx, mB)) THEN 01463 IF (lSelfGravity) THEN 01464 qLx_%data(qLx_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,ivx) = & 01465 qLx_%data(qLx_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,ivx) - hdt*& 01466 gradphix_%data(gradphix_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,1) 01467 END IF 01468 END IF 01469 01470 IF (istime(index, Info%level, qRy, mB)) THEN 01471 IF (lSelfGravity) THEN 01472 qRy_%data(qRy_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,ivy) = & 01473 qRy_%data(qRy_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,ivy) - hdt*& 01474 gradphiy_%data(gradphiy_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,1) 01475 END IF 01476 END IF 01477 01478 IF (istime(index, Info%level, qLy, mB)) THEN 01479 IF (lSelfGravity) THEN 01480 qLy_%data(qLy_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,ivy) = & 01481 qLy_%data(qLy_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,ivy) - hdt*& 01482 gradphiy_%data(gradphiy_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,1) 01483 END IF 01484 END IF 01485 01486 IF (istime(index, Info%level, qRz, mB)) THEN 01487 IF (lSelfGravity) THEN 01488 qRz_%data(qRz_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,ivz) = & 01489 qRz_%data(qRz_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,ivz) - hdt*& 01490 gradphiz_%data(gradphiz_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,1) 01491 01492 END IF 01493 END IF 01494 01495 IF (istime(index, Info%level, qLz, mB)) THEN 01496 IF (lSelfGravity) THEN 01497 qLz_%data(qLz_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,ivz) = & 01498 qLz_%data(qLz_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,ivz) - hdt*& 01499 gradphiz_%data(gradphiz_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,1) 01500 END IF 01501 END IF 01502 01503 END IF 01504 01505 01506 IF (lCautious) THEN 01507 IF (istime(index, Info%level, qRx, mB)) THEN 01508 DO i=mB(1,1),mB(1,2) 01509 CALL protect_all(qRx_%data(qRx_%x(i), mB(2,1):mB(2,2), mB(3,1):mB(3,2), 1,:)) 01510 END DO 01511 01512 END IF 01513 IF (istime(index, Info%level, qLx, mB)) THEN 01514 DO i=mB(1,1),mB(1,2) 01515 CALL protect_all(qLx_%data(qLx_%x(i), mB(2,1):mB(2,2), mB(3,1):mB(3,2), 1,:)) 01516 END DO 01517 01518 END IF 01519 IF (istime(index, Info%level, qRy, mB)) THEN 01520 DO i=mB(1,1),mB(1,2) 01521 CALL protect_all(qRy_%data(qRy_%x(i), mB(2,1):mB(2,2), mB(3,1):mB(3,2), 1,:)) 01522 END DO 01523 END IF 01524 IF (istime(index, Info%level, qLy, mB)) THEN 01525 DO i=mB(1,1),mB(1,2) 01526 CALL protect_all(qLy_%data(qLy_%x(i), mB(2,1):mB(2,2), mB(3,1):mB(3,2), 1,:)) 01527 END DO 01528 END IF 01529 IF (istime(index, Info%level, qRz, mB)) THEN 01530 DO i=mB(1,1),mB(1,2) 01531 CALL protect_all(qRz_%data(qRz_%x(i), mB(2,1):mB(2,2), mB(3,1):mB(3,2), 1,:)) 01532 END DO 01533 END IF 01534 IF (istime(index, Info%level, qLz, mB)) THEN 01535 DO i=mB(1,1),mB(1,2) 01536 CALL protect_all(qLz_%data(qLz_%x(i), mB(2,1):mB(2,2), mB(3,1):mB(3,2), 1,:)) 01537 END DO 01538 END IF 01539 END IF 01540 01541 01542 END SUBROUTINE Reconstruct 01543 01544 01550 SUBROUTINE calc_limiters(Info, index) 01551 TYPE(InfoDef) :: Info ! Info structure currently updating 01552 INTEGER :: index ! Current row in q being updated 01553 INTEGER :: i,j,k ! Loop counters 01554 INTEGER :: mB(3,2) ! Bounds of slab to update 01555 INTEGER :: mC(3,2) ! Bounds of slab to update 01556 REAL(KIND=qPrec) :: dPT1, dPT2 01557 INTEGER :: m 01558 REAL(KIND=qPrec), PARAMETER :: CA1=10d0, !1d0/(.85-.75) 01559 CA2=.85d0, 01560 CZ1=2d0, !1d0/(.75-.25) 01561 CZ2=.75d0 01562 IF (istimeshift(index, Info%level, pT, mB)) THEN 01563 IF (lIsothermal) THEN 01564 DO i=mB(1,1), mB(1,2) 01565 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 01566 pT_%data(pT_%x(i),j,k,1,1)=w_%data(w_%x(i),j,k,1,1)*Iso_Speed2 01567 END FORALL 01568 END DO 01569 ELSE 01570 DO i=mB(1,1), mB(1,2) 01571 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 01572 pT_%data(pT_%x(i),j,k,1,1)=w_%data(w_%x(i),j,k,1,iE) 01573 END FORALL 01574 END DO 01575 END IF 01576 END IF 01577 IF (istimeshift(index, Info%level, limiter_x, mB)) THEN 01578 DO i=mB(1,1),mB(1,2) 01579 DO j=mB(2,1),mB(2,2) 01580 DO k=mB(3,1),mB(3,2) 01581 IF(w_%data(w_%x(i+1),j,k,1,ivx) < w_%data(w_%x(i-1),j,k,1,ivx)) THEN 01582 dPT2=ABS(pT_%data(pT_%x(i+2),j,k,1,1) - pT_%data(pT_%x(i-2),j,k,1,1)) 01583 IF (dPT2 > epsilon) THEN 01584 dPT1 = ABS(pT_%data(pT_%x(i+1),j,k,1,1) - pT_%data(pT_%x(i-1),j,k,1,1)) 01585 limiter_x_%data(limiter_x_%x(i),j,k,1,1)=MAX(MIN(1d0,CZ1*(CZ2-dPT1/min(pT_%data(pT_%x(i+1),j,k,1,1),pT_%data(pT_%x(i-1),j,k,1,1)) )), & 01586 MAX(0d0, MIN(1d0,CA1*(CA2-dPT1/dPT2)))) 01587 ELSE 01588 limiter_x_%data(limiter_x_%x(i),j,k,1,1)=1d0 01589 END IF 01590 ELSE 01591 limiter_x_%data(limiter_x_%x(i),j,k,1,1)=1d0 01592 END IF 01593 END DO 01594 END DO 01595 END DO 01596 END IF 01597 IF (istimeshift(index, Info%level, limiter_y, mB)) THEN 01598 DO i=mB(1,1),mB(1,2) 01599 DO j=mB(2,1),mB(2,2) 01600 DO k=mB(3,1),mB(3,2) 01601 IF(w_%data(w_%x(i),j+1,k,1,ivy) < w_%data(w_%x(i),j-1,k,1,ivy)) THEN 01602 dPT2=ABS(pT_%data(pT_%x(i),j+2,k,1,1) - pT_%data(pT_%x(i),j-2,k,1,1)) 01603 IF (dPT2 > epsilon) THEN 01604 dPT1 = ABS(pT_%data(pT_%x(i),j+1,k,1,1) - pT_%data(pT_%x(i),j-1,k,1,1)) 01605 limiter_y_%data(limiter_y_%x(i),j,k,1,1)=MAX(MIN(1d0,CZ1*(CZ2-dPT1/min(pT_%data(pT_%x(i),j+1,k,1,1),pT_%data(pT_%x(i),j-1,k,1,1)) )), & 01606 MAX(0d0, MIN(1d0,CA1*(CA2-dPT1/dPT2)))) 01607 ELSE 01608 limiter_y_%data(limiter_y_%x(i),j,k,1,1)=1d0 01609 END IF 01610 ELSE 01611 limiter_y_%data(limiter_y_%x(i),j,k,1,1)=1d0 01612 END IF 01613 END DO 01614 END DO 01615 END DO 01616 END IF 01617 IF (istimeshift(index, Info%level, limiter_z, mB)) THEN 01618 DO i=mB(1,1),mB(1,2) 01619 DO j=mB(2,1),mB(2,2) 01620 DO k=mB(3,1),mB(3,2) 01621 IF(w_%data(w_%x(i),j,k+1,1,ivz) < w_%data(w_%x(i),j,k-1,1,ivz)) THEN 01622 dPT2=ABS(pT_%data(pT_%x(i),j,k+2,1,1) - pT_%data(pT_%x(i),j,k-2,1,1)) 01623 IF (dPT2 > epsilon) THEN 01624 dPT1 = ABS(pT_%data(pT_%x(i),j,k+1,1,1) - pT_%data(pT_%x(i),j,k-1,1,1)) 01625 limiter_z_%data(limiter_z_%x(i),j,k,1,1)=MAX(MIN(1d0,CZ1*(CZ2-dPT1/min(pT_%data(pT_%x(i),j,k+1,1,1),pT_%data(pT_%x(i),j,k-1,1,1)) )), & 01626 MAX(0d0, MIN(1d0,CA1*(CA2-dPT1/dPT2)))) 01627 01628 ELSE 01629 limiter_z_%data(limiter_z_%x(i),j,k,1,1)=1d0 01630 END IF 01631 ELSE 01632 limiter_z_%data(limiter_z_%x(i),j,k,1,1)=1d0 01633 END IF 01634 END DO 01635 END DO 01636 END DO 01637 END IF 01638 IF (istimeshift(index, Info%level, limiter_ppm, mB)) THEN 01639 IF (nDim == 1) THEN 01640 DO i=mB(1,1),mB(1,2) 01641 FORALL(j=mB(2,1):mB(2,2), k=mB(3,1):mB(3,2)) 01642 limiter_ppm_%data(limiter_ppm_%x(i),j,k,1,1)= MINVAL((/limiter_x_%data(limiter_x_%x(i-1),j,k,1,1), & 01643 limiter_x_%data(limiter_x_%x(i),j,k,1,1),limiter_x_%data(limiter_x_%x(i+1),j,k,1,1)/)) 01644 END FORALL 01645 END DO 01646 ELSE IF (nDim == 2) THEN 01647 DO i=mB(1,1),mB(1,2) 01648 FORALL(j=mB(2,1):mB(2,2), k=mB(3,1):mB(3,2)) 01649 limiter_ppm_%data(limiter_ppm_%x(i),j,k,1,1)= MINVAL((/limiter_x_%data(limiter_x_%x(i-1),j-1:j+1,k,1,1), & 01650 limiter_x_%data(limiter_x_%x(i),j-1:j+1,k,1,1),limiter_x_%data(limiter_x_%x(i+1),j-1:j+1,k,1,1)/)) 01651 END FORALL 01652 END DO 01653 ELSE IF (nDim == 3) THEN 01654 DO i=mB(1,1),mB(1,2) 01655 FORALL(j=mB(2,1):mB(2,2), k=mB(3,1):mB(3,2)) 01656 limiter_ppm_%data(limiter_ppm_%x(i),j,k,1,1)= MINVAL((/limiter_x_%data(limiter_x_%x(i-1),j-1:j+1,k-1:k+1,1,1), & 01657 limiter_x_%data(limiter_x_%x(i),j-1:j+1,k-1:k+1,1,1),limiter_x_%data(limiter_x_%x(i+1),j-1:j+1,k-1:k+1,1,1)/)) 01658 END FORALL 01659 END DO 01660 END IF 01661 IF (nDim >= 2) THEN 01662 IF (nDim == 2) THEN 01663 DO i=mB(1,1),mB(1,2) 01664 FORALL(j=mB(2,1):mB(2,2), k=mB(3,1):mB(3,2)) 01665 limiter_ppm_%data(limiter_ppm_%x(i),j,k,1,1)=MIN(limiter_ppm_%data(limiter_ppm_%x(i),j,k,1,1), & 01666 MINVAL((/limiter_y_%data(limiter_y_%x(i-1),j-1:j+1,k,1,1),limiter_y_%data(limiter_y_%x(i),j-1:j+1,k,1,1),limiter_y_%data(limiter_y_%x(i+1),j-1:j+1,k,1,1)/))) 01667 END FORALL 01668 END DO 01669 ELSE 01670 DO i=mB(1,1),mB(1,2) 01671 FORALL(j=mB(2,1):mB(2,2), k=mB(3,1):mB(3,2)) 01672 limiter_ppm_%data(limiter_ppm_%x(i),j,k,1,1)=MIN(limiter_ppm_%data(limiter_ppm_%x(i),j,k,1,1), & 01673 MINVAL((/limiter_y_%data(limiter_y_%x(i-1),j-1:j+1,k-1:k+1,1,1),limiter_y_%data(limiter_y_%x(i),j-1:j+1,k-1:k+1,1,1),limiter_y_%data(limiter_y_%x(i+1),j-1:j+1,k-1:k+1,1,1)/))) 01674 END FORALL 01675 END DO 01676 END IF 01677 01678 IF (nDim >= 3) THEN 01679 DO i=mB(1,1),mB(1,2) 01680 FORALL(j=mB(2,1):mB(2,2), k=mB(3,1):mB(3,2)) 01681 limiter_ppm_%data(limiter_ppm_%x(i),j,k,1,1)=MIN(limiter_ppm_%data(limiter_ppm_%x(i),j,k,1,1), & 01682 MINVAL((/limiter_z_%data(limiter_z_%x(i-1),j-1:j+1,k-1:k+1,1,1),limiter_z_%data(limiter_z_%x(i),j-1:j+1,k-1:k+1,1,1),limiter_z_%data(limiter_z_%x(i+1),j-1:j+1,k-1:k+1,1,1)/))) 01683 END FORALL 01684 END DO 01685 END IF 01686 END IF 01687 END IF 01688 END SUBROUTINE calc_limiters 01689 01690 01695 FUNCTION request_eigens(Info, index)!w,lambda,r,l,n) 01696 TYPE(InfoDef) :: Info ! Info structure currently updating 01697 INTEGER :: index ! Current row in q being updated 01698 INTEGER :: i,j,k ! Loop counters 01699 INTEGER :: mB(3,2) ! Bounds of slab to update 01700 INTEGER :: mC(3,2) ! Bounds of slab to update 01701 LOGICAL :: request_eigens 01702 LOGICAL :: lSpeedsX,lSpeedsY,lSpeedsZ,lnWaves,lLeftX,lRightX,lLeftY,lRightY,lLeftZ,lRightZ 01703 LOGICAL :: req_dim(3) 01704 REAL(KIND=qPrec), ALLOCATABLE, DIMENSION(:) :: prim 01705 REAL(KIND=qPrec), ALLOCATABLE, DIMENSION(:,:) :: lambda 01706 REAL(KIND=qPrec), ALLOCATABLE, DIMENSION(:,:,:) :: r,l 01707 INTEGER, ALLOCATABLE, DIMENSION(:) :: n 01708 req_dim(nDim+1:3) = .false. 01709 req_dim(1:nDim) = .true. 01710 request_eigens=.true. 01711 lSpeedsX=istimeshift(index, Info%level, SpeedsX, mC) 01712 lSpeedsY=istimeshift(index, Info%level, SpeedsY, mC) 01713 lSpeedsZ=istimeshift(index, Info%level, SpeedsZ, mC) 01714 lLeftX=istimeshift(index, Info%level, leftX, mC) 01715 lRightX=istimeshift(index, Info%level, RightX, mC) 01716 lLeftY=istimeshift(index, Info%level, leftY, mC) 01717 lRightY=istimeshift(index, Info%level, RightY, mC) 01718 lLeftZ=istimeshift(index, Info%level, leftZ, mC) 01719 lRightZ=istimeshift(index, Info%level, RightZ, mC) 01720 lnWaves=istimeshift(index, Info%level, nWaves, mC) 01721 IF (istime(index, Info%level, req_eigens, mB)) THEN 01722 ALLOCATE(n(nDim),prim(SweepCons)) 01723 ALLOCATE (r(nDim,NrWaves,NrWaves),l(nDim,NrWaves,NrWaves),lambda(nDim,NrWaves)) 01724 DO i=mB(1,1),mB(1,2) 01725 DO j=mB(2,1),mB(2,2) 01726 DO k=mB(3,1), mB(3,2) 01727 prim=w_%data(w_%x(i),j,k,1,:) 01728 CALL calc_eigens(request_eigens, prim, req_dim,lambda, n, l, r,index+i,j,k,Info%level) 01729 IF (lSpeedsX) SpeedsX_%data(SpeedsX_%x(i),j,k,1,:)=lambda(1,:) 01730 IF (lSpeedsY) SpeedsY_%data(SpeedsY_%x(i),j,k,1,:)=lambda(2,:) 01731 IF (lSpeedsZ) SpeedsZ_%data(SpeedsZ_%x(i),j,k,1,:)=lambda(3,:) 01732 IF (lnWaves) nWaves_%data(nWaves_%x(i),j,k,1,:)=n(:) 01733 IF (lleftX) leftX_%data(leftX_%x(i),j,k,:,:)=l(1,:,:) 01734 IF (lrightX) rightX_%data(rightX_%x(i),j,k,:,:)=r(1,:,:) 01735 IF (lleftY) leftY_%data(leftY_%x(i),j,k,:,:)=l(2,:,:) 01736 IF (lrightY) rightY_%data(rightY_%x(i),j,k,:,:)=r(2,:,:) 01737 IF (lleftZ) leftZ_%data(leftZ_%x(i),j,k,:,:)=l(3,:,:) 01738 IF (lrightZ) rightZ_%data(rightZ_%x(i),j,k,:,:)=r(3,:,:) 01739 END DO 01740 END DO 01741 END DO 01742 DEALLOCATE(n,prim, r, l, lambda) 01743 END IF 01744 01745 01746 01747 END FUNCTION request_eigens 01748 01749 01754 SUBROUTINE MHD_Source_Terms(Info, index) 01755 TYPE(InfoDef) :: Info ! Info structure currently updating 01756 INTEGER :: index ! Current row in q being updated 01757 INTEGER :: i,j,k ! Loop counters 01758 INTEGER :: mB(3,2) ! Bounds of slab to update 01759 IF (nDim == 2) THEN 01760 IF (istime(index, Info%level, qLx, mB)) THEN 01761 DO i=mB(1,1),mB(1,2) 01762 FORALL(j=mB(2,1):mB(2,2), k=mB(3,1):mB(3,2)) 01763 qLx_%data(qLx_%x(i),j,k,1,iBy)=qLx_%data(qLx_%x(i),j,k,1,iBy)+w_%data(w_%x(i-1),j,k,1,ivy)*hdtdx * & 01764 (Info%aux(index+i,j,k,1)-Info%aux(index+i-1,j,k,1)) 01765 END FORALL 01766 END DO 01767 END IF 01768 IF (istime(index, Info%level, qRx, mB)) THEN 01769 DO i=mB(1,1),mB(1,2) 01770 FORALL(j=mB(2,1):mB(2,2), k=mB(3,1):mB(3,2)) 01771 qRx_%data(qRx_%x(i),j,k,1,iBy)=qRx_%data(qRx_%x(i),j,k,1,iBy)+w_%data(w_%x(i),j,k,1,ivy)*hdtdx * & 01772 (Info%aux(index+i+1,j,k,1)-Info%aux(index+i,j,k,1)) 01773 END FORALL 01774 END DO 01775 END IF 01776 IF (istime(index, Info%level, qLy, mB)) THEN 01777 DO i=mB(1,1),mB(1,2) 01778 FORALL(j=mB(2,1):mB(2,2), k=mB(3,1):mB(3,2)) 01779 qLy_%data(qLy_%x(i),j,k,1,iBx)=qLy_%data(qLy_%x(i),j,k,1,iBx)+w_%data(w_%x(i),j-1,k,1,ivx)*hdtdy * & 01780 (Info%aux(index+i,j,k,2)-Info%aux(index+i,j-1,k,2)) 01781 END FORALL 01782 END DO 01783 END IF 01784 IF (istime(index, Info%level, qRy, mB)) THEN 01785 DO i=mB(1,1),mB(1,2) 01786 FORALL(j=mB(2,1):mB(2,2), k=mB(3,1):mB(3,2)) 01787 qRy_%data(qRy_%x(i),j,k,1,iBx)=qRy_%data(qRy_%x(i),j,k,1,iBx)+w_%data(w_%x(i),j,k,1,ivx)*hdtdy * & 01788 (Info%aux(index+i,j+1,k,2)-Info%aux(index+i,j,k,2)) 01789 END FORALL 01790 END DO 01791 END IF 01792 ELSEIF (nDim == 3) THEN 01793 IF (istime(index, Info%level, qLx, mB)) THEN 01794 DO i=mB(1,1),mB(1,2) 01795 FORALL(j=mB(2,1):mB(2,2), k=mB(3,1):mB(3,2)) 01796 qLx_%data(qLx_%x(i),j,k,1,iBz)=qLx_%data(qLx_%x(i),j,k,1,iBz)+w_%data(w_%x(i-1),j,k,1,ivz)*minmod(hdtdx * & 01797 (Info%aux(index+i,j,k,1)-Info%aux(index+i-1,j,k,1)),hdtdz*(Info%aux(index+i-1,j,k,3) - & 01798 Info%aux(index+i-1,j,k+1,3))) 01799 qLx_%data(qLx_%x(i),j,k,1,iBy)=qLx_%data(qLx_%x(i),j,k,1,iBy)+w_%data(w_%x(i-1),j,k,1,ivy)*minmod(hdtdx * & 01800 (Info%aux(index+i,j,k,1)-Info%aux(index+i-1,j,k,1)), hdtdy*(Info%aux(index+i-1,j,k,2) - & 01801 Info%aux(index+i-1,j+1,k,2))) 01802 END FORALL 01803 END DO 01804 END IF 01805 IF (istime(index, Info%level, qRx, mB)) THEN 01806 DO i=mB(1,1),mB(1,2) 01807 FORALL(j=mB(2,1):mB(2,2), k=mB(3,1):mB(3,2)) 01808 qRx_%data(qRx_%x(i),j,k,1,iBz)=qRx_%data(qRx_%x(i),j,k,1,iBz)+w_%data(w_%x(i),j,k,1,ivz)*minmod(hdtdx * & 01809 (Info%aux(index+i+1,j,k,1)-Info%aux(index+i,j,k,1)),hdtdz*(Info%aux(index+i,j,k,3) - & 01810 Info%aux(index+i,j,k+1,3))) 01811 qRx_%data(qRx_%x(i),j,k,1,iBy)=qRx_%data(qRx_%x(i),j,k,1,iBy)+w_%data(w_%x(i),j,k,1,ivy)*minmod(hdtdx * & 01812 (Info%aux(index+i+1,j,k,1)-Info%aux(index+i,j,k,1)), hdtdy*(Info%aux(index+i,j,k,2) - & 01813 Info%aux(index+i,j+1,k,2))) 01814 END FORALL 01815 END DO 01816 END IF 01817 IF (istime(index, Info%level, qLy, mB)) THEN 01818 DO i=mB(1,1),mB(1,2) 01819 FORALL(j=mB(2,1):mB(2,2), k=mB(3,1):mB(3,2)) 01820 qLy_%data(qLy_%x(i),j,k,1,iBz)=qLy_%data(qLy_%x(i),j,k,1,iBz)+w_%data(w_%x(i),j-1,k,1,ivz)*minmod(hdtdy * & 01821 (Info%aux(index+i,j,k,2)-Info%aux(index+i,j-1,k,2)),hdtdz*(Info%aux(index+i,j-1,k,3) - & 01822 Info%aux(index+i,j-1,k+1,3))) 01823 qLy_%data(qLy_%x(i),j,k,1,iBx)=qLy_%data(qLy_%x(i),j,k,1,iBx)+w_%data(w_%x(i),j-1,k,1,ivx)*minmod(hdtdy * & 01824 (Info%aux(index+i,j,k,2)-Info%aux(index+i,j-1,k,2)),hdtdx*(Info%aux(index+i,j-1,k,1) - & 01825 Info%aux(index+i+1,j-1,k,1))) 01826 END FORALL 01827 END DO 01828 END IF 01829 IF (istime(index, Info%level, qRy, mB)) THEN 01830 DO i=mB(1,1),mB(1,2) 01831 FORALL(j=mB(2,1):mB(2,2), k=mB(3,1):mB(3,2)) 01832 qRy_%data(qRy_%x(i),j,k,1,iBz)=qRy_%data(qRy_%x(i),j,k,1,iBz)+w_%data(w_%x(i),j,k,1,ivz)*minmod(hdtdy * & 01833 (Info%aux(index+i,j+1,k,2)-Info%aux(index+i,j,k,2)),hdtdz*(Info%aux(index+i,j,k,3) - & 01834 Info%aux(index+i,j,k+1,3))) 01835 qRy_%data(qRy_%x(i),j,k,1,iBx)=qRy_%data(qRy_%x(i),j,k,1,iBx)+w_%data(w_%x(i),j,k,1,ivx)*minmod(hdtdy * & 01836 (Info%aux(index+i,j+1,k,2)-Info%aux(index+i,j,k,2)),hdtdx*(Info%aux(index+i,j,k,1) - & 01837 Info%aux(index+i+1,j,k,1))) 01838 END FORALL 01839 END DO 01840 END IF 01841 IF (istime(index, Info%level, qLz, mB)) THEN 01842 DO i=mB(1,1),mB(1,2) 01843 FORALL(j=mB(2,1):mB(2,2), k=mB(3,1):mB(3,2)) 01844 qLz_%data(qLz_%x(i),j,k,1,iBx)=qLz_%data(qLz_%x(i),j,k,1,iBx)+w_%data(w_%x(i),j,k-1,1,ivx)*minmod(hdtdz * & 01845 (Info%aux(index+i,j,k,3)-Info%aux(index+i,j,k-1,3)),hdtdx*(Info%aux(index+i,j,k-1,1) - & 01846 Info%aux(index+i+1,j,k-1,1))) 01847 qLz_%data(qLz_%x(i),j,k,1,iBy)=qLz_%data(qLz_%x(i),j,k,1,iBy)+w_%data(w_%x(i),j,k-1,1,ivy)*minmod(hdtdz * & 01848 (Info%aux(index+i,j,k,3)-Info%aux(index+i,j,k-1,3)),hdtdy*(Info%aux(index+i,j,k-1,2) - & 01849 Info%aux(index+i,j+1,k-1,2))) 01850 END FORALL 01851 END DO 01852 END IF 01853 IF (istime(index, Info%level, qRz, mB)) THEN 01854 DO i=mB(1,1),mB(1,2) 01855 FORALL(j=mB(2,1):mB(2,2), k=mB(3,1):mB(3,2)) 01856 qRz_%data(qRz_%x(i),j,k,1,iBx)=qRz_%data(qRz_%x(i),j,k,1,iBx)+w_%data(w_%x(i),j,k,1,ivx)*minmod(hdtdz * & 01857 (Info%aux(index+i,j,k+1,3)-Info%aux(index+i,j,k,3)),hdtdx*(Info%aux(index+i,j,k,1) - & 01858 Info%aux(index+i+1,j,k,1))) 01859 qRz_%data(qRz_%x(i),j,k,1,iBy)=qRz_%data(qRz_%x(i),j,k,1,iBy)+w_%data(w_%x(i),j,k,1,ivy)*minmod(hdtdz * & 01860 (Info%aux(index+i,j,k+1,3)-Info%aux(index+i,j,k,3)),hdtdy*(Info%aux(index+i,j,k,2) - & 01861 Info%aux(index+i,j+1,k,2))) 01862 END FORALL 01863 END DO 01864 END IF 01865 END IF 01866 END SUBROUTINE MHD_Source_Terms 01867 01868 01873 SUBROUTINE calc_fluxes(Info, index) 01874 TYPE(InfoDef) :: Info ! Info structure currently updating 01875 INTEGER :: index ! Current row in q being updated 01876 INTEGER :: i,j,k ! Loop counters 01877 INTEGER :: mB(3,2) ! Bounds of slab to update 01878 INTEGER :: m 01879 IF (istimeshift(index, Info%level, fx, mB)) THEN 01880 DO i=mB(1,1),mB(1,2) 01881 DO j=mB(2,1),mB(2,2) 01882 DO k=mB(3,1),mB(3,2) 01883 maxsolverspeed(Info%level)=max(maxsolverspeed(Info%level),calc_flux_x(qLx_%data(qLx_%x(i),j,k,1,:), qRx_%data(qRx_%x(i),j,k,1,:), fx_%data(fx_%x(i),j,k,1,:))) 01884 END DO 01885 END DO 01886 01887 DO m=1,nFlux !FORALL(m=1:nFlux) 01888 fx_%data(fx_%x(i),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,SweepFluxFields(m)) = & 01889 fx_%data(fx_%x(i),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,SweepFluxFields(m))*hdtdx 01890 END DO !FORALL 01891 01892 END DO 01893 END IF 01894 01895 IF (istimeshift(index, Info%level, fy, mB)) THEN 01896 DO i=mB(1,1),mB(1,2) 01897 DO j=mB(2,1),mB(2,2) 01898 DO k=mB(3,1),mB(3,2) 01899 maxsolverspeed(Info%level)=max(maxsolverspeed(Info%level), calc_flux_y(qLy_%data(qLy_%x(i),j,k,1,:), qRy_%data(qRy_%x(i),j,k,1,:), fy_%data(fy_%x(i),j,k,1,:))) 01900 END DO 01901 END DO 01902 DO m=1,nFlux !FORALL(m=1:nFlux) 01903 fy_%data(fy_%x(i),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,SweepFluxFields(m)) = & 01904 fy_%data(fy_%x(i),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,SweepFluxFields(m))*hdtdy 01905 END DO !FORALL 01906 END DO 01907 END IF 01908 01909 01910 IF (istimeshift(index, Info%level, fz, mB)) THEN 01911 DO i=mB(1,1),mB(1,2) 01912 DO j=mB(2,1),mB(2,2) 01913 DO k=mB(3,1),mB(3,2) 01914 maxsolverspeed(Info%level)=max(maxsolverspeed(Info%level), calc_flux_z(qLz_%data(qLz_%x(i),j,k,1,:), qRz_%data(qRz_%x(i),j,k,1,:), fz_%data(fz_%x(i),j,k,1,:))) 01915 END DO 01916 END DO 01917 DO m=1,nFlux 01918 fz_%data(fz_%x(i),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,SweepFluxFields(m)) = & 01919 fz_%data(fz_%x(i),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,SweepFluxFields(m))*hdtdz 01920 END DO 01921 END DO 01922 END IF 01923 END SUBROUTINE calc_fluxes 01924 01925 01930 01931 SUBROUTINE calc_fluxes_noctu(Info, index) 01932 TYPE(InfoDef) :: Info ! Info structure currently updating 01933 INTEGER :: index ! Current row in q being updated 01934 INTEGER :: i,j,k ! Loop counters 01935 INTEGER :: mB(3,2) ! Bounds of slab to update 01936 INTEGER :: m 01937 IF (istimeshift(index, Info%level, f2x, mB)) THEN 01938 DO i=mB(1,1),mB(1,2) 01939 DO j=mB(2,1),mB(2,2) 01940 DO k=mB(3,1),mB(3,2) 01941 maxsolverspeed(Info%level)=max(maxsolverspeed(Info%level), calc_flux_x(qLx_%data(qLx_%x(i),j,k,1,:), qRx_%data(qRx_%x(i),j,k,1,:), f2x_%data(f2x_%x(i),j,k,1,:))) 01942 END DO 01943 END DO 01944 if (.false. .and. index+i == Info%mX(1)/4+1) THEN 01945 ! write(*,'(A,E25.16,A3,3E25.16)') 'qex at ', Info%xBounds(1,1)+real(index+i-1)*dx, ' = ', qLx_%data(qLx_%x(i),1,1,1,1), 1d0+.1d0*sin(2d0*Pi*(real(index+i-1,8)*dx - hdt)),abs(qLx_%data(qLx_%x(i),1,1,1,1)- (1d0+.1d0*sin(2d0*Pi*(real(index+i-1,8)*dx-hdt)))) 01946 ! write(*,'(A,E25.16,A3,3E25.16)') 'qex at ', Info%xBounds(1,1)+real(index+i-1)*dx, ' = ', f2x_%data(f2x_%x(i),1,1,1,1), 1d0+.1d0*sin(2d0*Pi*(real(index+i-1,8)*dx - hdt)),abs(f2x_%data(f2x_%x(i),1,1,1,1)- (1d0+.1d0*sin(2d0*Pi*(real(index+i-1,8)*dx-hdt)))) 01947 01948 write(*,'(A,E25.16,A3,3E25.16)') 'qex at ', Info%xBounds(1,1)+real(index+i-1)*dx, ' = ', f2x_%data(f2x_%x(i),1,1,1,1), 1d0-.1d0/2d0/pi/dt*(cos(2d0*Pi*(real(index+i-1,8)*dx))-cos(2d0*Pi*(real(index+i-1,8)*dx-dt))),abs(f2x_%data(f2x_%x(i),1,1,1,1)- (1d0-.1d0/2d0/pi/dt*(cos(2d0*Pi*(real(index+i-1,8)*dx))-cos(2d0*Pi*(real(index+i-1,8)*dx-dt))))) 01949 01950 ! write(*,'(A,E25.16,A3,3E25.16)') 'qex at ', Info%xBounds(1,1)+real(index+i)*dx, ' = ', qLx_%data(qLx_%x(i),1,1,1,1), 1d0+.1*sin(2d0*Pi*((real(index+i)-half)*dx - hdt)),abs(qLx_%data(qLx_%x(i),1,1,1,1)- (1d0+.1*sin(2d0*Pi*((real(index+i+1)-half)*dx-hdt)))) 01951 ! write(*,'(A,E25.16,A3,3E25.16)') 'qex at ', Info%xBounds(1,1)+real(index+i)*dx, ' = ', qRx_%data(qRx_%x(i),1,1,1,1), 1d0+.1*sin(2d0*Pi*(real(index+i)-half)*dx - hdt),abs(qRx_%data(qRx_%x(i),1,1,1,1)- (1d0+.1*sin(2d0*Pi*((real(index+i)-half)*dx-hdt)))) 01952 01953 ! 01954 ! write(*,'(A,E25.16,A3,3E25.16)') 'qex at ', Info%xBounds(1,1)+real(index+i)*dx, ' = ', qRx_%data(qRx_%x(i),1,1,1,1), 1d0+.1*sin(2d0*Pi*((real(index+i)-half)*dx - hdt)),abs(qRx_%data(qRx_%x(i),1,1,1,1)- (1d0+.1*sin(2d0*Pi*((real(index+i)-half)*dx-hdt)))) 01955 01956 ! write(*,'(A,E25.16,A3,3E25.16)') 'qex at ', Info%xBounds(1,1)+real(index+i)*dx, ' = ', f2x_%data(f2x_%x(i),1,1,1,1), 1d0+.1*sin(2d0*Pi*((real(index+i)-half)*dx - hdt)),abs(f2x_%data(f2x_%x(i),1,1,1,1)- (1d0+.1*sin(2d0*Pi*((real(index+i)-half)*dx-hdt)))) 01957 01958 ! write(*,'(A,E25.16,A3,3E25.16)') 'qex at ', Info%xBounds(1,1)+real(index+i)*dx, ' = ', qRx_%data(qRx_%x(i),1,1,1,1), 1d0+.1*sin(2d0*Pi*(real(index+i)-half)*dx - hdt),abs(qRx_%data(qRx_%x(i),1,1,1,1)- (1d0+.1*sin(2d0*Pi*((real(index+i)-half)*dx-hdt)))) 01959 ! STOP 01960 ! 01961 STOP 01962 END if 01963 01964 DO m=1,nFlux !FORALL(m=1:nFlux) 01965 f2x_%data(f2x_%x(i),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,SweepFluxFields(m)) = & 01966 f2x_%data(f2x_%x(i),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,SweepFluxFields(m))*dtdx 01967 END DO !FORALL 01968 01969 END DO 01970 END IF 01971 01972 IF (istimeshift(index, Info%level, f2y, mB)) THEN 01973 DO i=mB(1,1),mB(1,2) 01974 DO j=mB(2,1),mB(2,2) 01975 DO k=mB(3,1),mB(3,2) 01976 maxsolverspeed(Info%level)=max(maxsolverspeed(Info%level), calc_flux_y(qLy_%data(qLy_%x(i),j,k,1,:), qRy_%data(qRy_%x(i),j,k,1,:), f2y_%data(f2y_%x(i),j,k,1,:))) 01977 END DO 01978 END DO 01979 DO m=1,nFlux !FORALL(m=1:nFlux) 01980 f2y_%data(f2y_%x(i),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,SweepFluxFields(m)) = & 01981 f2y_%data(f2y_%x(i),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,SweepFluxFields(m))*dtdy 01982 END DO !FORALL 01983 END DO 01984 END IF 01985 IF (istimeshift(index, Info%level, f2z, mB)) THEN 01986 DO i=mB(1,1),mB(1,2) 01987 DO j=mB(2,1),mB(2,2) 01988 DO k=mB(3,1),mB(3,2) 01989 maxsolverspeed(Info%level)=max(maxsolverspeed(Info%level), calc_flux_z(qLz_%data(qLz_%x(i),j,k,1,:), qRz_%data(qRz_%x(i),j,k,1,:), f2z_%data(f2z_%x(i),j,k,1,:))) 01990 END DO 01991 END DO 01992 DO m=1,nFlux !FORALL(m=1:nFlux) 01993 f2z_%data(f2z_%x(i),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,SweepFluxFields(m)) = & 01994 f2z_%data(f2z_%x(i),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,SweepFluxFields(m))*dtdz 01995 END DO !FORALL 01996 01997 END DO 01998 END IF 01999 END SUBROUTINE calc_fluxes_noctu 02000 02001 02006 SUBROUTINE calc_emf(Info, index) 02007 TYPE(InfoDef) :: Info ! Info structure currently updating 02008 INTEGER :: index ! Current row in q being updated 02009 INTEGER :: i,j,k ! Loop counters 02010 INTEGER :: mB(3,2) ! Bounds of slab to update 02011 IF (istimeshift(index, Info%level, ex_bar, mB)) THEN 02012 DO i=mB(1,1),mB(1,2) 02013 FORALL(j=mB(2,1):mB(2,2), k=mB(3,1):mB(3,2)) 02014 ex_bar_%data(ex_bar_%x(i),j,k,1,1) = & 02015 w_%data(w_%x(i),j,k,1,ivz)*w_%data(w_%x(i),j,k,1,iBy)-w_%data(w_%x(i),j,k,1,ivy)*w_%data(w_%x(i),j,k,1,iBz) 02016 END FORALL 02017 END DO 02018 END IF 02019 IF (istimeshift(index, Info%level, ey_bar, mB)) THEN 02020 DO i=mB(1,1),mB(1,2) 02021 FORALL(j=mB(2,1):mB(2,2), k=mB(3,1):mB(3,2)) 02022 ey_bar_%data(ey_bar_%x(i),j,k,1,1) = & 02023 w_%data(w_%x(i),j,k,1,ivx)*w_%data(w_%x(i),j,k,1,iBz)-w_%data(w_%x(i),j,k,1,ivz)*w_%data(w_%x(i),j,k,1,iBx) 02024 END FORALL 02025 END DO 02026 END IF 02027 IF (istimeshift(index, Info%level, ez_bar, mB)) THEN 02028 DO i=mB(1,1),mB(1,2) 02029 FORALL(j=mB(2,1):mB(2,2), k=mB(3,1):mB(3,2)) 02030 ez_bar_%data(ez_bar_%x(i),j,k,1,1) = & 02031 w_%data(w_%x(i),j,k,1,ivy)*w_%data(w_%x(i),j,k,1,iBx)-w_%data(w_%x(i),j,k,1,ivx)*w_%data(w_%x(i),j,k,1,iBy) 02032 END FORALL 02033 END DO 02034 END IF 02035 IF (istimeshift(index, Info%level, ex, mB)) THEN 02036 DO i=mB(1,1),mB(1,2) 02037 FORALL(j=mB(2,1):mB(2,2), k=mB(3,1):mB(3,2)) 02038 ex_%data(ex_%x(i),j,k,1,1)=upwinded_emf(fz_%data(fz_%x(i),j-1:j,k,1,iBy),-fy_%data(fy_%x(i),j,k-1:k,1,iBz),& 02039 ex_bar_%data(ex_bar_%x(i),j-1:j,k-1:k,1,1), & 02040 fy_%data(fy_%x(i),j,k-1:k,1,1),fz_%data(fz_%x(i),j-1:j,k,1,1)) 02041 END FORALL 02042 END DO 02043 END IF 02044 IF (istimeshift(index, Info%level, ey, mB)) THEN 02045 DO i=mB(1,1),mB(1,2) 02046 FORALL(j=mB(2,1):mB(2,2), k=mB(3,1):mB(3,2)) 02047 ey_%data(ey_%x(i),j,k,1,1) = & 02048 upwinded_emf(fx_%data(fx_%x(i),j,k-1:k,1,iBz),(/-fz_%data(fz_%x(i-1),j,k,1,iBx),-fz_%data(fz_%x(i),j,k,1,iBx)/), & 02049 reshape((/ey_bar_%data(ey_bar_%x(i-1),j,k-1:k,1,1),ey_bar_%data(ey_bar_%x(i),j,k-1:k,1,1)/),(/2,2/)), & 02050 (/fz_%data(fz_%x(i-1),j,k,1,1),fz_%data(fz_%x(i),j,k,1,1)/),fx_%data(fx_%x(i),j,k-1:k,1,1)) 02051 END FORALL 02052 END DO 02053 END IF 02054 IF (istimeshift(index, Info%level, ez, mB)) THEN 02055 DO i=mB(1,1),mB(1,2) 02056 FORALL(j=mB(2,1):mB(2,2), k=mB(3,1):mB(3,2)) 02057 ez_%data(ez_%x(i),j,k,1,1) = & 02058 upwinded_emf((/fy_%data(fy_%x(i-1),j,k,1,iBx),fy_%data(fy_%x(i),j,k,1,iBx)/),-fx_%data(fx_%x(i),j-1:j,k,1,iBy), & 02059 transpose(reshape((/ez_bar_%data(ez_bar_%x(i-1),j-1:j,k,1,1), ez_bar_%data(ez_bar_%x(i),j-1:j,k,1,1)/),(/2,2/))), & 02060 fx_%data(fx_%x(i),j-1:j,k,1,1),(/fy_%data(fy_%x(i-1),j,k,1,1),fy_%data(fy_%x(i),j,k,1,1)/)) 02061 END FORALL 02062 END DO 02063 END IF 02064 END SUBROUTINE calc_emf 02065 02070 SUBROUTINE updateB(Info,index) 02071 TYPE(InfoDef) :: Info ! Info structure currently updating 02072 INTEGER :: index ! Current row in q being updated 02073 INTEGER :: i,j,k ! Loop counters 02074 INTEGER :: mB(3,2) ! Bounds of slab to update 02075 IF (istimeshift(index, Info%level, A2x, mB)) THEN 02076 A2x_%data(A2x_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,:) = & 02077 Info%aux(index+mB(1,1):index+mB(1,2),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1:1) & 02078 - hdtdy*(ez_%data(ez_%x(mB(1,1):mB(1,2)),mB(2,1)+1:mB(2,2)+1, mB(3,1):mB(3,2),1,1:1) & 02079 -ez_%data(ez_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,1:1)) 02080 IF (nDim >= 3) THEN 02081 A2x_%data(A2x_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,:) = & 02082 A2x_%data(A2x_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,:) & 02083 + hdtdz*(ey_%data(ey_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1)+1:mB(3,2)+1,1,1:1) & 02084 -ey_%data(ey_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,1:1)) 02085 END IF 02086 END IF 02087 IF (istimeshift(index, Info%level, A2y, mB)) THEN 02088 A2y_%data(A2y_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,:) = & 02089 Info%aux(index+mB(1,1):index+mB(1,2),mB(2,1):mB(2,2), mB(3,1):mB(3,2),2:2) & 02090 + hdtdx*(ez_%data(ez_%x(mB(1,1)+1:mB(1,2)+1),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,1:1) & 02091 -ez_%data(ez_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,1:1)) 02092 IF (nDim >= 3) THEN 02093 A2y_%data(A2y_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,:) = & 02094 A2y_%data(A2y_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,:) & 02095 - hdtdz*(ex_%data(ex_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1)+1:mB(3,2)+1,1,1:1) & 02096 -ex_%data(ex_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,1:1)) 02097 END IF 02098 END IF 02099 IF (istimeshift(index, Info%level, A2z, mB)) THEN 02100 A2z_%data(A2z_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,:) = & 02101 Info%aux(index+mB(1,1):index+mB(1,2),mB(2,1):mB(2,2), mB(3,1):mB(3,2),3:3) & 02102 + hdtdy*(ex_%data(ex_%x(mB(1,1):mB(1,2)),mB(2,1)+1:mB(2,2)+1, mB(3,1):mB(3,2),1,1:1) & 02103 -ex_%data(ex_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,1:1)) & 02104 - hdtdx*(ey_%data(ey_%x(mB(1,1)+1:mB(1,2)+1),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,1:1) & 02105 -ey_%data(ey_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,1:1)) 02106 END IF 02107 02108 END SUBROUTINE updateB 02109 02113 SUBROUTINE updatew2(Info,index) 02114 TYPE(InfoDef) :: Info ! Info structure currently updating 02115 INTEGER :: index ! Current row in q being updated 02116 INTEGER :: i,j,k ! Loop counters 02117 INTEGER :: mB(3,2) ! Bounds of slab to update 02118 INTEGER :: m 02119 REAL(KIND=qPREC), DIMENSION(:), POINTER :: q 02120 02121 IF (istimeshift(index, Info%level, w2, mB)) THEN 02122 DO i=mB(1,1),mB(1,2) 02123 FORALL(j=mB(2,1):mB(2,2), k=mB(3,1):mB(3,2),m=1:nSweepFlux) 02124 w2_%data(w2_%x(i),j,k,1,SweepFluxFields(m))=beforesweepstep_%data(beforesweepstep_%x(i),j,k,1,SweepFluxFields(m))+(fx_%data(fx_%x(i),j,k,1,SweepFluxFields(m)) - & 02125 fx_%data(fx_%x(i+1),j,k,1,SweepFluxFields(m))) 02126 END FORALL 02127 IF (nDim >= 2) THEN 02128 FORALL(j=mB(2,1):mB(2,2), k=mB(3,1):mB(3,2),m=1:nSweepFlux) 02129 w2_%data(w2_%x(i),j,k,1,SweepFluxFields(m))=w2_%data(w2_%x(i),j,k,1,SweepFluxFields(m))+(fy_%data(fy_%x(i),j,k,1,SweepFluxFields(m)) - & 02130 fy_%data(fy_%x(i),j+1,k,1,SweepFluxFields(m))) 02131 END FORALL 02132 IF (nDim >= 3) THEN 02133 FORALL(j=mB(2,1):mB(2,2), k=mB(3,1):mB(3,2),m=1:nSweepFlux) 02134 w2_%data(w2_%x(i),j,k,1,SweepFluxFields(m))=w2_%data(w2_%x(i),j,k,1,SweepFluxFields(m))+(fz_%data(fz_%x(i),j,k,1,SweepFluxFields(m)) - & 02135 fz_%data(fz_%x(i),j,k+1,1,SweepFluxFields(m))) 02136 END FORALL 02137 END IF 02138 END IF 02139 END DO 02140 IF (lMHD) THEN 02141 IF (nDim >= 2) THEN 02142 w2_%data(w2_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,iBx) = & 02143 half*(A2x_%data(A2x_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2),mB(3,1):mB(3,2),1,1) + & 02144 A2x_%data(A2x_%x(mB(1,1)+1:mB(1,2)+1),mB(2,1):mB(2,2),mB(3,1):mB(3,2),1,1)) 02145 w2_%data(w2_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,iBy) = & 02146 half*(A2y_%data(A2y_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2),mB(3,1):mB(3,2),1,1) + & 02147 A2y_%data(A2y_%x(mB(1,1):mB(1,2)),mB(2,1)+1:mB(2,2)+1,mB(3,1):mB(3,2),1,1)) 02148 IF (nDim >= 3) THEN 02149 w2_%data(w2_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,iBz) = & 02150 half*(A2z_%data(A2z_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2),mB(3,1):mB(3,2),1,1) + & 02151 A2z_%data(A2z_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2),mB(3,1)+1:mB(3,2)+1,1,1)) 02152 END IF 02153 END IF 02154 END IF 02155 IF (lSelfGravity) THEN 02156 w2_%data(w2_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,ivx) = & 02157 w2_%data(w2_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,ivx) - qdtdx*& 02158 Info%q(index+mB(1,1):index+mB(1,2),mB(2,1):mB(2,2), mB(3,1):mB(3,2),irho) * & 02159 (Info%q(index+mB(1,1)+1:index+mB(1,2)+1,mB(2,1):mB(2,2), mB(3,1):mB(3,2), iPhiGas) - & 02160 Info%q(index+mB(1,1)-1:index+mB(1,2)-1,mB(2,1):mB(2,2), mB(3,1):mB(3,2), iPhiGas)) 02161 02162 w2_%data(w2_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,iE) = & 02163 w2_%data(w2_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,iE) - qdtdx*& 02164 Info%q(index+mB(1,1):index+mB(1,2),mB(2,1):mB(2,2), mB(3,1):mB(3,2),ivx) * & 02165 (Info%q(index+mB(1,1)+1:index+mB(1,2)+1,mB(2,1):mB(2,2), mB(3,1):mB(3,2), iPhiGas) - & 02166 Info%q(index+mB(1,1)-1:index+mB(1,2)-1,mB(2,1):mB(2,2), mB(3,1):mB(3,2), iPhiGas)) 02167 02168 IF (nDim >= 2) THEN 02169 w2_%data(w2_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,ivy) = & 02170 w2_%data(w2_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,ivy) - qdtdy*& 02171 Info%q(index+mB(1,1):index+mB(1,2),mB(2,1):mB(2,2), mB(3,1):mB(3,2),irho) * & 02172 (Info%q(index+mB(1,1):index+mB(1,2),mB(2,1)+1:mB(2,2)+1, mB(3,1):mB(3,2), iPhiGas) - & 02173 Info%q(index+mB(1,1):index+mB(1,2),mB(2,1)-1:mB(2,2)-1, mB(3,1):mB(3,2), iPhiGas)) 02174 02175 w2_%data(w2_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,iE) = & 02176 w2_%data(w2_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,iE) - qdtdy*& 02177 Info%q(index+mB(1,1):index+mB(1,2),mB(2,1):mB(2,2), mB(3,1):mB(3,2),ivy) * & 02178 (Info%q(index+mB(1,1):index+mB(1,2),mB(2,1)+1:mB(2,2)+1, mB(3,1):mB(3,2), iPhiGas) - & 02179 Info%q(index+mB(1,1):index+mB(1,2),mB(2,1)-1:mB(2,2)-1, mB(3,1):mB(3,2), iPhiGas)) 02180 02181 IF (nDim >= 3) THEN 02182 w2_%data(w2_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,ivz) = & 02183 w2_%data(w2_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,ivz) - qdtdz*& 02184 Info%q(index+mB(1,1):index+mB(1,2),mB(2,1):mB(2,2), mB(3,1):mB(3,2),irho) * & 02185 (Info%q(index+mB(1,1):index+mB(1,2),mB(2,1):mB(2,2), mB(3,1)+1:mB(3,2)+1, iPhiGas) - & 02186 Info%q(index+mB(1,1):index+mB(1,2),mB(2,1):mB(2,2), mB(3,1)-1:mB(3,2)-1, iPhiGas)) 02187 02188 w2_%data(w2_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,iE) = & 02189 w2_%data(w2_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,iE) - qdtdz*& 02190 Info%q(index+mB(1,1):index+mB(1,2),mB(2,1):mB(2,2), mB(3,1):mB(3,2),ivz) * & 02191 (Info%q(index+mB(1,1):index+mB(1,2),mB(2,1):mB(2,2), mB(3,1)+1:mB(3,2)+1, iPhiGas) - & 02192 Info%q(index+mB(1,1):index+mB(1,2),mB(2,1):mB(2,2), mB(3,1)-1:mB(3,2)-1, iPhiGas)) 02193 02194 END IF 02195 END IF 02196 END IF 02197 DO i=mB(1,1),mB(1,2) 02198 CALL cons_to_prim_1(w2_%data(w2_%x(i),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,:)) 02199 END DO 02200 END IF 02201 END SUBROUTINE updatew2 02202 02203 02208 SUBROUTINE update_fluxes(Info, index) 02209 TYPE(InfoDef) :: Info ! Info structure currently updating 02210 INTEGER :: index ! Current row in q being updated 02211 INTEGER :: i,j,k ! Loop counters 02212 INTEGER :: mB(3,2) ! Bounds of slab to update 02213 IF (nDim >= 3) THEN 02214 IF (istimeshift(index, Info%level, ctfx, mB)) THEN 02215 DO i=mB(1,1),mB(1,2) 02216 FORALL(j=mB(2,1):mB(2,2), k=mB(3,1):mB(3,2)) 02217 ctfx_%data(ctfx_%x(i),j,k,1,1)=-qdtdx*(ez_%data(ez_%x(i),j,k,1,1)+ez_%data(ez_%x(i),j+1,k,1,1)) 02218 ctfx_%data(ctfx_%x(i),j,k,1,2)=qdtdx*(ey_%data(ey_%x(i),j,k,1,1)+ey_%data(ey_%x(i),j,k+1,1,1)) 02219 END FORALL 02220 END DO 02221 END IF 02222 IF (istimeshift(index, Info%level, ctfy, mB)) THEN 02223 DO i=mB(1,1),mB(1,2) 02224 FORALL(j=mB(2,1):mB(2,2), k=mB(3,1):mB(3,2)) 02225 ctfy_%data(ctfy_%x(i),j,k,1,1)=-qdtdy*(ex_%data(ex_%x(i),j,k,1,1)+ex_%data(ex_%x(i),j,k+1,1,1)) 02226 ctfy_%data(ctfy_%x(i),j,k,1,2)=qdtdy*(ez_%data(ez_%x(i),j,k,1,1)+ez_%data(ez_%x(i+1),j,k,1,1)) 02227 END FORALL 02228 END DO 02229 END IF 02230 IF (istimeshift(index, Info%level, ctfz, mB)) THEN 02231 DO i=mB(1,1),mB(1,2) 02232 FORALL(j=mB(2,1):mB(2,2), k=mB(3,1):mB(3,2)) 02233 ctfz_%data(ctfz_%x(i),j,k,1,1)=-qdtdz*(ey_%data(ey_%x(i),j,k,1,1)+ey_%data(ey_%x(i+1),j,k,1,1)) 02234 ctfz_%data(ctfz_%x(i),j,k,1,2)=qdtdz*(ex_%data(ex_%x(i),j,k,1,1)+ex_%data(ex_%x(i),j+1,k,1,1)) 02235 END FORALL 02236 END DO 02237 END IF 02238 END IF 02239 END SUBROUTINE update_fluxes 02240 02241 02245 SUBROUTINE CTU(Info,index) 02246 TYPE(InfoDef) :: Info ! Info structure currently updating 02247 INTEGER :: index ! Current row in q being updated 02248 INTEGER :: i,j,k ! Loop counters 02249 INTEGER :: mB(3,2) ! Bounds of slab to update 02250 INTEGER :: m 02251 IF(istimeshift(index, Info%level, Sx, mB)) THEN 02252 02253 IF (nDim == 2) THEN 02254 DO i=mB(1,1),mB(1,2) 02255 FORALL(j=mB(2,1):mB(2,2), k=mB(3,1):mB(3,2)) 02256 Sx_%data(Sx_%x(i),j,k,1,m_low:m_high)=hdtdx*w_%data(w_%x(i),j,k,1,iBx:iBz)*(Info%aux(index+i+1,j,k,1)-Info%aux(index+i,j,k,1)) 02257 Sx_%data(Sx_%x(i),j,k,1,iBz)=w_%data(w_%x(i),j,k,1,ivz)*minmod(hdtdy*(Info%aux(index+i,j,k,2)-Info%aux(index+i,j+1,k,2)), & 02258 hdtdx*(Info%aux(index+i+1,j,k,1)-Info%aux(index+i,j,k,1))) 02259 END FORALL 02260 IF (iE .ne. 0) FORALL(j=mB(2,1):mB(2,2), k=mB(3,1):mB(3,2)) & 02261 Sx_%data(Sx_%x(i),j,k,1,iE) = w_%data(w_%x(i),j,k,1,iBz)*Sx_%data(Sx_%x(i),j,k,1,iBz) 02262 END DO 02263 ELSE 02264 DO i=mB(1,1),mB(1,2) 02265 FORALL(j=mB(2,1):mB(2,2), k=mB(3,1):mB(3,2)) 02266 Sx_%data(Sx_%x(i),j,k,1,m_low:m_high)=hdtdx*w_%data(w_%x(i),j,k,1,iBx:iBz)*(Info%aux(index+i+1,j,k,1) - & 02267 Info%aux(index+i,j,k,1)) 02268 Sx_%data(Sx_%x(i),j,k,1,iBy)=w_%data(w_%x(i),j,k,1,ivy)*minmod(hdtdz*(Info%aux(index+i,j,k,3)-Info%aux(index+i,j,k+1,3)), & 02269 hdtdx*(Info%aux(index+i+1,j,k,1)-Info%aux(index+i,j,k,1))) 02270 Sx_%data(Sx_%x(i),j,k,1,iBz)=w_%data(w_%x(i),j,k,1,ivz)*minmod(hdtdy*(Info%aux(index+i,j,k,2)-Info%aux(index+i,j+1,k,2)), & 02271 hdtdx*(Info%aux(index+i+1,j,k,1)-Info%aux(index+i,j,k,1))) 02272 END FORALL 02273 IF (iE .ne. 0) THEN 02274 FORALL(j=mB(2,1):mB(2,2), k=mB(3,1):mB(3,2)) 02275 Sx_%data(Sx_%x(i),j,k,1,iE)=w_%data(w_%x(i),j,k,1,iBy)*Sx_%data(Sx_%x(i),j,k,1,iBy)+w_%data(w_%x(i),j,k,1,iBz)*Sx_%data(Sx_%x(i),j,k,1,iBz) 02276 END FORALL 02277 END IF 02278 END DO 02279 END IF 02280 END IF 02281 IF(istimeshift(index, Info%level, Sy, mB)) THEN 02282 IF (nDim == 2) THEN 02283 DO i=mB(1,1),mB(1,2) 02284 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 02285 Sy_%data(Sy_%x(i),j,k,1,m_low:m_high)=hdtdy*w_%data(w_%x(i),j,k,1,iBx:iBz)*(Info%aux(index+i,j+1,k,2)-Info%aux(index+i,j,k,2)) 02286 Sy_%data(Sy_%x(i),j,k,1,iBz)=w_%data(w_%x(i),j,k,1,ivz)*minmod(hdtdx*(Info%aux(index+i,j,k,1)-Info%aux(index+i+1,j,k,1)), & 02287 hdtdy*(Info%aux(index+i,j+1,k,2)-Info%aux(index+i,j,k,2))) 02288 END FORALL 02289 IF (iE .ne. 0) THEN 02290 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 02291 Sy_%data(Sy_%x(i),j,k,1,iE)=w_%data(w_%x(i),j,k,1,iBz)*Sy_%data(Sy_%x(i),j,k,1,iBz) 02292 END FORALL 02293 END IF 02294 END DO 02295 ELSE 02296 DO i=mB(1,1),mB(1,2) 02297 FORALL(j=mB(2,1):mB(2,2), k=mB(3,1):mB(3,2)) 02298 Sy_%data(Sy_%x(i),j,k,1,m_low:m_high) = hdtdy*w_%data(w_%x(i),j,k,1,iBx:iBz)*(Info%aux(index+i,j+1,k,2)-Info%aux(index+i,j,k,2)) 02299 Sy_%data(Sy_%x(i),j,k,1,iBz)=w_%data(w_%x(i),j,k,1,ivz)*minmod(hdtdx*(Info%aux(index+i,j,k,1)-Info%aux(index+i+1,j,k,1)), & 02300 hdtdy*(Info%aux(index+i,j+1,k,2)-Info%aux(index+i,j,k,2))) 02301 Sy_%data(Sy_%x(i),j,k,1,iBx)=w_%data(w_%x(i),j,k,1,ivx)*minmod(hdtdz*(Info%aux(index+i,j,k,3)-Info%aux(index+i,j,k+1,3)), & 02302 hdtdy*(Info%aux(index+i,j+1,k,2)-Info%aux(index+i,j,k,2))) 02303 END FORALL 02304 IF (iE .ne. 0) THEN 02305 FORALL(j=mB(2,1):mB(2,2), k=mB(3,1):mB(3,2)) 02306 Sy_%data(Sy_%x(i),j,k,1,iE)=w_%data(w_%x(i),j,k,1,iBz)*Sy_%data(Sy_%x(i),j,k,1,iBz)+w_%data(w_%x(i),j,k,1,iBx)*Sy_%data(Sy_%x(i),j,k,1,iBx) 02307 END FORALL 02308 END IF 02309 END DO 02310 02311 END IF 02312 END IF 02313 IF(istimeshift(index, Info%level, Sz, mB)) THEN 02314 DO i=mB(1,1),mB(1,2) 02315 FORALL(j=mB(2,1):mB(2,2), k=mB(3,1):mB(3,2)) 02316 Sz_%data(Sz_%x(i),j,k,1,m_low:m_high) = hdtdz*w_%data(w_%x(i),j,k,1,iBx:iBz)*(Info%aux(index+i,j,k+1,3)-Info%aux(index+i,j,k,3)) 02317 Sz_%data(Sz_%x(i),j,k,1,iBx)=w_%data(w_%x(i),j,k,1,ivx)*minmod(hdtdy*(Info%aux(index+i,j,k,2)-Info%aux(index+i,j+1,k,2)), & 02318 hdtdz*(Info%aux(index+i,j,k+1,3)-Info%aux(index+i,j,k,3))) 02319 Sz_%data(Sz_%x(i),j,k,1,iBy)=w_%data(w_%x(i),j,k,1,ivy)*minmod(hdtdx*(Info%aux(index+i,j,k,1)-Info%aux(index+i+1,j,k,1)), & 02320 hdtdz*(Info%aux(index+i,j,k+1,3)-Info%aux(index+i,j,k,3))) 02321 END FORALL 02322 IF (iE .ne. 0) THEN 02323 FORALL(j=mB(2,1):mB(2,2), k=mB(3,1):mB(3,2)) 02324 Sz_%data(Sz_%x(i),j,k,1,iE)=w_%data(w_%x(i),j,k,1,iBx)*Sz_%data(Sz_%x(i),j,k,1,iBx)+w_%data(w_%x(i),j,k,1,iBy)*Sz_%data(Sz_%x(i),j,k,1,iBy) 02325 END FORALL 02326 END IF 02327 END DO 02328 END IF 02329 02330 02331 IF(istimeshift(index, Info%level, q2Lx, mB)) THEN 02332 DO i=mB(1,1),mB(1,2) 02333 CALL prim_to_cons_2(qLx_%data(qLx_%x(i),mB(2,1):mB(2,2),mB(3,1):mB(3,2),1,:), & 02334 q2Lx_%data(q2Lx_%x(i),mB(2,1):mB(2,2),mB(3,1):mB(3,2),1,:)) 02335 FORALL(j=mB(2,1):mB(2,2), k=mB(3,1):mB(3,2),m=1:nSweepFlux) 02336 q2Lx_%data(q2Lx_%x(i),j,k,1,SweepFluxFields(m))=q2Lx_%data(q2Lx_%x(i),j,k,1,SweepFluxFields(m))+(fy_%data(fy_%x(i-1),j,k,1,SweepFluxFields(m)) - & 02337 fy_%data(fy_%x(i-1),j+1,k,1,SweepFluxFields(m))) 02338 END FORALL 02339 IF (nDim >= 3) THEN 02340 FORALL(j=mB(2,1):mB(2,2), k=mB(3,1):mB(3,2),m=1:nSweepFlux) 02341 q2Lx_%data(q2Lx_%x(i),j,k,1,SweepFluxFields(m))=q2Lx_%data(q2Lx_%x(i),j,k,1,SweepFluxFields(m))+(fz_%data(fz_%x(i-1),j,k,1,SweepFluxFields(m)) - & 02342 fz_%data(fz_%x(i-1),j,k+1,1,SweepFluxFields(m))) 02343 END FORALL 02344 END IF 02345 IF (lMHD) THEN 02346 FORALL(j=mB(2,1):mB(2,2), k=mB(3,1):mB(3,2),m=1:SweepCons) 02347 q2Lx_%data(q2Lx_%x(i),j,k,1,m)=q2Lx_%data(q2Lx_%x(i),j,k,1,m)+Sx_%data(Sx_%x(i-1),j,k,1,m) 02348 END FORALL 02349 FORALL(j=mB(2,1):mB(2,2), k=mB(3,1):mB(3,2)) 02350 q2Lx_%data(q2Lx_%x(i),j,k,1,iBx) = A2x_%data(A2x_%x(i),j,k,1,1) 02351 END FORALL 02352 02353 IF (nDim >= 3) THEN 02354 FORALL(j=mB(2,1):mB(2,2), k=mB(3,1):mB(3,2)) 02355 q2Lx_%data(q2Lx_%x(i),j,k,1,iBy) = q2Lx_%data(q2Lx_%x(i),j,k,1,iBy)+(ctfz_%data(ctfz_%x(i-1),j,k,1,2)-ctfz_%data(ctfz_%x(i-1),j,k+1,1,2)) 02356 q2Lx_%data(q2Lx_%x(i),j,k,1,iBz) = q2Lx_%data(q2Lx_%x(i),j,k,1,iBz)+(ctfy_%data(ctfy_%x(i-1),j,k,1,1)-ctfy_%data(ctfy_%x(i-1),j+1,k,1,1)) 02357 END FORALL 02358 END IF 02359 END IF 02360 IF (lSelfGravity) THEN 02361 FORALL(j=mB(2,1):mB(2,2), k=mB(3,1):mB(3,2)) 02362 q2Lx_%data(q2Lx_%x(i),j,k,1,ivy)=q2Lx_%data(q2Lx_%x(i),j,k,1,ivy)-qdt*Info%q(index+i-1,j,k,1)*sum(gradphiy_%data(gradphiy_%x(i-1),j:j+1,k,1,1)) 02363 END FORALL 02364 IF (iE /= 0) THEN 02365 FORALL(j=mB(2,1):mB(2,2), k=mB(3,1):mB(3,2)) 02366 q2Lx_%data(q2Lx_%x(i),j,k,1,iE)=q2Lx_%data(q2Lx_%x(i),j,k,1,iE)-hdx*(fy_%data(fy_%x(i-1),j,k,1,1)*gradphiy_%data(gradphiy_%x(i-1),j,k,1,1)+fy_%data(fy_%x(i-1),j+1,k,1,1)*gradphiy_%data(gradphiy_%x(i-1),j+1,k,1,1)) 02367 END FORALL 02368 END IF 02369 IF (nDim >= 3) THEN 02370 FORALL(j=mB(2,1):mB(2,2), k=mB(3,1):mB(3,2)) 02371 q2Lx_%data(q2Lx_%x(i),j,k,1,ivz)=q2Lx_%data(q2Lx_%x(i),j,k,1,ivz)-qdt*Info%q(index+i-1,j,k,1)*sum(gradphiz_%data(gradphiz_%x(i-1),j,k:k+1,1,1)) 02372 END FORALL 02373 IF (iE /= 0) THEN 02374 FORALL(j=mB(2,1):mB(2,2), k=mB(3,1):mB(3,2)) 02375 q2Lx_%data(q2Lx_%x(i),j,k,1,iE)=q2Lx_%data(q2Lx_%x(i),j,k,1,iE)-hdx*(fz_%data(fz_%x(i-1),j,k,1,1)*gradphiz_%data(gradphiz_%x(i-1),j,k,1,1)+fz_%data(fz_%x(i-1),j,k+1,1,1)*gradphiz_%data(gradphiz_%x(i-1),j,k+1,1,1)) 02376 END FORALL 02377 END IF 02378 END IF 02379 END IF 02380 CALL cons_to_prim_1(q2Lx_%data(q2Lx_%x(i),mB(2,1):mB(2,2),mB(3,1):mB(3,2),1,:)) 02381 IF (lCautious) CALL protect_all(q2Lx_%data(q2Lx_%x(i),mB(2,1):mB(2,2),mB(3,1):mB(3,2),1,:)) 02382 END DO 02383 02384 END IF 02385 IF(istimeshift(index, Info%level, q2Rx, mB)) THEN 02386 DO i=mB(1,1),mB(1,2) 02387 CALL prim_to_cons_2(qRx_%data(qRx_%x(i),mB(2,1):mB(2,2),mB(3,1):mB(3,2),1,:), & 02388 q2Rx_%data(q2Rx_%x(i),mB(2,1):mB(2,2),mB(3,1):mB(3,2),1,:)) 02389 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2),m=1:nSweepFlux) 02390 q2Rx_%data(q2Rx_%x(i),j,k,1,SweepFluxFields(m))=q2Rx_%data(q2Rx_%x(i),j,k,1,SweepFluxFields(m))+(fy_%data(fy_%x(i),j,k,1,SweepFluxFields(m)) - & 02391 fy_%data(fy_%x(i),j+1,k,1,SweepFluxFields(m))) 02392 END FORALL 02393 02394 IF (nDim >= 3) THEN 02395 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2),m=1:nSweepFlux) 02396 q2Rx_%data(q2Rx_%x(i),j,k,1,SweepFluxFields(m))=q2Rx_%data(q2Rx_%x(i),j,k,1,SweepFluxFields(m))+(fz_%data(fz_%x(i),j,k,1,SweepFluxFields(m)) - & 02397 fz_%data(fz_%x(i),j,k+1,1,SweepFluxFields(m))) 02398 END FORALL 02399 END IF 02400 IF (lMHD) THEN 02401 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2),m=1:SweepCons) 02402 q2Rx_%data(q2Rx_%x(i),j,k,1,m)=q2Rx_%data(q2Rx_%x(i),j,k,1,m)+Sx_%data(Sx_%x(i),j,k,1,m) 02403 END FORALL 02404 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 02405 q2Rx_%data(q2Rx_%x(i),j,k,1,iBx)=A2x_%data(A2x_%x(i),j,k,1,1) 02406 END FORALL 02407 IF (nDim >= 3) THEN 02408 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 02409 q2Rx_%data(q2Rx_%x(i),j,k,1,iBz)=q2Rx_%data(q2Rx_%x(i),j,k,1,iBz)+(ctfy_%data(ctfy_%x(i),j,k,1,1)-ctfy_%data(ctfy_%x(i),j+1,k,1,1)) 02410 q2Rx_%data(q2Rx_%x(i),j,k,1,iBy)=q2Rx_%data(q2Rx_%x(i),j,k,1,iBy)+(ctfz_%data(ctfz_%x(i),j,k,1,2)-ctfz_%data(ctfz_%x(i),j,k+1,1,2)) 02411 END FORALL 02412 END IF 02413 END IF 02414 02415 IF (lSelfGravity) THEN 02416 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 02417 q2Rx_%data(q2Rx_%x(i),j,k,1,ivy)=q2Rx_%data(q2Rx_%x(i),j,k,1,ivy)-qdt*Info%q(index+i,j,k,1)*sum(gradphiy_%data(gradphiy_%x(i),j:j+1,k,1,1)) 02418 END FORALL 02419 IF (iE /= 0) THEN 02420 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 02421 q2Rx_%data(q2Rx_%x(i),j,k,1,iE)=q2Rx_%data(q2Rx_%x(i),j,k,1,iE)-hdx*(fy_%data(fy_%x(i),j,k,1,1)*gradphiy_%data(gradphiy_%x(i),j,k,1,1)+fy_%data(fy_%x(i),j+1,k,1,1)*gradphiy_%data(gradphiy_%x(i),j+1,k,1,1)) 02422 END FORALL 02423 END IF 02424 IF (nDim >= 3) THEN 02425 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 02426 q2Rx_%data(q2Rx_%x(i),j,k,1,ivz)=q2Rx_%data(q2Rx_%x(i),j,k,1,ivz)-qdt*Info%q(index+i,j,k,1)*sum(gradphiz_%data(gradphiz_%x(i),j,k:k+1,1,1)) 02427 END FORALL 02428 IF (iE /= 0) THEN 02429 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 02430 q2Rx_%data(q2Rx_%x(i),j,k,1,iE)=q2Rx_%data(q2Rx_%x(i),j,k,1,iE)-hdx*(fz_%data(fz_%x(i),j,k,1,1)*gradphiz_%data(gradphiz_%x(i),j,k,1,1)+fz_%data(fz_%x(i),j,k+1,1,1)*gradphiz_%data(gradphiz_%x(i),j,k+1,1,1)) 02431 END FORALL 02432 END IF 02433 END IF 02434 END IF 02435 02436 CALL cons_to_prim_1(q2Rx_%data(q2Rx_%x(i),mB(2,1):mB(2,2),mB(3,1):mB(3,2),1,:)) 02437 IF (lCautious) CALL protect_all(q2Rx_%data(q2Rx_%x(i),mB(2,1):mB(2,2),mB(3,1):mB(3,2),1,:)) 02438 END DO 02439 END IF 02440 02441 IF(istimeshift(index, Info%level, q2Ly, mB)) THEN 02442 DO i=mB(1,1),mB(1,2) 02443 CALL prim_to_cons_2(qLy_%data(qLy_%x(i),mB(2,1):mB(2,2),mB(3,1):mB(3,2),1,:), & 02444 q2Ly_%data(q2Ly_%x(i),mB(2,1):mB(2,2),mB(3,1):mB(3,2),1,:)) 02445 02446 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2),m=1:nSweepFlux) 02447 q2Ly_%data(q2Ly_%x(i),j,k,1,SweepFluxFields(m))=q2Ly_%data(q2Ly_%x(i),j,k,1,SweepFluxFields(m))+(fx_%data(fx_%x(i),j-1,k,1,SweepFluxFields(m)) - & 02448 fx_%data(fx_%x(i+1),j-1,k,1,SweepFluxFields(m))) 02449 END FORALL 02450 IF (nDim >= 3) THEN 02451 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2),m=1:nSweepFlux) 02452 q2Ly_%data(q2Ly_%x(i),j,k,1,SweepFluxFields(m))=q2Ly_%data(q2Ly_%x(i),j,k,1,SweepFluxFields(m))+(fz_%data(fz_%x(i),j-1,k,1,SweepFluxFields(m)) - & 02453 fz_%data(fz_%x(i),j-1,k+1,1,SweepFluxFields(m))) 02454 END FORALL 02455 END IF 02456 IF (lMHD) THEN 02457 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2),m=1:SweepCons) 02458 q2Ly_%data(q2Ly_%x(i),j,k,1,m)=q2Ly_%data(q2Ly_%x(i),j,k,1,m)+Sy_%data(Sy_%x(i),j-1,k,1,m) 02459 END FORALL 02460 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 02461 q2Ly_%data(q2Ly_%x(i),j,k,1,iBy)=A2y_%data(A2y_%x(i),j,k,1,1) 02462 END FORALL 02463 IF (nDim >= 3) THEN 02464 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 02465 q2Ly_%data(q2Ly_%x(i),j,k,1,iBz)=q2Ly_%data(q2Ly_%x(i),j,k,1,iBz)+(ctfx_%data(ctfx_%x(i),j-1,k,1,2)-ctfx_%data(ctfx_%x(i+1),j-1,k,1,2)) 02466 q2Ly_%data(q2Ly_%x(i),j,k,1,iBx)=q2Ly_%data(q2Ly_%x(i),j,k,1,iBx)+(ctfz_%data(ctfz_%x(i),j-1,k,1,1)-ctfz_%data(ctfz_%x(i),j-1,k+1,1,1)) 02467 END FORALL 02468 END IF 02469 END IF 02470 02471 02472 IF (lSelfGravity) THEN 02473 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 02474 q2Ly_%data(q2Ly_%x(i),j,k,1,ivx)=q2Ly_%data(q2Ly_%x(i),j,k,1,ivx)-qdt*Info%q(index+i,j-1,k,1)*sum(gradphix_%data((/gradphix_%x(i:i+1)/),j-1,k,1,1)) 02475 END FORALL 02476 IF (iE /= 0) THEN 02477 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 02478 q2Ly_%data(q2Ly_%x(i),j,k,1,iE)=q2Ly_%data(q2Ly_%x(i),j,k,1,iE)-hdx*(fx_%data(fx_%x(i),j-1,k,1,1)*gradphix_%data(gradphix_%x(i),j-1,k,1,1)+fx_%data(fx_%x(i+1),j-1,k,1,1)*gradphix_%data(gradphix_%x(i+1),j-1,k,1,1)) 02479 END FORALL 02480 END IF 02481 IF (nDim >= 3) THEN 02482 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 02483 q2Ly_%data(q2Ly_%x(i),j,k,1,ivz)=q2Ly_%data(q2Ly_%x(i),j,k,1,ivz)-qdt*Info%q(index+i,j-1,k,1)*sum(gradphiz_%data(gradphiz_%x(i),j-1,k:k+1,1,1)) 02484 END FORALL 02485 IF (iE /= 0) THEN 02486 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 02487 q2Ly_%data(q2Ly_%x(i),j,k,1,iE)=q2Ly_%data(q2Ly_%x(i),j,k,1,iE)-hdx*(fz_%data(fz_%x(i),j-1,k,1,1)*gradphiz_%data(gradphiz_%x(i),j-1,k,1,1)+fz_%data(fz_%x(i),j-1,k+1,1,1)*gradphiz_%data(gradphiz_%x(i),j-1,k+1,1,1)) 02488 END FORALL 02489 END IF 02490 END IF 02491 END IF 02492 02493 CALL cons_to_prim_1(q2Ly_%data(q2Ly_%x(i),mB(2,1):mB(2,2),mB(3,1):mB(3,2),1,:)) 02494 IF (lCautious) CALL protect_all(q2Ly_%data(q2Ly_%x(i),mB(2,1):mB(2,2),mB(3,1):mB(3,2),1,:)) 02495 END DO 02496 END IF 02497 IF(istimeshift(index, Info%level, q2Ry, mB)) THEN 02498 DO i=mB(1,1),mB(1,2) 02499 CALL prim_to_cons_2(qRy_%data(qRy_%x(i),mB(2,1):mB(2,2),mB(3,1):mB(3,2),1,:), & 02500 q2Ry_%data(q2Ry_%x(i),mB(2,1):mB(2,2),mB(3,1):mB(3,2),1,:)) 02501 02502 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2),m=1:nSweepFlux) 02503 q2Ry_%data(q2Ry_%x(i),j,k,1,SweepFluxFields(m))=q2Ry_%data(q2Ry_%x(i),j,k,1,SweepFluxFields(m))+(fx_%data(fx_%x(i),j,k,1,SweepFluxFields(m)) - & 02504 fx_%data(fx_%x(i+1),j,k,1,SweepFluxFields(m))) 02505 END FORALL 02506 IF (nDim >= 3) THEN 02507 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2),m=1:nSweepFlux) 02508 q2Ry_%data(q2Ry_%x(i),j,k,1,SweepFluxFields(m))=q2Ry_%data(q2Ry_%x(i),j,k,1,SweepFluxFields(m))+(fz_%data(fz_%x(i),j,k,1,SweepFluxFields(m)) - & 02509 fz_%data(fz_%x(i),j,k+1,1,SweepFluxFields(m))) 02510 END FORALL 02511 END IF 02512 IF (lMHD) THEN 02513 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2),m=1:SweepCons) 02514 q2Ry_%data(q2Ry_%x(i),j,k,1,m)=q2Ry_%data(q2Ry_%x(i),j,k,1,m)+Sy_%data(Sy_%x(i),j,k,1,m) 02515 END FORALL 02516 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 02517 q2Ry_%data(q2Ry_%x(i),j,k,1,iBy)=A2y_%data(A2y_%x(i),j,k,1,1) 02518 END FORALL 02519 IF (nDim >= 3) THEN 02520 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 02521 q2Ry_%data(q2Ry_%x(i),j,k,1,iBz)=q2Ry_%data(q2Ry_%x(i),j,k,1,iBz)+(ctfx_%data(ctfx_%x(i),j,k,1,2)-ctfx_%data(ctfx_%x(i+1),j,k,1,2)) 02522 q2Ry_%data(q2Ry_%x(i),j,k,1,iBx)=q2Ry_%data(q2Ry_%x(i),j,k,1,iBx)+(ctfz_%data(ctfz_%x(i),j,k,1,1)-ctfz_%data(ctfz_%x(i),j,k+1,1,1)) 02523 END FORALL 02524 END IF 02525 END IF 02526 02527 02528 IF (lSelfGravity) THEN 02529 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 02530 q2Ry_%data(q2Ry_%x(i),j,k,1,ivx)=q2Ry_%data(q2Ry_%x(i),j,k,1,ivx)-qdt*Info%q(index+i,j,k,1)*sum(gradphix_%data((/gradphix_%x(i:i+1)/),j,k,1,1)) 02531 END FORALL 02532 IF (iE /= 0) THEN 02533 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 02534 q2Ry_%data(q2Ry_%x(i),j,k,1,iE)=q2Ry_%data(q2Ry_%x(i),j,k,1,iE)-hdx*(fx_%data(fx_%x(i),j,k,1,1)*gradphix_%data(gradphix_%x(i),j,k,1,1)+fx_%data(fx_%x(i+1),j,k,1,1)*gradphix_%data(gradphix_%x(i+1),j,k,1,1)) 02535 END FORALL 02536 END IF 02537 IF (nDim >= 3) THEN 02538 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 02539 q2Ry_%data(q2Ry_%x(i),j,k,1,ivz)=q2Ry_%data(q2Ry_%x(i),j,k,1,ivz)-qdt*Info%q(index+i,j,k,1)*sum(gradphiz_%data(gradphiz_%x(i),j,k:k+1,1,1)) 02540 END FORALL 02541 IF (iE /= 0) THEN 02542 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 02543 q2Ry_%data(q2Ry_%x(i),j,k,1,iE)=q2Ry_%data(q2Ry_%x(i),j,k,1,iE)-hdx*(fz_%data(fz_%x(i),j,k,1,1)*gradphiz_%data(gradphiz_%x(i),j,k,1,1)+fz_%data(fz_%x(i),j,k+1,1,1)*gradphiz_%data(gradphiz_%x(i),j,k+1,1,1)) 02544 END FORALL 02545 END IF 02546 END IF 02547 END IF 02548 02549 02550 02551 CALL cons_to_prim_1(q2Ry_%data(q2Ry_%x(i),mB(2,1):mB(2,2),mB(3,1):mB(3,2),1,:)) 02552 IF (lCautious) CALL protect_all(q2Ry_%data(q2Ry_%x(i),mB(2,1):mB(2,2),mB(3,1):mB(3,2),1,:)) 02553 END DO 02554 END IF 02555 02556 IF(istimeshift(index, Info%level, q2Lz, mB)) THEN 02557 DO i=mB(1,1),mB(1,2) 02558 CALL prim_to_cons_2(qLz_%data(qLz_%x(i),mB(2,1):mB(2,2),mB(3,1):mB(3,2),1,:), & 02559 q2Lz_%data(q2Lz_%x(i),mB(2,1):mB(2,2),mB(3,1):mB(3,2),1,:)) 02560 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2),m=1:nSweepFlux) 02561 q2Lz_%data(q2Lz_%x(i),j,k,1,SweepFluxFields(m))=q2Lz_%data(q2Lz_%x(i),j,k,1,SweepFluxFields(m))+(fx_%data(fx_%x(i),j,k-1,1,SweepFluxFields(m)) - & 02562 fx_%data(fx_%x(i+1),j,k-1,1,SweepFluxFields(m))) & 02563 +(fy_%data(fy_%x(i),j,k-1,1,SweepFluxFields(m))-fy_%data(fy_%x(i),j+1,k-1,1,SweepFluxFields(m))) 02564 END FORALL 02565 IF (lMHD) THEN 02566 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2),m=1:SweepCons) 02567 q2Lz_%data(q2Lz_%x(i),j,k,1,m)=q2Lz_%data(q2Lz_%x(i),j,k,1,m)+Sz_%data(Sz_%x(i),j,k-1,1,m) 02568 END FORALL 02569 02570 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 02571 q2Lz_%data(q2Lz_%x(i),j,k,1,iBz)=A2z_%data(A2z_%x(i),j,k,1,1) 02572 q2Lz_%data(q2Lz_%x(i),j,k,1,iBy)=q2Lz_%data(q2Lz_%x(i),j,k,1,iBy)+(ctfx_%data(ctfx_%x(i),j,k-1,1,1)-ctfx_%data(ctfx_%x(i+1),j,k-1,1,1)) 02573 q2Lz_%data(q2Lz_%x(i),j,k,1,iBx)=q2Lz_%data(q2Lz_%x(i),j,k,1,iBx)+(ctfy_%data(ctfy_%x(i),j,k-1,1,2)-ctfy_%data(ctfy_%x(i),j+1,k-1,1,2)) 02574 END FORALL 02575 END IF 02576 02577 IF (lSelfGravity) THEN 02578 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 02579 q2Lz_%data(q2Lz_%x(i),j,k,1,ivx)=q2Lz_%data(q2Lz_%x(i),j,k,1,ivx)-qdt*Info%q(index+i,j,k-1,1)*sum(gradphix_%data((/gradphix_%x(i:i+1)/),j,k-1,1,1)) 02580 END FORALL 02581 IF (iE /= 0) THEN 02582 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 02583 q2Lz_%data(q2Lz_%x(i),j,k,1,iE)=q2Lz_%data(q2Lz_%x(i),j,k,1,iE)-hdx*(fx_%data(fx_%x(i),j,k-1,1,1)*gradphix_%data(gradphix_%x(i),j,k-1,1,1)+fx_%data(fx_%x(i+1),j,k-1,1,1)*gradphix_%data(gradphix_%x(i+1),j,k-1,1,1)) 02584 END FORALL 02585 END IF 02586 02587 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 02588 q2Lz_%data(q2Lz_%x(i),j,k,1,ivy)=q2Lz_%data(q2Lz_%x(i),j,k,1,ivy)-qdt*Info%q(index+i,j,k-1,1)*sum(gradphiy_%data(gradphiy_%x(i),j:j+1,k-1,1,1)) 02589 END FORALL 02590 IF (iE /= 0) THEN 02591 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 02592 q2Lz_%data(q2Lz_%x(i),j,k,1,iE)=q2Lz_%data(q2Lz_%x(i),j,k,1,iE)-hdx*(fy_%data(fy_%x(i),j,k-1,1,1)*gradphiy_%data(gradphiy_%x(i),j,k-1,1,1)+fy_%data(fy_%x(i),j+1,k-1,1,1)*gradphiy_%data(gradphiy_%x(i),j+1,k-1,1,1)) 02593 END FORALL 02594 END IF 02595 END IF 02596 02597 CALL cons_to_prim_1(q2Lz_%data(q2Lz_%x(i),mB(2,1):mB(2,2),mB(3,1):mB(3,2),1,:)) 02598 IF (lCautious) CALL protect_all(q2Lz_%data(q2Lz_%x(i),mB(2,1):mB(2,2),mB(3,1):mB(3,2),1,:)) 02599 END DO 02600 END IF 02601 IF(istimeshift(index, Info%level, q2Rz, mB)) THEN 02602 DO i=mB(1,1),mB(1,2) 02603 CALL prim_to_cons_2(qRz_%data(qRz_%x(i),mB(2,1):mB(2,2),mB(3,1):mB(3,2),1,:), & 02604 q2Rz_%data(q2Rz_%x(i),mB(2,1):mB(2,2),mB(3,1):mB(3,2),1,:)) 02605 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2),m=1:nSweepFlux) 02606 q2Rz_%data(q2Rz_%x(i),j,k,1,SweepFluxFields(m))=q2Rz_%data(q2Rz_%x(i),j,k,1,SweepFluxFields(m))+& 02607 (fx_%data(fx_%x(i),j,k,1,SweepFluxFields(m))-fx_%data(fx_%x(i+1),j,k,1,SweepFluxFields(m)))+ & 02608 (fy_%data(fy_%x(i),j,k,1,SweepFluxFields(m))-fy_%data(fy_%x(i),j+1,k,1,SweepFluxFields(m))) 02609 END FORALL 02610 IF (lMHD) THEN 02611 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2),m=1:SweepCons) 02612 q2Rz_%data(q2Rz_%x(i),j,k,1,m)=q2Rz_%data(q2Rz_%x(i),j,k,1,m)+Sz_%data(Sz_%x(i),j,k,1,m) 02613 END FORALL 02614 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 02615 q2Rz_%data(q2Rz_%x(i),j,k,1,iBz)=A2z_%data(A2z_%x(i),j,k,1,1) 02616 q2Rz_%data(q2Rz_%x(i),j,k,1,iBy)=q2Rz_%data(q2Rz_%x(i),j,k,1,iBy)+(ctfx_%data(ctfx_%x(i),j,k,1,1)-ctfx_%data(ctfx_%x(i+1),j,k,1,1)) 02617 q2Rz_%data(q2Rz_%x(i),j,k,1,iBx)=q2Rz_%data(q2Rz_%x(i),j,k,1,iBx)+(ctfy_%data(ctfy_%x(i),j,k,1,2)-ctfy_%data(ctfy_%x(i),j+1,k,1,2)) 02618 END FORALL 02619 END IF 02620 IF (lSelfGravity) THEN 02621 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 02622 q2Rz_%data(q2Rz_%x(i),j,k,1,ivx)=q2Rz_%data(q2Rz_%x(i),j,k,1,ivx)-qdt*Info%q(index+i,j,k,1)*sum(gradphix_%data((/gradphix_%x(i:i+1)/),j,k,1,1)) 02623 END FORALL 02624 IF (iE /= 0) THEN 02625 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 02626 q2Rz_%data(q2Rz_%x(i),j,k,1,iE)=q2Rz_%data(q2Rz_%x(i),j,k,1,iE)-hdx*(fx_%data(fx_%x(i),j,k,1,1)*gradphix_%data(gradphix_%x(i),j,k,1,1)+fx_%data(fx_%x(i+1),j,k,1,1)*gradphix_%data(gradphix_%x(i+1),j,k,1,1)) 02627 END FORALL 02628 END IF 02629 02630 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 02631 q2Rz_%data(q2Rz_%x(i),j,k,1,ivy)=q2Rz_%data(q2Rz_%x(i),j,k,1,ivy)-qdt*Info%q(index+i,j,k,1)*sum(gradphiy_%data(gradphiy_%x(i),j:j+1,k,1,1)) 02632 END FORALL 02633 IF (iE /= 0) THEN 02634 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 02635 q2Rz_%data(q2Rz_%x(i),j,k,1,iE)=q2Rz_%data(q2Rz_%x(i),j,k,1,iE)-hdx*(fy_%data(fy_%x(i),j,k,1,1)*gradphiy_%data(gradphiy_%x(i),j,k,1,1)+fy_%data(fy_%x(i),j+1,k,1,1)*gradphiy_%data(gradphiy_%x(i),j+1,k,1,1)) 02636 END FORALL 02637 END IF 02638 END IF 02639 CALL cons_to_prim_1(q2Rz_%data(q2Rz_%x(i),mB(2,1):mB(2,2),mB(3,1):mB(3,2),1,:)) 02640 IF (lCautious) CALL protect_all(q2Rz_%data(q2Rz_%x(i),mB(2,1):mB(2,2),mB(3,1):mB(3,2),1,:)) 02641 END DO 02642 END IF 02643 END SUBROUTINE CTU 02644 02648 SUBROUTINE calc_tracer_fluxes(Info, index) 02649 TYPE(InfoDef) :: Info ! Info structure currently updating 02650 INTEGER :: index ! Current row in q being updated 02651 INTEGER :: i,j,k ! Loop counters 02652 INTEGER :: mB(3,2) ! Bounds of slab to update 02653 REAL(Kind=qPrec) :: dq,sdq,dfmin,u_edge 02654 INTEGER :: m 02655 IF (istimeshift(index, Info%level, adfx, mB)) THEN 02656 DO i=mB(1,1),mB(1,2) 02657 DO j=mB(2,1), mB(2,2) 02658 DO k=mB(3,1), mB(3,2) 02659 DO m=nTracerLo, nTracerHi 02660 dq=half*(beforesweepstep_%data(beforesweepstep_%x(i+1),j,k,1,m)-beforesweepstep_%data(beforesweepstep_%x(i-1),j,k,1,m)) 02661 sdq=sign(1d0,dq) 02662 dfmin=MIN(abs(dq), & 02663 sdq*2d0*(beforesweepstep_%data(beforesweepstep_%x(i),j,k,1,m)-beforesweepstep_%data(beforesweepstep_%x(i-1),j,k,1,m)), & 02664 sdq*2d0*(beforesweepstep_%data(beforesweepstep_%x(i+1),j,k,1,m)-beforesweepstep_%data(beforesweepstep_%x(i),j,k,1,m))) 02665 adfx_%data(adfx_%x(i),j,k,1,m-nTracerLo+1)=sdq*MAX(0d0,dfmin) 02666 END DO 02667 END DO 02668 END DO 02669 END DO 02670 END IF 02671 02672 IF (istimeshift(index, Info%level, adfy, mB)) THEN 02673 DO i=mB(1,1),mB(1,2) 02674 DO j=mB(2,1), mB(2,2) 02675 DO k=mB(3,1), mB(3,2) 02676 DO m=nTracerLo, nTracerHi 02677 dq=half*(beforesweepstep_%data(beforesweepstep_%x(i),j+1,k,1,m)-beforesweepstep_%data(beforesweepstep_%x(i),j-1,k,1,m)) 02678 sdq=sign(1d0,dq) 02679 dfmin=MIN(abs(dq), & 02680 sdq*2d0*(beforesweepstep_%data(beforesweepstep_%x(i),j,k,1,m)-beforesweepstep_%data(beforesweepstep_%x(i),j-1,k,1,m)), & 02681 sdq*2d0*(beforesweepstep_%data(beforesweepstep_%x(i),j+1,k,1,m)-beforesweepstep_%data(beforesweepstep_%x(i),j,k,1,m))) 02682 adfy_%data(adfy_%x(i),j,k,1,m-nTracerLo+1)=sdq*MAX(0d0,dfmin) 02683 END DO 02684 END DO 02685 END DO 02686 END DO 02687 END IF 02688 02689 IF (istimeshift(index, Info%level, adfz, mB)) THEN 02690 DO i=mB(1,1),mB(1,2) 02691 DO j=mB(2,1), mB(2,2) 02692 DO k=mB(3,1), mB(3,2) 02693 DO m=nTracerLo, nTracerHi 02694 dq=half*(beforesweepstep_%data(beforesweepstep_%x(i),j,k+1,1,m)-beforesweepstep_%data(beforesweepstep_%x(i),j,k-1,1,m)) 02695 sdq=sign(1d0,dq) 02696 dfmin=MIN(abs(dq), & 02697 sdq*2d0*(beforesweepstep_%data(beforesweepstep_%x(i),j,k,1,m)-beforesweepstep_%data(beforesweepstep_%x(i),j,k-1,1,m)), & 02698 sdq*2d0*(beforesweepstep_%data(beforesweepstep_%x(i),j,k+1,1,m)-beforesweepstep_%data(beforesweepstep_%x(i),j,k,1,m))) 02699 adfz_%data(adfz_%x(i),j,k,1,m-nTracerLo+1)=sdq*MAX(0d0,dfmin) 02700 END DO 02701 END DO 02702 END DO 02703 END DO 02704 END IF 02705 02706 02707 IF (istime(index, Info%level, f2x, mB)) THEN 02708 DO i=mB(1,1),mB(1,2) 02709 DO j=mB(2,1), mB(2,2) 02710 DO k=mB(3,1), mB(3,2) 02711 DO m=nTracerLO, nTracerHI 02712 u_edge=half*(w2_%data(w2_%x(i),j,k,1,ivx)+w2_%data(w2_%x(i-1),j,k,1,ivx)) 02713 IF (u_edge > 0d0) THEN 02714 f2x_%data(f2x_%x(i),j,k,1,m)=w2_%data(w2_%x(i-1),j,k,1,ivx)* & 02715 (beforesweepstep_%data(beforesweepstep_%x(i-1),j,k,1,m)+half*adfx_%data(adfx_%x(i-1),j,k,1,m+1-nTracerLo)*(1d0-MIN(1d0, u_edge*dtdx))) 02716 ELSEIF (u_edge < 0d0) THEN 02717 f2x_%data(f2x_%x(i),j,k,1,m)=w2_%data(w2_%x(i),j,k,1,ivx)* & 02718 (beforesweepstep_%data(beforesweepstep_%x(i),j,k,1,m)-half*adfx_%data(adfx_%x(i),j,k,1,m+1-nTracerLo)*(1d0-MIN(1d0, -u_edge*dtdx))) 02719 ELSE 02720 f2x_%data(f2x_%x(i),j,k,1,m)=0d0 02721 END IF 02722 END DO 02723 END DO 02724 END DO 02725 END DO 02726 END IF 02727 02728 IF (istime(index, Info%level, f2y, mB)) THEN 02729 DO i=mB(1,1), mB(1,2) 02730 DO j=mB(2,1), mB(2,2) 02731 DO k=mB(3,1), mB(3,2) 02732 DO m=nTracerLO, nTracerHI 02733 u_edge=half*(w2_%data(w2_%x(i),j,k,1,ivy)+w2_%data(w2_%x(i),j-1,k,1,ivy)) 02734 IF (u_edge > 0d0) THEN 02735 f2y_%data(f2y_%x(i),j,k,1,m)=w2_%data(w2_%x(i),j-1,k,1,ivy)* & 02736 (beforesweepstep_%data(beforesweepstep_%x(i),j-1,k,1,m)+half*adfy_%data(adfy_%x(i),j-1,k,1,m+1-nTracerLo)*(1d0-MIN(1d0, u_edge*dtdy))) 02737 ELSEIF (u_edge < 0d0) THEN 02738 f2y_%data(f2y_%x(i),j,k,1,m)=w2_%data(w2_%x(i),j,k,1,ivy)* & 02739 (beforesweepstep_%data(beforesweepstep_%x(i),j,k,1,m)-half*adfy_%data(adfy_%x(i),j,k,1,m+1-nTracerLo)*(1d0-MIN(1d0, -u_edge*dtdy))) 02740 ELSE 02741 f2y_%data(f2y_%x(i),j,k,1,m)=0d0 02742 END IF 02743 END DO 02744 END DO 02745 END DO 02746 END DO 02747 END IF 02748 02749 IF (istime(index, Info%level, f2z, mB)) THEN 02750 DO i=mB(1,1), mB(1,2) 02751 DO j=mB(2,1), mB(2,2) 02752 DO k=mB(3,1), mB(3,2) 02753 DO m=nTracerLO, nTracerHI 02754 u_edge=half*(w2_%data(w2_%x(i),j,k,1,ivz)+w2_%data(w2_%x(i),j,k-1,1,ivz)) 02755 IF (u_edge > 0d0) THEN 02756 f2z_%data(f2z_%x(i),j,k,1,m)=w2_%data(w2_%x(i),j,k-1,1,ivz)* & 02757 (beforesweepstep_%data(beforesweepstep_%x(i),j,k-1,1,m)+half*adfz_%data(adfz_%x(i),j,k-1,1,m+1-nTracerLo)*(1d0-MIN(1d0, u_edge*dtdz))) 02758 ELSEIF (u_edge < 0d0) THEN 02759 f2z_%data(f2z_%x(i),j,k,1,m)=w2_%data(w2_%x(i),j,k,1,ivz)* & 02760 (beforesweepstep_%data(beforesweepstep_%x(i),j,k,1,m)-half*adfz_%data(adfz_%x(i),j,k,1,m+1-nTracerLo)*(1d0-MIN(1d0, -u_edge*dtdz))) 02761 ELSE 02762 f2z_%data(f2z_%x(i),j,k,1,m)=0d0 02763 END IF 02764 END DO 02765 END DO 02766 END DO 02767 END DO 02768 END IF 02769 END SUBROUTINE calc_tracer_fluxes 02770 02774 SUBROUTINE HVisc(Info, index) 02775 TYPE(InfoDef) :: Info ! Info structure currently updating 02776 INTEGER :: index ! Current row in q being updated 02777 INTEGER :: i,j,k ! Loop counters 02778 INTEGER :: mB(3,2) ! Bounds of slab to update 02779 IF (istimeshift(index, Info%level, etax, mB)) THEN 02780 DO i=mB(1,1),mB(1,2) 02781 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 02782 etax_%data(etax_%x(i),j,k,1,1)=half*maxval(abs(SpeedsX_%data(SpeedsX_%x(i),j,k,1,:) - & 02783 SpeedsX_%data(SpeedsX_%x(i-1),j,k,1,:))) 02784 02785 ! etax_%data(etax_%x(i),j,k,1,1)=half*abs(SpeedsX_%data(SpeedsX_%x(i),j,k,1,NrWaves) - & 02786 ! SpeedsX_%data(SpeedsX_%x(i-1),j,k,1,1)) 02787 END FORALL 02788 END DO 02789 END IF 02790 02791 IF (istimeshift(index, Info%level, etay, mB)) THEN 02792 DO i=mB(1,1),mB(1,2) 02793 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 02794 etay_%data(etay_%x(i),j,k,1,1)=half*maxval(abs(SpeedsY_%data(SpeedsY_%x(i),j,k,1,:) - & 02795 SpeedsY_%data(SpeedsY_%x(i),j-1,k,1,:))) 02796 02797 ! etay_%data(etay_%x(i),j,k,1,1)=half*abs(SpeedsY_%data(SpeedsY_%x(i),j,k,1,NrWaves) - & 02798 ! SpeedsY_%data(SpeedsY_%x(i),j-1,k,1,1)) 02799 END FORALL 02800 END DO 02801 END IF 02802 02803 IF (istimeshift(index, Info%level, etaz, mB)) THEN 02804 DO i=mB(1,1),mB(1,2) 02805 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 02806 etaz_%data(etaz_%x(i),j,k,1,1)=half*maxval(abs(SpeedsZ_%data(SpeedsZ_%x(i),j,k,1,:) - & 02807 SpeedsZ_%data(SpeedsZ_%x(i),j,k-1,1,:))) 02808 02809 ! etaz_%data(etaz_%x(i),j,k,1,1)=half*abs(SpeedsZ_%data(SpeedsZ_%x(i),j,k,1,NrWaves) - & 02810 ! SpeedsZ_%data(SpeedsZ_%x(i),j,k-1,1,1)) 02811 02812 END FORALL 02813 END DO 02814 END IF 02815 02816 IF (ViscCD == 1) THEN !just normal viscosity at boundary 02817 IF (istimeshift(index, Info%level, eta2x, mB)) THEN 02818 DO i=mB(1,1),mB(1,2) 02819 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 02820 eta2x_%data(eta2x_%x(i),j,k,1,1) = etax_%data(etax_%x(i),j,k,1,1) 02821 END FORALL 02822 END DO 02823 END IF 02824 IF (istimeshift(index, Info%level, eta2y, mB)) THEN 02825 DO i=mB(1,1),mB(1,2) 02826 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 02827 eta2y_%data(eta2y_%x(i),j,k,1,1) = etay_%data(etay_%x(i),j,k,1,1) 02828 END FORALL 02829 END DO 02830 END IF 02831 IF (istimeshift(index, Info%level, eta2z, mB)) THEN 02832 DO i=mB(1,1),mB(1,2) 02833 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 02834 eta2z_%data(eta2z_%x(i),j,k,1,1) = etaz_%data(etaz_%x(i),j,k,1,1) 02835 END FORALL 02836 END DO 02837 END IF 02838 ELSE IF (ViscCD == 2) THEN !H-viscosity 02839 IF (istimeshift(index, Info%level, eta2x, mB)) THEN 02840 DO i=mB(1,1),mB(1,2) 02841 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 02842 eta2x_%data(eta2x_%x(i),j,k,1,1) = max(etax_%data(etax_%x(i),j,k,1,1), max(maxval(etay_%data(etay_%x(i-1),j:j+1,k,1,1)), & 02843 maxval(etay_%data(etay_%x(i),j:j+1,k,1,1)))) 02844 END FORALL 02845 IF (nDim >= 3) THEN 02846 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 02847 eta2x_%data(eta2x_%x(i),j,k,1,1) = max(eta2x_%data(eta2x_%x(i),j,k,1,1), max(maxval(etaz_%data(etaz_%x(i-1),j,k:k+1,1,1)), & 02848 maxval(etaz_%data(etaz_%x(i),j,k:k+1,1,1)))) 02849 END FORALL 02850 END IF 02851 END DO 02852 END IF 02853 IF (istimeshift(index, Info%level, eta2y, mB)) THEN 02854 DO i=mB(1,1),mB(1,2) 02855 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 02856 eta2y_%data(eta2y_%x(i),j,k,1,1) = max(etay_%data(etay_%x(i),j,k,1,1), max(maxval(etax_%data(etax_%x(i),j-1:j,k,1,1)), & 02857 maxval(etax_%data(etax_%x(i+1),j-1:j,k,1,1)))) 02858 END FORALL 02859 IF (nDim >= 3) THEN 02860 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 02861 eta2y_%data(eta2y_%x(i),j,k,1,1) = max(eta2y_%data(eta2y_%x(i),j,k,1,1), maxval(etaz_%data(etaz_%x(i),j-1:j,k:k+1,1,1))) 02862 END FORALL 02863 END IF 02864 END DO 02865 02866 END IF 02867 IF (istimeshift(index, Info%level, eta2z, mB)) THEN 02868 DO i=mB(1,1),mB(1,2) 02869 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 02870 eta2z_%data(eta2z_%x(i),j,k,1,1) = max(etaz_%data(etaz_%x(i),j,k,1,1), maxval(etay_%data(etay_%x(i),j:j+1,k-1:k,1,1))) 02871 END FORALL 02872 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 02873 eta2z_%data(eta2z_%x(i),j,k,1,1) = max(eta2z_%data(eta2z_%x(i),j,k,1,1), max(maxval(etax_%data(etax_%x(i),j,k-1:k,1,1)), & 02874 maxval(etax_%data(etax_%x(i+1),j,k-1:k,1,1)))) 02875 END FORALL 02876 END DO 02877 END IF 02878 END IF 02879 END SUBROUTINE HVisc 02880 02884 SUBROUTINE calc_final_fluxes(Info, index) 02885 TYPE(InfoDef) :: Info ! Info structure currently updating 02886 INTEGER :: index ! Current row in q being updated 02887 INTEGER :: i,j,k ! Loop counters 02888 INTEGER :: mB(3,2) ! Bounds of slab to update 02889 INTEGER :: m 02890 IF (istimeshift(index, Info%level, f2x, mB)) THEN 02891 IF (ViscCD > 0) THEN 02892 DO i=mB(1,1), mB(1,2) 02893 DO j=mB(2,1), mB(2,2) 02894 DO k=mB(3,1), mB(3,2) 02895 maxsolverspeed(Info%level)=max(maxsolverspeed(Info%level), calc_flux_x(q2Lx_%data(q2Lx_%x(i),j,k,1,1:SweepCons), q2Rx_%data(q2Rx_%x(i),j,k,1,1:SweepCons), & 02896 f2x_%data(f2x_%x(i),j,k,1,1:SweepCons), eta2x_%data(eta2x_%x(i),j,k,1,1))) 02897 END DO 02898 END DO 02899 END DO 02900 ELSE 02901 DO i=mB(1,1), mB(1,2) 02902 DO j=mB(2,1), mB(2,2) 02903 DO k=mB(3,1), mB(3,2) 02904 maxsolverspeed(Info%level)=max(maxsolverspeed(Info%level), calc_flux_x(q2Lx_%data(q2Lx_%x(i),j,k,1,1:SweepCons), q2Rx_%data(q2Rx_%x(i),j,k,1,1:SweepCons), & 02905 f2x_%data(f2x_%x(i),j,k,1,1:SweepCons))) 02906 END DO 02907 END DO 02908 END DO 02909 END IF 02910 DO i=mB(1,1),mB(1,2) 02911 DO m=1,nFlux 02912 f2x_%data(f2x_%x(i),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,FluxFields(m)) = & 02913 f2x_%data(f2x_%x(i),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,FluxFields(m))*dtdx 02914 END DO 02915 END DO 02916 END IF 02917 IF (istimeshift(index, Info%level, f2y, mB)) THEN 02918 IF (ViscCD > 0) THEN 02919 DO i=mB(1,1), mB(1,2) 02920 DO j=mB(2,1),mB(2,2) 02921 DO k=mB(3,1),mB(3,2) 02922 maxsolverspeed(Info%level)=max(maxsolverspeed(Info%level), calc_flux_y(q2Ly_%data(q2Ly_%x(i),j,k,1,1:SweepCons), q2Ry_%data(q2Ry_%x(i),j,k,1,1:SweepCons), & 02923 f2y_%data(f2y_%x(i),j,k,1,1:SweepCons), eta2y_%data(eta2y_%x(i),j,k,1,1))) 02924 END DO 02925 END DO 02926 END DO 02927 ELSE 02928 DO i=mB(1,1), mB(1,2) 02929 DO j=mB(2,1),mB(2,2) 02930 DO k=mB(3,1),mB(3,2) 02931 maxsolverspeed(Info%level)=max(maxsolverspeed(Info%level), calc_flux_y(q2Ly_%data(q2Ly_%x(i),j,k,1,1:SweepCons), q2Ry_%data(q2Ry_%x(i),j,k,1,1:SweepCons), & 02932 f2y_%data(f2y_%x(i),j,k,1,1:SweepCons))) 02933 END DO 02934 END DO 02935 END DO 02936 END IF 02937 DO i=mB(1,1),mB(1,2) 02938 DO m=1,nFlux 02939 f2y_%data(f2y_%x(i),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,FluxFields(m)) = & 02940 f2y_%data(f2y_%x(i),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,FluxFields(m))*dtdy 02941 END DO 02942 02943 END DO 02944 END IF 02945 IF (istimeshift(index, Info%level, f2z, mB)) THEN 02946 IF (ViscCD > 0) THEN 02947 DO i=mB(1,1), mB(1,2) 02948 DO j=mB(2,1),mB(2,2) 02949 DO k=mB(3,1),mB(3,2) 02950 maxsolverspeed(Info%level)=max(maxsolverspeed(Info%level), calc_flux_z(q2Lz_%data(q2Lz_%x(i),j,k,1,1:SweepCons), q2Rz_%data(q2Rz_%x(i),j,k,1,1:SweepCons), & 02951 f2z_%data(f2z_%x(i),j,k,1,1:SweepCons), eta2z_%data(eta2z_%x(i),j,k,1,1))) 02952 END DO 02953 END DO 02954 END DO 02955 ELSE 02956 DO i=mB(1,1), mB(1,2) 02957 DO j=mB(2,1),mB(2,2) 02958 DO k=mB(3,1),mB(3,2) 02959 maxsolverspeed(Info%level)=max(maxsolverspeed(Info%level), calc_flux_z(q2Lz_%data(q2Lz_%x(i),j,k,1,1:SweepCons), q2Rz_%data(q2Rz_%x(i),j,k,1,1:SweepCons), & 02960 f2z_%data(f2z_%x(i),j,k,1,1:SweepCons))) 02961 END DO 02962 END DO 02963 END DO 02964 END IF 02965 02966 DO i=mB(1,1),mB(1,2) 02967 DO m=1,nFlux 02968 f2z_%data(f2z_%x(i),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,FluxFields(m)) = & 02969 f2z_%data(f2z_%x(i),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,FluxFields(m))*dtdz 02970 END DO 02971 END DO 02972 END IF 02973 END SUBROUTINE calc_final_fluxes 02974 02978 SUBROUTINE calc_final_emf(Info, index) 02979 TYPE(InfoDef) :: Info ! Info structure currently updating 02980 INTEGER :: index ! Current row in q being updated 02981 INTEGER :: i,j,k ! Loop counters 02982 INTEGER :: mB(3,2) ! Bounds of slab to update 02983 INTEGER :: mS(3,2) ! Bounds of slab for storing 02984 REAL (kind=qPrec) :: r 02985 IF (istimeshift(index, Info%level, e2x_bar, mB)) THEN 02986 DO i=mB(1,1),mB(1,2) 02987 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 02988 e2x_bar_%data(e2x_bar_%x(i),j,k,1,1) = & 02989 w2_%data(w2_%x(i),j,k,1,ivz)*w2_%data(w2_%x(i),j,k,1,iBy)-w2_%data(w2_%x(i),j,k,1,ivy)*w2_%data(w2_%x(i),j,k,1,iBz) 02990 END FORALL 02991 END DO 02992 END IF 02993 IF (istimeshift(index, Info%level, e2y_bar, mB)) THEN 02994 DO i=mB(1,1),mB(1,2) 02995 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 02996 e2y_bar_%data(e2y_bar_%x(i),j,k,1,1) = & 02997 w2_%data(w2_%x(i),j,k,1,ivx)*w2_%data(w2_%x(i),j,k,1,iBz)-w2_%data(w2_%x(i),j,k,1,ivz)*w2_%data(w2_%x(i),j,k,1,iBx) 02998 END FORALL 02999 END DO 03000 END IF 03001 IF (istimeshift(index, Info%level, e2z_bar, mB)) THEN 03002 DO i=mB(1,1),mB(1,2) 03003 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 03004 e2z_bar_%data(e2z_bar_%x(i),j,k,1,1) = & 03005 w2_%data(w2_%x(i),j,k,1,ivy)*w2_%data(w2_%x(i),j,k,1,iBx)-w2_%data(w2_%x(i),j,k,1,ivx)*w2_%data(w2_%x(i),j,k,1,iBy) 03006 END FORALL 03007 END DO 03008 END IF 03009 IF (istimeshift(index, Info%level, e2x, mB)) THEN 03010 DO i=mB(1,1),mB(1,2) 03011 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 03012 e2x_%data(e2x_%x(i),j,k,1,1)= & 03013 dtdx*upwinded_emf(f2z_%data(f2z_%x(i), j-1:j,k, 1, iBy),-f2y_%data(f2y_%x(i), j,k-1:k, 1, iBz),& 03014 e2x_bar_%data(e2x_bar_%x(i),j-1:j,k-1:k,1,1), & 03015 f2y_%data(f2y_%x(i),j,k-1:k,1,1),f2z_%data(f2z_%x(i),j-1:j,k,1,1)) 03016 END FORALL 03017 END DO 03018 IF (lStressTest) THEN 03019 DO i=mB(1,1),mB(1,2) 03020 CALL Randomize(e2x_%data(e2x_%x(i),mB(2,1):mB(2,2),mB(3,1):mB(3,2),1,1:1)) 03021 END DO 03022 END IF 03023 mS(2:3,:)=mB(2:3,:) 03024 mS(1,:)=index+mB(1,:) 03025 CALL StoreEmfs(Info, mS, 1, e2x_%data(e2x_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2),mB(3,1):mB(3,2),1,1)) 03026 END IF 03027 IF (istimeshift(index, Info%level, e2y, mB)) THEN 03028 DO i=mB(1,1),mB(1,2) 03029 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 03030 e2y_%data(e2y_%x(i),j,k,1,1)=dtdx*upwinded_emf(f2x_%data(f2x_%x(i), j,k-1:k, 1, iBz), - & 03031 (/f2z_%data(f2z_%x(i-1), j,k,1,iBx), f2z_%data(f2z_%x(i), j,k,1,iBx)/), & 03032 reshape((/e2y_bar_%data(e2y_bar_%x(i-1),j,k-1:k,1,1),e2y_bar_%data(e2y_bar_%x(i),j,k-1:k,1,1)/),(/2,2/)), & 03033 (/f2z_%data(f2z_%x(i-1),j,k,1,1),f2z_%data(f2z_%x(i),j,k,1,1)/),f2x_%data(f2x_%x(i),j,k-1:k,1,1)) 03034 END FORALL 03035 END DO 03036 IF (lStressTest) THEN 03037 DO i=mB(1,1), mB(1,2) 03038 CALL Randomize(e2y_%data(e2y_%x(i),mB(2,1):mB(2,2),mB(3,1):mB(3,2),1,1:1)) 03039 END DO 03040 END IF 03041 mS(2:3,:)=mB(2:3,:) 03042 mS(1,:)=index+mB(1,:) 03043 CALL StoreEmfs(Info, mS, 2, e2y_%data(e2y_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2),mB(3,1):mB(3,2), 1, 1)) 03044 END IF 03045 IF (istimeshift(index, Info%level, e2z, mB)) THEN 03046 IF (iCylindrical == NoCyl) THEN 03047 DO i=mB(1,1),mB(1,2) 03048 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 03049 e2z_%data(e2z_%x(i), j, k, 1,1)=& 03050 dtdx*upwinded_emf((/f2y_%data(f2y_%x(i-1), j,k, 1, iBx),f2y_%data(f2y_%x(i), j,k, 1, iBx)/), - & 03051 f2x_%data(f2x_%x(i), j-1:j,k, 1, iBy), & 03052 transpose(reshape((/e2z_bar_%data(e2z_bar_%x(i-1),j-1:j,k,1,1), e2z_bar_%data(e2z_bar_%x(i),j-1:j,k,1,1)/),(/2,2/))), & 03053 f2x_%data(f2x_%x(i),j-1:j,k,1,1),(/f2y_%data(f2y_%x(i-1),j,k,1,1),f2y_%data(f2y_%x(i),j,k,1,1)/)) 03054 END FORALL 03055 END DO 03056 ELSE 03057 r=Info%xBounds(1,1)+(index+i-1)*dx 03058 DO i=mB(1,1),mB(1,2) 03059 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 03060 e2z_%data(e2z_%x(i),j,k,1,1)=r*& 03061 dtdx*upwinded_emf((/f2y_%data(f2y_%x(i-1), j,k, 1, iBx),f2y_%data(f2y_%x(i), j,k, 1, iBx)/), - & 03062 f2x_%data(f2x_%x(i), j-1:j,k, 1, iBy), & 03063 transpose(reshape((/e2z_bar_%data(e2z_bar_%x(i-1),j-1:j,k,1,1), e2z_bar_%data(e2z_bar_%x(i),j-1:j,k,1,1)/),(/2,2/))), & 03064 f2x_%data(f2x_%x(i),j-1:j,k,1,1),(/f2y_%data(f2y_%x(i-1),j,k,1,1),f2y_%data(f2y_%x(i),j,k,1,1)/)) 03065 END FORALL 03066 END DO 03067 END IF 03068 IF (lStressTest) THEN 03069 DO i=mB(1,1),mB(1,2) 03070 CALL Randomize(e2z_%data(e2z_%x(i),mB(2,1):mB(2,2),mB(3,1):mB(3,2),1,1:1)) 03071 END DO 03072 END IF 03073 mS(2:3,:)=mB(2:3,:) 03074 mS(1,:)=index+mB(1,:) 03075 CALL StoreEmfs(Info, mS, 3, e2z_%data(e2z_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2),mB(3,1):mB(3,2),1,1)) 03076 END IF 03077 END SUBROUTINE calc_final_emf 03078 03082 SUBROUTINE update_final_fluxes(Info, index) 03083 TYPE(InfoDef) :: Info ! Info structure currently updating 03084 INTEGER :: index ! Current row in q being updated 03085 INTEGER :: i,j,k ! Loop counters 03086 INTEGER :: mB(3,2) ! Bounds of slab to update 03087 REAL(KIND=qPREC) :: rho, rho_min, rho_max 03088 LOGICAL :: mask(4) 03089 LOGICAL :: lCheck 03090 INTEGER :: l 03091 ! The emf components of the fluxes (ie f2x) in MHD don't get multiplied by dtdx - but instead are stored in ctf2x 03092 IF (lApplyDiffusion) THEN 03093 03094 IF (istimeshift(index, Info%level, cornerdiv, mB)) THEN 03095 03096 IF (nDim == 1) THEN 03097 DO i=mB(1,1), mB(1,2) 03098 DO j=mB(2,1), mB(2,2) 03099 DO k=mB(3,1), mB(3,2) 03100 03101 cornerdiv_%data(cornerdiv_%x(i),j,k,1,1)= (w_%data(w_%x(i),j,k,1,imom(1)) - w_%data(w_%x(i-1),j,k,1,imom(1))) 03102 END DO 03103 END DO 03104 END DO 03105 03106 ELSEIF (nDim == 2) THEN 03107 DO i=mB(1,1), mB(1,2) 03108 DO j=mB(2,1), mB(2,2) 03109 DO k=mB(3,1), mB(3,2) 03110 cornerdiv_%data(cornerdiv_%x(i),j,k,1,1)= .5d0*( & 03111 ((w_%data(w_%x(i),j-1,k,1,imom(1)) - w_%data(w_%x(i-1),j-1,k,1,imom(1))) + & 03112 (w_%data(w_%x(i),j,k,1,imom(1)) - w_%data(w_%x(i-1),j,k,1,imom(1)))) + & 03113 ((w_%data(w_%x(i-1),j,k,1,imom(2)) - w_%data(w_%x(i-1),j-1,k,1,imom(2))) + & 03114 (w_%data(w_%x(i),j,k,1,imom(2)) - w_%data(w_%x(i),j-1,k,1,imom(2))))) 03115 END DO 03116 END DO 03117 END DO 03118 ELSE 03119 DO i=mB(1,1), mB(1,2) 03120 DO j=mB(2,1), mB(2,2) 03121 DO k=mB(3,1), mB(3,2) 03122 cornerdiv_%data(cornerdiv_%x(i),j,k,1,1)= .25d0*( & 03123 (((w_%data(w_%x(i),j-1,k-1,1,imom(1)) - w_%data(w_%x(i-1),j-1,k-1,1,imom(1))) + & 03124 (w_%data(w_%x(i),j,k-1,1,imom(1)) - w_%data(w_%x(i-1),j,k-1,1,imom(1)))) + & 03125 ((w_%data(w_%x(i),j-1,k,1,imom(1)) - w_%data(w_%x(i-1),j-1,k,1,imom(1))) + & 03126 (w_%data(w_%x(i),j,k,1,imom(1)) - w_%data(w_%x(i-1),j,k,1,imom(1))))) + & 03127 (((w_%data(w_%x(i-1),j,k-1,1,imom(2)) - w_%data(w_%x(i-1),j-1,k-1,1,imom(2))) + & 03128 (w_%data(w_%x(i),j,k-1,1,imom(2)) - w_%data(w_%x(i),j-1,k-1,1,imom(2)))) + & 03129 ((w_%data(w_%x(i-1),j,k,1,imom(2)) - w_%data(w_%x(i-1),j-1,k,1,imom(2))) + & 03130 (w_%data(w_%x(i),j,k,1,imom(2)) - w_%data(w_%x(i),j-1,k,1,imom(2))))) + & 03131 (((w_%data(w_%x(i-1),j-1,k,1,imom(3)) - w_%data(w_%x(i-1),j-1,k-1,1,imom(3))) + & 03132 (w_%data(w_%x(i),j-1,k,1,imom(3)) - w_%data(w_%x(i),j-1,k-1,1,imom(3)))) + & 03133 ((w_%data(w_%x(i-1),j,k,1,imom(3)) - w_%data(w_%x(i-1),j,k-1,1,imom(3))) + & 03134 (w_%data(w_%x(i),j,k,1,imom(3)) - w_%data(w_%x(i),j,k-1,1,imom(3)))))) 03135 END DO 03136 END DO 03137 END DO 03138 END IF 03139 END IF 03140 END IF 03141 03142 IF (istime(index, Info%level, f2x, mB)) THEN 03143 IF (lStressTest) THEN 03144 DO i=mB(1,1), mB(1,2) 03145 CALL Randomize(f2x_%data(f2x_%x(i),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,:)) 03146 END DO 03147 END IF 03148 IF (lApplyDiffusion) THEN 03149 DO i=mB(1,1), mB(1,2) 03150 DO j=mB(2,1),mB(2,2) 03151 DO k=mB(3,1),mB(3,2) 03152 IF (nDim == 1) THEN 03153 f2x_%data(f2x_%x(i),j,k,1,FluxFields) = f2x_%data(f2x_%x(i),j,k,1,FluxFields) + & 03154 dtdx*DIFF_ALPHA*max(0d0,-(cornerdiv_%data(cornerdiv_%x(i),j,k,1,1)))*( & 03155 Info%q(index+i-1,j,k,FluxFields) - & 03156 Info%q(index+i,j,k,FluxFields)) 03157 03158 ELSEIF (nDim == 2) THEN 03159 03160 f2x_%data(f2x_%x(i),j,k,1,FluxFields) = f2x_%data(f2x_%x(i),j,k,1,FluxFields) + & 03161 dtdx*DIFF_ALPHA*max(0d0,-.5d0*(cornerdiv_%data(cornerdiv_%x(i),j,k,1,1)+cornerdiv_%data(cornerdiv_%x(i),j+1,k,1,1)))*( & 03162 Info%q(index+i-1,j,k,FluxFields) - & 03163 Info%q(index+i,j,k,FluxFields)) 03164 ELSE 03165 f2x_%data(f2x_%x(i),j,k,1,FluxFields) = f2x_%data(f2x_%x(i),j,k,1,FluxFields) + & 03166 dtdx*DIFF_ALPHA*max(0d0,-.25d0*(sum(cornerdiv_%data(cornerdiv_%x(i),j,k:k+1,1,1))+sum(cornerdiv_%data(cornerdiv_%x(i),j+1,k:k+1,1,1))))*( & 03167 Info%q(index+i-1,j,k,FluxFields) - & 03168 Info%q(index+i,j,k,FluxFields)) 03169 03170 END IF 03171 END DO 03172 END DO 03173 END DO 03174 END IF 03175 03176 IF (lApplyLOF) THEN 03177 DO i=mB(1,1),mB(1,2) 03178 DO j=mB(2,1),mB(2,2) 03179 DO k=mB(3,1),mB(3,2) 03180 lCheck = (limiter_y_%data(limiter_y_%x(i),j,k,1,1) == 1 .OR. limiter_y_%data(limiter_y_%x(i-1),j,k,1,1) == 1) 03181 IF (.NOT. lCheck .AND. nDim == 3) lCheck = (limiter_z_%data(limiter_z_%x(i),j,k,1,1) == 1 .OR. limiter_z_%data(limiter_z_%x(i-1),j,k,1,1) == 1) 03182 IF (lCheck) THEN 03183 rho=half*(Info%q(index+i,j,k,1)+Info%q(index+i-1,j,k,1)) 03184 rho_max=rho*(1d0+1d-6) 03185 rho_min=rho*(1d0-1d-6) 03186 DO l=1,4 03187 IF (Info%q(index+i-3+l,j,k,1) > rho_max) THEN 03188 mask(l)=.true. 03189 ELSEIF (Info%q(index+i-3+l,j,k,1) < rho_min) THEN 03190 mask(l)=.false. 03191 ELSE 03192 mask=.false. 03193 exit 03194 END IF 03195 END DO 03196 IF (ALL(mask .eqv. (/.true.,.false.,.true.,.false./)) .OR. ALL(mask .eqv. (/.false.,.true.,.false.,.true./))) THEN 03197 f2x_%data(f2x_%x(i),j,k,1,FluxFields) = f2x_%data(f2x_%x(i),j,k,1,FluxFields) - LOF_ALPHA*( & 03198 Info%q(index+i,j,k,FluxFields) - & 03199 Info%q(index+i-1,j,k,FluxFields)) 03200 END IF 03201 END IF 03202 END DO 03203 END DO 03204 END DO 03205 END IF 03206 03207 END IF 03208 03209 IF (istime(index, Info%level, f2y, mB)) THEN 03210 IF (lStressTest) THEN 03211 DO i=mB(1,1), mB(1,2) 03212 CALL Randomize(f2y_%data(f2y_%x(i),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,:)) 03213 END DO 03214 END IF 03215 03216 IF (lApplyDiffusion) THEN 03217 DO i=mB(1,1), mB(1,2) 03218 DO j=mB(2,1),mB(2,2) 03219 DO k=mB(3,1),mB(3,2) 03220 IF (nDim == 2) THEN 03221 f2y_%data(f2y_%x(i),j,k,1,FluxFields) = f2y_%data(f2y_%x(i),j,k,1,FluxFields) + & 03222 dtdy*DIFF_ALPHA*max(0d0,-.5d0*(cornerdiv_%data(cornerdiv_%x(i),j,k,1,1)+cornerdiv_%data(cornerdiv_%x(i+1),j,k,1,1)))*( & 03223 Info%q(index+i,j-1,k,FluxFields) - & 03224 Info%q(index+i,j,k,FluxFields)) 03225 ELSE 03226 f2y_%data(f2y_%x(i),j,k,1,FluxFields) = f2y_%data(f2y_%x(i),j,k,1,FluxFields) + & 03227 dtdy*DIFF_ALPHA*max(0d0,-.25d0*(sum(cornerdiv_%data(cornerdiv_%x(i),j,k:k+1,1,1))+sum(cornerdiv_%data(cornerdiv_%x(i+1),j,k:k+1,1,1))))*( & 03228 Info%q(index+i,j-1,k,FluxFields) - & 03229 Info%q(index+i,j,k,FluxFields)) 03230 03231 END IF 03232 END DO 03233 END DO 03234 END DO 03235 END IF 03236 03237 IF (LApplyLOF) THEN 03238 DO i=mB(1,1),mB(1,2) 03239 DO j=mB(2,1),mB(2,2) 03240 DO k=mB(3,1),mB(3,2) 03241 lCheck = (limiter_x_%data(limiter_x_%x(i),j,k,1,1) == 1 .OR. limiter_x_%data(limiter_x_%x(i),j-1,k,1,1) == 1) 03242 IF (.NOT. lCheck .AND. nDim == 3) lCheck = (limiter_z_%data(limiter_z_%x(i),j,k,1,1) == 1 .OR. limiter_z_%data(limiter_z_%x(i),j-1,k,1,1) == 1) 03243 IF (lCheck) THEN 03244 rho=half*(Info%q(index+i,j,k,1)+Info%q(index+i,j-1,k,1)) 03245 rho_max=rho*(1d0+1d-6) 03246 rho_min=rho*(1d0-1d-6) 03247 DO l=1,4 03248 IF (Info%q(index+i,j-3+l,k,1) > rho_max) THEN 03249 mask(l)=.true. 03250 ELSEIF (Info%q(index+i,j-3+l,k,1) < rho_min) THEN 03251 mask(l)=.false. 03252 ELSE 03253 mask=.false. 03254 exit 03255 END IF 03256 END DO 03257 IF (ALL(mask .eqv. (/.true.,.false.,.true.,.false./)) .OR. ALL(mask .eqv. (/.false.,.true.,.false.,.true./))) THEN 03258 f2y_%data(f2y_%x(i),j,k,1,FluxFields) = f2y_%data(f2y_%x(i),j,k,1,FluxFields) - LOF_ALPHA*( & 03259 Info%q(index+i,j,k,FluxFields) - & 03260 Info%q(index+i,j-1,k,FluxFields)) 03261 END IF 03262 END IF 03263 END DO 03264 END DO 03265 END DO 03266 END IF 03267 END IF 03268 IF (istime(index, Info%level, f2z, mB)) THEN 03269 ! f2z_%data(f2z_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,SweepCons+1:)=f2z_%data(f2z_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,SweepCons+1:)*dtdz 03270 IF (lStressTest) THEN 03271 DO i=mB(1,1), mB(1,2) 03272 CALL Randomize(f2z_%data(f2z_%x(i),mB(2,1):mB(2,2), mB(3,1):mB(3,2),1,:)) 03273 END DO 03274 END IF 03275 03276 IF (lApplyDiffusion) THEN 03277 DO i=mB(1,1), mB(1,2) 03278 DO j=mB(2,1),mB(2,2) 03279 DO k=mB(3,1),mB(3,2) 03280 f2z_%data(f2z_%x(i),j,k,1,FluxFields) = f2z_%data(f2z_%x(i),j,k,1,FluxFields) + & 03281 dtdz*DIFF_ALPHA*max(0d0,-.25d0*(sum(cornerdiv_%data(cornerdiv_%x(i),j:j+1,k,1,1))+sum(cornerdiv_%data(cornerdiv_%x(i+1),j:j+1,k,1,1))))*( & 03282 Info%q(index+i,j,k-1,FluxFields) - & 03283 Info%q(index+i,j,k,FluxFields)) 03284 03285 END DO 03286 END DO 03287 END DO 03288 END IF 03289 03290 IF (lApplyLOF) THEN 03291 DO i=mB(1,1),mB(1,2) 03292 DO j=mB(2,1),mB(2,2) 03293 DO k=mB(3,1),mB(3,2) 03294 lCheck = (limiter_x_%data(limiter_x_%x(i),j,k,1,1) == 1 .OR. limiter_x_%data(limiter_x_%x(i-1),j,k,1,1) == 1) 03295 IF (.NOT. lCheck) lCheck = (limiter_y_%data(limiter_y_%x(i),j,k,1,1) == 1 .OR. limiter_y_%data(limiter_y_%x(i),j-1,k,1,1) == 1) 03296 IF (lCheck) THEN 03297 rho=half*(Info%q(index+i,j,k,1)+Info%q(index+i,j,k-1,1)) 03298 rho_max=rho*(1d0+1d-6) 03299 rho_min=rho*(1d0-1d-6) 03300 DO l=1,4 03301 IF (Info%q(index+i,j,k-3+l,1) > rho_max) THEN 03302 mask(l)=.true. 03303 ELSEIF (Info%q(index+i,j,k-3+l,1) < rho_min) THEN 03304 mask(l)=.false. 03305 ELSE 03306 mask=.false. 03307 exit 03308 END IF 03309 END DO 03310 IF (ALL(mask .eqv. (/.true.,.false.,.true.,.false./)) .OR. ALL(mask .eqv. (/.false.,.true.,.false.,.true./))) THEN 03311 f2z_%data(f2z_%x(i),j,k,1,FluxFields) = f2z_%data(f2z_%x(i),j,k,1,FluxFields) - LOF_ALPHA*( & 03312 Info%q(index+i,j,k,FluxFields) - & 03313 Info%q(index+i,j,k-1,FluxFields)) 03314 END IF 03315 END IF 03316 END DO 03317 END DO 03318 END DO 03319 END IF 03320 03321 END IF 03322 03323 IF (istimeshift(index, Info%level, ctf2x, mB)) THEN 03324 DO i=mB(1,1),mB(1,2) 03325 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 03326 ctf2x_%data(ctf2x_%x(i),j,k,1,1)=dtdx*f2x_%data(f2x_%x(i),j,k,1,iBy) 03327 ctf2x_%data(ctf2x_%x(i),j,k,1,2)=dtdx*f2x_%data(f2x_%x(i),j,k,1,iBz) 03328 END FORALL 03329 END DO 03330 END IF 03331 IF (istimeshift(index, Info%level, ctf2y, mB)) THEN 03332 DO i=mB(1,1),mB(1,2) 03333 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 03334 ctf2y_%data(ctf2y_%x(i),j,k,1,1)=dtdy*f2y_%data(f2y_%x(i),j,k,1,iBz) 03335 ctf2y_%data(ctf2y_%x(i),j,k,1,2)=dtdy*f2y_%data(f2y_%x(i),j,k,1,iBx) 03336 END FORALL 03337 END DO 03338 END IF 03339 IF (istimeshift(index, Info%level, ctf2z, mB)) THEN 03340 DO i=mB(1,1),mB(1,2) 03341 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 03342 ctf2z_%data(ctf2z_%x(i),j,k,1,1)=dtdz*f2z_%data(f2z_%x(i),j,k,1,iBx) 03343 ctf2z_%data(ctf2z_%x(i),j,k,1,2)=dtdz*f2z_%data(f2z_%x(i),j,k,1,iBy) 03344 END FORALL 03345 END DO 03346 END IF 03347 03348 03349 IF (lSelfGravity) THEN 03350 IF (nDim == 1) THEN 03351 IF (istime(index, Info%level, f2x, mB)) THEN 03352 DO i=mB(1,1),mB(1,2) 03353 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 03354 f2x_%data(f2x_%x(i),j,k,1,ivx) = f2x_%data(f2x_%x(i),j,k,1,ivx) + & 03355 dtdx*(.125d0/Pi/ScaleGrav*gradphix_%data(gradphix_%x(i),j,k,1,1)**2+half*mean_density*(Info%q(index+i,j,k,iPhiGas)+ Info%q(index+i-1,j,k,iPhiGas))) 03356 END FORALL 03357 END DO 03358 END IF 03359 ELSEIF (nDim == 2) THEN 03360 IF (istime(index, Info%level, f2x, mB)) THEN 03361 03362 DO i=mB(1,1),mB(1,2) 03363 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 03364 f2x_%data(f2x_%x(i),j,k,1,ivx) = f2x_%data(f2x_%x(i),j,k,1,ivx) + dtdx*(.125d0/Pi/ScaleGrav*& 03365 (gradphix_%data(gradphix_%x(i),j,k,1,1)**2-(.25d0*sum(gradphiy_%data((/gradphiy_%x(i-1:i)/),j:j+1,k,1,1)))**2)+& 03366 half*mean_density*SUM(Info%q(index+i-1:index+i,j,k,iPhiGas))) 03367 f2x_%data(f2x_%x(i),j,k,1,ivy) = f2x_%data(f2x_%x(i),j,k,1,ivy) + dtdx*(.25d0/Pi/ScaleGrav*& 03368 (gradphix_%data(gradphix_%x(i),j,k,1,1)*.25d0*sum(gradphiy_%data((/gradphiy_%x(i-1:i)/),j:j+1,k,1,1)))) 03369 END FORALL 03370 END DO 03371 END IF 03372 IF (istime(index, Info%level, f2y, mB)) THEN 03373 DO i=mB(1,1),mB(1,2) 03374 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 03375 f2y_%data(f2y_%x(i),j,k,1,ivy) = f2y_%data(f2y_%x(i),j,k,1,ivy) + dtdx*(.125d0/Pi/ScaleGrav*& 03376 (gradphiy_%data(gradphiy_%x(i),j,k,1,1)**2-(.25d0*sum(gradphix_%data((/gradphix_%x(i:i+1)/),j-1:j,k,1,1)))**2)+& 03377 half*mean_density*SUM(Info%q(index+i,j-1:j,k,iPhiGas))) 03378 f2y_%data(f2y_%x(i),j,k,1,ivx) = f2y_%data(f2y_%x(i),j,k,1,ivx) + dtdx*(.25d0/Pi/ScaleGrav*& 03379 (gradphiy_%data(gradphiy_%x(i),j,k,1,1)*.25d0*sum(gradphix_%data((/gradphix_%x(i:i+1)/),j-1:j,k,1,1)))) 03380 END FORALL 03381 END DO 03382 END IF 03383 ELSE! nDim == 3 03384 IF (istime(index, Info%level, f2x, mB)) THEN 03385 DO i=mB(1,1),mB(1,2) 03386 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 03387 f2x_%data(f2x_%x(i),j,k,1,ivx) = f2x_%data(f2x_%x(i),j,k,1,ivx) + dtdx*(.125d0/Pi/ScaleGrav*& 03388 (gradphix_%data(gradphix_%x(i),j,k,1,1)**2-(.25d0*sum(gradphiy_%data((/gradphiy_%x(i-1:i)/),j:j+1,k,1,1)))**2-(.25d0*sum(gradphiz_%data((/gradphiz_%x(i-1:i)/),j,k:k+1,1,1)))**2)+& 03389 half*mean_density*SUM(Info%q(index+i-1:index+i,j,k,iPhiGas))) 03390 f2x_%data(f2x_%x(i),j,k,1,ivy) = f2x_%data(f2x_%x(i),j,k,1,ivy) + dtdx*(.25d0/Pi/ScaleGrav*& 03391 (gradphix_%data(gradphix_%x(i),j,k,1,1)*.25d0*sum(gradphiy_%data((/gradphiy_%x(i-1:i)/),j:j+1,k,1,1)))) 03392 f2x_%data(f2x_%x(i),j,k,1,ivz) = f2x_%data(f2x_%x(i),j,k,1,ivz) + dtdx*(.25d0/Pi/ScaleGrav*& 03393 (gradphix_%data(gradphix_%x(i),j,k,1,1)*.25d0*sum(gradphiz_%data((/gradphiz_%x(i-1:i)/),j,k:k+1,1,1)))) 03394 END FORALL 03395 END DO 03396 END IF 03397 IF (istime(index, Info%level, f2y, mB)) THEN 03398 DO i=mB(1,1),mB(1,2) 03399 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 03400 f2y_%data(f2y_%x(i),j,k,1,ivy) = f2y_%data(f2y_%x(i),j,k,1,ivy) + dtdx*(.125d0/Pi/ScaleGrav*& 03401 (gradphiy_%data(gradphiy_%x(i),j,k,1,1)**2-(.25d0*sum(gradphix_%data((/gradphix_%x(i:i+1)/),j-1:j,k,1,1)))**2-(.25d0*sum(gradphiz_%data(gradphiz_%x(i),j-1:j,k:k+1,1,1)))**2)+& 03402 half*mean_density*SUM(Info%q(index+i,j-1:j,k,iPhiGas))) 03403 f2y_%data(f2y_%x(i),j,k,1,ivx) = f2y_%data(f2y_%x(i),j,k,1,ivx) + dtdx*(.25d0/Pi/ScaleGrav*& 03404 (gradphiy_%data(gradphiy_%x(i),j,k,1,1)*.25d0*sum(gradphix_%data((/gradphix_%x(i:i+1)/),j-1:j,k,1,1)))) 03405 f2y_%data(f2y_%x(i),j,k,1,ivz) = f2y_%data(f2y_%x(i),j,k,1,ivz) + dtdx*(.25d0/Pi/ScaleGrav*& 03406 (gradphiy_%data(gradphiy_%x(i),j,k,1,1)*.25d0*sum(gradphiz_%data(gradphiz_%x(i),j-1:j,k:k+1,1,1)))) 03407 END FORALL 03408 END DO 03409 END IF 03410 IF (istime(index, Info%level, f2z, mB)) THEN 03411 DO i=mB(1,1),mB(1,2) 03412 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 03413 f2z_%data(f2z_%x(i),j,k,1,ivz) = f2z_%data(f2z_%x(i),j,k,1,ivz) + dtdx*(.125d0/Pi/ScaleGrav*& 03414 (gradphiz_%data(gradphiz_%x(i),j,k,1,1)**2-(.25d0*sum(gradphix_%data((/gradphix_%x(i:i+1)/),j,k-1:k,1,1)))**2-(.25d0*sum(gradphiy_%data(gradphiy_%x(i),j:j+1,k-1:k,1,1)))**2)+& 03415 half*mean_density*SUM(Info%q(index+i,j,k-1:k,iPhiGas))) 03416 f2z_%data(f2z_%x(i),j,k,1,ivx) = f2z_%data(f2z_%x(i),j,k,1,ivx) + dtdx*(.25d0/Pi/ScaleGrav*& 03417 (gradphiz_%data(gradphiz_%x(i),j,k,1,1)*.25d0*sum(gradphix_%data((/gradphix_%x(i:i+1)/),j,k-1:k,1,1)))) 03418 f2z_%data(f2z_%x(i),j,k,1,ivy) = f2z_%data(f2z_%x(i),j,k,1,ivy) + dtdx*(.25d0/Pi/ScaleGrav*& 03419 (gradphiz_%data(gradphiz_%x(i),j,k,1,1)*.25d0*sum(gradphiy_%data(gradphiy_%x(i),j:j+1,k-1:k,1,1)))) 03420 END FORALL 03421 END DO 03422 END IF 03423 END IF 03424 END IF 03425 END SUBROUTINE update_final_fluxes 03426 03430 SUBROUTINE store_fixup_fluxes(Info, index) 03431 TYPE(InfoDef) :: Info ! Info structure currently updating 03432 INTEGER :: index ! Current row in q being updated 03433 INTEGER :: i,j,k ! Loop counters 03434 INTEGER :: mB(3,2) ! Bounds of slab to update 03435 INTEGER :: mS(3,2) ! Bounds of slab to store fluxes 03436 03437 IF (istime(index, Info%level, f2x, mB)) THEN 03438 ms(1,:)=index+mB(1,:) 03439 mS(2:3,:)=mB(2:3,:) 03440 CALL storefixupfluxes(Info,mS,1,f2x_%data(f2x_%x(mB(1,1):mB(1,2)),:,:,1,:)) 03441 END IF 03442 IF (istime(index, Info%level, f2y, mB)) THEN 03443 ms(1,:)=index+mB(1,:) 03444 mS(2:3,:)=mB(2:3,:) 03445 CALL storefixupfluxes(Info,mS,2,f2y_%data(f2y_%x(mB(1,1):mB(1,2)),:,:,1,:)) 03446 END IF 03447 IF (istime(index, Info%level, f2z, mB)) THEN 03448 ms(1,:)=index+mB(1,:) 03449 mS(2:3,:)=mB(2:3,:) 03450 CALL storefixupfluxes(Info,mS,3,f2z_%data(f2z_%x(mB(1,1):mB(1,2)),:,:,1,:)) 03451 END IF 03452 END SUBROUTINE store_fixup_fluxes 03453 03454 03458 SUBROUTINE updateB_final(Info,index) 03459 TYPE(InfoDef) :: Info ! Info structure currently updating 03460 INTEGER :: index ! Current row in q being updated 03461 INTEGER :: i,j,k ! Loop counters 03462 INTEGER :: mB(3,2), mS(3,2) ! Bounds of slab to update 03463 REAL (kind=qPrec) :: ri, rl,rh 03464 03465 IF (istime(index, Info%level, A3x, mB)) THEN 03466 Info%aux(index+mB(1,1):index+mB(1,2),mB(2,1):mB(2,2),mB(3,1):mB(3,2),1)=& 03467 Info%aux(index+mB(1,1):index+mB(1,2),mB(2,1):mB(2,2),mB(3,1):mB(3,2),1) & 03468 - (e2z_%data(e2z_%x(mB(1,1):mB(1,2)),mB(2,1)+1:mB(2,2)+1,mB(3,1):mB(3,2),1,1) & 03469 - e2z_%data(e2z_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2),mB(3,1):mB(3,2),1,1)) 03470 IF (nDim >= 3) THEN 03471 Info%aux(index+mB(1,1):index+mB(1,2),mB(2,1):mB(2,2),mB(3,1):mB(3,2),1)=& 03472 Info%aux(index+mB(1,1):index+mB(1,2),mB(2,1):mB(2,2),mB(3,1):mB(3,2),1) & 03473 +(e2y_%data(e2y_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2),mB(3,1)+1:mB(3,2)+1,1,1) & 03474 - e2y_%data(e2y_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2),mB(3,1):mB(3,2),1,1)) 03475 END IF 03476 END IF 03477 IF (istime(index, Info%level, A3y, mB)) THEN 03478 IF (iCylindrical==NoCyl) THEN 03479 Info%aux(index+mB(1,1):index+mB(1,2),mB(2,1):mB(2,2),mB(3,1):mB(3,2),2)=& 03480 Info%aux(index+mB(1,1):index+mB(1,2),mB(2,1):mB(2,2),mB(3,1):mB(3,2),2) & 03481 +(e2z_%data(e2z_%x(mB(1,1)+1:mB(1,2)+1),mB(2,1):mB(2,2),mB(3,1):mB(3,2),1,1) & 03482 - e2z_%data(e2z_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2),mB(3,1):mB(3,2),1,1)) 03483 IF (nDim >= 3) THEN 03484 Info%aux(index+mB(1,1):index+mB(1,2),mB(2,1):mB(2,2),mB(3,1):mB(3,2),2)=& 03485 Info%aux(index+mB(1,1):index+mB(1,2),mB(2,1):mB(2,2),mB(3,1):mB(3,2),2) & 03486 -(e2x_%data(e2x_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2),mB(3,1)+1:mB(3,2)+1,1,1) & 03487 - e2x_%data(e2x_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2),mB(3,1):mB(3,2),1,1)) 03488 END IF 03489 ELSE 03490 DO i=mB(1,1), mB(1,2) 03491 ri=1.d0/(Info%xBounds(1,1)+(REAL(index+i)-half)*dx) 03492 rl=(Info%xBounds(1,1)+(index+i-1)*dx) 03493 rh=(Info%xBounds(1,1)+(index+i)*dx) 03494 Info%aux(index+i,mB(2,1):mB(2,2),mB(3,1):mB(3,2),2)=& 03495 Info%aux(index+i,mB(2,1):mB(2,2),mB(3,1):mB(3,2),2) & 03496 + ri*(rh*e2z_%data(e2z_%x(i+1),mB(2,1):mB(2,2),mB(3,1):mB(3,2),1,1) & 03497 - rl*e2z_%data(e2z_%x(i),mB(2,1):mB(2,2),mB(3,1):mB(3,2),1,1)) 03498 END DO 03499 END IF 03500 END IF 03501 IF (istime(index, Info%level, A3z, mB)) THEN 03502 Info%aux(index+mB(1,1):index+mB(1,2),mB(2,1):mB(2,2),mB(3,1):mB(3,2),3) = & 03503 Info%aux(index+mB(1,1):index+mB(1,2),mB(2,1):mB(2,2),mB(3,1):mB(3,2),3) & 03504 +(e2x_%data(e2x_%x(mB(1,1):mB(1,2)),mB(2,1)+1:mB(2,2)+1,mB(3,1):mB(3,2),1,1) & 03505 - e2x_%data(e2x_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2),mB(3,1):mB(3,2),1,1)) & 03506 -(e2y_%data(e2y_%x(mB(1,1)+1:mB(1,2)+1),mB(2,1):mB(2,2),mB(3,1):mB(3,2),1,1) & 03507 - e2y_%data(e2y_%x(mB(1,1):mB(1,2)),mB(2,1):mB(2,2),mB(3,1):mB(3,2),1,1)) 03508 END IF 03509 03510 END SUBROUTINE updateB_final 03511 03512 03516 SUBROUTINE update_final(Info,index) 03517 TYPE(InfoDef) :: Info ! Info structure currently updating 03518 INTEGER :: index ! Current row in q being updated 03519 INTEGER :: i,j,k ! Loop counters 03520 INTEGER :: mB(3,2), mS(3,2) ! Bounds of slab to update 03521 INTEGER :: m 03522 IF (istime(index, Info%level, w3, mB)) THEN 03523 DO i=mB(1,1),mB(1,2) 03524 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2), m=1:nFlux) 03525 Info%q(index+i,j,k,FluxFields(m))=Info%q(index+i,j,k,FluxFields(m))+& 03526 (f2x_%data(f2x_%x(i),j,k,1,FluxFields(m))-f2x_%data(f2x_%x(i+1),j,k,1,FluxFields(m))) 03527 END FORALL 03528 IF (MaintainAuxArrays) Info%q(index+i,mB(2,1):mB(2,2),mB(3,1):mB(3,2),iBx) = & 03529 half*(Info%aux(index+i,mB(2,1):mB(2,2),mB(3,1):mB(3,2), 1) + & 03530 Info%aux(index+i+1,mB(2,1):mB(2,2),mB(3,1):mB(3,2), 1)) 03531 IF (nDim >= 2) THEN 03532 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2), m=1:nFlux) 03533 Info%q(index+i,j,k,FluxFields(m))=Info%q(index+i,j,k,FluxFields(m))+& 03534 (f2y_%data(f2y_%x(i),j,k,1,FluxFields(m))-f2y_%data(f2y_%x(i),j+1,k,1,FluxFields(m))) 03535 END FORALL 03536 IF (MaintainAuxArrays) Info%q(index+i,mB(2,1):mB(2,2),mB(3,1):mB(3,2),iBy) = & 03537 half*(Info%aux(index+i,mB(2,1):mB(2,2),mB(3,1):mB(3,2), 2) + & 03538 Info%aux(index+i,mB(2,1)+1:mB(2,2)+1,mB(3,1):mB(3,2), 2)) 03539 IF (nDim >= 3) THEN 03540 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2), m=1:nFlux) 03541 Info%q(index+i,j,k,FluxFields(m))=Info%q(index+i,j,k,FluxFields(m))+& 03542 (f2z_%data(f2z_%x(i),j,k,1,FluxFields(m))-f2z_%data(f2z_%x(i),j,k+1,1,FluxFields(m))) 03543 END FORALL 03544 IF (MaintainAuxArrays) Info%q(index+i,mB(2,1):mB(2,2),mB(3,1):mB(3,2),iBz) = & 03545 half*(Info%aux(index+i,mB(2,1):mB(2,2),mB(3,1):mB(3,2), 3) + & 03546 Info%aux(index+i,mB(2,1):mB(2,2),mB(3,1)+1:mB(3,2)+1, 3)) 03547 END IF 03548 END IF 03549 IF (lSelfGravity .AND. iE /= 0) THEN 03550 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 03551 Info%q(index+i,j,k,iE)=Info%q(index+i,j,k,iE)-half*( & 03552 f2x_%data(f2x_%x(i),j,k,1,1)*(Info%q(index+i,j,k,iPhiGas)-Info%q(index+i-1,j,k,iPhiGas)) + & 03553 f2x_%data(f2x_%x(i+1),j,k,1,1)*(Info%q(index+i+1,j,k,iPhiGas)-Info%q(index+i,j,k,iPhiGas))) 03554 END FORALL 03555 IF (nDim >= 2) THEN 03556 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 03557 Info%q(index+i,j,k,iE)=Info%q(index+i,j,k,iE)-half*( & 03558 f2y_%data(f2y_%x(i),j,k,1,1)*(Info%q(index+i,j,k,iPhiGas)-Info%q(index+i,j-1,k,iPhiGas)) + & 03559 f2y_%data(f2y_%x(i),j+1,k,1,1)*(Info%q(index+i,j+1,k,iPhiGas)-Info%q(index+i,j,k,iPhiGas))) 03560 END FORALL 03561 IF (nDim == 3) THEN 03562 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2)) 03563 Info%q(index+i,j,k,iE)=Info%q(index+i,j,k,iE)-half*( & 03564 f2z_%data(f2z_%x(i),j,k,1,1)*(Info%q(index+i,j,k,iPhiGas)-Info%q(index+i,j,k-1,iPhiGas)) + & 03565 f2z_%data(f2z_%x(i),j,k+1,1,1)*(Info%q(index+i,j,k+1,iPhiGas)-Info%q(index+i,j,k,iPhiGas))) 03566 END FORALL 03567 END IF 03568 END IF 03569 END IF 03570 END DO 03571 END IF 03572 END SUBROUTINE update_final 03573 03577 SUBROUTINE update_final_noctu(Info,index) 03578 TYPE(InfoDef) :: Info ! Info structure currently updating 03579 INTEGER :: index ! Current row in q being updated 03580 INTEGER :: i,j,k ! Loop counters 03581 INTEGER :: mB(3,2) ! Bounds of slab to update 03582 INTEGER :: m 03583 IF (istime(index, Info%level, w3, mB)) THEN 03584 03585 DO i=mB(1,1),mB(1,2) 03586 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2),m=1:nSweepFlux) 03587 Info%q(index+i,j,k,SweepFluxFields(m))=Info%q(index+i,j,k,SweepFluxFields(m))+2d0*(fx_%data(fx_%x(i),j,k,1,SweepFluxFields(m)) - & 03588 fx_%data(fx_%x(i+1),j,k,1,SweepFluxFields(m))) 03589 END FORALL 03590 END DO 03591 ! write(*,*) 'updating Info%q', index+i,mB(2:3,1:2), SweepFluxFields, nSweepFlux 03592 ! write(*,*) fx_%data(fx_%x(i),1,1,1,1) 03593 IF (nDim >= 2) THEN 03594 DO i=mB(1,1),mB(1,2) 03595 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2),m=1:nSweepFlux) 03596 Info%q(index+i,j,k,SweepFluxFields(m))=Info%q(index+i,j,k,SweepFluxFields(m))+2d0*(fy_%data(fy_%x(i),j,k,1,SweepFluxFields(m)) - & 03597 fy_%data(fy_%x(i),j+1,k,1,SweepFluxFields(m))) 03598 END FORALL 03599 END DO 03600 IF (nDim >= 3) THEN 03601 DO i=mB(1,1),mB(1,2) 03602 FORALL(j=mB(2,1):mB(2,2),k=mB(3,1):mB(3,2),m=1:nSweepFlux) 03603 Info%q(index+i,j,k,SweepFluxFields(m))=Info%q(index+i,j,k,SweepFluxFields(m))+2d0*(fz_%data(fz_%x(i),j,k,1,SweepFluxFields(m)) - & 03604 fz_%data(fz_%x(i),j,k+1,1,SweepFluxFields(m))) 03605 END FORALL 03606 END DO 03607 END IF 03608 END IF 03609 END IF 03610 END SUBROUTINE update_final_noctu 03611 03612 03619 real(Kind=qPrec) pure FUNCTION upwinded_emf(ez_fy, ez_fx, ez_c, vx, vy) 03620 !ez^c method of Gardiner and Stone 03621 !ez_fy is the z component of the emf at the y cell faces 03622 !ez_fx is the z component of the emf at the x cell faces 03623 !ez_c is a two by two array of the emf at the cell centers 03624 !vx and vy are the mass flux across the x and y boundaries. 03625 !REAL(KIND=qPrec) :: upwinded_emf 03626 REAL(KIND=qPrec), DIMENSION(2), INTENT(IN) :: ez_fy, ez_fx, vx, vy 03627 REAL(KIND=qPrec), DIMENSION(2,2), INTENT(IN):: ez_c 03628 REAL(KIND=qPrec), DIMENSION(2) :: dezdx,dezdy 03629 03630 IF (vy(1) > 0) THEN 03631 dezdx(1) = ez_fx(1)-ez_c(1,1) 03632 ELSE IF (vy(1) < 0) THEN 03633 dezdx(1) = ez_fx(2)-ez_c(1,2) 03634 ELSE 03635 dezdx(1) = half*(sum(ez_fx(:))-sum(ez_c(1,:))) 03636 END IF 03637 03638 IF (vy(2) > 0) THEN 03639 dezdx(2) = ez_c(2,1)-ez_fx(1) 03640 ELSE IF (vy(2) < 0) THEN 03641 dezdx(2) = ez_c(2,2)-ez_fx(2) 03642 ELSE 03643 dezdx(2) = half*(sum(ez_c(2,:))-sum(ez_fx(:))) 03644 END IF 03645 03646 IF (vx(1) > 0) THEN 03647 dezdy(1) = ez_fy(1)-ez_c(1,1) 03648 ELSE IF (vx(1) < 0) THEN 03649 dezdy(1) = ez_fy(2)-ez_c(2,1) 03650 ELSE 03651 dezdy(1) = half*(sum(ez_fy(:))-sum(ez_c(:,1))) 03652 END IF 03653 03654 IF (vx(2) > 0) THEN 03655 dezdy(2) = ez_c(1,2)-ez_fy(1) 03656 ELSE IF (vx(2) < 0) THEN 03657 dezdy(2) = ez_c(2,2)-ez_fy(2) 03658 ELSE 03659 dezdy(2) = half*(sum(ez_c(:,2))-sum(ez_fy(:))) 03660 END IF 03661 03662 upwinded_emf=fourth*(SUM(ez_fx(1:2))+SUM(ez_fy(1:2)) + (dezdx(1)-dezdx(2))+(dezdy(1)-dezdy(2))) 03663 ! upwinded_emf=fourth*(SUM(ez_c)) 03664 ! write(*,'(A,10E36.28)') 'dezdx=', dezdx 03665 ! write(*,'(A,10E36.28)') 'dezdy=', dezdy 03666 ! write(*,'(A,10E36.28)') 'ez_fx=', ez_fx 03667 ! write(*,'(A,10E36.28)') 'ez_fy=', ez_fy 03668 ! write(*,'(A,10E36.28)') 'upwinded_emf=', upwinded_emf 03669 ! write(*,'(A,10E36.28)') 'ez_c', ez_c 03670 END FUNCTION upwinded_emf 03671 03672 03673 03674 03675 SUBROUTINE LoadLevelStencilBuffers(n) 03676 INTEGER :: n 03677 CurrentLevelLoaded=n 03678 IF (w /= 0) w_ => LevelBuffers(n)%StencilBuffer(w) 03679 IF (qLx /= 0) qLx_ => LevelBuffers(n)%StencilBuffer(qLx) 03680 IF (qRx /= 0) qRx_ => LevelBuffers(n)%StencilBuffer(qRx) 03681 IF (qLy /= 0) qLy_ => LevelBuffers(n)%StencilBuffer(qLy) 03682 IF (qRy /= 0) qRy_ => LevelBuffers(n)%StencilBuffer(qRy) 03683 IF (qLz /= 0) qLz_ => LevelBuffers(n)%StencilBuffer(qLz) 03684 IF (qRz /= 0) qRz_ => LevelBuffers(n)%StencilBuffer(qRz) 03685 IF (fx /= 0) fx_ => LevelBuffers(n)%StencilBuffer(fx) 03686 IF (fy /= 0) fy_ => LevelBuffers(n)%StencilBuffer(fy) 03687 IF (fz /= 0) fz_ => LevelBuffers(n)%StencilBuffer(fz) 03688 IF (q2Lx /= 0) q2Lx_ => LevelBuffers(n)%StencilBuffer(q2Lx) 03689 IF (q2Rx /= 0) q2Rx_ => LevelBuffers(n)%StencilBuffer(q2Rx) 03690 IF (q2Ly /= 0) q2Ly_ => LevelBuffers(n)%StencilBuffer(q2Ly) 03691 IF (q2Ry /= 0) q2Ry_ => LevelBuffers(n)%StencilBuffer(q2Ry) 03692 IF (q2Lz /= 0) q2Lz_ => LevelBuffers(n)%StencilBuffer(q2Lz) 03693 IF (q2Rz /= 0) q2Rz_ => LevelBuffers(n)%StencilBuffer(q2Rz) 03694 IF (f2x /= 0) f2x_ => LevelBuffers(n)%StencilBuffer(f2x) 03695 IF (f2y /= 0) f2y_ => LevelBuffers(n)%StencilBuffer(f2y) 03696 IF (f2z /= 0) f2z_ => LevelBuffers(n)%StencilBuffer(f2z) 03697 IF (limiter_x /= 0) limiter_x_ => LevelBuffers(n)%StencilBuffer(limiter_x) 03698 IF (limiter_y /= 0) limiter_y_ => LevelBuffers(n)%StencilBuffer(limiter_y) 03699 IF (limiter_z /= 0) limiter_z_ => LevelBuffers(n)%StencilBuffer(limiter_z) 03700 IF (limiter_ppm /= 0) limiter_ppm_ => LevelBuffers(n)%StencilBuffer(limiter_ppm) 03701 IF (pT /= 0) pT_ => LevelBuffers(n)%StencilBuffer(pT) 03702 IF (qex /= 0) qex_ => LevelBuffers(n)%StencilBuffer(qex) 03703 IF (qey /= 0) qey_ => LevelBuffers(n)%StencilBuffer(qey) 03704 IF (qez /= 0) qez_ => LevelBuffers(n)%StencilBuffer(qez) 03705 IF (dqx /= 0) dqx_ => LevelBuffers(n)%StencilBuffer(dqx) 03706 IF (dqy /= 0) dqy_ => LevelBuffers(n)%StencilBuffer(dqy) 03707 IF (dqz /= 0) dqz_ => LevelBuffers(n)%StencilBuffer(dqz) 03708 IF (ex /= 0) ex_ => LevelBuffers(n)%StencilBuffer(ex) 03709 IF (ey /= 0) ey_ => LevelBuffers(n)%StencilBuffer(ey) 03710 IF (ez /= 0) ez_ => LevelBuffers(n)%StencilBuffer(ez) 03711 IF (ex_bar /= 0) ex_bar_ => LevelBuffers(n)%StencilBuffer(ex_bar) 03712 IF (ey_bar /= 0) ey_bar_ => LevelBuffers(n)%StencilBuffer(ey_bar) 03713 IF (ez_bar /= 0) ez_bar_ => LevelBuffers(n)%StencilBuffer(ez_bar) 03714 IF (e2x /= 0) e2x_ => LevelBuffers(n)%StencilBuffer(e2x) 03715 IF (e2y /= 0) e2y_ => LevelBuffers(n)%StencilBuffer(e2y) 03716 IF (e2z /= 0) e2z_ => LevelBuffers(n)%StencilBuffer(e2z) 03717 IF (e2x_bar /= 0) e2x_bar_ => LevelBuffers(n)%StencilBuffer(e2x_bar) 03718 IF (e2y_bar /= 0) e2y_bar_ => LevelBuffers(n)%StencilBuffer(e2y_bar) 03719 IF (e2z_bar /= 0) e2z_bar_ => LevelBuffers(n)%StencilBuffer(e2z_bar) 03720 IF (ctfy /= 0) ctfy_ => LevelBuffers(n)%StencilBuffer(ctfy) 03721 IF (ctfz /= 0) ctfz_ => LevelBuffers(n)%StencilBuffer(ctfz) 03722 IF (ctfx /= 0) ctfx_ => LevelBuffers(n)%StencilBuffer(ctfx) 03723 IF (ctf2x /= 0) ctf2x_ => LevelBuffers(n)%StencilBuffer(ctf2x) 03724 IF (ctf2y /= 0) ctf2y_ => LevelBuffers(n)%StencilBuffer(ctf2y) 03725 IF (ctf2z /= 0) ctf2z_ => LevelBuffers(n)%StencilBuffer(ctf2z) 03726 IF (w2 /= 0) w2_ => LevelBuffers(n)%StencilBuffer(w2) 03727 IF (A2x /= 0) A2x_ => LevelBuffers(n)%StencilBuffer(A2x) 03728 IF (A2y /= 0) A2y_ => LevelBuffers(n)%StencilBuffer(A2y) 03729 IF (A2z /= 0) A2z_ => LevelBuffers(n)%StencilBuffer(A2z) 03730 IF (Sx /= 0) Sx_ => LevelBuffers(n)%StencilBuffer(Sx) 03731 IF (Sy /= 0) Sy_ => LevelBuffers(n)%StencilBuffer(Sy) 03732 IF (Sz /= 0) Sz_ => LevelBuffers(n)%StencilBuffer(Sz) 03733 IF (w3 /= 0) w3_ => LevelBuffers(n)%StencilBuffer(w3) 03734 IF (A3x /= 0) A3x_ => LevelBuffers(n)%StencilBuffer(A3x) 03735 IF (A3y /= 0) A3y_ => LevelBuffers(n)%StencilBuffer(A3y) 03736 IF (A3z /= 0) A3z_ => LevelBuffers(n)%StencilBuffer(A3z) 03737 IF (SpeedsX /= 0) SpeedsX_ => LevelBuffers(n)%StencilBuffer(SpeedsX) 03738 IF (SpeedsY /= 0) SpeedsY_ => LevelBuffers(n)%StencilBuffer(SpeedsY) 03739 IF (SpeedsZ /= 0) SpeedsZ_ => LevelBuffers(n)%StencilBuffer(SpeedsZ) 03740 IF (leftX /= 0) leftX_ => LevelBuffers(n)%StencilBuffer(leftX) 03741 IF (leftY /= 0) leftY_ => LevelBuffers(n)%StencilBuffer(leftY) 03742 IF (leftZ /= 0) leftZ_ => LevelBuffers(n)%StencilBuffer(leftZ) 03743 IF (rightX /= 0) rightX_ => LevelBuffers(n)%StencilBuffer(rightX) 03744 IF (rightY /= 0) rightY_ => LevelBuffers(n)%StencilBuffer(rightY) 03745 IF (rightZ /= 0) rightZ_ => LevelBuffers(n)%StencilBuffer(rightZ) 03746 IF (nWaves /= 0) nWaves_ => LevelBuffers(n)%StencilBuffer(nWaves) 03747 IF (req_eigens /= 0) req_eigens_ => LevelBuffers(n)%StencilBuffer(req_eigens) 03748 IF (adfx /= 0) adfx_ => LevelBuffers(n)%StencilBuffer(adfx) 03749 IF (adfy /= 0) adfy_ => LevelBuffers(n)%StencilBuffer(adfy) 03750 IF (adfz /= 0) adfz_ => LevelBuffers(n)%StencilBuffer(adfz) 03751 IF (eta2x /= 0) eta2x_ => LevelBuffers(n)%StencilBuffer(eta2x) 03752 IF (eta2y /= 0) eta2y_ => LevelBuffers(n)%StencilBuffer(eta2y) 03753 IF (eta2z /= 0) eta2z_ => LevelBuffers(n)%StencilBuffer(eta2z) 03754 IF (etax /= 0) etax_ => LevelBuffers(n)%StencilBuffer(etax) 03755 IF (etay /= 0) etay_ => LevelBuffers(n)%StencilBuffer(etay) 03756 IF (etaz /= 0) etaz_ => LevelBuffers(n)%StencilBuffer(etaz) 03757 IF (q /= 0) q_ => LevelBuffers(n)%StencilBuffer(q) 03758 IF (aux /= 0) aux_ => LevelBuffers(n)%StencilBuffer(aux) 03759 IF (recon /= 0) recon_ => LevelBuffers(n)%StencilBuffer(recon) 03760 IF (beforesweepstep /= 0) beforesweepstep_ => LevelBuffers(n)%StencilBuffer(beforesweepstep) 03761 IF (aftersweepstep /= 0) aftersweepstep_ => LevelBuffers(n)%StencilBuffer(aftersweepstep) 03762 IF (source /= 0) source_ => LevelBuffers(n)%StencilBuffer(source) 03763 IF (source2 /= 0) source2_ => LevelBuffers(n)%StencilBuffer(source2) 03764 IF (cornerdiv /= 0) cornerdiv_ => LevelBuffers(n)%StencilBuffer(cornerdiv) 03765 IF (gradphix /= 0) gradphix_ => LevelBuffers(n)%StencilBuffer(gradphix) 03766 IF (gradphiy /= 0) gradphiy_ => LevelBuffers(n)%StencilBuffer(gradphiy) 03767 IF (gradphiz /= 0) gradphiz_ => LevelBuffers(n)%StencilBuffer(gradphiz) 03768 ! write(*,*) 'loaded level stencil buffers for level', n 03769 END SUBROUTINE LoadLevelStencilBuffers 03770 03771 END SUBROUTINE sweepAdvance 03772 03773 03774 03777 SUBROUTINE cons_to_prim_1(q) 03778 REAL(KIND=qPrec), DIMENSION(:,:,:), INTENT(INOUT) :: q 03779 INTEGER :: j,k 03780 REAL(KIND=qPrec), DIMENSION(:), ALLOCATABLE :: v 03781 IF (lMHD) THEN 03782 ALLOCATE(v(3)) 03783 DO j=lbound(q,1),ubound(q,1) 03784 DO k=lbound(q,2),ubound(q,2) 03785 v(1:3)=q(j,k,ivx:ivz)/q(j,k,1) 03786 IF (iE .ne. 0) q(j,k,iE)=gamma1*(q(j,k,iE)-half*(DOT_PRODUCT(q(j,k,ivx:ivz),v(1:3)) + & 03787 DOT_PRODUCT(q(j,k,iBx:iBz),q(j,k,iBx:iBz)))) 03788 q(j,k,ivx:ivz)=v(1:3) 03789 END DO 03790 END DO 03791 ELSE 03792 ALLOCATE(v(1:m_high-m_low+1)) 03793 DO j=lbound(q,1),ubound(q,1) 03794 DO k=lbound(q,2),ubound(q,2) 03795 v=q(j,k,m_low:m_high)/q(j,k,1) 03796 IF (iE .ne. 0) q(j,k,iE)=gamma1*(q(j,k,iE)-half*(DOT_PRODUCT(q(j,k,m_low:m_high),v))) 03797 q(j,k,m_low:m_high)=v 03798 END DO 03799 END DO 03800 END IF 03801 DEALLOCATE(v) 03802 END SUBROUTINE cons_to_prim_1 03803 03804 03807 SUBROUTINE cons_to_prim_2(q,w) 03808 REAL(KIND=qPrec), DIMENSION(:,:,:), INTENT(IN) :: q 03809 REAL(KIND=qPrec), DIMENSION(:,:,:), INTENT(OUT) :: w 03810 INTEGER :: j,k 03811 w=q 03812 IF (lMHD) THEN 03813 DO j=lbound(q,1),ubound(q,1) 03814 DO k=lbound(q,2),ubound(q,2) 03815 w(j,k,m_low:ivz)=q(j,k,m_low:ivz)/q(j,k,1) 03816 IF (iE .ne. 0) w(j,k,iE)=gamma1*(q(j,k,iE)-half*(DOT_PRODUCT(q(j,k,m_low:ivz),w(j,k,m_low:ivz)) + & 03817 DOT_PRODUCT(q(j,k,iBx:iBz),q(j,k,iBx:iBz)))) 03818 END DO 03819 END DO 03820 ELSE 03821 DO j=lbound(q,1),ubound(q,1) 03822 DO k=lbound(q,2),ubound(q,2) 03823 w(j,k,m_low:m_high)=q(j,k,m_low:m_high)/q(j,k,1) 03824 IF (iE .ne. 0) w(j,k,iE)=gamma1*(q(j,k,iE)-half*(DOT_PRODUCT(q(j,k,m_low:m_high),w(j,k,m_low:m_high)))) 03825 END DO 03826 END DO 03827 END IF 03828 END SUBROUTINE cons_to_prim_2 03829 03830 03833 SUBROUTINE prim_to_cons_1(q) 03834 REAL(KIND=qPrec), DIMENSION(:,:,:), INTENT(INOUT) :: q 03835 INTEGER :: j,k 03836 REAL(KIND=qPrec), DIMENSION(:), ALLOCATABLE :: v 03837 IF (lMHD) THEN 03838 ALLOCATE(v(3)) 03839 DO j=lbound(q,1),ubound(q,1) 03840 DO k=lbound(q,2),ubound(q,2) 03841 v(1:3)=q(j,k,ivx:ivz)*q(j,k,1) 03842 IF (iE .ne. 0) q(j,k,iE)=gamma7*q(j,k,iE)+half*(DOT_PRODUCT(q(j,k,ivx:ivz),v(1:3)) + & 03843 DOT_PRODUCT(q(j,k,iBx:iBz),q(j,k,iBx:iBz))) 03844 q(j,k,ivx:ivz)=v(1:3) 03845 END DO 03846 END DO 03847 ELSE 03848 ALLOCATE(v(1:m_high-m_low+1)) 03849 DO j=lbound(q,1),ubound(q,1) 03850 DO k=lbound(q,2),ubound(q,2) 03851 v=q(j,k,m_low:m_high)*q(j,k,1) 03852 IF (iE .ne. 0) q(j,k,iE)=gamma7*q(j,k,iE)+half*(DOT_PRODUCT(q(j,k,m_low:m_high),v)) 03853 q(j,k,m_low:m_high)=v 03854 END DO 03855 END DO 03856 END IF 03857 DEALLOCATE(v) 03858 END SUBROUTINE prim_to_cons_1 03859 03860 03864 SUBROUTINE prim_to_cons_2(w,q) 03865 REAL(KIND=qPrec), DIMENSION(:,:,:), INTENT(IN) :: w 03866 REAL(KIND=qPrec), DIMENSION(:,:,:), INTENT(OUT) :: q 03867 INTEGER :: j,k 03868 q=w 03869 IF (lMHD) THEN 03870 DO j=lbound(q,1),ubound(q,1) 03871 DO k=lbound(q,2),ubound(q,2) 03872 q(j,k,m_low:ivz)=w(j,k,m_low:ivz)*w(j,k,1) 03873 IF (iE .ne. 0) q(j,k,iE)=gamma7*w(j,k,iE)+half*(DOT_PRODUCT(q(j,k,m_low:ivz),w(j,k,m_low:ivz)) + & 03874 DOT_PRODUCT(w(j,k,iBx:iBz),w(j,k,iBx:iBz))) 03875 END DO 03876 END DO 03877 ELSE 03878 DO j=lbound(q,1),ubound(q,1) 03879 DO k=lbound(q,2),ubound(q,2) 03880 q(j,k,m_low:m_high)=w(j,k,m_low:m_high)*w(j,k,1) 03881 IF (iE .ne. 0) q(j,k,iE)=gamma7*w(j,k,iE)+half*(DOT_PRODUCT(q(j,k,m_low:m_high),w(j,k,m_low:m_high))) 03882 END DO 03883 END DO 03884 END IF 03885 END SUBROUTINE prim_to_cons_2 03886 03892 FUNCTION calc_flux_x(left,right,flux, lambda_max) 03893 REAL(KIND=qPREC) :: calc_flux_x 03894 REAL(KIND=qPREC), DIMENSION(:) :: left, right 03895 REAL(KIND=qPREC), DIMENSION(:), INTENT(INOUT) :: flux 03896 REAL(KIND=qPREC), DIMENSION(:), ALLOCATABLE :: tempflux 03897 REAL(KIND=qPREC), OPTIONAL :: lambda_max 03898 ALLOCATE(tempflux(size(flux,1))) 03899 IF (present(lambda_max)) THEN 03900 calc_flux_x=calc_flux(left(wDx_i),right(wDx_i),tempflux, lambda_max) 03901 ELSE 03902 calc_flux_x=calc_flux(left(wDx_i),right(wDx_i),tempflux) 03903 END IF 03904 flux(:)=tempflux(fDx_i) 03905 DEALLOCATE(tempflux) 03906 END FUNCTION calc_flux_x 03907 03913 FUNCTION calc_flux_y(left,right,flux,lambda_max) 03914 REAL(KIND=qPREC) :: calc_flux_y 03915 REAL(KIND=qPREC), DIMENSION(:), INTENT(IN) :: left, right 03916 REAL(KIND=qPREC), DIMENSION(:), INTENT(OUT) :: flux 03917 REAL(KIND=qPREC), DIMENSION(:), ALLOCATABLE :: tempflux 03918 REAL(KIND=qPREC), OPTIONAL :: lambda_max 03919 ALLOCATE(tempflux(size(flux,1))) 03920 IF (present(lambda_max)) THEN 03921 calc_flux_y= calc_flux(left(wDy_i),right(wDy_i),tempflux,lambda_max) 03922 ELSE 03923 !print*,'18mar2011';stop 03924 calc_flux_y= calc_flux(left(wDy_i),right(wDy_i),tempflux) 03925 END IF 03926 flux(:)=tempflux(fDy_i) 03927 DEALLOCATE(tempflux) 03928 END FUNCTION calc_flux_y 03929 03930 03936 FUNCTION calc_flux_z(left,right,flux,lambda_max) 03937 REAL(KIND=qPREC) :: calc_flux_z 03938 REAL(KIND=qPREC), DIMENSION(:), INTENT(IN) :: left, right 03939 REAL(KIND=qPREC), DIMENSION(:), INTENT(OUT) :: flux 03940 REAL(KIND=qPREC), DIMENSION(:), ALLOCATABLE :: tempflux 03941 REAL(KIND=qPREC), OPTIONAL :: lambda_max 03942 ALLOCATE(tempflux(size(flux,1))) 03943 IF (present(lambda_max)) THEN 03944 calc_flux_z= calc_flux(left(wDz_i),right(wDz_i),tempflux,lambda_max) 03945 ELSE 03946 calc_flux_z= calc_flux(left(wDz_i),right(wDz_i),tempflux) 03947 END IF 03948 flux(:)=tempflux(fDz_i) 03949 DEALLOCATE(tempflux) 03950 END FUNCTION calc_flux_z 03951 03952 03956 pure REAL(KIND=qPREC) function minmod(x,y) 03957 REAL(KIND=qPREC), INTENT(IN) :: x,y 03958 if ((x <= 0 .AND. y >= 0) .OR. (x >= 0 .AND. y <= 0)) THEN 03959 minmod=0 03960 else 03961 minmod=sign(min(abs(x),abs(y)),x) 03962 end if 03963 end function minmod 03964 03967 SUBROUTINE protect(w) 03968 REAL(KIND=qPrec), DIMENSION(:), INTENT(INOUT) :: w 03969 REAL(KIND=qPrec) :: my_TolDens, BE 03970 IF (lMHD) THEN 03971 BE=half*(DOT_PRODUCT(w(iBx:iBz),w(iBx:iBz))) 03972 ELSE 03973 BE=0d0 03974 END IF 03975 my_TolDens=MinDensity 03976 IF (w(1) < my_TolDens) THEN 03977 w(1)=my_TolDens 03978 IF (.NOT. lIsothermal) w(iE)=Iso_Speed2*w(1) 03979 w(m_low:m_high)=0d0 03980 ELSE IF (.NOT. lIsothermal) THEN 03981 w(iE)=MAX(w(iE),Iso_Speed2*w(1)) 03982 END IF 03983 END SUBROUTINE protect 03984 03987 SUBROUTINE protect_all(w) 03988 REAL(KIND=qPrec), DIMENSION(:,:,:), INTENT(INOUT) :: w 03989 REAL(KIND=qPrec) :: BE, my_TolDens 03990 INTEGER :: j,k 03991 DO j=lbound(w,1), ubound(w,1) 03992 DO k=lbound(w,2), ubound(w,2) 03993 ! IF (lMHD) THEN 03994 ! BE=half*(DOT_PRODUCT(w(j,k,iBx:iBz),w(j,k,iBx:iBz))) 03995 ! ELSE 03996 ! BE=0d0 03997 ! END IF 03998 my_TolDens=MinDensity 03999 IF (w(j,k,1) < my_TolDens) THEN 04000 w(j,k,1)=my_TolDens 04001 w(j,k,m_low:m_high)=0d0 04002 IF (iE .ne. 0) w(j,k,iE)=Iso_Speed2*w(j,k,1) 04003 ELSE IF (.NOT. lIsothermal) THEN 04004 w(j,k,iE)=MAX(w(j,k,iE), Iso_Speed2*w(j,k,1)) 04005 END IF 04006 END DO 04007 END DO 04008 END SUBROUTINE protect_all 04009 04010 04013 SUBROUTINE Randomize(q) 04014 REAL(KIND=qPREC), DIMENSION(:,:,:) :: q 04015 INTEGER :: i,j,k 04016 REAL(KIND=qPREC) :: rand 04017 DO i=1,size(q,1) 04018 DO j=1,size(q,2) 04019 DO k=1,size(q,3) 04020 CALL Random_number(rand) 04021 q(i,j,k)=.001*real(i) !q(i,j,k)*(1d0+(.001)*(REAL(i)))!rand*1e-2) 04022 ! q(i,j,1)=q(i,j,1)*(1d0+.01*REAL(level)/(levels(level)%dt/levels(level)%dx)) !(.001)*(REAL(i+j+k)))!rand*1e-2) 04023 END DO 04024 END DO 04025 END DO 04026 END SUBROUTINE Randomize 04027 04028 04029 ! INCLUDE 'sweep_scheme_.f90' 04030 ! INCLUDE 'i_dependencies.f90' 04031 04032 END MODULE SweepScheme 04033