Scrambler  1
sweep_scheme.f90
Go to the documentation of this file.
00001 !#########################################################################
00002 !               
00003 !    Copyright (C) 2003-2012 Department of Physics and Astronomy,
00004 !                            University of Rochester,
00005 !                            Rochester, NY
00006 !
00007 !    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 
 All Classes Files Functions Variables